fadno 1.1.8 → 1.1.9.1

raw patch · 7 files changed

+185/−46 lines, 7 filesdep ~basedep ~fadno-xmlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, fadno-xml

API changes (from Hackage documentation)

Files

• fadno.cabal +4/−3
• src/Fadno/Meter.hs +0/−2
• src/Fadno/Midi.hs +4/−5
• src/Fadno/Notation.hs +60/−16
• src/Fadno/Note.hs +7/−4
• src/Fadno/Util.hs +1/−4
• src/Fadno/Xml.hs +109/−12

@@ -1,7 +1,7 @@ name:                fadno category:            Music synopsis:            Minimal library for music generation and notation-version:             1.1.8+version:             1.1.9.1 homepage:            http://github.com/slpopejoy/fadno description:         Provides the Note type and HasNote class with polymorphic pitch and duration representations,                      metering, barring and time signature utilities, plus midi and MusicXML support.@@ -29,11 +29,11 @@   -- other-extensions:   build-depends:       Decimal >= 0.4                      , HUnit >= 1.5-                     , base >= 4.9 && < 4.15+                     , base >= 4.9 && < 4.20                      , containers >= 0.5                      , data-default >= 0.7                      , event-list >= 0.1-                     , fadno-xml >= 1.2+                     , fadno-xml >= 1.2.1                      , lens >= 4.15                      , midi >= 0.2                      , mtl >= 2.2@@ -45,6 +45,7 @@                      , xml >= 1.3   hs-source-dirs: src   default-language:    Haskell2010+  ghc-options: -Wall  test-suite tests   type: exitcode-stdio-1.0

@@ -11,7 +11,6 @@ import Fadno.Note import Control.Lens hiding (Empty,pre) import Data.Foldable-import Test.HUnit import Data.Ratio import GHC.Real import Data.Maybe@@ -20,7 +19,6 @@ import Control.Arrow import qualified Data.Map.Strict as M import Safe-import Fadno.Util  type HasRatioNotes t n p = (Traversable t, HasNote n p Rational) 

@@ -23,7 +23,6 @@ import Control.Arrow import System.Process import Control.Monad-import Data.Ratio  -- | Serializable midi data. type MidiData = MFile.T@@ -120,7 +119,7 @@ makeTrack :: [MidiEvent] -> MidiTrack makeTrack = fromPairList . concat . snd . mapAccumL conv 0     where conv :: IDur -> MidiEvent -> (IDur,[(ElapsedTime,MEvent.T)])-          conv _ (Pad dur) = (dur,[])+          conv _ (Pad dur') = (dur',[])           conv off (Event e) = (0,[(toElapsedTime $ fromIntegral off,e)])  @@ -153,7 +152,7 @@  -- | note on + note off events, using 'Pad' to carve out space. noteEvents :: MidiChan -> MidiVelocity -> ([IPitch],IDur) -> [MidiEvent]-noteEvents chan vel (ps,dur) = evs noteOn ++ [Pad dur] ++ evs noteOff+noteEvents chan vel (ps,dur') = evs noteOn ++ [Pad dur'] ++ evs noteOff     where evs f = map (f chan vel . fromIntegral) ps  -- TODO: figure out polymorphic way to attach velocity and anything else to notes.@@ -161,8 +160,8 @@ -- | note on or note off event. noteEvent :: (Pitch -> Velocity -> MVoice.T) ->              MidiChan -> MidiVelocity -> IPitch -> MidiEvent-noteEvent f chan vel pitch = voiceEvent chan-                             (f (toPitch (fromIntegral pitch))+noteEvent f chan vel pitch' = voiceEvent chan+                             (f (toPitch (fromIntegral pitch'))                                     (toVelocity $ fromIntegral vel)) noteOn :: MidiChan -> MidiVelocity -> IPitch -> MidiEvent noteOn = noteEvent NoteOn

