CdText.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-|
Description:    Functions providing metadata about the contents of a disc.

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

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

Metadata is stored in a binary format both library-internally and on the disc.
Most audio archivists will recognize it as "those information fields in a CUE
file" (though there are [other
formats](https://www.gnu.org/software/libcdio/cd-text-format.html#Sony-Text-File-Format-_0028Input-Sheet-Version-0_002e7T_0029)
as well), and casual listeners will recognize it as the scrolling text that
you're always happy to see, on the rare times your music player shows it.
Little-used and even-less-known, however, is that a single disc can
theoretically contain metadata in up to eight different languages; because of
the complexity that introduces, it makes more sense to use a second monadic
interface than to try to provide a single monolithic datatype within 'Cdio'.
-}
module Sound.Libcdio.Read.CdText
    ( -- * Types
      CdText
    , CdTextError ( .. )
    , CdTextErrorType ( .. )
    , Info ( .. )
    , emptyInfo
    , Foreign.Genre ( .. )
    , Foreign.Language ( .. )
      -- * Evaluation
    , cdText
    , parseCdText
    , withLanguage
    , withIndex
    , withAll
    , runCdText
      -- * Data
    , language
    , languages
    , firstTrack
    , lastTrack
    , info
    , discId
    , genre
    , cdTextRaw
    ) where


import qualified Control.Applicative as A
#if MIN_VERSION_mtl(2,2,1)
import qualified Control.Monad.Except as N.E
#else
import qualified Control.Monad.Error as N.E
#endif
import qualified Control.Monad.Fail as N.F

import qualified Data.ByteString as BS
import qualified Data.Maybe as Y
import qualified Data.Text as T

import qualified Foreign.Libcdio.CdText as Foreign
import qualified Foreign.Libcdio.Disc as Foreign
import qualified Foreign.Libcdio.Logging as Foreign

import qualified Text.Show as R

import Sound.Libcdio.Logging
import Sound.Libcdio.Track
import Sound.Libcdio.Types.Cdio

import Control.Applicative ( (<|>) )
import Data.Functor ( ($>) )


-- | A computation within the environment of metadata (in a particular
-- language) stored on a CD.  The options for affecting that environment
-- from within are limited by design, as this library is intended for /reading/
-- discs rather than /authoring/ them.
newtype CdText a = CdText (Maybe InitialLanguage -> Foreign.Cdio -> IO (Either CdTextError a))
instance Functor CdText where
    fmap f (CdText a) = CdText $ \l c -> fmap f <$> a l c
instance Applicative CdText where
    pure a = CdText $ \_ _ -> return $ Right a
    CdText f <*> CdText a = CdText $ \l c -> do
        f' <- f l c
        a' <- a l c
        return $ f' <*> a'
-- | 'A.empty' fails with 'CdTextEmpty'.
instance A.Alternative CdText where
    empty = CdText $ \_ _ -> return . Left . CdTextError CdTextEmpty $ T.pack "empty"
    CdText f <|> CdText g = CdText $ \l c -> f l c <|> g l c
instance Monad CdText where
    CdText a >>= f = CdText $ \l c -> do
        a' <- a l c
        let bind' a'' = let CdText b = f a'' in b l c
        either (return . Left) bind' a'
-- | Wraps the text in a 'FreeformCdTextError', for recovery with 'N.E.catchError'.
instance N.F.MonadFail CdText where
    fail e = CdText $ \_ _ ->
        return . Left $ CdTextError (FreeformCdTextError $ T.pack e) (T.pack "fail")
instance N.E.MonadError CdTextError CdText where
    throwError err = CdText $ \_ _ -> return $ Left err
    catchError (CdText f) e = CdText $ \l c -> f l c >>= \a' -> case a' of
        Left err ->
            let CdText g = e err
            in  g l c
        Right a -> return $ Right a
instance LibcdioLogger CdText where
    logCutoff = CdText $ \_ _ -> Right <$> Foreign.logCutoff
    setLogCutoff l = CdText $ \_ _ -> Right <$> Foreign.setLogCutoff l
    readLog = CdText $ \_ _ -> Right <$> Foreign.readLog
    clearLog = CdText $ \_ _ -> Right <$> Foreign.clearLog
    putLog e = CdText $ \_ _ -> Right <$> Foreign.putLog e

