Common.hs

----------------------------------------------------------------------------
-- |
-- Module      :  Emacs.Module.Monad.Common
-- Copyright   :  (c) Sergey Vinokurov 2022
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE MagicHash         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnboxedTuples     #-}

module Emacs.Module.Monad.Common
  ( EmacsRes(..)
  , NonLocalState(..)
  , withNonLocalState
  , unpackEnumFuncallExit
  , unpackEnumFuncallExitSafe
  , Emacs.Module.Monad.Common.nonLocalExitGet
  , nonLocalExitSignal
  , extractText
  , extractShortByteString
  , checkNonLocalExitSignal
  , checkNonLocalExitFull
  , extractSignalInfo
  , extractTextUnsafe
  ) where

import Control.Exception
import Control.Monad.Primitive
import Data.ByteString.Short (ShortByteString)
import Data.ByteString.Short qualified as SBS
import Data.Text (Text)
import Data.Text.Array qualified as TA
import Data.Text.Internal qualified as T
import Data.Traversable
import Data.Tuple.Homogenous
import Data.Void
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import GHC.Exts
import GHC.IO
import GHC.Stack (CallStack, callStack)
import Prettyprinter

#ifdef ASSERTIONS
import Data.ByteString.Internal qualified as BSI
import Data.Text.Encoding qualified as TE
import Foreign.ForeignPtr qualified as Foreign
#endif

import Data.Emacs.Module.Env.Functions
import Data.Emacs.Module.NonNullPtr
import Data.Emacs.Module.Raw.Env (EnumFuncallExit(..))
import Data.Emacs.Module.Raw.Env qualified as Env
import Data.Emacs.Module.Raw.Env.Internal
import Data.Emacs.Module.Raw.Value
import Data.Emacs.Module.SymbolName.Internal
import Data.Emacs.Module.SymbolName.Predefined qualified as Sym
import Emacs.Module.Assert
import Emacs.Module.Errors
import Foreign.Ptr.Builder as PtrBuilder

data EmacsRes s t a
  = EmacsSuccess a
  | EmacsExitSignal s
  | EmacsExitThrow t
  deriving (Functor, Foldable, Traversable)

