diff --git a/abcnotation.cabal b/abcnotation.cabal --- a/abcnotation.cabal +++ b/abcnotation.cabal @@ -1,6 +1,6 @@ name: abcnotation -version: 1.8.1 +version: 1.9.0 synopsis: Haskell representation and parser for ABC notation. author: Hans Hoglund maintainer: Hans Hoglund @@ -24,8 +24,8 @@ location: git://github.com/music-suite/abcnotation.git library - exposed-modules: Music.Abc - Music.Abc.Parser + exposed-modules: Data.Music.Abc + Data.Music.Abc.Parser build-depends: base >= 4 && < 5, semigroups >= 0.13.0.1 && < 1, prettify, diff --git a/src/Data/Music/Abc.hs b/src/Data/Music/Abc.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/Abc.hs @@ -0,0 +1,593 @@ + +{-# LANGUAGE TypeOperators, OverloadedStrings, GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +-- A Haskell representation and parser for ABC notation. Based on the 2.1 standard. +-- +-- For more information see . +-- +------------------------------------------------------------------------------------- + +-- TODO compare https://github.com/sergi/abcnode/blob/master/parser.pegjs + +module Data.Music.Abc ( + + ---------------------------------------------------------------------- + + -- * Abc format + -- ** Files + AbcFile(..), + + -- *** File header + FileHeader(..), + Element(..), + + -- ** Tunes + AbcTune(..), + TuneHeader(..), + TuneBody(..), + + ---------------------------------------------------------------------- + + -- * Music + Music(..), + Chord(..), + Barline(..), + Annotation(..), + ChordSymbol(..), + Decoration(..), + Dynamic(..), + + -- ** Time + Duration(..), + Meter(..), + Tempo(..), + + -- ** Pitch + PitchClass(..), + Accidental(..), + Octave(..), + Pitch(..), + Key(..), + StemDirection(..), + Clef(..), + Mode(..), + + ---------------------------------------------------------------------- + + -- * Information + Information(..), + Directive(..), + VoiceProperties(..), + + ---------------------------------------------------------------------- + + -- * Import and export + readAbc, + showAbc + ) where + +import Data.Maybe +import Data.Ratio +import Data.Char +import Data.Semigroup +import Data.List (intersperse) +import Text.Pretty hiding (Mode) + +-------------------------------------------------------------------------------- + +-- File structure + + +-- | A full ABC file (2.2). +data AbcFile + = AbcFile + (Maybe String) + (Maybe FileHeader) + [Element] + deriving (Eq, Ord, Show) + +instance Pretty AbcFile where + pretty (AbcFile version header elements) = mempty + <> "%abc-" <> string (fromMaybe "2.1" version) <> "\n" + <> pretty header <> "\n" + <> sepBy "\n" (fmap pretty elements) <> "\n" + + +-- | File header (2.2.2). +data FileHeader + = FileHeader + [Information] + [Directive] + deriving (Eq, Ord, Show) + +instance Pretty FileHeader where + pretty (FileHeader info directives) = mempty + <> sepBy "\n" (fmap pretty info) <> "\n" + <> sepBy "\n" (fmap pretty directives) + + +-- | Either a tune, free text or typeset text (2.2.3). +data Element + = Tune + AbcTune -- ^ An Abc tune. + | FreeText + String -- ^ Free text (2.2.3). + | TypesetText + String -- ^ Typeset text (2.2.3). + deriving (Eq, Ord, Show) + +instance Pretty Element where + pretty (Tune a) = pretty a + pretty (FreeText a) = string a + pretty (TypesetText a) = string a + + +data AbcTune + = AbcTune + TuneHeader + TuneBody + deriving (Eq, Ord, Show) + +instance Pretty AbcTune where + pretty (AbcTune header elements) = mempty + <> pretty header <> "\n" + <> sepBy "\n" (fmap pretty elements) <> "\n" + + +data TuneHeader + = TuneHeader + [Information] + deriving (Eq, Ord, Show) + +instance Pretty TuneHeader where + pretty (TuneHeader info) = + sepBy "\n" (fmap pretty info) + + +-- | Lines of music code. +type TuneBody + = [Music] +-- TODO voices, see http://www.barfly.dial.pipex.com/multivoice.txt + + +-------------------------------------------------------------------------------- + +-- Music + + +-- | One line of music code. +data Music + = Chord Chord + | Barline Barline + | Tie Music + | Slur Music + | Beam Music + | Grace Music + | Tuplet Duration Music + | Decorate Decoration Music + | Annotate Annotation Music + | ChordSymbol ChordSymbol Music + | Sequence [Music] -- beam? music + deriving (Eq, Ord, Show) + +instance Pretty Music where + pretty = go + where + go (Chord a) = pretty a + go (Sequence as) = sepBy " " $ fmap pretty as + -- FIXME + + +data Annotation + = AnnotateLeft String + | AnnotateRight String + | AnnotateAbove String + | AnnotateBelow String + | AnnotateUnspecified String + deriving (Eq, Ord, Show) + +-- TODO clefs and transposition (4.6) +-- TODO redifinable symbols (4.16) +-- TODO symbol lines (4.15) +-- TODO symbol lyrics + +-- Note (4.20) +newtype Chord = Chord_ { getChord :: ( + [Pitch], + (Maybe Duration) + ) } + deriving (Eq, Ord, Show) + +instance Pretty Chord where + -- TODO skip duration if zero + pretty (Chord_ ([], dur)) = "" + pretty (Chord_ ([pitch], dur)) = + pretty pitch <> pretty dur + pretty (Chord_ (pitches, dur)) = + brackets (sepBy "" (fmap pretty pitches)) <> pretty dur + + +type ChordSymbol + = String + +-- | Barline, including special barlines and repeats. +data Barline + = SingleBarline + | DoubleBarline Bool Bool -- thick? thick? + | Repeat Int Bool Bool -- times end? begin? + | DottedBarline Barline + | InvisibleBarline Barline + deriving (Eq, Ord, Show) + +-- TODO first and second repeats (4.9) +-- TODO variant endings (4.10) + + +-- | Decorations (4.14) +data Decoration + = Trill -- "tr" (trill mark) + | TrillBegin -- start of an extended trill + | TrillEnd -- end of an extended trill + | Lowermordent -- short squiggle with a vertical line through it + | Uppermordent -- short squiggle + | Roll -- a roll mark (arc) as used in Irish music + | Turn -- a turn mark (also known as gruppetto) + | Turnx -- a turn mark with a line through it + | Invertedturn -- an inverted turn mark + | Invertedturnx -- an inverted turn mark with a line through it + | Arpeggio -- vertical squiggle + | Accent -- accent mark + | Fermata Bool -- fermata or hold (arc above dot), inverted? + | Tenuto -- horizontal line to indicate holding note for full duration + | Fingering Int -- fingerings + | Plus -- left-hand pizzicato, or rasp for French horns + | Snap -- snap-pizzicato mark, visually similar to !thumb! + | Slide -- slide up to a note, visually similar to a half slur + | Wedge -- small filled-in wedge mark + | Upbow -- V mark + | Downbow -- squared n mark + | Open -- small circle above note indicating open string or harmonic + | Thumb -- cello thumb symbol + | Breath -- a breath mark (apostrophe-like) after note + | Dynamic Dynamic -- Dynamics + | Crescendo -- start of a crescendo mark + | EndCrescendo -- end of a crescendo mark, placed after the last note + | Diminuendo -- start of a diminuendo mark + | EndDiminuendo -- end of a diminuendo mark, placed after the last note + | Segno -- ornate s-like symbols separated by a diagonal line + | Coda -- a ring with a cross in it + | DaSegno -- the letters D.S. (=Da Segno) + | DaCapo -- the letters D.C. (=either Da Coda or Da Capo) + | Dacoda -- the word "Da" followed by a Coda sign + | Fine -- the word "fine" + | Shortphrase -- vertical line on the upper part of the staff + | Mediumphrase -- same, but extending down to the centre line + | Longphrase -- same, but extending 3/4 of the way down + deriving (Eq, Ord, Show) + +data Dynamic + = PPPP + | PPP + | PP + | P_ + | MP + | MF + | F_ + | FF + | FFF + | FFFF + | SFZ + deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- + +-- Information + + +-- | An information field (3). +data Information + = Area String + | Book String + | Composer String + | Discography String + | FileUrl String + | Group String + | History String + | Instruction Directive + | Key Key + | UnitNoteLength Duration + | Meter Meter + | Macro -- ^ Macro (not supported) + | Notes String -- ^ Notes + | Origin String -- ^ Origin of tune. + | Parts + | Tempo Tempo -- ^ Tempo of tune. + | Rhythm String -- ^ Rhythm type of tune. + | Remark -- ^ Remarks (not supported) + | Source String -- ^ Source material. + | SymbolLine + | Title String -- ^ Title of tune. + | UserDefined -- ^ User defined (not supported) + | Voice VoiceProperties + | Words String + | ReferenceNumber Integer + | Transcription String + deriving (Eq, Ord, Show) + +instance Pretty Information where + pretty a = string $ fieldName a ++ ": " ++ showField a + + +fieldName :: Information -> String +fieldName = go + where + go (Area _) = "A" + go (Book _) = "B" + go (Composer _) = "C" + go (Discography _) = "D" + go (FileUrl _) = "F" + go (Group _) = "G" + go (History _) = "H" + go (Instruction _) = "I" + go (Key _) = "K" + go (UnitNoteLength _) = "L" + go (Meter _) = "M" + go Macro = "m" + go (Notes _) = "N" + go (Origin _) = "O" + go Parts = "O" + go (Tempo _) = "Q" + go (Rhythm _) = "R" + go Remark = "r" + go (Source _) = "S" + go SymbolLine = "s" + go (Title _) = "T" + go UserDefined = "U" + go (Voice _) = "V" + go (Words _) = "W" + go (ReferenceNumber _) = "X" + go (Transcription _) = "Z" + +-- (file header, tune header, tune body, inline) +fieldAllowed :: Information -> (Bool, Bool, Bool, Bool) +fieldAllowed = go + where + go (Area _) = (True, True, False, False) + go (Book _) = (True, True, False, False) + go (Composer _) = (True, True, False, False) + go (Discography _) = (True, True, False, False) + go (FileUrl _) = (True, True, False, False) + go (Group _) = (True, True, False, False) + go (History _) = (True, True, False, False) + + go (Instruction _) = (True, True, True, True) + go (Key _) = (False, True{-last-}, True, True) + go (UnitNoteLength _) = (True, True, True, True) + go (Meter _) = (True, True, True, True) + go Macro = (True, True, True, True) + go (Notes _) = (True, True, True, True) + + go (Origin _) = (True, True, False, False) + go Parts = (False, True, True, True) + go (Tempo _) = (False, True, True, True) + go (Rhythm _) = (True, True, True, True) + go Remark = (True, True, True, True) + + go (Source _) = (True, True, False, False) + go SymbolLine = (False, False, True, False) + go (Title _) = (False, True{-second-}, True, False) + + go UserDefined = (True, True, True, True) + go (Voice _) = (False, True, True, True) + go (Words _) = (False, True, True, False) + go (ReferenceNumber _) = (False, True{-first-}, True, False) + go (Transcription _) = (True, True, False, False) + +fieldAllowedInFileHeader a = r where (r,_,_,_) = fieldAllowed a +fieldAllowedInTuneHeader a = r where (_,r,_,_) = fieldAllowed a +fieldAllowedInTuneBody a = r where (_,_,r,_) = fieldAllowed a +fieldAllowedInline a = r where (_,_,_,r) = fieldAllowed a + +showField :: Information -> String +showField = go + where + go (Area a) = a + go (Book a) = a + go (Composer a) = a + go (Discography a) = a + go (FileUrl a) = a + go (Group a) = a + go (History a) = a + go (Instruction a) = show $ pretty a + go (Key a) = show $ pretty a + go (UnitNoteLength a) = show $ pretty a + go (Meter a) = show $ pretty a + go Macro = "" + go (Notes a) = a + go (Origin a) = a + go Parts = "" -- TODO + go (Tempo a) = show $ pretty a + go (Rhythm a) = a + go Remark = "" -- TODO + go (Source a) = a + go SymbolLine = "" -- TODO + go (Title a) = a + go UserDefined = "" -- TODO + go (Voice a) = show $ pretty a + go (Words a) = a + go (ReferenceNumber a) = show a + go (Transcription a) = a + + +-------------------------------------------------------------------------------- + +-- Base types + +-- | Pitch (4.1, 4.2). +newtype Pitch = Pitch { getPitch :: (PitchClass, Maybe Accidental, Octave) } + deriving (Eq, Ord, Show) + +instance Pretty Pitch where + pretty (Pitch (cl, acc, oct)) = pretty acc <> (string $ + (if oct <= 0 then id else fmap toLower) (show cl) + ++ replicate (negate (fromIntegral oct) `max` 0) ',' + ++ replicate (fromIntegral (oct - 1) `max` 0) '\'') + +-- | Pitch class (4.1). +data PitchClass = C | D | E | F | G | A | B + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Accidentals (4.2). +data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp + deriving (Eq, Ord, Show, Enum, Bounded) + +instance Pretty Accidental where + pretty = go + where + go DoubleFlat = "__" + go Flat = "_" + go Natural = "=" + go Sharp = "^" + go DoubleSharp = "^^" + +-- | Octaves (4.1). +newtype Octave = Octave { getOctave :: Int } + deriving (Eq, Ord, Show, Enum, Num, Real, Integral) + + + + + + +-- | Duration (4.3). +newtype Duration = Duration { getDuration :: Rational } + deriving (Eq, Ord, Show, Enum, Num, Real, Fractional, RealFrac) + +instance Pretty Duration where + pretty = string . showRatio . getDuration + + +data Meter + = NoMeter + | Common + | Cut + | Simple Rational + | Compound [Integer] Integer + deriving (Eq, Ord, Show) + +instance Pretty Meter where + pretty = go + where + go Common = "C" + go Cut = "C|" + go (Simple a) = string $ showRatio a + go (Compound as a) = sepBy "+" (fmap integer as) <> "/" <> integer a + + + + + + + + +newtype Key = Key_ (Integer, Mode) + deriving (Eq, Ord, Show) + +instance Pretty Key where + pretty (Key_ (tonic, mode)) = prettyTonic tonic <+> pretty mode + where + prettyTonic a = case a of + 0 -> "C" + +data Mode + = Major + | Minor + | Ionian + | Dorian + | Phrygian + | Lydian + | Mixolydian + | Aeolian + | Locrian + deriving (Eq, Ord, Show) + +instance Pretty Mode where + pretty = go + where + go Major = "" + go Minor = "minor" + go Ionian = "ionian" + go Dorian = "dorian" + go Phrygian = "phrygian" + go Lydian = "lydian" + go Mixolydian = "mixolydian" + go Aeolian = "aeolian" + go Locrian = "locrian" + + + + +-- | Optional string, numerators, frequency (3.1.8) +newtype Tempo = Tempo_ { getTempo :: (Maybe String, [Duration], Duration) } + deriving (Eq, Ord, Show) + +instance Pretty Tempo where + pretty (Tempo_ (str, durs, bpm)) = + pretty str <+> (hsep (fmap pretty durs) <> "=" <> pretty bpm) + +data VoiceProperties + = VoiceProperties + (Maybe String) + (Maybe String) + (Maybe StemDirection) + (Maybe Clef) + deriving (Eq, Ord, Show) + +instance Pretty VoiceProperties where + pretty _ = "{VoiceProperties}" + -- FIXME + +data StemDirection = Up | Down + deriving (Eq, Ord, Show, Enum, Bounded) + +data Clef = NoClef | Treble | Alto | Tenor | Bass | Perc + deriving (Eq, Ord, Show, Enum, Bounded) + + +-- | Abc directive. +newtype Directive = Directive { getDirective :: (String, String) } + deriving (Eq, Ord, Show) + +instance Pretty Directive where + pretty _ = "{Directive}" + -- FIXME + + + +-------------------------------------------------------------------------------- + +-- Utility + +readAbc :: String -> AbcFile +readAbc = error "Not impl" + +showAbc :: AbcFile -> String +showAbc = error "Not impl" + + +showRatio :: (Integral a, Show a) => Ratio a -> String +showRatio x + | denominator x == 1 = show (numerator x) + | otherwise = (show $ numerator x) ++ "/" ++ (show $ denominator x) + diff --git a/src/Data/Music/Abc/Parser.hs b/src/Data/Music/Abc/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/Abc/Parser.hs @@ -0,0 +1,141 @@ + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.Abc.Parser ( + parse + ) where + +import Data.Monoid +import Data.Either +import Control.Monad +import Control.Applicative hiding ((<|>), optional, many) + +import Text.Parsec hiding (parse) +import Text.Parsec.Token +import Text.Parsec.String + +import Data.Music.Abc + +-- TODO information field verification (header/body) + +-- ## Limitations: +-- +-- * Limited support for *volatile* features +-- * Limited support for text strings (§8.2) +-- * No mnemonics +-- * No entities +-- * Unicode escapes are supported +-- * No support for macros (§9) +-- * No support for outdated syntax (§10) +-- * Stylesheet directives are ignored (§11) +-- * Typeset text is ignored (§2.2.3) +-- * Strict interpretation assumed (§12) + + +-- | +-- Parse a module description, returning an error if unsuccessful. +-- +parse :: String -> Either ParseError AbcFile +parse = runParser abcFile () "" + +------------------------------------------------------------------------------------- +-- Parsers +------------------------------------------------------------------------------------- + +abcFile :: Parser AbcFile +abcFile = do + -- optional byteOrderMark + string "%abc" + optional $ string "-" >> version + optional $ fileHeader + fileBody + return undefined + +fileHeader :: Parser FileHeader +fileHeader = fmap (uncurry FileHeader . partitionEithers) $ many1 $ mzero + <|> fmap Left informationField + <|> fmap Right styleSheetDirective + +fileBody :: Parser [Element] +fileBody = (flip sepBy) emptyLine $ mzero + <|> fmap Tune abcTune + <|> fmap FreeText freeText + <|> fmap TypesetText typeSetText + +informationField :: Parser Information +informationField = do + letter + char ':' + -- TODO anything not \n + char '\n' + return undefined + +-- Not parsed, see Limitations +styleSheetDirective :: Parser Directive +styleSheetDirective = mzero + +byteOrderMark :: Parser () +byteOrderMark = do + char '\xFFFE' <|> char '\xFEFF' + return () + +version :: Parser Double +version = undefined + +abcTune :: Parser AbcTune +abcTune = undefined + +freeText :: Parser String +freeText = undefined + +-- Not parsed, see Limitations +typeSetText :: Parser String +typeSetText = mzero + + +------------------------------------------------------------------------------------- +-- Lexer +------------------------------------------------------------------------------------- + +lexer :: TokenParser () +lexer = makeTokenParser $ LanguageDef { + commentStart = "[r:", + commentEnd = "]", + commentLine = "%", + nestedComments = False, + identStart = (letter <|> char '_'), + identLetter = (alphaNum <|> char '_'), + opStart = mzero, + opLetter = mzero, + reservedNames = reservedNames, + reservedOpNames = mzero, + caseSensitive = True + } + where + reservedNames = [] + +-- Convenient synonyms, not exported +llex = lexeme lexer +lnat = natural lexer +lstr = stringLiteral lexer +lname = identifier lexer +lres = reserved lexer +lspace = whiteSpace lexer + +emptyLine = newLine >> newLine +newLine = string "\r\n" <|> string "\n" + +single x = [x] + +notSupported x = error $ "Not supported yet: " ++ x + diff --git a/src/Music/Abc.hs b/src/Music/Abc.hs deleted file mode 100644 --- a/src/Music/Abc.hs +++ /dev/null @@ -1,593 +0,0 @@ - -{-# LANGUAGE TypeOperators, OverloadedStrings, GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- --- A Haskell representation and parser for ABC notation. Based on the 2.1 standard. --- --- For more information see . --- -------------------------------------------------------------------------------------- - --- TODO compare https://github.com/sergi/abcnode/blob/master/parser.pegjs - -module Music.Abc ( - - ---------------------------------------------------------------------- - - -- * Abc format - -- ** Files - AbcFile(..), - - -- *** File header - FileHeader(..), - Element(..), - - -- ** Tunes - AbcTune(..), - TuneHeader(..), - TuneBody(..), - - ---------------------------------------------------------------------- - - -- * Music - Music(..), - Chord(..), - Barline(..), - Annotation(..), - ChordSymbol(..), - Decoration(..), - Dynamic(..), - - -- ** Time - Duration(..), - Meter(..), - Tempo(..), - - -- ** Pitch - PitchClass(..), - Accidental(..), - Octave(..), - Pitch(..), - Key(..), - StemDirection(..), - Clef(..), - Mode(..), - - ---------------------------------------------------------------------- - - -- * Information - Information(..), - Directive(..), - VoiceProperties(..), - - ---------------------------------------------------------------------- - - -- * Import and export - readAbc, - showAbc - ) where - -import Data.Maybe -import Data.Ratio -import Data.Char -import Data.Semigroup -import Data.List (intersperse) -import Text.Pretty hiding (Mode) - --------------------------------------------------------------------------------- - --- File structure - - --- | A full ABC file (2.2). -data AbcFile - = AbcFile - (Maybe String) - (Maybe FileHeader) - [Element] - deriving (Eq, Ord, Show) - -instance Pretty AbcFile where - pretty (AbcFile version header elements) = mempty - <> "%abc-" <> string (fromMaybe "2.1" version) <> "\n" - <> pretty header <> "\n" - <> sepBy "\n" (fmap pretty elements) <> "\n" - - --- | File header (2.2.2). -data FileHeader - = FileHeader - [Information] - [Directive] - deriving (Eq, Ord, Show) - -instance Pretty FileHeader where - pretty (FileHeader info directives) = mempty - <> sepBy "\n" (fmap pretty info) <> "\n" - <> sepBy "\n" (fmap pretty directives) - - --- | Either a tune, free text or typeset text (2.2.3). -data Element - = Tune - AbcTune -- ^ An Abc tune. - | FreeText - String -- ^ Free text (2.2.3). - | TypesetText - String -- ^ Typeset text (2.2.3). - deriving (Eq, Ord, Show) - -instance Pretty Element where - pretty (Tune a) = pretty a - pretty (FreeText a) = string a - pretty (TypesetText a) = string a - - -data AbcTune - = AbcTune - TuneHeader - TuneBody - deriving (Eq, Ord, Show) - -instance Pretty AbcTune where - pretty (AbcTune header elements) = mempty - <> pretty header <> "\n" - <> sepBy "\n" (fmap pretty elements) <> "\n" - - -data TuneHeader - = TuneHeader - [Information] - deriving (Eq, Ord, Show) - -instance Pretty TuneHeader where - pretty (TuneHeader info) = - sepBy "\n" (fmap pretty info) - - --- | Lines of music code. -type TuneBody - = [Music] --- TODO voices, see http://www.barfly.dial.pipex.com/multivoice.txt - - --------------------------------------------------------------------------------- - --- Music - - --- | One line of music code. -data Music - = Chord Chord - | Barline Barline - | Tie Music - | Slur Music - | Beam Music - | Grace Music - | Tuplet Duration Music - | Decorate Decoration Music - | Annotate Annotation Music - | ChordSymbol ChordSymbol Music - | Sequence [Music] -- beam? music - deriving (Eq, Ord, Show) - -instance Pretty Music where - pretty = go - where - go (Chord a) = pretty a - go (Sequence as) = sepBy " " $ fmap pretty as - -- FIXME - - -data Annotation - = AnnotateLeft String - | AnnotateRight String - | AnnotateAbove String - | AnnotateBelow String - | AnnotateUnspecified String - deriving (Eq, Ord, Show) - --- TODO clefs and transposition (4.6) --- TODO redifinable symbols (4.16) --- TODO symbol lines (4.15) --- TODO symbol lyrics - --- Note (4.20) -newtype Chord = Chord_ { getChord :: ( - [Pitch], - (Maybe Duration) - ) } - deriving (Eq, Ord, Show) - -instance Pretty Chord where - -- TODO skip duration if zero - pretty (Chord_ ([], dur)) = "" - pretty (Chord_ ([pitch], dur)) = - pretty pitch <> pretty dur - pretty (Chord_ (pitches, dur)) = - brackets (sepBy "" (fmap pretty pitches)) <> pretty dur - - -type ChordSymbol - = String - --- | Barline, including special barlines and repeats. -data Barline - = SingleBarline - | DoubleBarline Bool Bool -- thick? thick? - | Repeat Int Bool Bool -- times end? begin? - | DottedBarline Barline - | InvisibleBarline Barline - deriving (Eq, Ord, Show) - --- TODO first and second repeats (4.9) --- TODO variant endings (4.10) - - --- | Decorations (4.14) -data Decoration - = Trill -- "tr" (trill mark) - | TrillBegin -- start of an extended trill - | TrillEnd -- end of an extended trill - | Lowermordent -- short squiggle with a vertical line through it - | Uppermordent -- short squiggle - | Roll -- a roll mark (arc) as used in Irish music - | Turn -- a turn mark (also known as gruppetto) - | Turnx -- a turn mark with a line through it - | Invertedturn -- an inverted turn mark - | Invertedturnx -- an inverted turn mark with a line through it - | Arpeggio -- vertical squiggle - | Accent -- accent mark - | Fermata Bool -- fermata or hold (arc above dot), inverted? - | Tenuto -- horizontal line to indicate holding note for full duration - | Fingering Int -- fingerings - | Plus -- left-hand pizzicato, or rasp for French horns - | Snap -- snap-pizzicato mark, visually similar to !thumb! - | Slide -- slide up to a note, visually similar to a half slur - | Wedge -- small filled-in wedge mark - | Upbow -- V mark - | Downbow -- squared n mark - | Open -- small circle above note indicating open string or harmonic - | Thumb -- cello thumb symbol - | Breath -- a breath mark (apostrophe-like) after note - | Dynamic Dynamic -- Dynamics - | Crescendo -- start of a crescendo mark - | EndCrescendo -- end of a crescendo mark, placed after the last note - | Diminuendo -- start of a diminuendo mark - | EndDiminuendo -- end of a diminuendo mark, placed after the last note - | Segno -- ornate s-like symbols separated by a diagonal line - | Coda -- a ring with a cross in it - | DaSegno -- the letters D.S. (=Da Segno) - | DaCapo -- the letters D.C. (=either Da Coda or Da Capo) - | Dacoda -- the word "Da" followed by a Coda sign - | Fine -- the word "fine" - | Shortphrase -- vertical line on the upper part of the staff - | Mediumphrase -- same, but extending down to the centre line - | Longphrase -- same, but extending 3/4 of the way down - deriving (Eq, Ord, Show) - -data Dynamic - = PPPP - | PPP - | PP - | P_ - | MP - | MF - | F_ - | FF - | FFF - | FFFF - | SFZ - deriving (Eq, Ord, Show) - - --------------------------------------------------------------------------------- - --- Information - - --- | An information field (3). -data Information - = Area String - | Book String - | Composer String - | Discography String - | FileUrl String - | Group String - | History String - | Instruction Directive - | Key Key - | UnitNoteLength Duration - | Meter Meter - | Macro -- ^ Macro (not supported) - | Notes String -- ^ Notes - | Origin String -- ^ Origin of tune. - | Parts - | Tempo Tempo -- ^ Tempo of tune. - | Rhythm String -- ^ Rhythm type of tune. - | Remark -- ^ Remarks (not supported) - | Source String -- ^ Source material. - | SymbolLine - | Title String -- ^ Title of tune. - | UserDefined -- ^ User defined (not supported) - | Voice VoiceProperties - | Words String - | ReferenceNumber Integer - | Transcription String - deriving (Eq, Ord, Show) - -instance Pretty Information where - pretty a = string $ fieldName a ++ ": " ++ showField a - - -fieldName :: Information -> String -fieldName = go - where - go (Area _) = "A" - go (Book _) = "B" - go (Composer _) = "C" - go (Discography _) = "D" - go (FileUrl _) = "F" - go (Group _) = "G" - go (History _) = "H" - go (Instruction _) = "I" - go (Key _) = "K" - go (UnitNoteLength _) = "L" - go (Meter _) = "M" - go Macro = "m" - go (Notes _) = "N" - go (Origin _) = "O" - go Parts = "O" - go (Tempo _) = "Q" - go (Rhythm _) = "R" - go Remark = "r" - go (Source _) = "S" - go SymbolLine = "s" - go (Title _) = "T" - go UserDefined = "U" - go (Voice _) = "V" - go (Words _) = "W" - go (ReferenceNumber _) = "X" - go (Transcription _) = "Z" - --- (file header, tune header, tune body, inline) -fieldAllowed :: Information -> (Bool, Bool, Bool, Bool) -fieldAllowed = go - where - go (Area _) = (True, True, False, False) - go (Book _) = (True, True, False, False) - go (Composer _) = (True, True, False, False) - go (Discography _) = (True, True, False, False) - go (FileUrl _) = (True, True, False, False) - go (Group _) = (True, True, False, False) - go (History _) = (True, True, False, False) - - go (Instruction _) = (True, True, True, True) - go (Key _) = (False, True{-last-}, True, True) - go (UnitNoteLength _) = (True, True, True, True) - go (Meter _) = (True, True, True, True) - go Macro = (True, True, True, True) - go (Notes _) = (True, True, True, True) - - go (Origin _) = (True, True, False, False) - go Parts = (False, True, True, True) - go (Tempo _) = (False, True, True, True) - go (Rhythm _) = (True, True, True, True) - go Remark = (True, True, True, True) - - go (Source _) = (True, True, False, False) - go SymbolLine = (False, False, True, False) - go (Title _) = (False, True{-second-}, True, False) - - go UserDefined = (True, True, True, True) - go (Voice _) = (False, True, True, True) - go (Words _) = (False, True, True, False) - go (ReferenceNumber _) = (False, True{-first-}, True, False) - go (Transcription _) = (True, True, False, False) - -fieldAllowedInFileHeader a = r where (r,_,_,_) = fieldAllowed a -fieldAllowedInTuneHeader a = r where (_,r,_,_) = fieldAllowed a -fieldAllowedInTuneBody a = r where (_,_,r,_) = fieldAllowed a -fieldAllowedInline a = r where (_,_,_,r) = fieldAllowed a - -showField :: Information -> String -showField = go - where - go (Area a) = a - go (Book a) = a - go (Composer a) = a - go (Discography a) = a - go (FileUrl a) = a - go (Group a) = a - go (History a) = a - go (Instruction a) = show $ pretty a - go (Key a) = show $ pretty a - go (UnitNoteLength a) = show $ pretty a - go (Meter a) = show $ pretty a - go Macro = "" - go (Notes a) = a - go (Origin a) = a - go Parts = "" -- TODO - go (Tempo a) = show $ pretty a - go (Rhythm a) = a - go Remark = "" -- TODO - go (Source a) = a - go SymbolLine = "" -- TODO - go (Title a) = a - go UserDefined = "" -- TODO - go (Voice a) = show $ pretty a - go (Words a) = a - go (ReferenceNumber a) = show a - go (Transcription a) = a - - --------------------------------------------------------------------------------- - --- Base types - --- | Pitch (4.1, 4.2). -newtype Pitch = Pitch { getPitch :: (PitchClass, Maybe Accidental, Octave) } - deriving (Eq, Ord, Show) - -instance Pretty Pitch where - pretty (Pitch (cl, acc, oct)) = pretty acc <> (string $ - (if oct <= 0 then id else fmap toLower) (show cl) - ++ replicate (negate (fromIntegral oct) `max` 0) ',' - ++ replicate (fromIntegral (oct - 1) `max` 0) '\'') - --- | Pitch class (4.1). -data PitchClass = C | D | E | F | G | A | B - deriving (Eq, Ord, Show, Enum, Bounded) - --- | Accidentals (4.2). -data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp - deriving (Eq, Ord, Show, Enum, Bounded) - -instance Pretty Accidental where - pretty = go - where - go DoubleFlat = "__" - go Flat = "_" - go Natural = "=" - go Sharp = "^" - go DoubleSharp = "^^" - --- | Octaves (4.1). -newtype Octave = Octave { getOctave :: Int } - deriving (Eq, Ord, Show, Enum, Num, Real, Integral) - - - - - - --- | Duration (4.3). -newtype Duration = Duration { getDuration :: Rational } - deriving (Eq, Ord, Show, Enum, Num, Real, Fractional, RealFrac) - -instance Pretty Duration where - pretty = string . showRatio . getDuration - - -data Meter - = NoMeter - | Common - | Cut - | Simple Rational - | Compound [Integer] Integer - deriving (Eq, Ord, Show) - -instance Pretty Meter where - pretty = go - where - go Common = "C" - go Cut = "C|" - go (Simple a) = string $ showRatio a - go (Compound as a) = sepBy "+" (fmap integer as) <> "/" <> integer a - - - - - - - - -newtype Key = Key_ (Integer, Mode) - deriving (Eq, Ord, Show) - -instance Pretty Key where - pretty (Key_ (tonic, mode)) = prettyTonic tonic <+> pretty mode - where - prettyTonic a = case a of - 0 -> "C" - -data Mode - = Major - | Minor - | Ionian - | Dorian - | Phrygian - | Lydian - | Mixolydian - | Aeolian - | Locrian - deriving (Eq, Ord, Show) - -instance Pretty Mode where - pretty = go - where - go Major = "" - go Minor = "minor" - go Ionian = "ionian" - go Dorian = "dorian" - go Phrygian = "phrygian" - go Lydian = "lydian" - go Mixolydian = "mixolydian" - go Aeolian = "aeolian" - go Locrian = "locrian" - - - - --- | Optional string, numerators, frequency (3.1.8) -newtype Tempo = Tempo_ { getTempo :: (Maybe String, [Duration], Duration) } - deriving (Eq, Ord, Show) - -instance Pretty Tempo where - pretty (Tempo_ (str, durs, bpm)) = - pretty str <+> (hsep (fmap pretty durs) <> "=" <> pretty bpm) - -data VoiceProperties - = VoiceProperties - (Maybe String) - (Maybe String) - (Maybe StemDirection) - (Maybe Clef) - deriving (Eq, Ord, Show) - -instance Pretty VoiceProperties where - pretty _ = "{VoiceProperties}" - -- FIXME - -data StemDirection = Up | Down - deriving (Eq, Ord, Show, Enum, Bounded) - -data Clef = NoClef | Treble | Alto | Tenor | Bass | Perc - deriving (Eq, Ord, Show, Enum, Bounded) - - --- | Abc directive. -newtype Directive = Directive { getDirective :: (String, String) } - deriving (Eq, Ord, Show) - -instance Pretty Directive where - pretty _ = "{Directive}" - -- FIXME - - - --------------------------------------------------------------------------------- - --- Utility - -readAbc :: String -> AbcFile -readAbc = error "Not impl" - -showAbc :: AbcFile -> String -showAbc = error "Not impl" - - -showRatio :: (Integral a, Show a) => Ratio a -> String -showRatio x - | denominator x == 1 = show (numerator x) - | otherwise = (show $ numerator x) ++ "/" ++ (show $ denominator x) - diff --git a/src/Music/Abc/Parser.hs b/src/Music/Abc/Parser.hs deleted file mode 100644 --- a/src/Music/Abc/Parser.hs +++ /dev/null @@ -1,141 +0,0 @@ - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.Abc.Parser ( - parse - ) where - -import Data.Monoid -import Data.Either -import Control.Monad -import Control.Applicative hiding ((<|>), optional, many) - -import Text.Parsec hiding (parse) -import Text.Parsec.Token -import Text.Parsec.String - -import Music.Abc - --- TODO information field verification (header/body) - --- ## Limitations: --- --- * Limited support for *volatile* features --- * Limited support for text strings (§8.2) --- * No mnemonics --- * No entities --- * Unicode escapes are supported --- * No support for macros (§9) --- * No support for outdated syntax (§10) --- * Stylesheet directives are ignored (§11) --- * Typeset text is ignored (§2.2.3) --- * Strict interpretation assumed (§12) - - --- | --- Parse a module description, returning an error if unsuccessful. --- -parse :: String -> Either ParseError AbcFile -parse = runParser abcFile () "" - -------------------------------------------------------------------------------------- --- Parsers -------------------------------------------------------------------------------------- - -abcFile :: Parser AbcFile -abcFile = do - -- optional byteOrderMark - string "%abc" - optional $ string "-" >> version - optional $ fileHeader - fileBody - return undefined - -fileHeader :: Parser FileHeader -fileHeader = fmap (uncurry FileHeader . partitionEithers) $ many1 $ mzero - <|> fmap Left informationField - <|> fmap Right styleSheetDirective - -fileBody :: Parser [Element] -fileBody = (flip sepBy) emptyLine $ mzero - <|> fmap Tune abcTune - <|> fmap FreeText freeText - <|> fmap TypesetText typeSetText - -informationField :: Parser Information -informationField = do - letter - char ':' - -- TODO anything not \n - char '\n' - return undefined - --- Not parsed, see Limitations -styleSheetDirective :: Parser Directive -styleSheetDirective = mzero - -byteOrderMark :: Parser () -byteOrderMark = do - char '\xFFFE' <|> char '\xFEFF' - return () - -version :: Parser Double -version = undefined - -abcTune :: Parser AbcTune -abcTune = undefined - -freeText :: Parser String -freeText = undefined - --- Not parsed, see Limitations -typeSetText :: Parser String -typeSetText = mzero - - -------------------------------------------------------------------------------------- --- Lexer -------------------------------------------------------------------------------------- - -lexer :: TokenParser () -lexer = makeTokenParser $ LanguageDef { - commentStart = "[r:", - commentEnd = "]", - commentLine = "%", - nestedComments = False, - identStart = (letter <|> char '_'), - identLetter = (alphaNum <|> char '_'), - opStart = mzero, - opLetter = mzero, - reservedNames = reservedNames, - reservedOpNames = mzero, - caseSensitive = True - } - where - reservedNames = [] - --- Convenient synonyms, not exported -llex = lexeme lexer -lnat = natural lexer -lstr = stringLiteral lexer -lname = identifier lexer -lres = reserved lexer -lspace = whiteSpace lexer - -emptyLine = newLine >> newLine -newLine = string "\r\n" <|> string "\n" - -single x = [x] - -notSupported x = error $ "Not supported yet: " ++ x -