{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}

module Ivory.Language.MemArea where

import Prelude ()
import Prelude.Compat

import Ivory.Language.Area
import Ivory.Language.Init
import Ivory.Language.Proxy
import Ivory.Language.Ref
import Ivory.Language.Scope
import Ivory.Language.Type
import qualified Ivory.Language.Syntax as I

import qualified MonadLib        as M
import qualified MonadLib.Derive as M

-- Running Initializers --------------------------------------------------------

-- | This is used to generate fresh names for compound initializers.
newtype AreaInitM a = AreaInitM
  { unAreaInitM :: M.ReaderT String (M.StateT Int M.Id) a }

areaInit_iso :: M.Iso (M.ReaderT String (M.StateT Int M.Id)) AreaInitM
areaInit_iso = M.Iso AreaInitM unAreaInitM

instance Functor AreaInitM where
  fmap = M.derive_fmap areaInit_iso
  {-# INLINE fmap #-}

instance Applicative AreaInitM where
  pure  = M.derive_pure areaInit_iso
  (<*>) = M.derive_apply areaInit_iso
  {-# INLINE pure #-}
  {-# INLINE (<*>) #-}

instance Monad AreaInitM where
  return  = pure
  (>>=)   = M.derive_bind   areaInit_iso
  {-# INLINE return #-}
  {-# INLINE (>>=) #-}

instance M.ReaderM AreaInitM String where
  ask = M.derive_ask areaInit_iso
  {-# INLINE ask #-}

instance M.StateM AreaInitM Int where
  get = M.derive_get areaInit_iso
  set = M.derive_set areaInit_iso
  {-# INLINE get #-}
  {-# INLINE set #-}

instance FreshName AreaInitM where
  freshName s = do
    i <- M.get
    M.set $! i + 1
    name <- M.ask
    return (I.VarLitName ("_iv_" ++ name ++ "_" ++ s ++ show i))

runAreaInitM :: String -> AreaInitM a -> a
runAreaInitM s x = fst (M.runId (M.runStateT 0 (M.runReaderT s(unAreaInitM x))))

areaInit :: String -> Init area -> (I.Init, [Binding])
areaInit s ini = runAreaInitM s (runInit (getInit ini))

-- Memory Areas ----------------------------------------------------------------

-- | Externally defined memory areas.
data MemArea (area :: Area *)
  = MemImport I.AreaImport
  | MemArea I.Area [I.Area]
  deriving (Eq, Show)

-- XXX do not export
memSym :: MemArea area -> I.Sym
memSym m = case m of
  MemImport i -> I.aiSym i
  MemArea a _ -> I.areaSym a

-- | Create an area from an auxillary binding.
bindingArea :: Bool -> Binding -> I.Area
bindingArea isConst b = I.Area
  { I.areaSym   = bindingSym b
  , I.areaConst = isConst
  , I.areaType  = bindingType b
  , I.areaInit  = bindingInit b
  }

makeArea :: I.Sym -> Bool -> I.Type -> I.Init -> I.Area
makeArea sym isConst ty ini = I.Area
  { I.areaSym   = sym
  , I.areaConst = isConst
  , I.areaType  = ty
  , I.areaInit  = ini
  }

-- | Define a global constant. Requires an IvoryZero constraint to ensure the
-- area has an initializers, but does not explicilty initialize to 0 so that the
-- value is placed in the .bss section.
area :: forall area. (IvoryArea area, IvoryZero area)
     => I.Sym -> Maybe (Init area) -> MemArea area
area sym (Just ini) = MemArea a1 as
  where
  (ini', binds) = areaInit sym ini
  ty            = ivoryArea (Proxy :: Proxy area)
  a1            = makeArea sym False ty ini'
  as            = map (bindingArea False) binds
area sym Nothing = MemArea a1 []
  where
  ty = ivoryArea (Proxy :: Proxy area)
  a1 = makeArea sym False ty I.zeroInit

-- | Import an external symbol from a header.
importArea :: IvoryArea area => I.Sym -> String -> MemArea area
importArea name header = MemImport I.AreaImport
  { I.aiSym   = name
  , I.aiConst = False
  , I.aiFile  = header
  }


-- Constant Memory Areas -------------------------------------------------------

newtype ConstMemArea (area :: Area *) = ConstMemArea (MemArea area)

-- | Constant memory area definition.
constArea :: forall area. IvoryArea area
          => I.Sym -> Init area -> ConstMemArea area
constArea sym ini = ConstMemArea $ MemArea a1 as
  where
  (ini', binds) = areaInit sym ini
  ty            = ivoryArea (Proxy :: Proxy area)
  a1            = makeArea sym True ty ini'
  as            = map (bindingArea True) binds

-- | Import an external symbol from a header.
importConstArea :: IvoryArea area => I.Sym -> String -> ConstMemArea area
importConstArea name header = ConstMemArea $ MemImport I.AreaImport
  { I.aiSym   = name
  , I.aiConst = False
  , I.aiFile  = header
  }

-- Area Usage ------------------------------------------------------------------

-- | Turn a memory area into a reference.
class IvoryAddrOf (mem :: Area * -> *) ref | mem -> ref, ref -> mem  where
  addrOf :: IvoryArea area => mem area -> ref 'Global area

-- XXX do not export
primAddrOf :: IvoryArea area => MemArea area -> I.Expr
primAddrOf mem = I.ExpAddrOfGlobal (memSym mem)

instance IvoryAddrOf MemArea Ref where
  addrOf mem = wrapExpr (primAddrOf mem)

instance IvoryAddrOf ConstMemArea ConstRef where
  addrOf (ConstMemArea mem) = wrapExpr (primAddrOf mem)