content: {-# LANGUAGE CPP                 #-}
  {-# LANGUAGE DataKinds           #-}
  {-# LANGUAGE FlexibleInstances   #-}
  {-# LANGUAGE KindSignatures      #-}
  {-# LANGUAGE PolyKinds           #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies        #-}
  {-# LANGUAGE TypeOperators       #-}
  
  module Ivory.Language.Init where
  
  import           Prelude                ()
  import           Prelude.Compat
  #if !MIN_VERSION_base(4,11,0)
  import           Data.Semigroup         (Semigroup(..))
  #endif
  
  import           Ivory.Language.Area
  import           Ivory.Language.Array
  import qualified Ivory.Language.Effects as E
  import           Ivory.Language.Float
  import           Ivory.Language.IBool
  import           Ivory.Language.IChar
  import           Ivory.Language.Monad
  import           Ivory.Language.Proc
  import           Ivory.Language.Proxy
  import           Ivory.Language.Ptr
  import           Ivory.Language.Ref
  import           Ivory.Language.Scope
  import           Ivory.Language.Sint
  import           Ivory.Language.Struct
  import qualified Ivory.Language.Syntax  as I
  import           Ivory.Language.Type
  import           Ivory.Language.Uint
  
  import           Control.Monad          (forM_)
  
  import           GHC.TypeLits           (Symbol)
  
  -- Initializers ----------------------------------------------------------------
  
  -- | Intermediate initializer type supporting compound initializers.
  -- The "IFresh" nodes are flattened into multiple "I.Init" nodes
  -- in a "FreshName" monad when the variable is allocated.
  data XInit
    = IVal      I.Type I.Init
    | IArray    I.Type [XInit] Bool -- True if no dropped initialization values.
    | IStruct   I.Type [(String, XInit)]
    | IFresh    I.Type XInit (I.Var -> I.Init)
  
  -- | Return the type of the initializer.
  initType :: XInit -> I.Type
  initType (IVal    ty _)   = ty
  initType (IArray  ty _ _) = ty
  initType (IStruct ty _)   = ty
  initType (IFresh  ty _ _) = ty
  
  newtype Init (area :: Area *) = Init { getInit :: XInit }
  
  -- | Zero initializers. The semantics of Ivory is that initializers must be
  -- compatible with C semantics of initializing to 0 for globals in .bss.
  class IvoryZero (area :: Area *) where
    izero :: Init area
  
  -- | Zero the memory pointed to by this reference, as long as it could have been
  -- created with a zero initializer.
  refZero :: forall eff s a. (IvoryZero a, IvoryArea a) => Ref s a -> Ivory eff ()
  refZero ref = emit (I.RefZero (ivoryArea (Proxy :: Proxy a)) (unwrapExpr ref))
  
  
  -- Running Initializers --------------------------------------------------------
  
  class Monad m => FreshName m where
    freshName :: String -> m I.Var
  
  instance FreshName (Ivory eff) where
    freshName = freshVar
  
  -- | A variable binding (on the stack or in a memory area).
  data Binding = Binding
    { bindingVar  :: I.Var
    , bindingType :: I.Type
    , bindingInit :: I.Init
    } deriving Show
  
  -- XXX do not export
  bindingSym :: Binding -> I.Sym
  bindingSym b =
    case bindingVar b of
      I.VarName s     -> s
      I.VarInternal s -> s
      I.VarLitName s  -> s
  
  -- | Return the initializer and auxillary bindings for an
  -- initializer in a context that can allocate fresh names.
  runInit :: FreshName m => XInit -> m (I.Init, [Binding])
  runInit ini =
    case ini of
      IVal _ i ->
        return (i, [])
      IArray _ is b -> do
        binds    <- mapM runInit is
        let inis  = map fst binds
        let aux   = concatMap snd binds
        return (I.InitArray inis b, aux)
      IStruct _ is -> do
        binds    <- mapM iniStruct is
        let inis  = map fst binds
        let aux   = concatMap snd binds
        return (I.InitStruct inis, aux)
      IFresh _ i f -> do
        var       <- freshName "init"
        (i', aux) <- runInit i
        let ty     = initType i
        let aux'   = aux ++ [Binding var ty i']
        return (f var, aux')
    where
      iniStruct (s, i) = do
        (i', binds) <- runInit i
        return ((s, i'), binds)
  
  -- Stored Initializers ---------------------------------------------------------
  
  -- | Initializers for 'Stored' things.
  class IvoryVar e => IvoryInit e where
    ival :: e -> Init ('Stored e)
    ival e = Init (IVal ty (I.InitExpr ty (unwrapExpr e)))
      where
      ty = ivoryType (Proxy :: Proxy e)
  
  instance IvoryInit IBool
  instance IvoryInit IChar
  instance IvoryInit Uint8
  instance IvoryInit Uint16
  instance IvoryInit Uint32
  instance IvoryInit Uint64
  instance IvoryInit Sint8
  instance IvoryInit Sint16
  instance IvoryInit Sint32
  instance IvoryInit Sint64
  instance IvoryInit IFloat
  instance IvoryInit IDouble
  instance ProcType proc => IvoryInit (ProcPtr proc)
  instance IvoryArea area => IvoryInit (Ptr 'Global area)
  instance ANat len => IvoryInit (Ix len)
  
  class (IvoryVar a) => IvoryZeroVal a where
    izeroval :: Init ('Stored a)
  
  instance IvoryZeroVal IBool where
    izeroval = ival false
  
  instance IvoryZeroVal IChar where
    izeroval = ival (char '\0')
  
  -- IvoryZero instances for numeric things
  instance IvoryZeroVal Uint8    where izeroval = ival 0
  instance IvoryZeroVal Uint16   where izeroval = ival 0
  instance IvoryZeroVal Uint32   where izeroval = ival 0
  instance IvoryZeroVal Uint64   where izeroval = ival 0
  instance IvoryZeroVal Sint8    where izeroval = ival 0
  instance IvoryZeroVal Sint16   where izeroval = ival 0
  instance IvoryZeroVal Sint32   where izeroval = ival 0
  instance IvoryZeroVal Sint64   where izeroval = ival 0
  instance IvoryZeroVal IFloat   where izeroval = ival 0
  instance IvoryZeroVal IDouble  where izeroval = ival 0
  
  instance (ANat n) => IvoryZeroVal (Ix n) where
    izeroval = ival 0
  
  instance IvoryArea area => IvoryZeroVal (Ptr 'Global area) where
    izeroval = ival nullPtr
  
  instance IvoryZeroVal a => IvoryZero ('Stored a) where
    izero = izeroval
  
  -- Array Initializers ----------------------------------------------------------
  
  instance (IvoryZero area, IvoryArea area, ANat len) =>
      IvoryZero ('Array len area) where
    izero = Init (IVal ty I.InitZero)
      where
      ty = ivoryArea (Proxy :: Proxy ('Array len area))
  
  iarray :: forall len area. (IvoryArea area, ANat len)
         => [Init area] -> Init ('Array len area)
  iarray is =
    Init (IArray ty (take len (map getInit is)) (null (drop len is)))
    -- truncate to known length, Bool tells us if there were dropped values.
    where
    len = fromInteger (fromTypeNat (aNat :: NatType len))
    ty  = ivoryArea (Proxy :: Proxy ('Array len area))
  
  -- Struct Initializers ---------------------------------------------------------
  
  instance IvoryStruct sym => IvoryZero ('Struct sym) where
    izero = Init (IVal ty I.InitZero)
      where
      ty = ivoryArea (Proxy :: Proxy ('Struct sym))
  
  newtype InitStruct (sym :: Symbol) = InitStruct
    { getInitStruct :: [(String, XInit)]
    }
  
  -- Much like the C initializers, the furthest right field initializer will take
  -- precidence, and fields not mentioned will be left as zero.
  instance IvoryStruct sym => Semigroup (InitStruct sym) where
    l <> r = InitStruct (getInitStruct l <> getInitStruct r)
  
  instance IvoryStruct sym => Monoid (InitStruct sym) where
    mempty  = InitStruct []
    mappend = (<>)
  
  istruct :: forall sym. IvoryStruct sym => [InitStruct sym] -> Init ('Struct sym)
  istruct is = Init (IStruct ty fields)
    where
    fields = [ (l,i) | (l,i) <- getInitStruct (mconcat is) ]
    ty = ivoryArea (Proxy :: Proxy ('Struct sym))
  
  (.=) :: Label sym area -> Init area -> InitStruct sym
  l .= ini = InitStruct [(getLabel l, getInit ini)]
  
  -- | Stack allocation
  local :: forall eff s area. (IvoryArea area, E.GetAlloc eff ~ 'E.Scope s)
        => Init area
        -> Ivory eff (Ref ('Stack s) area)
  local ini = do
    (i, binds) <- runInit (getInit ini)
  
    forM_ binds $ \b -> do
      emit (I.Local (bindingType b) (bindingVar b) (bindingInit b))
  
    lname <- freshVar "local"
    let ty = ivoryArea (Proxy :: Proxy area)
    emit (I.Local ty lname i)
  
    rname <- freshVar "ref"
    let areaTy = ivoryArea (Proxy :: Proxy area)
    emit (I.AllocRef areaTy rname (I.NameVar lname))
  
    return (wrapExpr (I.ExpVar rname))
  