Util.hs

{-# LANGUAGE ForeignFunctionInterface #-}

{-|
Description:    Miscellaneous utility functions, of limited utility.

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

Stability:      stable
Portability:    non-portable (requires libcdio)

Most functions defined by the C header either encapsulate math to perform on
an object or the system state, or edit `String's in some (barring allocations)
pure manner, including a few with general utility rather than being specific to
libcdio.  However, most are also restricted to internal use, and not provided
as symbols exported by the library itself; those internal functions are still
present in the Haskell source as well, for anyone interested.  As such, this
module and the functions it provides should rarely need to be used.


= @util.h@

== Defines
* @CDIO_FREE_IF_NOT_NULL@           (removed; Haskell handles its own memory management)
* @CLAMP@                           (removed; preprocessor logic isn't required in Haskell)
* @IN@                              (removed; preprocessor logic isn't required in Haskell)
* @MAX@                             (removed; preprocessor logic isn't required in Haskell)
* @MAX@                             (removed; preprocessor logic isn't required in Haskell)

== Symbols
* @_cdio_strfreev@                  (removed; list is automatically freed)
* @_cdio_strsplit@                  -> 'Foreign.Libcdio.Util.strsplit'
* @cdio_from_bcd8@                  -> 'Foreign.Libcdio.Util.fromBcd8'
* @cdio_realpath@                   -> 'Foreign.Libcdio.Util.realpath'
* @cdio_to_bcd8@                    -> 'Foreign.Libcdio.Util.toBcd8'
-}
module Foreign.Libcdio.Util
    ( Bcd
    , toBcd8, fromBcd8
    , strsplit
    , realpath
    ) where


{- Used only by not exported symbols
import qualified Foreign.ForeignPtr 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 System.IO.Unsafe as IO.Unsafe

import Foreign.Libcdio.Types.Internal
-}

import qualified Data.Word as W


import qualified Data.Ix as I

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

import qualified Foreign.Marshal.Utils as M
import qualified Foreign.Storable as S

import qualified Numeric as NM

import qualified Text.Printf as P


import Foreign.Libcdio.Marshal


{- Not exported
-- | Calculate how many blocks of a given size are required to contain the
-- given number of bytes.
len2blocks
    :: W.Word32
        -- ^ The number of bytes to fit.
    -> W.Word16
        -- ^ The size of each block.
    -> Lsn
len2blocks b s = fromIntegral $ len2blocks' (fromIntegral b) (fromIntegral s)

foreign import ccall safe "cdio/util.h _cdio_len2blocks"
  len2blocks' :: C.CUInt -> C.CUShort -> C.CInt

-- | Round up to the next block boundery after a given offset.
ceil2block
    :: Int
        -- ^ The base address to round.
    -> W.Word16
        -- ^ The size of each block.
    -> Int
ceil2block p s = fromIntegral $ ceil2block' (fromIntegral p) (fromIntegral s)

foreign import ccall safe "cdio/util.h _cdio_ceil2block"
  ceil2block' :: C.CInt -> C.CUShort -> C.CInt


-- | Add a given length after a given address, potentially putting it at the
-- start of a new block if there is not enough space remaining in the one in
-- which the address is located.
ofsAdd
    :: Int
        -- ^ The base addres.
    -> Int
        -- ^ The number of bytes to add.
    -> W.Word16
        -- ^ The size of each block.
    -> Int
ofsAdd p a s = fromIntegral $ ofsAdd' (fromIntegral p) (fromIntegral a) (fromIntegral s)

foreign import ccall safe "cdio/util.h _cdio_ofs_add"
  ofsAdd' :: C.CInt -> C.CInt -> C.CUShort -> C.CInt


-- | Print a 'True'/'False' value as "yes"/"no".
--
-- A similar, but not identical, result may be obtained with 'show'.
boolStr :: Bool -> String
boolStr = IO.Unsafe.unsafePerformIO . C.peekCString . boolStr' . M.fromBool

foreign import ccall safe "cdio/util.h _cdio_bool_str"
  boolStr' :: C.CInt -> C.CString


-- | Copy the contents of one memory address to another, newly allocated one.
memdup :: C.Ptr a -> Word
    -> IO (Maybe (C.ForeignPtr a))
        -- ^ 'Nothing' if the source is 'nullPtr',
                                    -- or a pointer to the new memory.
memdup p s = do
    p' <- memdup' p (fromIntegral s)
    if p == C.nullPtr
    then return Nothing
    else Just <$> C.newForeignPtr cdioFreePtr p'

foreign import ccall safe "cdio/util.h _cdio_memdup"
  memdup' :: C.Ptr a -> C.CSize -> IO (C.Ptr a)


-- | Create a copy of a string with all characters transformed to upper case.
--
-- This should be functionally identical to @map toUpper@.
strdupUpper :: String -> IO String
strdupUpper s = C.withCString s strdupUpper' >>= peekFString

foreign import ccall safe "cdio/util.h _cdio_strdup_upper"
  strdupUpper' :: C.CString -> IO C.CString

-- | Duplicate a path and make it platform compliant.  Typically needed for
-- MinGW\/MSYS where a "\/c\/..." path must be translated to "c:\/...".
strdupFixpath :: String -> IO (Maybe String)
strdupFixpath s = C.withCString s strdupFixpath' >>= peekNullFString

foreign import ccall safe "cdio/util.h _cdio_strdup_fixpath"
  strdupFixpath' :: C.CString -> IO C.CString


-- | Count the number of C-style string pointers in a NULL-terminated array.
--
-- As we are already know the list is fully populated, this offers no benefit
-- over 'length'; Haskell's type system will not insert anything acting like a
-- string which is actually @NULL@.
strlenv :: [String] -> IO Word
strlenv ss = M.withMany C.withCString ss $ \ss' ->
    fromIntegral <$> M.withArray0 C.nullPtr ss' strlenv'

foreign import ccall safe "cdio/util.h _cdio_strlenv"
  strlenv' :: C.Ptr C.CString -> IO C.CSize
-}


-- | Return the substrings between a given delimiter, dropping any empty ones.
--
-- The Haskell repositories provide this via
-- [split](https://hackage.haskell.org/package/split).
--
-- > strsplit str d == Data.List.Split.wordsBy (== d) str
strsplit :: String -> Char -> IO [String]
strsplit s c = C.withCString s (flip strsplit' . fromIntegral $ fromEnum c) >>= peekFStringArray

foreign import ccall safe "cdio/util.h _cdio_strsplit"
  strsplit' :: C.CString -> C.CChar -> IO (C.Ptr C.CString)


-- | A bitwise encoding where the lower four bits encode a number modulo 10,
-- and the upper encode the same divided by 10.
newtype Bcd = Bcd W.Word8
instance Eq Bcd where
    a == b = fromBcd8 a == fromBcd8 b
instance Ord Bcd where
    compare a b = compare (fromBcd8 a) (fromBcd8 b)
instance Show Bcd where
    showsPrec p i@(Bcd w)
        | mod w 0x10 >= 0xA = showParen (p > application) $
            showString ("Bcd 0x" ++ pad) . NM.showHex w
        | otherwise = showsPrec p $ fromBcd8 i
      where application = 10
            pad | i >= 0x10 = ""
                | otherwise = "0"
instance Read Bcd where
    readsPrec p s =
           map toBcd8Fst (readsPrec p s)
        ++ readParen (p > application)
            (\r -> [ (Bcd i, v ++ ' ' : u)
                   | ("Bcd", t) <- lex r
                   , ('0':'x':l, u) <- lex t
                   , (i, v) <- NM.readHex l
                   ]) s
      where toBcd8Fst (w, b) = (toBcd8 w, b)
            application = 10
-- | >>> map fromBcd8 [minBound, maxBound]
-- [0, 159]
instance Bounded Bcd where
    minBound = Bcd 0
    maxBound = Bcd 0xF9
instance Enum Bcd where
    toEnum i = toBcd8 $ toEnum i
    fromEnum b = fromEnum $ fromBcd8 b
    succ i
        | i >= maxBound = error "Enum.succ(Bcd): tried to take `succ' of maxBound"
        | otherwise = toBcd8 . succ $ fromBcd8 i
    pred i
        | i <= minBound = error "Enum.pred(Bcd): tried to take `pred' of minBound"
        | otherwise = toBcd8 . pred $ fromBcd8 i
instance I.Ix Bcd where
    range (a, b) = map toBcd8 $ I.range (fromBcd8 a, fromBcd8 b)
    inRange (a, b) i = I.inRange (fromBcd8 a, fromBcd8 b) $ fromBcd8 i
    index (a, b) i = I.index (fromBcd8 a, fromBcd8 b) $ fromBcd8 i
instance Num Bcd where
    a + b = toBcd8 $ fromBcd8 a + fromBcd8 b
    a - b = toBcd8 $ fromBcd8 a - fromBcd8 b
    a * b = toBcd8 $ fromBcd8 a * fromBcd8 b
    abs i = i
    signum b = toBcd8 . signum $ fromBcd8 b
    fromInteger i = toBcd8 $ fromInteger i
instance Real Bcd where
    toRational b = toRational $ fromBcd8 b
instance Integral Bcd where
    quotRem dividend divisor = (toBcd8 q, toBcd8 r)
      where (q, r) = quotRem (fromBcd8 dividend) (fromBcd8 divisor)
    toInteger b = toInteger $ fromBcd8 b
instance P.PrintfArg Bcd where
    formatArg = P.formatArg . fromBcd8
instance S.Storable Bcd where
    sizeOf (Bcd i)    = S.sizeOf i
    alignment (Bcd i) = S.alignment i
    peek p            = Bcd <$> S.peek (C.castPtr p)
    poke p (Bcd i)    = S.poke (C.castPtr p) i

-- | Encode a number according to the libcdio BCD encoding.  If the value is
-- greater than @'maxBound' :: 'Bcd'@, it wraps back around to @0@.
toBcd8 :: Word -> Bcd
toBcd8 = Bcd . fromIntegral . toBcd8' . fromIntegral

foreign import ccall safe "cdio/util.h cdio_to_bcd8"
  toBcd8' :: C.CUInt -> C.CUInt

-- | Decode a number in the libcdio BCD encoding.
fromBcd8 :: Bcd -> Word
fromBcd8 (Bcd i) = fromIntegral . fromBcd8' $ fromIntegral i

foreign import ccall safe "cdio/util.h cdio_from_bcd8"
  fromBcd8' :: C.CUInt -> C.CUInt


-- | Same as POSIX.1-2001 realpath, if the system provides it.  If not,
-- libcdio's "poor-man's simulation" of its behavior.
--
-- The Haskell repositories provide a similar alternative in
-- @System.Directory.canonicalizePath@ from
-- [directory](https://hackage.haskell.org/package/directory).
realpath :: String -> IO (Maybe String)
realpath s = C.withCString s (`realpath'` C.nullPtr) >>= M.maybePeek peekFString

foreign import ccall safe "cdio/util.h cdio_realpath"
  realpath' :: C.CString -> C.CString -> IO C.CString


{- Pointer logic is not exposed.
-- | Some function which matches the free() prototype.
type DataFree = C.FunPtr (C.Ptr () -> IO ())
-}