From 6df9e64249d2b5d17cf5925cd4d661522602ed84 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 18 Dec 2012 18:17:10 -0500 Subject: [PATCH] Move the K3 backend to Backend.K3 --- dyna.cabal | 11 +- src/Dyna/{BackendK3 => Backend/K3}/AST.hs | 149 ++++++++++---- .../{BackendK3 => Backend/K3}/Automation.hs | 4 +- .../{BackendK3 => Backend/K3}/CollectDecls.hs | 21 +- .../{BackendK3 => Backend/K3}/Examples.hs | 3 +- src/Dyna/{BackendK3 => Backend/K3}/Render.hs | 192 +++++++++++------- .../{BackendK3 => Backend/K3}/Selftest.hs | 8 +- src/Dyna/Test/Main.hs | 9 +- 8 files changed, 258 insertions(+), 139 deletions(-) rename src/Dyna/{BackendK3 => Backend/K3}/AST.hs (87%) rename src/Dyna/{BackendK3 => Backend/K3}/Automation.hs (99%) rename src/Dyna/{BackendK3 => Backend/K3}/CollectDecls.hs (92%) rename src/Dyna/{BackendK3 => Backend/K3}/Examples.hs (99%) rename src/Dyna/{BackendK3 => Backend/K3}/Render.hs (82%) rename src/Dyna/{BackendK3 => Backend/K3}/Selftest.hs (94%) diff --git a/dyna.cabal b/dyna.cabal index af66fc0..5553cb1 100644 --- a/dyna.cabal +++ b/dyna.cabal @@ -3,7 +3,7 @@ Version: 0.4 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 @@ -30,9 +30,9 @@ Library 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, @@ -69,6 +69,7 @@ Executable drepl haskeline >=0.6, mtl >=2.1, parsers >=0.2, + process >=1.1, reducers >=3.0, semigroups >=0.8, tagged >= 0.4.4, @@ -109,6 +110,6 @@ Test-suite dyna-selftests 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 diff --git a/src/Dyna/BackendK3/AST.hs b/src/Dyna/Backend/K3/AST.hs similarity index 87% rename from src/Dyna/BackendK3/AST.hs rename to src/Dyna/Backend/K3/AST.hs index ea63706..c218233 100644 --- a/src/Dyna/BackendK3/AST.hs +++ b/src/Dyna/Backend/K3/AST.hs @@ -38,7 +38,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall -Werror #-} -module Dyna.BackendK3.AST ( +module Dyna.Backend.K3.AST ( -- * Preliminaries VarIx(..), AddrIx(..), Target, @@ -76,7 +76,9 @@ module Dyna.BackendK3.AST ( -- * Declarations Decl(..), DBody(..), asR, asCollR, {- asRefR, -} - mkCollDecl, mkTrigDecl, -- unUDR, + mkCollDecl, mkRefDecl, mkTrigDecl, mkFuncDecl, -- unUDR, + + K3Proxied, K3Unproxy, -- * Programs mkK3, mkK3T, MkK3T, Prog(..) @@ -119,11 +121,13 @@ instance K3BaseTy () 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 :: *) :: * @@ -159,6 +163,9 @@ type instance MapK3Unproxy r (a ': as) = K3Unproxy r a ': (MapK3Unproxy r as) 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) @@ -228,7 +235,10 @@ asColl = const ------------------------------------------------------------------------}}} -- 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 @@ -236,7 +246,6 @@ instance (K3BaseTy a) => K3BaseTy (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 {{{ @@ -252,10 +261,8 @@ data PKind where -- | Just patterns (see 'PJust') PKJust :: PKind -> PKind -{- XXX k3ref -- | Ref patterns (see 'PRef') PKRef :: PKind -> PKind - -} -- | HList patterns PKHL :: [PKind] -> PKind @@ -292,10 +299,8 @@ data PDat (r :: * -> *) (k :: PKind) where -- "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) @@ -351,23 +356,21 @@ instance (Pat w) => Pat (PKJust w) where 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 '[] = () @@ -382,11 +385,11 @@ instance (MapPatConst ts) -- ** 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]) :: [*] @@ -408,9 +411,9 @@ instance (MapPatConst ts) -- 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 @@ -596,6 +599,18 @@ instance BiNum Float Int where -- 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 @@ -657,7 +672,9 @@ class K3 (r :: * -> *) where -- 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 @@ -728,8 +745,7 @@ class K3 (r :: * -> *) where -- -- 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. -- @@ -791,19 +807,26 @@ data DBody dt where 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 @@ -823,29 +846,61 @@ data Prog = forall s t . Prog (Decl s t) 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)) @@ -877,3 +932,11 @@ asRefR = const -} ------------------------------------------------------------------------}}} +-- Template Haskell splices (THSPLICE) {{{ + +$(mkTupleRecInstances ''K3BaseTy []) +$(mkTyMapFlat 1 ''TMapPatTy ''PatTy) +$(mkTyMapFlat 1 ''TMapPatBTy ''PatBTy) +$(mkTyMapFlat 1 ''TMapPatReprFn ''PatReprFn) + +------------------------------------------------------------------------}}} diff --git a/src/Dyna/BackendK3/Automation.hs b/src/Dyna/Backend/K3/Automation.hs similarity index 99% rename from src/Dyna/BackendK3/Automation.hs rename to src/Dyna/Backend/K3/Automation.hs index e87462a..b40cc1c 100644 --- a/src/Dyna/BackendK3/Automation.hs +++ b/src/Dyna/Backend/K3/Automation.hs @@ -19,7 +19,7 @@ {-# 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, @@ -31,7 +31,7 @@ module Dyna.BackendK3.Automation ( ) where import Data.Word -import Dyna.BackendK3.AST +import Dyna.Backend.K3.AST import Dyna.XXX.HList -- import Dyna.XXX.THTuple diff --git a/src/Dyna/BackendK3/CollectDecls.hs b/src/Dyna/Backend/K3/CollectDecls.hs similarity index 92% rename from src/Dyna/BackendK3/CollectDecls.hs rename to src/Dyna/Backend/K3/CollectDecls.hs index 9b30e7d..72ed155 100644 --- a/src/Dyna/BackendK3/CollectDecls.hs +++ b/src/Dyna/Backend/K3/CollectDecls.hs @@ -17,11 +17,11 @@ {-# 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) @@ -43,6 +43,7 @@ mkpc PUnk = () 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) @@ -52,8 +53,9 @@ mkpc (PT5 (a,b,c,d,e)) = (mkpc a, mkpc b, mkpc c, mkpc d, mkpc e) 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 @@ -73,7 +75,6 @@ cslice (PT5 (a,b,c,d,e)) = 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 @@ -140,14 +141,12 @@ instance K3 C where 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) diff --git a/src/Dyna/BackendK3/Examples.hs b/src/Dyna/Backend/K3/Examples.hs similarity index 99% rename from src/Dyna/BackendK3/Examples.hs rename to src/Dyna/Backend/K3/Examples.hs index 5007553..4cab237 100644 --- a/src/Dyna/BackendK3/Examples.hs +++ b/src/Dyna/Backend/K3/Examples.hs @@ -15,8 +15,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} - -module Dyna.BackendK3.Examples where +module Dyna.Backend.K3.Examples where import Dyna.BackendK3.AST import Dyna.BackendK3.Automation diff --git a/src/Dyna/BackendK3/Render.hs b/src/Dyna/Backend/K3/Render.hs similarity index 82% rename from src/Dyna/BackendK3/Render.hs rename to src/Dyna/Backend/K3/Render.hs index 006255e..96ec79b 100644 --- a/src/Dyna/BackendK3/Render.hs +++ b/src/Dyna/Backend/K3/Render.hs @@ -21,7 +21,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-} -module Dyna.BackendK3.Render ( +module Dyna.Backend.K3.Render ( -- * K3 implementations AsK3Ty(..), AsK3E(..), @@ -35,14 +35,34 @@ import qualified Data.List as DL 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 {{{ @@ -61,40 +81,40 @@ k3cfn_sing CBag (AsK3E e) = AsK3E$ encBag . e -- 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 @@ -102,7 +122,7 @@ 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 @@ -111,10 +131,16 @@ 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 {{{ @@ -129,11 +155,9 @@ k3sfn PUnk = return $ AsK3E$ const$ text "_" 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 @@ -155,7 +179,7 @@ k3sfn (PT4 (a,b,c,d)) = do 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 @@ -163,8 +187,8 @@ k3sfn (PT5 (a,b,c,d,e)) = do 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] ------------------------------------------------------------------------}}} @@ -301,6 +325,12 @@ instance K3Ty (AsK3Ty e) where 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 {{{ @@ -334,7 +364,7 @@ instance K3 (AsK3E e) where 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 ] @@ -363,11 +393,12 @@ instance K3 (AsK3E e) where 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]))) @@ -393,8 +424,7 @@ instance K3 (AsK3E e) where 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 ] @@ -416,58 +446,84 @@ binop p' o (AsK3E a) (AsK3E b) = 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 ------------------------------------------------------------------------}}} @@ -480,12 +536,10 @@ shk3 :: Prog -> (Doc e, [Doc e]) 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) } @@ -555,7 +609,7 @@ instance K3 (AsK3P e) where -} ------------------------------------------------------------------------}}} --- Template Haskell splices {{{ +-- Template Haskell splices (XXX) {{{ {- @@ -580,3 +634,5 @@ $(do $ ls )) -} + +------------------------------------------------------------------------}}} diff --git a/src/Dyna/BackendK3/Selftest.hs b/src/Dyna/Backend/K3/Selftest.hs similarity index 94% rename from src/Dyna/BackendK3/Selftest.hs rename to src/Dyna/Backend/K3/Selftest.hs index 523b14a..3088ab6 100644 --- a/src/Dyna/BackendK3/Selftest.hs +++ b/src/Dyna/Backend/K3/Selftest.hs @@ -5,11 +5,11 @@ {-# 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 diff --git a/src/Dyna/Test/Main.hs b/src/Dyna/Test/Main.hs index bf3df51..a7be1b6 100644 --- a/src/Dyna/Test/Main.hs +++ b/src/Dyna/Test/Main.hs @@ -3,13 +3,14 @@ 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 ] -- 2.50.1