{-# 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'
    ,xmlRepeats,xmlRepeats'
    ,xmlBarline,xmlTimeSig,xmlRehearsalMark,xmlDirection
    -- * Notes
    ,xmlNote,xmlChord
    ,xmlTie
    -- * 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
import Data.Monoid


makeClassy_ ''ChxMusicData
makeClassy_ ''Note
makeClassy_ ''ChxNote
makeClassy_ ''GrpFullNote
makeClassy_ ''MusicData
makeClassy_ ''Measure

makeClassy_ ''ScorePartwise
makeClassy_ ''ScoreHeader
makeClassy_ ''Identification
makeClassy_ ''PartList
makeClassy_ ''CmpPart



_testFile :: IO ()
_testFile :: IO ()
_testFile = String -> ScorePartwise -> IO ()
forall a. EmitXml a => String -> a -> IO ()
renderFile String
"output/newtest.xml" (ScorePartwise -> IO ()) -> ScorePartwise -> IO ()
forall a b. (a -> b) -> a -> b
$
           String -> String -> [(CmpPart, ScorePart)] -> ScorePartwise
xmlScore String
"Test" String
"Stoobie"
           [String -> String -> Clef -> [Measure] -> (CmpPart, ScorePart)
forall (f :: * -> *).
MeasureList f =>
String -> String -> Clef -> f Measure -> (CmpPart, ScorePart)
xmlPartClef String
"Hurdy Gurdy" String
"HGy" Clef
N.TrebleClef
            [String -> [ChxMusicData] -> Measure
forall (t :: * -> *).
Traversable t =>
String -> t ChxMusicData -> Measure
xmlMeasure String
"1" ([ChxMusicData] -> Measure) -> [ChxMusicData] -> Measure
forall a b. (a -> b) -> a -> b
$ Note' [PitchRep] Rational -> [ChxMusicData]
forall a. HasNote a [PitchRep] Rational => a -> [ChxMusicData]
xmlChord Note' [PitchRep] Rational
_testNote]]



-- | Hardcoded divisions.
xmlDivisions :: PositiveDivisions
xmlDivisions :: PositiveDivisions
xmlDivisions = PositiveDivisions
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 :: String -> String -> [(CmpPart, ScorePart)] -> ScorePartwise
xmlScore String
title String
composer [(CmpPart, ScorePart)]
xmlParts =
    (ScoreHeader -> ScorePartwise
mkScorePartwise
     ((PartList -> ScoreHeader
mkScoreHeader PartList
doPartList)
      { scoreHeaderMovementTitle :: Maybe String
scoreHeaderMovementTitle = String -> Maybe String
forall a. a -> Maybe a
Just String
title
      , scoreHeaderIdentification :: Maybe Identification
scoreHeaderIdentification =
          Identification -> Maybe Identification
forall a. a -> Maybe a
Just (Identification
mkIdentification
                { identificationCreator :: [TypedText]
identificationCreator =
                  [String -> Maybe Token -> TypedText
TypedText String
composer (Token -> Maybe Token
forall a. a -> Maybe a
Just Token
"composer") ]}) })
        ) { scorePartwisePart :: [CmpPart]
scorePartwisePart = Getting (Endo [CmpPart]) [(CmpPart, ScorePart)] CmpPart
-> [(CmpPart, ScorePart)] -> [CmpPart]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (((CmpPart, ScorePart)
 -> Const (Endo [CmpPart]) (CmpPart, ScorePart))
-> [(CmpPart, ScorePart)]
-> Const (Endo [CmpPart]) [(CmpPart, ScorePart)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse(((CmpPart, ScorePart)
  -> Const (Endo [CmpPart]) (CmpPart, ScorePart))
 -> [(CmpPart, ScorePart)]
 -> Const (Endo [CmpPart]) [(CmpPart, ScorePart)])
-> ((CmpPart -> Const (Endo [CmpPart]) CmpPart)
    -> (CmpPart, ScorePart)
    -> Const (Endo [CmpPart]) (CmpPart, ScorePart))
-> Getting (Endo [CmpPart]) [(CmpPart, ScorePart)] CmpPart
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CmpPart -> Const (Endo [CmpPart]) CmpPart)
-> (CmpPart, ScorePart)
-> Const (Endo [CmpPart]) (CmpPart, ScorePart)
forall s t a b. Field1 s t a b => Lens s t a b
_1) [(CmpPart, ScorePart)]
xmlParts }
    where
      doPartList :: PartList
doPartList =
          [GrpPartGroup] -> ScorePart -> [ChxPartList] -> PartList
PartList []
          ([(CmpPart, ScorePart)]
xmlParts [(CmpPart, ScorePart)]
-> Getting (Endo ScorePart) [(CmpPart, ScorePart)] ScorePart
-> ScorePart
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! ((CmpPart, ScorePart)
 -> Const (Endo ScorePart) (CmpPart, ScorePart))
-> [(CmpPart, ScorePart)]
-> Const (Endo ScorePart) [(CmpPart, ScorePart)]
forall s a. Cons s s a a => Traversal' s a
_head(((CmpPart, ScorePart)
  -> Const (Endo ScorePart) (CmpPart, ScorePart))
 -> [(CmpPart, ScorePart)]
 -> Const (Endo ScorePart) [(CmpPart, ScorePart)])
-> ((ScorePart -> Const (Endo ScorePart) ScorePart)
    -> (CmpPart, ScorePart)
    -> Const (Endo ScorePart) (CmpPart, ScorePart))
-> Getting (Endo ScorePart) [(CmpPart, ScorePart)] ScorePart
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ScorePart -> Const (Endo ScorePart) ScorePart)
-> (CmpPart, ScorePart)
-> Const (Endo ScorePart) (CmpPart, ScorePart)
forall s t a b. Field2 s t a b => Lens s t a b
_2)
          ((ScorePart -> ChxPartList) -> [ScorePart] -> [ChxPartList]
forall a b. (a -> b) -> [a] -> [b]
map ScorePart -> ChxPartList
PartListScorePart (Getting (Endo [ScorePart]) [(CmpPart, ScorePart)] ScorePart
-> [(CmpPart, ScorePart)] -> [ScorePart]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (([(CmpPart, ScorePart)]
 -> Const (Endo [ScorePart]) [(CmpPart, ScorePart)])
-> [(CmpPart, ScorePart)]
-> Const (Endo [ScorePart]) [(CmpPart, ScorePart)]
forall s a. Cons s s a a => Traversal' s s
_tail(([(CmpPart, ScorePart)]
  -> Const (Endo [ScorePart]) [(CmpPart, ScorePart)])
 -> [(CmpPart, ScorePart)]
 -> Const (Endo [ScorePart]) [(CmpPart, ScorePart)])
-> Getting (Endo [ScorePart]) [(CmpPart, ScorePart)] ScorePart
-> Getting (Endo [ScorePart]) [(CmpPart, ScorePart)] ScorePart
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((CmpPart, ScorePart)
 -> Const (Endo [ScorePart]) (CmpPart, ScorePart))
-> [(CmpPart, ScorePart)]
-> Const (Endo [ScorePart]) [(CmpPart, ScorePart)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse(((CmpPart, ScorePart)
  -> Const (Endo [ScorePart]) (CmpPart, ScorePart))
 -> [(CmpPart, ScorePart)]
 -> Const (Endo [ScorePart]) [(CmpPart, ScorePart)])
-> ((ScorePart -> Const (Endo [ScorePart]) ScorePart)
    -> (CmpPart, ScorePart)
    -> Const (Endo [ScorePart]) (CmpPart, ScorePart))
-> Getting (Endo [ScorePart]) [(CmpPart, ScorePart)] ScorePart
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ScorePart -> Const (Endo [ScorePart]) ScorePart)
-> (CmpPart, ScorePart)
-> Const (Endo [ScorePart]) (CmpPart, ScorePart)
forall s t a b. Field2 s t a b => Lens s t a b
_2) [(CmpPart, ScorePart)]
xmlParts))


