Remove PTup and STup verbosity from BackendK3

diff --git a/src/Dyna/BackendK3/AST.hs b/src/Dyna/BackendK3/AST.hs
index c85bebfe9a8c8abf849b7b06e0e4092b00fffc8d..e6620e1e65c01d93404f8b26b5c17de914179eae 100644 (file)
--- a/src/Dyna/BackendK3/AST.hs
+++ b/src/Dyna/BackendK3/AST.hs
@@ -205,7 +205,7 @@ data PKind where
 --
 class (UnPatDa (PatDa w) ~ w) => Pat (w :: PKind) where
   -- | Any data this witness needs to carry around
-  data PatDa w :: *
+  type PatDa w :: *
   -- | The type this witness witnesses (i.e. the things matched against)
   type PatTy w :: *
   -- | The type this witness binds (i.e. after matching is done)
@@ -214,22 +214,27 @@ class (UnPatDa (PatDa w) ~ w) => Pat (w :: PKind) where
   type PatReprFn (r :: * -> *) w :: *
 
 type family UnPatDa (pd :: *) :: PKind
-type instance UnPatDa (PatDa w) = w
 
+data PVar a = PVar (UnivTyRepr a)
+type instance UnPatDa (PVar a) = PKVar a
 instance (K3BaseTy a) => Pat (PKVar (a :: *)) where
-  data PatDa     (PKVar a)   = PVar { unPVar :: UnivTyRepr a }
+  type PatDa     (PKVar a)   = PVar a
   type PatTy     (PKVar a)   =   a
   type PatBTy    (PKVar a)   =   a
   type PatReprFn r (PKVar a) = r a
 
+data PUnk a = PUnk
+type instance UnPatDa (PUnk a)       = PKUnk a
 instance (K3BaseTy a) => Pat (PKUnk (a :: *)) where
-  data PatDa     (PKUnk a)   = PUnk
+  type PatDa     (PKUnk a)   = PUnk a
   type PatTy     (PKUnk a)   =   a
   type PatBTy    (PKUnk a)   =   ()
   type PatReprFn r (PKUnk a) = r ()
 
+data PJust a = PJust { unPJust :: a }
+type instance UnPatDa (PJust a)      = PKJust (UnPatDa a)
 instance (Pat w) => Pat (PKJust w) where
-  data PatDa (PKJust w)       = PJust (PatDa w)
+  type PatDa (PKJust w)       = PJust (PatDa w)
   type PatTy (PKJust w)       = Maybe (PatTy w)
   type PatBTy (PKJust w)      = PatBTy w
   type PatReprFn r (PKJust w) = PatReprFn r w
@@ -238,7 +243,7 @@ type family MapPatDa (x :: [PKind]) :: *
 $(mkTyMapFlat 0 ''MapPatDa ''PatDa)
 
 type family UnMapPatDa (x :: *) :: [PKind]
-$(mkTyUnMap 0 ''UnMapPatDa ''UnPatDa)
+$(mkTyUnMap Nothing 0 ''UnMapPatDa ''UnPatDa)
 
 type family MapPatTy (x :: [PKind]) :: *
 $(mkTyMapFlat 0 ''MapPatTy ''PatTy)
@@ -249,9 +254,11 @@ $(mkTyMapFlat 0 ''MapPatBTy ''PatBTy)
 type family MapPatReprFn   (r :: * -> *) (x :: [PKind]) :: *
 $(mkTyMapFlat 1 ''MapPatReprFn ''PatReprFn)
 
