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
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
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 Parser a = StateT Context (Parsec Eec BL.ByteString) a
data Context = Context
{ contextCueSheet :: !CueSheet
, contextFiles :: ![CueFile]
, contextTracks :: ![CueTrack]
, contextTrackCount :: !Natural
, contextIndices :: ![CueTime]
, contextIndexCount :: !Natural
}
parseCueSheet
:: String
-> BL.ByteString
-> Either (ParseError Char Eec) CueSheet
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 }
pCueSheet :: Parser ()
pCueSheet = do
scn
void (many pHeaderItem)
void (some pFile)
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
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
Just x -> return x
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
failAtIf :: Bool -> String -> Parser ()
failAtIf shouldFail command = do
let p = void (symbol command)
lookAhead p
if shouldFail
then empty
else p
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
labelledLit
:: Bool
-> (String -> Either CueParserFailure a)
-> String
-> Parser a
labelledLit shouldFail check command = do
failAtIf shouldFail command
withCheck check (lexeme stringLit) <* eol <* scn
stringLit :: Parser String
stringLit = quoted <|> unquoted
where
quoted = char '\"' *> manyTill (noneOf ("\n" :: String)) (char '\"')
unquoted = many (noneOf ("\n\t\r " :: String))
naturalLit :: Parser Natural
naturalLit = fromIntegral <$> L.integer
symbol :: String -> Parser String
symbol s = string' s <* notFollowedBy alphaNumChar <* sc
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
scn :: Parser ()
scn = L.space (void spaceChar) empty empty
sc :: Parser ()
sc = L.space (void $ oneOf ("\t " :: String)) empty empty
seenFlags :: CueTrack -> Bool
seenFlags CueTrack {..} = or
[ cueTrackDigitalCopyPermitted
, cueTrackFourChannelAudio
, cueTrackPreemphasisEnabled
, cueTrackSerialCopyManagement ]
changingFirstOf :: [a] -> (a -> a) -> [a]
changingFirstOf [] _ = []
changingFirstOf (x:xs) f = f x : xs
decodeUtf8 :: String -> Text
decodeUtf8 = T.decodeUtf8 . B8.pack
dummyFile :: CueFile
dummyFile = CueFile
{ cueFileName = ""
, cueFileType = Wave
, cueFileTracks = dummyTrack :| [] }
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 }