cue-sheet-0.1.0: Text/CueSheet/Parser.hs
-- |
-- Module : Text.CueSheet.Parser
-- Copyright : © 2016 Mark Karpov
-- License : BSD 3 clause
--
-- Maintainer : Mark Karpov <markkarpov@openmailbox.org>
-- Stability : experimental
-- Portability : portable
--
-- The modules contains just CUE sheet parser. You probably want to import
-- "Text.CueSheet" instead.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Text.CueSheet.Parser
( parseCueSheet
, CueParserFailure (..)
, Eec (..) )
where
import Control.Applicative
import Control.Monad.State.Strict
import Data.Data (Data)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics
import Numeric.Natural
import Text.CueSheet.Types
import Text.Megaparsec
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as E
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Text.Megaparsec.Lexer as L
----------------------------------------------------------------------------
-- Types
-- | Extended error component with support for storing number of track
-- declaration in which a parsing error has occurred.
data Eec = Eec (Maybe Natural) (Maybe CueParserFailure)
deriving (Show, Eq, Ord, Data, Typeable, Generic)
instance ErrorComponent Eec where
representFail =
Eec Nothing . Just . CueParserFail
representIndentation ord p0 p1 =
(Eec Nothing . Just) (CueParserIndentation ord p0 p1)
instance ShowErrorComponent Eec where
showErrorComponent (Eec mtrack mfailure) =
maybe "" ((++ "\n") . showErrorComponent) mfailure ++
maybe "" (\n -> "in declaration of the track " ++ show n) mtrack
-- | Enumeration of all failures that may happen during run of
-- 'parseCueSheet'.
data CueParserFailure
= CueParserFail String
| CueParserIndentation Ordering Pos Pos
| CueParserInvalidCatalog Text
| CueParserInvalidCueText Text
| CueParserTrackOutOfOrder
| CueParserInvalidTrackIsrc Text
| CueParserInvalidSeconds Natural
| CueParserInvalidFrames Natural
| CueParserTrackIndexOutOfOrder
deriving (Show, Eq, Ord, Data, Typeable, Generic)
instance ShowErrorComponent CueParserFailure where
showErrorComponent = \case
CueParserFail msg ->
showErrorComponent (DecFail msg)
CueParserIndentation ord p0 p1 ->
showErrorComponent (DecIndentation ord p0 p1)
CueParserInvalidCatalog txt ->
"the value \"" ++ T.unpack txt ++ "\" is not a valid Media Catalog Number"
CueParserInvalidCueText txt ->
"the value \"" ++ T.unpack txt ++ "\" is not a valid CUE text literal"
CueParserTrackOutOfOrder ->
"this track appears out of order"
CueParserInvalidTrackIsrc txt ->
"\"" ++ T.unpack txt ++ "\" is not a valid ISRC"
CueParserInvalidSeconds n ->
"\"" ++ show n ++ "\" is not a valid number of seconds"
CueParserInvalidFrames n ->
"\"" ++ show n ++ "\" is not a valid number of frames"
CueParserTrackIndexOutOfOrder ->
"this index apprears out of order"
-- | Type of parser we use here, it's not public.
type Parser a = StateT Context (Parsec Eec BL.ByteString) a
-- | Context of parsing. This is passed around in 'StateT'. We need all of
-- this to signal parse errors on duplicate declaration of things that
-- should only be declared once according to description of the format, to
-- validate track numbers, etc.
data Context = Context
{ contextCueSheet :: !CueSheet
-- ^ Current state of CUE sheet we parse. When a part\/parameter of CUE
-- sheet is parsed, this thing is updated.
, contextFiles :: ![CueFile]
-- ^ Temporary storage for parsed files (we can't store it in the
-- 'CueSheet' because it does not allow empty list of files).
, contextTracks :: ![CueTrack]
-- ^ Similar to 'contextFiles', collection of tracks but for current
-- file.
, contextTrackCount :: !Natural
-- ^ Number of tracks we have parsed so far, to avoid traversing lists
-- again and again.
, contextIndices :: ![CueTime]
-- ^ Temporary storage for collection indices for current track.
, contextIndexCount :: !Natural
-- ^ Similarly for indices.
}
-- | Parse a CUE sheet from a lazy 'BL.ByteString'.
parseCueSheet
:: String -- ^ File name to include in error messages
-> BL.ByteString -- ^ CUE sheet to parsec as a lazy 'BL.ByteString'
-> Either (ParseError Char Eec) CueSheet -- ^ 'ParseError' or result
parseCueSheet = parse (contextCueSheet <$> execStateT pCueSheet initContext)
where
initContext = Context
{ contextCueSheet = CueSheet
{ cueCatalog = Nothing
, cueCdTextFile = Nothing
, cuePerformer = Nothing
, cueTitle = Nothing
, cueSongwriter = Nothing
, cueFirstTrackNumber = 0
, cueFiles = dummyFile :| [] }
, contextFiles = []
, contextTracks = []
, contextTrackCount = 0
, contextIndices = []
, contextIndexCount = 0 }
-- | Parse a 'CueSheet'. The result is not returned, but written in
-- 'Context'.
pCueSheet :: Parser ()
pCueSheet = do
scn
void (many pHeaderItem)
void (some pFile)
-- NOTE Lens would help here, but let's keep this vanilla.
modify $ \x -> x { contextCueSheet =
(contextCueSheet x)
{ cueFiles = (NE.fromList . reverse . contextFiles) x } }
eof
pHeaderItem :: Parser ()
pHeaderItem = choice
[ pCatalog
, pCdTextFile
, pPerformer
, pTitle
, pSongwriter
, pRem ]
pCatalog :: Parser ()
pCatalog = do
already <- gets (isJust . cueCatalog . contextCueSheet)
let f x' = let x = decodeUtf8 x' in
case mkMcn x of
Nothing -> Left (CueParserInvalidCatalog x)
Just mcn -> Right mcn
mcn <- labelledLit already f "CATALOG"
modify $ \x -> x { contextCueSheet =
(contextCueSheet x) { cueCatalog = Just mcn } }
pCdTextFile :: Parser ()
pCdTextFile = do
already <- gets (isJust . cueCdTextFile . contextCueSheet)
cdTextFile <- decodeUtf8 <$> labelledLit already Right "CDTEXTFILE"
modify $ \x -> x { contextCueSheet = (contextCueSheet x)
{ cueCdTextFile = Just (T.unpack cdTextFile) } }
pPerformer :: Parser ()
pPerformer = do
already <- gets (isJust . cuePerformer . contextCueSheet)
let f x' = let x = decodeUtf8 x' in
case mkCueText x of
Nothing -> Left (CueParserInvalidCueText x)
Just txt -> Right txt
performer <- labelledLit already f "PERFORMER"
modify $ \x -> x { contextCueSheet =
(contextCueSheet x) { cuePerformer = Just performer } }
pTitle :: Parser ()
pTitle = do
already <- gets (isJust . cueTitle . contextCueSheet)
let f x' = let x = decodeUtf8 x' in
case mkCueText x of
Nothing -> Left (CueParserInvalidCueText x)
Just txt -> Right txt
title <- labelledLit already f "TITLE"
modify $ \x -> x { contextCueSheet =
(contextCueSheet x) { cueTitle = Just title } }
pSongwriter :: Parser ()
pSongwriter = do
already <- gets (isJust . cueSongwriter . contextCueSheet)
let f x' = let x = decodeUtf8 x' in
case mkCueText x of
Nothing -> Left (CueParserInvalidCueText x)
Just txt -> Right txt
songwriter <- labelledLit already f "SONGWRITER"
modify $ \x -> x { contextCueSheet =
(contextCueSheet x) { cueSongwriter = Just songwriter } }
pRem :: Parser ()
pRem = do
void (symbol "REM")
manyTill anyChar eol *> scn
pFile :: Parser ()
pFile = do
void (symbol "FILE")
filename <- decodeUtf8 <$> lexeme stringLit
let pFiletype = choice
[ Binary <$ symbol "BINARY"
, Motorola <$ symbol "MOTOROLA"
, Aiff <$ symbol "AIFF"
, Wave <$ symbol "WAVE"
, MP3 <$ symbol "MP3" ]
filetype <- pFiletype <* eol <* scn
void (some (pTrack <|> pRem))
tracks <- gets contextTracks
let newFile = CueFile
{ cueFileName = T.unpack filename
, cueFileType = filetype
, cueFileTracks = NE.fromList (reverse tracks) }
modify $ \x -> x
{ contextFiles = newFile : contextFiles x
, contextTracks = [] }
pTrack :: Parser ()
pTrack = do
void (symbol "TRACK")
trackOffset <- gets (cueFirstTrackNumber . contextCueSheet)
trackCount <- gets contextTrackCount
let firstTrack = trackCount == 0
f x =
if firstTrack || x == trackOffset + trackCount
then Right x
else Left CueParserTrackOutOfOrder
n <- withCheck f (fromIntegral <$> lexeme L.integer)
let pTrackType = choice
[ CueTrackAudio <$ symbol "AUDIO"
, CueTrackCdg <$ symbol "CDG"
, CueTrackMode1_2048 <$ symbol "MODE1/2048"
, CueTrackMode1_2352 <$ symbol "MODE1/2352"
, CueTrackMode2_2336 <$ symbol "MODE2/2336"
, CueTrackMode2_2352 <$ symbol "MODE2/2352"
, CueTrackCdi2336 <$ symbol "CDI/2336"
, CueTrackCdi2352 <$ symbol "CDI/2352" ]
trackType <- pTrackType <* eol <* scn
let newTrack = dummyTrack { cueTrackType = trackType }
modify $ \x -> x
{ contextTracks = newTrack : contextTracks x
, contextTrackCount = trackCount + 1
, contextCueSheet = let old = contextCueSheet x in
if firstTrack
then old { cueFirstTrackNumber = n }
else old }
inTrack n $ do
void (many pTrackHeaderItem)
index0 <- (optional . try . pIndex) 0
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackPregapIndex = index0 } }
modify $ \x -> x
{ contextIndices = []
, contextIndexCount = 0 }
let grabIndex = do
next <- (+ 1) <$> gets contextIndexCount
nextIndex <- pIndex next
modify $ \x -> x
{ contextIndices = nextIndex : contextIndices x
, contextIndexCount = next }
void (some (grabIndex <|> pRem))
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackIndices = (NE.fromList . reverse . contextIndices) x } }
void (optional pPostgap)
pTrackHeaderItem :: Parser ()
pTrackHeaderItem = choice
[ pFlags
, pIsrc
, pTrackPerformer
, pTrackTitle
, pTrackSongwriter
, pRem
, pPregap ]
pFlags :: Parser ()
pFlags = do
already <- gets (seenFlags . head . contextTracks)
failAtIf already "FLAGS"
void (some pFlag) <* eol <* scn
-- | A helper data type.
data CueTrackFlag = DCP | FourCH | PRE | SCMS
pFlag :: Parser ()
pFlag = do
flag <- choice
[ DCP <$ symbol "DCP"
, FourCH <$ symbol "4CH"
, PRE <$ symbol "PRE"
, SCMS <$ symbol "SCMS" ]
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
case flag of
DCP -> t { cueTrackDigitalCopyPermitted = True }
FourCH -> t { cueTrackFourChannelAudio = True }
PRE -> t { cueTrackPreemphasisEnabled = True }
SCMS -> t { cueTrackSerialCopyManagement = True } }
pIsrc :: Parser ()
pIsrc = do
already <- gets (isJust . cueTrackIsrc . head . contextTracks)
let f x' = let x = T.pack x' in
case mkIsrc x of
Nothing -> Left (CueParserInvalidTrackIsrc x)
Just isrc -> Right isrc
isrc <- labelledLit already f "ISRC"
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackIsrc = Just isrc } }
pTrackPerformer :: Parser ()
pTrackPerformer = do
already <- gets (isJust . cueTrackPerformer . head . contextTracks)
let f x' = let x = decodeUtf8 x' in
case mkCueText x of
Nothing -> Left (CueParserInvalidCueText x)
Just txt -> Right txt
performer <- labelledLit already f "PERFORMER"
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackPerformer = Just performer } }
pTrackTitle :: Parser ()
pTrackTitle = do
already <- gets (isJust . cueTrackTitle . head . contextTracks)
let f x' = let x = decodeUtf8 x' in
case mkCueText x of
Nothing -> Left (CueParserInvalidCueText x)
Just txt -> Right txt
title <- labelledLit already f "TITLE"
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackTitle = Just title } }
pTrackSongwriter :: Parser ()
pTrackSongwriter = do
already <- gets (isJust . cueTrackSongwriter . head . contextTracks)
let f x' = let x = decodeUtf8 x' in
case mkCueText x of
Nothing -> Left (CueParserInvalidCueText x)
Just txt -> Right txt
songwriter <- labelledLit already f "SONGWRITER"
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackSongwriter = Just songwriter } }
pPregap :: Parser ()
pPregap = do
already <- gets (isJust . cueTrackPregap . head . contextTracks)
failAtIf already "PREGAP"
time <- lexeme cueTime <* eol <* scn
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackPregap = Just time } }
pPostgap :: Parser ()
pPostgap = do
already <- gets (isJust . cueTrackPostgap . head . contextTracks)
failAtIf already "POSTGAP"
time <- lexeme cueTime <* eol <* scn
modify $ \x -> x
{ contextTracks = changingFirstOf (contextTracks x) $ \t ->
t { cueTrackPostgap = Just time } }
pIndex :: Natural -> Parser CueTime
pIndex n = do
void (symbol "INDEX")
let f x =
if x == n
then Right ()
else Left CueParserTrackIndexOutOfOrder
withCheck f (lexeme naturalLit)
lexeme cueTime <* eol <* scn
cueTime :: Parser CueTime
cueTime = do
minutes <- naturalLit
void (char ':')
let checkSeconds n =
if n < 60
then Right n
else Left (CueParserInvalidSeconds n)
checkFrames n =
if n < 75
then Right n
else Left (CueParserInvalidFrames n)
seconds <- withCheck checkSeconds naturalLit
void (char ':')
frames <- withCheck checkFrames naturalLit
case fromMmSsFf minutes seconds frames of
Nothing -> empty -- NOTE must be always valid, we checked already
Just x -> return x
----------------------------------------------------------------------------
-- Helpers
-- | Parse a thing and then check if it's OK conceptually. If it's not OK,
-- the error will be reported with position at the start of offending
-- lexeme, otherwise the lexeme is parsed as usual. Of course if the lexeme
-- has incorrect format, that is just reported and no additional check
-- happens.
withCheck :: (a -> Either CueParserFailure b) -> Parser a -> Parser b
withCheck check p = do
r <- lookAhead p
case check r of
Left custom -> failure E.empty E.empty $
E.singleton (Eec Nothing (Just custom))
Right x -> x <$ p
-- | If the first argument is 'True' and we can parse the given command,
-- fail pointing at the beginning of the command and report it as something
-- unexpected.
failAtIf :: Bool -> String -> Parser ()
failAtIf shouldFail command = do
let p = void (symbol command)
lookAhead p
if shouldFail
then empty
else p
-- | Indicate that the inner parser belongs to declaration of track with
-- given index. The index of the track will be added to 'ParseError's to
-- help user find where the error happened.
inTrack :: Natural -> Parser a -> Parser a
inTrack n m = do
r <- observing m
case r of
Left ParseError {..} ->
failure errorUnexpected errorExpected $
if E.null errorCustom
then E.singleton (Eec (Just n) Nothing)
else E.map f errorCustom
where
f (Eec mn x) = Eec (mn <|> Just n) x
Right x -> return x
-- | A labelled literal (a helper for common case).
labelledLit
:: Bool -- ^ Should we instantly fail when command is parsed?
-> (String -> Either CueParserFailure a) -- ^ How to judge the result
-> String -- ^ Name of the command to grab
-> Parser a
labelledLit shouldFail check command = do
failAtIf shouldFail command
withCheck check (lexeme stringLit) <* eol <* scn
-- | String literal with support for quotation.
stringLit :: Parser String
stringLit = quoted <|> unquoted
where
quoted = char '\"' *> manyTill (noneOf ("\n" :: String)) (char '\"')
unquoted = many (noneOf ("\n\t\r " :: String))
-- | Parse a 'Natural'.
naturalLit :: Parser Natural
naturalLit = fromIntegral <$> L.integer
-- | Case-insensitive symbol parser.
symbol :: String -> Parser String
symbol s = string' s <* notFollowedBy alphaNumChar <* sc
-- | A wrapper for lexemes.
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
-- | Space consumer (eats newlines).
scn :: Parser ()
scn = L.space (void spaceChar) empty empty
-- | Space consumer (does not eat newlines).
sc :: Parser ()
sc = L.space (void $ oneOf ("\t " :: String)) empty empty
-- | Determine by 'CueTrack' if we have already parsed FLAGS command.
seenFlags :: CueTrack -> Bool
seenFlags CueTrack {..} = or
[ cueTrackDigitalCopyPermitted
, cueTrackFourChannelAudio
, cueTrackPreemphasisEnabled
, cueTrackSerialCopyManagement ]
-- | Apply given function to the first element of the list.
changingFirstOf :: [a] -> (a -> a) -> [a]
changingFirstOf [] _ = []
changingFirstOf (x:xs) f = f x : xs
-- | Decode UTF-8 encoded 'B.ByteString' represented as a 'String'.
decodeUtf8 :: String -> Text
decodeUtf8 = T.decodeUtf8 . B8.pack
----------------------------------------------------------------------------
-- Dummies
-- | A dummy file. It's only here because 'CueSheet' can't have an empty
-- list of files and it cannot be a bottom either.
dummyFile :: CueFile
dummyFile = CueFile
{ cueFileName = ""
, cueFileType = Wave
, cueFileTracks = dummyTrack :| [] }
-- | A dummy track, see 'dummyFile'.
dummyTrack :: CueTrack
dummyTrack = CueTrack
{ cueTrackDigitalCopyPermitted = False
, cueTrackFourChannelAudio = False
, cueTrackPreemphasisEnabled = False
, cueTrackSerialCopyManagement = False
, cueTrackType = CueTrackAudio
, cueTrackIsrc = Nothing
, cueTrackTitle = Nothing
, cueTrackPerformer = Nothing
, cueTrackSongwriter = Nothing
, cueTrackPregap = Nothing
, cueTrackPregapIndex = Nothing
, cueTrackIndices = CueTime 0 :| []
, cueTrackPostgap = Nothing }