-instance (ts ~ UnMapPatDa (MapPatDa ts))
+$(mkTyUnMap (Just 'PKTup) 0 ''UnPatDa ''UnPatDa)
+
+instance (UnPatDa (MapPatDa ts) ~ 'PKTup ts)
       => Pat       (PKTup (ts :: [PKind])) where
-  data PatDa       (PKTup ts)   = PTup (MapPatDa ts)
+  type PatDa       (PKTup ts)   = MapPatDa ts
   type PatTy       (PKTup ts)   = MapPatTy ts
   type PatBTy      (PKTup ts)   = MapPatBTy ts
   type PatReprFn r (PKTup ts)   = MapPatReprFn r ts
@@ -268,23 +275,28 @@ data SKind where
   SKTup  :: [SKind] -> SKind
 
 -- | Witness of slice well-formedness
-class Slice r (w :: SKind) where
-  data SliceDa w :: *
+class (UnSliceDa (SliceDa w) ~ w) => Slice r (w :: SKind) where
+  type SliceDa w :: *
   type SliceTy w :: *
 
 type family UnSliceDa (pd :: *) :: SKind
-type instance UnSliceDa (SliceDa w) = w
 
+data SVar r a = SVar (r a)
+type instance UnSliceDa (SVar r a) = SKVar r a
 instance (K3BaseTy a, r0 ~ r) => Slice r0 (SKVar (r :: * -> *) (a :: *)) where
-  data SliceDa (SKVar r a) = SVar (r a)
+  type SliceDa (SKVar r a) = SVar r a
   type SliceTy (SKVar r a) = a
 
+data SUnk a = SUnk
+type instance UnSliceDa (SUnk a)       = SKUnk a
 instance (K3BaseTy a) => Slice r (SKUnk (a :: *)) where
-  data SliceDa (SKUnk a) = SUnk
+  type SliceDa (SKUnk a) = SUnk a
   type SliceTy (SKUnk a) = a
 
+data SJust a = SJust { unSJust :: a }
+type instance UnSliceDa (SJust a)      = SKJust (UnSliceDa a)
 instance (Slice r s) => Slice r (SKJust s) where
-  data SliceDa (SKJust s) = SJust (SliceDa s)
+  type SliceDa (SKJust s) = SJust (SliceDa s)
   type SliceTy (SKJust s) = Maybe (SliceTy s)
 
 type family SliceConst (x :: SKind) (r :: * -> *) :: Constraint
@@ -298,14 +310,16 @@ type family MapSliceDa (x :: [SKind]) :: *
 $(mkTyMapFlat 0 ''MapSliceDa ''SliceDa)
 
 type family UnMapSliceDa (x :: *) :: [SKind]
-$(mkTyUnMap 0 ''UnMapSliceDa ''UnSliceDa)
+$(mkTyUnMap Nothing 0 ''UnMapSliceDa ''UnSliceDa)
 
 type family MapSliceTy (x :: [SKind]) :: *
 $(mkTyMapFlat 0 ''MapSliceTy ''SliceTy)
 
-instance (ts ~ UnMapSliceDa (MapSliceDa ts), MapSliceConst ts r)
+$(mkTyUnMap (Just 'SKTup) 0 ''UnSliceDa ''UnSliceDa)
+
+instance (UnSliceDa (MapSliceDa ts) ~ 'SKTup ts, MapSliceConst ts r)
       => Slice r (SKTup (ts :: [SKind])) where
-  data SliceDa   (SKTup ts)   = STup (MapSliceDa ts)
+  type SliceDa   (SKTup ts)   = MapSliceDa ts
   type SliceTy   (SKTup ts)   = MapSliceTy ts
 
 ------------------------------------------------------------------------}}}
@@ -483,4 +497,3 @@ asColl :: r (CTE r c t) -> CollTy c -> r (CTE r c t)
 asColl = const
 
 ------------------------------------------------------------------------}}}
-

diff --git a/src/Dyna/BackendK3/Examples.hs b/src/Dyna/BackendK3/Examples.hs
index 0511efdb3fa76d65c5cafa402ed655007fd37424..dae525f75261be93b2f3ab0d1f02a060633a9652 100644 (file)
--- a/src/Dyna/BackendK3/Examples.hs
+++ b/src/Dyna/BackendK3/Examples.hs
@@ -49,11 +49,11 @@ testdecf = Decl (Var "f")
 
 testmfn = Decl (Var "negAddOne")
                (tFun tInt tInt)
-               $Just (eLam (PVar $ UTR tInt) (\a -> eNeg $ eAdd a $ cInt 1))
+               $Just (eLam (PVar tInt) (\a -> eNeg $ eAdd a $ cInt 1))
 
 booli = Decl (Var "booli")
              (tFun tBool tInt)
-             $ Just (eLam (PVar (UTR tBool)) (\b -> eITE b (cInt 1) (cInt 0)))
+             $ Just (eLam (PVar tBool) (\b -> eITE b (cInt 1) (cInt 0)))
 
 testcfn = Decl (Var "cfn")
                (tFun tInt $ tColl CTSet tInt)

