module Ivory.Language.Monad (
Ivory()
, retProxy
, runIvory, primRunIvory
, collect
, noBreak
, noReturn
, noAlloc
, CodeBlock(..)
, emits
, emit
, freshVar
, result
, assign
) where
import qualified Ivory.Language.Effects as E
import Ivory.Language.Proxy
import Ivory.Language.Type
import qualified Ivory.Language.Syntax as AST
import Control.Applicative (Applicative(..))
import Data.Monoid (Monoid(..))
import MonadLib (StateT,WriterT,Id)
import qualified MonadLib
newtype Ivory (eff :: E.Effects) a = Ivory
{ unIvory :: WriterT CodeBlock (StateT Int Id) a
} deriving (Functor,Applicative,Monad)
data CodeBlock = CodeBlock
{ blockStmts :: AST.Block
, blockRequires :: [AST.Require]
, blockEnsures :: [AST.Ensure]
} deriving (Show)
instance Monoid CodeBlock where
mempty = CodeBlock
{ blockStmts = []
, blockRequires = []
, blockEnsures = []
}
mappend l r = CodeBlock
{ blockStmts = blockStmts l `mappend` blockStmts r
, blockRequires = blockRequires l `mappend` blockRequires r
, blockEnsures = blockEnsures l `mappend` blockEnsures r
}
runIvory :: Ivory (E.ProcEffects s r) a -> (a,CodeBlock)
runIvory b = primRunIvory b
primRunIvory :: Ivory (E.ProcEffects s r) a -> (a,CodeBlock)
primRunIvory m = fst (MonadLib.runM (unIvory m) 0)
collect :: Ivory eff' a -> Ivory eff (a,CodeBlock)
collect (Ivory m) = Ivory (MonadLib.collect m)
retProxy :: Ivory eff a -> Proxy r
retProxy _ = Proxy
emits :: CodeBlock -> Ivory eff ()
emits = Ivory . MonadLib.put
emit :: AST.Stmt -> Ivory eff ()
emit s = emits mempty { blockStmts = [s] }
freshVar :: String -> Ivory eff AST.Var
freshVar pfx = Ivory $ do
s <- MonadLib.get
MonadLib.set $! s + 1
return (AST.VarName (pfx ++ show s))
result :: forall eff a. IvoryExpr a => a -> Ivory eff AST.Var
result a = do
res <- freshVar "r"
let ty = ivoryType (Proxy :: Proxy a)
emit (AST.Assign ty res (unwrapExpr a))
return res
noBreak :: Ivory (E.ClearBreak eff) a -> Ivory eff a
noBreak (Ivory body) = Ivory body
noAlloc :: (innerEff ~ E.ClearAlloc outerEff)
=> Ivory innerEff a -> Ivory outerEff a
noAlloc (Ivory body) = Ivory body
noReturn :: Ivory (E.ClearReturn eff) a -> Ivory eff a
noReturn (Ivory body) = Ivory body
assign :: forall eff a. IvoryExpr a => a -> Ivory eff a
assign e = do
r <- freshVar "let"
emit (AST.Assign (ivoryType (Proxy :: Proxy a)) r (unwrapExpr e))
return (wrapExpr (AST.ExpVar r))