-- | Render partwise part and score parts.
xmlPart :: MeasureList f => String -> String -> f Measure -> (CmpPart,ScorePart)
xmlPart :: String -> String -> f Measure -> (CmpPart, ScorePart)
xmlPart String
longName String
shortName f Measure
measures =
    (IDREF -> [Measure] -> CmpPart
CmpPart (String -> IDREF
forall a. IsString a => String -> a
fromString String
shortName) (f Measure -> [Measure]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (f Measure -> [Measure]) -> f Measure -> [Measure]
forall a b. (a -> b) -> a -> b
$ f Measure -> f Measure
addDivs f Measure
measures),
     CmpScorePart -> ScorePart
ScorePart
     (ID -> PartName -> CmpScorePart
mkCmpScorePart (String -> ID
forall a. IsString a => String -> a
fromString String
shortName)
      (String -> PartName
mkPartName (String -> String
forall a. IsString a => String -> a
fromString String
longName)))
     { scorePartPartAbbreviation :: Maybe PartName
scorePartPartAbbreviation =
       PartName -> Maybe PartName
forall a. a -> Maybe a
Just (String -> PartName
mkPartName (String -> String
forall a. IsString a => String -> a
fromString String
shortName)) })
    where addDivs :: f Measure -> f Measure
addDivs = ChxMusicData -> f Measure -> f Measure
forall (f :: * -> *).
MeasureList f =>
ChxMusicData -> f Measure -> f Measure
xmlPrependMeasureData
                    (Attributes -> ChxMusicData
MusicDataAttributes
                      ((Editorial -> Attributes
mkAttributes Editorial
mkEditorial)
                       { attributesDivisions :: Maybe PositiveDivisions
attributesDivisions = PositiveDivisions -> Maybe PositiveDivisions
forall a. a -> Maybe a
Just PositiveDivisions
xmlDivisions }))

-- | Render partwise part with clef.
xmlPartClef :: MeasureList f => String -> String -> N.Clef -> f Measure -> (CmpPart,ScorePart)
xmlPartClef :: String -> String -> Clef -> f Measure -> (CmpPart, ScorePart)
xmlPartClef String
l String
s Clef
c f Measure
ms = String -> String -> f Measure -> (CmpPart, ScorePart)
forall (f :: * -> *).
MeasureList f =>
String -> String -> f Measure -> (CmpPart, ScorePart)
xmlPart String
l String
s (ChxMusicData -> f Measure -> f Measure
forall (f :: * -> *).
MeasureList f =>
ChxMusicData -> f Measure -> f Measure
xmlPrependMeasureData (Clef -> ChxMusicData
xmlClef' Clef
c) f Measure
ms)


--
-- BARS
--

type ApplyMonoid c t = (Applicative c,Monoid (c t))

-- | Partwise measure.
xmlMeasure :: Traversable t => String -> t ChxMusicData -> Measure
xmlMeasure :: String -> t ChxMusicData -> Measure
xmlMeasure String
mNumber = Token -> MusicData -> Measure
mkMeasure (String -> Token
forall a. IsString a => String -> a
fromString String
mNumber) (MusicData -> Measure)
-> (t ChxMusicData -> MusicData) -> t ChxMusicData -> Measure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChxMusicData] -> MusicData
MusicData ([ChxMusicData] -> MusicData)
-> (t ChxMusicData -> [ChxMusicData])
-> t ChxMusicData
-> MusicData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t ChxMusicData -> [ChxMusicData]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Add datum to beginning of first measure
xmlPrependMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure
xmlPrependMeasureData :: ChxMusicData -> f Measure -> f Measure
xmlPrependMeasureData = [ChxMusicData] -> f Measure -> f Measure
forall (f :: * -> *).
MeasureList f =>
[ChxMusicData] -> f Measure -> f Measure
xmlPrependMeasureDatas ([ChxMusicData] -> f Measure -> f Measure)
-> (ChxMusicData -> [ChxMusicData])
-> ChxMusicData
-> f Measure
-> f Measure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChxMusicData -> [ChxMusicData]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Add data to beginning of first measure
xmlPrependMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure
xmlPrependMeasureDatas :: [ChxMusicData] -> f Measure -> f Measure
xmlPrependMeasureDatas [ChxMusicData]
d = ASetter (f Measure) (f Measure) [ChxMusicData] [ChxMusicData]
-> ([ChxMusicData] -> [ChxMusicData]) -> f Measure -> f Measure
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Measure -> Identity Measure) -> f Measure -> Identity (f Measure)
forall s a. Cons s s a a => Traversal' s a
_head((Measure -> Identity Measure)
 -> f Measure -> Identity (f Measure))
-> (([ChxMusicData] -> Identity [ChxMusicData])
    -> Measure -> Identity Measure)
-> ASetter (f Measure) (f Measure) [ChxMusicData] [ChxMusicData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(MusicData -> Identity MusicData) -> Measure -> Identity Measure
forall c. HasMeasure c => Lens' c MusicData
_measureMusicData((MusicData -> Identity MusicData) -> Measure -> Identity Measure)
-> (([ChxMusicData] -> Identity [ChxMusicData])
    -> MusicData -> Identity MusicData)
-> ([ChxMusicData] -> Identity [ChxMusicData])
-> Measure
-> Identity Measure
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([ChxMusicData] -> Identity [ChxMusicData])
-> MusicData -> Identity MusicData
forall c. HasMusicData c => Lens' c [ChxMusicData]
_musicDataMusicData) ([ChxMusicData]
d [ChxMusicData] -> [ChxMusicData] -> [ChxMusicData]
forall a. Semigroup a => a -> a -> a
<>)

