{-# LANGUAGE ForeignFunctionInterface #-}

{-|
Description:    Utility functions for the libcdio FFI.

Copyright:      (c) 2018-2021 Sam May
License:        GPL-3.0-or-later
Maintainer:     ag@eitilt.life

Stability:      provisional
Portability:    portable
-}
module Foreign.Libcdio.Marshal
    ( -- * Types
      -- ** Cdio
      Cdio
    , withCdio
    , withCdio_
    , withCdioPtr
    , peekCdio
      -- ** CdText
    , CdText
    , withCdText
    , withCdText'
    , withCdText_
    , hasCdText
    , cdTextDataInit
      -- * Management
    , setupLogger
    , genBitArray
      -- * Marshalling
      -- ** Bool
    , errorOrBool
    , bool3
      -- ** Int
    , errorOrInt
    , maybeError
      -- ** Enum a
    , joinEnumFlags
    , modEnumFlags
      -- ** ByteString
    , peekByteStringLen
      -- ** String
    , allocaStringArray
      -- ** FString
    , peekFString
    , peekFStringArray
    ) where


import qualified Data.Array.BitArray as A
import qualified Data.Bits as B
import qualified Data.ByteString as BS
import qualified Data.Ix as I
import qualified Data.Maybe as Y

import qualified Foreign.C.String as C
import qualified Foreign.C.Types as C
import qualified Foreign.ForeignPtr as C
import qualified Foreign.Ptr as C

import qualified Foreign.Marshal.Alloc as M
import qualified Foreign.Marshal.Array as M
import qualified Foreign.Marshal.Utils as M

import qualified Foreign.Storable as S


-- | Helper to convert device capabilities to a bitfield.
genBitArray :: (Bounded a, I.Ix a) => [a] -> A.BitArray a
genBitArray :: [a] -> BitArray a
genBitArray [] = (a, a) -> BitArray a
forall i. Ix i => (i, i) -> BitArray i
A.false (a
forall a. Bounded a => a
minBound, a
forall a. Bounded a => a
maxBound)
genBitArray [a]
cs = (a, a) -> [(a, Bool)] -> BitArray a
forall i. Ix i => (i, i) -> [(i, Bool)] -> BitArray i
A.array (a
forall a. Bounded a => a
minBound, a
forall a. Bounded a => a
maxBound) ([(a, Bool)] -> BitArray a) -> [(a, Bool)] -> BitArray a
forall a b. (a -> b) -> a -> b
$ (a -> (a, Bool)) -> [a] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
i -> (a
i, Bool
True)) [a]
cs


-- | A particular disc reading/writing device, along with the data contained
-- on the loaded disc.  Note well that this is always a mutable object, and is
-- not thread-safe; moreover, any function this is passed to may wind up
-- silently modifying the data.
data Cdio = Cdio (Maybe (C.ForeignPtr Cdio)) (Maybe (C.ForeignPtr CdText))

-- | Free all memory used by a reference to a device.
foreign import ccall "cdio/compat/device.h &cdio_destroy"
  cdioDestroy :: C.FinalizerPtr Cdio

