HarmTrace-Base-1.1.0.2: src/HarmTrace/Base/ChordTokenizer.hs
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE FlexibleContexts #-}
--------------------------------------------------------------------------------
-- |
-- Module : HarmTrace.Base.Parsing
-- Copyright : (c) 2012--2013 W. Bas de Haas and Jose Pedro Magalhaes
-- License : LGPL-3
--
-- Maintainer : bas@chordify.net, dreixel@chordify.net
-- Stability : experimental
-- Portability : non-portable
--
-- Summary: Some general parsing utilities used for parsing textual chord
-- representations.
--------------------------------------------------------------------------------
module HarmTrace.Base.ChordTokenizer ( -- * Top level parser
parseChordSeq
-- * Parsing (elements of) chords
, pChord
, pShorthand
, pSongAbs
, pRoot
, pAdditions
, pAddition
, pKey
) where
import HarmTrace.Base.Parsing
import HarmTrace.Base.MusicRep
--------------------------------------------------------------------------------
-- Top level Chord sequence parser
--------------------------------------------------------------------------------
-- | Top level parser that parsers a string into a 'PieceLabel' and a posibly
-- empty list of errors
parseChordSeq :: String -> (PieceLabel, [Error LineColPos])
parseChordSeq = parseDataWithErrors pSongAbs
--------------------------------------------------------------------------------
-- Tokenizing: parsing strings into tokens
--------------------------------------------------------------------------------
-- | Parser that parses a string of whitespace-separated 'Chord's, e.g.
-- @C:maj Bb:9(s11);1 E:min7;1 Eb:min7;1 Ab:7;1 D:min7;1 G:7(13);1 C:maj6(9);1@
-- The first 'Chord' must be the key of the piece, and the after each chord
-- the semicolumn and an Integer representing the duration of the chord must
-- be presented
pSongAbs :: Parser PieceLabel -- PieceRelToken --
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
-- parses chords with a duration (separated by a ';')
pChordDur :: Parser ChordLabel
pChordDur = setDur <$> pChord <*> (pSym ';' *> pNaturalRaw) <?> "Chord;Int"
where setDur c d = c {duration = d}
-- | Parses a 'ChordLabel' in Harte et al. syntax including possible additions,
-- and removal of chord additions. If a chord has no 'Shorthand', the 'Degree'
-- list (if any) is analysed and depending on the 'Triad' (if any) a
-- 'Maj', 'Min','Aug', or 'Dim' 'Shorthand' is stored. By default all the
-- duration stored in every 'Chord' is 1 (where the unit is application
-- dependend, often these are beats, but they can also be eightnotes)
pChord :: Parser ChordLabel
{-# INLINE pChord #-}
pChord = pChordLabel
<|> (noneLabel <$ (pString "N" <|> pString "&pause"))
<|> (unknownLabel <$ (pSym '*' <|> pSym 'X'))
<?> "Chord"
-- Parses a chord label
-- TODO add support for inversion
pChordLabel :: Parser ChordLabel
{-# INLINE pChordLabel #-}
pChordLabel = toChord <$> pRoot <* (pSym ':' `opt` ':') <*> pMaybe pShorthand
-- we ignore optional inversions for now
<*> ((pAdditions `opt` []) <* pInversion)
where toChord :: Root -> Maybe Shorthand -> [Addition] -> ChordLabel
-- if there are no degrees and no shorthand, following Harte it
-- should be labelled a Maj chord
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
-- removes the third and the fifth from a Addtion list
remTriadDeg :: [Addition] -> [Addition]
remTriadDeg = filter (\(Add (Note _ i)) -> i /= I3 || i /= I5)
-- Parses an inversion, but inversionsion are ignored for now.
pInversion :: Parser (Maybe (Note Interval))
pInversion = (Just <$> (pSym '/' *> (Note <$> pMaybe pAccidental <*> pInterval))
<?> "/Inversion") `opt` Nothing
-- | parses a musical key description, e.g. @C:maj@, or @D:min@
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)
-- | Parses a shorthand following Harte et al. syntax, but also the shorthands
-- added to the Billboard dataset, e.g. @maj@, @min@, or @9@.
pShorthand :: Parser Shorthand
{-# INLINE pShorthand #-}
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"
-- additional Billboard shorthands
<|> Min11 <$ pString "min11"
<|> Min13 <$ pString "min13"
<|> Maj13 <$ pString "maj13"
<|> Eleven <$ pString "11"
<|> Thirteen <$ pString "13"
<|> None <$ pString "1" -- no shorthand: used in billboard to
-- denote a rootnote only
<?> "Shorthand"
-- | Parses a list of 'Chord' 'Addition's within parenthesis
pAdditions :: Parser [Addition]
pAdditions = pPacked (pSym '(') (pSym ')') ( pListSep (pSym ',') pAddition )
<?> "Addition List"
-- | Parses the a 'Chord' 'Addition' (or the removal of a chord addition,
-- prefixed by a @*@)
pAddition :: Parser Addition
pAddition = (Add <$> (Note <$> pMaybe pAccidental <*> pInterval))
<|> (NoAdd <$> (pSym '*'*> (Note <$> pMaybe pAccidental <*> pInterval)))
<?> "Addition"
-- | Parses in 'Accidental'
pAccidental :: Parser Accidental
pAccidental = Sh <$ pSym 's'
<|> Sh <$ pSym '#'
<|> Fl <$ pSym 'b'
<|> SS <$ pString "ss"
<|> FF <$ pString "bb" <?> "Accidental"
-- | Parses an 'Interval'
pInterval :: Parser Interval
pInterval = ((!!) [minBound..] ) . pred <$> pNaturalRaw <?> "Interval"
-- | Parses a 'Root' 'Note', e.g. @A@, @Bb@, or @F#@.
pRoot :: Parser Root
{-# INLINE pRoot #-}
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"