module Ivory.Language.Module where
import Prelude ()
import Prelude.Compat
import Ivory.Language.Area (IvoryArea)
import Ivory.Language.MemArea (MemArea(..),ConstMemArea(..))
import Ivory.Language.Proc (Def(..))
import Ivory.Language.Proxy (Proxy(..), ASymbol)
import Ivory.Language.String (IvoryString(..))
import Ivory.Language.Struct (IvoryStruct(..),StructDef(..),StructName)
import Ivory.Language.Type (IvoryExpr, unwrapExpr)
import qualified Ivory.Language.Syntax as I
import Control.Monad (forM_)
import MonadLib (ReaderT,WriterT,ReaderM,WriterM,Id,runM,put,ask,local)
import MonadLib.Derive (Iso (..),derive_ask,derive_put)
import qualified Data.Set as Set
data Visible = Public | Private deriving (Show)
newtype ModuleM a = Module
{ unModule :: ReaderT Visible (WriterT I.Module Id) a
} deriving (Functor,Monad,Applicative)
instance ReaderM ModuleM Visible where
ask = derive_ask (Iso Module unModule)
instance WriterM ModuleM I.Module where
put = derive_put (Iso Module unModule)
type ModuleDef = ModuleM ()
instance Monoid (ModuleM ()) where
mempty = return ()
mappend = (>>)
visAcc :: Visible -> a -> I.Visible a
visAcc vis e = case vis of
Public -> I.Visible { I.public = [e], I.private = [] }
Private -> I.Visible { I.public = [], I.private = [e] }
incl :: Def a -> ModuleDef
incl (DefProc p) = do
visibility <- ask
put (mempty { I.modProcs = visAcc visibility p })
incl (DefImport i)
| null (I.importFile i) = error $ "Empty header name for " ++ show i
| otherwise = put (mempty { I.modImports = [i] })
inclSym :: IvoryExpr t => t -> ModuleDef
inclSym t = case unwrapExpr t of
I.ExpExtern sym
| null (I.externFile sym) -> error $ "Empty header name for " ++ show sym
| otherwise -> put (mempty { I.modExterns = [sym] })
e -> error $ "Cannot import expression " ++ show e
depend :: I.Module -> ModuleDef
depend m =
put (mempty { I.modDepends = Set.singleton (I.modName m) })
defStruct :: forall sym. (IvoryStruct sym, ASymbol sym) =>
Proxy sym -> ModuleDef
defStruct _ = case getStructDef def of
I.Abstract n "" -> error $ "Empty header name for struct " ++ n
str -> do
visibility <- ask
put (mempty { I.modStructs = visAcc visibility str })
where
def :: StructDef sym
def = structDef
defStringType :: forall str. (IvoryString str) => Proxy str -> ModuleDef
defStringType _ = defStruct (Proxy :: Proxy (StructName str))
defMemArea :: IvoryArea area => MemArea area -> ModuleDef
defMemArea m = case m of
MemImport ia
| null (I.aiFile ia) -> error $ "Empty header name for " ++ show ia
| otherwise -> put (mempty { I.modAreaImports = [ia] })
MemArea a as -> do
visibility <- ask
put (mempty { I.modAreas = visAcc visibility a })
forM_ as $ \aux -> do
put (mempty { I.modAreas = visAcc Private aux })
defConstMemArea :: IvoryArea area => ConstMemArea area -> ModuleDef
defConstMemArea (ConstMemArea m) = defMemArea m
package :: String -> ModuleDef -> I.Module
package name build = (snd (runM (unModule build) Public)) { I.modName = name }
private :: ModuleDef -> ModuleDef
private build = Module $ local Private (unModule build)
public :: ModuleDef -> ModuleDef
public build = Module $ local Public (unModule build)
moduleName :: I.Module -> String
moduleName = I.modName