diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -9,14 +9,14 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of the nor the + * Neither the name of the Music Suite nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND diff --git a/abcnotation.cabal b/abcnotation.cabal --- a/abcnotation.cabal +++ b/abcnotation.cabal @@ -1,6 +1,6 @@ name: abcnotation -version: 0.5 +version: 1.6 cabal-version: >= 1.2 author: Hans Hoglund maintainer: Hans Hoglund @@ -21,7 +21,7 @@ library build-depends: - base >= 4 && < 5, + base >= 4 && < 5, semigroups, prettify, network, diff --git a/src/Music/Abc.hs b/src/Music/Abc.hs --- a/src/Music/Abc.hs +++ b/src/Music/Abc.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeOperators, OverloadedStrings, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- | @@ -11,16 +11,21 @@ -- Stability : experimental -- Portability : portable -- --- A Haskell representation and parser for ABC notation. Based on the 2.1 standard. --- +-- 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(..), + AbcFile(..), -- *** File header FileHeader(..), @@ -28,66 +33,89 @@ -- ** Tunes AbcTune(..), - TuneHeader(..), - TuneBody(..), + TuneHeader(..), + TuneBody(..), + ---------------------------------------------------------------------- + -- * Music Music(..), - - -- ** Note stack - Note(..), + Chord(..), + Barline(..), + Annotation(..), + ChordSymbol(..), + Decoration(..), + Dynamic(..), - DecorationT(..), - SlurT(..), - BeamT(..), - GraceT(..), - TupletT(..), - DurationT(..), - RestT(..), - (:|:), - - -- * Basic types -- ** Time Duration(..), + Meter(..), + Tempo(..), -- ** Pitch PitchClass(..), Accidental(..), Octave(..), Pitch(..), - - -- ** Decorations (articulation, dynamics etc) - Decoration(..), + Key(..), + StemDirection(..), + Clef(..), + Mode(..), - -- ** Structure - Barline(..), - MultiRest(..), + ---------------------------------------------------------------------- - -- ** Information etc + -- * Information Information(..), Directive(..), + VoiceProperties(..), + ---------------------------------------------------------------------- + -- * Import and export readAbc, showAbc ) where -import Network.URI (URI) +import Data.Maybe +import Data.Ratio +import Data.Char +import Data.Semigroup +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] + = 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 @@ -98,38 +126,112 @@ String -- ^ Typeset text (2.2.3). deriving (Eq, Ord, Show) -data AbcTune - = AbcTune - TuneHeader +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) --- TODO verify X, T and K fields -data TuneHeader - = TuneHeader +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) -type TuneBody = [Music] +instance Pretty TuneHeader where + pretty (TuneHeader info) = + sepBy "\n" (fmap pretty info) --- One line of music code. -data Music - = Music [Note :|: MultiRest :|: Barline :|: ()] + +-- | One line of music code. +type TuneBody + = [Music] + + +-------------------------------------------------------------------------------- + +-- 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) -newtype MultiRest = MultiRest { getMultiRest :: Int } +instance Pretty Music where + pretty = go + where + go (Chord a) = pretty a + -- 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 -type Note = DecorationT (SlurT (BeamT (GraceT (TupletT (DurationT (RestT Pitch)))))) +-- Note (4.20) +newtype Chord = Chord_ { getChord :: ( + [Pitch], + (Maybe Duration) + ) } + deriving (Eq, Ord, Show) -type DecorationT a = ([Decoration], a) -type SlurT a = (Bool, a, Bool) -type BeamT a = (Bool, a, Bool) -type GraceT a = (Bool, a) -type TupletT a = (Duration, a) -type DurationT a = (a, Duration) -type RestT a = Maybe (Maybe a) -- invisible/visible +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 @@ -155,9 +257,7 @@ | Open -- small circle above note indicating open string or harmonic | Thumb -- cello thumb symbol | Breath -- a breath mark (apostrophe-like) after note - -- !pppp! !ppp! !pp! !p! dynamics marks - -- !mp! !mf! !f! !ff! more dynamics marks - -- !fff! !ffff! !sfz! more dynamics marks + | 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 @@ -173,89 +273,209 @@ | Longphrase -- same, but extending 3/4 of the way down deriving (Eq, Ord, Show) - --- Base types - -newtype Duration = Duration { getDuration :: Rational } - deriving (Eq, Ord, Show, Enum, Num, Real, Fractional, RealFrac) - -data PitchClass = C | D | E | F | G | A | B - deriving (Eq, Ord, Show, Enum, Bounded) - -data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp - deriving (Eq, Ord, Show, Enum, Bounded) - -newtype Octave = Octave { getOctave :: Int } - deriving (Eq, Ord, Show, Enum, Num, Real, Integral) - -newtype Pitch = Pitch { getPitch :: (PitchClass, Accidental, Octave) } +data Dynamic + = PPPP + | PPP + | PP + | P_ + | MP + | MF + | F_ + | FF + | FFF + | FFFF + | SFZ deriving (Eq, Ord, Show) -data StemDirection = Up | Down - deriving (Eq, Ord, Show, Enum, Bounded) -data Clef = NoClef | Treble | Alto | Tenor | Bass | Perc - deriving (Eq, Ord, Show, Enum, Bounded) +-------------------------------------------------------------------------------- --- | Barline, including special barlines and repeats. -data Barline - = Barline - | DoubleBarline Bool Bool -- thick? thick? - | Repeat Int Bool Bool -- times end? begin? - | DottedBarline Barline - | InvisibleBarline Barline - deriving (Eq, Ord, Show) +-- Information --- TODO add elements + +-- | An information field (3). data Information = Area String | Book String | Composer String | Discography String - | FileUrl String URI + | 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) - | Meter Meter - -- Macros not supported - | Notes String - | Origin String - | Parts -- TODO +instance Pretty Information where + pretty a = string $ fieldName a ++ ": " ++ showField a - | Tempo Tempo - | Rhythm String -- Polska, marsch etc. - -- Remarks are discarded - | Source String -- Uppland etc. - | SymbolLine Symbol - | TuneTitle String - -- User defined not supported +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" - | Voice VoiceProps - | Words String -- TODO include separators - | ReferenceNumber Integer - | Transcription String - deriving (Eq, Ord, Show) +-- (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) -type Key = (PitchClass, Mode) +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 --- | Optional string, beats, frequency (3.1.8) -type Tempo = (Maybe String, [Duration], Duration) +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 + -type Symbol = () +-------------------------------------------------------------------------------- -data VoiceProps - = VoiceProps - (Maybe String) - (Maybe String) - (Maybe StemDirection) - (Maybe Clef) +-- 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 @@ -264,6 +484,30 @@ | 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 @@ -276,17 +520,142 @@ | 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. -type Directive = (String, String) - - +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" -infixr 5 :|: -type a :|: b = Either a b + +-------------------------------------------------------------------------------- + +-- Tests + +{- + + X:19004 + T:Silent Night + T:Stille Nacht! Heilige Nacht! + R:Air + C:Franz Xaver Gruber, 1818 + O:Austria + Z:Paul Hardy's Xmas Tunebook 2012 (see www.paulhardy.net). Creative Commons cc by-nc-sa licenced. + M:6/8 + L:1/8 + Q:3/8=60 + K:C + "C"G>A G E3|G>A G E2z|"G"d2 d B3|"C"c2 c G2z| + "F"A2 A c>B A|"C"G>A G E2z|"F"A2 A c>B A|"C"G>A G E2z| + "G7"d2 d f>d B|"C"c3 e2z|cGE "G7"G>F D|"C"C3-C3|] + W:Silent night, holy night + W:All is calm, all is bright + W:Round yon Virgin Mother and Child + W:Holy Infant so tender and mild + W:Sleep in heavenly peace + W:Sleep in heavenly peace + W: + W:(Josef Mohr, 1818, Trans by John Young, 1819) + +-} +test = AbcFile + (Just "1.2") + (Just $ FileHeader [ + Title "Collection" + ] []) + [ + Tune (AbcTune + (TuneHeader [ + ReferenceNumber 19004, + Title "Silent Night", + Title "Stille Nacht! Heilige Nacht!", + Rhythm "Air", + Composer "Franz Xaver Gruber, 1818", + Origin "Austria", + Source "Paul Hardy's Xmas Tunebook 2012", + Meter (Simple $ 6/8), + UnitNoteLength (1/8), + Tempo (Tempo_ (Just "Andante", [3/8], 60)), + Key (Key_ (0, Minor)), + + Words "Silent night, holy night", + Words "All is calm, all is bright", + Words "Round yon Virgin Mother and Child", + Words "Holy Infant so tender and mild", + Words "Sleep in heavenly peace", + Words "Sleep in heavenly peace" + ]) + [ + Chord (Chord_ ([(Pitch (C,Just Sharp,0))], Just 1)) + ]) + + ] + +main = (putStrLn . show . pretty) test + + + + + + +showRatio :: (Integral a, Show a) => Ratio a -> String +showRatio x + | denominator x == 1 = show (numerator x) + | otherwise = (show $ numerator x) ++ "/" ++ (show $ denominator x)