{-# LANGUAGE ForeignFunctionInterface #-}

{-|
Description:    Common type definitions used pervasively in libcdio, along with
                low-level features intended for internal use.

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

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

While most of @types.h@ is user-facing, it's undesirable to export the
@newtype@ constructors, for type safety.  Hiding them breaks c2hs automatic
marshalling, which means that we have to write custom marshalling functions.
Exporting those clutters the user surface with unnecessary and
likely-never-used code, so the types in this module got split off for use
internally — at which point the constructors may as well be exported anyway.
-}
module Foreign.Libcdio.Types.Internal
    ( -- * Addresses
      Lba ( .. )
    , CLba
    , Lsn ( .. )
    , CLsn
      -- * Segments
    , Track ( .. )
    , CTrack
    , TrackNum
    , minTrack
    , maxTrack
      -- * Data
    , CBitfield
    , isrcLength
    , mcnLength
      -- * Marshalling
    , invalidLba
    , invalidLsn
    , invalidZeroLsn
    , invalidTrack
    , invalidZeroTrack
    , withLba
    , withLsn
    , withTrack
    ) where


import qualified Data.Bits as B
import qualified Data.Ix as I
import qualified Data.List as L
import qualified Data.Maybe as Y

import qualified Foreign.C.Types as C
import qualified Foreign.Ptr as C
import qualified Foreign.Storable as S

import qualified Text.Printf as P

import Data.Bits ((.&.), (.|.))

import Foreign.Libcdio.Marshal


{- 'Char' is already native.
type CUtf8 = C.CChar

-- | A character explicitly encoded as UTF-8.
newtype Utf8 = Utf8 CUtf8
  deriving ( Eq, Ord, Show, Read, Bounded )
-}


-- | The representation of the various @DriveCaps*@ at the C boundary.
type CBitfield = C.CUInt

{- Accomplished with "Data.Array.BitArray".
-- | The type used for bit-fields in structs with eight or less flags.
newtype Bitfield = Bitfield CBitfield
  deriving ( Eq, Ord, Show, Read, Bounded )
-}


-- | Marshal an address to a type which pins the required size of the C
-- representation, rather than the polymorphism of 'fromIntegral'.
withLba :: Lba -> CLba
withLba (Lba i) = i

type CLba = C.CInt

-- | The type-safe representation of a Logical Block Address, counting sectors
-- from the very beginning of the write session.  See also 'Lsn'.
newtype Lba = Lba CLba
  deriving ( Eq, Ord, Show, Read )
instance Bounded Lba where
    minBound = Lba . lsnToLba $ fromIntegral (minBound :: Lsn)
    maxBound = Lba . lsnToLba $ fromIntegral (maxBound :: Lsn)
instance Enum Lba where
    toEnum = Lba . toEnum
    fromEnum (Lba i) = fromEnum i
instance I.Ix Lba where
    range (Lba a, Lba b) = map Lba [a..b]
    inRange (a, b) i = a <= i && i <= b
    index r@(a, b) i = Y.fromMaybe (error $ "Ix(Lba).index: Index (" ++ show i ++ ") out of range (" ++ show r ++ ")")
                     $ L.elemIndex i [a..b]
instance Num Lba where
    Lba a + Lba b = Lba $ a + b
    Lba a - Lba b = Lba $ a - b
    Lba a * Lba b = Lba $ a * b
    abs (Lba i) = Lba $ abs i
    signum (Lba i) = Lba $ signum i
    fromInteger = Lba . fromInteger
instance Real Lba where
    toRational (Lba i) = toRational i
instance Integral Lba where
    quotRem (Lba i) (Lba d) = (Lba q, Lba r)
      where (q, r) = quotRem i d
    toInteger (Lba i) = toInteger i
instance B.Bits Lba where
    (Lba a) .&. (Lba b) = Lba $ a .&. b
    (Lba a) .|. (Lba b) = Lba $ a .|. b
    xor (Lba a) (Lba b) = Lba $ B.xor a b
    complement (Lba i) = Lba $ B.complement i
    shift (Lba i) = Lba . B.shift i
    rotate (Lba i) = Lba . B.rotate i
    bitSize (Lba i) = B.finiteBitSize i
    bitSizeMaybe (Lba i) = B.bitSizeMaybe i
    isSigned (Lba i) = B.isSigned i
    testBit (Lba i) = B.testBit i
    bit = Lba . B.bit
    popCount (Lba i) = B.popCount i
instance B.FiniteBits Lba where
    finiteBitSize (Lba i) = B.finiteBitSize i
instance P.PrintfArg Lba where
    formatArg = P.formatArg . (fromIntegral :: Lba -> Int)
instance S.Storable Lba where
    sizeOf (Lba i)    = S.sizeOf i
    alignment (Lba i) = S.alignment i
    peek p            = Lba <$> S.peek (C.castPtr p)
    poke p (Lba i)    = S.poke (C.castPtr p) i

foreign import ccall safe "cdio/compat/sector.h cdio_lsn_to_lba"
  lsnToLba :: CLsn -> CLba

foreign import ccall safe "cdio/compat/disc.h invalid_lba"
  invalidLba' :: CLba

-- | Filter out @CDIO_INVALID_LBA@ values for type-safe errors.
invalidLba :: CLba -> Maybe Lba
invalidLba = fmap fromIntegral . maybeError [invalidLba']


-- | Marshal an address to a type which pins the required size of the C
-- representation, rather than the polymorphism of 'fromIntegral'.
withLsn :: Lsn -> CLsn
withLsn (Lsn i) = i

type CLsn = C.CInt

-- | The type-safe representation of a Logical Sector Number, counting sectors
-- from the start of track 1; this notably excludes the blank session lead-in.
-- See also 'Lba'.
newtype Lsn = Lsn CLsn
  deriving ( Eq, Ord, Show, Read )
instance Bounded Lsn where
    minBound = Lsn minLsn
    maxBound = Lsn maxLsn
instance Enum Lsn where
    toEnum = Lsn . toEnum
    fromEnum (Lsn i) = fromEnum i
instance I.Ix Lsn where
    range (Lsn a, Lsn b) = map Lsn [a..b]
    inRange (a, b) i = a <= i && i <= b
    index r@(a, b) i = Y.fromMaybe (error $ "Ix(Lsn).index: Index (" ++ show i ++ ") out of range (" ++ show r ++ ")")
                     $ L.elemIndex i [a..b]
instance Num Lsn where
    Lsn a + Lsn b = Lsn $ a + b
    Lsn a - Lsn b = Lsn $ a - b
    Lsn a * Lsn b = Lsn $ a * b
    abs (Lsn i) = Lsn $ abs i
    signum (Lsn i) = Lsn $ signum i
    fromInteger = Lsn . fromInteger
instance Real Lsn where
    toRational (Lsn i) = toRational i
instance Integral Lsn where
    quotRem (Lsn i) (Lsn d) = (Lsn q, Lsn r)
      where (q, r) = quotRem i d
    toInteger (Lsn i) = toInteger i
instance B.Bits Lsn where
    (Lsn a) .&. (Lsn b) = Lsn $ a .&. b
    (Lsn a) .|. (Lsn b) = Lsn $ a .|. b
    xor (Lsn a) (Lsn b) = Lsn $ B.xor a b
    complement (Lsn i) = Lsn $ B.complement i
    shift (Lsn i) = Lsn . B.shift i
    rotate (Lsn i) = Lsn . B.rotate i
    bitSize (Lsn i) = B.finiteBitSize i
    bitSizeMaybe (Lsn i) = B.bitSizeMaybe i
    isSigned (Lsn i) = B.isSigned i
    testBit (Lsn i) = B.testBit i
    bit = Lsn . B.bit
    popCount (Lsn i) = B.popCount i
instance B.FiniteBits Lsn where
    finiteBitSize (Lsn i) = B.finiteBitSize i
instance P.PrintfArg Lsn where
    formatArg = P.formatArg . (fromIntegral :: Lsn -> Int)
instance S.Storable Lsn where
    sizeOf (Lsn i)    = S.sizeOf i
    alignment (Lsn i) = S.alignment i
    peek p            = Lsn <$> S.peek (C.castPtr p)
    poke p (Lsn i)    = S.poke (C.castPtr p) i

foreign import ccall safe "cdio/compat/sector.h min_lsn"
  minLsn :: CLsn

foreign import ccall safe "cdio/compat/sector.h max_lsn"
  maxLsn :: CLsn

foreign import ccall safe "cdio/compat/disc.h invalid_lsn"
  invalidLsn' :: CLsn

-- | Filter out @CDIO_INVALID_LSN@ values for type-safe errors.
invalidLsn :: CLsn -> Maybe Lsn
invalidLsn = fmap fromIntegral . maybeError [invalidLsn']

-- | Filter out both @0@ and @CDIO_INVALID_LSN@ values for type-safe errors.
invalidZeroLsn :: CLsn -> Maybe Lsn
invalidZeroLsn = fmap fromIntegral . maybeError [0, invalidLsn']


-- | Marshal a track number to a type which pins the required size of the C
-- representation, rather than the polymorphism of 'fromIntegral'.  Note that
-- @withTrack 'DiscLeadout' /= fromIntegral (fromEnum 'DiscLeadout')@
withTrack :: Track -> CTrack
withTrack DiscPregap = 0
withTrack (Track (TrackNum i)) = fromIntegral i + minTrack'
withTrack DiscLeadout = leadoutTrack'

type CTrack = C.CUChar

-- | Opaque newtype representing the numeric index of a 'Track', while
-- enforcing the invariants inherant to the specification.  Of very limited
-- utility outside that context.
newtype TrackNum = TrackNum Word
  deriving ( Eq, Ord )
instance Bounded TrackNum where
    minBound = TrackNum 0
    maxBound = TrackNum $ maxTrackW - minTrackW
instance Show TrackNum where
    show (TrackNum i) = show $ i + minTrackW
instance Read TrackNum where
    readsPrec d = \str -> do
        (i, str') <- readsPrec d str
        return (TrackNum $ i - minTrackW, str')

-- | An index into the segmentation within a write session on a disc.
data Track
    = DiscPregap
        -- ^ The (usually buffer) data located before the first track on a
        -- disc.
    | Track TrackNum
        -- ^ The common understanding of a CD track: a segment of the data on
        -- the disc containing (usually) a single song.
    | DiscLeadout
        -- ^ Any (usually buffer) data located after the end of the last track
        -- on a disc.
  deriving ( Eq, Ord, Show )
instance Bounded Track where
    minBound = DiscPregap
    maxBound = DiscLeadout
-- | Note that @'fromEnum' 'DiscLeadout'@ uses a value (== 100) chosen to be
-- contiguous to the rest of the datatype rather than that used internally
-- (== 0xAA).  'toEnum' accepts both values.
instance Enum Track where
    toEnum i
        | i < fromIntegral minTrack' = DiscPregap
        | i > fromIntegral maxTrack' = DiscLeadout
        | otherwise = Track . TrackNum $ fromIntegral i - minTrackW
    fromEnum DiscPregap = fromIntegral minTrack' - 1
    fromEnum (Track (TrackNum i)) = fromIntegral $ i + minTrackW
    fromEnum DiscLeadout = fromIntegral maxTrack' + 1
    pred DiscPregap = error "Enum.pred(Track): tried to take `pred' of DiscPregap"
    pred (Track n@(TrackNum i))
        | n == minBound = DiscPregap
        | n > maxBound = DiscLeadout
        | otherwise = Track . TrackNum $ i - 1
    pred DiscLeadout = Track maxBound
    succ DiscPregap = Track minBound
    succ (Track n@(TrackNum i))
        | n >= maxBound = DiscLeadout
        | otherwise = Track . TrackNum $ i + 1
    succ DiscLeadout = error "Enum.succ(Track): tried to take `succ' of DiscLeadout"
instance Read Track where
    readsPrec d = \s ->
        [ (DiscPregap, s')
        | ("DiscPregap", s') <- lex s
        ] ++
        [ (DiscLeadout, s')
        | ("DiscLeadout", s') <- lex s
        ] ++
        [ (packTrack i, s')
        | (i, s') <- readParen (d > 10) readsTrack s
        ]
      where packTrack i
                | i < minTrackW = DiscPregap
                | i > maxTrackW = DiscLeadout
                | otherwise = Track . TrackNum $ i - minTrackW
            readsTrack s =
                [ (i, s'')
                | ("Track", s') <- lex s
                , (i, s'') <- readsPrec 10 s'
                ]
instance I.Ix Track where
    range (a, b) = map toEnum [fromEnum a..fromEnum b]
    inRange (a, b) i = a <= i && i <= b
    index r@(a, b) i = Y.fromMaybe (error $ "Ix(Track).index: Index (" ++ show i ++ ") out of range (" ++ show r ++ ")")
                     $ L.elemIndex i [a..b]
instance Num Track where
    a + b = toEnum $ fromEnum a + fromEnum b
    a - b = toEnum $ fromEnum a - fromEnum b
    a * b = toEnum $ fromEnum a * fromEnum b
    abs t = t
    signum _ = DiscPregap
    fromInteger = toEnum . fromInteger
instance P.PrintfArg Track where
    formatArg t = P.formatInt $ withTrack t
-- | Note that 'S.poke' uses the official representation of 'DiscLeadout'
-- (@CDIO_CDROM_LEADOUT_TRACK == 0xAA@, as used by libcdio) rather than the
-- hscdio @'fromEnum' 'DiscLeadout'@ (== 100), as the latter was chosen for
-- proximity to the other constructors.
instance S.Storable Track where
    sizeOf _    = S.sizeOf leadoutTrack'
    alignment _ = S.alignment leadoutTrack'
    peek p      = toEnum . fromIntegral <$> S.peek (C.castPtr p :: C.Ptr CTrack)
    poke p      = S.poke (C.castPtr p) . withTrack

-- | The first data track on a disc (i.e. @'Track' 1@).
minTrack :: Track
minTrack = fromIntegral minTrack'

minTrackW :: Word
minTrackW = fromIntegral minTrack'

foreign import ccall safe "cdio/compat/track.h min_tracks"
  minTrack' :: CTrack

-- | The highest data track allowed by the specifications (i.e. @'Track' 99@).
maxTrack :: Track
maxTrack = fromIntegral maxTrack'

maxTrackW :: Word
maxTrackW = fromIntegral maxTrack'

foreign import ccall safe "cdio/compat/track.h max_tracks"
  maxTrack' :: CTrack

foreign import ccall safe "cdio/compat/track.h leadout_track"
  leadoutTrack' :: CTrack

foreign import ccall safe "cdio/compat/track.h invalid_track"
  invalidTrack' :: CTrack

-- | Filter out @CDIO_INVALID_TRACK@ values for type-safe errors.
invalidTrack :: CTrack -> Maybe Track
invalidTrack = fmap (toEnum . fromIntegral) . maybeError [invalidTrack']

-- | Filter out @CDIO_INVALID_TRACK@ and 'DiscPregap' values for type-safe
-- errors.
invalidZeroTrack :: CTrack -> Maybe Track
invalidZeroTrack = fmap (toEnum . fromIntegral) . maybeError [0, invalidTrack']


-- | Number of ASCII bytes in a media catalog number.
mcnLength :: Word
mcnLength = fromIntegral mcnLength'

foreign import ccall safe "cdio/compat/types.h mcn_length"
  mcnLength' :: C.CUChar

{- Never used after definition.
-- | Some Media Catalog Number which identifies a disc; in practice usually a
-- UPC/EAN bar code.
newtype Mcn = Mcn String
  deriving ( Eq, Ord, Show, Read, Bounded )
instance S.Storable Mcn where
    sizeOf _       = S.sizeOf C.nullPtr
    alignment _    = S.alignment C.nullPtr
    peek p         = Mcn <$> C.peekCStringLen (C.castPtr p, mcnLength)
    poke p (Mcn s) = undefined
--}


-- | Number of ASCII characters in an International Standard Recording Code.
isrcLength :: Word
isrcLength = fromIntegral isrcLength'

foreign import ccall safe "cdio/compat/types.h isrc_length"
  isrcLength' :: C.CUChar

{- Never used after definition.
-- | The International Standard Recording Code attached to a track of a disc,
-- as assigned by a central agency.
newtype Isrc = Isrc String
  deriving ( Eq, Ord, Show, Read, Bounded )
instance S.Storable Isrc where
    sizeOf _        = S.sizeOf C.nullPtr
    alignment _     = S.alignment C.nullPtr
    peek p          = Isrc <$> C.peekCStringLen (C.castPtr p, isrcLength)
    poke p (Isrc s) = undefined
-}