abcnotation-1.6.1: src/Music/Abc.hs
{-# 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)