{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeOperators #-}
module Ivory.Language.Monad (
Ivory()
, retProxy
, runIvory, primRunIvory
, collect
, noBreak
, noReturn
, noAlloc
, CodeBlock(..)
, emits
, emit
, freshVar
, result
, assign
, SrcLoc
, mkLocation
, setLocation
, withLocation
) where
import Prelude ()
import Prelude.Compat
import Data.Semigroup (Semigroup(..))
import qualified Ivory.Language.Effects as E
import Ivory.Language.Proxy
import Ivory.Language.Type
import qualified Ivory.Language.Syntax as AST
import Ivory.Language.Syntax.Concrete.Location
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 Semigroup CodeBlock where
l <> r = l `seq` r `seq` CodeBlock
{ blockStmts = blockStmts l <> blockStmts r
, blockRequires = blockRequires l <> blockRequires r
, blockEnsures = blockEnsures l <> blockEnsures r
}
instance Monoid CodeBlock where
mempty = CodeBlock
{ blockStmts = []
, blockRequires = []
, blockEnsures = []
}
mappend = (<>)
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))
mkLocation :: FilePath -> Int -> Int -> Int -> Int -> SrcLoc
mkLocation file l1 c1 l2 c2
= SrcLoc (Range (Position 0 l1 c1) (Position 0 l2 c2)) (Just file)
setLocation :: SrcLoc -> Ivory eff ()
setLocation src = emit (AST.Comment $ AST.SourcePos src)
withLocation :: SrcLoc -> Ivory eff a -> Ivory eff a
withLocation src act = setLocation src >> act