{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Text.CueSheet.Parser
( parseCueSheet
, CueParserFailure (..)
, Eec (..) )
where
import Control.Monad.State.Strict
import Data.ByteString (ByteString)
import Data.Data (Data)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isJust)
import Data.Set (Set)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import GHC.Generics
import Numeric.Natural
import Text.CueSheet.Types
import Text.Megaparsec
import Text.Megaparsec.Byte
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.Byte.Lexer as L
data Eec = Eec (Maybe Natural) CueParserFailure
deriving (Show, Eq, Ord, Data, Typeable, Generic)
instance ShowErrorComponent Eec where
showErrorComponent (Eec mtrack failure') =
showErrorComponent failure' ++ "\n" ++
maybe "" (\n -> "in declaration of the track " ++ show n) mtrack
data CueParserFailure
= CueParserTrivialError (Maybe (ErrorItem Word8)) (Set (ErrorItem Word8))
| 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
CueParserTrivialError us es ->
init $ parseErrorTextPretty
(TrivialError undefined us es :: ParseError ByteString Eec)
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 appears out of order"
type Parser a = StateT Context (Parsec Eec ByteString) a
data Context = Context
{ contextCueSheet :: !CueSheet
, contextFiles :: ![CueFile]
, contextTracks :: ![CueTrack]
, contextTrackCount :: !Natural
, contextIndices :: ![CueTime]
, contextIndexCount :: !Natural
}
parseCueSheet
:: String
-> ByteString
-> Either (ParseErrorBundle ByteString 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 = T.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 <- T.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 = T.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 = T.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 = T.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")
takeWhileP (Just "character") (/= 10) *> char 10 *> scn
pFile :: Parser ()
pFile = do
void (symbol "FILE")
filename <- T.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 (lexeme L.decimal)
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.decodeUtf8 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 = T.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 = T.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 = T.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 58)
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 58)
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
o <- getOffset
r <- p
case check r of
Left custom -> do
setOffset o
(fancyFailure . E.singleton . ErrorCustom) (Eec Nothing custom)
Right x -> return x
failAtIf :: Bool -> ByteString -> 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 = region f
where
f (TrivialError pos us es) = FancyError pos . E.singleton $
ErrorCustom (Eec (Just n) (CueParserTrivialError us es))
f (FancyError pos xs) = FancyError pos (E.map g xs)
g (ErrorCustom (Eec mn x)) = ErrorCustom (Eec (mn <|> Just n) x)
g e = e
labelledLit
:: Bool
-> (ByteString -> Either CueParserFailure a)
-> ByteString
-> Parser a
labelledLit shouldFail check command = do
failAtIf shouldFail command
withCheck check (lexeme stringLit) <* eol <* scn
stringLit :: Parser ByteString
stringLit = (quoted <?> "quoted string literal")
<|> (unquoted <?> "unquoted string literal")
where
quoted = char 34 *> takeWhileP Nothing f <* char 34
unquoted = takeWhileP Nothing g
f x = x /= 10 && x /= 34
g x = x /= 10 && x /= 9 && x /= 13 && x /= 32
naturalLit :: Parser Natural
naturalLit = L.decimal
symbol :: ByteString -> Parser ByteString
symbol s = string' s <* notFollowedBy alphaNumChar <* sc
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
scn :: Parser ()
scn = L.space space1 empty empty
sc :: Parser ()
sc = L.space (void $ takeWhile1P Nothing f) empty empty
where
f x = x == 32 || x == 9
seenFlags :: CueTrack -> Bool
seenFlags CueTrack {..} = or
[ cueTrackDigitalCopyPermitted
, cueTrackFourChannelAudio
, cueTrackPreemphasisEnabled
, cueTrackSerialCopyManagement ]
changingFirstOf :: [a] -> (a -> a) -> [a]
changingFirstOf [] _ = []
changingFirstOf (x:xs) f = f x : xs
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 }