content: {-# LANGUAGE CPP                        #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses      #-}
  {-# LANGUAGE ScopedTypeVariables        #-}
  
  module Ivory.Language.Module where
  
  import           Prelude                ()
  import           Prelude.Compat
  
  import           Data.List              (nub)
  #if !MIN_VERSION_base(4,11,0)
  import           Data.Semigroup         (Semigroup(..))
  #endif
  
  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)
  
  -- Modules ---------------------------------------------------------------------
  
  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 #-}
  
  -- | Add an element to the public/private list, depending on visibility
  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] }
  
  -- | Include a defintion in the module.
  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] })
  
  -- | Import an externally-defined symbol.
  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
  
  -- | Add a dependency on another module.
  depend :: I.Module -> ModuleDef
  depend m = dependByName (I.modName m)
  
  -- | Add a dependency on another module by name. Use the same name
  -- here that you use when you call 'package' to build the target
  -- module. This function is particularly useful when building mutually
  -- dependent module structures.
  dependByName :: String -> ModuleDef
  dependByName nm =
    put (mempty { I.modDepends = [nm] })
  
  -- | Include the definition of a structure in the module.
  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
  
  -- | Include the definition of a string type's structure.
  defStringType :: forall str. (IvoryString str) => Proxy str -> ModuleDef
  defStringType _ = defStruct (Proxy :: Proxy (StructName str))
  
  -- | Include the definition of a memory area.
  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 })
  
  -- | Include the definition of a constant memory area.
  defConstMemArea :: IvoryArea area => ConstMemArea area -> ModuleDef
  defConstMemArea (ConstMemArea m) = defMemArea m
  
  -- | Package the module up. Default visibility is public.
  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)
      }
  
  -- | Start a block of definitions that should not be put in the header.
  private :: ModuleDef -> ModuleDef
  private build = Module $ local Private (unModule build)
  
  -- | Start a block of definitions should be put in the header. This is the
  -- default, and this function is just included to complement 'private'.
  public :: ModuleDef -> ModuleDef
  public build = Module $ local Public (unModule build)
  
  -- Accessors -------------------------------------------------------------------
  
  moduleName :: I.Module -> String
  moduleName  = I.modName
  