-- | Add datum to beginning of last measure
xmlAppendMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure
xmlAppendMeasureData :: ChxMusicData -> f Measure -> f Measure
xmlAppendMeasureData = [ChxMusicData] -> f Measure -> f Measure
forall (f :: * -> *).
MeasureList f =>
[ChxMusicData] -> f Measure -> f Measure
xmlAppendMeasureDatas ([ChxMusicData] -> f Measure -> f Measure)
-> (ChxMusicData -> [ChxMusicData])
-> ChxMusicData
-> f Measure
-> f Measure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChxMusicData -> [ChxMusicData]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Add data to beginning of last measure
xmlAppendMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure
xmlAppendMeasureDatas :: [ChxMusicData] -> f Measure -> f Measure
xmlAppendMeasureDatas [ChxMusicData]
d = ASetter (f Measure) (f Measure) [ChxMusicData] [ChxMusicData]
-> ([ChxMusicData] -> [ChxMusicData]) -> f Measure -> f Measure
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Measure -> Identity Measure) -> f Measure -> Identity (f Measure)
forall s a. Snoc s s a a => Traversal' s a
_last((Measure -> Identity Measure)
 -> f Measure -> Identity (f Measure))
-> (([ChxMusicData] -> Identity [ChxMusicData])
    -> Measure -> Identity Measure)
-> ASetter (f Measure) (f Measure) [ChxMusicData] [ChxMusicData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(MusicData -> Identity MusicData) -> Measure -> Identity Measure
forall c. HasMeasure c => Lens' c MusicData
_measureMusicData((MusicData -> Identity MusicData) -> Measure -> Identity Measure)
-> (([ChxMusicData] -> Identity [ChxMusicData])
    -> MusicData -> Identity MusicData)
-> ([ChxMusicData] -> Identity [ChxMusicData])
-> Measure
-> Identity Measure
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([ChxMusicData] -> Identity [ChxMusicData])
-> MusicData -> Identity MusicData
forall c. HasMusicData c => Lens' c [ChxMusicData]
_musicDataMusicData) ([ChxMusicData]
d [ChxMusicData] -> [ChxMusicData] -> [ChxMusicData]
forall a. Semigroup a => a -> a -> a
<>)


-- | 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 :: Getting (Maybe a) s (Maybe a) -> (a -> c t) -> s -> c t
maybeMusicDatas Getting (Maybe a) s (Maybe a)
l a -> c t
f = c t -> (a -> c t) -> Maybe a -> c t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe c t
forall a. Monoid a => a
mempty a -> c t
f (Maybe a -> c t) -> (s -> Maybe a) -> s -> c t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe a) s (Maybe a) -> s -> Maybe a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe a) s (Maybe a)
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 :: Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t
maybeMusicData Getting (Maybe a) s (Maybe a)
l a -> t
f = Getting (Maybe a) s (Maybe a) -> (a -> c t) -> s -> c t
forall (c :: * -> *) t a s.
ApplyMonoid c t =>
Getting (Maybe a) s (Maybe a) -> (a -> c t) -> s -> c t
maybeMusicDatas Getting (Maybe a) s (Maybe a)
l (t -> c t
forall (f :: * -> *) a. Applicative f => a -> f a
pure(t -> c t) -> (a -> t) -> a -> c t
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> t
f)

-- | Clef in bar
xmlClef :: (ApplyMonoid c ChxMusicData, N.HasClef a) => a -> c ChxMusicData
xmlClef :: a -> c ChxMusicData
xmlClef = Getting (Maybe Clef) a (Maybe Clef)
-> (Clef -> ChxMusicData) -> a -> c ChxMusicData
forall (c :: * -> *) t a s.
ApplyMonoid c t =>
Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t
maybeMusicData Getting (Maybe Clef) a (Maybe Clef)
forall a. HasClef a => Lens' a (Maybe Clef)
N.clef Clef -> ChxMusicData
xmlClef'

-- | Clef alone.
xmlClef' :: N.Clef -> ChxMusicData
xmlClef' :: Clef -> ChxMusicData
xmlClef' Clef
c =
    case Clef
c of
      Clef
N.TrebleClef -> ClefSign -> StaffLine -> ChxMusicData
mkC ClefSign
ClefSignG StaffLine
2
      Clef
N.BassClef -> ClefSign -> StaffLine -> ChxMusicData
mkC ClefSign
ClefSignF StaffLine
4
      Clef
N.AltoClef -> ClefSign -> StaffLine -> ChxMusicData
mkC ClefSign
ClefSignC StaffLine
3
      Clef
N.PercClef -> ClefSign -> StaffLine -> ChxMusicData
mkC ClefSign
ClefSignPercussion StaffLine
3
    where mkC :: ClefSign -> StaffLine -> ChxMusicData
mkC ClefSign
cs StaffLine
cl =
              Attributes -> ChxMusicData
MusicDataAttributes
              ((Editorial -> Attributes
mkAttributes Editorial
mkEditorial)
               { attributesClef :: [Clef]
attributesClef = [(ClefSign -> Clef
mkClef ClefSign
cs)
                                   { clefLine :: Maybe StaffLine
clefLine = StaffLine -> Maybe StaffLine
forall a. a -> Maybe a
Just StaffLine
cl }]})


-- | Measure barlines.
xmlBarline :: (ApplyMonoid c ChxMusicData) => N.HasBarline a => a -> c ChxMusicData
xmlBarline :: a -> c ChxMusicData
xmlBarline = Bool -> HasBarline a => a -> c ChxMusicData
forall (c :: * -> *) a.
ApplyMonoid c ChxMusicData =>
Bool -> HasBarline a => a -> c ChxMusicData
xmlBarline' Bool
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' :: Bool -> HasBarline a => a -> c ChxMusicData
xmlBarline' Bool
renderDoubleLeft = Getting (Maybe Barline) a (Maybe Barline)
-> (Barline -> ChxMusicData) -> a -> c ChxMusicData
forall (c :: * -> *) t a s.
ApplyMonoid c t =>
Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t
maybeMusicData Getting (Maybe Barline) a (Maybe Barline)
forall a. HasBarline a => Lens' a (Maybe Barline)
N.barline ((Barline -> ChxMusicData) -> a -> c ChxMusicData)
-> (Barline -> ChxMusicData) -> a -> c ChxMusicData
forall a b. (a -> b) -> a -> b
$ \Barline
b ->
  case Barline
b of
    Barline
N.Double -> RightLeftMiddle
-> BarStyle -> Maybe BackwardForward -> ChxMusicData
mdBarline RightLeftMiddle
doublePos
                BarStyle
BarStyleLightLight Maybe BackwardForward
forall a. Maybe a
Nothing
    Barline
N.Final -> RightLeftMiddle
-> BarStyle -> Maybe BackwardForward -> ChxMusicData
mdBarline RightLeftMiddle
RightLeftMiddleRight
               BarStyle
BarStyleLightHeavy Maybe BackwardForward
forall a. Maybe a
Nothing
  where
    doublePos :: RightLeftMiddle
