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(..)
  , Py(..)
  , pyIO
    -- ** Python code wrappers
  , PyQuote(..)
  , 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.IO.Class
import Control.Monad.Catch
import Control.Monad.Primitive (PrimMonad(..),RealWorld)
import Control.Exception
import Data.Coerce
import Data.Int
import Data.ByteString             qualified as BS
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

-- | Removes exception masking
instance MonadIO Py where
  liftIO = Py . interruptible

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


----------------------------------------------------------------
-- 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
  }


-- | 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
codeFromText = Code . T.encodeUtf8

-- | 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)