From 0c042907374ac73e4dc4081ddbf3bff5f439a049 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 30 Oct 2012 02:31:14 -0400 Subject: [PATCH] Scattered progress on K3 backend --- src/Dyna/BackendK3/AST.hs | 195 ++++++++++++++++++++----------- src/Dyna/BackendK3/Automation.hs | 24 +++- src/Dyna/BackendK3/Examples.hs | 2 - src/Dyna/BackendK3/Render.hs | 180 +++++++++++++++++++--------- src/Dyna/BackendK3/Selftest.hs | 4 +- 5 files changed, 279 insertions(+), 126 deletions(-) diff --git a/src/Dyna/BackendK3/AST.hs b/src/Dyna/BackendK3/AST.hs index 032cdc4..e3731b3 100644 --- a/src/Dyna/BackendK3/AST.hs +++ b/src/Dyna/BackendK3/AST.hs @@ -29,31 +29,39 @@ {-# LANGUAGE UndecidableInstances #-} module Dyna.BackendK3.AST ( - HList(..), HRList(..), - - VarIx(..), AddrIx(..), + -- * Preliminaries + VarIx(..), AddrIx(..), Target, + -- * Numeric Autocasting BiNum(..), UnNum(..), - CTE, CKind(..), CollTy(..), + -- * Collections + CTE, CKind(..), CollTy(..), K3_Coll_C, asColl, + -- * References Ref, + -- * Pattern System PKind(..), Pat(..), PVar(..), PUnk(..), PJust(..), PRef(..), - MapPatConst, + UnPatDa, + MapPatDa, UnMapPatDa, MapPatTy, + MapPatConst, K3_Pat_C, K3_Slice_C, - Ann(..), FunDepSpec(..), + -- * Annotations + AnnT(..), AnnE(..), FunDepSpec(..), K3_Xref_C, + -- * Type System: Base constraints K3BaseTy, + -- * Type System: Representations K3Ty(..), UnivTyRepr(..), - K3(..), K3_Pat_C, K3_Coll_C, K3_Slice_C, - - asColl, + -- * Expressions + K3(..), - Decl(..), mkdecl, mkfdecl, asCollR, asRefR + -- * Declarations + Decl(..), DKind(..), mkdecl, mkfdecl, asCollR, asRefR ) where import Data.Word @@ -64,7 +72,7 @@ import Dyna.XXX.HList import Dyna.XXX.THTuple ------------------------------------------------------------------------}}} -{- * Preliminaries -} -- {{{ +-- Preliminaries {{{ -- XXX newtype VarIx = Var String @@ -73,7 +81,7 @@ newtype AddrIx = Addr (String,Int) deriving (Eq,Show) ------------------------------------------------------------------------}}} -{- * Type System: Base Constraints -} -- {{{ +-- Type System: Base Constraints {{{ -- | A constraint for /base/ types in K3. These are the things that can -- be passed to lambdas. Essentially everything other than arrows. @@ -90,7 +98,20 @@ instance (K3BaseTy a, K3BaseTy (HList as)) => K3BaseTy (HList (a ': as)) $(mkTupleRecInstances ''K3BaseTy []) ------------------------------------------------------------------------}}} -{- * Collections -} -- {{{ +-- Targets {{{ + +-- | The 'r' representation of a target taking argument type 't'. +-- +-- This is similar to @t -> ()@ except that it executes in a different +-- transaction and must be named. The only safe source of Targets is a +-- 'Decl', but being first class, they can be stored in collections for +-- dynamic dispatch. +data family Target (r :: * -> *) t :: * + +instance (K3BaseTy a) => K3BaseTy (Target r a) + +------------------------------------------------------------------------}}} +-- Collections {{{ -- | Reflect 'CollTy' at the type level. data CKind = CBag | CList | CSet @@ -110,8 +131,14 @@ instance (K3BaseTy a) => K3BaseTy (CTE r c a) -- which need to dispatch on a type-tag in the output. type family K3_Coll_C (r :: * -> *) (c :: CKind) :: Constraint +-- | A convenience function for setting the type of a collection. +-- +-- Use as (eEmpty `asColl` CTSet) +asColl :: r (CTE r c t) -> CollTy c -> r (CTE r c t) +asColl = const + ------------------------------------------------------------------------}}} -{- * References -} -- {{{ +-- References {{{ -- | The 'r' representation of references of elements of type 'a' data family Ref (r :: * -> *) a @@ -119,7 +146,7 @@ data family Ref (r :: * -> *) a instance (K3BaseTy a) => K3BaseTy (Ref r a) ------------------------------------------------------------------------}}} -{- * Pattern System -} -- {{{ +-- Pattern System {{{ -- | Kinds of patterns permitted in K3 data PKind where @@ -185,6 +212,9 @@ class (UnPatDa (PatDa w) ~ w) => Pat (r :: * -> *) (w :: PKind) where -- | Given a chunk of pattern data, recover the PKind. type family UnPatDa (pd :: *) :: PKind +-- | Given a PatReprFn output and type constructor input, recover the PKind +type family UnPatReprFn (s :: * -> *) (prf :: *) :: PKind + -- | A variable used literally in a pattern newtype PVar r a = PVar (r a) type instance UnPatDa (PVar r a) = PKVar r a @@ -198,7 +228,7 @@ instance (K3BaseTy a, r ~ r') => Pat r' (PKVar (r :: * -> *) (a :: *)) where -- -- Note that 'PatReprFn s (PUnk a) ~ ()', which should prohibit even -- accidental use as part of a 'K3' expression or type. -data PUnk a = PUnk +data PUnk (a :: *) = PUnk type instance UnPatDa (PUnk a) = PKUnk a instance (K3BaseTy a) => Pat r (PKUnk (a :: *)) where type PatDa (PKUnk a) = PUnk a @@ -295,7 +325,7 @@ type family K3_Pat_C (r :: * -> *) (w :: PKind) :: Constraint type family K3_Slice_C (r :: * -> *) (w :: PKind) :: Constraint ------------------------------------------------------------------------}}} -{- * Annotations -} -- {{{ +-- Annotations {{{ -- | Specification for functional dependencies within a collection. -- @@ -307,56 +337,79 @@ data FunDepSpec a = FDIrr -- ^ /Irr/elevant to a fundep | FDCod -- ^ In the /Cod/omain of a fundep deriving (Eq,Show) --- | Annotations on 'K3' expressions or 'K3Ty' types. --- --- XXX should really do something smarter -data Ann a where +-- | A representation-specific constraint for cross-references +type family K3_Xref_C (r :: * -> *) (w :: PKind) :: Constraint - -- | Decorate an expression as atomic. - AAtomic :: Ann a +-- | Annotations on 'K3Ty' types +data AnnT a where -- | A functional dependency among elements of a collection. AFunDep :: (RTupled fs, RTR fs ~ FunDepSpec, RTE fs ~ a) - => fs -> Ann (CTE r t a) + => fs -> AnnT (CTE r t a) -- | Request an additional index on a collection AIndex :: (RTupled fs, RTR fs ~ FunDepSpec, RTE fs ~ a) - => fs -> Ann (CTE r t a) + => fs -> AnnT (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 + AOneOf :: (RTupled mv, RTR mv ~ Maybe) => AnnT mv -- | 'AFunDep' for HList representations - AFunDepHL :: HRList FunDepSpec a -> Ann (CTE r t (HList a)) + AFunDepHL :: HRList FunDepSpec a -> AnnT (CTE r t (HList a)) -- | 'AIndex' for HList representations - AIndexHL :: HRList FunDepSpec a -> Ann (CTE r t (HList a)) + AIndexHL :: HRList FunDepSpec a -> AnnT (CTE r t (HList a)) -- | 'AOneOf' for HList representations + AOneOfHL :: (HLR Maybe v mv) => AnnT (HList mv) + + -- | A cross-reference within this collection -- - -- XXX Constraints by analogy to AOneOf - AOneOfHL :: Ann (HList mv) + -- XXX this is not actually implemented anywhere and has yet to be + -- demonstrated as being implementable + AXref :: (PatTy r w ~ t, w ~ UnPatDa (PatDa w)) + => PatDa w -> (forall p . PatReprFn p w -> p x) + -- Foreign projection + -> PatDa w -> (forall p . PatReprFn p w -> p x) + -> AnnT (CTE r c' t) + + -- | A cross-reference to a declared collection. + -- + -- XXX this is not actually implemented anywhere and has yet to be + -- demonstrated as being implementable + AXrefF :: (Pat p w, Pat p w', PatTy p w ~ t, PatTy p w' ~ t') + => Decl UnivTyRepr r' (CTE r' c t) -- Foreign collection + -> PatDa w + -> (PatReprFn p w -> p x) -- Foreign projection + -> PatDa w' + -> (PatReprFn p w' -> p x) -- Local projection + -> AnnT (CTE r c' t') -{- - - XXX - -- | A cross-reference between collections - AXref :: r' (CTE rf tf af) - -> ??? - -> Ann (CTE rt tt at) --} + -- | An escape hatch! (XXX) + ATMisc :: String -> AnnT a + + +-- | Annotations on 'K3' expressions +data AnnE a where + + -- | Decorate an expression as atomic. + AAtomic :: AnnE a + + -- | + ASingleton :: AnnE (CTE r t a) -- | An escape hatch! (XXX) - AMisc :: String -> Ann a + AEMisc :: String -> AnnE a ------------------------------------------------------------------------}}} -{- * Type System -} -- {{{ +-- 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 :: r a -> [Ann a] -> r a + tAnn :: r a -> [AnnT a] -> r a tAddress :: r AddrIx tBool :: r Bool @@ -364,6 +417,7 @@ class K3Ty (r :: * -> *) where tFloat :: r Float tInt :: r Int tString :: r String + tTarget :: r t -> r (Target r' t) tUnit :: r () -- tPair :: r a -> r b -> r (a,b) @@ -396,6 +450,7 @@ instance K3Ty UnivTyRepr where tFloat = UTR tFloat tInt = UTR tInt tString = UTR tString + tTarget (UTR t) = UTR $ tTarget t tUnit = UTR tUnit tColl c (UTR a) = UTR $ tColl c a @@ -413,7 +468,7 @@ instance K3Ty UnivTyRepr where tHL us = UTR $ tHL $ hrlmap unUTR us ------------------------------------------------------------------------}}} -{- * Numeric Autocasting -} -- {{{ +-- Numeric Autocasting {{{ -- XXX should we make these be constraints in the K3 class so that -- different representations can make different choices? @@ -430,6 +485,7 @@ class BiNum a b where biadd :: a -> b -> BNTF a b bimul :: a -> b -> BNTF a b +-- | And and Or are captured as binary numerics instance BiNum Bool Bool where type BNTF Bool Bool = Bool biadd = (||) @@ -459,7 +515,7 @@ instance BiNum Float Int where -- XXX More ------------------------------------------------------------------------}}} -{- * Values and Expressions -} -- {{{ +-- Expressions {{{ -- | Data level representation of K3 expression, indexed by equivalent -- type in Haskell. @@ -468,7 +524,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 :: r a -> [Ann a] -> r a + cAnn :: r a -> [AnnE a] -> r a cAddress :: AddrIx -> r AddrIx cBool :: Bool -> r Bool @@ -481,6 +537,8 @@ class K3 (r :: * -> *) where -- | Reference the given variable (and promise that it has type 'a') -- + -- Note that this is, for example, the only way of producing Targets. + -- -- XXX replace with something more like declvar so that, in theory, a -- sufficiently smart "r" might know what to do about it? -- @@ -488,6 +546,8 @@ class K3 (r :: * -> *) where -- to get something like "The K3 Way" of doing local variables? unsafeVar :: VarIx -> UnivTyRepr a -> r a + declVar :: Decl UnivTyRepr r a -> r a + eJust :: r a -> r (Maybe a) eRef :: r a -> r (Ref r a) @@ -599,34 +659,37 @@ class K3 (r :: * -> *) where -- | Send a function and data to another node. -- -- XXX Is there any way to refer to "self" as an addrix? - -- - -- XXX Are there restrictions on the functions that can be sent (do they - -- have to be declarations)? If so, can we expose that by the type - -- system? - eSend :: r AddrIx -> r (a -> ()) -> r a -> r () + eSend :: r AddrIx -> r (Target r a) -> r a -> r () ------------------------------------------------------------------------}}} -{- * Miscellany -} -- {{{ +-- Declarations {{{ --- | A convenience function for setting the type of a collection. --- --- Use as (eEmpty `asColl` CTSet) -asColl :: r (CTE r c t) -> CollTy c -> r (CTE r c t) -asColl = const +-- | K3 supports a few kinds of delcarations at the top level: +data DKind r dt where + -- | Collections + -- + -- XXX No initializers? [t] -> + DKColl :: DKind r (CTE r (c :: CKind) t) + + -- | Global References + DKRef :: DKind r (Ref r t) + + -- | Functions, which execute in the same transaction as the caller + DKFunc :: r (a -> b) -> DKind r (a -> b) + + -- | Triggers, which execute in a different transaction than the caller + DKTrig :: r (t -> ()) -> DKind r (Target r t) -- | A top-level declaration. -- -- XXX does not enumerate local variables -data Decl tr r t = Decl VarIx (tr t) (Maybe (r t)) - --- | Capture a type-constructor as data. -data RCons (r :: * -> *) = RCons +data Decl tr r t = Decl VarIx (tr t) (DKind r t) -- | A utility for setting the type of sub-components of a declaration, by -- constraining polymorphism. Use the 'asCollR' and 'asRefR' combinators --- to avail yourself of the RCons passed in. -mkdecl :: (RCons r -> Decl tr r t) -> Decl tr r t -mkdecl f = f RCons +-- to avail yourself of the Proxy passed in. +mkdecl :: (Proxy r -> Decl tr r t) -> Decl tr r t +mkdecl f = f Proxy -- | Define a fixed-point declaration. Like mkdecl, it continues to assist -- in constraining polymorphism, but also yields a representation of the @@ -636,20 +699,20 @@ mkdecl f = f RCons -- type fields of the Decl being built to construct a K3 AST variable to -- refer to the current definition. mkfdecl :: (K3 r, K3Ty trx) - => (RCons r -> r t -> (forall tr . (K3Ty tr) => Decl tr r t)) + => (Proxy r -> r t -> (forall tr . (K3Ty tr) => Decl tr r t)) -> Decl trx r t -mkfdecl f = let self = (\(Decl n tr _) -> unsafeVar n tr) (f RCons self) - in f RCons self +mkfdecl f = let self = (\(Decl n tr _) -> unsafeVar n tr) (f Proxy self) + in f Proxy self -- | Ensure that the representation type of a collection matches -- -- This is probably most useful when s is a K3Ty and r is a K3, but this may -- be more generally applicable. -asCollR :: s (CTE r c t) -> RCons r -> s (CTE r c t) +asCollR :: s (CTE r c t) -> Proxy r -> s (CTE r c t) asCollR = const -- | Ensure that the representation type of a ref matches -asRefR :: r' (Ref r t) -> RCons r -> r' (Ref r t) +asRefR :: r' (Ref r t) -> Proxy r -> r' (Ref r t) asRefR = const ------------------------------------------------------------------------}}} diff --git a/src/Dyna/BackendK3/Automation.hs b/src/Dyna/BackendK3/Automation.hs index 3252229..1d9d4f1 100644 --- a/src/Dyna/BackendK3/Automation.hs +++ b/src/Dyna/BackendK3/Automation.hs @@ -32,6 +32,7 @@ module Dyna.BackendK3.Automation ( import Data.Word import Dyna.BackendK3.AST +import Dyna.XXX.HList import Dyna.XXX.THTuple ------------------------------------------------------------------------}}} @@ -67,6 +68,7 @@ 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 r a) where autoty = tRef autoty +instance (K3AutoTy a) => K3AutoTy (Target r a) where autoty = tTarget autoty instance (K3AutoTy a, K3BaseTy a, K3AutoTy b, K3BaseTy b) => K3AutoTy (a -> b) where autoty = tFun autoty autoty @@ -105,12 +107,17 @@ instance (K3AutoTyTup (wa ': w) (a,b), K3AutoTyTup w b) -} ------------------------------------------------------------------------}}} -{- * Automate pattern -} -- XXX {{{ +-- Automate pattern (XXX) {{{ -{- -- | Automatically derive a pattern, for use with eLam. --- Note that this is only useful for the (common) case of not using Just --- patterns. +-- Note that this is only useful for the (common) case of not using +-- elimination patterns. + +{- + +type family UnPatReprFn (s :: * -> *) (pr :: *) :: PKind +type instance UnPatReprFn s (s a) = PKVar UnivTyRepr a +type instance UnPatReprFn s (HList '[]) = PKHL '[] class (Pat UnivTyRepr w) => K3AutoPat (w :: PKind) where autopat :: PatDa w @@ -118,6 +125,15 @@ class (Pat UnivTyRepr w) => K3AutoPat (w :: PKind) where instance (K3BaseTy a, K3AutoTy a) => K3AutoPat (PKVar UnivTyRepr a) where autopat = PVar autoty +instance K3AutoPat (PKHL '[]) where + autopat = HN + +instance (K3AutoPat (PKHL ws), + K3AutoPat w, + MapPatConst ws UnivTyRepr) + => K3AutoPat (PKHL (w ': ws)) where + autopat = autopat :+ autopat + class UFAP (w :: [PKind]) where unfoldautopat :: HList (MapPatDa w) instance UFAP '[] where unfoldautopat = HN diff --git a/src/Dyna/BackendK3/Examples.hs b/src/Dyna/BackendK3/Examples.hs index dae525f..5007553 100644 --- a/src/Dyna/BackendK3/Examples.hs +++ b/src/Dyna/BackendK3/Examples.hs @@ -133,5 +133,3 @@ testlocal = macro_localVar autoty testHOF = eLam (PVar undefined) $ \x -> eApp x (cBool True) ------------------------------------------------------------------------}}} --- fin ---------------------------------------------------------------------------- diff --git a/src/Dyna/BackendK3/Render.hs b/src/Dyna/BackendK3/Render.hs index a24acf7..c60c57a 100644 --- a/src/Dyna/BackendK3/Render.hs +++ b/src/Dyna/BackendK3/Render.hs @@ -1,5 +1,8 @@ --------------------------------------------------------------------------- --- | Provides the "AsK3" type and instances for the K3 AST. +-- | Print a K3 AST or Type in a way that the K3 compiler understands. +-- +-- XXX Note that the output is currently hideously ugly. We really should +-- fix that. -- Header material {{{ {-# LANGUAGE ConstraintKinds #-} @@ -32,6 +35,7 @@ import qualified Data.List as DL import Text.PrettyPrint.Free import Dyna.BackendK3.AST +import Dyna.BackendK3.Automation import Dyna.XXX.HList import Dyna.XXX.MonadUtils import Dyna.XXX.THTuple @@ -138,7 +142,7 @@ instance (K3SFn e w, K3SFn e (PKHL ws), MapPatConst ws (AsK3 e)) return$ AsK3$ \n -> fn $ (unAsK3 pw n) <> (unAsK3 ps n) ------------------------------------------------------------------------}}} -{- * Annotations -} -- {{{ +-- Annotations {{{ fdscast :: FunDepSpec a -> FunDepSpec b fdscast FDIrr = FDIrr @@ -164,19 +168,64 @@ annfdshl op fs = <+> op <+> (tupled $ map pretty cod) - -annText :: Ann a -> Doc e -annText AAtomic = "atomic" -annText (AFunDep fs) = annfds "->" fs -annText (AFunDepHL fs) = annfdshl "->" fs -annText (AIndex fs) = annfds "=>" fs -annText (AIndexHL fs) = annfdshl "=>" fs -annText AOneOf = "oneof" -annText AOneOfHL = "oneof" -annText (AMisc s) = text s +{- +newtype K3RXref a = K3RXR { unK3RXR :: String } +class (UnPatDa (PatDa w) ~ w) => RXref (w :: PKind) where + rxref_mk :: PatDa w -> ReaderT String (State Int) (PatReprFn K3RXref w) + +instance (K3BaseTy a) => RXref (PKVar (K3RXref :: * -> *) (a :: *)) where + rxref_mk _ = do + pfx <- ask + ix <- get + return $ K3RXR (pfx <> show ix) + +instance (K3BaseTy a) => RXref (PKUnk (a :: *)) where + rxref_mk _ = return () + +instance (RXref w) => RXref (PKRef w) where + rxref_mk w = do + pfx <- ask + ix <- get + (r,_) <- local (const $ pfx <> show ix) $ bracketState 0 $ rxref_mk w + return r + +instance (UnMapPatDa (HList (MapPatDa ws)) ~ ws, + MapPatConst ws K3RXref, + MapConstraint RXref ws) + => RXref (PKHL '[]) where + rxref_mk HN = return HN + +instance (RXref w, RXref (PKHL ws), + MapPatConst ws K3RXref) + => RXref (PKHL (w ': ws)) where + rxref_mk (w :+ ws) = do + pfx <- ask + ix <- incState + (rw,_) <- local (const $ pfx <> show ix) $ bracketState 0 $ rxref_mk w + rs <- rxref_mk ws + return (rw :+ rs) + +type instance K3_Xref_C K3RXref w = RXref w +-} + +annTText :: AnnT a -> Doc e +annTText (AFunDep fs) = annfds "->" fs +annTText (AFunDepHL fs) = annfdshl "->" fs +annTText (AIndex fs) = annfds "=>" fs +annTText (AIndexHL fs) = annfdshl "=>" fs +annTText AOneOf = "oneof" +annTText AOneOfHL = "oneof" +annTText (AXref _ _ _ _) = "" -- XXX +annTText (AXrefF _ _ _ _ _) = "" -- XXX +annTText (ATMisc s) = text s + +annEText :: AnnE a -> Doc e +annEText AAtomic = "atomic" +annEText ASingleton = "singleton" +annEText (AEMisc s) = text s ------------------------------------------------------------------------}}} -{- * Type handling -} -- {{{ +-- Type handling {{{ -- | Produce a textual representation of a K3 type -- @@ -186,7 +235,7 @@ newtype AsK3Ty e (a :: *) = AsK3Ty { unAsK3Ty :: Doc e } instance K3Ty (AsK3Ty e) where tAnn (AsK3Ty e) anns = AsK3Ty$ align $ - e "@" <+> (encloseSep lbrace rbrace comma $ map annText anns) + e "@" <+> (encloseSep lbrace rbrace comma $ map annTText anns) tAddress = AsK3Ty$ "address" tBool = AsK3Ty$ "bool" @@ -196,6 +245,9 @@ instance K3Ty (AsK3Ty e) where tString = AsK3Ty$ "string" tUnit = AsK3Ty$ "unit" + -- XXX is that right? + tTarget _ = AsK3Ty$ "target" + -- tPair (AsK3Ty ta) (AsK3Ty tb) = AsK3Ty$ tupled [ ta, tb ] tMaybe (AsK3Ty ta) = AsK3Ty$ "Maybe" <+> ta @@ -219,8 +271,17 @@ instance K3Ty (AsK3Ty e) where ------------------------------------------------------------------------}}} -- Expression handling {{{ +data Prec = PrecLowest + | PrecITE + | PrecBOComp + | PrecBOAdd + | PrecBOMul + | PrecNeg + | PrecApp + deriving (Enum,Eq,Ord,Show) + -- | Produce a textual representation of a K3 expression -newtype AsK3 e (a :: *) = AsK3 { unAsK3 :: Int -> Doc e } +newtype AsK3 e (a :: *) = AsK3 { unAsK3 :: (Int,Prec) -> Doc e } type instance K3_Coll_C (AsK3 e) c = K3CFn c type instance K3_Pat_C (AsK3 e) p = K3PFn p @@ -230,7 +291,7 @@ instance K3 (AsK3 e) where cAnn (AsK3 e) anns = AsK3$ \n -> align $ parens (e n) <> " @ " - <> (encloseSep lbrace rbrace comma $ map annText anns) + <> (encloseSep lbrace rbrace comma $ map annEText anns) cComment str (AsK3 a) = AsK3$ \n -> "\n// " <> text str <> "\n" <> a n @@ -244,49 +305,49 @@ instance K3 (AsK3 e) where cNothing = AsK3$ const$ "nothing" cUnit = AsK3$ const$ "unit" - unsafeVar (Var v) _ = AsK3$ const$ text v - + unsafeVar (Var v) _ = AsK3$ const$ text v + declVar (Decl (Var v) _ _) = AsK3$ const$ text v eJust (AsK3 a) = builtin "just" [ a ] eRef (AsK3 a) = builtin "ref" [ a ] -- XXX TUPLES Note the similarity of these! - eTuple2 t = AsK3 $ \n -> tupled $ tupleopEL (flip unAsK3 n) t - eTuple3 t = AsK3 $ \n -> tupled $ tupleopEL (flip unAsK3 n) t - eTuple4 t = AsK3 $ \n -> tupled $ tupleopEL (flip unAsK3 n) t - eTuple5 t = AsK3 $ \n -> tupled $ tupleopEL (flip unAsK3 n) t + eTuple2 t = AsK3 $ \(n,_) -> tupled $ tupleopEL (flip unAsK3 (n,PrecLowest)) t + eTuple3 t = AsK3 $ \(n,_) -> tupled $ tupleopEL (flip unAsK3 (n,PrecLowest)) t + eTuple4 t = AsK3 $ \(n,_) -> tupled $ tupleopEL (flip unAsK3 (n,PrecLowest)) t + eTuple5 t = AsK3 $ \(n,_) -> tupled $ tupleopEL (flip unAsK3 (n,PrecLowest)) t - eHL t = AsK3 $ \n -> tupled $ hrlproj (flip unAsK3 n) t + eHL t = AsK3 $ \(n,_) -> tupled $ hrlproj (flip unAsK3 (n,PrecLowest)) t eEmpty = k3cfn_empty eSing = k3cfn_sing eCombine (AsK3 a) (AsK3 b) = AsK3$ \n -> parens (a n) <> " ++ " <> parens (b n) eRange (AsK3 f) (AsK3 l) (AsK3 s) = builtin "range" [ f, l, s ] - eAdd = binop "+" - eMul = binop "*" - eNeg (AsK3 b) = AsK3$ \n -> "-" <> parens (b n) + eAdd = binop PrecBOAdd "+" + eMul = binop PrecBOMul "*" + eNeg (AsK3 b) = AsK3$ \(n,p) -> np p PrecNeg $ "-" <> (b (n,PrecNeg)) - eEq = binop "==" - eLt = binop "<" - eLeq = binop "<=" - eNeq = binop "!=" + eEq = binop PrecBOComp "==" + eLt = binop PrecBOComp "<" + eLeq = binop PrecBOComp "<=" + eNeq = binop PrecBOComp "!=" - eLam w f = AsK3$ \n -> let ((pat, arg),n') = runState (runReaderT (k3pfn w) False) n - in "\\" <> pat <+> "->" `above` indent 2 (unAsK3 (f arg) n') + eLam w f = AsK3$ \(n,p) -> let ((pat, arg),n') = runState (runReaderT (k3pfn w) False) n + in "\\" <> pat <+> "->" `above` indent 2 (unAsK3 (f arg) (n',p)) eApp (AsK3 f) (AsK3 x) = AsK3$ \n -> - parens (parens (f n) `aboveBreak` parens (x n)) + parens (parens (f n) parens (x n)) - eBlock ss (AsK3 r) = AsK3$ \n -> - "do" <> (semiBraces (map ($ n) ((map unAsK3 ss) ++ [r]))) + eBlock ss (AsK3 r) = AsK3$ \(n,_) -> + "do" <> (semiBraces (map ($ (n,PrecLowest)) ((map unAsK3 ss) ++ [r]))) eIter (AsK3 f) (AsK3 c) = builtin "iterate" [ f, c ] - eITE (AsK3 b) (AsK3 t) (AsK3 e) = AsK3$ \n -> - "if" <+> (align $ above (parens (b n)) - ("then" <+> parens (t n) `aboveBreak` - "else" <+> parens (e n))) + eITE (AsK3 b) (AsK3 t) (AsK3 e) = AsK3$ \(n,p) -> np p PrecITE $ + "if" <+> (align $ above (parens (b (n,PrecLowest))) + ("then" <+> t (n,PrecLowest) `aboveBreak` + "else" <+> e (n,PrecLowest))) eMap (AsK3 f) (AsK3 c) = builtin "map" [ f, c ] eFiltMap (AsK3 f) (AsK3 m) (AsK3 c) = builtin "filtermap" [ f, m, c ] @@ -302,31 +363,36 @@ instance K3 (AsK3 e) where eDelete (AsK3 c) (AsK3 e) = builtin "delete" [ c, e ] eUpdate (AsK3 c) (AsK3 o) (AsK3 n) = builtin "update" [ c, o, n ] - eAssign = binop "<-" + eAssign = binop PrecBOComp "<-" eSend (AsK3 a) (AsK3 f) (AsK3 x) = builtin "send" [ a, f, x ] ------------------------------------------------------------------------}}} -- Miscellany {{{ +inist :: (Int,Prec) +inist = (0,PrecLowest) + encBag :: Doc e -> Doc e encBag = enclose "{|" "|}" +np :: forall a e. Ord a => a -> a -> Doc e -> Doc e +np p p' = (if p > p' then parens else id) + -- Overly polymorphic; use only when correct! -binop :: Doc e -> AsK3 e a -> AsK3 e b -> AsK3 e c -binop o (AsK3 a) (AsK3 b) = AsK3$ \n -> parens (align $ a n) - o - <+> parens (align $ b n) +binop :: Prec -> Doc e -> AsK3 e a -> AsK3 e b -> AsK3 e c +binop p' o (AsK3 a) (AsK3 b) = + AsK3$ \(n,p) -> np p p' $ (align $ a (n,p')) o <+> (align $ b (n,succ p')) -- Overly polymorphic; use only when correct! -builtin :: Doc e -> [ Int -> Doc e ] -> AsK3 e b -builtin fn as = AsK3$ \n -> fn <> tupled (map ($ n) as) +builtin :: Doc e -> [ (Int,Prec) -> Doc e ] -> AsK3 e b +builtin fn as = AsK3$ \(n,_) -> fn <> tupled (map ($ (n,PrecLowest)) as) instance Show (AsK3 e a) where - show (AsK3 f) = show $ f 0 + show (AsK3 f) = show $ f inist sh :: AsK3 e a -> Doc e -sh f = unAsK3 f 0 +sh f = unAsK3 f inist instance Show (AsK3Ty e a) where show (AsK3Ty f) = show f @@ -336,13 +402,23 @@ sht = unAsK3Ty shd :: Decl (AsK3Ty e) (AsK3 e) t -> Doc e shd (Decl (Var name) tipe body) = - "declare " - <> text name + keyword + <+> text name <+> align (colon <+> unAsK3Ty tipe) <> case body of - Nothing -> empty - Just b -> space <> equals `aboveBreak` (indent 2 $ unAsK3 b 0) + DKColl -> empty + DKRef -> empty + (DKFunc b) -> renderBody b + (DKTrig b) -> renderBody b <> semi + where + keyword = case body of + DKColl -> "declare" + DKRef -> "declare" + (DKFunc _) -> "declare" + (DKTrig _) -> "trigger" + + renderBody b = space <> equals `aboveBreak` (indent 2 $ unAsK3 b inist) ------------------------------------------------------------------------}}} -- Template Haskell splices {{{ diff --git a/src/Dyna/BackendK3/Selftest.hs b/src/Dyna/BackendK3/Selftest.hs index 6da9711..6c83d25 100644 --- a/src/Dyna/BackendK3/Selftest.hs +++ b/src/Dyna/BackendK3/Selftest.hs @@ -41,7 +41,7 @@ render = despace . flip displaySimple [] . renderCompact . sh case_mfn :: Assertion case_mfn = e @=? render k3 where - e = "\\x0:int -> -((x0) + (1))" + e = "\\x0:int -> -(x0 + 1)" -- Note that we cannot automate the tInt here, since K3's math -- operators are overloaded, so there's no way to conclude -- the type of a from the occurrance of "a + Int". @@ -59,7 +59,7 @@ case_pairfn = e @=? render k3 case_mcm :: Assertion case_mcm = e @=? render k3 where - e = "if ((test) == (nothing)) then (0) " + e = "if (test == nothing) then (0) " <> "else (((\\just (x0:int) -> x0) (test)))" k3 = caseMaybe tInt (unsafeVar (Var "test") autoty) (cInt 0) (id) -- 2.50.1