doublePos | Bool
renderDoubleLeft = RightLeftMiddle
RightLeftMiddleLeft
              | Bool
otherwise = RightLeftMiddle
RightLeftMiddleRight

-- | Measure repeats for a single measure.
xmlRepeats :: (ApplyMonoid t ChxMusicData) => N.HasRepeats a => a -> t ChxMusicData
xmlRepeats :: a -> t ChxMusicData
xmlRepeats = Getting (Maybe Repeats) a (Maybe Repeats)
-> (Repeats -> t ChxMusicData) -> a -> t ChxMusicData
forall (c :: * -> *) t a s.
ApplyMonoid c t =>
Getting (Maybe a) s (Maybe a) -> (a -> c t) -> s -> c t
maybeMusicDatas Getting (Maybe Repeats) a (Maybe Repeats)
forall a. HasRepeats a => Lens' a (Maybe Repeats)
N.repeats ((Repeats -> t ChxMusicData) -> a -> t ChxMusicData)
-> (Repeats -> t ChxMusicData) -> a -> t ChxMusicData
forall a b. (a -> b) -> a -> b
$ \Repeats
r ->
     case Repeats
r of
        Repeats
N.RStart -> ChxMusicData -> t ChxMusicData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChxMusicData
startRepeat
        Repeats
N.REnd -> ChxMusicData -> t ChxMusicData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChxMusicData
endRepeat
        Repeats
N.RBoth -> ChxMusicData -> t ChxMusicData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChxMusicData
startRepeat t ChxMusicData -> t ChxMusicData -> t ChxMusicData
forall a. Semigroup a => a -> a -> a
<> ChxMusicData -> t ChxMusicData
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChxMusicData
endRepeat
    where

startRepeat :: ChxMusicData
startRepeat :: ChxMusicData
startRepeat = RightLeftMiddle
-> BarStyle -> Maybe BackwardForward -> ChxMusicData
mdBarline RightLeftMiddle
RightLeftMiddleLeft
              BarStyle
BarStyleHeavyLight (BackwardForward -> Maybe BackwardForward
forall a. a -> Maybe a
Just BackwardForward
BackwardForwardForward)
endRepeat :: ChxMusicData
endRepeat :: ChxMusicData
endRepeat = RightLeftMiddle
-> BarStyle -> Maybe BackwardForward -> ChxMusicData
mdBarline RightLeftMiddle
RightLeftMiddleRight
            BarStyle
BarStyleLightHeavy (BackwardForward -> Maybe BackwardForward
forall a. a -> Maybe a
Just BackwardForward
BackwardForwardBackward)

-- | Measure repeats bracketing existing measures.
xmlRepeats' :: (N.HasRepeats a, MeasureList f) => a -> f Measure -> f Measure
xmlRepeats' :: a -> f Measure -> f Measure
xmlRepeats' a
s f Measure
measures =
    case Getting (Maybe Repeats) a (Maybe Repeats) -> a -> Maybe Repeats
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Repeats) a (Maybe Repeats)
forall a. HasRepeats a => Lens' a (Maybe Repeats)
N.repeats a
s of
      Maybe Repeats
Nothing -> f Measure
measures
      Just Repeats
N.RStart -> f Measure -> f Measure
doStart f Measure
measures
      Just Repeats
N.REnd -> f Measure -> f Measure
doEnd f Measure
measures
      Just Repeats
N.RBoth -> f Measure -> f Measure
doStart (f Measure -> f Measure)
-> (f Measure -> f Measure) -> f Measure -> f Measure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Measure -> f Measure
doEnd (f Measure -> f Measure) -> f Measure -> f Measure
forall a b. (a -> b) -> a -> b
$ f Measure
measures
    where doStart :: f Measure -> f Measure
doStart = ChxMusicData -> f Measure -> f Measure
forall (f :: * -> *).
MeasureList f =>
ChxMusicData -> f Measure -> f Measure
xmlPrependMeasureData ChxMusicData
startRepeat
          doEnd :: f Measure -> f Measure
doEnd = ChxMusicData -> f Measure -> f Measure
forall (f :: * -> *).
MeasureList f =>
ChxMusicData -> f Measure -> f Measure
xmlAppendMeasureData ChxMusicData
endRepeat

-- | utility
mdBarline :: RightLeftMiddle -> BarStyle ->
             Maybe BackwardForward -> ChxMusicData
mdBarline :: RightLeftMiddle
-> BarStyle -> Maybe BackwardForward -> ChxMusicData
mdBarline RightLeftMiddle
rml BarStyle
bs Maybe BackwardForward
bf =
    Barline -> ChxMusicData
MusicDataBarline
    ((Editorial -> Barline
mkBarline Editorial
mkEditorial)
     { barlineLocation :: Maybe RightLeftMiddle
barlineLocation = RightLeftMiddle -> Maybe RightLeftMiddle
forall a. a -> Maybe a
Just RightLeftMiddle
rml
     , barlineBarStyle :: Maybe BarStyleColor
barlineBarStyle = BarStyleColor -> Maybe BarStyleColor
forall a. a -> Maybe a
Just (BarStyle -> BarStyleColor
mkBarStyleColor BarStyle
bs)
     , barlineRepeat :: Maybe Repeat
barlineRepeat = (BackwardForward -> Repeat)
-> Maybe BackwardForward -> Maybe Repeat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BackwardForward -> Repeat
mkRepeat Maybe BackwardForward
bf })

-- | Measure time signature.
xmlTimeSig :: (ApplyMonoid t ChxMusicData, N.HasTimeSignature a) => a -> t ChxMusicData
xmlTimeSig :: a -> t ChxMusicData
xmlTimeSig = Getting (Maybe TimeSignature) a (Maybe TimeSignature)
-> (TimeSignature -> ChxMusicData) -> a -> t ChxMusicData
forall (c :: * -> *) t a s.
ApplyMonoid c t =>
Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t
maybeMusicData Getting (Maybe TimeSignature) a (Maybe TimeSignature)
forall a. HasTimeSignature a => Lens' a (Maybe TimeSignature)
N.timeSignature ((TimeSignature -> ChxMusicData) -> a -> t ChxMusicData)
-> (TimeSignature -> ChxMusicData) -> a -> t ChxMusicData
forall a b. (a -> b) -> a -> b
$ \(N.TimeSignature Int
n Quanta
q) ->
       Attributes -> ChxMusicData
