abcnotation 1.8.1 → 1.9.0

raw patch · 5 files changed

+737/−737 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• abcnotation.cabal +3/−3
• src/Data/Music/Abc.hs +593/−0
• src/Data/Music/Abc/Parser.hs +141/−0
• src/Music/Abc.hs +0/−593
• src/Music/Abc/Parser.hs +0/−141

@@ -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,

@@ -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 <http://abcnotation.com>.+--+-------------------------------------------------------------------------------------++-- 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)+

@@ -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+                                                         

@@ -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 <http://abcnotation.com>.--------------------------------------------------------------------------------------------- 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)-

@@ -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-