-- | Convert the (foreign) reference to a device to something the FFI can use.
withCdio :: Cdio -> (C.Ptr Cdio -> IO b) -> IO (Maybe b)
withCdio :: Cdio -> (Ptr Cdio -> IO b) -> IO (Maybe b)
withCdio (Cdio Maybe (ForeignPtr Cdio)
Nothing Maybe (ForeignPtr CdText)
_) = IO (Maybe b) -> (Ptr Cdio -> IO b) -> IO (Maybe b)
forall a b. a -> b -> a
const (IO (Maybe b) -> (Ptr Cdio -> IO b) -> IO (Maybe b))
-> IO (Maybe b) -> (Ptr Cdio -> IO b) -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
withCdio (Cdio (Just ForeignPtr Cdio
c) Maybe (ForeignPtr CdText)
_) = (b -> Maybe b) -> IO b -> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe b
forall a. a -> Maybe a
Just (IO b -> IO (Maybe b))
-> ((Ptr Cdio -> IO b) -> IO b)
-> (Ptr Cdio -> IO b)
-> IO (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignPtr Cdio -> (Ptr Cdio -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
C.withForeignPtr ForeignPtr Cdio
c

withCdio_ :: Cdio -> (C.Ptr Cdio -> IO ()) -> IO ()
withCdio_ :: Cdio -> (Ptr Cdio -> IO ()) -> IO ()
withCdio_ Cdio
c Ptr Cdio -> IO ()
f = Cdio -> (Ptr Cdio -> IO ()) -> IO (Maybe ())
forall b. Cdio -> (Ptr Cdio -> IO b) -> IO (Maybe b)
withCdio Cdio
c Ptr Cdio -> IO ()
f IO (Maybe ()) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. Monoid a => a
mempty

-- | Marshall a device reference with an extra layer of indirection.
withCdioPtr :: Cdio -> (C.Ptr (C.Ptr Cdio) -> IO b) -> IO (Maybe b)
withCdioPtr :: Cdio -> (Ptr (Ptr Cdio) -> IO b) -> IO (Maybe b)
withCdioPtr (Cdio Maybe (ForeignPtr Cdio)
Nothing Maybe (ForeignPtr CdText)
_) Ptr (Ptr Cdio) -> IO b
_ = Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
withCdioPtr (Cdio (Just ForeignPtr Cdio
c) Maybe (ForeignPtr CdText)
_) Ptr (Ptr Cdio) -> IO b
f = (Ptr (Ptr Cdio) -> IO (Maybe b)) -> IO (Maybe b)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
M.alloca ((Ptr (Ptr Cdio) -> IO (Maybe b)) -> IO (Maybe b))
-> (Ptr (Ptr Cdio) -> IO (Maybe b)) -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr Cdio)
p ->
    ForeignPtr Cdio -> (Ptr Cdio -> IO (Maybe b)) -> IO (Maybe b)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
C.withForeignPtr ForeignPtr Cdio
c ((Ptr Cdio -> IO (Maybe b)) -> IO (Maybe b))
-> (Ptr Cdio -> IO (Maybe b)) -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ \Ptr Cdio
c' -> do
        Ptr (Ptr Cdio) -> Ptr Cdio -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
S.poke Ptr (Ptr Cdio)
p Ptr Cdio
c'
        b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> IO b -> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (Ptr Cdio) -> IO b
f Ptr (Ptr Cdio)
p

-- | Un-marshall a newly-allocated pointer to a drive.
peekCdio :: C.Ptr Cdio -> IO Cdio
peekCdio :: Ptr Cdio -> IO Cdio
peekCdio Ptr Cdio
c = do
    -- All public methods of opening 'Cdio' objects already have this earlier to
    -- catch any logs from opening the disc, but add it again just to be safe.
    IO ()
setupLogger
    Maybe (Ptr CdText)
x <- (Ptr Cdio -> IO (Ptr CdText))
-> Ptr Cdio -> IO (Maybe (Ptr CdText))
forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
M.maybePeek Ptr Cdio -> IO (Ptr CdText)
getCdText' Ptr Cdio
c
    Maybe (ForeignPtr CdText)
x' <- case Maybe (Ptr CdText)
x of
        Just Ptr CdText
x' -> ForeignPtr CdText -> Maybe (ForeignPtr CdText)
forall a. a -> Maybe a
Just (ForeignPtr CdText -> Maybe (ForeignPtr CdText))
-> IO (ForeignPtr CdText) -> IO (Maybe (ForeignPtr CdText))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CdText -> IO (ForeignPtr CdText)
forall a. Ptr a -> IO (ForeignPtr a)
C.newForeignPtr_ Ptr CdText
x'
        Maybe (Ptr CdText)
Nothing -> Maybe (ForeignPtr CdText) -> IO (Maybe (ForeignPtr CdText))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ForeignPtr CdText)
forall a. Maybe a
Nothing
    ForeignPtr Cdio
p' <- FinalizerPtr Cdio -> Ptr Cdio -> IO (ForeignPtr Cdio)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
C.newForeignPtr FinalizerPtr Cdio
cdioDestroy Ptr Cdio
c
    Cdio -> IO Cdio
