FLAM.hs

{-# LANGUAGE MagicHash #-}

-- We capitalize module names, but use camelCase/PascalCase in code:
--
-- - in types names:    FlamFoo, FooFlamBar
-- - in variable names: flamFoo, fooFlamBar

-- | Intended for qualified import.
--
-- @
-- import HsBindgen.Runtime.FLAM (WithFlam)
-- import HsBindgen.Runtime.FLAM qualified as FLAM
-- @
module HsBindgen.Runtime.FLAM (
  -- * Definitions
  Offset (..),
  NumElems (..),
  WithFlam (..),

  -- * Exceptions
  FlamLengthMismatch (..),
) where

import Control.Exception (Exception, throwIO)
import Data.Kind (Type)
import Data.Vector.Storable qualified as VS
import Data.Vector.Storable.Mutable qualified as VSM
import Foreign (Ptr, Storable)
import Foreign qualified
import GHC.Exts (Proxy#, proxy#)

import HsBindgen.Runtime.Marshal

{-------------------------------------------------------------------------------
  Definitions
-------------------------------------------------------------------------------}

-- | The offset of the FLAM to the beginning of the underlying data structure in
--   bytes
class Offset elem aux | aux -> elem where
  offset :: Proxy# aux -> Int

-- | The number of elements 'elem' of the FLAM contained in structure 'aux'
class (Offset elem aux) => NumElems elem aux | aux -> elem where
  numElems :: aux -> Int

-- | Data structure with flexible array member
data WithFlam elem aux = WithFlam
  { -- Underlying data structure without FLAM
    aux :: !aux
  , -- We use the word "flam" for the flexible array member of the struct.
    -- We use the word "vector" to refer to its Haskell representation (as a
    -- vector).
    flam :: {-# UNPACK #-} !(VS.Vector elem)
  }
  deriving stock (Show)

instance
  (Storable aux, Storable elem, NumElems elem aux)
  => ReadRaw (WithFlam elem aux)
  where
  readRaw = peek

instance
  (Storable aux, Storable elem, NumElems elem aux)
  => WriteRaw (WithFlam elem aux)
  where
  writeRaw = poke

{-------------------------------------------------------------------------------
  Peek and poke
-------------------------------------------------------------------------------}

-- | Peek structure with flexible array member.
peek
  :: forall aux elem
   . (Storable aux, Storable elem, NumElems elem aux)
  => Ptr (WithFlam elem aux) -> IO (WithFlam elem aux)
peek ptrStruct = do
  aux <- Foreign.peek (ptrToAux ptrStruct)
  let Size{sizeNumElems, sizeNumBytes} = flamSize aux
  vector <- VSM.unsafeNew sizeNumElems
  Foreign.withForeignPtr (fst (VSM.unsafeToForeignPtr0 vector)) $ \ptrVectorElems -> do
    Foreign.copyBytes ptrVectorElems (ptrToFlam ptrStruct) sizeNumBytes
  vector' <- VS.unsafeFreeze vector
  return (WithFlam aux vector')

-- | Poke structure with flexible array member.
poke
  :: forall aux elem
   . (Storable aux, Storable elem, NumElems elem aux)
  => Ptr (WithFlam elem aux) -> WithFlam elem aux -> IO ()
poke ptrStruct (WithFlam aux vector)
  | sizeNumElems /= VS.length vector =
      throwIO $ FlamLengthMismatch sizeNumElems (VS.length vector)
  | otherwise = do
      Foreign.poke (ptrToAux ptrStruct) aux
      VS.unsafeWith vector $ \ptrVectorElems -> do
        Foreign.copyBytes (ptrToFlam ptrStruct) ptrVectorElems sizeNumBytes
 where
  Size{sizeNumElems, sizeNumBytes} = flamSize aux

{-------------------------------------------------------------------------------
  Exceptions
-------------------------------------------------------------------------------}

-- | Exception thrown when 'writeRaw' detects a FLAM length mismatch
data FlamLengthMismatch = FlamLengthMismatch
  { flamLengthStruct :: Int
  , flamLengthProvided :: Int
  }
  deriving stock (Show)

instance Exception FlamLengthMismatch

{-------------------------------------------------------------------------------
  Internal helpers
-------------------------------------------------------------------------------}

ptrToAux :: Ptr (WithFlam elem aux) -> Ptr aux
ptrToAux = Foreign.castPtr

ptrToFlam
  :: forall elem aux
   . (Offset elem aux)
  => Ptr (WithFlam elem aux) -> Ptr elem
ptrToFlam ptrStruct = Foreign.plusPtr ptrStruct (offset (proxy# @aux))

-- Internal.
data Size = Size
  { sizeNumElems :: Int
  , sizeNumBytes :: Int
  }

flamSize
  :: forall (elem :: Type) aux
   . (NumElems elem aux, Storable elem)
  => aux -> Size
flamSize aux =
  Size
    { sizeNumElems
    , sizeNumBytes = sizeNumElems * Foreign.sizeOf (undefined :: elem)
    }
 where
  sizeNumElems = numElems aux