diff --git a/src/Dyna/BackendK3/Render.hs b/src/Dyna/BackendK3/Render.hs
index abadb1ee3431c04093b3492dac1b98916debd2cb..4617438fc93cd41661b130d9609d3bfbffc46248 100644 (file)
--- a/src/Dyna/BackendK3/Render.hs
+++ b/src/Dyna/BackendK3/Render.hs
@@ -268,7 +268,7 @@ shd (Decl (Var name) tipe body) =
 -- Template Haskell splices                                             {{{
 
 $(mkLRecInstances (''K3PFn,[]) 'PKTup 
-                  ('k3pfn,'PTup,\ls -> TH.tupE [
+                  ('k3pfn,Nothing,\ls -> TH.tupE [
                                           TH.appE (TH.varE 'tupled)
                                           $ TH.listE
                                           $ map (TH.appE (TH.varE 'fst)) ls
@@ -280,7 +280,7 @@ $(do
     e <- liftM TH.varT $ TH.newName "e"
     n <- TH.newName "n"
     mkLRecInstances (''K3SFn,[e]) 'SKTup 
-                  ('k3sfn,'STup,\ls ->
+                  ('k3sfn,Nothing,\ls ->
                       TH.appE (TH.conE 'AsK3)
                     $ TH.lamE [TH.varP n]
                     $ TH.appE (TH.varE 'tupled)

diff --git a/src/Dyna/BackendK3/Selftest.hs b/src/Dyna/BackendK3/Selftest.hs
index 86283ec68e45bdb422c2e5b7f9c82e99bd0d29f8..83a8157e60b47188898cb78b3f8475ca043bfbe7 100644 (file)
--- a/src/Dyna/BackendK3/Selftest.hs
+++ b/src/Dyna/BackendK3/Selftest.hs
@@ -51,7 +51,7 @@ case_pairfn :: Assertion
 case_pairfn = e @=? render k3
  where
   e  = "\\(x0:int ,x1:bool) -> x0"
-  k3 = eLam (PTup (PVar tInt, PVar tBool)) (\(a,_) -> a)
+  k3 = eLam (PVar tInt, PVar tBool) (\(a,_) -> a)
 
 ------------------------------------------------------------------------}}}
 -- Macro expansion test cases                                           {{{

diff --git a/src/Dyna/XXX/THTupleInternals.hs b/src/Dyna/XXX/THTupleInternals.hs
index 4405d832646c598ed16b6ca78f6118da0e3e2112..eb1b2fa0ea6aa1187f60c89121cda86d8833c405 100644 (file)
--- a/src/Dyna/XXX/THTupleInternals.hs
+++ b/src/Dyna/XXX/THTupleInternals.hs
@@ -93,8 +93,8 @@ mkTyMapFlatN nargs _ty _fn size = do
 -- | The composition mkTyMap (MKLT a)
 mkTyMapFlat a b c = foreachTupleSize (mkTyMapFlatN a b c)
 
-mkTyUnMapN :: Int -> Name -> Name -> Int -> Q Dec
-mkTyUnMapN nargs _ty _fn size = do
+mkTyUnMapN :: Maybe Name -> Int -> Name -> Name -> Int -> Q Dec
+mkTyUnMapN _mwr nargs _ty _fn size = do
   let ty = conT _ty
   let fn = conT _fn
   names <- mkNames size 
@@ -103,9 +103,10 @@ mkTyUnMapN nargs _ty _fn size = do
   let afn = genMap appT fn id args
 
   tySynInstD _ty (args++[mkTy size names])
+                 $ maybe id (\_wr -> appT (conT _wr)) _mwr
                  $ promoteList $ map (appT afn . varT) names
 
-mkTyUnMap a b c = foreachTupleSize (mkTyUnMapN a b c)
+mkTyUnMap a b c d = foreachTupleSize (mkTyUnMapN a b c d)
 
 ------------------------------------------------------------------------}}}
 -- Make Tuple                                                           {{{
@@ -221,10 +222,11 @@ mkRecInstances a b c d e = foreachTupleSize (mkRecInstance a b c d e)
 
 mkLRecInstance :: (Name, [TypeQ])              -- ^ Class name and args
                -> Name
-               -> (Name, Name, [ExpQ] -> ExpQ) -- ^ Function, data, and body
+               -> (Name, Maybe Name, [ExpQ] -> ExpQ)
+                                               -- ^ Function, data, and body
                -> Int                          -- ^ Tuple size
                -> Q Dec
-mkLRecInstance (_cname,_cargs) _tyf (_fn,_fpn,fm) n = do
+mkLRecInstance (_cname,_cargs) _tyf (_fn,_mfpn,fm) n = do
   names <- mkNames n
   let context = cxt $ map (\na -> classP _cname $ _cargs ++ [varT na]) names
   let conarg = (appT (conT _tyf) $ promoteList $ map varT names)
@@ -236,7 +238,7 @@ mkLRecInstance (_cname,_cargs) _tyf (_fn,_fpn,fm) n = do
   let res = noBindS $ appE (varE $ mkName "return") $ fm $ map varE resnames
 
   instanceD context (genMap appT (conT _cname) (id) $ _cargs ++ [conarg])
-            [funD _fn [clause [conP _fpn [tupP $ map varP names]]
+            [funD _fn [clause [maybe tupP conP _mfpn $ [tupP $ map varP names]]
                               (normalB $ doE $ stmts++[res])
                               []
                       ]