module Music.MusicXml.Write.Score (
) where
import Prelude hiding (getLine)
import Data.Maybe (maybeToList)
import Data.Semigroup
import Data.Default
import Numeric.Natural
import Text.XML.Light hiding (Line)
import Music.MusicXml.Score
import Music.MusicXml.Time
import Music.MusicXml.Pitch
import Music.MusicXml.Dynamics
import Music.MusicXml.Read
import Music.MusicXml.Write
import qualified Data.List as List
import qualified Data.Char as Char
instance WriteMusicXml Score where
write (Partwise attr
header
parts) = single
$ unode "score-partwise"
$ write header <> writePartwise parts
write (Timewise attr
header
measures) = single
$ unode "timewise-score"
$ write header <> writeTimewise measures
writePartwise :: [(PartAttrs, [(MeasureAttrs, Music)])] -> [Element]
writeTimewise :: [(MeasureAttrs, [(PartAttrs, Music)])] -> [Element]
writePartwise = fmap (\(attrs, measures) -> writePartElem attrs $
fmap (\(attrs, music) -> writeMeasureElem attrs $
writeMusic music) measures)
writeTimewise = fmap (\(attrs, parts) -> writeMeasureElem attrs $
fmap (\(attrs, music) -> writePartElem attrs $
writeMusic music) parts)
writePartElem attrs = addPartAttrs attrs . unode "part"
writeMeasureElem attrs = addMeasureAttrs attrs . unode "measure"
writeMusic = concatMap write . getMusic
addScoreAttrs :: ScoreAttrs -> Element -> Element
addPartAttrs :: PartAttrs -> Element -> Element
addMeasureAttrs :: MeasureAttrs -> Element -> Element
addScoreAttrs (ScoreAttrs []) = id
addScoreAttrs (ScoreAttrs xs) = addAttr (uattr "version" $ concatSep "." $ map show xs)
addPartAttrs (PartAttrs x) = addAttr (uattr "id" x)
addMeasureAttrs (MeasureAttrs n) = addAttr (uattr "number" $ show n)
instance WriteMusicXml ScoreHeader where
write (ScoreHeader title
mvm
ident
partList) = mempty <> writeTitle title
<> writeMvm mvm
<> writeIdent ident
<> writePartList partList
where {
writeTitle, writeMvm :: Maybe String -> [Element] ;
writeIdent :: Maybe Identification -> [Element] ;
writePartList :: PartList -> [Element] ;
writeTitle = fmap (unode "title") . maybeToList ;
writeMvm = fmap (unode "movement-title") . maybeToList ;
writeIdent = single . unode "identification" . (write =<<) . maybeToList ;
writePartList = single . unode "part-list" . (write =<<) . getPartList ;
}
instance WriteMusicXml Identification where
write (Identification creators) = map writeCreator creators
where
writeCreator (Creator t n) = unode "creator" (uattr "type" t, n)
instance WriteMusicXml PartListElem where
write (Part id
name
abbrev) = single
$ addAttr (uattr "id" id)
$ unode "score-part"
$ writeName name <> writeAbbrev abbrev
where
writeName = single . unode "part-name"
writeAbbrev = maybeToList . fmap (unode "part-abbreviation")
write (Group level
startStop
name
abbrev
symbol
barlines
time) = single
$ addAttr (uattr "number" $ show $ getLevel level)
$ addAttr (uattr "type" $ writeStartStop startStop)
$ unode "part-group"
$ mempty
<> writeName name
<> writeAbbrev abbrev
<> writeSymbol symbol
<> writeBarlines barlines
where
writeName = single . unode "group-name"
writeAbbrev = maybeToList . fmap (unode "group-abbreviation")
writeSymbol = maybeToList . fmap (unode "group-symbol" . writeGroupSymbol)
writeBarlines = maybeToList . fmap (unode "group-barline" . writeGroupBarlines)
writeGroupSymbol :: GroupSymbol -> String
writeGroupBarlines :: GroupBarlines -> String
instance WriteMusicXml MusicElem where
write (MusicAttributes x) = single $ unode "attributes" $ write x
write (MusicNote x) = single $ unode "note" $ write x
write (MusicDirection x) = single $ unode "direction" (unode "direction-type" $ write x)
write (MusicBackup d) = single $ unode "backup" (unode "duration" $show $ getDivs $ d)
write (MusicForward d) = single $ unode "forward" (unode "duration" $show $ getDivs $ d)
instance WriteMusicXml Attributes where
write (Divisions divs) = single $ unode "divisions"
$ show $ getDivs divs
write (Clef sign line) = single $ unode "clef"
[ unode "sign" (writeClef sign),
unode "line" (show $ getLine line)]
write (Key fifths mode) = single $ unode "key"
[ unode "fifths" (show $ getFifths fifths),
unode "mode" (writeMode mode)]
write (Time (CommonTime)) = single $ addAttr (uattr "symbol" "common")
$ unode "time"
[ unode "beats" (show 4),
unode "beat-type" (show 4)]
write (Time (CutTime)) = single $ addAttr (uattr "symbol" "cut")
$ unode "time"
[ unode "beats" (show 2),
unode "beat-type" (show 2) ]
write (Time (DivTime beats beatType)) = single $ unode "time"
[ unode "beats" (show $ getBeat beats),
unode "beat-type" (show $ getBeatType beatType)]
instance WriteMusicXml NoteProps where
write (NoteProps
instrument
voice
typ
dots
accidental
timeMod
stem
noteHead
noteHeadText
staff
beam
notations
lyrics)
= mempty
<> maybeOne (\n -> unode "voice" $ show n) voice
<> maybeOne (\(noteVal, noteSize) -> unode "type" (writeNoteVal noteVal)) typ
<> replicate (fromIntegral dots) (unode "dot" ())
<> maybeOne (\(m, n) -> unode "time-modification" [
unode "actual-notes" (show m),
unode "normal-notes" (show n)
]) timeMod
<> maybeOne (\(nh,_,_) -> unode "notehead" (writeNoteHead nh)) noteHead
<> maybeOne (\(n, typ) -> addAttr (uattr "number" $ show $ getLevel n)
$ unode "beam" $ writeBeamType typ) beam
<> case notations of
[] -> []
ns -> [unode "notations" (concatMap write ns)]
instance WriteMusicXml FullNote where
write (Pitched isChord
(steps, alter, octaves)) = mempty
<> singleIf isChord (unode "chord" ())
<> single (unode "pitch" (mempty
<> single ((unode "step" . show) steps)
<> maybeOne (unode "alter" . show . getSemitones) alter
<> single ((unode "octave" . show . getOctaves) octaves)))
write (Unpitched isChord
Nothing) = mempty
<> singleIf isChord (unode "chord" ())
<> single (unode "unpitched" ())
write (Unpitched isChord
(Just (steps, octaves))) = mempty
<> singleIf isChord (unode "chord" ())
<> single (unode "unpitched" (mempty
<> single ((unode "display-step" . show) steps)
<> single ((unode "display-octave" . show . getOctaves) octaves)))
write (Rest isChord
Nothing) = mempty
<> singleIf isChord (unode "chord" ())
<> single (unode "rest" ())
write (Rest isChord
(Just (steps, octaves))) = mempty
<> singleIf isChord (unode "chord" ())
<> single (unode "rest" (mempty
<> single ((unode "display-step" . show) steps)
<> single ((unode "display-octave" . show . getOctaves) octaves)))
instance WriteMusicXml Note where
write (Note full
dur
ties
props) = write full <> writeDuration dur
<> concatMap writeTie ties
<> write props
write (CueNote full
dur
props) = [unode "cue" ()] <> write full
<> writeDuration dur
<> write props
write (GraceNote full
ties
props) = [unode "grace" ()] <> write full
<> concatMap writeTie ties
<> write props
writeDuration :: Duration -> [Element]
writeDuration = single . unode "duration" . show . getDivs
writeTie :: Tie -> [Element]
writeTie typ = single $ addAttr (uattr "type" $ writeStartStopContinue typ) $ unode "tie" ()
instance WriteMusicXml Notation where
write (Tied typ) = single
$ addAttr (uattr "type" $ writeStartStopContinue typ)
$ unode "tied" ()
write (Slur level typ) = single
$ addAttr (uattr "number" $ show $ getLevel level)
$ addAttr (uattr "type" $ writeStartStopContinue typ)
$ unode "slur" ()
write (Tuplet level typ) = single
$ addAttr (uattr "number" $ show $ getLevel level)
$ addAttr (uattr "type" $ writeStartStopContinue typ)
$ unode "tuplet" ()
write (Glissando level typ lineTyp text) = single
$ addAttr (uattr "number" $ show $ getLevel level)
$ addAttr (uattr "type" $ writeStartStopContinue typ)
$ addAttr (uattr "line-type" $ writeLineType lineTyp)
$ case text of
Nothing -> unode "glissando" ()
Just text -> unode "glissando" text
write (Slide level typ lineTyp text) = single
$ addAttr (uattr "number" $ show $ getLevel level)
$ addAttr (uattr "type" $ writeStartStopContinue typ)
$ addAttr (uattr "line-type" $ writeLineType lineTyp)
$ case text of
Nothing -> unode "slide" ()
Just text -> unode "slide" text
write (Ornaments xs) = single $ unode "ornaments" (concatMap writeOrnamentWithAcc xs)
where
writeOrnamentWithAcc (o, as) = write o
<> fmap (unode "accidental-mark" . writeAccidental) as
write (Technical xs) = single $ unode "technical" (concatMap write xs)
write (Articulations xs) = single $ unode "articulations" (concatMap write xs)
write (DynamicNotation dyn) = single $ unode "dynamics" (writeDynamics dyn)
write (Fermata sign) = single $ unode "fermata" (writeFermataSign sign)
write Arpeggiate = single $ unode "arpeggiate" ()
write NonArpeggiate = single $ unode "non-arpeggiate" ()
write (AccidentalMark acc) = single $ unode "accidental-mark" (writeAccidental acc)
write (OtherNotation not) = notImplemented "OtherNotation"
instance WriteMusicXml Ornament where
write TrillMark = single $ unode "trill-mark" ()
write Turn = single $ unode "turn" ()
write DelayedTurn = single $ unode "delayed-turn" ()
write InvertedTurn = single $ unode "inverted-turn" ()
write DelayedInvertedTurn = single $ unode "delayed-inverted-turn" ()
write VerticalTurn = single $ unode "vertical-turn" ()
write Shake = single $ unode "shake" ()
write WavyLine = single $ unode "wavyline" ()
write Mordent = single $ unode "mordent" ()
write InvertedMordent = single $ unode "inverted-mordent" ()
write Schleifer = single $ unode "schleifer" ()
write (Tremolo num) = single $ unode "tremolo" (show num)
instance WriteMusicXml Technical where
write UpBow = single $ unode "up-bow" ()
write DownBow = single $ unode "down-bow" ()
write Harmonic = single $ unode "harmonic" ()
write OpenString = single $ unode "openstring" ()
write ThumbPosition = single $ unode "thumb-position" ()
write Fingering = single $ unode "fingering" ()
write Pluck = single $ unode "pluck" ()
write DoubleTongue = single $ unode "double-tongue" ()
write TripleTongue = single $ unode "triple-tongue" ()
write Stopped = single $ unode "stopped" ()
write SnapPizzicato = single $ unode "snap-pizzicato" ()
write Fret = single $ unode "fret" ()
write String = single $ unode "string" ()
write HammerOn = single $ unode "hammer-on" ()
write PullOff = single $ unode "pull-off" ()
write Bend = single $ unode "bend" ()
write Tap = single $ unode "tap" ()
write Heel = single $ unode "heel" ()
write Toe = single $ unode "toe" ()
write Fingernails = single $ unode "fingernails" ()
write Hole = single $ unode "hole" ()
write Arrow = single $ unode "arrow" ()
write Handbell = single $ unode "handbell" ()
write (OtherTechnical tech) = notImplemented "OtherTechnical"
instance WriteMusicXml Articulation where
write Accent = single $ unode "accent" ()
write StrongAccent = single $ unode "strong-accent" ()
write Staccato = single $ unode "staccato" ()
write Tenuto = single $ unode "tenuto" ()
write DetachedLegato = single $ unode "detached-legato" ()
write Staccatissimo = single $ unode "staccatissimo" ()
write Spiccato = single $ unode "spiccato" ()
write Scoop = single $ unode "scoop" ()
write Plop = single $ unode "plop" ()
write Doit = single $ unode "doit" ()
write Falloff = single $ unode "falloff" ()
write BreathMark = single $ unode "breathmark" ()
write Caesura = single $ unode "caesura" ()
write Stress = single $ unode "stress" ()
write Unstress = single $ unode "unstress" ()
write OtherArticulation = notImplemented "OtherArticulation"
instance WriteMusicXml Direction where
write (Rehearsal str) = single $ unode "rehearsal" str
write Segno = single $ unode "segno" ()
write (Words str) = single $ unode "words" str
write Coda = single $ unode "coda" ()
write (Crescendo Start) = single $ addAttr (uattr "type" "crescendo") $ unode "wedge" ()
write (Diminuendo Start) = single $ addAttr (uattr "type" "diminuendo") $ unode "wedge" ()
write (Crescendo Stop) = single $ addAttr (uattr "type" "stop") $ unode "wedge" ()
write (Diminuendo Stop) = single $ addAttr (uattr "type" "stop") $ unode "wedge" ()
write (Dynamics dyn) = single $ unode "dynamics" (writeDynamics dyn)
write (Metronome noteVal dotted tempo) = single $ unode "metronome" $
[ unode "beat-unit" (writeNoteVal noteVal) ]
<> singleIf dotted (unode "beat-unit-dot" ())
<> [ unode "per-minute" (show $ round $getTempo tempo) ]
write Bracket = notImplemented "Unsupported directions"
write (OtherDirection dir) = notImplemented "OtherDirection"
instance WriteMusicXml Lyric where
write = notImplemented "WriteMusicXml instance for Lyric"
writeBeamType BeginBeam = "begin"
writeBeamType ContinueBeam = "continue"
writeBeamType EndBeam = "end"
writeBeamType ForwardHook = "forward-hook"
writeBeamType BackwardHook = "backward-hook"
writeStartStop = writeStartStopContinueChange
writeStartStopChange = writeStartStopContinueChange
writeStartStopContinue = writeStartStopContinueChange
writeStartStopContinueChange Start = "start"
writeStartStopContinueChange Stop = "stop"
writeStartStopContinueChange Continue = "continue"
writeStartStopContinueChange Change = "change"
writeStemDirection StemDown = "down"
writeStemDirection StemUp = "up"
writeStemDirection StemNone = "none"
writeStemDirection StemDouble = "double"
writeLineType Solid = "solid"
writeLineType Dashed = "dashed"
writeLineType Dotted = "dotted"
writeLineType Wavy = "wavy"
writeNoteHead SlashNoteHead = "slash"
writeNoteHead TriangleNoteHead = "triangle"
writeNoteHead DiamondNoteHead = "diamond"
writeNoteHead SquareNoteHead = "square"
writeNoteHead CrossNoteHead = "cross"
writeNoteHead XNoteHead = "x"
writeNoteHead CircleXNoteHead = "circle"
writeNoteHead InvertedTriangleNoteHead = "inverted-triangle"
writeNoteHead ArrowDownNoteHead = "arrow-down"
writeNoteHead ArrowUpNoteHead = "arrow-up"
writeNoteHead SlashedNoteHead = "slashed"
writeNoteHead BackSlashedNoteHead = "back-slashed"
writeNoteHead NormalNoteHead = "normal"
writeNoteHead ClusterNoteHead = "cluster"
writeNoteHead CircleDotNoteHead = "circle"
writeNoteHead LeftTriangleNoteHead = "left-triangle"
writeNoteHead RectangleNoteHead = "rectangle"
writeNoteHead NoNoteHead = "none"
writeAccidental DoubleFlat = "double-flat"
writeAccidental Flat = "flat"
writeAccidental Natural = "natural"
writeAccidental Sharp = "sharp"
writeAccidental DoubleSharp = "double-sharp"
writeNoteVal :: NoteVal -> String
writeNoteVal (NoteVal x)
| x == (1/1024) = "1024th"
| x == (1/512) = "512th"
| x == (1/256) = "256th"
| x == (1/128) = "128th"
| x == (1/64) = "64th"
| x == (1/32) = "32nd"
| x == (1/16) = "16th"
| x == (1/8) = "eighth"
| x == (1/4) = "quarter"
| x == (1/2) = "half"
| x == (1/1) = "whole"
| x == (2/1) = "breve"
| x == (4/1) = "long"
| x == (8/1) = "maxima"
| otherwise = error $ "Music.MusicXml.Write.Score.wrietNoteVal: Invalid note value:" ++ show x
writeClef :: ClefSign -> String
writeClef GClef = "G"
writeClef CClef = "C"
writeClef FClef = "F"
writeClef PercClef = "percussion"
writeClef TabClef = "tab"
writeMode :: Mode -> String
writeMode NoMode = "none"
writeMode x = toLowerString . show $ x
writeGroupSymbol GroupBrace = "brace"
writeGroupSymbol GroupLine = "line"
writeGroupSymbol GroupBracket = "bracket"
writeGroupSymbol GroupSquare = "square"
writeGroupSymbol NoGroupSymbol = "none"
writeGroupBarlines GroupBarLines = "yes"
writeGroupBarlines GroupNoBarLines = "no"
writeGroupBarlines GroupMensurstrich = "Mensurstrich"
writeFermataSign NormalFermata = "normal"
writeFermataSign AngledFermata = "angled"
writeFermataSign SquaredFermata = "squared"
writeDynamics x = unode (toLowerString $ show x) ()
addAttr :: Attr -> Element -> Element
addAttrs :: [Attr] -> Element -> Element
addAttr = add_attr
addAttrs = add_attrs
uattr :: String -> String -> Attr
uattr n = Attr (unqual n)
sep :: a -> [a] -> [a]
sep = List.intersperse
concatSep :: [a] -> [[a]] -> [a]
concatSep x = concat . sep x
toUpperChar :: Char -> Char
toUpperChar = Char.toUpper
toLowerChar :: Char -> Char
toLowerChar = Char.toLower
toUpperString :: String -> String
toUpperString = fmap Char.toUpper
toLowerString :: String -> String
toLowerString = fmap Char.toLower
toCapitalString :: String -> String
toCapitalString [] = []
toCapitalString (x:xs) = toUpperChar x : toLowerString xs
one :: (a -> b) -> a -> [b]
one f = single . f
maybeOne :: (a -> b) -> Maybe a -> [b]
maybeOne f = maybeToList . fmap f
single :: a -> [a]
single = return
fromSingle :: [a] -> a
fromSingle [x] = x
fromSingle _ = error "fromSingle: non-single list"
singleIf :: Bool -> a -> [a]
singleIf p x | not p = []
| otherwise = [x]
notImplemented x = error $ "Not implemented: " ++ x