data NonLocalState = NonLocalState
  { nlsErr  :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular))
  , nlsData :: {-# UNPACK #-} !(NonNullPtr (RawValue 'Regular))
  , nlsSize :: {-# UNPACK #-} !(NonNullPtr CPtrdiff)
  }

withNonLocalState :: (NonLocalState -> IO a) -> IO a
withNonLocalState f =
  allocaNonNull $ \ !nlsErr ->
    allocaNonNull $ \ !nlsData ->
      allocaNonNull $ \ !nlsSize ->
        f NonLocalState{nlsErr, nlsData, nlsSize}

unpackEnumFuncallExit
  :: WithCallStack
  => EnumFuncallExit -> IO (FuncallExit ())
unpackEnumFuncallExit =
  either throwIO pure . unpackEnumFuncallExitSafe

unpackEnumFuncallExitSafe
  :: WithCallStack
  => EnumFuncallExit -> Either EmacsInternalError (FuncallExit ())
unpackEnumFuncallExitSafe (EnumFuncallExit (CInt !x)) =
  case funcallExitFromNum x of
    Nothing -> Left $ mkEmacsInternalError $
      "Unknown value of enum emacs_funcall_exit:" <+> pretty x
    Just y  -> Right y

{-# INLINE nonLocalExitGet #-}
nonLocalExitGet
  :: WithCallStack
  => Env
  -> NonLocalState
  -> IO (FuncallExit (RawValue 'Regular, RawValue 'Regular))
nonLocalExitGet env NonLocalState{nlsErr, nlsData} = do
  exit <- Env.nonLocalExitGet env nlsErr nlsData
  foldFuncallExitFromNum
    (unEnumFuncallExit exit)
    (throwIO $ mkEmacsInternalError $ "Unknown value of enum emacs_funcall_exit:" <+> pretty exit)
    (\x ->
      for x $ \(_ :: ()) ->
        (,) <$> peek (unNonNullPtr nlsErr) <*> peek (unNonNullPtr nlsData))
  -- x <- unpackEnumFuncallExit =<< Env.nonLocalExitGet env nlsErr nlsData
  -- for x $ \(_ :: ()) ->
  --   (,) <$> peek (unNonNullPtr nlsErr) <*> peek (unNonNullPtr nlsData)

{-# INLINE nonLocalExitSignal #-}
nonLocalExitSignal
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> CallStack
  -> RawValue 'Unknown           -- ^ Error symbol
  -> Builder (RawValue 'Regular) -- ^ Error data
  -> IO EmacsSignal
nonLocalExitSignal cache env !emacsSignalOrigin !sym !dat = do
  listSym <- reifySymbolUnknown env Sym.list
  withPtrLenNonNull (coerceBuilderCache cache) dat $ \n args -> do
    dat'            <- Env.funcallPrimitive env listSym (fromIntegral n) args
    emacsSignalInfo <- extractSignalInfo cache env sym dat'
    Env.nonLocalExitSignal env sym dat'
    pure EmacsSignal
      { emacsSignalSym  = toUnknown sym
      , emacsSignalData = dat'
      , emacsSignalOrigin
      , emacsSignalInfo
      }

{-# INLINE extractStringWith #-}
extractStringWith
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> NonLocalState
  -> RawValue p
  -> (Int# -> MutableByteArray# RealWorld -> IO b)
  -> IO (EmacsRes EmacsSignal Void b)
extractStringWith cache env !nls@NonLocalState{nlsSize} !x k = do
  res <- Env.copyStringContents env x nullPtr nlsSize
  if Env.isNonTruthy res
  then do
    Env.nonLocalExitClear env
    throwIO $ mkEmacsInternalError
      "Failed to obtain size when unpacking string. Probable cause: emacs object is not a string."
  else do
    I# size# <- fromIntegral <$> peek (unNonNullPtr nlsSize)
    IO $ \s1 -> case newPinnedByteArray# size# s1 of
      (# s2, mbarr# #) -> (\kk -> kk s2) (unIO (do
        !copyPerformed <- Env.copyStringContents env x (Ptr (mutableByteArrayContents# mbarr#)) nlsSize
        if Env.isTruthy copyPerformed
        then
          EmacsSuccess <$> k size# mbarr#
        else
         nonLocalExitGet env nls >>= \case
           FuncallExitSignal (sym, dat) -> do
             -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
             Env.nonLocalExitClear env
             emacsSignalInfo <- extractSignalInfo cache env sym dat
             pure $ EmacsExitSignal $ EmacsSignal
               { emacsSignalSym    = toUnknown sym
               , emacsSignalData   = dat
               , emacsSignalOrigin = callStack
               , emacsSignalInfo
               }
           FuncallExitReturn            ->
             throwIO $ mkEmacsInternalError "Failed to unpack string"
           FuncallExitThrow{} ->
             throwIO $ mkEmacsInternalError
               "The copy string contents operation should have never exited via throw"))

{-# INLINE extractText #-}
extractText
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> NonLocalState
  -> RawValue p
  -> IO (EmacsRes EmacsSignal Void Text)
extractText cache env nls x =
  extractStringWith cache env nls x $ \size# mbarr# ->
#ifdef ASSERTIONS
    do
      -- Should subtract 1 from size to avoid NULL terminator at the end.
      ptr <- Foreign.newForeignPtr_ (Ptr (mutableByteArrayContents# mbarr#))
      evaluate $ TE.decodeUtf8 $ BSI.BS ptr (I# (size# -# 1#))
#else
    IO $ \s1 ->
      case unsafeFreezeByteArray# mbarr# s1 of
        (# s2, barr #) ->
          -- Should subtract 1 from size to avoid NULL terminator at the end.
          (# s2, T.Text (TA.ByteArray barr) 0 (I# (size# -# 1#)) #)
#endif

{-# INLINE extractShortByteString #-}
extractShortByteString
  :: WithCallStack
  => BuilderCache (RawValue a)
  -> Env
  -> NonLocalState
  -> RawValue p
  -> IO (EmacsRes EmacsSignal Void ShortByteString)
extractShortByteString cache env nls x =
  extractStringWith cache env nls x $ \size# mbarr# ->
    IO $ \s3 ->
      -- Should subtract 1 from size to avoid NULL terminator at the end.
      case shrinkMutableByteArray# mbarr# (size# -# 1#) s3 of
        s4 ->
          case unsafeFreezeByteArray# mbarr# s4 of
            (# s5, barr #) ->
              (# s5, SBS.SBS barr #)

{-# INLINE checkNonLocalExitSignal #-}
checkNonLocalExitSignal
  :: WithCallStack
  => BuilderCache (RawValue b)
  -> Env
  -> NonLocalState
  -> Text
  -> a
  -> IO (EmacsRes EmacsSignal Void a)
checkNonLocalExitSignal cache env !nls !errMsg !res = do
  nonLocalExitGet env nls >>= \ case
    FuncallExitReturn            ->
      pure $ EmacsSuccess res
    FuncallExitSignal (sym, dat) -> do
      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
      Env.nonLocalExitClear env
      emacsSignalInfo <- extractSignalInfo cache env sym dat
      pure $ EmacsExitSignal $ EmacsSignal
        { emacsSignalSym    = toUnknown sym
        , emacsSignalData   = dat
        , emacsSignalOrigin = callStack
        , emacsSignalInfo
        }
    FuncallExitThrow{} ->
      throwIO $ mkEmacsInternalError $
        "The operation should have never exited via throw:" <> line <> pretty errMsg

{-# INLINE checkNonLocalExitFull #-}
checkNonLocalExitFull
  :: WithCallStack
  => BuilderCache (RawValue b)
  -> Env
  -> NonLocalState
  -> a
  -> IO (EmacsRes EmacsSignal EmacsThrow a)
checkNonLocalExitFull cache env !nls !res =
  nonLocalExitGet env nls >>= \case
    FuncallExitReturn            ->
      pure $ EmacsSuccess res
    FuncallExitSignal (sym, dat) -> do
      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
      Env.nonLocalExitClear env
      emacsSignalInfo <- extractSignalInfo cache env sym dat
      pure $ EmacsExitSignal $ EmacsSignal
        { emacsSignalSym    = toUnknown sym
        , emacsSignalData   = dat
        , emacsSignalOrigin = callStack
        , emacsSignalInfo
        }
      -- -- Important to clean up so that we can still call Emacs
      -- -- functions to make nil return value, etc
      -- Env.nonLocalExitClear env
    FuncallExitThrow (tag, value) -> do
      -- Important to clean up so that we can still call Emacs functions to make nil return value, etc
      Env.nonLocalExitClear env
      pure $ EmacsExitThrow $ EmacsThrow
        { emacsThrowTag    = tag
        , emacsThrowValue  = value
        , emacsThrowOrigin = callStack
        }

extractSignalInfo
  :: WithCallStack
  => BuilderCache (RawValue a) -> Env -> RawValue p -> RawValue 'Regular -> IO Text
extractSignalInfo cache env !sym !dat = do
  cons          <- reifySymbolUnknown env Sym.cons
  dat'          <- withPtrLenNonNull (coerceBuilderCache cache) (foldMap PtrBuilder.storable $ Tuple2 (toUnknown sym, toUnknown dat)) $ \n args ->
    Env.funcallPrimitive env cons (fromIntegral n) args
  prin1ToString <- reifySymbolUnknown env Sym.prin1ToString
  formatted     <- withPtrLenNonNull (coerceBuilderCache cache) (foldMap PtrBuilder.storable $ Tuple1 dat') $ \n args ->
    Env.funcallPrimitive env prin1ToString (fromIntegral n) args
  formatRes     <- unpackEnumFuncallExit =<< Env.nonLocalExitCheck env
  case formatRes of
    FuncallExitSignal{} -> do
      Env.nonLocalExitClear env
      throwIO $ mkEmacsInternalError "Failed to format Emacs signal data"
    FuncallExitThrow{}  -> do
      Env.nonLocalExitClear env
      throwIO $ mkEmacsInternalError "Failed to format Emacs signal data"
    FuncallExitReturn   ->
      extractTextUnsafe env formatted

extractTextUnsafe
  :: WithCallStack
  => Env
  -> RawValue p
  -> IO Text
extractTextUnsafe env !x = do
  allocaNonNull $ \pSize -> do
    res <- Env.copyStringContents env x nullPtr pSize
    if Env.isNonTruthy res
    then do
      Env.nonLocalExitClear env
      throwIO $ mkEmacsInternalError
        "Failed to obtain size when unpacking string. Probable cause: emacs object is not a string."
    else do
      !size@(I# size#) <- fromIntegral <$> peek (unNonNullPtr pSize)
      IO $ \s1 -> case newPinnedByteArray# size# s1 of
        (# s2, mbarr #) -> (\k -> k s2) (unIO (do
          !copyPerformed <- Env.copyStringContents env x (Ptr (mutableByteArrayContents# mbarr)) pSize
          if Env.isTruthy copyPerformed
          then
            IO $ \s3 ->
              case unsafeFreezeByteArray# mbarr s3 of
                (# s4, barr #) ->
                  -- Should subtract 1 from size to avoid NULL terminator at the end.
                  (# s4, T.Text (TA.ByteArray barr) 0 (size -  1) #)
          else do
            Env.nonLocalExitClear env
            throwIO $ mkEmacsInternalError "Failed to unpack string"))