Foreign.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}

-- |
-- Miscellaneous utility functions for marshalling values to/from C. The most
-- notable thing in this module is the `Freeable` typeclass.
module Raylib.Internal.Foreign
  ( c'free,
    p'free,
    freeMaybePtr,
    Freeable (..),
    rlFreeMaybeArray,
    pop,
    popCArray,
    popCString,
    withFreeable,
    withFreeableArray,
    withFreeableArrayLen,
    withFreeableArray2D,
    configsToBitflag,
    withMaybe,
    withMaybeCString,
    withCStringBuffer,
    peekMaybe,
    peekMaybeOff,
    pokeMaybe,
    pokeMaybeOff,
    peekMaybeArray,
    newMaybeArray,
    peekStaticArray,
    peekStaticArrayOff,
    pokeStaticArray,
    pokeStaticArrayOff,
    rightPad,
  )
where

import Control.Monad (forM_, unless)
import Data.Bits ((.|.))
import qualified Data.ByteString as BS
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Foreign (FunPtr, Ptr, Storable (peek, peekByteOff, poke, sizeOf), allocaBytes, castPtr, malloc, newArray, nullPtr, peekArray, plusPtr, pokeArray0, with, withArray, withArrayLen)
import Foreign.C (CFloat, CInt, CString, CUChar, CUInt, peekCString, withCString)
import Foreign.C.Types (CBool, CChar, CShort, CUShort)

#ifndef DISABLE_LENS

import Linear (V2, V3, V4)

#endif

-- Internal utility functions

#ifdef WEB_FFI

