music-score-1.3: src/Music/Score/Export/MusicXml.hs
{-# LANGUAGE
TypeFamilies,
DeriveFunctor,
DeriveFoldable,
DeriveDataTypeable,
GeneralizedNewtypeDeriving,
FlexibleContexts,
ConstraintKinds,
TypeOperators,
OverloadedStrings,
NoMonomorphismRestriction #-}
-------------------------------------------------------------------------------------
-- |
-- Copyright : (c) Hans Hoglund 2012
--
-- License : BSD-style
--
-- Maintainer : hans@hanshoglund.se
-- Stability : experimental
-- Portability : non-portable (TF,GNTD)
--
-------------------------------------------------------------------------------------
module Music.Score.Export.MusicXml (
XmlScore,
XmlMusic,
HasMusicXml(..),
toXml,
writeXml,
openXml,
toXmlVoice,
toXmlSingle,
writeXmlSingle,
openXmlSingle,
) where
import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)
import Data.Semigroup
import Data.Ratio
import Data.String
import Control.Applicative
import Control.Monad hiding (mapM)
import Control.Monad.Plus
import Data.Maybe
import Data.Either
import Data.Foldable
import Data.Typeable
import Data.Traversable
import Data.Function (on)
import Data.Ord (comparing)
import Data.VectorSpace
import Data.AffineSpace
import Data.Basis
import Music.Time
import Music.Pitch.Literal
import Music.Dynamics.Literal
import Music.Score.Rhythm
import Music.Score.Track
import Music.Score.Voice
import Music.Score.Score
import Music.Score.Combinators
import Music.Score.Zip
import Music.Score.Pitch
import Music.Score.Ties
import Music.Score.Part
import Music.Score.Articulation
import Music.Score.Dynamics
import Music.Score.Ornaments
import Music.Score.Instances
import Music.Score.Export.Util
import qualified Codec.Midi as Midi
import qualified Music.MusicXml.Simple as Xml
import qualified Music.Lilypond as Lilypond
import qualified Text.Pretty as Pretty
import qualified Data.Map as Map
import qualified Data.List as List
type XmlScore = Xml.Score
type XmlMusic = Xml.Music
-- |
-- Class of types that can be converted to MusicXML.
--
class Tiable a => HasMusicXml a where
-- |
-- Convert a value to MusicXML.
--
-- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it
-- to add beams, slurs, dynamics, articulation etc.
--
getMusicXml :: DurationT -> a -> XmlMusic
instance HasMusicXml Int where getMusicXml d = getMusicXml d . toInteger
instance HasMusicXml Float where getMusicXml d = getMusicXml d . toInteger . round
instance HasMusicXml Double where getMusicXml d = getMusicXml d . toInteger . round
instance Integral a => HasMusicXml (Ratio a) where getMusicXml d = getMusicXml d . toInteger . round
-- instance HasMusicXml a => HasMusicXml (Maybe a) where getMusicXml d = ?
instance HasMusicXml Integer where
getMusicXml d p = Xml.note (spellXml (fromIntegral p)) . fromDurationT $ d
instance HasMusicXml a => HasMusicXml (PartT n a) where
getMusicXml d (PartT (_,x)) = getMusicXml d x
instance HasMusicXml a => HasMusicXml (TieT a) where
getMusicXml d (TieT (ta,x,tb)) = addTies $ getMusicXml d x
where
addTies | ta && tb = Xml.endTie . Xml.beginTie
| tb = Xml.beginTie
| ta = Xml.endTie
| otherwise = id
instance HasMusicXml a => HasMusicXml (DynamicT a) where
getMusicXml d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getMusicXml d a
where
notate x = nec <> ned <> nl <> nbc <> nbd <> x
nec = if ec then Xml.endCresc else mempty
ned = if ed then Xml.endDim else mempty
nbc = if bc then Xml.beginCresc else mempty
nbd = if bd then Xml.beginDim else mempty
nl = case l of
Nothing -> mempty
Just lvl -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing)))
instance HasMusicXml a => HasMusicXml (ArticulationT a) where
getMusicXml d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getMusicXml d a
where
notate = nes . nal . nsl . nbs
nes = if es then Xml.endSlur else id
nal = case al of
0 -> id
1 -> Xml.accent
2 -> Xml.strongAccent
nsl = case sl of
(-2) -> Xml.tenuto
(-1) -> Xml.tenuto . Xml.staccato
0 -> id
1 -> Xml.staccato
2 -> Xml.staccatissimo
nbs = if bs then Xml.beginSlur else id
instance HasMusicXml a => HasMusicXml (TremoloT a) where
getMusicXml d (TremoloT (n,x)) = notate $ getMusicXml d x
where
notate = case n of
0 -> id
_ -> Xml.tremolo n
instance HasMusicXml a => HasMusicXml (TextT a) where
getMusicXml d (TextT (s,x)) = notate s $ getMusicXml d x
where
notate ts a = mconcat (fmap Xml.text ts) <> a
instance HasMusicXml a => HasMusicXml (HarmonicT a) where
getMusicXml d (HarmonicT (n,x)) = notate $ getMusicXml d x
where
notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead
| otherwise = id
-- TODO adjust pitch etc
instance HasMusicXml a => HasMusicXml (SlideT a) where
getMusicXml d (SlideT (eg,es,a,bg,bs)) = notate $ getMusicXml d a
where
notate = neg . nes . nbg . nbs
neg = if es then Xml.endGliss else id
nes = if es then Xml.endSlide else id
nbg = if es then Xml.beginGliss else id
nbs = if es then Xml.beginSlide else id
-- |
-- Convert a score to MusicXML and write to a file.
--
writeXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => FilePath -> Score a -> IO ()
writeXml path sc = writeFile path (Xml.showXml $ toXml sc)
-- |
-- Convert a score to MusicXML and open it.
--
openXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> IO ()
openXml sc = do
writeXml "test.xml" sc
execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]
-- FIXME hardcoded
-- |
-- Convert a score to MusicXML and write to a file.
--
writeXmlSingle :: HasMusicXml a => FilePath -> Score a -> IO ()
writeXmlSingle path sc = writeFile path (Xml.showXml $ toXmlSingle sc)
-- |
-- Convert a score to MusicXML and open it.
--
openXmlSingle :: HasMusicXml a => Score a -> IO ()
openXmlSingle sc = do
writeXmlSingle "test.xml" sc
execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]
-- FIXME hardcoded
-- |
-- Convert a score to a MusicXML representation.
--
toXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> XmlScore
toXml sc = Xml.fromParts "Title" "Composer" pl . fmap (toXmlVoice' . scoreToVoice) . extract $ sc
where
pl = Xml.partList (fmap show $ getParts sc)
-- |
-- Convert a single-voice score to a MusicXML representation.
--
toXmlSingle :: HasMusicXml a => Score a -> XmlScore
toXmlSingle = toXmlVoice . scoreToVoice
-- |
-- Convert a single-voice score to a MusicXML representation.
--
toXmlVoice :: HasMusicXml a => Voice (Maybe a) -> XmlScore
toXmlVoice = Xml.fromPart "Title" "Composer" "Voice" . toXmlVoice'
-- |
-- Convert a voice score to a list of bars.
--
toXmlVoice' :: HasMusicXml a => Voice (Maybe a) -> [XmlMusic]
toXmlVoice' =
addDefaultSignatures . fmap barToXml . voiceToBars
where
addDefaultSignatures [] = []
addDefaultSignatures (x:xs) = (defaultSignatures <> x):xs
defaultSignatures = mempty
<> Xml.defaultKey
<> Xml.defaultDivisions
<> Xml.metronome (1/4) 60
<> Xml.commonTime
barToXml :: HasMusicXml a => [(DurationT, Maybe a)] -> Xml.Music
barToXml bar = case quantize bar of
Left e -> error $ "barToXml: Could not quantize this bar: " ++ show e
Right rh -> rhythmToXml rh
rhythmToXml :: HasMusicXml a => Rhythm (Maybe a) -> Xml.Music
rhythmToXml (Beat d x) = noteRestToXml d x
rhythmToXml (Group rs) = mconcat $ map rhythmToXml rs
rhythmToXml (Dotted n (Beat d x)) = noteRestToXml (dotMod n * d) x
rhythmToXml (Tuplet m r) = Xml.tuplet b a (rhythmToXml r)
where (a,b) = both fromIntegral fromIntegral $ unRatio $ fromDurationT m
noteRestToXml :: HasMusicXml a => DurationT -> Maybe a -> Xml.Music
noteRestToXml d Nothing = setDefaultVoice $ Xml.rest $ fromDurationT d
noteRestToXml d (Just p) = setDefaultVoice $ getMusicXml d p
-- FIXME only works for single-voice parts
setDefaultVoice :: Xml.Music -> Xml.Music
setDefaultVoice = Xml.setVoice 1
-- FIXME arbitrary spelling, please modularize...
spellXml :: Integer -> Xml.Pitch
spellXml p = (
toEnum $ fromIntegral pc,
if alt == 0 then Nothing else Just (fromIntegral alt),
fromIntegral oct
)
where (pc,alt,oct) = spellPitch p