{-# 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
import Dyna.XXX.THTuple
------------------------------------------------------------------------}}}
-{- * Preliminaries -} -- {{{
+-- Preliminaries {{{
-- XXX
newtype VarIx = Var String
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.
$(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
-- 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
instance (K3BaseTy a) => K3BaseTy (Ref r a)
------------------------------------------------------------------------}}}
-{- * Pattern System -} -- {{{
+-- Pattern System {{{
-- | Kinds of patterns permitted in K3
data 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
--
-- 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
type family K3_Slice_C (r :: * -> *) (w :: PKind) :: Constraint
------------------------------------------------------------------------}}}
-{- * Annotations -} -- {{{
+-- Annotations {{{
-- | Specification for functional dependencies within a collection.
--
| 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
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)
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
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?
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 = (||)
-- XXX More
------------------------------------------------------------------------}}}
-{- * Values and Expressions -} -- {{{
+-- Expressions {{{
-- | Data level representation of K3 expression, indexed by equivalent
-- type in Haskell.
-- | 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
-- | 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?
--
-- 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)
-- | 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
-- 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
------------------------------------------------------------------------}}}
---------------------------------------------------------------------------
--- | 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 #-}
import Text.PrettyPrint.Free
import Dyna.BackendK3.AST
+import Dyna.BackendK3.Automation
import Dyna.XXX.HList
import Dyna.XXX.MonadUtils
import Dyna.XXX.THTuple
return$ AsK3$ \n -> fn $ (unAsK3 pw n) <> (unAsK3 ps n)
------------------------------------------------------------------------}}}
-{- * Annotations -} -- {{{
+-- Annotations {{{
fdscast :: FunDepSpec a -> FunDepSpec b
fdscast FDIrr = FDIrr
<+> 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
--
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"
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
------------------------------------------------------------------------}}}
-- 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
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
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 ]
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
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 {{{
projects / dyna2 / commitdiff