-- | Lift a metadata computation from the C-style "Foreign.Libcdio" interface
-- into the monadic "Sound.Libcdio".
liftCdText :: (Foreign.Cdio -> IO a) -> CdText a
liftCdText f = CdText $ \_ c -> Right <$> f c


-- | Associates a well-typed error with human-readable context information.
data CdTextError = CdTextError CdTextErrorType T.Text
  deriving ( Eq, Show, Read )

-- | Potential situations which may cause a computation to fail.
data CdTextErrorType
    = InvalidBlock Word
        -- ^ The requested language index is outside of the bounds accessible
        -- by the library (@[0..7]@ in libcdio 2.1 and after, or the smaller
        -- range of languages returned by 'languages' before that version).
    | LanguageNotFound Foreign.Language
        -- ^ The CdText data does not contain the requested language, or
        -- 'Foreign.UnknownLanguage' was requested (prior to libcdio 2.1 there
        -- was no way to select the latter blocks; even after that version,
        -- 'withIndex' must be used instead).
    | BadBinaryRead
        -- ^ The binary data can not be parsed into a CdText object.
    | NoCdText
        -- ^ The CD contains no CdText data.
    | CdTextEmpty
        -- ^ 'A.empty' was called and no better alternative was encountered.
    | FreeformCdTextError T.Text
        -- ^ Escape hatch from structured typing to allow user-specified
        -- (and user-triggered) errors.
  deriving ( Eq, Show, Read )


-- | The language which was active at the beginning of the 'CdText'
-- computation.
data InitialLanguage
    = Lang Foreign.Language
        -- ^ The language was chosen specifically.
    | Index Word
        -- ^ The language was chosen by index.
    | Default
        -- ^ No language was explicitly set.

-- | Restore the active language to whatever it was before a 'CdText'
-- computation was run.
resetLanguage :: Maybe InitialLanguage -> Foreign.Cdio -> IO ()
resetLanguage Nothing _ = mempty
resetLanguage (Just (Lang l)) c = Foreign.selectLanguage c l >> mempty
resetLanguage (Just (Index i)) c = Foreign.selectLanguageIndex c i >> mempty
resetLanguage (Just Default) c = Foreign.selectLanguageIndex c 0 >> mempty


-- | Textual metadata describing a single track on a disc, or the disc itself.
data Info = Info
    { title      :: Maybe T.Text
    , performer  :: Maybe T.Text
    , songwriter :: Maybe T.Text
    , composer   :: Maybe T.Text
    , arranger   :: Maybe T.Text
    , message    :: Maybe T.Text
        -- ^ An otherwise-uncategorized comment.
    , code       :: Maybe T.Text
        -- ^ Either a UPC/EAN (for the disc) or an ISRC (for a track).
    }
  deriving ( Eq )
-- | Modeled after the standard record syntax, but omitting any 'Nothing'
-- fields for space reasons.
instance Show Info where
    showsPrec d ts = R.showParen (d > 10)
        $ R.showString "Info { "
        . maybeShows title "title"
        . maybeShows performer "performer"
        . maybeShows songwriter "songwriter"
        . maybeShows composer "composer"
        . maybeShows arranger "arranger"
        . maybeShows message "message"
        . maybeShows code "code"
        . R.showString "}"
      where maybeShows f n
                | Just t <- f ts =
                      R.showString (n ++ " = ")
                    . shows t
                    . R.showString ", "
                | otherwise = id
