module Music.Abc (
AbcFile(..),
FileHeader(..),
Element(..),
AbcTune(..),
TuneHeader(..),
TuneBody(..),
Music(..),
Chord(..),
Barline(..),
Annotation(..),
ChordSymbol(..),
Decoration(..),
Dynamic(..),
Duration(..),
Meter(..),
Tempo(..),
PitchClass(..),
Accidental(..),
Octave(..),
Pitch(..),
Key(..),
StemDirection(..),
Clef(..),
Mode(..),
Information(..),
Directive(..),
VoiceProperties(..),
readAbc,
showAbc
) where
import Data.Maybe
import Data.Ratio
import Data.Char
import Data.Semigroup
import Text.Pretty hiding (Mode)
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"
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)
data Element
= Tune
AbcTune
| FreeText
String
| TypesetText
String
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)
type TuneBody
= [Music]
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]
deriving (Eq, Ord, Show)
instance Pretty Music where
pretty = go
where
go (Chord a) = pretty a
data Annotation
= AnnotateLeft String
| AnnotateRight String
| AnnotateAbove String
| AnnotateBelow String
| AnnotateUnspecified String
deriving (Eq, Ord, Show)
newtype Chord = Chord_ { getChord :: (
[Pitch],
(Maybe Duration)
) }
deriving (Eq, Ord, Show)
instance Pretty Chord where
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
data Barline
= SingleBarline
| DoubleBarline Bool Bool
| Repeat Int Bool Bool
| DottedBarline Barline
| InvisibleBarline Barline
deriving (Eq, Ord, Show)
data Decoration
= Trill
| TrillBegin
| TrillEnd
| Lowermordent
| Uppermordent
| Roll
| Turn
| Turnx
| Invertedturn
| Invertedturnx
| Arpeggio
| Accent
| Fermata Bool
| Tenuto
| Fingering Int
| Plus
| Snap
| Slide
| Wedge
| Upbow
| Downbow
| Open
| Thumb
| Breath
| Dynamic Dynamic
| Crescendo
| EndCrescendo
| Diminuendo
| EndDiminuendo
| Segno
| Coda
| DaSegno
| DaCapo
| Dacoda
| Fine
| Shortphrase
| Mediumphrase
| Longphrase
deriving (Eq, Ord, Show)
data Dynamic
= PPPP
| PPP
| PP
| P_
| MP
| MF
| F_
| FF
| FFF
| FFFF
| SFZ
deriving (Eq, Ord, Show)
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
| Notes String
| Origin String
| Parts
| Tempo Tempo
| Rhythm String
| Remark
| Source String
| SymbolLine
| Title String
| UserDefined
| 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"
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, 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, True, False)
go UserDefined = (True, True, True, True)
go (Voice _) = (False, True, True, True)
go (Words _) = (False, True, True, False)
go (ReferenceNumber _) = (False, True, 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 = ""
go (Tempo a) = show $ pretty a
go (Rhythm a) = a
go Remark = ""
go (Source a) = a
go SymbolLine = ""
go (Title a) = a
go UserDefined = ""
go (Voice a) = show $ pretty a
go (Words a) = a
go (ReferenceNumber a) = show a
go (Transcription a) = a
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) '\'')
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)
instance Pretty Accidental where
pretty = go
where
go DoubleFlat = "__"
go Flat = "_"
go Natural = "="
go Sharp = "^"
go DoubleSharp = "^^"
newtype Octave = Octave { getOctave :: Int }
deriving (Eq, Ord, Show, Enum, Num, Real, Integral)
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"
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}"
data StemDirection = Up | Down
deriving (Eq, Ord, Show, Enum, Bounded)
data Clef = NoClef | Treble | Alto | Tenor | Bass | Perc
deriving (Eq, Ord, Show, Enum, Bounded)
newtype Directive = Directive { getDirective :: (String, String) }
deriving (Eq, Ord, Show)
instance Pretty Directive where
pretty _ = "{Directive}"
readAbc :: String -> AbcFile
readAbc = error "Not impl"
showAbc :: AbcFile -> String
showAbc = error "Not impl"
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)