@@ -17,7 +17,6 @@ module Fadno.Notation where  import GHC.Generics-import Data.Semigroup import Data.String import Data.Default import Fadno.Note@@ -26,7 +25,6 @@ import Data.Ratio import Data.Sequence (Seq,fromList) import Data.Foldable-import Test.HUnit import Data.List import Data.Maybe @@ -84,9 +82,9 @@   -- | Duration iso, from Integral to Rational, given PPQ-ratioPPQ :: Integral a => PPQ -> Iso' a Rational+ratioPPQ :: forall a . Integral a => PPQ -> Iso' a Rational ratioPPQ p = iso toRat toInt where-    ppq4 = ppqDiv p * 4+    ppq4 = ppqDiv p * (4 :: a)     toRat i = fromIntegral i % fromIntegral ppq4     toInt r = truncate (r * toRational ppq4) @@ -120,8 +118,25 @@ instance HasSlur Slur where slur = adaptHas  -- | Note articulations.-data Articulation = Staccato | Accent-    deriving (Eq,Show,Bounded,Enum,Ord)+data Articulation+    = Staccato+    | Accent+    -- | StrongAccent TODO implement after fixing fadno-xml #7+    | Tenuto+    | DetachedLegato+    | Staccatissimo+    | Spiccato+    | Scoop+    | Plop+    | Doit+    | Falloff+    | BreathMark+    | Caesura+    | Stress+    | Unstress+    | SoftAccent+    | OtherArticulation String+    deriving (Eq,Show,Ord) class HasArticulation a where articulation :: Lens' a (Maybe Articulation) instance HasArticulation Articulation where articulation = adaptHas @@ -159,7 +174,22 @@ class HasClef a where clef :: Lens' a (Maybe Clef) instance HasClef Clef where clef = adaptHas +-- | Adapts musicxml Beams where beams are labeled "1" for eighth beam etc,+-- where instead it is a list implying the first element is eighth etc.+data Beam+    = BeamBegin+    | BeamContinue+    | BeamEnd+    | BeamForwardHook+    | BeamBackwardHook+    deriving (Eq,Bounded,Enum,Ord,Show)+class HasBeams a where beams :: Lens' a [Beam]+instance HasBeams [Beam] where beams = ($) +class HasVoice a where voice :: Lens' a (Maybe String)+++ -- | Part identifier, prefers 'Num' or 'IsString' values. newtype Part a = Part { _partIdx :: a }     deriving (Eq,Generic,Ord,Functor,Bounded,Foldable,Traversable,Real,Num,IsString)@@ -178,31 +208,45 @@ -- Example types.  -- | Note with notations.-data Note' p d = Note' {-      _nNote :: Note p d++type Note' p d = Noted (Note p d)++data Noted n = Noted {+      _nNote :: n     , _nTie :: Maybe Tie     , _nSlur :: Maybe Slur     , _nArticulation :: Maybe Articulation-    } deriving (Eq,Generic)+    , _nBeams :: [Beam]+    , _nVoice :: Maybe String+    } deriving (Eq,Generic,Functor,Foldable,Traversable) -makeLenses ''Note'+makeLenses ''Noted instance HasNote (Note' p d) p d where     note = nNote     fromNote = note' . view note-instance HasTie (Note' p d) where tie = nTie-instance HasSlur (Note' p d) where slur = nSlur-instance HasArticulation (Note' p d) where articulation = nArticulation-instance (Show p, Show d) => Show (Note' p d) where-    show n = mshows n ("note' (" ++ show (view nNote n) ++ ")")+instance HasTie (Noted n) where tie = nTie+instance HasSlur (Noted n) where slur = nSlur+instance HasArticulation (Noted n) where articulation = nArticulation+instance HasBeams (Noted n) where beams = nBeams+instance HasVoice (Noted n) where voice = nVoice+instance (Show n) => Show (Noted n) where+    show n = mshows n (show (view nNote n))              [mshow tie "tie"              ,mshow slur "slur"              ,mshow articulation "articulation"+             ,const $ case view beams n of+                 [] -> ""+                 bs -> " & beams .= " ++ show bs+             ,mshow voice "voice"              ]   -- | Note smart ctor, used in 'Show'. note' :: Note p d -> Note' p d-note' n = Note' n Nothing Nothing Nothing+note' = noted++noted :: n -> Noted n+noted n = Noted n Nothing Nothing Nothing [] Nothing  testNote :: Note' [Int] Int testNote = note' ([60]|:2) & tie ?~ TStart & articulation ?~ Accent