forall (m :: * -> *) a. Monad m => a -> m a
return (Cdio -> IO Cdio) -> Cdio -> IO Cdio
forall a b. (a -> b) -> a -> b
$ Maybe (ForeignPtr Cdio) -> Maybe (ForeignPtr CdText) -> Cdio
Cdio (ForeignPtr Cdio -> Maybe (ForeignPtr Cdio)
forall a. a -> Maybe a
Just ForeignPtr Cdio
p') Maybe (ForeignPtr CdText)
x'

foreign import ccall "cdio/compat/disc.h cdio_get_cdtext"
  getCdText' :: C.Ptr Cdio -> IO (C.Ptr CdText)


-- | Initialize the log-management backend to use the mechanisms provided by
-- this library instead of just printing to standard output.  While this will
-- usually be taken care of automatically, it may still be necessary to call
-- this explicitly if messages are being recorded before any disc session is
-- opened.
foreign import ccall "cdio/compat/logging.h setup_cdio_logger"
  setupLogger :: IO ()


-- | The metadata describing the contents of a disc.
-- 
-- This type is not exported, and is mainly here to catch copy-paste errors on
-- my end.
data CdText

-- | Free all memory used by a reference to a device.
foreign import ccall "cdio/compat/cdtext.h &cdtext_destroy"
  cdTextDestroy :: C.FinalizerPtr CdText

-- | Convert the (foreign) reference to a device to something the FFI can use.
withCdText :: Cdio -> (C.Ptr CdText -> IO b) -> IO (Maybe b)
withCdText :: Cdio -> (Ptr CdText -> IO b) -> IO (Maybe b)
withCdText (Cdio Maybe (ForeignPtr Cdio)
_ Maybe (ForeignPtr CdText)
Nothing) = IO (Maybe b) -> (Ptr CdText -> IO b) -> IO (Maybe b)
forall a b. a -> b -> a
const (IO (Maybe b) -> (Ptr CdText -> IO b) -> IO (Maybe b))
-> IO (Maybe b) -> (Ptr CdText -> IO b) -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
withCdText (Cdio Maybe (ForeignPtr Cdio)
_ (Just ForeignPtr CdText
x)) = (b -> Maybe b) -> IO b -> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe b
forall a. a -> Maybe a
Just (IO b -> IO (Maybe b))
-> ((Ptr CdText -> IO b) -> IO b)
-> (Ptr CdText -> IO b)
-> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForeignPtr CdText -> (Ptr CdText -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
C.withForeignPtr ForeignPtr CdText
x

withCdText' :: b -> Cdio -> (C.Ptr CdText -> IO b) -> IO b
withCdText' :: b -> Cdio -> (Ptr CdText -> IO b) -> IO b
withCdText' b
b Cdio
c = (Maybe b -> b) -> IO (Maybe b) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Maybe b -> b
forall a. a -> Maybe a -> a
Y.fromMaybe b
b) (IO (Maybe b) -> IO b)
-> ((Ptr CdText -> IO b) -> IO (Maybe b))
-> (Ptr CdText -> IO b)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cdio -> (Ptr CdText -> IO b) -> IO (Maybe b)
forall b. Cdio -> (Ptr CdText -> IO b) -> IO (Maybe b)
withCdText Cdio
c

withCdText_ :: Cdio -> (C.Ptr CdText -> IO ()) -> IO ()
withCdText_ :: Cdio -> (Ptr CdText -> IO ()) -> IO ()
withCdText_ Cdio
c Ptr CdText -> IO ()
f = Cdio -> (Ptr CdText -> IO ()) -> IO (Maybe ())
forall b. Cdio -> (Ptr CdText -> IO b) -> IO (Maybe b)
withCdText Cdio
c Ptr CdText -> IO ()
f IO (Maybe ()) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. Monoid a => a
mempty

-- | Whether the various functions in "Foreign.Libcdio.CdText" will have any
-- effect, or simply return 'mempty'.
hasCdText :: Cdio -> Bool
hasCdText :: Cdio -> Bool
hasCdText (Cdio Maybe (ForeignPtr Cdio)
_ Maybe (ForeignPtr CdText)
x) = Maybe (ForeignPtr CdText) -> Bool
forall a. Maybe a -> Bool
Y.isJust Maybe (ForeignPtr CdText)
x


-- | Read binary CD-TEXT data into a structured datatype.
--
-- Note that binary CdText dumps will frequently include four bytes at the
-- beginning indicating the size of the file; this implementation expects that
-- those bytes /are not/ included.  If your dump does include them, @'BS.drop'
-- 4@ before passing the 'BS.ByteString' to this function.
-- 
-- /Before libcdio 0.94:  Always returns 'Nothing'/
cdTextDataInit :: BS.ByteString -> IO (Maybe Cdio)
cdTextDataInit :: ByteString -> IO (Maybe Cdio)
cdTextDataInit ByteString
bs = do
    IO ()
setupLogger
    ForeignPtr CdText
x <- IO (Ptr CdText)
cdTextInit' IO (Ptr CdText)
-> (Ptr CdText -> IO (ForeignPtr CdText)) -> IO (ForeignPtr CdText)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FinalizerPtr CdText -> Ptr CdText -> IO (ForeignPtr CdText)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
C.newForeignPtr FinalizerPtr CdText
cdTextDestroy
    Maybe CInt
b <- ByteString -> (CStringLen -> IO (Maybe CInt)) -> IO (Maybe CInt)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
bs ((CStringLen -> IO (Maybe CInt)) -> IO (Maybe CInt))
-> (CStringLen -> IO (Maybe CInt)) -> IO (Maybe CInt)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bs', Int
l) -> Cdio -> (Ptr CdText -> IO CInt) -> IO (Maybe CInt)
forall b. Cdio -> (Ptr CdText -> IO b) -> IO (Maybe b)
withCdText (Maybe (ForeignPtr Cdio) -> Maybe (ForeignPtr CdText) -> Cdio
Cdio Maybe (ForeignPtr Cdio)
forall a. Maybe a
Nothing (Maybe (ForeignPtr CdText) -> Cdio)
-> Maybe (ForeignPtr CdText) -> Cdio
forall a b. (a -> b) -> a -> b
$ ForeignPtr CdText -> Maybe (ForeignPtr CdText)
forall a. a -> Maybe a
Just ForeignPtr CdText
x) ((Ptr CdText -> IO CInt) -> IO (Maybe CInt))
-> (Ptr CdText -> IO CInt) -> IO (Maybe CInt)
forall a b. (a -> b) -> a -> b
$ \Ptr CdText
x' ->
        Ptr CdText -> Ptr CChar -> CSize -> IO CInt
