{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ivory.Language.Module where
import Prelude ()
import Prelude.Compat
import Data.List (nub)
import Data.Semigroup (Semigroup(..))
import Ivory.Language.Area (IvoryArea)
import Ivory.Language.MemArea (ConstMemArea (..), MemArea (..))
import Ivory.Language.Proc (Def (..))
import Ivory.Language.Proxy (ASymbol, Proxy (..))
import Ivory.Language.String (IvoryString (..))
import Ivory.Language.Struct (IvoryStruct (..), StructDef (..),
StructName)
import qualified Ivory.Language.Syntax as I
import Ivory.Language.Type (IvoryExpr, unwrapExpr)
import Control.Monad (forM_)
import MonadLib (Id, ReaderM, ReaderT, WriterM, WriterT,
ask, local, put, runM)
import MonadLib.Derive (Iso (..), derive_ask, derive_put)
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)
{-# INLINE ask #-}
instance WriterM ModuleM I.Module where
put = derive_put (Iso Module unModule)
{-# INLINE put #-}
type ModuleDef = ModuleM ()
instance Semigroup (ModuleM ()) where
(<>) = (>>)
{-# INLINE (<>) #-}
instance Monoid (ModuleM ()) where
mempty = return ()
{-# INLINE mempty #-}
mappend = (<>)
{-# INLINE 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 = dependByName (I.modName m)
dependByName :: String -> ModuleDef
dependByName nm =
put (mempty { I.modDepends = [nm] })
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 =
let m = (snd (runM (unModule build) Public)) { I.modName = name } in
m { I.modHeaders = nub (I.modHeaders m)
, I.modDepends = nub (I.modDepends m)
}
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