instance Read Info where
    readsPrec p =
           readParen (p > 10) $ \r ->
            [ (Info t f w c a m o, r10)
            | ("Info", r1) <- lex r
            , ("{", r2) <- lex r1
            , (t, r3) <- maybeLex "title" r2
            , (f, r4) <- maybeLex "performer" r3
            , (w, r5) <- maybeLex "songwriter" r4
            , (c, r6) <- maybeLex "composer" r5
            , (a, r7) <- maybeLex "arranger" r6
            , (m, r8) <- maybeLex "message" r7
            , (o, r9) <- maybeLex "code" r8
            , ("}", r10) <- lex r9
            ]
      where maybeLex t s' = do
                (t', s1) <- lex s'
                if t == t'
                then do
                    ("=", s2) <- lex s1
                    (x, s3) <- reads s2
                    (",", s4) <- lex s3
                    return (Just x, s4)
                else return (Nothing, s')

-- | An 'Info' object with values suitable as defaults.
emptyInfo :: Info
emptyInfo = Info
    { title      = Nothing
    , performer  = Nothing
    , songwriter = Nothing
    , composer   = Nothing
    , arranger   = Nothing
    , message    = Nothing
    , code       = Nothing
    }


-- | Use a C-style 'Foreign.Cdio' object as the base to run a Haskell-style
-- 'CdText' computation.
-- 
-- Note that some invariants of the monadic interface may not work as expected
-- when used with the mutable objects, usually due to changing the active
-- language block:
-- 
-- @
-- l  <- 'Foreign.language' cdio
-- _  <- 'runCdText' cdio $ 'withIndex' i g
-- l' <- 'Foreign.language' cdio
-- (l == l') == undefined
-- @
runCdText :: Foreign.Cdio -> CdText a -> IO (Either CdTextError a)
runCdText c (CdText f) = isolateLogs $ f Nothing c


-- | Run the given computation within the CdText data associated with the
-- 'Cdio' session.  At this top level, a @'withIndex' 0@ specifically will
-- almost always have the same effect as running the computation directly.
-- Fails with 'NoCdText' if the disc doesn't provide any metadata.
cdText :: CdText a -> Cdio (Either CdTextError a)
cdText (CdText f) = liftCdio $ \c' -> if Foreign.hasCdText c'
    then isolateLogs $ f (Just Default) c'
    else return . Left . CdTextError NoCdText $ T.pack "cdText"

-- | Given a binary stream, attempt to parse it as a CdText block and run the
-- given computation.  Returns @'Left' 'BadBinaryRead'@ if that parse fails.
-- At this top level, a @'withIndex' 0@ specifically will almost always have
-- the same effect as running the computation directly.
--
-- 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 indeed begin with them,
-- @'BS.drop' 4@ before passing the 'BS.ByteString' to this function.
--
-- /Before libcdio 0.94:  Always returns @'Left' 'BadBinaryRead'@/
parseCdText :: BS.ByteString -> CdText a -> IO (Either CdTextError a)
parseCdText bs (CdText f) = isolateLogs $ do
    c <- Foreign.cdTextDataInit bs
    case c of
        Just c' -> f (Just Default) c'
        Nothing -> return . Left . CdTextError BadBinaryRead $ T.pack "parseCdText"


-- | Try to use a specific language as the context for the given computation;
-- as this will frequently fail with 'LanguageNotFound' if given anything other
-- than 'Foreign.English', it is recommended that you provide a fallback with
-- 'A.<|>' or at least allow recovery with 'A.optional'.  Note that
-- 'Foreign.UnknownLanguage' will always fail.
withLanguage :: Foreign.Language -> CdText a -> CdText a
withLanguage l (CdText f) = CdText $ \l' c -> isolateLogs $ do
    b <- Foreign.selectLanguage c l
    a <- if b
        then f (Just $ Lang l) c
        else return . Left . CdTextError (LanguageNotFound l) $ T.pack "withLanguage"
    resetLanguage l' c
    return a

-- | Run the given computation over the data in a specific block.  Fails with
-- 'InvalidBlock' if the index can't be accessed.
withIndex :: Word -> CdText a -> CdText a
withIndex i x = CdText $ \l c -> do
    a <- withIndex' "withIndex" c x i
    resetLanguage l c
    return a

-- | Underlying logic for index-based block selection.  Fails with
-- 'InvalidBlock' if the index can't be accessed.
withIndex'
    :: String
        -- ^ The function calling this, for error printing.
    -> Foreign.Cdio
        -- ^ The underlying disc session.
    -> CdText a
        -- ^ The computation to run.
    -> Word
        -- ^ The index to select.
    -> IO (Either CdTextError a)
withIndex' s c (CdText f) i = do
    b <- Foreign.selectLanguageIndex c i
    if b
    then f (Just $ Index i) c
    else return . Left . CdTextError (InvalidBlock i) $ T.pack s

-- | Run the given computation over /all/ of the accessible languages in the
-- CdText data.  When successful, the resulting list can be associated exactly
-- with the list of 'languages':
--
-- >>> ls <- 'languages'
-- >>> Right ls' <- 'cdText' $ 'withAll' 'language'
-- >>> ls == ls'
-- True
withAll :: CdText a -> CdText [Maybe a]
withAll x = CdText $ \l c -> do
    ls <- Foreign.listAllLanguages c
    let is = zipWith ($>) ls [0..]
    as <- mapM (withBlock c) is
    resetLanguage l c
    return $ sequence as
  where withBlock c (Just i) = fmap Just <$> withIndex' "withAll" c x i
        withBlock _ Nothing = return $ Right Nothing


-- | Get the raw binary data making up the CdText data, if any exists on the
-- disc.
cdTextRaw :: Cdio (Maybe BS.ByteString)
cdTextRaw = liftCdio Foreign.cdTextRaw


-- | Get the language in which any info is currently being retrieved.
language :: CdText Foreign.Language
language = liftCdText $ fmap (Y.fromMaybe Foreign.UnknownLanguage) . Foreign.language

-- | List every language with associated data in the CdText data associated
-- with the session.  Drops any 'Foreign.UnknownLanguage' values from the end
-- of the list.  For a version which operates within the 'CdText' monad, the
-- construction @'withAll' 'language'@ will have an identical effect.
--
-- /Before libcdio 2.1.0:  Silently drops any 'Nothing' or/
-- /@'Just' 'Foreign.UnknownLanguage'@ values, even in the middle of the list,/
-- /and only lists any single language a maximum of one time./
languages :: Cdio [Maybe Foreign.Language]
languages = liftCdio Foreign.listAllLanguages


-- | The earliest track with any associated metadata in the current language.
-- Note that this may differ from 'Sound.Libcdio.Track.minTrack' which gives
-- the first track on the disk, CDTEXT or not.
firstTrack :: CdText Track
firstTrack = liftCdText $ fmap (Y.fromMaybe 1) . Foreign.firstTrack

-- | The final track with any associated metadata in the current language.
-- Note that this may differ from 'Sound.Libcdio.Track.maxTrack' which gives
-- the last track on the disc, CDTEXT or not.
lastTrack :: CdText Track
lastTrack = liftCdText $ fmap (Y.fromMaybe 1) . Foreign.lastTrack


-- | Publisher-specific catalogue number, or some other context-specific
-- identifier.  Note that this may be different than @'code' $ 'info'
-- 'Nothing'@ which is (assumed to be) the unambiguous bar code unique to this
-- disc release.
discId :: CdText (Maybe T.Text)
discId = liftCdText $ \c -> fmap T.pack <$> Foreign.cdTextGet c Foreign.DiscId Nothing

-- | The genre describing the music on this disc, and any associated
-- human-readable name or subgenre.
genre :: CdText (Maybe Foreign.Genre, Maybe T.Text)
genre = liftCdText $ \c -> do
    g <- Foreign.genre c
    s <- Foreign.cdTextGet c Foreign.GenreName Nothing
    return (g, T.pack <$> s)


-- | Retrieve the collection of data associated with a specific track, or if
-- 'Nothing', the disc itself.
info :: Maybe Track -> CdText Info
info t = liftCdText $ \c -> do
    l <- Foreign.cdTextGet c Foreign.Title t
    p <- Foreign.cdTextGet c Foreign.Performer t
    s <- Foreign.cdTextGet c Foreign.Songwriter t
    w <- Foreign.cdTextGet c Foreign.Composer t
    a <- Foreign.cdTextGet c Foreign.Arranger t
    m <- Foreign.cdTextGet c Foreign.Message t
    o <- Foreign.cdTextGet c (if Y.isNothing t then Foreign.UpcEan else Foreign.Isrc) t
    return $ Info
        { title = T.pack <$> l
        , performer = T.pack <$> p
        , songwriter = T.pack <$> s
        , composer = T.pack <$> w
        , arranger = T.pack <$> a
        , message = T.pack <$> m
        , code = T.pack <$> o
        }