musicxml2 1.8.1 → 1.9.0
raw patch · 19 files changed
+2532/−2509 lines, 19 filesdep ~music-dynamics-literaldep ~music-pitch-literal
Dependency ranges changed: music-dynamics-literal, music-pitch-literal
Files
- musicxml2.cabal +12/−12
- src/Data/Music/MusicXml.hs +155/−0
- src/Data/Music/MusicXml/Dynamics.hs +67/−0
- src/Data/Music/MusicXml/Pitch.hs +119/−0
- src/Data/Music/MusicXml/Read.hs +17/−0
- src/Data/Music/MusicXml/Score.hs +607/−0
- src/Data/Music/MusicXml/Simple.hs +859/−0
- src/Data/Music/MusicXml/Time.hs +87/−0
- src/Data/Music/MusicXml/Write.hs +23/−0
- src/Data/Music/MusicXml/Write/Score.hs +586/−0
- src/Music/MusicXml.hs +0/−155
- src/Music/MusicXml/Dynamics.hs +0/−67
- src/Music/MusicXml/Pitch.hs +0/−119
- src/Music/MusicXml/Read.hs +0/−17
- src/Music/MusicXml/Score.hs +0/−606
- src/Music/MusicXml/Simple.hs +0/−845
- src/Music/MusicXml/Time.hs +0/−87
- src/Music/MusicXml/Write.hs +0/−23
- src/Music/MusicXml/Write/Score.hs +0/−578
musicxml2.cabal view
@@ -1,6 +1,6 @@ name: musicxml2-version: 1.8.1+version: 1.9.0 synopsis: A representation of the MusicXML format. author: Hans Hoglund maintainer: Hans Hoglund@@ -26,16 +26,16 @@ type-unary >= 0.2.16 && < 1.0, reverse-apply, xml,- music-pitch-literal == 1.8.1,- music-dynamics-literal == 1.8.1- exposed-modules: Music.MusicXml- Music.MusicXml.Time- Music.MusicXml.Pitch- Music.MusicXml.Dynamics- Music.MusicXml.Read- Music.MusicXml.Score- Music.MusicXml.Write- Music.MusicXml.Simple- other-modules: Music.MusicXml.Write.Score+ music-pitch-literal == 1.9.0,+ music-dynamics-literal == 1.9.0+ exposed-modules: Data.Music.MusicXml+ Data.Music.MusicXml.Time+ Data.Music.MusicXml.Pitch+ Data.Music.MusicXml.Dynamics+ Data.Music.MusicXml.Read+ Data.Music.MusicXml.Score+ Data.Music.MusicXml.Write+ Data.Music.MusicXml.Simple+ other-modules: Data.Music.MusicXml.Write.Score hs-source-dirs: src default-language: Haskell2010
+ src/Data/Music/MusicXml.hs view
@@ -0,0 +1,155 @@++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-- A Haskell representation of MusicXML.+-- You may want to use the "Data.Music.MusicXml.Simple" module to generate the representation.+--+-- For an introduction to MusicXML, see <http://www.makemusic.com/musicxml/tutorial>.+--+-------------------------------------------------------------------------------------++module Data.Music.MusicXml (++ -- * Score+ Score(..),+ ScoreHeader(..),+ Identification(..),+ Creator(..),+ Defaults(..),+ ScoreAttrs(..),+ PartAttrs(..),+ MeasureAttrs(..),++ -- ** Part list+ PartList(..),+ PartListElem(..),++ -- * Music+ Music(..),+ MusicElem(..),++ -- ** Attributes+ Attributes(..),+ TimeSignature(..),+ ClefSign(..),++ -- ** Notes+ Note(..),+ FullNote(..),+ IsChord,+ noChord,+ Tie(..),+ noTies,+ NoteProps(..),+ HasNoteProps(..),++ -- ** Notations+ Notation(..),+ Articulation(..),+ Ornament(..),+ Technical(..),++ -- ** Directions+ Direction(..),++ -- ** Lyrics+ Lyric(..),+++++ -- * Basic types++ -- ** Pitch+ Pitch(..),+ DisplayPitch(..),+ PitchClass,+ Semitones(..),+ noSemitones,++ Octaves(..),+ Fifths(..),+ Line(..),++ Mode(..),+ Accidental(..),++ -- ** Time+ Duration(..),+ NoteType(..),++ Divs(..),+ NoteVal(..),+ NoteSize(..),++ Beat(..),+ BeatType(..),+++ -- ** Dynamics+ Dynamics,+++ -----------------------------------------------------------------------------+ -- ** Misc++ StemDirection(..),+ NoteHead(..),+ LineType(..),++ Level(..),+ BeamType(..),+ StartStop(..),+ StartStopChange(..),+ StartStopContinue(..),+ StartStopContinueChange(..),+ + + -----------------------------------------------------------------------------+ -- * Import and export functions+ -----------------------------------------------------------------------------++ toXml,+ showXml++ ) where++import Text.XML.Light hiding (Line)++import Data.Music.MusicXml.Score+import Data.Music.MusicXml.Time+import Data.Music.MusicXml.Pitch+import Data.Music.MusicXml.Dynamics+import Data.Music.MusicXml.Read+import Data.Music.MusicXml.Write++import Data.Music.MusicXml.Write.Score++-- --------------------------------------------------------------------------------+-- Import and export functions+-- --------------------------------------------------------------------------------++-- |+-- Render a score as a MusicXML string.+showXml :: Score -> String+showXml = ppTopElement . toXml++-- |+-- Render a score as MusicXML.+toXml :: Score -> Element+toXml = fromSingle . write++-- --------------------------------------------------------------------------------++fromSingle :: [a] -> a+fromSingle [x] = x+fromSingle _ = error "fromSingle: non-single list"+
+ src/Data/Music/MusicXml/Dynamics.hs view
@@ -0,0 +1,67 @@++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-------------------------------------------------------------------------------------++module Data.Music.MusicXml.Dynamics (++ Dynamics(..)++ ) where++import Music.Dynamics.Literal++data Dynamics + = PPPPPP + | PPPPP + | PPPP + | PPP + | PP + | P + | MP + | MF + | F + | FF + | FFF + | FFFF + | FFFFF + | FFFFFF+ | SF + | SFP + | SFPP+ | FP + | RF + | RFZ + | SFZ + | SFFZ + | FZ+ deriving (Eq, Ord, Show, Enum, Bounded)++instance IsDynamics Dynamics where+ fromDynamics (DynamicsL (Just x, Nothing)) = case x of+ (-6.5) -> PPPPPP+ (-5.5) -> PPPPP+ (-4.5) -> PPPP+ (-3.5) -> PPP+ (-2.5) -> PP+ (-1.5) -> P+ (-0.5) -> MP+ 0.5 -> MF+ 1.5 -> F+ 2.5 -> FF+ 3.5 -> FFF+ 4.5 -> FFFF+ 5.5 -> FFFFF+ 6.5 -> FFFFFF+ fromDynamics _ = error "fromDynamics: Unsupported literal for MusicXml.Dynamics"+
+ src/Data/Music/MusicXml/Pitch.hs view
@@ -0,0 +1,119 @@++{-# LANGUAGE + GeneralizedNewtypeDeriving, + StandaloneDeriving, + TypeSynonymInstances, + FlexibleInstances #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-------------------------------------------------------------------------------------++module Data.Music.MusicXml.Pitch (++ Pitch(..),+ DisplayPitch(..),+ PitchClass(..),+ Semitones(..),+ noSemitones,++ Octaves(..),+ Fifths(..),+ Line(..),++ Mode(..),+ Accidental(..)++ ) where++import Music.Pitch.Literal++type Pitch = (PitchClass, Maybe Semitones, Octaves)+type DisplayPitch = (PitchClass, Octaves)++data Mode = Major | Minor + | Dorian | Phrygian | Lydian | Mixolydian + | Aeolian | Ionian | Locrian | NoMode++data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp++data PitchClass = C | D | E | F | G | A | B++newtype Semitones = Semitones { getSemitones :: Double } -- ^ Semitones, i.e 100 cent+newtype Octaves = Octaves { getOctaves :: Int } -- ^ Octaves, i.e. 1200 cent+newtype Fifths = Fifths { getFifths :: Int } -- ^ Number of fifths upwards relative to C (i.e. F is -1, G is 1)+newtype Line = Line { getLine :: Int } -- ^ Line number, from bottom (i.e. 1-5)+++noSemitones :: Maybe Semitones+noSemitones = Nothing++deriving instance Eq PitchClass+deriving instance Ord PitchClass+deriving instance Enum PitchClass+deriving instance Show PitchClass++deriving instance Eq Accidental+deriving instance Ord Accidental+deriving instance Enum Accidental++deriving instance Eq Mode+deriving instance Ord Mode+deriving instance Enum Mode+deriving instance Show Mode++deriving instance Eq Semitones+deriving instance Ord Semitones+deriving instance Num Semitones+deriving instance Enum Semitones+deriving instance Fractional Semitones++deriving instance Eq Octaves+deriving instance Ord Octaves+deriving instance Num Octaves+deriving instance Enum Octaves+deriving instance Real Octaves+deriving instance Integral Octaves++deriving instance Eq Fifths+deriving instance Ord Fifths+deriving instance Num Fifths+deriving instance Enum Fifths++deriving instance Eq Line+deriving instance Ord Line+deriving instance Num Line+deriving instance Enum Line++instance IsPitch Pitch where+ fromPitch (PitchL (pc, Nothing, oct)) = (toEnum pc, Nothing, fromIntegral oct)+ fromPitch (PitchL (pc, Just st, oct)) = (toEnum pc, Just $ fromRational $ toRational $ st, fromIntegral oct)++instance IsPitch DisplayPitch where+ fromPitch (PitchL (pc, _, oct)) = (toEnum pc, fromIntegral oct)++instance IsPitch Fifths where+ fromPitch (PitchL (pc, Nothing, _)) = pitchToFifths pc 0+ fromPitch (PitchL (pc, Just ac, _)) = pitchToFifths pc (round ac)++pitchToFifths 1 (-1) = (-4)+pitchToFifths 2 (-1) = (-3)+pitchToFifths 4 (-1) = (-6)+pitchToFifths 5 (-1) = (-5)+pitchToFifths 6 (-1) = (-2)+pitchToFifths 0 0 = 0+pitchToFifths 1 0 = 2+pitchToFifths 2 0 = 4+pitchToFifths 3 0 = (-1)+pitchToFifths 4 0 = 1+pitchToFifths 5 0 = 3+pitchToFifths 6 0 = 5+pitchToFifths 3 1 = 6
+ src/Data/Music/MusicXml/Read.hs view
@@ -0,0 +1,17 @@++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-------------------------------------------------------------------------------------++module Data.Music.MusicXml.Read (+ ) where++
+ src/Data/Music/MusicXml/Score.hs view
@@ -0,0 +1,607 @@++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-------------------------------------------------------------------------------------++module Data.Music.MusicXml.Score (++ -----------------------------------------------------------------------------+ -- * Score+ -----------------------------------------------------------------------------++ Score(..),+ ScoreHeader(..),+ Identification(..),+ Creator(..),+ Defaults(..),+ ScoreAttrs(..),+ PartAttrs(..),+ MeasureAttrs(..),++ -- ** Part list+ PartList(..),+ PartListElem(..),+ GroupSymbol(..),+ GroupBarlines(..),++ -----------------------------------------------------------------------------+ -- * Music+ -----------------------------------------------------------------------------++ Music(..),+ MusicElem(..),++ -----------------------------------------------------------------------------++ -- ** Attributes+ Attributes(..),+ TimeSignature(..),+ ClefSign(..),++ -----------------------------------------------------------------------------+ -- ** Notes++ Note(..),+ FullNote(..),+ IsChord,+ noChord,+ noTies,+ Tie,+ NoteProps(..),+ HasNoteProps(..),++ -----------------------------------------------------------------------------+ -- ** Notations++ Notation(..),+ FermataSign(..),+ Articulation(..),+ Ornament(..),+ Technical(..),++ -----------------------------------------------------------------------------+ -- ** Directions++ Direction(..),++ -----------------------------------------------------------------------------+ -- ** Lyrics++ Lyric(..),+++ -----------------------------------------------------------------------------+ -- * Basic types+ -----------------------------------------------------------------------------++ -----------------------------------------------------------------------------+ -- ** Pitch++ Pitch(..),+ DisplayPitch(..),+ PitchClass,+ Semitones(..),+ noSemitones,++ Octaves(..),+ Fifths(..),+ Line(..),++ Mode(..),+ Accidental(..),++ -----------------------------------------------------------------------------+ -- ** Time++ Duration(..),+ NoteType(..),++ Divs(..),+ NoteVal(..),+ NoteSize(..),++ Beat(..),+ BeatType(..),++ -----------------------------------------------------------------------------+ -- ** Dynamics++ Dynamics(..),++ -----------------------------------------------------------------------------+ -- ** Misc++ StemDirection(..),+ NoteHead(..),+ LineType(..),++ Level(..),+ BeamType(..),+ StartStop(..),+ StartStopChange(..),+ StartStopContinue(..),+ StartStopContinueChange(..),++ ) where++import Prelude hiding (getLine)++import Data.Default+import Data.Semigroup+import Data.Foldable+import Numeric.Natural+import TypeUnary.Nat++import Data.Music.MusicXml.Time+import Data.Music.MusicXml.Pitch+import Data.Music.MusicXml.Dynamics++import qualified Data.List as List++-- ----------------------------------------------------------------------------------+-- Score+-- ----------------------------------------------------------------------------------++data Score+ = Partwise+ ScoreAttrs+ ScoreHeader+ [(PartAttrs,+ [(MeasureAttrs, Music)])] -- music by part and time+ | Timewise+ ScoreAttrs+ ScoreHeader+ [(MeasureAttrs,+ [(PartAttrs, Music)])] -- music by time and part++data ScoreHeader+ = ScoreHeader+ (Maybe String) -- title+ (Maybe String) -- movement title+ (Maybe Identification) -- identification?+ -- defaults?+ -- credit*+ PartList -- partlist?+++data Identification+ = Identification+ [Creator] -- creator++data Creator+ = Creator+ String -- type (composer, lyricist, arranger etc)+ String -- name++data Defaults+ = Defaults+ -- page layout (marigins, distance etc)+ -- system layout+ -- staff layout+ -- scaling+ -- appearance (line width etc)++data ScoreAttrs+ = ScoreAttrs+ [Int] -- score version++data PartAttrs+ = PartAttrs+ String -- part id++data MeasureAttrs+ = MeasureAttrs+ Int -- measure number+++-- ----------------------------------------------------------------------------------+-- Part list+-- ----------------------------------------------------------------------------------++newtype PartList = PartList { getPartList :: [PartListElem] }++instance Default PartList where+ def = PartList []++instance Semigroup PartList where+ PartList xs <> PartList ys = PartList (setIds $ xs <> ys)+ where+ setIds = snd . List.mapAccumL setId partIds+ setId id (Part _ name abbr dname dabbrev) = (tail id, Part (head id) name abbr dname dabbrev)+ setId id x = (id, x)++ partIds = [ "P" ++ show n | n <- [1..] ]++instance Monoid PartList where+ mempty = def+ mappend = (<>)++data PartListElem+ = Part+ String+ String+ (Maybe String)+ (Maybe String)+ (Maybe String) -- id name abbrev? name-display? abbrev-display?+ | Group + Level + StartStop+ String+ (Maybe String)+ (Maybe GroupSymbol)+ (Maybe GroupBarlines)+ Bool -- number start/stop name abbrev? symbol barline style++data GroupSymbol = GroupBrace | GroupLine | GroupBracket | GroupSquare | NoGroupSymbol+data GroupBarlines = GroupBarLines | GroupNoBarLines | GroupMensurstrich++-- ----------------------------------------------------------------------------------+-- Music+-- ----------------------------------------------------------------------------------++newtype Music = Music { getMusic :: [MusicElem] }+ deriving (Semigroup, Monoid)++data MusicElem+ = MusicAttributes+ Attributes+ | MusicBackup+ Duration+ | MusicForward+ Duration+ | MusicNote+ Note+ | MusicDirection+ Direction+ | MusicHarmony -- TODO+ | MusicFiguredBass -- TODO+ | MusicPrint -- TODO+ | MusicSound -- TODO+ | MusicBarline -- TODO+ | MusicGrouping -- TODO+ | MusicLink -- TODO+ | MusicBookmark -- TODO+++-- ----------------------------------------------------------------------------------+-- Attributes+-- ----------------------------------------------------------------------------------++data Attributes+ = Divisions+ Divs+ | Key+ Fifths+ Mode+ | Time+ TimeSignature+ | Staves+ Natural+ | PartSymbol -- TODO+ | Instruments+ Natural+ | Clef+ ClefSign+ Line+ | StaffDetails -- TODO+ | Transpose -- TODO+ | Directive -- TODO+ | MeasureStyle -- TODO++data TimeSignature+ = CommonTime+ | CutTime+ | DivTime+ Beat+ BeatType++data ClefSign+ = GClef+ | CClef+ | FClef+ | PercClef+ | TabClef+ deriving (Eq, Ord, Enum, Bounded)+++-- ----------------------------------------------------------------------------------+-- Notes+-- ----------------------------------------------------------------------------------++data Note+ = Note+ FullNote+ Duration+ [Tie]+ NoteProps+ | CueNote+ FullNote+ Duration+ NoteProps+ | GraceNote+ FullNote+ [Tie]+ NoteProps++data FullNote+ = Pitched+ IsChord+ Pitch+ | Unpitched+ IsChord+ (Maybe DisplayPitch)+ | Rest+ IsChord+ (Maybe DisplayPitch)++type IsChord = Bool+type Tie = StartStop++data NoteProps+ = NoteProps {+ noteInstrument :: Maybe String, -- instrument+ noteVoice :: Maybe Natural, -- voice+ noteType :: Maybe NoteType, -- type+ noteDots :: Natural, -- dots+ noteAccidental :: Maybe (Accidental, Bool, Bool), -- accidental, cautionary, editorial+ noteTimeMod :: Maybe (Natural, Natural), -- actual, normal+ noteStem :: Maybe StemDirection, -- stem+ noteNoteHead :: Maybe (NoteHead, Bool, Bool), -- notehead, filled, parentheses+ noteNoteHeadText :: Maybe String, -- notehead-text+ noteStaff :: Maybe Natural, -- staff+ noteBeam :: Maybe (Level, BeamType), -- beam-level, beam-type+ noteNotations :: [Notation], -- notation+ noteLyrics :: [Lyric] -- lyric+ }++noChord :: IsChord+noChord = False++noTies :: [Tie]+noTies = []+++class HasNoteProps a where+ modifyNoteProps :: (NoteProps -> NoteProps) -> a -> a+ ++instance HasNoteProps Note where+ modifyNoteProps f (Note x d t p) = Note x d t (f p)+ modifyNoteProps f (CueNote x d p) = CueNote x d (f p)+ modifyNoteProps f (GraceNote x t p) = GraceNote x t (f p)++instance HasNoteProps MusicElem where+ modifyNoteProps f (MusicNote n) = MusicNote (modifyNoteProps f n)+ modifyNoteProps f x = x++++-- ----------------------------------------------------------------------------------+-- Notations+-- ----------------------------------------------------------------------------------++data Notation+ = Tied+ StartStopContinue -- type+ | Slur+ Level+ StartStopContinue -- level start/stop+ | Tuplet+ Level+ StartStopContinue -- level start/stop+ | Glissando+ Level+ StartStopContinue+ LineType+ (Maybe String) -- level type start/stop text?+ | Slide+ Level+ StartStopContinue+ LineType+ (Maybe String) -- level type start/stop text?+ | Ornaments+ [(Ornament, [Accidental])]+ | Technical+ [Technical]+ | Articulations+ [Articulation]+ | DynamicNotation+ Dynamics+ | Fermata FermataSign+ | Arpeggiate+ | NonArpeggiate+ | AccidentalMark+ Accidental+ | OtherNotation+ String++data FermataSign = NormalFermata | AngledFermata | SquaredFermata++data Articulation+ = Accent + | StrongAccent + | Staccato + | Tenuto+ | DetachedLegato + | Staccatissimo + | Spiccato+ | Scoop + | Plop + | Doit + | Falloff + | BreathMark+ | Caesura + | Stress + | Unstress + | OtherArticulation++data Ornament+ = TrillMark + | Turn + | DelayedTurn + | InvertedTurn + | DelayedInvertedTurn + | VerticalTurn + | Shake + | WavyLine + | Mordent + | InvertedMordent + | Schleifer + | Tremolo + Natural -- TODO restrict to (1..8) range+ | OtherOrnament+ String+ +data Technical+ = UpBow + | DownBow + | Harmonic + | OpenString + | ThumbPosition + | Fingering + | Pluck + | DoubleTongue + | TripleTongue + | Stopped + | SnapPizzicato + | Fret + | String + | HammerOn + | PullOff + | Bend + | Tap + | Heel + | Toe + | Fingernails + | Hole + | Arrow + | Handbell + | OtherTechnical+ String++-- ----------------------------------------------------------------------------------+-- Directions+-- ----------------------------------------------------------------------------------++data Direction+ = Rehearsal+ String+ | Segno+ | Words+ String+ | Coda+ | Crescendo+ StartStop -- start/stop+ | Diminuendo+ StartStop -- start/stop+ | Dynamics+ Dynamics+ | Dashes+ Level+ StartStop -- level start/stop+ | Bracket -- TODO+ | Pedal+ StartStopChange+ | Metronome+ NoteVal+ Bool+ Tempo -- noteVal isDotted bpm + | OctaveShift -- TODO+ | HarpPedals -- TODO+ | Damp -- TODO+ | DampAll -- TODO+ | EyeGlasses -- TODO+ | StringMute -- TODO+ | Scordatura -- TODO+ | Image -- TODO+ | PrincipalVoice -- TODO+ | AccordionRegistration -- TODO+ | Percussion -- TODO+ | OtherDirection+ String+++-- ----------------------------------------------------------------------------------+-- Lyrics+-- ----------------------------------------------------------------------------------++data Lyric = Lyric -- TODO+++-- ----------------------------------------------------------------------------------+-- Basic types+-- ----------------------------------------------------------------------------------++newtype Level = Level { getLevel :: Max8 }++data BeamType+ = BeginBeam+ | ContinueBeam+ | EndBeam+ | ForwardHook+ | BackwardHook++type StartStop = StartStopContinueChange+type StartStopChange = StartStopContinueChange+type StartStopContinue = StartStopContinueChange++data StartStopContinueChange+ = Start+ | Stop+ | Continue + | Change++data StemDirection+ = StemDown+ | StemUp+ | StemNone+ | StemDouble++data LineType+ = Solid+ | Dashed+ | Dotted+ | Wavy++data NoteHead+ = SlashNoteHead+ | TriangleNoteHead+ | DiamondNoteHead+ | SquareNoteHead+ | CrossNoteHead+ | XNoteHead+ | CircleXNoteHead+ | InvertedTriangleNoteHead+ | ArrowDownNoteHead+ | ArrowUpNoteHead+ | SlashedNoteHead+ | BackSlashedNoteHead+ | NormalNoteHead+ | ClusterNoteHead+ | CircleDotNoteHead+ | LeftTriangleNoteHead+ | RectangleNoteHead+ | NoNoteHead -- "none"++deriving instance Eq Level+deriving instance Show Level+deriving instance Num Level++-- ----------------------------------------------------------------------------------++-- Bounded ints+type Max8 = Index N8++notImplemented x = error $ "Not implemented: " ++ x++
+ src/Data/Music/MusicXml/Simple.hs view
@@ -0,0 +1,859 @@++{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-- Provides smart constructors for the MusicXML representation.+--++-------------------------------------------------------------------------------------++module Data.Music.MusicXml.Simple (+ + module Data.Music.MusicXml,+ + -----------------------------------------------------------------------------+ -- * Score and parts+ -----------------------------------------------------------------------------++ -- ** Basic constructors+ fromPart,+ fromParts,++ -- ** Part lists+ partList,+ partListDisplay,+ partListAbbr,+ bracket,+ brace,+ + -- ** Measures+ measure,+ bar,++ -- -- ** Others+ -- standardPartAttributes,+ -- header,+ -- setHeader,+ -- setTitle,+ -- setMovementTitle,++ -----------------------------------------------------------------------------+ -- * Top-level attributes+ -----------------------------------------------------------------------------++ -- ** Pitch+ trebleClef,+ altoClef,+ bassClef,+ defaultClef,+ clef, + defaultKey,+ key,++ -- ** Time+ defaultDivisions,+ divisions, + commonTime,+ cutTime,+ time,+ staves,++ -- ** Tempo+ -- TODO #15 tempo+ metronome,+ metronome',+ + -----------------------------------------------------------------------------+ -- * Backup and forward+ -----------------------------------------------------------------------------++ backup,+ forward,++ -----------------------------------------------------------------------------+ -- * Notes+ -----------------------------------------------------------------------------+ + -- ** Basic constructors+ rest,+ note,+ chord,++ -- ** Voice+ setVoice,++ -- ** Duration+ dot,+ tuplet,+ setNoteVal,+ -- setTimeMod,+ -- beginTuplet,+ -- endTuplet,+ separateDots,++ -- ** Beams+ beam,+ beginBeam,+ continueBeam,+ endBeam,++ -- ** Ties+ beginTie,+ endTie,++ -- ** Note heads+ setNoteHead,++ -- ** Notations+ addNotation,++ -----------------------------------------------------------------------------+ -- * Pitch transformations+ -----------------------------------------------------------------------------+ + -- ** Glissando+ beginGliss,+ endGliss,++ -- ** Slides+ beginSlide,+ endSlide,++ -----------------------------------------------------------------------------+ -- * Time transformations+ -----------------------------------------------------------------------------++ -- ** Accelerando and ritardando+ -- TODO #16 accelerando,+ -- TODO #16 ritardando,++ -- ** Fermatas and breaks+ fermata,+ breathMark,+ caesura,++ -----------------------------------------------------------------------------+ -- * Articulation+ -----------------------------------------------------------------------------++ addTechnical,+ addArticulation,+ + -- ** Technical+ upbow,+ downbow,+ harmonic,+ openString,+ + -- ** Slurs+ slur,+ beginSlur,+ endSlur, + + -- ** Staccato and tenuto+ staccato,+ tenuto,+ spiccato,+ staccatissimo,++ -- ** Accents+ accent,+ strongAccent,++ -- ** Miscellaneous+ scoop,+ plop,+ doit,+ falloff,+ stress,+ unstress,+ + -- ** Ornaments+ trill,+ turn,+ shake,+ mordent,+ tremolo,++ -----------------------------------------------------------------------------+ -- * Dynamics+ -----------------------------------------------------------------------------++ -- ** Crescendo and diminuendo+ cresc,+ dim,+ beginCresc,+ endCresc,+ beginDim,+ endDim,++ -- ** Dynamic levels+ dynamic,++ -- ** Both+ crescFrom,+ crescTo,+ crescFromTo,+ dimFrom,+ dimTo,+ dimFromTo, ++ -----------------------------------------------------------------------------+ -- * Text+ -----------------------------------------------------------------------------++ text,+ rehearsal,+ segno,+ coda,++ -----------------------------------------------------------------------------+ -- * Folds and maps+ -----------------------------------------------------------------------------+ + -- mapNote,+ mapMusic,+ foldMusic,++ ) +where++import Data.Default+import Data.Ratio+import Data.Monoid+import Control.Arrow++import Data.Music.MusicXml+import Data.Music.MusicXml.Score+import Data.Music.MusicXml.Time+import Data.Music.MusicXml.Pitch+import Data.Music.MusicXml.Dynamics+import Data.Music.MusicXml.Read+import Data.Music.MusicXml.Write++import qualified Data.List as List++-- ----------------------------------------------------------------------------------+-- Score and parts+-- ----------------------------------------------------------------------------------++-- | +-- Create a single-part score.+--+-- > fromPart title composer partName measures+--+-- Example:+--+-- @ 'fromPart' \"Suite\" \"Bach\" \"Cello solo\" [] @+--+fromPart :: String -> String -> String -> [Music] -> Score+fromPart title composer partName music = + fromParts title composer (partList [partName]) [music]++-- | +-- Create a multi-part score.+--+-- > fromParts title composer partList parts+--+-- Example:+--+-- @ 'fromParts' \"4'33\" \"Cage\" ('partList' [\"Violin\", \"Viola\", \"Cello\"]) [[]] @+--+fromParts :: String -> String -> PartList -> [[Music]] -> Score+fromParts title composer partList music + = Partwise + (def)+ (header title composer partList)+ (addPartwiseAttributes music) ++-- | +-- Create a part list from instrument names.+--+partList :: [String] -> PartList+partList = PartList . zipWith (\partId name -> Part partId name Nothing Nothing Nothing) standardPartAttributes++-- | +-- Create a part list from instrument names and displayed names (some applications need the name to be something +-- specific, so use displayed name to override).+--+partListDisplay :: [(String, String)] -> PartList+partListDisplay = PartList . zipWith (\partId (name,dispName) -> Part partId name Nothing (Just dispName) Nothing) standardPartAttributes++-- | +-- Create a part list from instrument names and abbreviations.+--+partListAbbr :: [(String, String)] -> PartList+partListAbbr = PartList . zipWith (\partId (name,abbr) -> Part partId name (Just abbr) Nothing Nothing) standardPartAttributes++-- | +-- Enclose the given parts in a bracket.+-- +bracket :: PartList -> PartList+bracket ps = PartList $ mempty+ <> [Group 1 Start "" Nothing (Just GroupBracket) (Just GroupBarLines) False] + <> getPartList ps + <> [Group 1 Stop "" Nothing Nothing Nothing False]++-- | +-- Enclose the given parts in a brace.+-- +brace :: PartList -> PartList+brace ps = PartList $ mempty+ <> [Group 1 Start "" Nothing (Just GroupBrace) (Just GroupBarLines) False] + <> getPartList ps + <> [Group 1 Stop "" Nothing Nothing Nothing False]+++-- |+-- Convenient synonym for 'mconcat', allowing us to write things like+--+-- > measure [+-- > beam [ +-- > note c (1/8), +-- > note d (1/8),+-- > note e (1/8),+-- > note f (1/8) +-- > ],+-- > tuplet 3 2 [ +-- > note g (1/4),+-- > note a (1/4),+-- > note b (1/4) +-- > ]+-- > ]+-- +measure :: [Music] -> Music+measure = mconcat++-- |+-- Convenient synonym for 'mconcat'.+-- +bar :: [Music] -> Music+bar = measure+++header :: String -> String -> PartList -> ScoreHeader+header title composer partList = ScoreHeader Nothing (Just title) (Just (Identification [Creator "composer" composer])) partList++setHeader :: ScoreHeader -> Score -> Score+setHeader header (Partwise attrs _ music) = Partwise attrs header music+setHeader header (Timewise attrs _ music) = Timewise attrs header music++setTitle :: String -> ScoreHeader -> ScoreHeader+setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader (Just title) mvmTitle ident partList++setMovementTitle :: String -> ScoreHeader -> ScoreHeader+setMovementTitle mvmTitle (ScoreHeader title _ ident partList) = ScoreHeader title (Just mvmTitle) ident partList++-- | The values P1, P2... which are conventionally used to identify parts in MusicXML.+standardPartAttributes :: [String]+standardPartAttributes = [ "P" ++ show n | n <- [1..] ]++-- | Given a partwise score (list of parts, which are lists of measures), add part and measure attributes (numbers).+addPartwiseAttributes :: [[Music]] -> [(PartAttrs, [(MeasureAttrs, Music)])]+addPartwiseAttributes = deepZip partIds barIds+ where+ partIds = fmap PartAttrs standardPartAttributes+ barIds = fmap MeasureAttrs [1..]++ deepZip :: [a] -> [b] -> [[c]] -> [(a, [(b, c)])] + deepZip xs ys = zipWith (curry $ second (zip ys)) xs++-- ----------------------------------------------------------------------------------+-- Top-level attributes+-- ----------------------------------------------------------------------------------++trebleClef, altoClef, bassClef :: Music+trebleClef = clef GClef 2+altoClef = clef CClef 3+bassClef = clef FClef 4++defaultClef :: Music+defaultClef = trebleClef++-- |+-- Create a clef.+--+clef :: ClefSign -> Line -> Music+clef symbol line = Music . single $ MusicAttributes $ Clef symbol line++defaultKey :: Music+defaultKey = key 0 Major++-- |+-- Create a key signature.+--+key :: Fifths -> Mode -> Music+key n m = Music . single $ MusicAttributes $ Key n m+++-- Number of ticks per whole note (we use 768 per quarter like Sibelius).+defaultDivisionsVal :: Divs +defaultDivisionsVal = 768 * 4++-- |+-- Set the tick division to the default value.+--+defaultDivisions :: Music+defaultDivisions = Music $ single $ MusicAttributes $ Divisions $ defaultDivisionsVal `div` 4++-- |+-- Define the number of ticks per quarter note.+--+divisions :: Divs -> Music+divisions n = Music . single $ MusicAttributes $ Divisions $ n++commonTime, cutTime :: Music+commonTime = Music . single $ MusicAttributes $ Time CommonTime+cutTime = Music . single $ MusicAttributes $ Time CutTime++-- |+-- Create a time signature.+--+time :: Beat -> BeatType -> Music+time a b = Music . single $ MusicAttributes $ Time $ DivTime a b++staves :: Int -> Music+staves n = Music $ single $ MusicAttributes $ Staves (fromIntegral n)+++-- |+-- Create a metronome mark.+--+metronome :: NoteVal -> Tempo -> Music+metronome nv tempo = case dots of+ 0 -> metronome' nv' False tempo+ 1 -> metronome' nv' True tempo+ _ -> error "Metronome mark requires a maximum of one dot."+ where+ (nv', dots) = separateDots nv++-- |+-- Create a metronome mark.+--+metronome' :: NoteVal -> Bool -> Tempo -> Music+metronome' nv dot tempo = Music . single $ MusicDirection (Metronome nv dot tempo)++-- TODO #15 tempo+++backup :: Duration -> Music+backup d = Music . single $ MusicBackup d++forward :: Duration -> Music+forward d = Music . single $ MusicForward d++-- ----------------------------------------------------------------------------------+-- Notes+-- ----------------------------------------------------------------------------------++-- |+-- Create a rest.+--+-- > rest (1/4)+-- > rest (3/8)+-- > rest quarter+-- > rest (dotted eight)+--+rest :: NoteVal -> Music+-- rest = rest'+rest dur = case dots of+ 0 -> rest' dur'+ 1 -> rest' dur' <> rest' (dur' / 2)+ 2 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4)+ 3 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4) <> rest' (dur' / 8)+ _ -> error "Data.Music.MusicXml.Simple.rest: too many dots"+ where+ (dur', dots) = separateDots dur++rest' :: NoteVal -> Music+rest' dur = Music . single $ MusicNote (Note def (defaultDivisionsVal `div` denom) noTies (setNoteValP val def))+ where+ num = fromIntegral $ numerator $ toRational $ dur+ denom = fromIntegral $ denominator $ toRational $ dur+ val = NoteVal $ toRational $ dur ++-- |+-- Create a single note.+--+-- > note c (1/4)+-- > note fs_ (3/8)+-- > note c quarter+-- > note (c + pure fifth) (dotted eight)+--+note :: Pitch -> NoteVal -> Music+note pitch dur = note' False pitch dur' dots+ where+ (dur', dots) = separateDots dur++chordNote :: Pitch -> NoteVal -> Music+chordNote pitch dur = note' True pitch dur' dots+ where+ (dur', dots) = separateDots dur++-- |+-- Create a chord.+-- +-- > chord [c,eb,fs_] (3/8)+-- > chord [c,d,e] quarter+-- > chord [c,d,e] (dotted eight)+--+chord :: [Pitch] -> NoteVal -> Music+chord [] d = rest d+chord (p:ps) d = note p d <> Music (concatMap (\p -> getMusic $ chordNote p d) ps)+++note' :: Bool -> Pitch -> NoteVal -> Int -> Music+note' isChord pitch dur dots + = Music . single $ MusicNote $ + Note + (Pitched isChord $ pitch) + (defaultDivisionsVal `div` denom) + noTies + (setNoteValP val $ addDots $ def)+ where + addDots = foldl (.) id (replicate dots dotP)+ num = fromIntegral $ numerator $ toRational $ dur+ denom = fromIntegral $ denominator $ toRational $ dur+ val = NoteVal $ toRational $ dur ++separateDots :: NoteVal -> (NoteVal, Int)+separateDots = separateDots' [2/3, 6/7, 14/15, 30/31, 62/63]++separateDots' :: [NoteVal] -> NoteVal -> (NoteVal, Int)+separateDots' [] nv = errorNoteValue+separateDots' (div:divs) nv + | isDivisibleBy 2 nv = (nv, 0)+ | otherwise = (nv', dots' + 1)+ where + (nv', dots') = separateDots' divs (nv*div)++errorNoteValue = error "Data.Music.MusicXml.Simple.separateDots: Note value must be a multiple of two or dotted"++++setVoice :: Int -> Music -> Music+setVoice n = Music . fmap (modifyNoteProps (setVoiceP n)) . getMusic++dot :: Music -> Music+setNoteVal :: NoteVal -> Music -> Music+setTimeMod :: Int -> Int -> Music -> Music+dot = Music . fmap (modifyNoteProps dotP) . getMusic+setNoteVal x = Music . fmap (modifyNoteProps (setNoteValP x)) . getMusic+setTimeMod m n = Music . fmap (modifyNoteProps (setTimeModP m n)) . getMusic++addNotation :: Notation -> Music -> Music+addNotation x = Music . fmap (modifyNoteProps (addNotationP x)) . getMusic++setNoteHead :: NoteHead -> Music -> Music+setNoteHead x = Music . fmap (modifyNoteProps (mapNoteHeadP (const $ Just (x,False,False)))) . getMusic++-- TODO clean up, skip empty notation groups etc+mergeNotations :: [Notation] -> [Notation]+mergeNotations notations = mempty+ <> [foldOrnaments ornaments] + <> [foldTechnical technical] + <> [foldArticulations articulations]+ <> others+ where+ (ornaments,notations') = List.partition isOrnaments notations+ (technical,notations'') = List.partition isTechnical notations'+ (articulations,others) = List.partition isArticulations notations'++ isOrnaments (Ornaments _) = True+ isOrnaments _ = False+ isTechnical (Technical _) = True+ isTechnical _ = False+ isArticulations (Articulations _) = True+ isArticulations _ = False+ + foldOrnaments = foldr mergeN (Ornaments [])+ foldTechnical = foldr mergeN (Technical [])+ foldArticulations = foldr mergeN (Articulations [])+ (Ornaments xs) `mergeN` (Ornaments ys) = Ornaments (xs <> ys)+ (Technical xs) `mergeN` (Technical ys) = Technical (xs <> ys)+ (Articulations xs) `mergeN` (Articulations ys) = Articulations (xs <> ys)+++beginTuplet :: Music -> Music+endTuplet :: Music -> Music+beginTuplet = addNotation (Tuplet 1 Start)+endTuplet = addNotation (Tuplet 1 Stop)++beginBeam :: Music -> Music+continueBeam :: Music -> Music+endBeam :: Music -> Music+beginBeam = Music . fmap (modifyNoteProps (beginBeamP 1)) . getMusic+continueBeam = Music . fmap (modifyNoteProps (continueBeamP 1)) . getMusic+endBeam = Music . fmap (modifyNoteProps (endBeamP 1)) . getMusic++beginTie :: Music -> Music+endTie :: Music -> Music+beginTie = beginTie' . addNotation (Tied Start)+endTie = endTie' . addNotation (Tied Stop)+beginTie' = Music . fmap beginTie'' . getMusic+endTie' = Music . fmap endTie'' . getMusic+beginTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur (ties++[Start]) props))+beginTie'' x = x+endTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur ([Stop]++ties) props))+endTie'' x = x+++setNoteValP v x = x { noteType = Just (v, Nothing) }+setVoiceP n x = x { noteVoice = Just (fromIntegral n) }+setTimeModP m n x = x { noteTimeMod = Just (fromIntegral m, fromIntegral n) }+beginBeamP n x = x { noteBeam = Just (fromIntegral n, BeginBeam) }+continueBeamP n x = x { noteBeam = Just (fromIntegral n, ContinueBeam) }+endBeamP n x = x { noteBeam = Just (fromIntegral n, EndBeam) }+dotP x@(NoteProps { noteDots = n@_ }) = x { noteDots = succ n }+addNotationP n x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (mergeNotations $ ns++[n]) }+mapNotationsP f x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (f ns) }+mapStemP f x@(NoteProps { noteStem = a@_ }) = x { noteNotations = (f a) }+mapNoteHeadP f x@(NoteProps { noteNoteHead = a@_ }) = x { noteNoteHead = (f a) }+++-- ----------------------------------------------------------------------------------++beginGliss :: Music -> Music+endGliss :: Music -> Music+beginSlide :: Music -> Music+endSlide :: Music -> Music+beginGliss = addNotation (Glissando 1 Start Solid Nothing)+endGliss = addNotation (Glissando 1 Stop Solid Nothing)+beginSlide = addNotation (Slide 1 Start Solid Nothing)+endSlide = addNotation (Slide 1 Stop Solid Nothing)++arpeggiate :: Music -> Music+nonArpeggiate :: Music -> Music+arpeggiate = addNotation Arpeggiate+nonArpeggiate = addNotation NonArpeggiate+++-- ----------------------------------------------------------------------------------++fermata :: FermataSign -> Music -> Music+breathMark :: Music -> Music+caesura :: Music -> Music+fermata = addNotation . Fermata+breathMark = addNotation (Articulations [BreathMark]) +caesura = addNotation (Articulations [Caesura]) ++-- ----------------------------------------------------------------------------------++addTechnical :: Technical -> Music -> Music+addTechnical x = addNotation (Technical [x])++addArticulation :: Articulation -> Music -> Music+addArticulation x = addNotation (Articulations [x])++upbow = addTechnical UpBow+downbow = addTechnical DownBow+harmonic = addTechnical Harmonic+openString = addTechnical OpenString+++beginSlur :: Music -> Music+endSlur :: Music -> Music+beginSlur = addNotation (Slur 1 Start)+endSlur = addNotation (Slur 1 Stop)++accent :: Music -> Music+strongAccent :: Music -> Music+staccato :: Music -> Music+tenuto :: Music -> Music+detachedLegato :: Music -> Music+staccatissimo :: Music -> Music+spiccato :: Music -> Music+scoop :: Music -> Music+plop :: Music -> Music+doit :: Music -> Music+falloff :: Music -> Music+stress :: Music -> Music+unstress :: Music -> Music+accent = addNotation (Articulations [Accent]) +strongAccent = addNotation (Articulations [StrongAccent]) +staccato = addNotation (Articulations [Staccato]) +tenuto = addNotation (Articulations [Tenuto]) +detachedLegato = addNotation (Articulations [DetachedLegato]) +staccatissimo = addNotation (Articulations [Staccatissimo]) +spiccato = addNotation (Articulations [Spiccato]) +scoop = addNotation (Articulations [Scoop]) +plop = addNotation (Articulations [Plop]) +doit = addNotation (Articulations [Doit]) +falloff = addNotation (Articulations [Falloff]) +stress = addNotation (Articulations [Stress]) +unstress = addNotation (Articulations [Unstress]) ++-- ----------------------------------------------------------------------------------++cresc, dim :: Music -> Music+crescFrom, crescTo, dimFrom, dimTo :: Dynamics -> Music -> Music +crescFromTo, dimFromTo :: Dynamics -> Dynamics -> Music -> Music ++cresc = \m -> beginCresc <> m <> endCresc+dim = \m -> beginDim <> m <> endDim++crescFrom x = \m -> dynamic x <> cresc m+crescTo x = \m -> cresc m <> dynamic x+crescFromTo x y = \m -> dynamic x <> cresc m <> dynamic y++dimFrom x = \m -> dynamic x <> dim m+dimTo x = \m -> dim m <> dynamic x+dimFromTo x y = \m -> dynamic x <> dim m <> dynamic y++beginCresc, endCresc, beginDim, endDim :: Music++beginCresc = Music $ [MusicDirection $ Crescendo Start]+endCresc = Music $ [MusicDirection $ Crescendo Stop]+beginDim = Music $ [MusicDirection $ Diminuendo Start]+endDim = Music $ [MusicDirection $ Diminuendo Stop]++dynamic :: Dynamics -> Music+dynamic level = Music $ [MusicDirection $ Dynamics level]++tuplet :: Int -> Int -> Music -> Music+tuplet m n (Music []) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ Music []+tuplet m n (Music [xs]) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ Music [xs]+tuplet m n (Music xs) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ setTimeMod m n $ (as <> bs <> cs)+ where + as = beginTuplet $ Music [head xs]+ bs = Music $ init (tail xs)+ cs = endTuplet $ Music [last (tail xs)]++scaleDur x = mapMusic id (mapNote + (\f d t p -> (f,round $ fromIntegral d*x,t,p)) + (\f d p -> (f,round $ fromIntegral d*x,p)) + (\f t p -> (f,t,p))) id++beam :: Music -> Music+beam (Music []) = Music []+beam (Music [xs]) = Music [xs]+beam (Music xs) = (as <> bs <> cs)+ where+ as = beginBeam $ Music [head xs]+ bs = continueBeam $ Music (init (tail xs))+ cs = endBeam $ Music [last (tail xs)]++slur :: Music -> Music+slur (Music []) = Music []+slur (Music [xs]) = Music [xs]+slur (Music xs) = (as <> bs <> cs)+ where+ as = beginSlur $ Music [head xs]+ bs = Music $ init (tail xs)+ cs = endSlur $ Music [last (tail xs)]+ +-- TODO combine tuplet, beam, slur etc++++-----------------------------------------------------------------------------+-- * Ornaments+-----------------------------------------------------------------------------++tremolo :: Int -> Music -> Music+tremolo n = addNotation (Ornaments [(Tremolo $ fromIntegral n, [])])++trill :: Music -> Music+turn :: Bool -> Bool -> Music -> Music+shake :: Music -> Music+mordent :: Bool -> Music -> Music++trill = addOrnament TrillMark+turn delay invert = case (delay,invert) of+ (False,False) -> addOrnament Turn+ (True, False) -> addOrnament DelayedTurn+ (False,True) -> addOrnament InvertedTurn+ (True, True) -> addOrnament DelayedInvertedTurn++shake = addOrnament Shake+mordent invert = case invert of+ False -> addOrnament Mordent+ True -> addOrnament InvertedMordent++addOrnament a = addNotation (Ornaments [(a, [])])++-- ----------------------------------------------------------------------------------+-- Text+-- ----------------------------------------------------------------------------------++text :: String -> Music+rehearsal :: String -> Music++text = Music . single . MusicDirection . Words+rehearsal = Music . single . MusicDirection . Rehearsal++segno, coda :: Music+segno = Music . single . MusicDirection $ Segno+coda = Music . single . MusicDirection $ Coda++-- ----------------------------------------------------------------------------------++mapNote fn fc fg = go+ where + go (Note f d t p) = let (f',d',t',p') = fn f d t p in Note f' d' t' p'+ go (CueNote f d p) = let (f',d',p') = fc f d p in CueNote f' d' p'+ go (GraceNote f t p) = let (f',t',p') = fg f t p in GraceNote f' t' p'++mapMusic :: (Attributes -> Attributes) -> (Note -> Note) -> (Direction -> Direction) -> Music -> Music+mapMusic fa fn fd = foldMusic (MusicAttributes . fa) (MusicNote . fn) (MusicDirection . fd) (Music . return)++foldMusic :: Monoid m => (Attributes -> r) -> (Note -> r) -> (Direction -> r) -> (r -> m) -> Music -> m+foldMusic fa fn fd f = mconcat . fmap f . (foldMusic' $ fmap (foldMusicElem fa fn fd))++foldMusic' :: ([MusicElem] -> r) -> Music -> r+foldMusic' f (Music x) = f x++foldMusicElem :: (Attributes -> r) -> (Note -> r) -> (Direction -> r) -> MusicElem -> r+foldMusicElem = go+ where go fa fn fd (MusicAttributes x) = fa x+ go fa fn fd (MusicNote x) = fn x+ go fa fn fd (MusicDirection x) = fd x++-- ----------------------------------------------------------------------------------++instance Default ScoreAttrs where+ def = ScoreAttrs []++instance Default ScoreHeader where+ def = ScoreHeader Nothing Nothing Nothing mempty++instance Default Note where+ def = Note def def [] def++instance Default Divs where+ def = defaultDivisionsVal++instance Default FullNote where+ def = Rest noChord Nothing++instance Default NoteProps where+ def = NoteProps Nothing Nothing (Just (1/4, Nothing)) 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] []++++-------------------------------------------------------------------------------------+++logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a+logBaseR k n + | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1+logBaseR k n + | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1+logBaseR k n = logBase (fromRational k) (fromRational n)++isDivisibleBy :: (Real a, Real b) => a -> b -> Bool+isDivisibleBy n = (equalTo 0.0) . snd . properFraction . logBaseR (toRational n) . toRational++single x = [x]+equalTo = (==)++
+ src/Data/Music/MusicXml/Time.hs view
@@ -0,0 +1,87 @@++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-------------------------------------------------------------------------------------++module Data.Music.MusicXml.Time (+ Duration(..),+ NoteType(..),++ Divs(..),+ NoteVal(..),+ NoteSize(..),++ Beat(..),+ BeatType(..),+ + Tempo(..)+ ) where++type Duration = Divs+type NoteType = (NoteVal, Maybe NoteSize)++newtype Divs = Divs { getDivs :: Int } -- ^ Sounding time in ticks+newtype NoteVal = NoteVal { getNoteVal :: Rational } -- ^ Notated time in fractions, in @[2^^i | i <- [-10..3]]@.++data NoteSize = SizeFull | SizeCue | SizeLarge++newtype Beat = Beat { getBeat :: Int } -- ^ Time nominator+newtype BeatType = BeatType { getBeatType :: Int } -- ^ Time denominator++newtype Tempo = Tempo { getTempo :: Double } -- ^ Tempo in BPM+++++deriving instance Eq Divs+deriving instance Ord Divs+deriving instance Num Divs+deriving instance Real Divs+deriving instance Integral Divs+deriving instance Enum Divs+deriving instance Show Divs++deriving instance Eq NoteVal+deriving instance Ord NoteVal+deriving instance Num NoteVal+deriving instance Enum NoteVal+deriving instance Fractional NoteVal+deriving instance Real NoteVal+deriving instance RealFrac NoteVal+deriving instance Show NoteVal++deriving instance Eq NoteSize+deriving instance Ord NoteSize+deriving instance Enum NoteSize+deriving instance Bounded NoteSize++deriving instance Eq Beat+deriving instance Ord Beat+deriving instance Num Beat+deriving instance Enum Beat ++deriving instance Eq BeatType+deriving instance Ord BeatType+deriving instance Num BeatType+deriving instance Enum BeatType++deriving instance Eq Tempo+deriving instance Ord Tempo+deriving instance Num Tempo+deriving instance Enum Tempo+deriving instance Fractional Tempo+deriving instance Real Tempo+deriving instance RealFrac Tempo+deriving instance Show Tempo++
+ src/Data/Music/MusicXml/Write.hs view
@@ -0,0 +1,23 @@++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-------------------------------------------------------------------------------------++module Data.Music.MusicXml.Write (+ WriteMusicXml(..)++ ) where++import Text.XML.Light (Element)++class WriteMusicXml a where+ write :: a -> [Element]+
+ src/Data/Music/MusicXml/Write/Score.hs view
@@ -0,0 +1,586 @@++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-------------------------------------------------------------------------------------++module Data.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 Data.Music.MusicXml.Score+import Data.Music.MusicXml.Time+import Data.Music.MusicXml.Pitch+import Data.Music.MusicXml.Dynamics+import Data.Music.MusicXml.Read+import Data.Music.MusicXml.Write++import qualified Data.List as List+import qualified Data.Char as Char+++-- This instance is used by toXml and should return a single list+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)+++++-- ----------------------------------------------------------------------------------+-- Part list+-- ----------------------------------------------------------------------------------++instance WriteMusicXml PartListElem where+ write (Part id+ name+ abbrev+ nameDisplay+ abbrevDisplay+ ) = single+ $ addAttr (uattr "id" id)+ $ unode "score-part"+ $ mconcat [writeName name, writeAbbrev abbrev, + writeNameDisplay nameDisplay, writeAbbrevDisplay abbrevDisplay]+ where+ writeName = single . unode "part-name"+ writeAbbrev = maybeToList . fmap (unode "part-abbreviation")+ writeNameDisplay = maybeToList . fmap (unode "part-name-display" . unode "display-text")+ writeAbbrevDisplay = maybeToList . fmap (unode "part-abbreviation-display" . unode "display-text")++ 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++-- ----------------------------------------------------------------------------------+-- Music+-- ----------------------------------------------------------------------------------++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)++-- ----------------------------------------------------------------------------------+-- Attributes+-- ----------------------------------------------------------------------------------+++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)]++ write (Staves n) = single $ unode "staves" $ show n++-- ----------------------------------------------------------------------------------+-- Notes+-- ----------------------------------------------------------------------------------++instance WriteMusicXml NoteProps where+ write (NoteProps+ instrument -- TODO+ voice+ typ+ dots+ accidental -- TODO+ timeMod -- TODO+ stem -- TODO+ noteHead+ noteHeadText -- TODO+ staff -- TODO+ beam+ notations+ lyrics) -- TODO+ = mempty+ -- TODO instrument+ <> maybeOne (\n -> unode "voice" $ show n) voice+ <> maybeOne (\(noteVal, noteSize) -> unode "type" (writeNoteVal noteVal)) typ+ <> replicate (fromIntegral dots) (unode "dot" ())+ -- TODO accidental+ <> maybeOne (\(m, n) -> unode "time-modification" [+ unode "actual-notes" (show m),+ unode "normal-notes" (show n)+ ]) timeMod+ -- TODO stem+ <> maybeOne (\(nh,_,_) -> unode "notehead" (writeNoteHead nh)) noteHead + -- TODO notehead-text+ -- TODO staff+ <> 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" ()++++-- ----------------------------------------------------------------------------------+-- Notations+-- ----------------------------------------------------------------------------------++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"++++-- ----------------------------------------------------------------------------------+-- Directions+-- ----------------------------------------------------------------------------------++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"+++-- ----------------------------------------------------------------------------------+-- Lyrics+-- ----------------------------------------------------------------------------------++instance WriteMusicXml Lyric where+ write = notImplemented "WriteMusicXml instance for Lyric"+++-- ----------------------------------------------------------------------------------+-- Basic types+-- ----------------------------------------------------------------------------------+++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 $ "Data.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) ()+++-- ----------------------------------------------------------------------------------+++-- XML aliases++addAttr :: Attr -> Element -> Element+addAttrs :: [Attr] -> Element -> Element+addAttr = add_attr+addAttrs = add_attrs++uattr :: String -> String -> Attr+uattr n = Attr (unqual n)+++-- Misc++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
− src/Music/MusicXml.hs
@@ -1,155 +0,0 @@------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable------ A Haskell representation of MusicXML.--- You may want to use the "Music.MusicXml.Simple" module to generate the representation.------ For an introduction to MusicXML, see <http://www.makemusic.com/musicxml/tutorial>.-------------------------------------------------------------------------------------------module Music.MusicXml (-- -- * Score- Score(..),- ScoreHeader(..),- Identification(..),- Creator(..),- Defaults(..),- ScoreAttrs(..),- PartAttrs(..),- MeasureAttrs(..),-- -- ** Part list- PartList(..),- PartListElem(..),-- -- * Music- Music(..),- MusicElem(..),-- -- ** Attributes- Attributes(..),- TimeSignature(..),- ClefSign(..),-- -- ** Notes- Note(..),- FullNote(..),- IsChord,- noChord,- Tie(..),- noTies,- NoteProps(..),- HasNoteProps(..),-- -- ** Notations- Notation(..),- Articulation(..),- Ornament(..),- Technical(..),-- -- ** Directions- Direction(..),-- -- ** Lyrics- Lyric(..),----- -- * Basic types-- -- ** Pitch- Pitch(..),- DisplayPitch(..),- PitchClass,- Semitones(..),- noSemitones,-- Octaves(..),- Fifths(..),- Line(..),-- Mode(..),- Accidental(..),-- -- ** Time- Duration(..),- NoteType(..),-- Divs(..),- NoteVal(..),- NoteSize(..),-- Beat(..),- BeatType(..),--- -- ** Dynamics- Dynamics,--- ------------------------------------------------------------------------------ -- ** Misc-- StemDirection(..),- NoteHead(..),- LineType(..),-- Level(..),- BeamType(..),- StartStop(..),- StartStopChange(..),- StartStopContinue(..),- StartStopContinueChange(..),- - - ------------------------------------------------------------------------------ -- * Import and export functions- ------------------------------------------------------------------------------- toXml,- showXml-- ) where--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 Music.MusicXml.Write.Score---- ----------------------------------------------------------------------------------- Import and export functions--- ------------------------------------------------------------------------------------ |--- Render a score as a MusicXML string.-showXml :: Score -> String-showXml = ppTopElement . toXml---- |--- Render a score as MusicXML.-toXml :: Score -> Element-toXml = fromSingle . write---- ----------------------------------------------------------------------------------fromSingle :: [a] -> a-fromSingle [x] = x-fromSingle _ = error "fromSingle: non-single list"-
− src/Music/MusicXml/Dynamics.hs
@@ -1,67 +0,0 @@--{-# LANGUAGE GeneralizedNewtypeDeriving #-}------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------------------module Music.MusicXml.Dynamics (-- Dynamics(..)-- ) where--import Music.Dynamics.Literal--data Dynamics - = PPPPPP - | PPPPP - | PPPP - | PPP - | PP - | P - | MP - | MF - | F - | FF - | FFF - | FFFF - | FFFFF - | FFFFFF- | SF - | SFP - | SFPP- | FP - | RF - | RFZ - | SFZ - | SFFZ - | FZ- deriving (Eq, Ord, Show, Enum, Bounded)--instance IsDynamics Dynamics where- fromDynamics (DynamicsL (Just x, Nothing)) = case x of- (-6.5) -> PPPPPP- (-5.5) -> PPPPP- (-4.5) -> PPPP- (-3.5) -> PPP- (-2.5) -> PP- (-1.5) -> P- (-0.5) -> MP- 0.5 -> MF- 1.5 -> F- 2.5 -> FF- 3.5 -> FFF- 4.5 -> FFFF- 5.5 -> FFFFF- 6.5 -> FFFFFF- fromDynamics _ = error "fromDynamics: Unsupported literal for MusicXml.Dynamics"-
− src/Music/MusicXml/Pitch.hs
@@ -1,119 +0,0 @@--{-# LANGUAGE - GeneralizedNewtypeDeriving, - StandaloneDeriving, - TypeSynonymInstances, - FlexibleInstances #-}------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------------------module Music.MusicXml.Pitch (-- Pitch(..),- DisplayPitch(..),- PitchClass(..),- Semitones(..),- noSemitones,-- Octaves(..),- Fifths(..),- Line(..),-- Mode(..),- Accidental(..)-- ) where--import Music.Pitch.Literal--type Pitch = (PitchClass, Maybe Semitones, Octaves)-type DisplayPitch = (PitchClass, Octaves)--data Mode = Major | Minor - | Dorian | Phrygian | Lydian | Mixolydian - | Aeolian | Ionian | Locrian | NoMode--data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp--data PitchClass = C | D | E | F | G | A | B--newtype Semitones = Semitones { getSemitones :: Double } -- ^ Semitones, i.e 100 cent-newtype Octaves = Octaves { getOctaves :: Int } -- ^ Octaves, i.e. 1200 cent-newtype Fifths = Fifths { getFifths :: Int } -- ^ Number of fifths upwards relative to C (i.e. F is -1, G is 1)-newtype Line = Line { getLine :: Int } -- ^ Line number, from bottom (i.e. 1-5)---noSemitones :: Maybe Semitones-noSemitones = Nothing--deriving instance Eq PitchClass-deriving instance Ord PitchClass-deriving instance Enum PitchClass-deriving instance Show PitchClass--deriving instance Eq Accidental-deriving instance Ord Accidental-deriving instance Enum Accidental--deriving instance Eq Mode-deriving instance Ord Mode-deriving instance Enum Mode-deriving instance Show Mode--deriving instance Eq Semitones-deriving instance Ord Semitones-deriving instance Num Semitones-deriving instance Enum Semitones-deriving instance Fractional Semitones--deriving instance Eq Octaves-deriving instance Ord Octaves-deriving instance Num Octaves-deriving instance Enum Octaves-deriving instance Real Octaves-deriving instance Integral Octaves--deriving instance Eq Fifths-deriving instance Ord Fifths-deriving instance Num Fifths-deriving instance Enum Fifths--deriving instance Eq Line-deriving instance Ord Line-deriving instance Num Line-deriving instance Enum Line--instance IsPitch Pitch where- fromPitch (PitchL (pc, Nothing, oct)) = (toEnum pc, Nothing, fromIntegral oct)- fromPitch (PitchL (pc, Just st, oct)) = (toEnum pc, Just $ fromRational $ toRational $ st, fromIntegral oct)--instance IsPitch DisplayPitch where- fromPitch (PitchL (pc, _, oct)) = (toEnum pc, fromIntegral oct)--instance IsPitch Fifths where- fromPitch (PitchL (pc, Nothing, _)) = pitchToFifths pc 0- fromPitch (PitchL (pc, Just ac, _)) = pitchToFifths pc (round ac)--pitchToFifths 1 (-1) = (-4)-pitchToFifths 2 (-1) = (-3)-pitchToFifths 4 (-1) = (-6)-pitchToFifths 5 (-1) = (-5)-pitchToFifths 6 (-1) = (-2)-pitchToFifths 0 0 = 0-pitchToFifths 1 0 = 2-pitchToFifths 2 0 = 4-pitchToFifths 3 0 = (-1)-pitchToFifths 4 0 = 1-pitchToFifths 5 0 = 3-pitchToFifths 6 0 = 5-pitchToFifths 3 1 = 6
− src/Music/MusicXml/Read.hs
@@ -1,17 +0,0 @@------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------------------module Music.MusicXml.Read (- ) where--
− src/Music/MusicXml/Score.hs
@@ -1,606 +0,0 @@--{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------------------module Music.MusicXml.Score (-- ------------------------------------------------------------------------------ -- * Score- ------------------------------------------------------------------------------- Score(..),- ScoreHeader(..),- Identification(..),- Creator(..),- Defaults(..),- ScoreAttrs(..),- PartAttrs(..),- MeasureAttrs(..),-- -- ** Part list- PartList(..),- PartListElem(..),- GroupSymbol(..),- GroupBarlines(..),-- ------------------------------------------------------------------------------ -- * Music- ------------------------------------------------------------------------------- Music(..),- MusicElem(..),-- ------------------------------------------------------------------------------- -- ** Attributes- Attributes(..),- TimeSignature(..),- ClefSign(..),-- ------------------------------------------------------------------------------ -- ** Notes-- Note(..),- FullNote(..),- IsChord,- noChord,- noTies,- Tie,- NoteProps(..),- HasNoteProps(..),-- ------------------------------------------------------------------------------ -- ** Notations-- Notation(..),- FermataSign(..),- Articulation(..),- Ornament(..),- Technical(..),-- ------------------------------------------------------------------------------ -- ** Directions-- Direction(..),-- ------------------------------------------------------------------------------ -- ** Lyrics-- Lyric(..),--- ------------------------------------------------------------------------------ -- * Basic types- ------------------------------------------------------------------------------- ------------------------------------------------------------------------------ -- ** Pitch-- Pitch(..),- DisplayPitch(..),- PitchClass,- Semitones(..),- noSemitones,-- Octaves(..),- Fifths(..),- Line(..),-- Mode(..),- Accidental(..),-- ------------------------------------------------------------------------------ -- ** Time-- Duration(..),- NoteType(..),-- Divs(..),- NoteVal(..),- NoteSize(..),-- Beat(..),- BeatType(..),-- ------------------------------------------------------------------------------ -- ** Dynamics-- Dynamics(..),-- ------------------------------------------------------------------------------ -- ** Misc-- StemDirection(..),- NoteHead(..),- LineType(..),-- Level(..),- BeamType(..),- StartStop(..),- StartStopChange(..),- StartStopContinue(..),- StartStopContinueChange(..),-- ) where--import Prelude hiding (getLine)--import Data.Default-import Data.Semigroup-import Data.Foldable-import Numeric.Natural-import TypeUnary.Nat--import Music.MusicXml.Time-import Music.MusicXml.Pitch-import Music.MusicXml.Dynamics--import qualified Data.List as List---- ------------------------------------------------------------------------------------- Score--- ------------------------------------------------------------------------------------data Score- = Partwise- ScoreAttrs- ScoreHeader- [(PartAttrs,- [(MeasureAttrs, Music)])] -- music by part and time- | Timewise- ScoreAttrs- ScoreHeader- [(MeasureAttrs,- [(PartAttrs, Music)])] -- music by time and part--data ScoreHeader- = ScoreHeader- (Maybe String) -- title- (Maybe String) -- movement title- (Maybe Identification) -- identification?- -- defaults?- -- credit*- PartList -- partlist?---data Identification- = Identification- [Creator] -- creator--data Creator- = Creator- String -- type (composer, lyricist, arranger etc)- String -- name--data Defaults- = Defaults- -- page layout (marigins, distance etc)- -- system layout- -- staff layout- -- scaling- -- appearance (line width etc)--data ScoreAttrs- = ScoreAttrs- [Int] -- score version--data PartAttrs- = PartAttrs- String -- part id--data MeasureAttrs- = MeasureAttrs- Int -- measure number----- ------------------------------------------------------------------------------------- Part list--- ------------------------------------------------------------------------------------newtype PartList = PartList { getPartList :: [PartListElem] }---- TODO fix for #11, by overwriting id when part list is merged--instance Default PartList where- def = PartList []--instance Semigroup PartList where- PartList xs <> PartList ys = PartList (setIds $ xs <> ys)- where- setIds = snd . List.mapAccumL setId partIds- setId id (Part _ name abbr) = (tail id, Part (head id) name abbr)- setId id x = (id, x)- partIds = [ "P" ++ show n | n <- [1..] ]--instance Monoid PartList where- mempty = def- mappend = (<>)--data PartListElem- = Part- String- String- (Maybe String) -- id name abbrev?- | Group - Level - StartStop- String- (Maybe String)- (Maybe GroupSymbol)- (Maybe GroupBarlines)- Bool -- number start/stop name abbrev? symbol barline style--data GroupSymbol = GroupBrace | GroupLine | GroupBracket | GroupSquare | NoGroupSymbol-data GroupBarlines = GroupBarLines | GroupNoBarLines | GroupMensurstrich---- ------------------------------------------------------------------------------------- Music--- ------------------------------------------------------------------------------------newtype Music = Music { getMusic :: [MusicElem] }- deriving (Semigroup, Monoid)--data MusicElem- = MusicAttributes- Attributes- | MusicBackup- Duration- | MusicForward- Duration- | MusicNote- Note- | MusicDirection- Direction- | MusicHarmony -- TODO- | MusicFiguredBass -- TODO- | MusicPrint -- TODO- | MusicSound -- TODO- | MusicBarline -- TODO- | MusicGrouping -- TODO- | MusicLink -- TODO- | MusicBookmark -- TODO----- ------------------------------------------------------------------------------------- Attributes--- ------------------------------------------------------------------------------------data Attributes- = Divisions- Divs- | Key- Fifths- Mode- | Time- TimeSignature- | Staves- Natural- | PartSymbol -- TODO- | Instruments- Natural- | Clef- ClefSign- Line- | StaffDetails -- TODO- | Transpose -- TODO- | Directive -- TODO- | MeasureStyle -- TODO--data TimeSignature- = CommonTime- | CutTime- | DivTime- Beat- BeatType--data ClefSign- = GClef- | CClef- | FClef- | PercClef- | TabClef- deriving (Eq, Ord, Enum, Bounded)----- ------------------------------------------------------------------------------------- Notes--- ------------------------------------------------------------------------------------data Note- = Note- FullNote- Duration- [Tie]- NoteProps- | CueNote- FullNote- Duration- NoteProps- | GraceNote- FullNote- [Tie]- NoteProps--data FullNote- = Pitched- IsChord- Pitch- | Unpitched- IsChord- (Maybe DisplayPitch)- | Rest- IsChord- (Maybe DisplayPitch)--type IsChord = Bool-type Tie = StartStop--data NoteProps- = NoteProps {- noteInstrument :: Maybe String, -- instrument- noteVoice :: Maybe Natural, -- voice- noteType :: Maybe NoteType, -- type- noteDots :: Natural, -- dots- noteAccidental :: Maybe (Accidental, Bool, Bool), -- accidental, cautionary, editorial- noteTimeMod :: Maybe (Natural, Natural), -- actual, normal- noteStem :: Maybe StemDirection, -- stem- noteNoteHead :: Maybe (NoteHead, Bool, Bool), -- notehead, filled, parentheses- noteNoteHeadText :: Maybe String, -- notehead-text- noteStaff :: Maybe Natural, -- staff- noteBeam :: Maybe (Level, BeamType), -- beam-level, beam-type- noteNotations :: [Notation], -- notation- noteLyrics :: [Lyric] -- lyric- }--noChord :: IsChord-noChord = False--noTies :: [Tie]-noTies = []---class HasNoteProps a where- modifyNoteProps :: (NoteProps -> NoteProps) -> a -> a- --instance HasNoteProps Note where- modifyNoteProps f (Note x d t p) = Note x d t (f p)- modifyNoteProps f (CueNote x d p) = CueNote x d (f p)- modifyNoteProps f (GraceNote x t p) = GraceNote x t (f p)--instance HasNoteProps MusicElem where- modifyNoteProps f (MusicNote n) = MusicNote (modifyNoteProps f n)- modifyNoteProps f x = x------ ------------------------------------------------------------------------------------- Notations--- ------------------------------------------------------------------------------------data Notation- = Tied- StartStopContinue -- type- | Slur- Level- StartStopContinue -- level start/stop- | Tuplet- Level- StartStopContinue -- level start/stop- | Glissando- Level- StartStopContinue- LineType- (Maybe String) -- level type start/stop text?- | Slide- Level- StartStopContinue- LineType- (Maybe String) -- level type start/stop text?- | Ornaments- [(Ornament, [Accidental])]- | Technical- [Technical]- | Articulations- [Articulation]- | DynamicNotation- Dynamics- | Fermata FermataSign- | Arpeggiate- | NonArpeggiate- | AccidentalMark- Accidental- | OtherNotation- String--data FermataSign = NormalFermata | AngledFermata | SquaredFermata--data Articulation- = Accent - | StrongAccent - | Staccato - | Tenuto- | DetachedLegato - | Staccatissimo - | Spiccato- | Scoop - | Plop - | Doit - | Falloff - | BreathMark- | Caesura - | Stress - | Unstress - | OtherArticulation--data Ornament- = TrillMark - | Turn - | DelayedTurn - | InvertedTurn - | DelayedInvertedTurn - | VerticalTurn - | Shake - | WavyLine - | Mordent - | InvertedMordent - | Schleifer - | Tremolo - Natural -- TODO restrict to (1..8) range- | OtherOrnament- String- -data Technical- = UpBow - | DownBow - | Harmonic - | OpenString - | ThumbPosition - | Fingering - | Pluck - | DoubleTongue - | TripleTongue - | Stopped - | SnapPizzicato - | Fret - | String - | HammerOn - | PullOff - | Bend - | Tap - | Heel - | Toe - | Fingernails - | Hole - | Arrow - | Handbell - | OtherTechnical- String---- ------------------------------------------------------------------------------------- Directions--- ------------------------------------------------------------------------------------data Direction- = Rehearsal- String- | Segno- | Words- String- | Coda- | Crescendo- StartStop -- start/stop- | Diminuendo- StartStop -- start/stop- | Dynamics- Dynamics- | Dashes- Level- StartStop -- level start/stop- | Bracket -- TODO- | Pedal- StartStopChange- | Metronome- NoteVal- Bool- Tempo -- noteVal isDotted bpm - | OctaveShift -- TODO- | HarpPedals -- TODO- | Damp -- TODO- | DampAll -- TODO- | EyeGlasses -- TODO- | StringMute -- TODO- | Scordatura -- TODO- | Image -- TODO- | PrincipalVoice -- TODO- | AccordionRegistration -- TODO- | Percussion -- TODO- | OtherDirection- String----- ------------------------------------------------------------------------------------- Lyrics--- ------------------------------------------------------------------------------------data Lyric = Lyric -- TODO----- ------------------------------------------------------------------------------------- Basic types--- ------------------------------------------------------------------------------------newtype Level = Level { getLevel :: Max8 }--data BeamType- = BeginBeam- | ContinueBeam- | EndBeam- | ForwardHook- | BackwardHook--type StartStop = StartStopContinueChange-type StartStopChange = StartStopContinueChange-type StartStopContinue = StartStopContinueChange--data StartStopContinueChange- = Start- | Stop- | Continue - | Change--data StemDirection- = StemDown- | StemUp- | StemNone- | StemDouble--data LineType- = Solid- | Dashed- | Dotted- | Wavy--data NoteHead- = SlashNoteHead- | TriangleNoteHead- | DiamondNoteHead- | SquareNoteHead- | CrossNoteHead- | XNoteHead- | CircleXNoteHead- | InvertedTriangleNoteHead- | ArrowDownNoteHead- | ArrowUpNoteHead- | SlashedNoteHead- | BackSlashedNoteHead- | NormalNoteHead- | ClusterNoteHead- | CircleDotNoteHead- | LeftTriangleNoteHead- | RectangleNoteHead- | NoNoteHead -- "none"--deriving instance Eq Level-deriving instance Show Level-deriving instance Num Level---- -------------------------------------------------------------------------------------- Bounded ints-type Max8 = Index N8--notImplemented x = error $ "Not implemented: " ++ x--
− src/Music/MusicXml/Simple.hs
@@ -1,845 +0,0 @@--{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-}------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable------ Provides smart constructors for the MusicXML representation.--------------------------------------------------------------------------------------------module Music.MusicXml.Simple (- - module Music.MusicXml,- - ------------------------------------------------------------------------------ -- * Score and parts- ------------------------------------------------------------------------------- -- ** Basic constructors- fromPart,- fromParts,-- -- ** Part lists- partList,- partListAbbr,- bracket,- brace,- - -- ** Measures- measure,- bar,-- -- -- ** Others- -- standardPartAttributes,- -- header,- -- setHeader,- -- setTitle,- -- setMovementTitle,-- ------------------------------------------------------------------------------ -- * Top-level attributes- ------------------------------------------------------------------------------- -- ** Pitch- trebleClef,- altoClef,- bassClef,- defaultClef,- clef, - defaultKey,- key,-- -- ** Time- defaultDivisions,- divisions, - commonTime,- cutTime,- time,-- -- ** Tempo- -- TODO #15 tempo- metronome,- metronome',- - ------------------------------------------------------------------------------ -- * Backup and forward- ------------------------------------------------------------------------------- backup,- forward,-- ------------------------------------------------------------------------------ -- * Notes- ------------------------------------------------------------------------------ - -- ** Basic constructors- rest,- note,- chord,-- -- ** Voice- setVoice,-- -- ** Duration- dot,- tuplet,- setNoteVal,- -- setTimeMod,- -- beginTuplet,- -- endTuplet,- separateDots,-- -- ** Beams- beam,- beginBeam,- continueBeam,- endBeam,-- -- ** Ties- beginTie,- endTie,-- -- ** Note heads- setNoteHead,-- -- ** Notations- addNotation,-- ------------------------------------------------------------------------------ -- * Pitch transformations- ------------------------------------------------------------------------------ - -- ** Glissando- beginGliss,- endGliss,-- -- ** Slides- beginSlide,- endSlide,-- ------------------------------------------------------------------------------ -- * Time transformations- ------------------------------------------------------------------------------- -- ** Accelerando and ritardando- -- TODO #16 accelerando,- -- TODO #16 ritardando,-- -- ** Fermatas and breaks- fermata,- breathMark,- caesura,-- ------------------------------------------------------------------------------ -- * Articulation- ------------------------------------------------------------------------------- addTechnical,- addArticulation,- - -- ** Technical- upbow,- downbow,- harmonic,- openString,- - -- ** Slurs- slur,- beginSlur,- endSlur, - - -- ** Staccato and tenuto- staccato,- tenuto,- spiccato,- staccatissimo,-- -- ** Accents- accent,- strongAccent,-- -- ** Miscellaneous- scoop,- plop,- doit,- falloff,- stress,- unstress,- - -- ** Ornaments- trill,- turn,- shake,- mordent,- tremolo,-- ------------------------------------------------------------------------------ -- * Dynamics- ------------------------------------------------------------------------------- -- ** Crescendo and diminuendo- cresc,- dim,- beginCresc,- endCresc,- beginDim,- endDim,-- -- ** Dynamic levels- dynamic,-- -- ** Both- crescFrom,- crescTo,- crescFromTo,- dimFrom,- dimTo,- dimFromTo, -- ------------------------------------------------------------------------------ -- * Text- ------------------------------------------------------------------------------- text,- rehearsal,- segno,- coda,-- ------------------------------------------------------------------------------ -- * Folds and maps- ------------------------------------------------------------------------------ - -- mapNote,- mapMusic,- foldMusic,-- ) -where--import Data.Default-import Data.Ratio-import Data.Monoid-import Control.Arrow--import Music.MusicXml-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---- ------------------------------------------------------------------------------------- Score and parts--- -------------------------------------------------------------------------------------- | --- Create a single-part score.------ > fromPart title composer partName measures------ Example:------ @ 'fromPart' \"Suite\" \"Bach\" \"Cello solo\" [] @----fromPart :: String -> String -> String -> [Music] -> Score-fromPart title composer partName music = - fromParts title composer (partList [partName]) [music]---- | --- Create a multi-part score.------ > fromParts title composer partList parts------ Example:------ @ 'fromParts' \"4'33\" \"Cage\" ('partList' [\"Violin\", \"Viola\", \"Cello\"]) [[]] @----fromParts :: String -> String -> PartList -> [[Music]] -> Score-fromParts title composer partList music - = Partwise - (def)- (header title composer partList)- (addPartwiseAttributes music) ---- | --- Create a part list from instrument names.----partList :: [String] -> PartList-partList = PartList . zipWith (\partId name -> Part partId name Nothing) standardPartAttributes---- | --- Create a part list from instrument names and abbreviations.----partListAbbr :: [(String, String)] -> PartList-partListAbbr = PartList . zipWith (\partId (name,abbr) -> Part partId name (Just abbr)) standardPartAttributes---- | --- Enclose the given parts in a bracket.--- -bracket :: PartList -> PartList-bracket ps = PartList $ mempty- <> [Group 1 Start "" Nothing (Just GroupBracket) (Just GroupBarLines) False] - <> getPartList ps - <> [Group 1 Stop "" Nothing Nothing Nothing False]---- | --- Enclose the given parts in a brace.--- -brace :: PartList -> PartList-brace ps = PartList $ mempty- <> [Group 1 Start "" Nothing (Just GroupBrace) (Just GroupBarLines) False] - <> getPartList ps - <> [Group 1 Stop "" Nothing Nothing Nothing False]----- |--- Convenient synonym for 'mconcat', allowing us to write things like------ > measure [--- > beam [ --- > note c (1/8), --- > note d (1/8),--- > note e (1/8),--- > note f (1/8) --- > ],--- > tuplet 3 2 [ --- > note g (1/4),--- > note a (1/4),--- > note b (1/4) --- > ]--- > ]--- -measure :: [Music] -> Music-measure = mconcat---- |--- Convenient synonym for 'mconcat'.--- -bar :: [Music] -> Music-bar = measure---header :: String -> String -> PartList -> ScoreHeader-header title composer partList = ScoreHeader Nothing (Just title) (Just (Identification [Creator "composer" composer])) partList--setHeader :: ScoreHeader -> Score -> Score-setHeader header (Partwise attrs _ music) = Partwise attrs header music-setHeader header (Timewise attrs _ music) = Timewise attrs header music--setTitle :: String -> ScoreHeader -> ScoreHeader-setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader (Just title) mvmTitle ident partList--setMovementTitle :: String -> ScoreHeader -> ScoreHeader-setMovementTitle mvmTitle (ScoreHeader title _ ident partList) = ScoreHeader title (Just mvmTitle) ident partList---- | The values P1, P2... which are conventionally used to identify parts in MusicXML.-standardPartAttributes :: [String]-standardPartAttributes = [ "P" ++ show n | n <- [1..] ]---- | Given a partwise score (list of parts, which are lists of measures), add part and measure attributes (numbers).-addPartwiseAttributes :: [[Music]] -> [(PartAttrs, [(MeasureAttrs, Music)])]-addPartwiseAttributes = deepZip partIds barIds- where- partIds = fmap PartAttrs standardPartAttributes- barIds = fmap MeasureAttrs [1..]-- deepZip :: [a] -> [b] -> [[c]] -> [(a, [(b, c)])] - deepZip xs ys = zipWith (curry $ second (zip ys)) xs---- ------------------------------------------------------------------------------------- Top-level attributes--- ------------------------------------------------------------------------------------trebleClef, altoClef, bassClef :: Music-trebleClef = clef GClef 2-altoClef = clef CClef 3-bassClef = clef FClef 4--defaultClef :: Music-defaultClef = trebleClef---- |--- Create a clef.----clef :: ClefSign -> Line -> Music-clef symbol line = Music . single $ MusicAttributes $ Clef symbol line--defaultKey :: Music-defaultKey = key 0 Major---- |--- Create a key signature.----key :: Fifths -> Mode -> Music-key n m = Music . single $ MusicAttributes $ Key n m----- Number of ticks per whole note (we use 768 per quarter like Sibelius).-defaultDivisionsVal :: Divs -defaultDivisionsVal = 768 * 4---- |--- Set the tick division to the default value.----defaultDivisions :: Music-defaultDivisions = Music $ single $ MusicAttributes $ Divisions $ defaultDivisionsVal `div` 4---- |--- Define the number of ticks per quarter note.----divisions :: Divs -> Music-divisions n = Music . single $ MusicAttributes $ Divisions $ n--commonTime, cutTime :: Music-commonTime = Music . single $ MusicAttributes $ Time CommonTime-cutTime = Music . single $ MusicAttributes $ Time CutTime---- |--- Create a time signature.----time :: Beat -> BeatType -> Music-time a b = Music . single $ MusicAttributes $ Time $ DivTime a b---- |--- Create a metronome mark.----metronome :: NoteVal -> Tempo -> Music-metronome nv tempo = case dots of- 0 -> metronome' nv' False tempo- 1 -> metronome' nv' True tempo- _ -> error "Metronome mark requires a maximum of one dot."- where- (nv', dots) = separateDots nv---- |--- Create a metronome mark.----metronome' :: NoteVal -> Bool -> Tempo -> Music-metronome' nv dot tempo = Music . single $ MusicDirection (Metronome nv dot tempo)---- TODO #15 tempo--backup :: Duration -> Music-backup d = Music . single $ MusicBackup d--forward :: Duration -> Music-forward d = Music . single $ MusicForward d---- ------------------------------------------------------------------------------------- Notes--- -------------------------------------------------------------------------------------- |--- Create a rest.------ > rest (1/4)--- > rest (3/8)--- > rest quarter--- > rest (dotted eight)----rest :: NoteVal -> Music--- rest = rest'-rest dur = case dots of- 0 -> rest' dur'- 1 -> rest' dur' <> rest' (dur' / 2)- 2 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4)- 3 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4) <> rest' (dur' / 8)- _ -> error "Music.MusicXml.Simple.rest: too many dots"- where- (dur', dots) = separateDots dur--rest' :: NoteVal -> Music-rest' dur = Music . single $ MusicNote (Note def (defaultDivisionsVal `div` denom) noTies (setNoteValP val def))- where- num = fromIntegral $ numerator $ toRational $ dur- denom = fromIntegral $ denominator $ toRational $ dur- val = NoteVal $ toRational $ dur ---- |--- Create a single note.------ > note c (1/4)--- > note fs_ (3/8)--- > note c quarter--- > note (c + pure fifth) (dotted eight)----note :: Pitch -> NoteVal -> Music-note pitch dur = note' False pitch dur' dots- where- (dur', dots) = separateDots dur--chordNote :: Pitch -> NoteVal -> Music-chordNote pitch dur = note' True pitch dur' dots- where- (dur', dots) = separateDots dur---- |--- Create a chord.--- --- > chord [c,eb,fs_] (3/8)--- > chord [c,d,e] quarter--- > chord [c,d,e] (dotted eight)----chord :: [Pitch] -> NoteVal -> Music-chord [] d = rest d-chord (p:ps) d = note p d <> Music (concatMap (\p -> getMusic $ chordNote p d) ps)---note' :: Bool -> Pitch -> NoteVal -> Int -> Music-note' isChord pitch dur dots - = Music . single $ MusicNote $ - Note - (Pitched isChord $ pitch) - (defaultDivisionsVal `div` denom) - noTies - (setNoteValP val $ addDots $ def)- where - addDots = foldl (.) id (replicate dots dotP)- num = fromIntegral $ numerator $ toRational $ dur- denom = fromIntegral $ denominator $ toRational $ dur- val = NoteVal $ toRational $ dur --separateDots :: NoteVal -> (NoteVal, Int)-separateDots = separateDots' [2/3, 6/7, 14/15, 30/31, 62/63]--separateDots' :: [NoteVal] -> NoteVal -> (NoteVal, Int)-separateDots' [] nv = errorNoteValue-separateDots' (div:divs) nv - | isDivisibleBy 2 nv = (nv, 0)- | otherwise = (nv', dots' + 1)- where - (nv', dots') = separateDots' divs (nv*div)--errorNoteValue = error "Music.MusicXml.Simple.separateDots: Note value must be a multiple of two or dotted"----setVoice :: Int -> Music -> Music-setVoice n = Music . fmap (modifyNoteProps (setVoiceP n)) . getMusic--dot :: Music -> Music-setNoteVal :: NoteVal -> Music -> Music-setTimeMod :: Int -> Int -> Music -> Music-dot = Music . fmap (modifyNoteProps dotP) . getMusic-setNoteVal x = Music . fmap (modifyNoteProps (setNoteValP x)) . getMusic-setTimeMod m n = Music . fmap (modifyNoteProps (setTimeModP m n)) . getMusic--addNotation :: Notation -> Music -> Music-addNotation x = Music . fmap (modifyNoteProps (addNotationP x)) . getMusic--setNoteHead :: NoteHead -> Music -> Music-setNoteHead x = Music . fmap (modifyNoteProps (mapNoteHeadP (const $ Just (x,False,False)))) . getMusic---- TODO clean up, skip empty notation groups etc-mergeNotations :: [Notation] -> [Notation]-mergeNotations notations = mempty- <> [foldOrnaments ornaments] - <> [foldTechnical technical] - <> [foldArticulations articulations]- <> others- where- (ornaments,notations') = List.partition isOrnaments notations- (technical,notations'') = List.partition isTechnical notations'- (articulations,others) = List.partition isArticulations notations'-- isOrnaments (Ornaments _) = True- isOrnaments _ = False- isTechnical (Technical _) = True- isTechnical _ = False- isArticulations (Articulations _) = True- isArticulations _ = False- - foldOrnaments = foldr mergeN (Ornaments [])- foldTechnical = foldr mergeN (Technical [])- foldArticulations = foldr mergeN (Articulations [])- (Ornaments xs) `mergeN` (Ornaments ys) = Ornaments (xs <> ys)- (Technical xs) `mergeN` (Technical ys) = Technical (xs <> ys)- (Articulations xs) `mergeN` (Articulations ys) = Articulations (xs <> ys)---beginTuplet :: Music -> Music-endTuplet :: Music -> Music-beginTuplet = addNotation (Tuplet 1 Start)-endTuplet = addNotation (Tuplet 1 Stop)--beginBeam :: Music -> Music-continueBeam :: Music -> Music-endBeam :: Music -> Music-beginBeam = Music . fmap (modifyNoteProps (beginBeamP 1)) . getMusic-continueBeam = Music . fmap (modifyNoteProps (continueBeamP 1)) . getMusic-endBeam = Music . fmap (modifyNoteProps (endBeamP 1)) . getMusic--beginTie :: Music -> Music-endTie :: Music -> Music-beginTie = beginTie' . addNotation (Tied Start)-endTie = endTie' . addNotation (Tied Stop)-beginTie' = Music . fmap beginTie'' . getMusic-endTie' = Music . fmap endTie'' . getMusic-beginTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur (ties++[Start]) props))-beginTie'' x = x-endTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur ([Stop]++ties) props))-endTie'' x = x---setNoteValP v x = x { noteType = Just (v, Nothing) }-setVoiceP n x = x { noteVoice = Just (fromIntegral n) }-setTimeModP m n x = x { noteTimeMod = Just (fromIntegral m, fromIntegral n) }-beginBeamP n x = x { noteBeam = Just (fromIntegral n, BeginBeam) }-continueBeamP n x = x { noteBeam = Just (fromIntegral n, ContinueBeam) }-endBeamP n x = x { noteBeam = Just (fromIntegral n, EndBeam) }-dotP x@(NoteProps { noteDots = n@_ }) = x { noteDots = succ n }-addNotationP n x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (mergeNotations $ ns++[n]) }-mapNotationsP f x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (f ns) }-mapStemP f x@(NoteProps { noteStem = a@_ }) = x { noteNotations = (f a) }-mapNoteHeadP f x@(NoteProps { noteNoteHead = a@_ }) = x { noteNoteHead = (f a) }----- ------------------------------------------------------------------------------------beginGliss :: Music -> Music-endGliss :: Music -> Music-beginSlide :: Music -> Music-endSlide :: Music -> Music-beginGliss = addNotation (Glissando 1 Start Solid Nothing)-endGliss = addNotation (Glissando 1 Stop Solid Nothing)-beginSlide = addNotation (Slide 1 Start Solid Nothing)-endSlide = addNotation (Slide 1 Stop Solid Nothing)--arpeggiate :: Music -> Music-nonArpeggiate :: Music -> Music-arpeggiate = addNotation Arpeggiate-nonArpeggiate = addNotation NonArpeggiate----- ------------------------------------------------------------------------------------fermata :: FermataSign -> Music -> Music-breathMark :: Music -> Music-caesura :: Music -> Music-fermata = addNotation . Fermata-breathMark = addNotation (Articulations [BreathMark]) -caesura = addNotation (Articulations [Caesura]) ---- ------------------------------------------------------------------------------------addTechnical :: Technical -> Music -> Music-addTechnical x = addNotation (Technical [x])--addArticulation :: Articulation -> Music -> Music-addArticulation x = addNotation (Articulations [x])--upbow = addTechnical UpBow-downbow = addTechnical DownBow-harmonic = addTechnical Harmonic-openString = addTechnical OpenString---beginSlur :: Music -> Music-endSlur :: Music -> Music-beginSlur = addNotation (Slur 1 Start)-endSlur = addNotation (Slur 1 Stop)--accent :: Music -> Music-strongAccent :: Music -> Music-staccato :: Music -> Music-tenuto :: Music -> Music-detachedLegato :: Music -> Music-staccatissimo :: Music -> Music-spiccato :: Music -> Music-scoop :: Music -> Music-plop :: Music -> Music-doit :: Music -> Music-falloff :: Music -> Music-stress :: Music -> Music-unstress :: Music -> Music-accent = addNotation (Articulations [Accent]) -strongAccent = addNotation (Articulations [StrongAccent]) -staccato = addNotation (Articulations [Staccato]) -tenuto = addNotation (Articulations [Tenuto]) -detachedLegato = addNotation (Articulations [DetachedLegato]) -staccatissimo = addNotation (Articulations [Staccatissimo]) -spiccato = addNotation (Articulations [Spiccato]) -scoop = addNotation (Articulations [Scoop]) -plop = addNotation (Articulations [Plop]) -doit = addNotation (Articulations [Doit]) -falloff = addNotation (Articulations [Falloff]) -stress = addNotation (Articulations [Stress]) -unstress = addNotation (Articulations [Unstress]) ---- ------------------------------------------------------------------------------------cresc, dim :: Music -> Music-crescFrom, crescTo, dimFrom, dimTo :: Dynamics -> Music -> Music -crescFromTo, dimFromTo :: Dynamics -> Dynamics -> Music -> Music --cresc = \m -> beginCresc <> m <> endCresc-dim = \m -> beginDim <> m <> endDim--crescFrom x = \m -> dynamic x <> cresc m-crescTo x = \m -> cresc m <> dynamic x-crescFromTo x y = \m -> dynamic x <> cresc m <> dynamic y--dimFrom x = \m -> dynamic x <> dim m-dimTo x = \m -> dim m <> dynamic x-dimFromTo x y = \m -> dynamic x <> dim m <> dynamic y--beginCresc, endCresc, beginDim, endDim :: Music--beginCresc = Music $ [MusicDirection $ Crescendo Start]-endCresc = Music $ [MusicDirection $ Crescendo Stop]-beginDim = Music $ [MusicDirection $ Diminuendo Start]-endDim = Music $ [MusicDirection $ Diminuendo Stop]--dynamic :: Dynamics -> Music-dynamic level = Music $ [MusicDirection $ Dynamics level]--tuplet :: Int -> Int -> Music -> Music-tuplet m n (Music []) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ Music []-tuplet m n (Music [xs]) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ Music [xs]-tuplet m n (Music xs) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ setTimeMod m n $ (as <> bs <> cs)- where - as = beginTuplet $ Music [head xs]- bs = Music $ init (tail xs)- cs = endTuplet $ Music [last (tail xs)]--scaleDur x = mapMusic id (mapNote - (\f d t p -> (f,round $ fromIntegral d*x,t,p)) - (\f d p -> (f,round $ fromIntegral d*x,p)) - (\f t p -> (f,t,p))) id--beam :: Music -> Music-beam (Music []) = Music []-beam (Music [xs]) = Music [xs]-beam (Music xs) = (as <> bs <> cs)- where- as = beginBeam $ Music [head xs]- bs = continueBeam $ Music (init (tail xs))- cs = endBeam $ Music [last (tail xs)]--slur :: Music -> Music-slur (Music []) = Music []-slur (Music [xs]) = Music [xs]-slur (Music xs) = (as <> bs <> cs)- where- as = beginSlur $ Music [head xs]- bs = Music $ init (tail xs)- cs = endSlur $ Music [last (tail xs)]- --- TODO combine tuplet, beam, slur etc------------------------------------------------------------------------------------ * Ornaments--------------------------------------------------------------------------------tremolo :: Int -> Music -> Music-tremolo n = addNotation (Ornaments [(Tremolo $ fromIntegral n, [])])--trill :: Music -> Music-turn :: Bool -> Bool -> Music -> Music-shake :: Music -> Music-mordent :: Bool -> Music -> Music--trill = addOrnament TrillMark-turn delay invert = case (delay,invert) of- (False,False) -> addOrnament Turn- (True, False) -> addOrnament DelayedTurn- (False,True) -> addOrnament InvertedTurn- (True, True) -> addOrnament DelayedInvertedTurn--shake = addOrnament Shake-mordent invert = case invert of- False -> addOrnament Mordent- True -> addOrnament InvertedMordent--addOrnament a = addNotation (Ornaments [(a, [])])---- ------------------------------------------------------------------------------------- Text--- ------------------------------------------------------------------------------------text :: String -> Music-rehearsal :: String -> Music--text = Music . single . MusicDirection . Words-rehearsal = Music . single . MusicDirection . Rehearsal--segno, coda :: Music-segno = Music . single . MusicDirection $ Segno-coda = Music . single . MusicDirection $ Coda---- ------------------------------------------------------------------------------------mapNote fn fc fg = go- where - go (Note f d t p) = let (f',d',t',p') = fn f d t p in Note f' d' t' p'- go (CueNote f d p) = let (f',d',p') = fc f d p in CueNote f' d' p'- go (GraceNote f t p) = let (f',t',p') = fg f t p in GraceNote f' t' p'--mapMusic :: (Attributes -> Attributes) -> (Note -> Note) -> (Direction -> Direction) -> Music -> Music-mapMusic fa fn fd = foldMusic (MusicAttributes . fa) (MusicNote . fn) (MusicDirection . fd) (Music . return)--foldMusic :: Monoid m => (Attributes -> r) -> (Note -> r) -> (Direction -> r) -> (r -> m) -> Music -> m-foldMusic fa fn fd f = mconcat . fmap f . (foldMusic' $ fmap (foldMusicElem fa fn fd))--foldMusic' :: ([MusicElem] -> r) -> Music -> r-foldMusic' f (Music x) = f x--foldMusicElem :: (Attributes -> r) -> (Note -> r) -> (Direction -> r) -> MusicElem -> r-foldMusicElem = go- where go fa fn fd (MusicAttributes x) = fa x- go fa fn fd (MusicNote x) = fn x- go fa fn fd (MusicDirection x) = fd x---- ------------------------------------------------------------------------------------instance Default ScoreAttrs where- def = ScoreAttrs []--instance Default ScoreHeader where- def = ScoreHeader Nothing Nothing Nothing mempty--instance Default Note where- def = Note def def [] def--instance Default Divs where- def = defaultDivisionsVal--instance Default FullNote where- def = Rest noChord Nothing--instance Default NoteProps where- def = NoteProps Nothing Nothing (Just (1/4, Nothing)) 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] []--------------------------------------------------------------------------------------------logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a-logBaseR k n - | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1-logBaseR k n - | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1-logBaseR k n = logBase (fromRational k) (fromRational n)--isDivisibleBy :: (Real a, Real b) => a -> b -> Bool-isDivisibleBy n = (equalTo 0.0) . snd . properFraction . logBaseR (toRational n) . toRational--single x = [x]-equalTo = (==)--
− src/Music/MusicXml/Time.hs
@@ -1,87 +0,0 @@--{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------------------module Music.MusicXml.Time (- Duration(..),- NoteType(..),-- Divs(..),- NoteVal(..),- NoteSize(..),-- Beat(..),- BeatType(..),- - Tempo(..)- ) where--type Duration = Divs-type NoteType = (NoteVal, Maybe NoteSize)--newtype Divs = Divs { getDivs :: Int } -- ^ Sounding time in ticks-newtype NoteVal = NoteVal { getNoteVal :: Rational } -- ^ Notated time in fractions, in @[2^^i | i <- [-10..3]]@.--data NoteSize = SizeFull | SizeCue | SizeLarge--newtype Beat = Beat { getBeat :: Int } -- ^ Time nominator-newtype BeatType = BeatType { getBeatType :: Int } -- ^ Time denominator--newtype Tempo = Tempo { getTempo :: Double } -- ^ Tempo in BPM-----deriving instance Eq Divs-deriving instance Ord Divs-deriving instance Num Divs-deriving instance Real Divs-deriving instance Integral Divs-deriving instance Enum Divs-deriving instance Show Divs--deriving instance Eq NoteVal-deriving instance Ord NoteVal-deriving instance Num NoteVal-deriving instance Enum NoteVal-deriving instance Fractional NoteVal-deriving instance Real NoteVal-deriving instance RealFrac NoteVal-deriving instance Show NoteVal--deriving instance Eq NoteSize-deriving instance Ord NoteSize-deriving instance Enum NoteSize-deriving instance Bounded NoteSize--deriving instance Eq Beat-deriving instance Ord Beat-deriving instance Num Beat-deriving instance Enum Beat --deriving instance Eq BeatType-deriving instance Ord BeatType-deriving instance Num BeatType-deriving instance Enum BeatType--deriving instance Eq Tempo-deriving instance Ord Tempo-deriving instance Num Tempo-deriving instance Enum Tempo-deriving instance Fractional Tempo-deriving instance Real Tempo-deriving instance RealFrac Tempo-deriving instance Show Tempo--
− src/Music/MusicXml/Write.hs
@@ -1,23 +0,0 @@------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------------------module Music.MusicXml.Write (- WriteMusicXml(..)-- ) where--import Text.XML.Light (Element)--class WriteMusicXml a where- write :: a -> [Element]-
− src/Music/MusicXml/Write/Score.hs
@@ -1,578 +0,0 @@------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : portable-------------------------------------------------------------------------------------------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----- This instance is used by toXml and should return a single list-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)------- ------------------------------------------------------------------------------------- Part list--- ------------------------------------------------------------------------------------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---- ------------------------------------------------------------------------------------- Music--- ------------------------------------------------------------------------------------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)---- ------------------------------------------------------------------------------------- Attributes--- -------------------------------------------------------------------------------------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)]---- ------------------------------------------------------------------------------------- Notes--- ------------------------------------------------------------------------------------instance WriteMusicXml NoteProps where- write (NoteProps- instrument -- TODO- voice- typ- dots- accidental -- TODO- timeMod -- TODO- stem -- TODO- noteHead- noteHeadText -- TODO- staff -- TODO- beam- notations- lyrics) -- TODO- = mempty- -- TODO instrument- <> maybeOne (\n -> unode "voice" $ show n) voice- <> maybeOne (\(noteVal, noteSize) -> unode "type" (writeNoteVal noteVal)) typ- <> replicate (fromIntegral dots) (unode "dot" ())- -- TODO accidental- <> maybeOne (\(m, n) -> unode "time-modification" [- unode "actual-notes" (show m),- unode "normal-notes" (show n)- ]) timeMod- -- TODO stem- <> maybeOne (\(nh,_,_) -> unode "notehead" (writeNoteHead nh)) noteHead - -- TODO notehead-text- -- TODO staff- <> 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" ()------ ------------------------------------------------------------------------------------- Notations--- ------------------------------------------------------------------------------------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"------ ------------------------------------------------------------------------------------- Directions--- ------------------------------------------------------------------------------------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"----- ------------------------------------------------------------------------------------- Lyrics--- ------------------------------------------------------------------------------------instance WriteMusicXml Lyric where- write = notImplemented "WriteMusicXml instance for Lyric"----- ------------------------------------------------------------------------------------- Basic types--- -------------------------------------------------------------------------------------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) ()----- --------------------------------------------------------------------------------------- XML aliases--addAttr :: Attr -> Element -> Element-addAttrs :: [Attr] -> Element -> Element-addAttr = add_attr-addAttrs = add_attrs--uattr :: String -> String -> Attr-uattr n = Attr (unqual n)----- Misc--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