From ee537e16b7f5c97598ee6f5ef0c6a2c76ab521c2 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Wed, 17 Oct 2012 17:04:00 -0400 Subject: [PATCH] Remove PTup and STup verbosity from BackendK3 --- src/Dyna/BackendK3/AST.hs | 49 ++++++++++++++++++++------------ src/Dyna/BackendK3/Examples.hs | 4 +-- src/Dyna/BackendK3/Render.hs | 4 +-- src/Dyna/BackendK3/Selftest.hs | 2 +- src/Dyna/XXX/THTupleInternals.hs | 14 +++++---- 5 files changed, 44 insertions(+), 29 deletions(-) diff --git a/src/Dyna/BackendK3/AST.hs b/src/Dyna/BackendK3/AST.hs index c85bebf..e6620e1 100644 --- 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 0511efd..dae525f 100644 --- 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 abadb1e..4617438 100644 --- 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 86283ec..83a8157 100644 --- 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 4405d83..eb1b2fa 100644 --- 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]) [] ] -- 2.50.1