cdTextDataInit' Ptr CdText
x' Ptr CChar
bs' (CSize -> IO CInt) -> CSize -> IO CInt
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l
    Maybe Cdio -> IO (Maybe Cdio)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Cdio -> IO (Maybe Cdio)) -> Maybe Cdio -> IO (Maybe Cdio)
forall a b. (a -> b) -> a -> b
$ if Maybe CInt
b Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Maybe CInt
forall a. a -> Maybe a
Just CInt
0
        then Cdio -> Maybe Cdio
forall a. a -> Maybe a
Just (Cdio -> Maybe Cdio)
-> (Maybe (ForeignPtr CdText) -> Cdio)
-> Maybe (ForeignPtr CdText)
-> Maybe Cdio
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (ForeignPtr Cdio) -> Maybe (ForeignPtr CdText) -> Cdio
Cdio Maybe (ForeignPtr Cdio)
forall a. Maybe a
Nothing (Maybe (ForeignPtr CdText) -> Maybe Cdio)
-> Maybe (ForeignPtr CdText) -> Maybe Cdio
forall a b. (a -> b) -> a -> b
$ ForeignPtr CdText -> Maybe (ForeignPtr CdText)
forall a. a -> Maybe a
Just ForeignPtr CdText
x
        else Maybe Cdio
forall a. Maybe a
Nothing

-- | Create a new empty CDTEXT object.
foreign import ccall "cdio/compat/cdtext.h cdtext_init"
  cdTextInit' :: IO (C.Ptr CdText)

