{-# 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 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)
-- | 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)
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
-- 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"
--------------------------------------------------------------------------------
-- 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)