MusicDataAttributes (Attributes -> ChxMusicData) -> Attributes -> ChxMusicData
forall a b. (a -> b) -> a -> b
$
       (Editorial -> Attributes
mkAttributes Editorial
mkEditorial)
        { attributesTime :: [Time]
attributesTime =
          [ChxTime -> Time
mkTime ([TimeSignature] -> Maybe Interchangeable -> ChxTime
TimeTimeSignature
                   [ String -> String -> TimeSignature
TimeSignature
                     (String -> String
forall a. IsString a => String -> a
fromString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n)
                     (String -> String
forall a. IsString a => String -> a
fromString (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Quanta -> Int
N.qToInt Quanta
q)
                   ]
                   Maybe Interchangeable
forall a. Maybe a
Nothing)]}

-- | Measure rehearsal mark.
xmlRehearsalMark :: (ApplyMonoid t ChxMusicData,N.HasRehearsalMark a) => a -> t ChxMusicData
xmlRehearsalMark :: a -> t ChxMusicData
xmlRehearsalMark = Getting (Maybe RehearsalMark) a (Maybe RehearsalMark)
-> (RehearsalMark -> ChxMusicData) -> a -> t ChxMusicData
forall (c :: * -> *) t a s.
ApplyMonoid c t =>
Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t
maybeMusicData Getting (Maybe RehearsalMark) a (Maybe RehearsalMark)
forall a. HasRehearsalMark a => Lens' a (Maybe RehearsalMark)
N.rehearsalMark
               (ChxDirectionType -> ChxMusicData
makeDirection (ChxDirectionType -> ChxMusicData)
-> (RehearsalMark -> ChxDirectionType)
-> RehearsalMark
-> ChxMusicData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FormattedTextId] -> ChxDirectionType
DirectionTypeRehearsal ([FormattedTextId] -> ChxDirectionType)
-> (RehearsalMark -> [FormattedTextId])
-> RehearsalMark
-> ChxDirectionType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormattedTextId -> [FormattedTextId]
forall (m :: * -> *) a. Monad m => a -> m a
return (FormattedTextId -> [FormattedTextId])
-> (RehearsalMark -> FormattedTextId)
-> RehearsalMark
-> [FormattedTextId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                String -> FormattedTextId
mkFormattedTextId (String -> FormattedTextId)
-> (RehearsalMark -> String) -> RehearsalMark -> FormattedTextId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting String RehearsalMark String -> RehearsalMark -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String RehearsalMark String
Iso' RehearsalMark String
N.rehearsalText)

-- | Measure direction.
xmlDirection :: (ApplyMonoid t ChxMusicData,N.HasDirection a) => a -> t ChxMusicData
xmlDirection :: a -> t ChxMusicData
xmlDirection = Getting (Maybe Direction) a (Maybe Direction)
-> (Direction -> ChxMusicData) -> a -> t ChxMusicData
forall (c :: * -> *) t a s.
ApplyMonoid c t =>
Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t
maybeMusicData Getting (Maybe Direction) a (Maybe Direction)
forall a. HasDirection a => Lens' a (Maybe Direction)
N.direction
                   (ChxDirectionType -> ChxMusicData
makeDirection (ChxDirectionType -> ChxMusicData)
-> (Direction -> ChxDirectionType) -> Direction -> ChxMusicData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChxDirectionType0] -> ChxDirectionType
DirectionTypeDirectionType ([ChxDirectionType0] -> ChxDirectionType)
-> (Direction -> [ChxDirectionType0])
-> Direction
-> ChxDirectionType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChxDirectionType0 -> [ChxDirectionType0]
forall (m :: * -> *) a. Monad m => a -> m a
return (ChxDirectionType0 -> [ChxDirectionType0])
-> (Direction -> ChxDirectionType0)
-> Direction
-> [ChxDirectionType0]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormattedTextId -> ChxDirectionType0
DirectionTypeWords (FormattedTextId -> ChxDirectionType0)
-> (Direction -> FormattedTextId) -> Direction -> ChxDirectionType0
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    String -> FormattedTextId
mkFormattedTextId (String -> FormattedTextId)
-> (Direction -> String) -> Direction -> FormattedTextId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting String Direction String -> Direction -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Direction String
Iso' Direction String
N.directionText)

-- | Utility for direction types
makeDirection :: ChxDirectionType -> ChxMusicData
makeDirection :: ChxDirectionType -> ChxMusicData
makeDirection ChxDirectionType
dt = Direction -> ChxMusicData
MusicDataDirection
                        ((EditorialVoiceDirection -> Direction
mkDirection EditorialVoiceDirection
mkEditorialVoiceDirection)
                         { directionDirectionType :: [DirectionType]
directionDirectionType = [ChxDirectionType -> DirectionType
mkDirectionType ChxDirectionType
dt] })



--
-- NOTES
--



-- | render note/rest as xml
xmlNote :: (N.HasNote a (N.Mono N.PitchRep) Rational) => a -> ChxMusicData
xmlNote :: a -> ChxMusicData
xmlNote a
n = Note -> ChxMusicData
MusicDataNote
            (ChxNote -> EditorialVoice -> Note
mkNote (GrpFullNote -> Duration -> [Tie] -> ChxNote
ChxNoteFullNote
                     (Maybe Empty -> FullNote -> GrpFullNote
GrpFullNote Maybe Empty
forall a. Maybe a
Nothing
                      (Mono PitchRep -> FullNote
fullNote (Getting (Mono PitchRep) a (Mono PitchRep) -> a -> Mono PitchRep
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Mono PitchRep) a (Mono PitchRep)
forall s p d. HasNote s p d => Lens' s p
N.notePitch a
n)))
                     (PositiveDivisions -> Duration
Duration PositiveDivisions
durDivs) [])
             EditorialVoice
mkEditorialVoice)
            { noteType :: Maybe NoteType
noteType = NoteType -> Maybe NoteType
forall a. a -> Maybe a
Just (NoteTypeValue -> NoteType
mkNoteType NoteTypeValue
durNoteType)
            , noteDot :: [EmptyPlacement]
noteDot = [EmptyPlacement]
nds }
    where (PositiveDivisions
durDivs,NoteTypeValue
durNoteType,Int
durDots) = PositiveDivisions
-> Rational -> (PositiveDivisions, NoteTypeValue, Int)
convertDurR PositiveDivisions
xmlDivisions (Rational -> (PositiveDivisions, NoteTypeValue, Int))
-> Rational -> (PositiveDivisions, NoteTypeValue, Int)
forall a b. (a -> b) -> a -> b
$ Getting Rational a Rational -> a -> Rational
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Rational a Rational
forall s p d. HasNote s p d => Lens' s d
N.noteDur a
n
          nds :: [EmptyPlacement]
nds = Int -> EmptyPlacement -> [EmptyPlacement]
forall a. Int -> a -> [a]
replicate Int
durDots EmptyPlacement
mkEmptyPlacement
          fullNote :: Mono PitchRep -> FullNote
fullNote (N.M PitchRep
p) = Pitch -> FullNote
FullNotePitch (PitchRep -> Pitch
convertPitchRep PitchRep
p)
          fullNote Mono PitchRep
N.Rest = Rest -> FullNote
FullNoteRest Rest
mkRest

-- | render notes as xml chord or rest.
xmlChord :: (N.HasNote a [N.PitchRep] Rational) =>
            a -> [ChxMusicData]
