Types.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}
-- |
-- Definition of data types used by inline-python. They are moved to
-- separate module since some are required for @inline-c@'s context
-- and we need context for
module Python.Internal.Types
  ( -- * Data type
    PyObject(..)
  , withPyObject
  , unsafeWithPyObject
  , PyThreadState
  , PyError(..)
  , PyException(..)
  , PyInternalError(..)
  , PyThreadId(..)
  , Py(..)
  , pyIO
    -- ** Python code wrappers
  , PyQuote(..)
  , PyQuoteFun(..)
  , Code(..)
  , codeFromText
  , codeFromString
  , DictBinder(..)
    -- * inline-C
  , pyCtx
    -- * Patterns
  , pattern IPY_OK
  , pattern IPY_ERR_COMPILE
  , pattern IPY_ERR_PYTHON
  , pattern NULL
  , pattern FALSE
  , pattern TRUE
  ) where

import Control.Monad.Catch
import Control.Monad.Primitive (PrimMonad(..),RealWorld)
import Data.Coerce
import Data.Int
import Data.Word
import Data.ByteString             qualified as BS
import Data.ByteString.Lazy        qualified as BL
import Data.ByteString.Builder     qualified as BB
import Data.Map.Strict             qualified as Map
import Data.Text                   qualified as T
import Data.Text.Encoding          qualified as T
import Foreign.Ptr
import Foreign.C.Types
import Language.Haskell.TH.Syntax  qualified as TH
import GHC.ForeignPtr

import Language.C.Types
import Language.C.Inline.Context


----------------------------------------------------------------
-- Primitives
----------------------------------------------------------------

-- | Pointer tag
data PyThreadState

-- | Some python object. Since almost everything in python is mutable
--   it could only be accessed only in IO monad.
newtype PyObject = PyObject (ForeignPtr PyObject)
  deriving stock Show

withPyObject :: forall a. PyObject -> (Ptr PyObject -> Py a) -> Py a
withPyObject = coerce (withForeignPtr @PyObject @a)

unsafeWithPyObject :: forall a. PyObject -> (Ptr PyObject -> Py a) -> Py a
unsafeWithPyObject = coerce (unsafeWithForeignPtr @PyObject @a)

-- | Python exception converted to haskell.
data PyError
  = PyError !PyException
    -- ^ Python exception. Contains exception type and message as strings.
  | BadPyType
    -- ^ It's not possible to convert given python value to a haskell
    --   value
  | OutOfRange
    -- ^ Data type is suitable but value is outside of allowed
    --   range. For example attempting to convert 1000 to @Word8@ will
    --   result in this exception.
  | PyInitializationFailed
    -- ^ Initialization of python interpreter failed
  | PythonNotInitialized
    -- ^ Python interpreter is not initialized
  | PythonIsFinalized
    -- ^ Python interpreter is not initialized
  deriving stock    (Show)
  deriving anyclass (Exception)

-- | Python exception converted to haskell value
data PyException = PyException
  { ty        :: !String   -- ^ Exception type as a string
  , str       :: !String   -- ^ String representation of an exception
  , exception :: !PyObject -- ^ Exception object
  }
  deriving stock Show

-- | Internal error. If this exception is thrown it means there's bug
--   in a library.
data PyInternalError = PyInternalError String
  deriving stock    (Show)
  deriving anyclass (Exception)

-- | Monad for code which is interacts with python interpreter. Only
--   one haskell thread can interact with python interpreter at a
--   time. Function that execute @Py@ make sure that this invariant is
--   held. Also note that all code in @Py@ monad is executed with
--   asynchronous exception masked, but 'liftIO' removes mask.
newtype Py a = Py (IO a)
  -- See NOTE: [Python and threading]
  deriving newtype (Functor,Applicative,Monad,MonadFail,
                    MonadThrow,MonadCatch,MonadMask)

-- | Inject @IO@ into @Py@ monad without changing masking state
--   (unlike 'liftIO')
pyIO :: IO a -> Py a
pyIO = Py

instance PrimMonad Py where
  type PrimState Py = RealWorld
  primitive = Py . primitive
  {-# INLINE primitive #-}


-- | Identifier of python's thread as python understands them.
newtype PyThreadId = PyThreadId Word64
  deriving stock (Show,Eq,Ord)


----------------------------------------------------------------
-- Code wrappers
----------------------------------------------------------------

-- | Quasiquoted python code. It contains source code and closure
--   which populates dictionary with local variables. @PyQuote@ value
--   which captures local variables could be created using
--   'Python.Inline.QQ.pycode' quasiquoter.
--
--   @since 0.2@
data PyQuote = PyQuote
  { code   :: !Code
  , binder :: !DictBinder
  }


-- | Quasiquoted body of python function which could be used by
--   'Python.Inline.Eval.evalPyFunction'. Function body must be
--   wrapped in @_inline_python_@ function which quasiquoter
--   'Python.Inline.QQ.pyfun' does automatically.
--
--   @since 0.3@
data PyQuoteFun = PyQuoteFun
  { code   :: !Code
  , binder :: !DictBinder
  }


-- | UTF-8 encoded python source code.
--
--   @since 0.2@
newtype Code = Code BS.ByteString
  deriving stock (Show, TH.Lift)

-- | Create properly encoded @Code@. This function doesn't check
--   syntactic validity.
--
--   @since 0.2@
codeFromText :: T.Text -> Code
-- NOTE: We consume code with BS.useAsCString and python C API expect
--       NULL-terminated string. We have to add terminator manually
codeFromText code
  = Code
  $ BL.toStrict
  $ BB.toLazyByteString
  $ T.encodeUtf8Builder code <> BB.word8 0

-- | Create properly encoded @Code@. This function doesn't check
--   syntactic validity.
--
--   @since 0.2@
codeFromString :: String -> Code
codeFromString = codeFromText . T.pack

-- | Closure which stores values in provided python dictionary.
--
--   @since 0.2@
newtype DictBinder = DictBinder { bind :: Ptr PyObject -> Py () }

instance Semigroup DictBinder where
  f <> g = DictBinder $ \p -> f.bind p >> g.bind p
instance Monoid DictBinder where
  mempty = DictBinder $ \_ -> pure ()


----------------------------------------------------------------
-- inline-C
----------------------------------------------------------------

-- | @inline-c@ context for mapping
pyCtx :: Context
pyCtx = mempty { ctxTypesTable = Map.fromList tytabs } where
  tytabs =
    [ ( TypeName "PyObject",      [t| PyObject      |])
    , ( TypeName "PyThreadState", [t| PyThreadState |])
    , ( TypeName "PyCFunction"
      , [t| FunPtr (Ptr PyObject -> Ptr PyObject -> IO (Ptr PyObject)) |])
    , ( TypeName "PyCFunctionFast"
      , [t| FunPtr (Ptr PyObject -> Ptr (Ptr PyObject) -> Int64 -> IO (Ptr PyObject)) |])
    ]


----------------------------------------------------------------
-- Patterns
----------------------------------------------------------------

pattern IPY_OK, IPY_ERR_PYTHON, IPY_ERR_COMPILE :: CInt
-- | Success
pattern IPY_OK          = 0
-- | Python exception raised
pattern IPY_ERR_PYTHON  = 1
-- | Error while compiling python source to byte code. Normally it
--   shouldn't happen.
pattern IPY_ERR_COMPILE = 2


pattern NULL :: Ptr a
pattern NULL <- ((== nullPtr) -> True) where
  NULL = nullPtr

pattern FALSE :: CInt
pattern FALSE = 0

pattern TRUE :: CInt
pattern TRUE <- ((/= 0) -> True)