From e6cbe39ddae48bafba2229e1b60cf765d3195f0e Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 16 Oct 2012 14:19:29 -0400 Subject: [PATCH] K3: CTE, Ref now data families; new Annotation framework; misc small fixes --- src/Dyna/BackendK3/AST.hs | 144 ++++++++++++++++++------------- src/Dyna/BackendK3/Automation.hs | 6 +- src/Dyna/BackendK3/Render.hs | 69 ++++++++++----- 3 files changed, 134 insertions(+), 85 deletions(-) diff --git a/src/Dyna/BackendK3/AST.hs b/src/Dyna/BackendK3/AST.hs index b1bdfe7..c85bebf 100644 --- a/src/Dyna/BackendK3/AST.hs +++ b/src/Dyna/BackendK3/AST.hs @@ -35,16 +35,36 @@ import Dyna.XXX.THTuple newtype VarIx = Var String -- XXX (Hostname,Port) newtype AddrIx = Addr (String,Int) + deriving (Eq,Show) + + -- XXX This has a phantom type only so that we can use it as an r + -- in RTupled. We'd rather not (see .Render's need to use fdscast) +data FunDepSpec a = FDIrr | FDDom | FDCod + deriving (Eq,Show) -- XXX should really do something smarter -data Ann = Ann [String] +data Ann a where + + -- | Decorate an expression as atomic. + AAtomic :: Ann a + + -- | A functional dependency among elements of a collection. + AFunDep :: (RTupled fs, RTE fs ~ a, RTR fs ~ FunDepSpec) + => fs -> Ann (CTE r t a) + + -- | An "Exactly-One-Of" annotation, used to convey variants (i.e. sums) + -- to K3. + AOneOf :: (RTupled mv, RTR mv ~ Maybe) => Ann mv + + -- | An escape hatch! (XXX) + AMisc :: String -> Ann a ------------------------------------------------------------------------}}} {- * Collections -} -- {{{ data CKind = CBag | CList | CSet -data CTE (c :: CKind) e +data family CTE (r :: * -> *) (c :: CKind) e data CollTy c where CTBag :: CollTy CBag @@ -68,30 +88,43 @@ data VTy v where VTCont :: VTy VKCont -} -data Ref a = Ref +data family Ref (r :: * -> *) a ------------------------------------------------------------------------}}} {- * Type System -} -- {{{ - -- | Data level representation of K3 types, indexed by equivalent type in - -- Haskell. -class K3Ty (r :: * -> *) where - -- | Attach an annotation to a type - tAnn :: Ann -> r a -> r a +-- | A constraint for "base" types in K3. These are the things that can +-- be passed to lambdas. Essentially everything other than arrows. +class K3BaseTy a +instance K3BaseTy Bool +instance K3BaseTy Word8 +instance K3BaseTy Float +instance K3BaseTy Int +instance K3BaseTy String +instance K3BaseTy () +instance (K3BaseTy a) => K3BaseTy (CTE r c a) +instance (K3BaseTy a) => K3BaseTy (Maybe a) +instance (K3BaseTy a) => K3BaseTy (Ref r a) +$(mkTupleRecInstances ''K3BaseTy []) - tBool :: r Bool - tByte :: r Word8 - tFloat :: r Float - tInt :: r Int - tString :: r String - tUnit :: r () +-- | Data level representation of K3 types, indexed by equivalent type in +-- Haskell. +class K3Ty (r :: * -> *) where + -- | Attach an annotation to a type + tAnn :: r a -> [Ann a] -> r a -{- TAddress | TTarget BaseTy -} + tAddress :: r AddrIx + tBool :: r Bool + tByte :: r Word8 + tFloat :: r Float + tInt :: r Int + tString :: r String + tUnit :: r () -- tPair :: r a -> r b -> r (a,b) tMaybe :: r a -> r (Maybe a) - tRef :: r a -> r (Ref a) - tColl :: CollTy c -> r a -> r (CTE c a) + tRef :: r a -> r (Ref r' a) + tColl :: (K3BaseTy a) => CollTy c -> r a -> r (CTE r' c a) tFun :: r a -> r b -> r (a -> b) -- XXX TUPLES @@ -99,12 +132,15 @@ class K3Ty (r :: * -> *) where tTuple2 :: (r a, r b) -> r (a,b) tTuple3 :: (r a, r b, r c) -> r (a,b,c) tTuple4 :: (r a, r b, r c, r d) -> r (a,b,c,d) + tTuple5 :: (r a, r b, r c, r d, r e) -> r (a,b,c,d,e) - -- | Universal typeclass wrapper for K3Ty +-- | Universal typeclass wrapper for K3Ty newtype UnivTyRepr (a :: *) = UTR { unUTR :: forall r . (K3Ty r) => r a } instance K3Ty UnivTyRepr where - tAnn s (UTR t) = UTR $ tAnn s t + tAnn (UTR t) s = UTR $ tAnn t s + + tAddress = UTR tAddress tBool = UTR tBool tByte = UTR tByte tFloat = UTR tFloat @@ -122,20 +158,8 @@ instance K3Ty UnivTyRepr where tTuple2 us = UTR $ tTuple2 $ tupleopRS unUTR us tTuple3 us = UTR $ tTuple3 $ tupleopRS unUTR us tTuple4 us = UTR $ tTuple4 $ tupleopRS unUTR us + tTuple5 us = UTR $ tTuple5 $ tupleopRS unUTR us - -- | A constraint for "base" types in K3. These are the things that can - -- be passed to lambdas. Essentially everything other than arrows. -class K3BaseTy a -instance K3BaseTy Bool -instance K3BaseTy Word8 -instance K3BaseTy Float -instance K3BaseTy Int -instance K3BaseTy String -instance K3BaseTy () -instance (K3BaseTy a) => K3BaseTy (CTE c a) -instance (K3BaseTy a) => K3BaseTy (Maybe a) -instance (K3BaseTy a) => K3BaseTy (Ref a) -$(mkTupleRecInstances ''K3BaseTy []) ------------------------------------------------------------------------}}} {- * Pattern System -} -- {{{ @@ -337,7 +361,7 @@ class K3 (r :: * -> *) where -- | Add a comment to some part of the AST cComment :: String -> r a -> r a -- | Add some annotations to some part of the AST - cAnn :: Ann -> r a -> r a + cAnn :: r a -> [Ann a] -> r a -- XXX An escape hatch -- @@ -345,7 +369,7 @@ class K3 (r :: * -> *) where -- we handle with SKUnk/SUnk. -- cUnk :: r a - -- XXX cAddress :: AddrIx -> r AddrIx + cAddress :: AddrIx -> r AddrIx cBool :: Bool -> r Bool cByte :: Word8 -> r Word8 cFloat :: Float -> r Float @@ -364,20 +388,20 @@ class K3 (r :: * -> *) where eTuple4 :: (r a, r b, r c,r d) -> r (a,b,c,d) -- eTuple :: K3RTuple r a -> r a - eEmpty :: (K3AST_Coll_C r c) => r (CTE c e) - eSing :: (K3AST_Coll_C r c) => r e -> r (CTE c e) - eCombine :: r (CTE c e) -> r (CTE c e) -> r (CTE c e) - eRange :: r Int -> r Int -> r Int -> r (CTE c Int) + eEmpty :: (K3AST_Coll_C r c) => r (CTE r c e) + eSing :: (K3AST_Coll_C r c) => r e -> r (CTE r c e) + eCombine :: r (CTE r c e) -> r (CTE r c e) -> r (CTE r c e) + eRange :: r Int -> r Int -> r Int -> r (CTE r c Int) eAdd :: (BiNum a b) => r a -> r b -> r (BNTF a b) eMul :: (BiNum a b) => r a -> r b -> r (BNTF a b) eNeg :: (UnNum a) => r a -> r a -- XXX Constraints? - eEq :: r a -> r a -> r Bool - eLt :: r a -> r a -> r Bool - eLeq :: r a -> r a -> r Bool - eNeq :: r a -> r a -> r Bool + eEq :: (K3BaseTy a) => r a -> r a -> r Bool + eLt :: (K3BaseTy a) => r a -> r a -> r Bool + eLeq :: (K3BaseTy a) => r a -> r a -> r Bool + eNeq :: (K3BaseTy a) => r a -> r a -> r Bool -- | A lambda application in K3. -- @@ -392,17 +416,17 @@ class K3 (r :: * -> *) where eBlock :: [r ()] -> r a -> r a - eIter :: r (t -> ()) -> r (CTE c t) -> r () + eIter :: r (t -> ()) -> r (CTE r c t) -> r () eITE :: r Bool -> r a -> r a -> r a - eMap :: r (t -> t') -> r (CTE c t) -> r (CTE c t') - eFiltMap :: r (t -> Bool) -> r (t -> t') -> r (CTE c t) -> r (CTE c t') + eMap :: r (t -> t') -> r (CTE r c t) -> r (CTE r c t') + eFiltMap :: r (t -> Bool) -> r (t -> t') -> r (CTE r c t) -> r (CTE r c t') - eFlatten :: r (CTE c (CTE c' t)) -> r (CTE c' t) + eFlatten :: r (CTE r c (CTE r c' t)) -> r (CTE r c' t) -- | Called Aggregate in K3's AST - eFold :: r ((t', t) -> t') -> r t' -> r (CTE c t) -> r t' + eFold :: r ((t', t) -> t') -> r t' -> r (CTE r c t) -> r t' -- | Group-By-Aggregate. -- @@ -412,12 +436,12 @@ class K3 (r :: * -> *) where eGBA :: r (t -> t'') -- ^ Partitioner -> r ((t',t) -> t') -- ^ Folder -> r t' -- ^ Zero for each partition - -> r (CTE c t) -- ^ Input collection - -> r (CTE c (t'',t')) + -> r (CTE r c t) -- ^ Input collection + -> r (CTE r c (t'',t')) - eSort :: r (CTE c t) -- ^ Input collection + eSort :: r (CTE r c t) -- ^ Input collection -> r ((t,t) -> Bool) -- ^ Less-or-equal - -> r (CTE 'CList t) + -> r (CTE r 'CList t) -- | Peek an element from a collection. -- @@ -425,7 +449,7 @@ class K3 (r :: * -> *) where -- -- For lists, this returns the head; for sets and bags -- it samples arbitrarily. - ePeek :: r (CTE c e) -> r e + ePeek :: r (CTE r c e) -> r e -- | Slice out from a collection; the slice's type and -- the type of elements of the collection must match. @@ -433,16 +457,18 @@ class K3 (r :: * -> *) where -- Rather like lambdas, except that the witness is also -- a mandatory part of the definition of "slice" :) eSlice :: (K3AST_Slice_C r w, Slice r w, SliceTy w ~ t) - => SliceDa w -> r (CTE c t) -> r (CTE c t) + => SliceDa w -- ^ Slice specification + -> r (CTE r c t) -- ^ Input collection + -> r (CTE r c t) - eInsert :: r (CTE c t) -> r t -> r () - eDelete :: r (CTE c t) -> r t -> r () - eUpdate :: r (CTE c t) -> r t -> r t -> r () + eInsert :: r (CTE r c t) -> r t -> r () + eDelete :: r (CTE r c t) -> r t -> r () + eUpdate :: r (CTE r c t) -> r t -> r t -> r () - eAssign :: r (Ref t) -> r t -> r () - eDeref :: r (Ref t) -> r t + eAssign :: r (Ref r t) -> r t -> r () + eDeref :: r (Ref r t) -> r t - -- XXX eSend + eSend :: r AddrIx -> r (a -> ()) -> r a -> r () ------------------------------------------------------------------------}}} {- * Miscellany -} -- {{{ diff --git a/src/Dyna/BackendK3/Automation.hs b/src/Dyna/BackendK3/Automation.hs index 76d4fcf..82c0764 100644 --- a/src/Dyna/BackendK3/Automation.hs +++ b/src/Dyna/BackendK3/Automation.hs @@ -59,10 +59,10 @@ instance K3AutoTy Float where autoty = tFloat instance K3AutoTy Int where autoty = tInt instance K3AutoTy String where autoty = tString instance K3AutoTy () where autoty = tUnit -instance (K3AutoColl c, K3AutoTy a) => K3AutoTy (CTE c a) where +instance (K3AutoColl c, K3AutoTy a, K3BaseTy a) => K3AutoTy (CTE r c a) where autoty = tColl autocoll autoty instance (K3AutoTy a) => K3AutoTy (Maybe a) where autoty = tMaybe autoty -instance (K3AutoTy a) => K3AutoTy (Ref a) where autoty = tRef autoty +instance (K3AutoTy a) => K3AutoTy (Ref r a) where autoty = tRef autoty instance (K3AutoTy a, K3AutoTy b) => K3AutoTy (a -> b) where autoty = tFun autoty autoty @@ -114,7 +114,7 @@ macro_caseMaybe w m n b = eITE (eEq m cNothing) -- | Case analyze a collection as either empty or a peeked element macro_emptyPeek :: (K3AST_Coll_C r c, K3AST_Pat_C r (PKVar a), K3 r, K3BaseTy a, K3AutoTy a) - => r (CTE c a) -> r b -> (r a -> r b) -> r b + => r (CTE r c a) -> r b -> (r a -> r b) -> r b macro_emptyPeek c e l = eITE (eEq c eEmpty) e (eApp (eLam (PVar autoty) l) $ ePeek c) diff --git a/src/Dyna/BackendK3/Render.hs b/src/Dyna/BackendK3/Render.hs index 475887e..abadb1e 100644 --- a/src/Dyna/BackendK3/Render.hs +++ b/src/Dyna/BackendK3/Render.hs @@ -17,16 +17,32 @@ module Dyna.BackendK3.Render where import Control.Monad.Identity import Control.Monad.State +import qualified Data.List as DL import Text.PrettyPrint.Free import Dyna.BackendK3.AST import Dyna.XXX.MonadUtils import Dyna.XXX.THTuple -import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH as TH ------------------------------------------------------------------------}}} --- Type handling {{{ +{- * Annotations -} -- {{{ + +annText :: Ann a -> Doc e +annText AAtomic = "atomic" +annText AOneOf = "oneof" +annText (AMisc s) = text s +annText (AFunDep fs) = let x = tupleopEL (fdscast) fs + in let (dom,cod) = (DL.elemIndices FDDom x + ,DL.elemIndices FDCod x) + in (tupled $ map pretty dom) + <+> "->" + <+> (tupled $ map pretty cod) + where + fdscast FDIrr = FDIrr + fdscast FDDom = FDDom + fdscast FDCod = FDCod ------------------------------------------------------------------------}}} {- * Type handling -} -- {{{ @@ -36,16 +52,16 @@ import qualified Language.Haskell.TH as TH newtype AsK3Ty e (a :: *) = AsK3Ty { unAsK3Ty :: Doc e } instance K3Ty (AsK3Ty e) where - tAnn (Ann anns) (AsK3Ty e) = AsK3Ty$ - parens e <> " @ " - <> (encloseSep lbrace rbrace comma $ map text anns) + tAnn (AsK3Ty e) anns = AsK3Ty$ align $ + e "@" <+> (encloseSep lbrace rbrace comma $ map annText anns) - tBool = AsK3Ty$ "bool" - tByte = AsK3Ty$ "byte" - tFloat = AsK3Ty$ "float" - tInt = AsK3Ty$ "int" - tString = AsK3Ty$ "string" - tUnit = AsK3Ty$ "unit" + tAddress = AsK3Ty$ "address" + tBool = AsK3Ty$ "bool" + tByte = AsK3Ty$ "byte" + tFloat = AsK3Ty$ "float" + tInt = AsK3Ty$ "int" + tString = AsK3Ty$ "string" + tUnit = AsK3Ty$ "unit" -- tPair (AsK3Ty ta) (AsK3Ty tb) = AsK3Ty$ tupled [ ta, tb ] @@ -63,13 +79,14 @@ instance K3Ty (AsK3Ty e) where tTuple2 us = AsK3Ty $ tupled $ tupleopEL unAsK3Ty us tTuple3 us = AsK3Ty $ tupled $ tupleopEL unAsK3Ty us tTuple4 us = AsK3Ty $ tupled $ tupleopEL unAsK3Ty us + tTuple5 us = AsK3Ty $ tupled $ tupleopEL unAsK3Ty us ------------------------------------------------------------------------}}} -- Collection handling {{{ class K3CFn (c :: CKind) where - k3cfn_empty :: AsK3 e (CTE c a) - k3cfn_sing :: AsK3 e vma -> AsK3 e (CTE c vma) + k3cfn_empty :: AsK3 e (CTE (AsK3 e) c a) + k3cfn_sing :: AsK3 e vma -> AsK3 e (CTE (AsK3 e) c vma) instance K3CFn CSet where k3cfn_empty = AsK3$ const$ "{ }" @@ -101,6 +118,9 @@ instance (K3PFn w) => K3PFn (PKJust w) where (p, r) <- k3pfn w return ("just " <> parens p, r) +instance (K3BaseTy a) => K3PFn (PKUnk (a :: *)) where + k3pfn PUnk = return ("_", cUnit) + ------------------------------------------------------------------------}}} -- Slice handling {{{ @@ -128,17 +148,19 @@ instance K3 (AsK3 e) where type K3AST_Pat_C (AsK3 e) p = K3PFn p type K3AST_Slice_C (AsK3 e) s = K3SFn e s - cAnn (Ann anns) (AsK3 e) = AsK3$ \n -> + cAnn (AsK3 e) anns = AsK3$ \n -> align $ parens (e n) <> " @ " - <> (encloseSep lbrace rbrace comma $ map text anns) + <> (encloseSep lbrace rbrace comma $ map annText anns) cComment str (AsK3 a) = AsK3$ \n -> "\n// " <> text str <> "\n" <> a n - cBool n = AsK3$ const$ text$ show n - cByte n = AsK3$ const$ text$ show n - cFloat n = AsK3$ const$ text$ show n - cInt n = AsK3$ const$ text$ show n - cString n = AsK3$ const$ text$ show n + cAddress (Addr (h,p)) = AsK3$ const$ (text h <> ":" <> pretty p) + + cBool n = AsK3$ const$ text$ show n + cByte n = AsK3$ const$ text$ show n + cFloat n = AsK3$ const$ text$ show n + cInt n = AsK3$ const$ text$ show n + cString n = AsK3$ const$ text$ show n cNothing = AsK3$ const$ "nothing" cUnit = AsK3$ const$ "unit" @@ -168,7 +190,7 @@ instance K3 (AsK3 e) where eNeq = binop "!=" eLam w f = AsK3$ \n -> let ((pat, arg),n') = runState (k3pfn w) n - in "\\" <> pat <+> "->" <+> align (unAsK3 (f arg) n') + in "\\" <> pat <+> "->" `above` indent 2 (unAsK3 (f arg) n') eApp (AsK3 f) (AsK3 x) = AsK3$ \n -> parens (parens (f n) `aboveBreak` parens (x n)) @@ -200,7 +222,8 @@ instance K3 (AsK3 e) where eAssign = binop "<-" eDeref (AsK3 r) = builtin "deref" [ r ] -- XXX that doesn't seem to actually be right! - + + eSend (AsK3 a) (AsK3 f) (AsK3 x) = builtin "send" [ a, f, x ] ------------------------------------------------------------------------}}} -- Miscellany {{{ @@ -238,7 +261,7 @@ shd (Decl (Var name) tipe body) = <> unAsK3Ty tipe <> case body of Nothing -> empty - Just b -> space <> equals <> space <> unAsK3 b 0 + Just b -> space <> equals `aboveBreak` (indent 2 $ unAsK3 b 0) <> semi ------------------------------------------------------------------------}}} -- 2.50.1