xmlChord :: a -> [ChxMusicData]
xmlChord a
ch =
    case Getting [PitchRep] a [PitchRep] -> a -> [PitchRep]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [PitchRep] a [PitchRep]
forall s p d. HasNote s p d => Lens' s p
N.notePitch a
ch of
      [] -> [Mono PitchRep -> ChxMusicData
doNote Mono PitchRep
forall p. Mono p
N.Rest]
      [PitchRep]
ps -> (Int -> ChxMusicData -> ChxMusicData)
-> [Int] -> [ChxMusicData] -> [ChxMusicData]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ChxMusicData -> ChxMusicData
forall a a. (Eq a, Num a, HasChxMusicData a) => a -> a -> a
doChord [(Int
0 :: Int)..] ([ChxMusicData] -> [ChxMusicData])
-> [ChxMusicData] -> [ChxMusicData]
forall a b. (a -> b) -> a -> b
$ (PitchRep -> ChxMusicData) -> [PitchRep] -> [ChxMusicData]
forall a b. (a -> b) -> [a] -> [b]
map (Mono PitchRep -> ChxMusicData
doNote(Mono PitchRep -> ChxMusicData)
-> (PitchRep -> Mono PitchRep) -> PitchRep -> ChxMusicData
forall b c a. (b -> c) -> (a -> b) -> a -> c
.PitchRep -> Mono PitchRep
forall p. p -> Mono p
N.M) [PitchRep]
ps
    where doNote :: Mono PitchRep -> ChxMusicData
doNote Mono PitchRep
p = Note (Mono PitchRep) Rational -> ChxMusicData
forall a. HasNote a (Mono PitchRep) Rational => a -> ChxMusicData
xmlNote (Mono PitchRep -> Rational -> Note (Mono PitchRep) Rational
forall p d. p -> d -> Note p d
N.Note Mono PitchRep
p (Getting Rational a Rational -> a -> Rational
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Rational a Rational
forall s p d. HasNote s p d => Lens' s d
N.noteDur a
ch))
          doChord :: a -> a -> a
doChord a
i | a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> a
forall a. a -> a
id
                    | Bool
otherwise =
                        ASetter a a (Maybe Empty) (Maybe Empty) -> Maybe Empty -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Note -> Identity Note) -> a -> Identity a
forall c. HasChxMusicData c => Traversal' c Note
_musicDataNote((Note -> Identity Note) -> a -> Identity a)
-> ((Maybe Empty -> Identity (Maybe Empty))
    -> Note -> Identity Note)
-> ASetter a a (Maybe Empty) (Maybe Empty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ChxNote -> Identity ChxNote) -> Note -> Identity Note
forall c. HasNote c => Lens' c ChxNote
_noteNote((ChxNote -> Identity ChxNote) -> Note -> Identity Note)
-> ((Maybe Empty -> Identity (Maybe Empty))
    -> ChxNote -> Identity ChxNote)
-> (Maybe Empty -> Identity (Maybe Empty))
-> Note
-> Identity Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(GrpFullNote -> Identity GrpFullNote)
-> ChxNote -> Identity ChxNote
forall c. HasChxNote c => Traversal' c GrpFullNote
_chxnoteFullNote1((GrpFullNote -> Identity GrpFullNote)
 -> ChxNote -> Identity ChxNote)
-> ((Maybe Empty -> Identity (Maybe Empty))
    -> GrpFullNote -> Identity GrpFullNote)
-> (Maybe Empty -> Identity (Maybe Empty))
-> ChxNote
-> Identity ChxNote
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Empty -> Identity (Maybe Empty))
-> GrpFullNote -> Identity GrpFullNote
forall c. HasGrpFullNote c => Lens' c (Maybe Empty)
_fullNoteChord)
                            (Empty -> Maybe Empty
forall a. a -> Maybe a
Just Empty
Empty)


_testNote :: N.Note' [N.PitchRep] Rational
_testNote :: Note' [PitchRep] Rational
_testNote = ASetter
  (Note' [Int] Int)
  (Note' [PitchRep] Rational)
  (Note [Int] Int)
  (Note [PitchRep] Rational)
-> (Note [Int] Int -> Note [PitchRep] Rational)
-> Note' [Int] Int
-> Note' [PitchRep] Rational
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Note' [Int] Int)
  (Note' [PitchRep] Rational)
  (Note [Int] Int)
  (Note [PitchRep] Rational)
forall p1 d1 p2 d2.
Lens (Note' p1 d1) (Note' p2 d2) (Note p1 d1) (Note p2 d2)
N.nNote (Getting
  (Note [PitchRep] Rational)
  (Note [Int] Int)
  (Note [PitchRep] Rational)
-> Note [Int] Int -> Note [PitchRep] Rational
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (AnIso [Int] [Int] [PitchRep] [PitchRep]
-> AnIso Int Int Rational Rational
-> Iso
     (Note [Int] Int)
     (Note [Int] Int)
     (Note [PitchRep] Rational)
     (Note [PitchRep] Rational)
forall (f :: * -> * -> *) (g :: * -> * -> *) s t a b s' t' a' b'.
(Bifunctor f, Bifunctor g) =>
AnIso s t a b
-> AnIso s' t' a' b' -> Iso (f s s') (g t t') (f a a') (g b b')
bimapping (AnIso Int Int PitchRep PitchRep
-> Iso [Int] [Int] [PitchRep] [PitchRep]
forall (f :: * -> *) (g :: * -> *) s t a b.
(Functor f, Functor g) =>
AnIso s t a b -> Iso (f s) (g t) (f a) (g b)
mapping AnIso Int Int PitchRep PitchRep
forall a. Integral a => Iso' a PitchRep
N.pitchRep) (PPQ -> Iso' Int Rational
forall a. Integral a => PPQ -> Iso' a Rational
N.ratioPPQ PPQ
N.PQ4))) Note' [Int] Int
N.testNote

-- | Adapt a rendered note to account for tie information.
-- > xmlTie testNote <$> xmlChord 128 testNote
xmlTie :: (N.HasTie a) => a -> ChxMusicData -> ChxMusicData
xmlTie :: a -> ChxMusicData -> ChxMusicData
xmlTie a
a = ASetter ChxMusicData ChxMusicData [Notations] [Notations]
-> ([Notations] -> [Notations]) -> ChxMusicData -> ChxMusicData
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Note -> Identity Note) -> ChxMusicData -> Identity ChxMusicData
forall c. HasChxMusicData c => Traversal' c Note
_musicDataNote((Note -> Identity Note) -> ChxMusicData -> Identity ChxMusicData)
-> (([Notations] -> Identity [Notations]) -> Note -> Identity Note)
-> ASetter ChxMusicData ChxMusicData [Notations] [Notations]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Notations] -> Identity [Notations]) -> Note -> Identity Note
forall c. HasNote c => Lens' c [Notations]
_noteNotations) ([Notations] -> [Notations] -> [Notations]
forall a. [a] -> [a] -> [a]
++(TiedType -> Notations) -> [Notations]
forall a. (TiedType -> a) -> [a]
adapt TiedType -> Notations
mkTNot) (ChxMusicData -> ChxMusicData)
-> (ChxMusicData -> ChxMusicData) -> ChxMusicData -> ChxMusicData
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           ASetter ChxMusicData ChxMusicData [Tie] [Tie]
-> ([Tie] -> [Tie]) -> ChxMusicData -> ChxMusicData
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Note -> Identity Note) -> ChxMusicData -> Identity ChxMusicData
forall c. HasChxMusicData c => Traversal' c Note
_musicDataNote((Note -> Identity Note) -> ChxMusicData -> Identity ChxMusicData)
-> (([Tie] -> Identity [Tie]) -> Note -> Identity Note)
-> ASetter ChxMusicData ChxMusicData [Tie] [Tie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ChxNote -> Identity ChxNote) -> Note -> Identity Note
forall c. HasNote c => Lens' c ChxNote
_noteNote((ChxNote -> Identity ChxNote) -> Note -> Identity Note)
-> (([Tie] -> Identity [Tie]) -> ChxNote -> Identity ChxNote)
-> ([Tie] -> Identity [Tie])
-> Note
-> Identity Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Tie] -> Identity [Tie]) -> ChxNote -> Identity ChxNote
forall c. HasChxNote c => Traversal' c [Tie]
_chxnoteTie) ([Tie] -> [Tie] -> [Tie]
forall a. [a] -> [a] -> [a]
++(StartStop -> Tie) -> [Tie]
forall a. (StartStop -> a) -> [a]
adapt' StartStop -> Tie
mkTie)
    where adapt :: (TiedType -> a) -> [a]
