module UHC.Light.Compiler.CoreRun.Run
( module Control.Monad.RWS.Strict, module Control.Monad, module Control.Monad.Error
, RunRd (..), emptyRunRd
, RunSt (..), emptyRunSt
, RunSem (..)
, RunT', RunT
, err
, runCoreRun
, modifyIORefM )
where
import UHC.Light.Compiler.Base.HsName.Builtin
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Error
import UHC.Light.Compiler.Gam
import UHC.Light.Compiler.Gam.DataGam
import UHC.Light.Compiler.CoreRun
import UHC.Light.Compiler.CoreRun.Prim
import qualified UHC.Util.FastSeq as Seq
import qualified Data.Map as Map
import UHC.Util.Pretty
import Data.Maybe
import Data.Monoid
import Data.IORef
import Control.Monad
import Control.Monad.Error
import Control.Monad.RWS.Strict

{-# LINE 39 "src/ehc/CoreRun/Run.chs" #-}
data RunRd
  = RunRd
      {- cenvLamMp       :: LamMp
      -}

emptyRunRd
  = RunRd

{-# LINE 63 "src/ehc/CoreRun/Run.chs" #-}
data RunSt
  = RunSt
      {- cenvLamMp       :: LamMp
      -}

emptyRunSt
  = RunSt

{-# LINE 73 "src/ehc/CoreRun/Run.chs" #-}
-- | Factored out stuff, not much in it but intended to accomodate variability in running
class (Monad m, MonadIO m, Functor m) => RunSem r s v m a
    --- | r -> a s
    --- , s -> a r
    | r s -> v a
    where
  -- | Provide initial state
  rsemInitial :: m (r,s,a)

  -- | Setup whatever needs to be setup
  rsemSetup :: EHCOpts -> [Mod] -> Mod -> RunT' r s v m ()

  -- | Setup tracing
  rsemSetupTracing :: EHCOpts -> RunT' r s v m ()
  rsemSetupTracing opts = do
        let dotr  = CoreOpt_RunTrace `elem` ehcOptCoreOpts opts
            dotre = CoreOpt_RunTraceExtensive `elem` ehcOptCoreOpts opts
        rsemSetTrace (dotre || dotr) dotre

  -- | Set tracing on/off, 2nd param to tell to do it extensively
  rsemSetTrace :: Bool -> Bool -> RunT' r s v m ()
  rsemSetTrace _ _ = return ()

  -- | Exp
  rsemExp :: Exp -> RunT' r s v m a

  -- | SExp
  rsemSExp :: SExp -> RunT' r s v m a

  -- | Alt
  rsemAlt :: Alt -> RunT' r s v m a
  rsemAlt a = do
    case a of
      Alt_Alt {expr_Alt_Alt=e} -> rsemExp e
  {-# INLINE rsemAlt #-}

  -- | Force evaluation, subsumes rsemDeref
  rsemEvl :: v -> RunT' r s v m a

  -- | Dereference: get rid of intermediate indirections
  rsemDeref :: v -> RunT' r s v m a

  -- | Apply primitive to arguments
  rsemPrim :: RunPrim -> CRArray v -> RunT' r s v m a

  -- | Push, i.e. lift/put from v to internal machinery
  rsemPush :: v -> RunT' r s v m a
  -- | Pop, i.e. lift/get from internal machinery to v
  rsemPop :: a -> RunT' r s v m v
  -- | Construct a data constr/tuple
  rsemNode :: Int -> CRMArray v -> RunT' r s v m v

  -- | GC new level of roots (followed by multiple pushes followed by single pop for all)
  rsemGcEnterRootLevel :: RunT' r s v m ()
  rsemGcEnterRootLevel = return ()
  {-# INLINE rsemGcEnterRootLevel #-}
  -- | GC push as root
  rsemGcPushRoot :: v -> RunT' r s v m ()
  rsemGcPushRoot _ = return ()
  {-# INLINE rsemGcPushRoot #-}
  -- | GC pop as root
  rsemGcLeaveRootLevel :: RunT' r s v m ()
  rsemGcLeaveRootLevel = return ()
  {-# INLINE rsemGcLeaveRootLevel #-}

{-# LINE 143 "src/ehc/CoreRun/Run.chs" #-}
-- type RunT' s m a = ErrorT Err (RWST r w s m) a
-- type RunT        m a = RunT' RunRd RunWr RunSt m a
-- type RunT' s m a = ErrorT Err (StateT s m) a
type RunT' r s v m a = ErrorT Err (RWST r () s m) a
type RunT      v m a = RunT' RunRd RunSt v m a

{-# LINE 155 "src/ehc/CoreRun/Run.chs" #-}
err :: (RunSem r s v m a, PP msg) => msg -> RunT' r s v m b
err msg = throwError $ rngLift emptyRange Err_PP $ pp msg

{-# LINE 165 "src/ehc/CoreRun/Run.chs" #-}
runCoreRun
  :: forall r s v m a .
     (RunSem r s v m a)
  => EHCOpts
     -> [Mod]
     -> Mod
     -> RunT' r s v m a
     -> m (Either Err v) -- RunT' r s v m a
runCoreRun opts modImpL mod m = do
  (r, s, _ :: a) <- rsemInitial
  -- let s = error "runCoreRun.RWS"
  --     r = error "runCoreRun.Reader"
  (e, _, _) <-
    runRWST (runErrorT $ do
              rsemSetup opts modImpL mod
              (m >>= rsemPop >>= rsemDeref >>= rsemPop))
            r s
  return e

{-# LINE 190 "src/ehc/CoreRun/Run.chs" #-}
modifyIORefM :: IORef a -> (a -> IO a) -> IO ()
modifyIORefM r m = readIORef r >>= m >>= writeIORef r
{-# INLINE modifyIORefM #-}