module HarmTrace.Base.ChordTokenizer (
parseChordSeq
, pChord
, pShorthand
, pSongAbs
, pRoot
, pAdditions
, pAddition
, pKey
) where
import HarmTrace.Base.Parsing
import HarmTrace.Base.MusicRep
parseChordSeq :: String -> (PieceLabel, [Error LineColPos])
parseChordSeq = parseDataWithErrors pSongAbs
pSongAbs :: Parser PieceLabel
pSongAbs = PieceLabel <$> pKey <* pLineEnd
<*> (setLoc 0 <$> pListSep_ng pLineEnd pChordDur )
<* pList pLineEnd where
setLoc :: Int -> [Chord a] -> [Chord a]
setLoc _ [] = []
setLoc ix (Chord r c d _ l :cs) = (Chord r c d ix l) : setLoc (ix+1) cs
pChordDur :: Parser ChordLabel
pChordDur = setDur <$> pChord <*> (pSym ';' *> pNaturalRaw) <?> "Chord;Int"
where setDur c d = c {duration = d}
pChord :: Parser ChordLabel
pChord = pChordLabel
<|> (noneLabel <$ (pString "N" <|> pString "&pause"))
<|> (unknownLabel <$ (pSym '*' <|> pSym 'X'))
<?> "Chord"
pChordLabel :: Parser ChordLabel
pChordLabel = toChord <$> pRoot <* (pSym ':' `opt` ':') <*> pMaybe pShorthand
<*> ((pAdditions `opt` []) <* pInversion)
where toChord :: Root -> Maybe Shorthand -> [Addition] -> ChordLabel
toChord r Nothing [] = Chord r Maj [] 0 1
toChord r Nothing d = case analyseDegTriad d of
MajTriad -> Chord r Maj (remTriadDeg d) 0 1
MinTriad -> Chord r Min (remTriadDeg d) 0 1
AugTriad -> Chord r Aug (remTriadDeg d) 0 1
DimTriad -> Chord r Dim (remTriadDeg d) 0 1
NoTriad -> Chord r None d 0 1
toChord r (Just s) d = Chord r s d 0 1
remTriadDeg :: [Addition] -> [Addition]
remTriadDeg = filter (\(Add (Note _ i)) -> i /= I3 || i /= I5)
pInversion :: Parser (Maybe (Note Interval))
pInversion = (Just <$> (pSym '/' *> (Note <$> pMaybe pAccidental <*> pInterval))
<?> "/Inversion") `opt` Nothing
pKey :: Parser Key
pKey = f <$> pRoot <* pSym ':' <*> pShorthand <?> "Key"
where f r m | m == Maj = Key r MajMode
| m == Min = Key r MinMode
| otherwise = error ("Tokenizer: key must be Major or Minor, "
++ "found: " ++ show m)
pShorthand :: Parser Shorthand
pShorthand = Maj <$ pString "maj"
<|> Min <$ pString "min"
<|> Dim <$ pString "dim"
<|> Aug <$ pString "aug"
<|> Maj7 <$ pString "maj7"
<|> Min7 <$ pString "min7"
<|> Sev <$ pString "7"
<|> Dim7 <$ pString "dim7"
<|> HDim7 <$ pString "hdim" <* opt (pSym '7') '7'
<|> MinMaj7 <$ pString "minmaj7"
<|> Maj6 <$ pString "maj6"
<|> Maj6 <$ pString "6"
<|> Min6 <$ pString "min6"
<|> Nin <$ pString "9"
<|> Maj9 <$ pString "maj9"
<|> Min9 <$ pString "min9"
<|> Five <$ pString "5"
<|> Sus2 <$ pString "sus2"
<|> Sus4 <$ pString "sus4"
<|> Min11 <$ pString "min11"
<|> Min13 <$ pString "min13"
<|> Maj13 <$ pString "maj13"
<|> Eleven <$ pString "11"
<|> Thirteen <$ pString "13"
<|> None <$ pString "1"
<?> "Shorthand"
pAdditions :: Parser [Addition]
pAdditions = pPacked (pSym '(') (pSym ')') ( pListSep (pSym ',') pAddition )
<?> "Addition List"
pAddition :: Parser Addition
pAddition = (Add <$> (Note <$> pMaybe pAccidental <*> pInterval))
<|> (NoAdd <$> (pSym '*'*> (Note <$> pMaybe pAccidental <*> pInterval)))
<?> "Addition"
pAccidental :: Parser Accidental
pAccidental = Sh <$ pSym 's'
<|> Sh <$ pSym '#'
<|> Fl <$ pSym 'b'
<|> SS <$ pString "ss"
<|> FF <$ pString "bb" <?> "Accidental"
pInterval :: Parser Interval
pInterval = ((!!) [minBound..] ) . pred <$> pNaturalRaw <?> "Interval"
pRoot :: Parser Root
pRoot = Note Nothing A <$ pSym 'A'
<|> Note Nothing B <$ pSym 'B'
<|> Note Nothing C <$ pSym 'C'
<|> Note Nothing D <$ pSym 'D'
<|> Note Nothing E <$ pSym 'E'
<|> Note Nothing F <$ pSym 'F'
<|> Note Nothing G <$ pSym 'G'
<|> Note (Just Fl) A <$ pString "Ab"
<|> Note (Just Fl) B <$ pString "Bb"
<|> Note (Just Fl) C <$ pString "Cb"
<|> Note (Just Fl) D <$ pString "Db"
<|> Note (Just Fl) E <$ pString "Eb"
<|> Note (Just Fl) F <$ pString "Fb"
<|> Note (Just Fl) G <$ pString "Gb"
<|> Note (Just Sh) A <$ pString "A#"
<|> Note (Just Sh) B <$ pString "B#"
<|> Note (Just Sh) C <$ pString "C#"
<|> Note (Just Sh) D <$ pString "D#"
<|> Note (Just Sh) E <$ pString "E#"
<|> Note (Just Sh) F <$ pString "F#"
<|> Note (Just Sh) G <$ pString "G#" <?> "Chord root"