adapt TiedType -> a
fc = [a] -> (Tie -> [a]) -> Maybe Tie -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((TiedType -> a) -> [TiedType] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TiedType -> a
fc ([TiedType] -> [a]) -> (Tie -> [TiedType]) -> Tie -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tie -> [TiedType]
conv) (Maybe Tie -> [a]) -> Maybe Tie -> [a]
forall a b. (a -> b) -> a -> b
$ Getting (Maybe Tie) a (Maybe Tie) -> a -> Maybe Tie
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Tie) a (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
N.tie a
a
          conv :: Tie -> [TiedType]
conv Tie
N.TStart = [TiedType
TiedTypeStart]
          conv Tie
N.TStop = [TiedType
TiedTypeStop]
          conv Tie
N.TBoth = [TiedType
TiedTypeStop,TiedType
TiedTypeStart]
          adapt' :: (StartStop -> a) -> [a]
adapt' StartStop -> a
fc = [a] -> (Tie -> [a]) -> Maybe Tie -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((StartStop -> a) -> [StartStop] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StartStop -> a
fc ([StartStop] -> [a]) -> (Tie -> [StartStop]) -> Tie -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tie -> [StartStop]
conv') (Maybe Tie -> [a]) -> Maybe Tie -> [a]
forall a b. (a -> b) -> a -> b
$ Getting (Maybe Tie) a (Maybe Tie) -> a -> Maybe Tie
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Tie) a (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
N.tie a
a
          conv' :: Tie -> [StartStop]
conv' Tie
N.TStart = [StartStop
StartStopStart]
          conv' Tie
N.TStop = [StartStop
StartStopStop]
          conv' Tie
N.TBoth = [StartStop
StartStopStop,StartStop
StartStopStart]
          mkTNot :: TiedType -> Notations
mkTNot TiedType
s = (Editorial -> Notations
mkNotations Editorial
mkEditorial)
                     {notationsNotations :: [ChxNotations]
notationsNotations = [Tied -> ChxNotations
NotationsTied (TiedType -> Tied
mkTied TiedType
s)]}

-- | Steps and enharmonics.
steps :: [(Step,Maybe Semitones)]
steps :: [(Step, Maybe Semitones)]
steps = [(Step
StepC,Maybe Semitones
forall a. Maybe a
Nothing),
         (Step
StepC,Maybe Semitones
sharp),
         (Step
StepD,Maybe Semitones
forall a. Maybe a
Nothing),
         (Step
StepE,Maybe Semitones
flat),
         (Step
StepE,Maybe Semitones
forall a. Maybe a
Nothing),
         (Step
StepF,Maybe Semitones
forall a. Maybe a
Nothing),
         (Step
StepF,Maybe Semitones
sharp),
         (Step
StepG,Maybe Semitones
forall a. Maybe a
Nothing),
         (Step
StepA,Maybe Semitones
flat),
         (Step
StepA,Maybe Semitones
forall a. Maybe a
Nothing),
         (Step
StepB,Maybe Semitones
flat),
         (Step
StepB,Maybe Semitones
forall a. Maybe a
Nothing)]
    where sharp :: Maybe Semitones
sharp = Semitones -> Maybe Semitones
forall a. a -> Maybe a
Just Semitones
1
          flat :: Maybe Semitones
flat = Semitones -> Maybe Semitones
forall a. a -> Maybe a
Just (-Semitones
1)

-- | Note values indexed by powers of two. [(1,Long) .. (1024,256th)]
noteTypeValues :: M.Map Int NoteTypeValue
noteTypeValues :: Map Int NoteTypeValue
noteTypeValues = [(Int, NoteTypeValue)] -> Map Int NoteTypeValue
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, NoteTypeValue)] -> Map Int NoteTypeValue)
-> [(Int, NoteTypeValue)] -> Map Int NoteTypeValue
forall a b. (a -> b) -> a -> b
$ (Int, [(Int, NoteTypeValue)]) -> [(Int, NoteTypeValue)]
forall a b. (a, b) -> b
snd ((Int, [(Int, NoteTypeValue)]) -> [(Int, NoteTypeValue)])
-> (Int, [(Int, NoteTypeValue)]) -> [(Int, NoteTypeValue)]
forall a b. (a -> b) -> a -> b
$ (Int -> NoteTypeValue -> (Int, (Int, NoteTypeValue)))
-> Int -> [NoteTypeValue] -> (Int, [(Int, NoteTypeValue)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Int -> NoteTypeValue -> (Int, (Int, NoteTypeValue))
forall a b. Integral a => a -> b -> (a, (a, b))
acc (Int
256Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
4) [NoteTypeValue
forall a. Bounded a => a
minBound .. NoteTypeValue
forall a. Bounded a => a
maxBound]
    where acc :: a -> b -> (a, (a, b))
acc a
v b
nt = (a
v a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2,(a
v,b
nt))

-- | Int pitch to xml. TODO C3 vs C4?
convertPitch :: Int -> Pitch
convertPitch :: Int -> Pitch
convertPitch Int
i = Step -> Maybe Semitones -> Octave -> Pitch
Pitch Step
step Maybe Semitones
semi Octave
oct where
    oct :: Octave
oct = Int -> Octave
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Octave) -> Int -> Octave
forall a b. (a -> b) -> a -> b
$ (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
12) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    (Step
step, Maybe Semitones
semi) = [(Step, Maybe Semitones)]
steps [(Step, Maybe Semitones)] -> Int -> (Step, Maybe Semitones)
forall a. [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12)

convertPitchRep :: N.PitchRep -> Pitch
convertPitchRep :: PitchRep -> Pitch
convertPitchRep (N.PitchRep Spelling
s Int
o) = Step -> Maybe Semitones -> Octave -> Pitch
Pitch Step
step Maybe Semitones
semi (Int -> Octave
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
o)
    where (Step
step,Maybe Semitones
semi) = Spelling -> (Step, Maybe Semitones)
ss Spelling
s
          sharp :: Maybe Semitones
sharp = Semitones -> Maybe Semitones
forall a. a -> Maybe a
Just Semitones
1
          flat :: Maybe Semitones
flat = Semitones -> Maybe Semitones
forall a. a -> Maybe a
Just (-Semitones
1)
          ss :: Spelling -> (Step, Maybe Semitones)
ss Spelling
N.C = (Step
StepC,Maybe Semitones
forall a. Maybe a
Nothing)
          ss Spelling
N.Cs = (Step
StepC,Maybe Semitones
sharp)
          ss Spelling
N.Db = (Step
StepD,Maybe Semitones
flat)
          ss Spelling
N.D = (Step
StepD,Maybe Semitones
forall a. Maybe a
Nothing)
          ss Spelling
N.Ds = (Step
StepD,Maybe Semitones
sharp)
          ss Spelling
N.Eb = (Step
StepE,Maybe Semitones
flat)
          ss Spelling
N.E = (Step
StepE,Maybe Semitones
forall a. Maybe a
Nothing)
          ss Spelling
N.F = (Step
StepF,Maybe Semitones
forall a. Maybe a
Nothing)
          ss Spelling
N.Fs = (Step
StepF,Maybe Semitones
sharp)
          ss Spelling
N.Gb = (Step
StepG,Maybe Semitones
flat)
          ss Spelling
N.G = (Step
StepG,Maybe Semitones
forall a. Maybe a
Nothing)
          ss Spelling
N.Gs = (Step
StepG,Maybe Semitones
sharp)
          ss Spelling
N.Ab = (Step
StepA,Maybe Semitones
flat)
          ss Spelling
N.A = (Step
StepA,Maybe Semitones
forall a. Maybe a
Nothing)
          ss Spelling
N.As = (Step
StepA,Maybe Semitones
sharp)
          ss Spelling
N.Bb = (Step
StepB,Maybe Semitones
flat)
          ss Spelling
N.B = (Step
StepB,Maybe Semitones
forall a. Maybe a
Nothing)


-- | Int duration/PPQ to xml values.
convertDur :: N.PPQ -> Int -> PositiveDivisions -> (PositiveDivisions,NoteTypeValue,Int)
convertDur :: PPQ
-> Int
-> PositiveDivisions
-> (PositiveDivisions, NoteTypeValue, Int)
convertDur PPQ
ppq Int
dur PositiveDivisions
xdivs = (Int -> PositiveDivisions
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
divs,NoteTypeValue
findValue,Int
dots)
    where
      ppqd :: Int
ppqd = PPQ -> Int
forall a. Integral a => PPQ -> a
N.ppqDiv PPQ
ppq
      divs :: Int
divs = PositiveDivisions -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor PositiveDivisions
xdivs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
dur Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
ppqd
      (Int
num,Int
denom) = Ratio Int -> Int
forall a. Ratio a -> a
numerator (Ratio Int -> Int) -> (Ratio Int -> Int) -> Ratio Int -> (Int, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Ratio Int -> Int
forall a. Ratio a -> a
denominator (Ratio Int -> (Int, Int)) -> Ratio Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Int
dur Int -> Int -> Ratio Int
forall a. Integral a => a -> a -> Ratio a
% (Int
ppqd Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16))
      dots :: Int
dots = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
num Map Int Int
dotValues
      findValue :: NoteTypeValue
findValue = NoteTypeValue -> Maybe NoteTypeValue -> NoteTypeValue
forall a. a -> Maybe a -> a
fromMaybe NoteTypeValue
NoteTypeValue256th (Maybe NoteTypeValue -> NoteTypeValue)
-> Maybe NoteTypeValue -> NoteTypeValue
forall a b. (a -> b) -> a -> b
$
                  Int -> Map Int NoteTypeValue -> Maybe NoteTypeValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Int
denom Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
dots))  Map Int NoteTypeValue
noteTypeValues

