musicxml2 (empty) → 1.4
raw patch · 12 files changed
+2458/−0 lines, 12 filesdep +basedep +data-defaultdep +music-dynamics-literalsetup-changed
Dependencies added: base, data-default, music-dynamics-literal, music-pitch-literal, reverse-apply, semigroups, type-unary, xml
Files
- COPYING +26/−0
- Setup.hs +2/−0
- musicxml2.cabal +37/−0
- src/Music/MusicXml.hs +157/−0
- src/Music/MusicXml/Dynamics.hs +51/−0
- src/Music/MusicXml/Pitch.hs +115/−0
- src/Music/MusicXml/Read.hs +17/−0
- src/Music/MusicXml/Score.hs +600/−0
- src/Music/MusicXml/Simple.hs +770/−0
- src/Music/MusicXml/Time.hs +84/−0
- src/Music/MusicXml/Write.hs +23/−0
- src/Music/MusicXml/Write/Score.hs +576/−0
+ COPYING view
@@ -0,0 +1,26 @@++Copyright (c) 2013, Hans Höglund+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the <organization> nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ musicxml2.cabal view
@@ -0,0 +1,37 @@++name: musicxml2+version: 1.4+cabal-version: >= 1.2+author: Hans Hoglund+maintainer: Hans Hoglund+license: BSD3+license-file: COPYING+synopsis: A representation of the MusicXML format.+category: Music+tested-with: GHC+build-type: Simple++description: + A representation of the MusicXML format.++library + build-depends: + base >= 4 && < 5,+ semigroups, data-default, type-unary, reverse-apply,+ xml, + music-pitch-literal,+ music-dynamics-literal++ hs-source-dirs: src+ 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+
+ src/Music/MusicXml.hs view
@@ -0,0 +1,157 @@++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : portable+--+-- A Haskell representation of MusicXML.+--+-- For an introduction, 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(..),++ -- TODO rewrite these+ mapNoteProps,+ mapNoteProps2,++ -- ** 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 view
@@ -0,0 +1,51 @@++{-# 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 view
@@ -0,0 +1,115 @@++{-# 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 view
@@ -0,0 +1,17 @@++-------------------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,600 @@++{-# 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(..),+ mapNoteProps,+ mapNoteProps2,++ -----------------------------------------------------------------------------+ -- ** 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 -- TODO+ | MusicForward -- TODO+ | 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 = []++mapNoteProps :: (NoteProps -> NoteProps) -> Note -> Note+mapNoteProps f (Note x d t p) = Note x d t (f p)+mapNoteProps f (CueNote x d p) = CueNote x d (f p)+mapNoteProps f (GraceNote x t p) = GraceNote x t (f p)++mapNoteProps2 :: (NoteProps -> NoteProps) -> MusicElem -> MusicElem+mapNoteProps2 f (MusicNote n) = MusicNote (mapNoteProps f n)+mapNoteProps2 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 view
@@ -0,0 +1,770 @@++{-# 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+ -- partIds,+ -- header,+ -- setHeader,+ -- setTitle,+ -- setMvmTitle,++ -----------------------------------------------------------------------------+ -- * Top-level attributes+ -----------------------------------------------------------------------------++ -- ** Pitch+ trebleClef,+ altoClef,+ bassClef,+ defaultClef,+ clef, + defaultKey,+ key,++ -- ** Time+ defaultDivisions,+ divisions, + commonTime,+ cutTime,+ time,++ -- ** Tempo+ -- TODO #15 tempo+ metronome,+ metronome',+ + -----------------------------------------------------------------------------+ -- * 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+ -----------------------------------------------------------------------------+ + -- ** 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,++ ) +where++import Data.Default+import Data.Ratio+import Data.Monoid++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)+ (parts music) +++partIds :: [String]+partIds = [ "P" ++ show n | n <- [1..] ]++-- | +-- Create a part list from instrument names.+--+partList :: [String] -> PartList+partList = PartList . zipWith (\partId name -> Part partId name Nothing) partIds++-- | +-- Create a part list from instrument names and abbreviations.+--+partListAbbr :: [(String, String)] -> PartList+partListAbbr = PartList . zipWith (\partId (name,abbr) -> Part partId name (Just abbr)) partIds++-- | +-- 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 header (Partwise attrs _ music) = Partwise attrs header music+setHeader header (Timewise attrs _ music) = Timewise attrs header music++setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader title mvmTitle ident partList+setMvmTitle mvmTitle (ScoreHeader title _ ident partList) = ScoreHeader title (Just mvmTitle) ident partList+-- addIdent ident (ScoreHeader title mvmTitle idents partList) = ScoreHeader title mvmTitle (ident:idents) partList++parts :: [[Music]] -> [(PartAttrs, [(MeasureAttrs, Music)])]+parts = zipWith (\ids mus -> (PartAttrs ids, zipWith (\ids mus -> (MeasureAttrs ids, mus)) barIds mus)) partIds'+ where+ partIds' = partIds+ barIds = [1..]+ ++-- ----------------------------------------------------------------------------------+-- 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+++-- ----------------------------------------------------------------------------------+-- Notes+-- ----------------------------------------------------------------------------------++-- |+-- Create a rest.+--+-- > rest (1/4)+-- > rest (3/8)+-- > rest quarter+-- > rest (dotted eight)+--+rest :: NoteVal -> Music+rest dur = case dots of+ 0 -> rest' dur'+ 1 -> rest' dur' <> rest' (dur' / 2)+ _ -> error "Music.MusicXml.Simple.rest: to 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 (mapNoteProps2 (setVoiceP n)) . getMusic++dot :: Music -> Music+setNoteVal :: NoteVal -> Music -> Music+setTimeMod :: Int -> Int -> Music -> Music+dot = Music . fmap (mapNoteProps2 dotP) . getMusic+setNoteVal x = Music . fmap (mapNoteProps2 (setNoteValP x)) . getMusic+setTimeMod m n = Music . fmap (mapNoteProps2 (setTimeModP m n)) . getMusic++addNotation :: Notation -> Music -> Music+addNotation x = Music . fmap (mapNoteProps2 (addNotationP x)) . getMusic++setNoteHead :: NoteHead -> Music -> Music+setNoteHead x = Music . fmap (mapNoteProps2 (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 (mapNoteProps2 (beginBeamP 1)) . getMusic+continueBeam = Music . fmap (mapNoteProps2 (continueBeamP 1)) . getMusic+endBeam = Music . fmap (mapNoteProps2 (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]) ++-- ----------------------------------------------------------------------------------++beginSlur :: Music -> Music+endSlur :: Music -> Music+beginSlur = addNotation (Slur 1 Start)+endSlur = addNotation (Slur 1 Stop)++staccato :: Music -> Music+tenuto :: 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]+++-- FIXME should scale duration by inverse, see #1+tuplet :: Int -> Int -> Music -> Music+tuplet m n (Music []) = Music []+tuplet m n (Music [xs]) = Music [xs]+tuplet m n (Music xs) = setTimeMod m n $ (as <> bs <> cs)+ where+ as = beginTuplet $ Music [head xs]+ bs = Music $ init (tail xs)+ cs = endTuplet $ Music [last (tail xs)]++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+++-- ----------------------------------------------------------------------------------++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 [] []+++-- class HasDyn a where+-- mapLevel :: (Level -> Level) -> (a -> a)+-- +-- class HasPitch a where+-- mapPitch :: (Pitch -> Pitch) -> (a -> a)+-- +-- class HasPitch a => HasAcc a where+-- flatten :: a -> a+-- sharpen :: a -> a+-- mapAcc :: (Semitones -> Semitones) -> a -> a+-- flatten = mapAcc pred+-- sharpen = mapAcc succ++++-------------------------------------------------------------------------------------+++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 view
@@ -0,0 +1,84 @@++{-# 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 Show Tempo++
+ src/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 Music.MusicXml.Write (+ WriteMusicXml(..)++ ) where++import Text.XML.Light (Element)++class WriteMusicXml a where+ write :: a -> [Element]+
+ src/Music/MusicXml/Write/Score.hs view
@@ -0,0 +1,576 @@++-------------------------------------------------------------------------------------+-- |+-- 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)++-- ----------------------------------------------------------------------------------+-- 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