foreign import ccall safe "cdio/compat/cdtext.h cdtext_data_init_safe"
  cdTextDataInit' :: C.Ptr CdText -> C.Ptr C.CChar -> C.CSize -> IO C.CInt


-- | Free the memory indicated by a C-style pointer, avoiding a segfault if
-- passed a @NULL@ pointer.
cdioFree :: C.Ptr a -> IO ()
cdioFree :: Ptr a -> IO ()
cdioFree = FunPtr (Ptr a -> IO ()) -> Ptr a -> IO ()
forall a. FunPtr (Ptr a -> IO ()) -> Ptr a -> IO ()
mkFree FunPtr (Ptr a -> IO ())
forall a. FunPtr (Ptr a -> IO ())
cdioFree'

foreign import ccall "cdio/memory.h &cdio_free"
  cdioFree' :: C.FunPtr (C.Ptr a -> IO ())

-- | Retrieve the actual function with a @free@-style signature.
foreign import ccall "dynamic"
  mkFree :: C.FunPtr (C.Ptr a -> IO ()) -> C.Ptr a -> IO ()


-- | Convert a return code indicating an error or success/failure into a
-- type-safe representation.
errorOrBool :: (Integral a, Enum b) => a -> Either b Bool
errorOrBool :: a -> Either b Bool
errorOrBool = (a -> Bool) -> Either b a -> Either b Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Bool
forall a. (Eq a, Num a) => a -> Bool
M.toBool (Either b a -> Either b Bool)
-> (a -> Either b a) -> a -> Either b Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b a
forall a b. (Integral a, Enum b) => a -> Either b a
errorOrInt


-- | Convert the custom indeterminate boolean to more ideomatic Haskell.
bool3 :: C.CInt -> Maybe Bool
bool3 :: CInt -> Maybe Bool
bool3 CInt
0 = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
bool3 CInt
1 = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
bool3 CInt
_ = Maybe Bool
forall a. Maybe a
Nothing


-- | Convert a return code indicating an error or a numeric value into a
-- type-safe representation.
errorOrInt :: (Integral a, Enum b) => a -> Either b a
errorOrInt :: a -> Either b a
errorOrInt a
i
    | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = b -> Either b a
forall a b. a -> Either a b
Left (b -> Either b a) -> (Int -> b) -> Int -> Either b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> b
forall a. Enum a => Int -> a
toEnum (Int -> Either b a) -> Int -> Either b a
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i
    | Bool
otherwise = a -> Either b a
forall a b. b -> Either a b
Right a
i

-- | Filter out an error value expressed as part of a C-style enum.
maybeError :: Eq a => [a] -> a -> Maybe a
maybeError :: [a] -> a -> Maybe a
maybeError [a]
es a
i
    | a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
i [a]
es = Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just a
i


-- | Unmarshall a block of binary data from a C-style array with an explicit
-- length.  Returns 'Nothing' if the returned size is negative.
peekByteStringLen
    :: (Integral b, S.Storable b)
    => C.Ptr (C.Ptr a)
    -> C.Ptr b
    -> IO (Maybe BS.ByteString)
peekByteStringLen :: Ptr (Ptr a) -> Ptr b -> IO (Maybe ByteString)
peekByteStringLen Ptr (Ptr a)
p Ptr b
l = do
    Ptr a
p' <- Ptr (Ptr a) -> IO (Ptr a)
forall a. Storable a => Ptr a -> IO a
S.peek Ptr (Ptr a)
p
    b
l' <- Ptr b -> IO b
forall a. Storable a => Ptr a -> IO a
S.peek Ptr b
l
    if b
l' b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
0 Bool -> Bool -> Bool
|| Ptr a
p' Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
C.nullPtr
         then Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
         else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStringLen -> IO ByteString
BS.packCStringLen (Ptr a -> Ptr CChar
forall a b. Ptr a -> Ptr b
C.castPtr Ptr a
p', b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
l')


-- | Combine an ordered value and an array of bit flags into a single value.
joinEnumFlags
    :: (Enum a, Enum b, Bounded b, I.Ix b, Integral c, B.Bits c)
    => a
    -> A.BitArray b
    -> c
joinEnumFlags :: a -> BitArray b -> c
joinEnumFlags a
a BitArray b
bs = Int -> c
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Enum a => a -> Int
fromEnum a
a) c -> c -> c
forall a. Num a => a -> a -> a
+ c
bs'
  where bs' :: c