-- | Rational duration (ie, '1 % 4' for quarter note) to xml values.
convertDurR :: PositiveDivisions -> Rational -> (PositiveDivisions,NoteTypeValue,Int)
convertDurR :: PositiveDivisions
-> Rational -> (PositiveDivisions, NoteTypeValue, Int)
convertDurR PositiveDivisions
xdivs Rational
r' = (Int -> PositiveDivisions
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
divs,NoteTypeValue
findValue,Int
dots)
    where
      r :: Rational
r = Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
reduce (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r') (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r')
      divs :: Int
      divs :: Int
divs = Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ PositiveDivisions -> Rational
forall a. Real a => a -> Rational
toRational PositiveDivisions
xdivs Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
4)
      (Integer
num,Integer
denom) = Rational -> Integer
forall a. Ratio a -> a
numerator (Rational -> Integer)
-> (Rational -> Integer) -> Rational -> (Integer, Integer)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Rational -> Integer
forall a. Ratio a -> a
denominator (Rational -> (Integer, Integer)) -> Rational -> (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ Rational
r
      dots :: Int
dots = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
num) Map Int Int
dotValues
      findValue :: NoteTypeValue
findValue = NoteTypeValue -> Maybe NoteTypeValue -> NoteTypeValue
forall a. a -> Maybe a -> a
fromMaybe NoteTypeValue
NoteTypeValue256th (Maybe NoteTypeValue -> NoteTypeValue)
-> Maybe NoteTypeValue -> NoteTypeValue
forall a b. (a -> b) -> a -> b
$
                  Int -> Map Int NoteTypeValue -> Maybe NoteTypeValue
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
denom Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
dots)) Map Int NoteTypeValue
noteTypeValues

-- | Numerator values to dots.
dotValues :: M.Map Int Int
dotValues :: Map Int Int
dotValues = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, Int)] -> Map Int Int) -> [(Int, Int)] -> Map Int Int
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1024) (Int -> Int -> [Int]
forall t. Num t => t -> t -> [t]
dot Int
3 Int
4) [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
1..]
    where dot :: t -> t -> [t]
dot t
v t
i = t
vt -> [t] -> [t]
forall a. a -> [a] -> [a]
:t -> t -> [t]
dot (t
v t -> t -> t
forall a. Num a => a -> a -> a
+ t
i) (t
i t -> t -> t
forall a. Num a => a -> a -> a
* t
2)