content: ----------------------------------------------------------------------------
  -- |
  -- Module      :  Emacs.Module.Monad
  -- Copyright   :  (c) Sergey Vinokurov 2022
  -- License     :  Apache-2.0 (see LICENSE)
  -- Maintainer  :  serg.foo@gmail.com
  ----------------------------------------------------------------------------
  
  {-# LANGUAGE CPP                  #-}
  {-# LANGUAGE DataKinds            #-}
  {-# LANGUAGE GADTs                #-}
  {-# LANGUAGE MagicHash            #-}
  {-# LANGUAGE OverloadedStrings    #-}
  {-# LANGUAGE TypeFamilies         #-}
  {-# LANGUAGE UnboxedTuples        #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  module Emacs.Module.Monad
    ( module Emacs.Module.Monad.Class
    , EmacsM
    , runEmacsM
    ) where
  
  import Control.Exception
  import Control.Exception qualified as Exception
  import Control.Monad.Base
  import Control.Monad.Catch qualified as Catch
  import Control.Monad.Fix (MonadFix)
  import Control.Monad.Interleave
  import Control.Monad.Primitive hiding (unsafeInterleave)
  import Control.Monad.Reader
  import Control.Monad.Trans.Control
  import Data.ByteString qualified as BS
  import Data.ByteString.Short (ShortByteString)
  import Data.ByteString.Unsafe qualified as BSU
  import Data.Coerce
  import Data.Emacs.Module.Doc qualified as Doc
  import Data.Int
  import Data.Kind
  import Data.Proxy
  import Data.Text (Text)
  import Data.Void
  import Foreign.C.Types
  import Foreign.Ptr
  import GHC.ForeignPtr
  import GHC.Stack (callStack)
  import Prettyprinter
  
  import Data.Emacs.Module.Args
  import Data.Emacs.Module.Env.Functions
  import Data.Emacs.Module.Env.ProcessInput qualified as ProcessInput
  import Data.Emacs.Module.GetRawValue
  import Data.Emacs.Module.NonNullPtr
  import Data.Emacs.Module.Raw.Env qualified as Env
  import Data.Emacs.Module.Raw.Env.Internal (Env, RawFunctionType)
  import Data.Emacs.Module.Raw.Env.Internal qualified as Env
  import Data.Emacs.Module.Raw.Value
  import Data.Emacs.Module.SymbolName.Internal
  import Data.Emacs.Module.Value.Internal
  import Emacs.Module.Assert
  import Emacs.Module.Errors
  import Emacs.Module.Monad.Class
  import Emacs.Module.Monad.Common as Common
  import Foreign.Ptr.Builder as PtrBuilder
  
  data Environment = Environment
    { eEnv           :: Env
    , eNonLocalState :: {-# UNPACK #-} !NonLocalState
    , eArgsCache     :: BuilderCache (RawValue 'Unknown)
    }
  
  -- | Concrete monad for interacting with Emacs. It provides:
  --
  -- 1. Ability to call Emacs C functions and automatically rethrows any
  --    errors (non-local exits) from elisp as Haskell exceptions.
  -- 2. Tracks ownership of any produced Emacs values and communicates
  --    that to Emacs, so that GC on Emacs side will not make any
  --    values in Haskell invalid (funnily enough, this can happen!).
  --
  -- Parameter 's' serves to make ownership-tracking capabilities possible.
  -- It's use is the same as in 'Control.Monad.ST' monad. That is, it creates
  -- local threads so that no produced Emacs values can leave past 'runEmacsM'.
  newtype EmacsM (s :: k) (a :: Type) = EmacsM { unEmacsM :: ReaderT Environment IO a }
    deriving
      ( Functor
      , Applicative
      , Monad
      , Catch.MonadThrow
      , Catch.MonadCatch
      , Catch.MonadMask
      , MonadFix
      , PrimMonad
      )
  
  instance MonadInterleave (EmacsM s) where
    {-# INLINE unsafeInterleave #-}
    unsafeInterleave (EmacsM action) = EmacsM $ do
      env <- ask
      liftBase $ unsafeInterleave $ runReaderT action env
  
  instance MonadIO (EmacsM s) where
    {-# INLINE liftIO #-}
    liftIO = EmacsM . lift
  
  instance MonadBase IO (EmacsM s) where
    {-# INLINE liftBase #-}
    liftBase = EmacsM . lift
  
  instance MonadBaseControl IO (EmacsM s) where
    type StM (EmacsM s) a = StM (ReaderT Environment IO) a
    {-# INLINE liftBaseWith #-}
    liftBaseWith f = EmacsM (liftBaseWith (\runInBase -> f (runInBase . unEmacsM)))
    {-# INLINE restoreM #-}
    restoreM = EmacsM . restoreM
  
  -- | Execute emacs interaction session using an environment supplied by Emacs.
  runEmacsM
    :: WithCallStack
    => Env
    -> (forall s. EmacsM s a)
    -> IO a
  runEmacsM eEnv (EmacsM action) =
    withNonLocalState $ \eNonLocalState ->
      withBuilderCache 8 $ \eArgsCache ->
        runReaderT action Environment { eEnv, eNonLocalState, eArgsCache }
  
  {-# INLINE withEnv #-}
  withEnv :: (Env -> IO a) -> EmacsM s a
  withEnv f = EmacsM $ do
    Environment{eEnv} <- ask
    liftBase (f eEnv)
  
  {-# INLINE withEnvCache #-}
  withEnvCache :: (Env -> BuilderCache (RawValue b) -> IO a) -> EmacsM s a
  withEnvCache f = EmacsM $ do
    Environment{eEnv, eArgsCache} <- ask
    liftBase $ f eEnv (coerceBuilderCache eArgsCache)
  
  handleResult :: EmacsRes EmacsSignal EmacsThrow a -> IO a
  handleResult = \case
    EmacsSuccess    x -> pure x
    EmacsExitSignal e -> throwIO e
    EmacsExitThrow  e -> throwIO e
  
  handleResultNoThrow :: EmacsRes EmacsSignal Void a -> IO a
  handleResultNoThrow = \case
    EmacsSuccess    x -> pure x
    EmacsExitSignal e -> throwIO e
    EmacsExitThrow  e -> absurd e
  
  instance MonadEmacs EmacsM Value where
  
    {-# INLINE makeGlobalRef #-}
    makeGlobalRef :: WithCallStack => Value s -> EmacsM s (RawValue 'Pinned)
    makeGlobalRef x = withEnv $ \env ->
      liftBase $ Env.makeGlobalRef env $ getRawValue x
  
    {-# INLINE freeGlobalRef #-}
    freeGlobalRef :: WithCallStack => RawValue 'Pinned -> EmacsM s ()
    freeGlobalRef x = withEnv $ \env ->
      liftBase $ Env.freeGlobalRef env x
  
    nonLocalExitCheck
      :: WithCallStack
      => EmacsM s (FuncallExit ())
    nonLocalExitCheck = withEnv $ \env ->
      Env.nonLocalExitCheck env >>= Common.unpackEnumFuncallExit
  
    nonLocalExitGet
      :: WithCallStack
      => EmacsM s (FuncallExit (Value s, Value s))
    nonLocalExitGet = EmacsM $ do
      Environment{eEnv, eNonLocalState} <- ask
      liftBase $ do
        res <- Common.nonLocalExitGet eEnv eNonLocalState
        pure $ coerce res
  
    nonLocalExitSignal
      :: (WithCallStack, Foldable f)
      => Value s     -- ^ Error symbol
      -> f (Value s) -- ^ Error data, will be converted to a list as Emacs API expects.
      -> EmacsM s ()
    nonLocalExitSignal sym errData = withEnvCache $ \env cache ->
      Exception.throwIO =<< Common.nonLocalExitSignal cache env callStack (coerce sym) errData'
      where
        errData' =
          foldMap (coerce (PtrBuilder.storable :: RawValue 'Regular -> PtrBuilder.Builder (RawValue 'Regular))) errData
  
    nonLocalExitThrow
      :: WithCallStack
      => Value s -- ^ Tag
      -> Value s -- ^ Data
      -> EmacsM s ()
    nonLocalExitThrow tag errData = withEnv $ \env -> do
      Env.nonLocalExitThrow env tag' errData'
      Exception.throwIO EmacsThrow
        { emacsThrowTag    = tag'
        , emacsThrowValue  = errData'
        , emacsThrowOrigin = callStack
        }
      where
        tag'     = getRawValue tag
        errData' = getRawValue errData
  
    nonLocalExitClear :: WithCallStack => EmacsM s ()
    nonLocalExitClear = withEnv Env.nonLocalExitClear
  
    {-# INLINE makeFunction #-}
    makeFunction
      :: forall req opt rest s. (WithCallStack, EmacsInvocation req opt rest, GetArities req opt rest)
      => (forall s'. EmacsFunction req opt rest EmacsM Value s')
      -> Doc.Doc
      -> EmacsM s (Value s)
    makeFunction emacsFun doc = withEnv $ \env -> do
      impl' <- liftBase $ Env.exportToEmacs impl
      Doc.useDocAsCString doc $ \doc' -> do
        func <- Env.makeFunction env minArity maxArity impl' doc' (castFunPtrToPtr (Env.unRawFunction impl'))
        Env.setFunctionFinalizer env func Env.freeHaskellFunPtrWrapped
        pure $ Value func
      where
        (minArity, maxArity) = arities (Proxy @req) (Proxy @opt) (Proxy @rest)
  
        impl :: RawFunctionType 'Unknown ()
        impl envPtr nargs argsPtr _extraPtr = do
          let env = Env.fromPtr envPtr
          Exception.handle (reportAnyErrorToEmacs env) $
            Exception.handle (reportEmacsSignalToEmacs env) $
              Exception.handle (reportEmacsThrowToEmacs env) $
                runEmacsM env $ do
                  res <- coerce (supplyEmacsArgs (fromIntegral nargs) argsPtr (pure . Value) emacsFun)
                  -- Force since value may contain exceptions.
                  liftIO $ evaluate res
  
    {-# INLINE funcall #-}
    funcall
      :: (WithCallStack, Foldable f)
      => Value s
      -> f (Value s)
      -> EmacsM s (Value s)
    funcall func args = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase $
            coerce . handleResult
        =<< Common.checkNonLocalExitFull (coerceBuilderCache eArgsCache) eEnv eNonLocalState
        =<< (withPtrLenNonNull (coerceBuilderCache eArgsCache) (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' ->
               Env.funcall eEnv (getRawValue func) (fromIntegral n) args')
  
  
    {-# INLINE funcallPrimitive #-}
    funcallPrimitive
      :: (WithCallStack, Foldable f)
      => Value s
      -> f (Value s)
      -> EmacsM s (Value s)
    funcallPrimitive func args = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase $
            coerce . handleResult
        =<< Common.checkNonLocalExitFull (coerceBuilderCache eArgsCache) eEnv eNonLocalState
        =<< (withPtrLenNonNull (coerceBuilderCache eArgsCache) (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' ->
              Env.funcallPrimitive eEnv (getRawValue func) (fromIntegral n) args')
  
    {-# INLINE funcallPrimitiveUnchecked #-}
    funcallPrimitiveUnchecked
      :: (WithCallStack, Foldable f)
      => Value s
      -> f (Value s)
      -> EmacsM s (Value s)
    funcallPrimitiveUnchecked func args =
      withEnvCache $ \env cache ->
        withPtrLenNonNull cache (foldMap (PtrBuilder.storable . getRawValue) args) $ \n args' ->
          coerce $ Env.funcallPrimitive @IO env (getRawValue func) (fromIntegral n) args'
  
    intern
      :: WithCallStack
      => SymbolName
      -> EmacsM s (Value s)
    intern sym = withEnv $ \env ->
      coerce $ reifySymbolUnknown env sym
  
    typeOf
      :: WithCallStack
      => Value s -> EmacsM s (Value s)
    typeOf x = withEnv $ \env ->
      coerce $ Env.typeOf @IO env (getRawValue x)
  
    {-# INLINE isNotNil #-}
    isNotNil :: WithCallStack => Value s -> EmacsM s Bool
    isNotNil x = withEnv $ \env ->
      Env.isTruthy <$> Env.isNotNil env (getRawValue x)
  
    eq :: Value s -> Value s -> EmacsM s Bool
    eq x y = withEnv $ \env ->
      Env.isTruthy <$> Env.eq env (getRawValue x) (getRawValue y)
  
    extractWideInteger :: WithCallStack => Value s -> EmacsM s Int64
    extractWideInteger x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase
        $   handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "ExtractInteger" . fromIntegral
        =<< Env.extractInteger eEnv (getRawValue x)
  
    makeWideInteger :: WithCallStack => Int64 -> EmacsM s (Value s)
    makeWideInteger x = withEnv $ \env ->
      coerce $ Env.makeInteger @IO env (fromIntegral x)
  
    extractDouble :: WithCallStack => Value s -> EmacsM s Double
    extractDouble x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase
        $   handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "ExtractFloat" . (\(CDouble y) -> y)
        =<< Env.extractFloat eEnv (getRawValue x)
  
    makeDouble :: WithCallStack => Double -> EmacsM s (Value s)
    makeDouble x = withEnv $ \env ->
      coerce $ Env.makeFloat @IO env (CDouble x)
  
    extractText :: WithCallStack => Value s -> EmacsM s Text
    extractText x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase
        $   handleResultNoThrow
        =<< Common.extractText (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x)
  
    extractShortByteString :: WithCallStack => Value s -> EmacsM s ShortByteString
    extractShortByteString x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase
        $   handleResultNoThrow
        =<< Common.extractShortByteString (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x)
  
    extractByteString :: WithCallStack => Value s -> EmacsM s BS.ByteString
    extractByteString x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase
        $   handleResultNoThrow
        =<< Common.extractByteString (coerceBuilderCache eArgsCache) eEnv eNonLocalState (getRawValue x)
  
    makeString :: WithCallStack => BS.ByteString -> EmacsM s (Value s)
    makeString x = withEnv $ \env ->
      BSU.unsafeUseAsCStringLen x $ \(pStr, len) ->
        coerce $ Env.makeString @IO env pStr (fromIntegral len)
  
    makeBinaryString :: WithCallStack => BS.ByteString -> EmacsM s (Value s)
    makeBinaryString x = withEnv $ \env ->
      BSU.unsafeUseAsCStringLen x $ \(pStr, len) ->
        coerce $ Env.makeUnibyteString @IO env pStr (fromIntegral len)
  
    extractUserPtr :: WithCallStack => Value s -> EmacsM s (Ptr a)
    extractUserPtr x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase
        $   handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "GetUserPtr"
        =<< Env.getUserPtr eEnv (getRawValue x)
  
    makeUserPtr
      :: WithCallStack
      => FinalizerPtr a
      -> Ptr a
      -> EmacsM s (Value s)
    makeUserPtr fin ptr = withEnv $ \env ->
      coerce $ Env.makeUserPtr @IO env fin ptr
  
    assignUserPtr :: WithCallStack => Value s -> Ptr a -> EmacsM s ()
    assignUserPtr dest ptr = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      -- callWithResultMayFailSignalWaitSideEffect (SetUserPtr (getRawValue dest) ptr)
      liftBase $
            handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "SetUserPtr"
        =<< Env.setUserPtr eEnv (getRawValue dest) ptr
  
    extractUserPtrFinaliser
      :: WithCallStack => Value s -> EmacsM s (FinalizerPtr a)
    extractUserPtrFinaliser x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase $
            handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "GetUserPtrFinaliser"
        =<< Env.getUserFinaliser eEnv (getRawValue x)
  
    assignUserPtrFinaliser
      :: WithCallStack => Value s -> FinalizerPtr a -> EmacsM s ()
    assignUserPtrFinaliser x fin = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase $
            handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "SetUserPtrFinaliser"
        =<< Env.setUserFinaliser eEnv (getRawValue x) fin
  
    vecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s)
    vecGet vec n = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase $
            coerce . handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecGet"
        =<< Env.vecGet eEnv (getRawValue vec) (fromIntegral n)
  
    unsafeVecGet :: WithCallStack => Value s -> Int -> EmacsM s (Value s)
    unsafeVecGet vec n = EmacsM $ do
      Environment{eEnv} <- ask
      liftBase $
        coerce $
          Env.vecGet @IO eEnv (getRawValue vec) (fromIntegral n)
  
    vecSet
      :: WithCallStack
      => Value s -- ^ Vector
      -> Int     -- ^ Index
      -> Value s -- ^ New value
      -> EmacsM s ()
    vecSet vec n x = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase $
            handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecSet"
        =<< Env.vecSet eEnv (getRawValue vec) (fromIntegral n) (getRawValue x)
  
    vecSize :: WithCallStack => Value s -> EmacsM s Int
    vecSize vec = EmacsM $ do
      Environment{eEnv, eNonLocalState, eArgsCache} <- ask
      liftBase $
            handleResultNoThrow
        =<< checkNonLocalExitSignal (coerceBuilderCache eArgsCache) eEnv eNonLocalState "VecSize" . fromIntegral
        =<< Env.vecSize eEnv (getRawValue vec)
  
    processInput :: WithCallStack => EmacsM s ProcessInput.Result
    processInput =
      withEnv $ \env -> do
        Env.EnumProcessInputResult (CInt x) <- Env.processInput env
        case ProcessInput.resultFromNum x of
          Nothing ->
            throwIO $ mkEmacsInternalError $
              "Unknown value of enum emacs_process_input_result" <+> pretty x
          Just y  -> pure y
  