module Ivory.Language.Module where
import Ivory.Language.Area (IvoryArea)
import Ivory.Language.MemArea (MemArea(..),ConstMemArea(..))
import Ivory.Language.Proc (Def(..))
import Ivory.Language.Proxy (Proxy(..))
import Ivory.Language.String (IvoryString(..))
import Ivory.Language.Struct (IvoryStruct(..),StructDef(..))
import qualified Ivory.Language.Syntax as I
import Control.Monad (forM_)
import Data.Monoid (mempty)
import GHC.TypeLits (SingI())
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)
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 ()
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 (DefExtern e) = put (mempty { I.modExterns = [e] })
incl (DefImport i) = put (mempty { I.modImports = [i] })
inclHeader :: String -> ModuleDef
inclHeader inc = put (mempty { I.modHeaders = Set.singleton inc })
depend :: I.Module -> ModuleDef
depend m =
put (mempty { I.modDepends = Set.singleton (I.modName m) })
defStruct :: forall sym. (IvoryStruct sym, SingI sym) =>
Proxy sym -> ModuleDef
defStruct _ = do
visibility <- ask
put (mempty { I.modStructs = visAcc visibility (getStructDef def) })
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 -> 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
sourceDep :: FilePath -> ModuleDef
sourceDep d =
put (mempty { I.modSourceDeps = Set.singleton d })
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