bs' = ((b, Int) -> c -> c) -> c -> [(b, Int)] -> c
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (b, Int) -> c -> c
forall p. Bits p => (b, Int) -> p -> p
set c
0x0 ([(b, Int)] -> c) -> ([Int] -> [(b, Int)]) -> [Int] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> [Int] -> [(b, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(b, b) -> b
forall a b. (a, b) -> a
fst (b, b)
bnds .. (b, b) -> b
forall a b. (a, b) -> b
snd (b, b)
bnds] ([Int] -> c) -> [Int] -> c
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
fstBit [Int
0..]
        bnds :: (b, b)
bnds = (b
forall a. Bounded a => a
minBound, b
forall a. Bounded a => a
maxBound)
        set :: (b, Int) -> p -> p
set (b
e, Int
i) p
b = case BitArray b
bs BitArray b -> b -> Maybe Bool
forall i. Ix i => BitArray i -> i -> Maybe Bool
A.!? b
e of
            Just Bool
True -> p -> Int -> p
forall a. Bits a => a -> Int -> a
B.setBit p
b Int
i
            Maybe Bool
_ -> p
b
        fstBit :: Int
fstBit = Int -> Int
forall b. FiniteBits b => b -> Int
B.countTrailingZeros (Int -> Int) -> (b -> Int) -> b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Int
forall a. Enum a => a -> Int
fromEnum (b -> Int) -> b -> Int
forall a b. (a -> b) -> a -> b
$ (b, b) -> b
forall a b. (a, b) -> a
fst (b, b)
bnds

-- | Split a number into an ordered value (below the 'minBound') and an array
-- of bit flags.
modEnumFlags
    :: (Integral a, B.Bits a, Enum b, Bounded b, Enum c, Bounded c, I.Ix c)
    => a
    -> (Maybe b, A.BitArray c)
modEnumFlags :: a -> (Maybe b, BitArray c)
modEnumFlags a
i = (Int -> Maybe b
forall a. (Enum a, Bounded a) => Int -> Maybe a
toEnumMaybe (Int -> Maybe b) -> Int -> Maybe b
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
fs, BitArray c
bs)
  where fs :: a
fs = a -> a -> a
forall a. Integral a => a -> a -> a
mod a
i (a -> a) -> (c -> a) -> c -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> (c -> Int) -> c -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Int
forall a. Enum a => a -> Int
fromEnum (c -> a) -> c -> a
forall a b. (a -> b) -> a -> b
$ (c, c) -> c
forall a b. (a, b) -> a
fst (c, c)
bnds
        bs :: BitArray c
bs = (c, c) -> [Bool] -> BitArray c
forall i. Ix i => (i, i) -> [Bool] -> BitArray i
A.listArray (c, c)
bnds ([Bool] -> BitArray c) -> ([Int] -> [Bool]) -> [Int] -> BitArray c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
B.testBit a
i) ([Int] -> [Bool]) -> ([Int] -> [Int]) -> [Int] -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
fstBit ([Int] -> BitArray c) -> [Int] -> BitArray c
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
lstBit [Int
0..]
        bnds :: (c, c)
bnds = (c
forall a. Bounded a => a
minBound, c
forall a. Bounded a => a
maxBound)
        fstBit :: Int
fstBit = Int -> Int
forall b. FiniteBits b => b -> Int
B.countTrailingZeros (Int -> Int) -> (c -> Int) -> c -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Int
forall a. Enum a => a -> Int
fromEnum (c -> Int) -> c -> Int
forall a b. (a -> b) -> a -> b
$ (c, c) -> c
forall a b. (a, b) -> a
fst (c, c)
bnds
        lstBit :: Int