import Raylib.Internal.Web.Native (jsfree, p'jsfree)

c'free :: Ptr () -> IO ()
c'free = jsfree

p'free :: FunPtr (Ptr a -> IO ())
p'free = p'jsfree

#else

foreign import ccall "stdlib.h free" c'free :: Ptr () -> IO ()

foreign import ccall "stdlib.h &free" p'free :: FunPtr (Ptr a -> IO ())

#endif

freeMaybePtr :: Ptr () -> IO ()
freeMaybePtr ptr = unless (ptr == nullPtr) (c'free ptr)

-- | A typeclass used internally to free complex data types. You will most
--   likely not have to use this directly. If you do need to implement it, you
--   can probably just stick with the default definitions of `rlFree` and
--   `rlFreeDependents`.
class Freeable a where
  -- | Frees the data \"dependent\" on a pointer, which usually means dynamic
  --   C arrays, i.e. more pointers
  rlFreeDependents :: a -> Ptr a -> IO ()
  rlFreeDependents _ _ = return ()

  -- | Receives a pointer and frees all of the data associated with it,
  --   including the pointer itself
  rlFree :: a -> Ptr a -> IO ()
  rlFree val ptr = rlFreeDependents val ptr >> c'free (castPtr ptr)

instance Freeable CBool

instance Freeable CChar

instance Freeable CFloat

instance Freeable CInt

instance Freeable CShort

instance Freeable CUChar

instance Freeable CUInt

instance Freeable CUShort

instance Freeable (Ptr CChar) where
  rlFreeDependents str _ = c'free (castPtr str)

instance (Freeable a, Storable a) => Freeable [a] where
  rlFreeDependents arr ptr =
    forM_
      [0 .. length arr - 1]
      ( \i -> do
          let val = arr !! i in rlFreeDependents val (plusPtr ptr (i * sizeOf val))
      )

#ifndef DISABLE_LENS

instance Freeable (V2 a)

instance Freeable (V3 a)

instance Freeable (V4 a)

#endif

rlFreeMaybeArray :: (Freeable a, Storable a) => Maybe [a] -> Ptr a -> IO ()
rlFreeMaybeArray Nothing _ = return ()
rlFreeMaybeArray (Just arr) ptr = rlFree arr (castPtr ptr)

pop :: (Freeable a, Storable a) => Ptr a -> IO a
pop ptr = do
  val <- peek ptr
  rlFree val ptr
  return val

popCArray :: (Storable a) => Int -> Ptr a -> IO [a]
popCArray count ptr = do
  str <- peekArray count ptr
  c'free $ castPtr ptr
  return str

popCString :: CString -> IO String
popCString ptr = do
  str <- peekCString ptr
  c'free $ castPtr ptr
  return str

withFreeable :: (Freeable a, Storable a) => a -> (Ptr a -> IO b) -> IO b
withFreeable val f = do
  with
    val
    ( \ptr -> do
        result <- f ptr
        rlFreeDependents val ptr
        return result
    )

withFreeableArray :: (Freeable a, Storable a) => [a] -> (Ptr a -> IO b) -> IO b
withFreeableArray arr f = do
  withArray
    arr
    ( \ptr -> do
        result <- f ptr
        rlFreeDependents arr (castPtr ptr)
        return result
    )

withFreeableArrayLen :: (Freeable a, Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b
withFreeableArrayLen arr f = do
  withArrayLen
    arr
    ( \l ptr -> do
        result <- f l ptr
        rlFreeDependents arr (castPtr ptr)
        return result
    )

withFreeableArray2D :: (Freeable a, Storable a) => [[a]] -> (Ptr (Ptr a) -> IO b) -> IO b
withFreeableArray2D arr func = do
  arrays <- mapM newArray arr
  ptr <- newArray arrays
  res <- func ptr
  forM_ (zip [0 ..] arrays) (\(i, a) -> rlFree (arr !! i) (castPtr a))
  c'free $ castPtr ptr
  return res

configsToBitflag :: (Enum a) => [a] -> Integer
configsToBitflag = fromIntegral . foldr folder (toEnum 0)
  where
    folder a b = fromEnum a .|. b

withMaybe :: (Storable a) => Maybe a -> (Ptr a -> IO b) -> IO b
withMaybe a f = case a of
  (Just val) -> with val f
  Nothing -> f nullPtr

withMaybeCString :: Maybe String -> (CString -> IO b) -> IO b
withMaybeCString a f = case a of
  (Just val) -> withCString val f
  Nothing -> f nullPtr

withCStringBuffer :: String -> Maybe Int -> (Int -> CString -> IO b) -> IO (b, String)
withCStringBuffer str bufferSize f = do
  let bytes = BS.unpack (TE.encodeUtf8 (T.pack str))
      bufferSize' = fromMaybe (length bytes + 8) bufferSize
  allocaBytes
    bufferSize'
    ( \buffer -> do
        pokeArray0 0 buffer (map fromIntegral bytes)
        res <- f bufferSize' buffer
        str' <- peekCString buffer
        return (res, str')
    )

peekMaybe :: (Storable a) => Ptr (Ptr a) -> IO (Maybe a)
peekMaybe ptr = do
  ref <- peek ptr
  if ref == nullPtr then return Nothing else Just <$> peek ref

peekMaybeOff :: (Storable a) => Ptr (Ptr a) -> Int -> IO (Maybe a)
peekMaybeOff ptr off = do
  ref <- peekByteOff ptr off
  if ref == nullPtr then return Nothing else Just <$> peek ref

pokeMaybe :: (Storable a) => Ptr (Ptr a) -> Maybe a -> IO ()
pokeMaybe ptr val = case val of
  Nothing -> poke ptr nullPtr
  Just a -> do
    nested <- malloc
    poke nested a
    poke ptr nested

pokeMaybeOff :: (Storable a) => Ptr (Ptr a) -> Int -> Maybe a -> IO ()
pokeMaybeOff ptr off = pokeMaybe (plusPtr ptr off)

peekMaybeArray :: (Storable a) => Int -> Ptr a -> IO (Maybe [a])
peekMaybeArray size ptr = if ptr == nullPtr then return Nothing else Just <$> peekArray size ptr

newMaybeArray :: (Storable a) => Maybe [a] -> IO (Ptr a)
newMaybeArray a = case a of
  (Just arr) -> newArray arr
  Nothing -> return nullPtr

peekStaticArray :: (Storable a) => Int -> Ptr a -> IO [a]
peekStaticArray size ptr = reverse <$> helper size ptr []
  where
    helper s p a =
      if s == 0
        then return a
        else do
          val <- peek p
          helper (s - 1) (plusPtr p (sizeOf val)) (val : a)

peekStaticArrayOff :: (Storable a) => Int -> Ptr a -> Int -> IO [a]
peekStaticArrayOff size ptr off = peekStaticArray size (plusPtr ptr off)

pokeStaticArray :: (Storable a) => Ptr a -> [a] -> IO ()
pokeStaticArray _ [] = return ()
pokeStaticArray ptr (x : xs) = poke ptr x >> pokeStaticArray (plusPtr ptr $ sizeOf x) xs

pokeStaticArrayOff :: (Storable a) => Ptr a -> Int -> [a] -> IO ()
pokeStaticArrayOff ptr off = pokeStaticArray (plusPtr ptr off)

rightPad :: Int -> a -> [a] -> [a]
rightPad size val arr = take size $ arr ++ repeat val