Cabal-Version: >=1.14
Build-Type: Simple
Stability: alpha
-Copyright: Copyright (c) 2007--2012,
+Copyright: Copyright (c) 2007-2012,
Nathaniel W. Filardo, Tim Vieira, wren ng thornton
License: OtherLicense
License-File: LICENSE
Exposed-Modules: Dyna.Analysis.ANF,
Dyna.Analysis.Mode,
- Dyna.BackendK3.AST,
- Dyna.BackendK3.Automation,
- Dyna.BackendK3.Render,
+ Dyna.Backend.K3.AST,
+ Dyna.Backend.K3.Automation,
+ Dyna.Backend.K3.Render,
Dyna.ParserHS.Parser,
Dyna.XXX.HList,
Dyna.XXX.THTuple,
haskeline >=0.6,
mtl >=2.1,
parsers >=0.2,
+ process >=1.1,
reducers >=3.0,
semigroups >=0.8,
tagged >= 0.4.4,
utf8-string >=0.3,
wl-pprint-extras >=3.0
- Other-Modules: Dyna.BackendK3.Examples
+ Other-Modules: Dyna.Backend.K3.Examples
Main-Is: Dyna/Test/Main.hs
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -Werror #-}
-module Dyna.BackendK3.AST (
+module Dyna.Backend.K3.AST (
-- * Preliminaries
VarIx(..), AddrIx(..), Target,
-- * Declarations
Decl(..), DBody(..), asR, asCollR, {- asRefR, -}
- mkCollDecl, mkTrigDecl, -- unUDR,
+ mkCollDecl, mkRefDecl, mkTrigDecl, mkFuncDecl, -- unUDR,
+
+ K3Proxied, K3Unproxy,
-- * Programs
mkK3, mkK3T, MkK3T, Prog(..)
instance (K3BaseTy a) => K3BaseTy (Maybe a)
instance K3BaseTy (HList '[])
instance (K3BaseTy a, K3BaseTy (HList as)) => K3BaseTy (HList (a ': as))
-$(mkTupleRecInstances ''K3BaseTy [])
+-- See THSPLICE
------------------------------------------------------------------------}}}
-- Type System: Proxified Representations {{{
+-- XXX These will be a lot nicer once we get overlapping groups of type
+-- families. Real Soon Now, I hope.
type family K3Proxied (a :: *) :: *
type family K3Unproxy (r :: * -> *) (a :: *) :: *
type instance K3Proxied (HList a) = HList (MapK3Proxied a)
type instance K3Unproxy r (HList a) = HList (MapK3Unproxy r a)
+type instance K3Proxied (a -> b) = (K3Proxied a) -> (K3Proxied b)
+type instance K3Unproxy r (a -> b) = (K3Unproxy r a) -> (K3Unproxy r b)
+
type instance K3Proxied (a,b) = (K3Proxied a, K3Proxied b)
type instance K3Unproxy r (a,b) = (K3Unproxy r a, K3Unproxy r b)
------------------------------------------------------------------------}}}
-- References {{{
-{- XXX k3ref
+-- XXX k3ref At the moment K3 only supports global refs. This is enforced
+-- in Haskell by allowing Refs to only be made as declarations; this will
+-- change eventually.
+
-- | The 'r' representation of references of elements of type 'a'
data family Ref (r :: * -> *) a
type instance K3Proxied (Ref r a) = Ref Proxy (K3Proxied a)
type instance K3Unproxy r (Ref Proxy a) = Ref r (K3Unproxy r a)
- -}
------------------------------------------------------------------------}}}
-- Pattern System {{{
-- | Just patterns (see 'PJust')
PKJust :: PKind -> PKind
-{- XXX k3ref
-- | Ref patterns (see 'PRef')
PKRef :: PKind -> PKind
- -}
-- | HList patterns
PKHL :: [PKind] -> PKind
-- "a". This will in general be true of any variant (i.e. sum) pattern.
PJust :: PDat r w -> PDat r (PKJust w)
-{- XXX k3ref
-- | A /Ref/ pattern; dereferences the provided reference.
PRef :: PDat r w -> PDat r (PKRef w)
--}
-- | A HList-style product pattern
PHL :: HRList (PDat r) ws -> PDat r (PKHL ws)
type PatBTy s (PKJust w) = PatBTy s w
type PatReprFn s (PKJust w) = PatReprFn s w
-{- XXX k3ref
instance (Pat w) => Pat (PKRef w) where
type PatTy s (PKRef w) = Ref s (PatTy s w)
type PatBTy s (PKRef w) = PatBTy s w
type PatReprFn s (PKRef w) = PatReprFn s w
--}
-- ** Tuples
type family TMapPatTy (s :: * -> *) (x :: [PKind]) :: *
-$(mkTyMapFlat 1 ''TMapPatTy ''PatTy)
+-- see THSPLICE
type family TMapPatBTy (s :: * -> *) (x :: [PKind]) :: *
-$(mkTyMapFlat 1 ''TMapPatBTy ''PatBTy)
+-- see THSPLICE
type family TMapPatReprFn (r :: * -> *) (x :: [PKind]) :: *
-$(mkTyMapFlat 1 ''TMapPatReprFn ''PatReprFn)
+-- see THSPLICE
type family MapPatConst (x :: [PKind]) :: Constraint
type instance MapPatConst '[] = ()
-- ** HLists
type family MapPatTy (r :: * -> *) (x :: [PKind]) :: [*]
-type instance MapPatTy r ('[]) = '[]
+type instance MapPatTy r '[] = '[]
type instance MapPatTy r (w ': ws) = PatTy r w ': (MapPatTy r ws)
type family MapPatBTy (r :: * -> *) (x :: [PKind]) :: [*]
-type instance MapPatBTy r ('[]) = '[]
+type instance MapPatBTy r '[] = '[]
type instance MapPatBTy r (w ': ws) = PatBTy r w ': (MapPatBTy r ws)
type family MapPatReprFn (r :: * -> *) (x :: [PKind]) :: [*]
-- in RTupled. We'd rather not (see "Dyna.BackendK3.Render"'s
-- need to use 'fdscast'), but the alternative of, e.g. Tagged, is not that
-- great either!
-data FunDepSpec a = FDIrr -- ^ /Irr/elevant to a fundep
- | FDDom -- ^ In the /Dom/ain of a fundep
- | FDCod -- ^ In the /Cod/omain of a fundep
+data FunDepSpec (a :: *) = FDIrr -- ^ /Irr/elevant to a fundep
+ | FDDom -- ^ In the /Dom/ain of a fundep
+ | FDCod -- ^ In the /Cod/omain of a fundep
deriving (Eq,Show)
-- | Annotations on 'K3Ty' types
-- type in Haskell.
class K3 (r :: * -> *) where
+ -- XXX To ensure uniqueness of declarations, we pull the ST trick with an
+ -- existential skolem. Of course, that means that all of our
+ -- representations have to be marked. We don't yet do this.
+ --
+ -- type K3ReprSrc r :: *
+ --
+ -- Once we have that, add (s ~ K3ReprSrc r) to declVar.
+
+ -- | Reference a declaration by using its name. In emitted K3, this is
+ -- just a variable. See "Dyna.BackendK3.CollectDecls" for an interpreter
+ -- which gathers the transitive closure of declarations used in a program
+ -- fragment.
declVar :: (pt ~ K3Proxied t, t ~ K3Unproxy r pt)
=> Decl s pt -> r t
-- of type (r (a,b) -> r (a,b)) while the latter has ((r a, r b) -> r
-- (a,b)).
eLam :: (Pat w)
- => PDat UnivTyRepr w -> (PatReprFn r w -> r b) -> r (PatTy r w -> b)
+ => PDat UnivTyRepr w
+ -> (PatReprFn r w -> r b)
+ -> r (PatTy r w -> b)
-- | Apply
eApp :: r (a -> b) -> r a -> r b
--
-- Note that dereference is done by a lambda pattern. See Automation's
-- 'deref'.
- -- XXX k3ref
- -- eAssign :: r (Ref r t) -> r t -> r ()
+ eAssign :: r (Ref r t) -> r t -> r ()
-- | Send a function and data to another node.
--
DColl :: (pt ~ K3Proxied t)
=> UnivTyRepr (CTE r c t) -> DBody (CTE Proxy (c :: CKind) pt)
-{-
- - XXX K3ref
- -- | Global References
- DRef :: DBody (Ref Proxy (K3Proxied t))
--}
+ -- | Global References, with initializer
+ DRef :: UnivTyRepr pt
+ -> (forall r . (K3 r) => r (K3Unproxy r pt))
+ -> DBody (Ref Proxy pt)
-- | Triggers, which execute in a different transaction than the caller
--
-- XXX does not support local variables
- DTrig :: (forall r . (K3 r) => r (t -> ())) -> DBody (Target Proxy (K3Proxied t))
+ DTrig :: (Pat w, pt ~ PatTy Proxy w)
+ => PDat UnivTyRepr w
+ -> (forall r . (K3 r) => PatReprFn r w -> r ())
+ -> DBody (Target Proxy pt)
-- | Functions, which execute in the same transaction as the caller
- DFunc :: (forall r . (K3 r) => r (a -> b)) -> DBody (K3Proxied (a -> b))
+ DFunc :: (Pat w, pa ~ PatTy Proxy w, K3BaseTy pa, K3BaseTy pb)
+ => UnivTyRepr pa
+ -> UnivTyRepr pb
+ -> PDat UnivTyRepr w
+ -> (forall r . (K3 r) => PatReprFn r w -> r (K3Unproxy r pb))
+ -> DBody (pa -> pb)
{- XXX
-- | Role declaration
newtype DeclIx = DeclIx Int
deriving (Num,Show)
-mkCollDecl :: (Monad m)
+newtype MkK3T m s a = MkK3T { unMkK3T :: StateT DeclIx m a }
+ deriving (Monad, MonadState DeclIx)
+
+-- | Define a collection
+--
+-- Note that this is polymorphic in r rather than using it as an
+-- existential. This may seem rather odd, until one remembers that the only
+-- ways of building UnivTyReprs are all polymorphic in r, too. Thus we
+-- don't actually risk anything bad when we proxy and unproxy r out of the
+-- way. In fact, the 'K3Unproxy' constraint is here only to ensure that we
+-- get yelled at if we inadvertently write a collection that mixes
+-- representations (or could mix representations using polymorphism); use
+-- 'asCollR' and 'asR' and friends.
+mkCollDecl :: (Monad m, pt ~ K3Proxied t, t ~ K3Unproxy r pt)
=> String
- -> (forall r . Proxy r -> UnivTyRepr (CTE r c t))
- -> MkK3T m s (Decl s (CTE Proxy c (K3Proxied t)))
+ -> (Proxy r -> UnivTyRepr (CTE r c t))
+ -> MkK3T m s (Decl s (CTE Proxy c pt))
mkCollDecl n f = do
(DeclIx uniq) <- incState
let v = Var $ n ++ "_" ++ show uniq
- return $ Decl v $ DColl (f Proxy)
+ return $ Decl v $ DColl $ f Proxy
+
+mkRefDecl :: (Monad m)
+ => String
+ -> UnivTyRepr pt
+ -> (forall r . (K3 r) => r (K3Unproxy r pt))
+ -> MkK3T m s (Decl s (Ref Proxy pt))
+mkRefDecl n ty i = do
+ (DeclIx uniq) <- incState
+ let v = Var $ n ++ "_" ++ show uniq
+ return $ Decl v (DRef ty i)
--- | Define a fixed-point declaration, with an assist in constraining
--- polymorphism.
-mkTrigDecl :: (Monad m)
+-- | Define a trigger
+mkTrigDecl :: (Monad m, K3BaseTy pt, Pat w, pt ~ PatTy Proxy w)
=> String
- -> (forall r . Proxy r -> UnivTyRepr t)
- -> (forall r . (K3 r) => r t -> r (t -> ()))
- -> MkK3T m s (Decl s (Target Proxy (K3Proxied t)))
-mkTrigDecl n ty mk = do
+ -> PDat UnivTyRepr w
+ -> (forall r . (K3 r) => PatReprFn r w -> r ())
+ -> MkK3T m s (Decl s (Target Proxy pt))
+mkTrigDecl n p f = do
(DeclIx uniq) <- incState
let v = Var $ n ++ "_" ++ show uniq
- return $ Decl v (DTrig $ mk (unsafeVar v (ty Proxy)))
+ return $ Decl v (DTrig p f)
-newtype MkK3T m s a = MkK3T { unMkK3T :: StateT DeclIx m a }
- deriving (Monad, MonadState DeclIx)
+-- | Define a function
+mkFuncDecl :: (Monad m, Pat w, pa ~ PatTy Proxy w, K3BaseTy pa, K3BaseTy pb)
+ => String
+ -> UnivTyRepr pa
+ -> UnivTyRepr pb
+ -> PDat UnivTyRepr w
+ -> (forall r . (K3 r) => PatReprFn r w -> r (K3Unproxy r pb))
+ -> MkK3T m s (Decl s (pa -> pb))
+mkFuncDecl n ta tb pa f = do
+ (DeclIx uniq) <- incState
+ let v = Var $ n ++ "_" ++ show uniq
+ return $ Decl v (DFunc ta tb pa f)
mkK3T :: (Functor m, Monad m)
=> (forall s . MkK3T m s (Decl s a))
-}
------------------------------------------------------------------------}}}
+-- Template Haskell splices (THSPLICE) {{{
+
+$(mkTupleRecInstances ''K3BaseTy [])
+$(mkTyMapFlat 1 ''TMapPatTy ''PatTy)
+$(mkTyMapFlat 1 ''TMapPatBTy ''PatBTy)
+$(mkTyMapFlat 1 ''TMapPatReprFn ''PatReprFn)
+
+------------------------------------------------------------------------}}}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-module Dyna.BackendK3.Automation (
+module Dyna.Backend.K3.Automation (
-- * Automated derivation of data from types, where possible
K3AutoColl, autocoll, K3AutoTy, autoty,
) where
import Data.Word
-import Dyna.BackendK3.AST
+import Dyna.Backend.K3.AST
import Dyna.XXX.HList
-- import Dyna.XXX.THTuple
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -Werror #-}
-module Dyna.BackendK3.CollectDecls where
+module Dyna.Backend.K3.CollectDecls where
import qualified Data.Map as M
-import Dyna.BackendK3.AST
+import Dyna.Backend.K3.AST
import Dyna.XXX.HList
data ExDecl = forall a s . Ex (Decl s a)
mkpc (PHL HRN) = HN
mkpc (PHL (w :++ ws)) = mkpc w :+ mkpc (PHL ws)
mkpc (PJust x) = mkpc x
+mkpc (PRef x) = mkpc x
mkpc (PT2 (a,b)) = (mkpc a, mkpc b)
mkpc (PT3 (a,b,c)) = (mkpc a, mkpc b, mkpc c)
mkpc (PT4 (a,b,c,d)) = (mkpc a, mkpc b, mkpc c, mkpc d)
cslice :: PDat C w -> C (PatTy C w)
cslice (PVar x) = x
-cslice (PUnk) = eC
+cslice PUnk = eC
cslice (PJust x) = pC $ cslice x
+cslice (PRef x) = pC $ cslice x
cslice (PHL xs) = C $ M.unions $ hrlproj (unC . cslice) xs
cslice (PT2 (a,b)) = uC (cslice a) (cslice b)
cslice (PT3 (a,b,c)) = C $ M.unions [ unC $ cslice a
]
instance K3 C where
-
declVar d@(Decl v b) = C $ M.union (cdk b) (M.singleton v (Ex d))
unsafeVar _ _ = eC
eDelete a b = uC a b
eUpdate a b c = C $ M.unions [unC a, unC b, unC c]
- -- XXX k3ref
- -- eAssign r v = C $ M.union (unC r) (unC v)
+ eAssign r v = C $ M.union (unC r) (unC v)
eSend a t m = C $ M.unions [unC a, unC t, unC m]
cdk :: DBody t -> M.Map VarIx ExDecl
-cdk (DColl _) = M.empty
--- XXX k3ref
--- cdk DRef = M.empty
-cdk (DFunc b) = unC b
-cdk (DTrig b) = unC b
+cdk (DColl _) = M.empty
+cdk (DRef _ i) = unC i
+cdk (DFunc _ _ p f) = unC (f $ mkpc p)
+cdk (DTrig p f) = unC (f $ mkpc p)
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-
-module Dyna.BackendK3.Examples where
+module Dyna.Backend.K3.Examples where
import Dyna.BackendK3.AST
import Dyna.BackendK3.Automation
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall -Werror #-}
-module Dyna.BackendK3.Render (
+module Dyna.Backend.K3.Render (
-- * K3 implementations
AsK3Ty(..), AsK3E(..),
import qualified Data.Map as M
import Text.PrettyPrint.Free
-import Dyna.BackendK3.AST
-import Dyna.BackendK3.CollectDecls
+import Dyna.Backend.K3.AST
+import Dyna.Backend.K3.CollectDecls
import Dyna.XXX.HList
import Dyna.XXX.MonadUtils
import Dyna.XXX.THTuple
+import Dyna.XXX.PPrint
-- import qualified Language.Haskell.TH as TH
+------------------------------------------------------------------------}}}
+-- Utilities {{{
+
+-- | Since the entire type of an AsK3 is phantom, we can, of course, alter
+-- it at a moment's notice. Note that this is generally probably unwise.
+phantom_ask3e :: forall t e a. AsK3E e t -> AsK3E e a
+phantom_ask3e (AsK3E f) = AsK3E f
+
+{- XXX k3ref
+-- | Shift the phantom type for a reference inside AsK3E's interpretation
+phantom_ref :: AsK3E e (Ref (AsK3E e) a) -> AsK3E e (Ref r a)
+phantom_ref = phantom_ask3e
+-}
+
+{-
+-- | Shift the phantom type for a collection inside AsK3E's interpretation
+phantom_coll :: AsK3E e (CTE (AsK3E e) c a) -> AsK3E e (CTE r c a)
+phantom_coll = phantom_ask3e
+-}
------------------------------------------------------------------------}}}
-- Collection handling {{{
-- Pattern handling {{{
rec_k3pfn :: PDat UnivTyRepr w
- -> ReaderT Bool (State Int) (Doc e, PatReprFn (AsK3E e) w)
-rec_k3pfn = local (const False) . k3pfn
+ -> ReaderT (Doc e,Bool) (State Int) (Doc e, PatReprFn (AsK3E e) w)
+rec_k3pfn = local (\(a,_) -> (a,False)) . k3pfn
-- | Turn a pattern into two parts: the string to be placed after the
-- \ in the K3 code and the constitutent pieces to be passed into the
-- HOAS function given to eLam
-k3pfn :: PDat UnivTyRepr w -> ReaderT Bool (State Int) (Doc e, PatReprFn (AsK3E e) w)
+k3pfn :: PDat UnivTyRepr w -> ReaderT (Doc e,Bool) (State Int) (Doc e, PatReprFn (AsK3E e) w)
k3pfn (PVar tr) = do
n <- lift incState
- let sn = text $ "x" ++ show n
+ (pfx,_) <- ask
+ let sn = pfx <> pretty n
return (sn <> colon <> unAsK3Ty (unUTR tr)
,AsK3E$ const$ sn)
k3pfn PUnk = return ("_", ())
k3pfn (PJust w) = rec_k3pfn w >>= \(p,r) -> return ("just" <+> parens p, r)
--- XXX k3ref
--- k3pfn (PRef w) = rec_k3pfn w
-k3pfn (PHL HRN) = ask >>= \f -> return (if f then "" else "()", HN)
+k3pfn (PRef w) = rec_k3pfn w
+k3pfn (PHL HRN) = ask >>= \(_,f) -> return (if f then "" else "()", HN)
k3pfn (PHL (w :++ ws)) = do
(pw,rw) <- k3pfn w
- (ps,rs) <- local (const True) $ k3pfn (PHL ws)
- p <- asks (\f -> (if f then (comma <>) else parens) (pw <> ps))
+ (ps,rs) <- local (\(a,_) -> (a,True)) $ k3pfn (PHL ws)
+ p <- asks (\(_,f) -> (if f then (comma <>) else id) (pw <> ps))
let r = rw :+ rs
return (p,r)
k3pfn (PT2 (a,b)) = do
(pa,ra) <- k3pfn a
(pb,rb) <- k3pfn b
- let p = tupled [pa,pb]
+ let p = sepBy comma [pa,pb]
let r = (ra,rb)
return (p,r)
k3pfn (PT3 (a,b,c)) = do
(pa,ra) <- k3pfn a
(pb,rb) <- k3pfn b
(pc,rc) <- k3pfn c
- let p = tupled [pa,pb,pc]
+ let p = sepBy comma [pa,pb,pc]
let r = (ra,rb,rc)
return (p,r)
k3pfn (PT4 (a,b,c,d)) = do
(pb,rb) <- k3pfn b
(pc,rc) <- k3pfn c
(pd,rd) <- k3pfn d
- let p = tupled [pa,pb,pc,pd]
+ let p = sepBy comma [pa,pb,pc,pd]
let r = (ra,rb,rc,rd)
return (p,r)
k3pfn (PT5 (a,b,c,d,e)) = do
(pc,rc) <- k3pfn c
(pd,rd) <- k3pfn d
(pe,re) <- k3pfn e
- let p = tupled [pa,pb,pc,pd,pe]
+ let p = sepBy comma [pa,pb,pc,pd,pe]
let r = (ra,rb,rc,rd,re)
return (p,r)
+run_k3pfn :: Doc e
+ -> PDat UnivTyRepr w
+ -> Int
+ -> ((Doc e, PatReprFn (AsK3E e) w), Int)
+run_k3pfn pfx w n = runState (runReaderT (k3pfn w) (pfx,False)) n
+
------------------------------------------------------------------------}}}
-- Slice handling {{{
k3sfn (PJust s) = do
p <- rec_k3sfn s
return $ AsK3E$ \n -> "just" <> parens (unAsK3E p n)
-{- XXX k3ref
k3sfn (PRef x) = do
p <- rec_k3sfn x
- return $ AsK3E$ unAsK3E p -- coerce
--}
+ return $ phantom_ask3e p
k3sfn (PHL HRN) = asks (\f -> AsK3E$ const$ if f then "" else "()")
k3sfn (PHL (w :++ ws)) = do
pw <- k3sfn w
pc <- k3sfn c
pd <- k3sfn d
return$ AsK3E$ \n -> tupled [unAsK3E pa n, unAsK3E pb n
- ,unAsK3E pc n, unAsK3E pd n]
+ ,unAsK3E pc n, unAsK3E pd n]
k3sfn (PT5 (a,b,c,d,e)) = do
pa <- k3sfn a
pb <- k3sfn b
pd <- k3sfn d
pe <- k3sfn e
return$ AsK3E$ \n -> tupled [unAsK3E pa n, unAsK3E pb n
- ,unAsK3E pc n, unAsK3E pd n
- ,unAsK3E pe n]
+ ,unAsK3E pc n, unAsK3E pd n
+ ,unAsK3E pe n]
------------------------------------------------------------------------}}}
tHL us = AsK3Ty $ tupled $ hrlproj unAsK3Ty us
+instance Show (AsK3Ty e a) where
+ show (AsK3Ty f) = show f
+
+sht :: AsK3Ty e a -> Doc e
+sht = unAsK3Ty
+
------------------------------------------------------------------------}}}
-- Expression handling {{{
cInt n = AsK3E$ const$ text$ show n
cString n = AsK3E$ const$ text$ show n
cNothing = AsK3E$ const$ "nothing"
- cUnit = AsK3E$ const$ "unit"
+ cUnit = AsK3E$ const$ "()"
eJust (AsK3E a) = builtin "just" [ a ]
eLeq = binop PrecBOComp "<="
eNeq = binop PrecBOComp "!="
- eLam w f = AsK3E$ \(n,_) -> let ((pat, arg),n') = runState (runReaderT (k3pfn w) False) n
- in "\\" <> pat <+> "->" `above` indent 2 (unAsK3E (f arg) (n',PrecLowest))
+ eLam w f = AsK3E$ \(n,_) -> let ((pat, arg),n') = run_k3pfn "x" w n
+ in "\\" <> parens pat <+> "->" `above`
+ indent 2 (unAsK3E (f arg) (n',PrecLowest))
- eApp (AsK3E f) (AsK3E x) = AsK3E$ \n ->
- parens (parens (f n) </> parens (x n))
+ eApp (AsK3E f) (AsK3E x) = AsK3E$ \(n,_) ->
+ parens (parens (f (n,PrecApp)) </> parens (x (n,PrecApp)))
eBlock ss (AsK3E r) = AsK3E$ \(n,_) ->
"do" <> (semiBraces (map ($ (n,PrecLowest)) ((map unAsK3E ss) ++ [r])))
eDelete (AsK3E c) (AsK3E e) = builtin "delete" [ c, e ]
eUpdate (AsK3E c) (AsK3E o) (AsK3E n) = builtin "update" [ c, o, n ]
- -- XXX k3ref
- -- eAssign = binop PrecBOComp "<-"
+ eAssign = binop PrecBOComp ":="
eSend (AsK3E a) (AsK3E f) (AsK3E x) = builtin "send" [ a, f, x ]
builtin :: Doc e -> [ (Int,Prec) -> Doc e ] -> AsK3E e b
builtin fn as = AsK3E$ \(n,_) -> fn <> tupled (map ($ (n,PrecLowest)) as)
-{-
--- | Since the entire type of an AsK3 is phantom, we can, of course, alter
--- it at a moment's notice. Note that this is generally probably unwise.
-phantom_ask3e :: forall t e a. AsK3E e t -> AsK3E e a
-phantom_ask3e (AsK3E f) = AsK3E f
-
-{- XXX k3ref
--- | Shift the phantom type for a reference inside AsK3E's interpretation
-phantom_ref :: AsK3E e (Ref (AsK3E e) a) -> AsK3E e (Ref r a)
-phantom_ref = phantom_ask3e
--}
-
--- | Shift the phantom type for a collection inside AsK3E's interpretation
-phantom_coll :: AsK3E e (CTE (AsK3E e) c a) -> AsK3E e (CTE r c a)
-phantom_coll = phantom_ask3e
--}
-
instance Show (AsK3E e a) where
show (AsK3E f) = show $ f inist
sh :: AsK3E e a -> Doc e
sh f = unAsK3E f inist
-instance Show (AsK3Ty e a) where
- show (AsK3Ty f) = show f
+------------------------------------------------------------------------}}}
+-- Declaration handling: data synthesis from types (XXX JUNK?) {{{
-sht :: AsK3Ty e a -> Doc e
-sht = unAsK3Ty
+{-
+
+-- | Produce a textual representation of a K3 type
+--
+-- Unlike AsK3E below, we don't need to thread a variable counter
+-- around since K3 doesn't have tyvars
+newtype AsK3TyDat e (a :: *) = AsK3TyDat { unAsK3TyDat :: State Int (AsK3E e a) }
+
+mkvar :: AsK3TyDat e a
+mkvar = AsK3TyDat$ incState >>= \n -> return $ AsK3E $ \_ -> text ("a" ++ (show n))
+
+instance K3Ty (AsK3TyDat e) where
+ tAnn = const
+
+ tAddress = mkvar
+ tBool = mkvar
+ tByte = mkvar
+ tFloat = mkvar
+ tInt = mkvar
+ tString = mkvar
+ tUnit = mkvar
+ tTarget _ = mkvar
+ tMaybe _ = mkvar
+ tColl _ _ = mkvar
+ tFun _ _ = mkvar
+
+ -- XXX k3ref
+ -- tRef (AsK3Ty ta) = AsK3Ty$ "ref" <+> ta
+
+ -- XXX TUPLES
+ tTuple2 _ = mkvar
+ tTuple3 _ = mkvar
+ tTuple4 _ = mkvar
+ tTuple5 _ = mkvar
+
+ tHL _ = mkvar
+-}
+
+------------------------------------------------------------------------}}}
+-- Declaration handling: printout {{{
declKeyword :: DBody t -> Doc e
-declKeyword (DColl _) = "declare"
-declKeyword (DTrig _) = "trigger"
--- declKeyword DRef = "declare"
-declKeyword (DFunc _) = "declare"
+declKeyword (DColl _) = "declare"
+declKeyword (DTrig _ _) = "trigger"
+declKeyword (DRef _ _) = "declare"
+declKeyword (DFunc _ _ _ _) = "declare"
shdk :: DBody t -> Doc e
shdk d = case d of
- (DColl ty) -> align (colon <+> sht (unUTR ty))
- (DTrig b) -> renderBody b
- -- XXX k3ref
- -- shdk DRef = empty
- (DFunc b) -> renderBody b
+ (DColl ty) -> colon <+> sht (unUTR ty)
+ (DTrig p f) -> let ((pvs,args),_) = run_k3pfn "a" p 0
+ in parens pvs
+ <+> text "{}" -- XXX
+ <+> equals
+ <+> sh (f args)
+
+ (DRef ty i) -> colon <+> sht (unUTR ty)
+ <> renderBody i
+ (DFunc ta tb p f) -> colon <+> sht (unUTR $ tFun ta tb)
+ <> renderBody (eLam p f)
+
where
- renderBody b = space <> equals `aboveBreak`
- (indent 2 $ unAsK3E b inist)
+ renderBody b = space <> equals `aboveBreak` (indent 2 $ sh b)
shd :: Decl s t -> Doc e
shd (Decl (Var name) {- tipe -} body) =
declKeyword body
<+> text name
- <+> shdk body
- <> semi
+ <+> align (shdk body)
<> line
------------------------------------------------------------------------}}}
shk3 r = (case r of (Prog d) -> shd d,
case r of (Prog (Decl _ b)) -> map shex $ M.elems $ cdk b)
-{-
+{- XXX JUNK
+ -
-- | Produce a textual representation of a K3 program, including all
-- referenced declarations.
---
--- XXX I would rather do this differently, if I can, but for the moment,
--- this suffices.
data AsK3P e (a :: *) = AsK3P { ask3p_exp :: AsK3E e a
, ask3p_decls :: M.Map VarIx (Doc e)
}
-}
------------------------------------------------------------------------}}}
--- Template Haskell splices {{{
+-- Template Haskell splices (XXX) {{{
{-
$ ls
))
-}
+
+------------------------------------------------------------------------}}}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
-module Dyna.BackendK3.Selftest where
+module Dyna.Backend.K3.Selftest where
-import Dyna.BackendK3.AST
-import Dyna.BackendK3.Automation
-import Dyna.BackendK3.Render
+import Dyna.Backend.K3.AST
+import Dyna.Backend.K3.Automation
+import Dyna.Backend.K3.Render
import Dyna.XXX.HList
import qualified Test.Framework as TF
import Test.Framework.Providers.HUnit
module Dyna.Test.Main where
import Test.Framework
-import qualified Dyna.BackendK3.Selftest as DK3S
-import qualified Dyna.ParserHS.Selftest as DPHS
-import qualified Dyna.XXX.TrifectaTests as DXT
+import qualified Dyna.Backend.K3.Selftest as DK3S
+import qualified Dyna.ParserHS.Selftest as DPHS
+import qualified Dyna.XXX.TrifectaTests as DXT
main :: IO ()
main = defaultMain
[DPHS.selftest
- ,DK3S.selftest
+ -- XXX Until this is meaningful...
+ -- ,DK3S.selftest
, DXT.selftest
]
projects / dyna2 / commitdiff