lstBit = Int -> Int
forall b. FiniteBits b => b -> Int
B.countTrailingZeros (Int -> Int) -> (c -> Int) -> c -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Int
forall a. Enum a => a -> Int
fromEnum (c -> Int) -> c -> Int
forall a b. (a -> b) -> a -> b
$ (c, c) -> c
forall a b. (a, b) -> b
snd (c, c)
bnds


-- | Will not work if the 'Enum' instance has been redefined to not be
-- sequential.
-- 
-- From <https://stackoverflow.com/a/2744712/7634517>
toEnumMaybe :: (Enum a, Bounded a) => Int -> Maybe a
toEnumMaybe :: Int -> Maybe a
toEnumMaybe Int
i = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall a. Enum a => a -> Int
fromEnum a
n Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> a -> Int
forall a. Enum a => a -> Int
fromEnum a
x
    then Maybe a
forall a. Maybe a
Nothing
    else a -> Maybe a
forall a. a -> Maybe a
Just a
e
  where e :: a
e = Int -> a
forall a. Enum a => Int -> a
toEnum Int
i
        n :: a
n = a -> a -> a
forall a. a -> a -> a
asTypeOf a
forall a. Bounded a => a
minBound a
e
        x :: a
x = a -> a -> a
forall a. a -> a -> a
asTypeOf a
forall a. Bounded a => a
maxBound a
e


-- | Temporarily copy a list of 'String's to pass them to a C function as a
-- @NULL@-terminated array, cleaning up the allocated memory afterward.
allocaStringArray :: [String] -> (C.Ptr C.CString -> IO a) -> IO a
allocaStringArray :: [String] -> (Ptr (Ptr CChar) -> IO a) -> IO a
allocaStringArray [] Ptr (Ptr CChar) -> IO a
f = Ptr (Ptr CChar) -> IO a
f Ptr (Ptr CChar)
forall a. Ptr a
C.nullPtr
allocaStringArray [String]
ss Ptr (Ptr CChar) -> IO a
f = (String -> (Ptr CChar -> IO a) -> IO a)
-> [String] -> ([Ptr CChar] -> IO a) -> IO a
forall a b res.
(a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
M.withMany String -> (Ptr CChar -> IO a) -> IO a
forall a. String -> (Ptr CChar -> IO a) -> IO a
C.withCString [String]
ss (([Ptr CChar] -> IO a) -> IO a) -> ([Ptr CChar] -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Ptr CChar]
ss' -> Ptr CChar -> [Ptr CChar] -> (Ptr (Ptr CChar) -> IO a) -> IO a
forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
M.withArray0 Ptr CChar
forall a. Ptr a
C.nullPtr [Ptr CChar]
ss' Ptr (Ptr CChar) -> IO a
f


-- | Retrieve the value of a C-style string which needs to be manually freed.
peekFString :: C.CString -> IO String
peekFString :: Ptr CChar -> IO String
peekFString Ptr CChar
c = do
    String
s <- Ptr CChar -> IO String
C.peekCString Ptr CChar
c
    Ptr CChar -> IO ()
forall a. Ptr a -> IO ()
cdioFree Ptr CChar
c
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s

-- | Retrieve the values of an array of C-style strings which all need to be
-- manually freed.
peekFStringArray :: C.Ptr C.CString -> IO [String]
peekFStringArray :: Ptr (Ptr CChar) -> IO [String]
peekFStringArray Ptr (Ptr CChar)
p = do
    Maybe [Ptr CChar]
ss <- (Ptr (Ptr CChar) -> IO [Ptr CChar])
-> Ptr (Ptr CChar) -> IO (Maybe [Ptr CChar])
forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
M.maybePeek (Ptr CChar -> Ptr (Ptr CChar) -> IO [Ptr CChar]
forall a. (Storable a, Eq a) => a -> Ptr a -> IO [a]
M.peekArray0 Ptr CChar
forall a. Ptr a
C.nullPtr) Ptr (Ptr CChar)
p
    IO [String]
-> ([Ptr CChar] -> IO [String]) -> Maybe [Ptr CChar] -> IO [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []) ((Ptr CChar -> IO String) -> [Ptr CChar] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ptr CChar -> IO String
peekFString) Maybe [Ptr CChar]
ss