@@ -26,7 +26,6 @@ import Control.Lens import Control.Arrow import Data.Ratio-import Data.Semigroup import GHC.Generics (Generic) import Data.Traversable import Data.Function@@ -34,7 +33,7 @@  -- | Note = pitch and duration. data Note p d = Note { _pitch :: p, _dur :: d }-                deriving (Eq,Generic)+                deriving (Eq,Generic,Functor) $(makeLenses ''Note)  instance (Show p, Show d) => Show (Note p d) where@@ -123,7 +122,7 @@   -- | Chroma as enharmonic names.-data Spelling = C|Cs|Db|D|Ds|Eb|E|F|Fs|Gb|G|Gs|Ab|A|As|Bb|B+data Spelling = C|Cs|Db|D|Ds|Eb|E|Fb|Es|F|Fs|Gb|G|Gs|Ab|A|As|Bb|B|Cb|Bs             deriving (Eq,Show,Read,Enum,Ord,Bounded,Generic)  -- | Convert to 'Spelling' with 0==C, using 'Cs','Eb','Fs','Gs','Bb' enharmonics.@@ -152,6 +151,8 @@ toChroma Ds = 3 toChroma Eb = 3 toChroma E = 4+toChroma Fb = 4+toChroma Es = 5 toChroma F = 5 toChroma Fs = 6 toChroma Gb = 6@@ -162,6 +163,8 @@ toChroma As = 10 toChroma Bb = 10 toChroma B = 11+toChroma Cb = 11+toChroma Bs = 0  -- | 'Spelling'-to-chroma degenerate 'Iso'. spelling :: Integral a => Iso' a Spelling@@ -192,7 +195,7 @@     fromEnum = fromIntegral . toInteger  instance Ord PitchRep where-    a <= b = fromIntegral a <= fromIntegral b+    a <= b = (fromIntegral a :: Integer) <= fromIntegral b  instance Real PitchRep where     toRational (PitchRep s o) = (((fromIntegral o + 1) * 12) + toChroma s) % 1

@@ -1,14 +1,12 @@ {-# LANGUAGE RankNTypes #-} module Fadno.Util where -import Control.Applicative-import Control.Monad (replicateM)-import Test.HUnit import Data.List import Data.Function (on) import qualified Debug.Trace as T import qualified Data.Map as M import qualified Data.Set as S+import Control.Monad import Control.Monad.State import Control.Lens @@ -101,7 +99,6 @@     alts = nub $ map (\x -> normalize . sort $ map (modg . (x+)) norm) [0..(gamut-1)]     -- compute "values" as distance from head, reversed     vals = map (\x -> reverse $ map (flip (-) (head x)) x) alts-    min = minimum vals     in fst . minimumBy (compare `on` snd) $ zip alts vals  

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-}@@ -11,11 +12,12 @@     ,xmlPrependMeasureData,xmlPrependMeasureDatas     ,xmlAppendMeasureData,xmlAppendMeasureDatas     ,xmlClef,xmlClef'+    ,xmlKeySignature,toFifths     ,xmlRepeats,xmlRepeats'     ,xmlBarline,xmlBarline',xmlTimeSig,xmlRehearsalMark,xmlDirection     -- * Notes-    ,xmlNote,xmlChord-    ,xmlTie+    ,xmlNote,xmlChord,xmlArticulation+    ,xmlTie,xmlBeams,xmlVoice,xmlSlur     -- * Rendering     ,renderFile,renderString,renderElement,Element     -- * Internals@@ -36,7 +38,6 @@ import Data.String import Control.Lens hiding (Empty) import Data.Foldable-import Data.Monoid   makeClassy_ ''ChxMusicData@@ -51,6 +52,7 @@ makeClassy_ ''Identification makeClassy_ ''PartList makeClassy_ ''CmpPart+makeClassy_ ''EditorialVoice   @@ -163,7 +165,37 @@                { 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@@ -248,7 +280,8 @@ makeDirection :: ChxDirectionType -> ChxMusicData makeDirection dt = MusicDataDirection                         ((mkDirection mkEditorialVoiceDirection)-                         { directionDirectionType = [mkDirectionType dt] })+                         { directionDirectionType = [mkDirectionType dt]+                         , directionPlacement = Just AboveBelowAbove })   @@ -290,10 +323,13 @@ _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 = over (_musicDataNote._noteNotations) (++adapt mkTNot) .+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]@@ -306,9 +342,66 @@           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),+_steps :: [(Step,Maybe Semitones)]+_steps = [(StepC,Nothing),          (StepC,sharp),          (StepD,Nothing),          (StepE,flat),@@ -329,10 +422,10 @@     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+_convertPitch :: Int -> Pitch+_convertPitch i = Pitch step semi oct where     oct = fromIntegral $ (i `div` 12) - 1-    (step, semi) = steps !! (i `mod` 12)+    (step, semi) = _steps !! (i `mod` 12)  convertPitchRep :: N.PitchRep -> Pitch convertPitchRep (N.PitchRep s o) = Pitch step semi (fromIntegral o)@@ -346,6 +439,8 @@           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)@@ -356,11 +451,13 @@           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)+_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