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
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
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
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 -} -- {{{
-- | 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
--
-- 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
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.
--
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.
--
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.
--
--
-- 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.
-- 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 -} -- {{{
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 -} -- {{{
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 ]
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$ "{ }"
(p, r) <- k3pfn w
return ("just " <> parens p, r)
+instance (K3BaseTy a) => K3PFn (PKUnk (a :: *)) where
+ k3pfn PUnk = return ("_", cUnit)
+
------------------------------------------------------------------------}}}
-- Slice handling {{{
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"
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))
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 {{{
<> 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
------------------------------------------------------------------------}}}
projects / dyna2 / commitdiff