{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} module Fadno.Xml ( -- * Score and Part xmlScore,xmlPart,xmlPartClef -- * Bars ,xmlMeasure ,xmlPrependMeasureData,xmlPrependMeasureDatas ,xmlAppendMeasureData,xmlAppendMeasureDatas ,xmlClef,xmlClef' ,xmlKeySignature,toFifths ,xmlRepeats,xmlRepeats' ,xmlBarline,xmlBarline',xmlTimeSig,xmlRehearsalMark,xmlDirection -- * Notes ,xmlNote,xmlChord,xmlArticulation ,xmlTie,xmlBeams,xmlVoice,xmlSlur -- * Rendering ,renderFile,renderString,renderElement,Element -- * Internals ,convertDurR,xmlDivisions ) where import Fadno.MusicXml.MusicXml31 import Fadno.Xml.EmitXml import qualified Data.Map.Strict as M import qualified Fadno.Note as N import qualified Fadno.Notation as N import Data.List (mapAccumL) import Data.Maybe import GHC.Real import Control.Arrow import Text.XML.Light import Data.String import Control.Lens hiding (Empty) import Data.Foldable makeClassy_ ''ChxMusicData makeClassy_ ''Note makeClassy_ ''ChxNote makeClassy_ ''GrpFullNote makeClassy_ ''MusicData makeClassy_ ''Measure makeClassy_ ''ScorePartwise makeClassy_ ''ScoreHeader makeClassy_ ''Identification makeClassy_ ''PartList makeClassy_ ''CmpPart makeClassy_ ''EditorialVoice _testFile :: IO () _testFile = renderFile "output/newtest.xml" $ xmlScore "Test" "Stoobie" [xmlPartClef "Hurdy Gurdy" "HGy" N.TrebleClef [xmlMeasure "1" $ xmlChord _testNote]] -- | Hardcoded divisions. xmlDivisions :: PositiveDivisions xmlDivisions = 768 -- -- SCORE & PART -- type MeasureList f = (Traversable f, Cons (f Measure) (f Measure) Measure Measure, Snoc (f Measure) (f Measure) Measure Measure) -- | Partwise score. xmlScore :: String -> String -> [(CmpPart,ScorePart)] -> ScorePartwise xmlScore title composer xmlParts = (mkScorePartwise ((mkScoreHeader doPartList) { scoreHeaderMovementTitle = Just title , scoreHeaderIdentification = Just (mkIdentification { identificationCreator = [TypedText composer (Just "composer") ]}) }) ) { scorePartwisePart = toListOf (traverse._1) xmlParts } where doPartList = PartList [] (xmlParts ^?! _head._2) (map PartListScorePart (toListOf (_tail.traverse._2) xmlParts)) -- | Render partwise part and score parts. xmlPart :: MeasureList f => String -> String -> f Measure -> (CmpPart,ScorePart) xmlPart longName shortName measures = (CmpPart (fromString shortName) (toList $ addDivs measures), ScorePart (mkCmpScorePart (fromString shortName) (mkPartName (fromString longName))) { scorePartPartAbbreviation = Just (mkPartName (fromString shortName)) }) where addDivs = xmlPrependMeasureData (MusicDataAttributes ((mkAttributes mkEditorial) { attributesDivisions = Just xmlDivisions })) -- | Render partwise part with clef. xmlPartClef :: MeasureList f => String -> String -> N.Clef -> f Measure -> (CmpPart,ScorePart) xmlPartClef l s c ms = xmlPart l s (xmlPrependMeasureData (xmlClef' c) ms) -- -- BARS -- type ApplyMonoid c t = (Applicative c,Monoid (c t)) -- | Partwise measure. xmlMeasure :: Traversable t => String -> t ChxMusicData -> Measure xmlMeasure mNumber = mkMeasure (fromString mNumber) . MusicData . toList -- | Add datum to beginning of first measure xmlPrependMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure xmlPrependMeasureData = xmlPrependMeasureDatas . pure -- | Add data to beginning of first measure xmlPrependMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure xmlPrependMeasureDatas d = over (_head._measureMusicData._musicDataMusicData) (d <>) -- | Add datum to beginning of last measure xmlAppendMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure xmlAppendMeasureData = xmlAppendMeasureDatas . pure -- | Add data to beginning of last measure xmlAppendMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure xmlAppendMeasureDatas d = over (_last._measureMusicData._musicDataMusicData) (d <>) -- | Use a "Maybe Lens" to generate some or none of a datum. maybeMusicDatas :: (ApplyMonoid c t) => Getting (Maybe a) s (Maybe a) -> (a -> c t) -> s -> c t maybeMusicDatas l f = maybe mempty f . view l -- | Use a "Maybe Lens" to generate one or none of a datum. maybeMusicData :: (ApplyMonoid c t) => Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t maybeMusicData l f = maybeMusicDatas l (pure.f) -- | Clef in bar xmlClef :: (ApplyMonoid c ChxMusicData, N.HasClef a) => a -> c ChxMusicData xmlClef = maybeMusicData N.clef xmlClef' -- | Clef alone. xmlClef' :: N.Clef -> ChxMusicData xmlClef' c = case c of N.TrebleClef -> mkC ClefSignG 2 N.BassClef -> mkC ClefSignF 4 N.AltoClef -> mkC ClefSignC 3 N.PercClef -> mkC ClefSignPercussion 3 where mkC cs cl = MusicDataAttributes ((mkAttributes mkEditorial) { attributesClef = [(mkClef cs) { clefLine = Just cl }]}) xmlKeySignature :: N.Spelling -> ChxMusicData xmlKeySignature sp = MusicDataAttributes ((mkAttributes mkEditorial) { attributesKey = [ mkKey $ KeyTraditionalKey $ mkTraditionalKey (toFifths sp) ] } ) toFifths :: N.Spelling -> Fifths toFifths = \case N.C -> 0 N.G -> 1 N.D -> 2 N.A -> 3 N.E -> 4 N.B -> 5 N.Fs -> 6 N.Cs -> 7 N.Gs -> 8 -- totality only N.Ds -> 9 -- totality only N.As -> 10 -- totality only N.Es -> 11 -- totality only N.Bs -> 12 -- totality only N.Fb -> -8 -- totality only N.Cb -> -7 N.Gb -> -6 N.Db -> -5 N.Ab -> -4 N.Eb -> -3 N.Bb -> -2 N.F -> -1 -- | Measure barlines. xmlBarline :: (ApplyMonoid c ChxMusicData) => N.HasBarline a => a -> c ChxMusicData xmlBarline = xmlBarline' False -- | Measure barlines; flag determines if double bars are rendered to left (False) -- or right (True). xmlBarline' :: (ApplyMonoid c ChxMusicData) => Bool -> N.HasBarline a => a -> c ChxMusicData xmlBarline' renderDoubleLeft = maybeMusicData N.barline $ \b -> case b of N.Double -> mdBarline doublePos BarStyleLightLight Nothing N.Final -> mdBarline RightLeftMiddleRight BarStyleLightHeavy Nothing where doublePos | renderDoubleLeft = RightLeftMiddleLeft | otherwise = RightLeftMiddleRight -- | Measure repeats for a single measure. xmlRepeats :: (ApplyMonoid t ChxMusicData) => N.HasRepeats a => a -> t ChxMusicData xmlRepeats = maybeMusicDatas N.repeats $ \r -> case r of N.RStart -> pure startRepeat N.REnd -> pure endRepeat N.RBoth -> pure startRepeat <> pure endRepeat where startRepeat :: ChxMusicData startRepeat = mdBarline RightLeftMiddleLeft BarStyleHeavyLight (Just BackwardForwardForward) endRepeat :: ChxMusicData endRepeat = mdBarline RightLeftMiddleRight BarStyleLightHeavy (Just BackwardForwardBackward) -- | Measure repeats bracketing existing measures. xmlRepeats' :: (N.HasRepeats a, MeasureList f) => a -> f Measure -> f Measure xmlRepeats' s measures = case view N.repeats s of Nothing -> measures Just N.RStart -> doStart measures Just N.REnd -> doEnd measures Just N.RBoth -> doStart . doEnd $ measures where doStart = xmlPrependMeasureData startRepeat doEnd = xmlAppendMeasureData endRepeat -- | utility mdBarline :: RightLeftMiddle -> BarStyle -> Maybe BackwardForward -> ChxMusicData mdBarline rml bs bf = MusicDataBarline ((mkBarline mkEditorial) { barlineLocation = Just rml , barlineBarStyle = Just (mkBarStyleColor bs) , barlineRepeat = fmap mkRepeat bf }) -- | Measure time signature. xmlTimeSig :: (ApplyMonoid t ChxMusicData, N.HasTimeSignature a) => a -> t ChxMusicData xmlTimeSig = maybeMusicData N.timeSignature $ \(N.TimeSignature n q) -> MusicDataAttributes $ (mkAttributes mkEditorial) { attributesTime = [mkTime (TimeTimeSignature [ TimeSignature (fromString $ show n) (fromString $ show $ N.qToInt q) ] Nothing)]} -- | Measure rehearsal mark. xmlRehearsalMark :: (ApplyMonoid t ChxMusicData,N.HasRehearsalMark a) => a -> t ChxMusicData xmlRehearsalMark = maybeMusicData N.rehearsalMark (makeDirection . DirectionTypeRehearsal . return . mkFormattedTextId . view N.rehearsalText) -- | Measure direction. xmlDirection :: (ApplyMonoid t ChxMusicData,N.HasDirection a) => a -> t ChxMusicData xmlDirection = maybeMusicData N.direction (makeDirection . DirectionTypeDirectionType . return . DirectionTypeWords . mkFormattedTextId . view N.directionText) -- | Utility for direction types makeDirection :: ChxDirectionType -> ChxMusicData makeDirection dt = MusicDataDirection ((mkDirection mkEditorialVoiceDirection) { directionDirectionType = [mkDirectionType dt] , directionPlacement = Just AboveBelowAbove }) -- -- NOTES -- -- | render note/rest as xml xmlNote :: (N.HasNote a (N.Mono N.PitchRep) Rational) => a -> ChxMusicData xmlNote n = MusicDataNote (mkNote (ChxNoteFullNote (GrpFullNote Nothing (fullNote (view N.notePitch n))) (Duration durDivs) []) mkEditorialVoice) { noteType = Just (mkNoteType durNoteType) , noteDot = nds } where (durDivs,durNoteType,durDots) = convertDurR xmlDivisions $ view N.noteDur n nds = replicate durDots mkEmptyPlacement fullNote (N.M p) = FullNotePitch (convertPitchRep p) fullNote N.Rest = FullNoteRest mkRest -- | render notes as xml chord or rest. xmlChord :: (N.HasNote a [N.PitchRep] Rational) => a -> [ChxMusicData] xmlChord ch = case view N.notePitch ch of [] -> [doNote N.Rest] ps -> zipWith doChord [(0 :: Int)..] $ map (doNote.N.M) ps where doNote p = xmlNote (N.Note p (view N.noteDur ch)) doChord i | i == 0 = id | otherwise = set (_musicDataNote._noteNote._chxnoteFullNote1._fullNoteChord) (Just Empty) _testNote :: N.Note' [N.PitchRep] Rational _testNote = over N.nNote (view (bimapping (mapping N.pitchRep) (N.ratioPPQ N.PQ4))) N.testNote addNotations :: [Notations] -> ChxMusicData -> ChxMusicData addNotations ns = over (_musicDataNote._noteNotations) (++ ns) -- | Adapt a rendered note to account for tie information. -- > xmlTie testNote <$> xmlChord 128 testNote xmlTie :: (N.HasTie a) => a -> ChxMusicData -> ChxMusicData xmlTie a = addNotations (adapt mkTNot) . over (_musicDataNote._noteNote._chxnoteTie) (++adapt' mkTie) where adapt fc = maybe [] (fmap fc . conv) $ view N.tie a conv N.TStart = [TiedTypeStart] conv N.TStop = [TiedTypeStop] conv N.TBoth = [TiedTypeStop,TiedTypeStart] adapt' fc = maybe [] (fmap fc . conv') $ view N.tie a conv' N.TStart = [StartStopStart] conv' N.TStop = [StartStopStop] conv' N.TBoth = [StartStopStop,StartStopStart] mkTNot s = (mkNotations mkEditorial) {notationsNotations = [NotationsTied (mkTied s)]} -- | Add articulation to note. xmlArticulation :: N.HasArticulation a => a -> ChxMusicData -> ChxMusicData xmlArticulation a = addNotations $ case view N.articulation a of Nothing -> [] Just a' -> pure $ (mkNotations mkEditorial) { notationsNotations = [ NotationsArticulations (mkArticulations { articulationsArticulations = [ case a' of N.Accent -> ArticulationsAccent mkEmptyPlacement N.Staccato -> ArticulationsStaccato mkEmptyPlacement -- N.StrongAccent -> ArticulationsStrongAccent TODO implement after fixing fadno-xml #7 N.Tenuto -> ArticulationsTenuto mkEmptyPlacement N.DetachedLegato -> ArticulationsDetachedLegato mkEmptyPlacement N.Staccatissimo -> ArticulationsStaccatissimo mkEmptyPlacement N.Spiccato -> ArticulationsSpiccato mkEmptyPlacement N.Scoop -> ArticulationsScoop mkEmptyLine N.Plop -> ArticulationsPlop mkEmptyLine N.Doit -> ArticulationsDoit mkEmptyLine N.Falloff -> ArticulationsFalloff mkEmptyLine N.BreathMark -> ArticulationsBreathMark (mkBreathMark BreathMarkValue) N.Caesura -> ArticulationsCaesura (mkCaesura CaesuraValueNormal) N.Stress -> ArticulationsStress mkEmptyPlacement N.Unstress -> ArticulationsUnstress mkEmptyPlacement N.SoftAccent -> ArticulationsSoftAccent mkEmptyPlacement N.OtherArticulation s -> ArticulationsOtherArticulation (mkOtherPlacementText s) ] } ) ] } xmlSlur :: N.HasSlur a => a -> ChxMusicData -> ChxMusicData xmlSlur a = addNotations $ case view N.slur a of Nothing -> [] Just a' -> pure $ (mkNotations mkEditorial) { notationsNotations = [ NotationsSlur (mkSlur $ case a' of N.SStart -> StartStopContinueStart N.SStop -> StartStopContinueStop) ] } -- | Add beams, numbering from first beam in list, to note. xmlBeams :: N.HasBeams a => a -> ChxMusicData -> ChxMusicData xmlBeams a = over (_musicDataNote._noteBeam) (++ zipWith bs (view N.beams a) [1..]) where bs b i = (mkBeam (toX b)) { beamNumber = Just i } toX = \case N.BeamBegin -> BeamValueBegin N.BeamContinue -> BeamValueContinue N.BeamEnd -> BeamValueEnd N.BeamForwardHook -> BeamValueForwardHook N.BeamBackwardHook -> BeamValueBackwardHook xmlVoice :: N.HasVoice a => a -> ChxMusicData -> ChxMusicData xmlVoice a = case view N.voice a of Nothing -> id Just v -> set ( _musicDataNote . _noteEditorialVoice . _editorialVoiceVoice) (Just (Voice (show v))) -- | Steps and enharmonics. _steps :: [(Step,Maybe Semitones)] _steps = [(StepC,Nothing), (StepC,sharp), (StepD,Nothing), (StepE,flat), (StepE,Nothing), (StepF,Nothing), (StepF,sharp), (StepG,Nothing), (StepA,flat), (StepA,Nothing), (StepB,flat), (StepB,Nothing)] where sharp = Just 1 flat = Just (-1) -- | Note values indexed by powers of two. [(1,Long) .. (1024,256th)] noteTypeValues :: M.Map Int NoteTypeValue noteTypeValues = M.fromList $ snd $ mapAccumL acc (256*4) [minBound .. maxBound] where acc v nt = (v `div` 2,(v,nt)) -- | Int pitch to xml. TODO C3 vs C4? _convertPitch :: Int -> Pitch _convertPitch i = Pitch step semi oct where oct = fromIntegral $ (i `div` 12) - 1 (step, semi) = _steps !! (i `mod` 12) convertPitchRep :: N.PitchRep -> Pitch convertPitchRep (N.PitchRep s o) = Pitch step semi (fromIntegral o) where (step,semi) = ss s sharp = Just 1 flat = Just (-1) ss N.C = (StepC,Nothing) ss N.Cs = (StepC,sharp) ss N.Db = (StepD,flat) ss N.D = (StepD,Nothing) ss N.Ds = (StepD,sharp) ss N.Eb = (StepE,flat) ss N.E = (StepE,Nothing) ss N.Fb = (StepE,Nothing) ss N.Es = (StepF,Nothing) ss N.F = (StepF,Nothing) ss N.Fs = (StepF,sharp) ss N.Gb = (StepG,flat) ss N.G = (StepG,Nothing) ss N.Gs = (StepG,sharp) ss N.Ab = (StepA,flat) ss N.A = (StepA,Nothing) ss N.As = (StepA,sharp) ss N.Bb = (StepB,flat) ss N.B = (StepB,Nothing) ss N.Cb = (StepB,Nothing) ss N.Bs = (StepC,Nothing) -- | Int duration/PPQ to xml values. _convertDur :: N.PPQ -> Int -> PositiveDivisions -> (PositiveDivisions,NoteTypeValue,Int) _convertDur ppq dur xdivs = (fromIntegral divs,findValue,dots) where ppqd = N.ppqDiv ppq divs = floor xdivs * dur `div` ppqd (num,denom) = numerator &&& denominator $ (dur % (ppqd * 16)) dots = fromMaybe 0 $ M.lookup num dotValues findValue = fromMaybe NoteTypeValue256th $ M.lookup (denom `div` (2 ^ dots)) noteTypeValues -- | Rational duration (ie, '1 % 4' for quarter note) to xml values. convertDurR :: PositiveDivisions -> Rational -> (PositiveDivisions,NoteTypeValue,Int) convertDurR xdivs r' = (fromIntegral divs,findValue,dots) where r = reduce (numerator r') (denominator r') divs :: Int divs = floor $ toRational xdivs * (r * 4) (num,denom) = numerator &&& denominator $ r dots = fromMaybe 0 $ M.lookup (fromIntegral num) dotValues findValue = fromMaybe NoteTypeValue256th $ M.lookup (fromIntegral denom `div` (2 ^ dots)) noteTypeValues -- | Numerator values to dots. dotValues :: M.Map Int Int dotValues = M.fromList $ takeWhile (<= 1024) (dot 3 4) `zip` [1..] where dot v i = v:dot (v + i) (i * 2)