-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-}
-- | Convert Lilypond Events to lilypond code.
--
-- It's a terrible name, but what else am I supposed to call it?  Render?
-- Realize?  Perform?
module Perform.Lilypond.Process (
    process, convert_to_rests
    , parse_key
    , Ly(..), Note(..)
    , Voices(..), Voice(..)
#ifdef TESTING
    , module Perform.Lilypond.Process
#endif
) where
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.State.Strict as State

import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Ratio as Ratio
import qualified Data.Text as Text

import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq
import qualified Util.Then as Then

import qualified Derive.Attrs as Attrs
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Scale.Theory as Theory
import qualified Derive.Scale.Twelve as Twelve
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Lilypond.Constants as Constants
import qualified Perform.Lilypond.Meter as Meter
import qualified Perform.Lilypond.Types as Types
import           Perform.Lilypond.Types
       (event_attributes, event_end, to_lily, Time, ToLily, Event(..))
import qualified Perform.Pitch as Pitch

import           Global
import           Types


-- | Automatically add lilypond code for certain attributes.
simple_articulations :: [(Attrs.Attributes, Code)]
simple_articulations :: [(Attributes, Text)]
simple_articulations =
    [ (Attributes
Attrs.mute, Text
"-+")
    -- Previously pizz<>right, comment on "Attrs".
    , (Attributes
Attrs.pizz_right, Text
"-+")
    , (Attributes
Attrs.marcato, Text
"-^")
    , (Attributes
Attrs.staccato, Text
"-.")
    , (Attributes
Attrs.portato, Text
"-_")
    , (Attributes
Attrs.tenuto, Text
"--")
    , (Attributes
Attrs.accent, Text
"->")
    , (Attributes
Attrs.trem, Text
":32")
    ]

-- | Certain attributes are modal, in that they emit one thing when they
-- start, and another when they stop.
modal_articulations :: [(Attrs.Attributes, Code, Code)]
modal_articulations :: [(Attributes, Text, Text)]
modal_articulations =
    [ (Attributes
Attrs.pizz, Text
"^\"pizz.\"", Text
"^\"arco\"")
    , (Attributes
Attrs.nv, Text
"^\"nv\"", Text
"^\"vib\"")
    , (Attributes
Attrs.pont, Text
"^\"sul pont.\"", Text
"^\"loco\"")
    ]

-- * convert_to_rests

-- | Convert a staff to all rests, keeping the key, clef, and meter changes.
-- have predicates that recognize those, and keep those Codes
convert_to_rests :: [Either Voices Ly] -> [Ly]
convert_to_rests :: [Either Voices Ly] -> [Ly]
convert_to_rests = [Ly] -> [Ly]
hush ([Ly] -> [Ly])
-> ([Either Voices Ly] -> [Ly]) -> [Either Voices Ly] -> [Ly]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ly -> Bool) -> [Ly] -> [Ly]
forall a. (a -> Bool) -> [a] -> [a]
filter Ly -> Bool
wanted ([Ly] -> [Ly])
-> ([Either Voices Ly] -> [Ly]) -> [Either Voices Ly] -> [Ly]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Voices Ly -> [Ly]) -> [Either Voices Ly] -> [Ly]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Either Voices Ly -> [Ly]
flatten
    where
    flatten :: Either Voices Ly -> [Ly]
flatten (Left (Voices VoiceMap Ly
voices)) = case VoiceMap Ly
voices of
        [] -> []
        (Voice
_, [Ly]
lys) : VoiceMap Ly
_ -> [Ly]
lys
    flatten (Right Ly
ly) = [Ly
ly]
    wanted :: Ly -> Bool
wanted (LyCode Text
code) = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`Text.isPrefixOf` Text
code)
        [Text
"\\time ", Text
"\\key ", Text
"\\bar "]
    wanted Ly
_ = Bool
True
    has_duration :: Ly -> Maybe [NoteDuration]
has_duration (LyNote Note
n) = [NoteDuration] -> Maybe [NoteDuration]
forall a. a -> Maybe a
Just [Note -> NoteDuration
note_duration Note
n]
    has_duration (LyRest Rest
r) =
        [NoteDuration] -> Maybe [NoteDuration]
forall a. a -> Maybe a
Just ([NoteDuration] -> Maybe [NoteDuration])
-> [NoteDuration] -> Maybe [NoteDuration]
forall a b. (a -> b) -> a -> b
$ (Duration -> NoteDuration) -> [Duration] -> [NoteDuration]
forall a b. (a -> b) -> [a] -> [b]
map Duration -> NoteDuration
Types.dur_to_note_dur ([Duration] -> [NoteDuration]) -> [Duration] -> [NoteDuration]
forall a b. (a -> b) -> a -> b
$ Time -> [Duration]
Types.time_to_durs (Time -> [Duration]) -> Time -> [Duration]
forall a b. (a -> b) -> a -> b
$ Rest -> Time
rest_time Rest
r
    has_duration Ly
_ = Maybe [NoteDuration]
forall a. Maybe a
Nothing
    hush :: [Ly] -> [Ly]
hush [Ly]
lys = -- TODO simplify durs
        (NoteDuration -> Ly) -> [NoteDuration] -> [Ly]
forall a b. (a -> b) -> [a] -> [b]
map (Rest -> Ly
LyRest (Rest -> Ly) -> (NoteDuration -> Rest) -> NoteDuration -> Ly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RestType -> Rest
make_rest (RestType -> Rest)
-> (NoteDuration -> RestType) -> NoteDuration -> Rest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDuration -> RestType
HiddenRest) ([[NoteDuration]] -> [NoteDuration]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NoteDuration]]
durs) [Ly] -> [Ly] -> [Ly]
forall a. [a] -> [a] -> [a]
++ case [Ly]
non_notes of
            Ly
ly : [Ly]
rest -> Ly
ly Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
: [Ly] -> [Ly]
hush [Ly]
rest
            [] -> []
        where ([[NoteDuration]]
durs, [Ly]
non_notes) = (Ly -> Maybe [NoteDuration]) -> [Ly] -> ([[NoteDuration]], [Ly])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Seq.span_while Ly -> Maybe [NoteDuration]
has_duration [Ly]
lys

-- * process

data Chunk = ChunkNotes [Event] | ChunkVoices (VoiceMap Event)
    deriving (Int -> Chunk -> ShowS
[Chunk] -> ShowS
Chunk -> String
(Int -> Chunk -> ShowS)
-> (Chunk -> String) -> ([Chunk] -> ShowS) -> Show Chunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Chunk] -> ShowS
$cshowList :: [Chunk] -> ShowS
show :: Chunk -> String
$cshow :: Chunk -> String
showsPrec :: Int -> Chunk -> ShowS
$cshowsPrec :: Int -> Chunk -> ShowS
Show)

instance Pretty Chunk where
    format :: Chunk -> Doc
format (ChunkNotes [Event]
events) =
        Text -> [Doc] -> Doc
Pretty.constructor Text
"ChunkNotes" [[Event] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Event]
events]
    format (ChunkVoices VoiceMap Event
voices) =
        Text -> [Doc] -> Doc
Pretty.constructor Text
"ChunkVoices" [VoiceMap Event -> Doc
forall a. Pretty a => a -> Doc
Pretty.format VoiceMap Event
voices]

-- | This is the top level function which converts a stream of Events on one
-- staff into lilypond code.
--
-- . First pass finds voice boundaries.
-- . Then insert rests.
-- . Convert [Event]->[Ly]: keys, meter splitting, tuplet and tremolo.
-- . Merge 0 dur events 'FreeCode' in [Ly] since they have been split according
-- to the meter.
process :: Types.Config -> Time -> [Meter.Meter] -- ^ one for each measure
    -> [Event] -> Either Log.Msg [Either Voices Ly]
process :: Config
-> Time -> [Meter] -> [Event] -> Either Msg [Either Voices Ly]
process Config
config Time
start [Meter]
meters [Event]
events_ = (ConvertError -> Msg)
-> Either ConvertError [Either Voices Ly]
-> Either Msg [Either Voices Ly]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ConvertError -> Msg
to_log (Either ConvertError [Either Voices Ly]
 -> Either Msg [Either Voices Ly])
-> Either ConvertError [Either Voices Ly]
-> Either Msg [Either Voices Ly]
forall a b. (a -> b) -> a -> b
$ do
    let ([FreeCode]
free_codes, [Event]
events) = (Event -> Maybe FreeCode) -> [Event] -> ([FreeCode], [Event])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Seq.partition_on Event -> Maybe FreeCode
free_code [Event]
events_
    [Chunk]
chunks <- (Text -> Either ConvertError [Chunk])
-> ([Chunk] -> Either ConvertError [Chunk])
-> Either Text [Chunk]
-> Either ConvertError [Chunk]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ConvertError -> Either ConvertError [Chunk]
forall a b. a -> Either a b
Left (ConvertError -> Either ConvertError [Chunk])
-> (Text -> ConvertError) -> Text -> Either ConvertError [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Stack -> Text -> ConvertError
ConvertError Maybe Stack
forall a. Maybe a
Nothing) [Chunk] -> Either ConvertError [Chunk]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text [Chunk] -> Either ConvertError [Chunk])
-> Either Text [Chunk] -> Either ConvertError [Chunk]
forall a b. (a -> b) -> a -> b
$
        [Event] -> Either Text [Chunk]
collect_chunks [Event]
events
    let end :: Time
end = Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ [Time] -> Time
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum ((Meter -> Time) -> [Meter] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Meter -> Time
Meter.measure_time [Meter]
meters)
    -- Debug.tracepM "meters" (start, end, length meters,
    --     zip [1 :: Int ..] (_meter_starts start meters))
    [Chunk]
chunks <- [Chunk] -> Either ConvertError [Chunk]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Chunk] -> Either ConvertError [Chunk])
-> [Chunk] -> Either ConvertError [Chunk]
forall a b. (a -> b) -> a -> b
$ [Chunk] -> [Chunk]
merge_note_code_chunks ([Chunk] -> [Chunk]) -> [Chunk] -> [Chunk]
forall a b. (a -> b) -> a -> b
$
        Time -> Time -> [Chunk] -> [Chunk]
insert_rests_chunks Time
start Time
end [Chunk]
chunks
    let state :: State
state = Config -> Time -> [Meter] -> Key -> State
make_state Config
config Time
start [Meter]
meters Key
default_key
    Key
key <- Either ConvertError Key
-> (Event -> Either ConvertError Key)
-> Maybe Event
-> Either ConvertError Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Key -> Either ConvertError Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
default_key)
        (((Key, State) -> Key)
-> Either ConvertError (Key, State) -> Either ConvertError Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key, State) -> Key
forall a b. (a, b) -> a
fst (Either ConvertError (Key, State) -> Either ConvertError Key)
-> (Event -> Either ConvertError (Key, State))
-> Event
-> Either ConvertError Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> ConvertM Key -> Either ConvertError (Key, State)
forall a. State -> ConvertM a -> Either ConvertError (a, State)
run_convert State
state (ConvertM Key -> Either ConvertError (Key, State))
-> (Event -> ConvertM Key)
-> Event
-> Either ConvertError (Key, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ConvertM Key
lookup_key) ([Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head [Event]
events)
    State
state <- State -> Either ConvertError State
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Either ConvertError State)
-> State -> Either ConvertError State
forall a b. (a -> b) -> a -> b
$ State
state { state_key :: Key
state_key = Key
key }
    ([Either Voices Ly]
lys, State
_) <- State
-> ConvertM [Either Voices Ly]
-> Either ConvertError ([Either Voices Ly], State)
forall a. State -> ConvertM a -> Either ConvertError (a, State)
run_convert State
state (ConvertM [Either Voices Ly]
 -> Either ConvertError ([Either Voices Ly], State))
-> ConvertM [Either Voices Ly]
-> Either ConvertError ([Either Voices Ly], State)
forall a b. (a -> b) -> a -> b
$ [Chunk] -> ConvertM [Either Voices Ly]
convert [Chunk]
chunks
    [Either Voices Ly]
lys <- [Either Voices Ly] -> Either ConvertError [Either Voices Ly]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either Voices Ly] -> Either ConvertError [Either Voices Ly])
-> [Either Voices Ly] -> Either ConvertError [Either Voices Ly]
forall a b. (a -> b) -> a -> b
$ Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
merge_free_code Time
start [FreeCode]
free_codes [Either Voices Ly]
lys
    let meter :: Meter
meter = Meter -> Maybe Meter -> Meter
forall a. a -> Maybe a -> a
fromMaybe Meter
Meter.default_meter ([Meter] -> Maybe Meter
forall a. [a] -> Maybe a
Seq.head [Meter]
meters)
    [Either Voices Ly] -> Either ConvertError [Either Voices Ly]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either Voices Ly] -> Either ConvertError [Either Voices Ly])
-> [Either Voices Ly] -> Either ConvertError [Either Voices Ly]
forall a b. (a -> b) -> a -> b
$ Ly -> Either Voices Ly
forall a b. b -> Either a b
Right (Text -> Ly
LyCode (Text -> Ly) -> Text -> Ly
forall a b. (a -> b) -> a -> b
$ Text
"\\time " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Meter -> Text
forall a. ToLily a => a -> Text
to_lily Meter
meter)
        Either Voices Ly -> [Either Voices Ly] -> [Either Voices Ly]
forall a. a -> [a] -> [a]
: Ly -> Either Voices Ly
forall a b. b -> Either a b
Right (Text -> Ly
LyCode (Text -> Ly) -> Text -> Ly
forall a b. (a -> b) -> a -> b
$ Key -> Text
forall a. ToLily a => a -> Text
to_lily Key
key)
        Either Voices Ly -> [Either Voices Ly] -> [Either Voices Ly]
forall a. a -> [a] -> [a]
: [Either Voices Ly]
lys
        [Either Voices Ly] -> [Either Voices Ly] -> [Either Voices Ly]
forall a. [a] -> [a] -> [a]
++ [Ly -> Either Voices Ly
forall a b. b -> Either a b
Right (Text -> Ly
LyCode Text
"\\bar \"|.\"")]

_meter_starts :: Time -> [Meter.Meter] -> [(Time, Meter.Meter)]
_meter_starts :: Time -> [Meter] -> [(Time, Meter)]
_meter_starts Time
start [Meter]
meters = (Time, [(Time, Meter)]) -> [(Time, Meter)]
forall a b. (a, b) -> b
snd ((Time, [(Time, Meter)]) -> [(Time, Meter)])
-> (Time, [(Time, Meter)]) -> [(Time, Meter)]
forall a b. (a -> b) -> a -> b
$ (Time -> Meter -> (Time, (Time, Meter)))
-> Time -> [Meter] -> (Time, [(Time, Meter)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Time -> Meter -> (Time, (Time, Meter))
add Time
start [Meter]
meters
    where add :: Time -> Meter -> (Time, (Time, Meter))
add Time
t Meter
meter = (Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Meter -> Time
Meter.measure_time Meter
meter, (Time
t, Meter
meter))

-- | Group voice and non-voice Events into Chunks.
collect_chunks :: [Event] -> Either Error [Chunk]
collect_chunks :: [Event] -> Either Text [Chunk]
collect_chunks = [Event] -> Either Text [Chunk]
go
    where
    go :: [Event] -> Either Text [Chunk]
go [] = [Chunk] -> Either Text [Chunk]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go [Event]
events = do
        ([Event]
no_voice, [Event]
events) <- [Event] -> Either Text ([Event], [Event])
without_voice [Event]
events
        (VoiceMap Event
voice, [Event]
events) <- [Event] -> Either Text (VoiceMap Event, [Event])
with_voice [Event]
events
        let collected :: [Chunk]
collected = (Chunk -> Bool) -> [Chunk] -> [Chunk]
forall a. (a -> Bool) -> [a] -> [a]
filter Chunk -> Bool
nonempty [[Event] -> Chunk
ChunkNotes [Event]
no_voice, VoiceMap Event -> Chunk
ChunkVoices VoiceMap Event
voice]
        ([Chunk]
collected ++) ([Chunk] -> [Chunk]) -> Either Text [Chunk] -> Either Text [Chunk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event] -> Either Text [Chunk]
go [Event]
events
    nonempty :: Chunk -> Bool
nonempty (ChunkNotes []) = Bool
False
    nonempty (ChunkVoices []) = Bool
False
    nonempty Chunk
_ = Bool
True
    with_voice :: [Event] -> Either Text (VoiceMap Event, [Event])
with_voice [Event]
events = do
        (VoiceMap Event
voice, [Event]
remain) <- [Event] -> Either Text (VoiceMap Event, [Event])
collect_voices [Event]
events
        let tails :: [Event]
tails = ((Voice, [Event]) -> Maybe Event) -> VoiceMap Event -> [Event]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.last ([Event] -> Maybe Event)
-> ((Voice, [Event]) -> [Event]) -> (Voice, [Event]) -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Voice, [Event]) -> [Event]
forall a b. (a, b) -> b
snd) VoiceMap Event
voice
        Maybe Event -> (Event -> Either Text ()) -> Either Text ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head [Event]
remain) ((Event -> Either Text ()) -> Either Text ())
-> (Event -> Either Text ()) -> Either Text ()
forall a b. (a -> b) -> a -> b
$ \Event
e ->
            Maybe Event -> (Event -> Either Text ()) -> Either Text ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ((Event -> Bool) -> [Event] -> Maybe Event
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Event -> Event -> Bool
Types.event_overlaps Event
e) [Event]
tails) ((Event -> Either Text ()) -> Either Text ())
-> (Event -> Either Text ()) -> Either Text ()
forall a b. (a -> b) -> a -> b
$ \Event
over ->
                Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"last voice " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Event -> Text
forall a. Pretty a => a -> Text
pretty Event
over
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" overlaps first non-voice " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Event -> Text
forall a. Pretty a => a -> Text
pretty Event
e
        (VoiceMap Event, [Event]) -> Either Text (VoiceMap Event, [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (VoiceMap Event
voice, [Event]
remain)
    without_voice :: [Event] -> Either Text ([Event], [Event])
without_voice [Event]
events = do
        let ([Event]
without, [Event]
remain) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Maybe (Either Text Voice) -> Maybe (Either Text Voice) -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe (Either Text Voice)
forall a. Maybe a
Nothing) (Maybe (Either Text Voice) -> Bool)
-> (Event -> Maybe (Either Text Voice)) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Maybe (Either Text Voice)
event_voice) [Event]
events
        Maybe (Event, Event)
-> ((Event, Event) -> Either Text ()) -> Either Text ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ((,) (Event -> Event -> (Event, Event))
-> Maybe Event -> Maybe (Event -> (Event, Event))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.last [Event]
without Maybe (Event -> (Event, Event))
-> Maybe Event -> Maybe (Event, Event)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head [Event]
remain) (((Event, Event) -> Either Text ()) -> Either Text ())
-> ((Event, Event) -> Either Text ()) -> Either Text ()
forall a b. (a -> b) -> a -> b
$ \(Event
e1, Event
e2) ->
            Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> Event -> Bool
Types.event_overlaps Event
e1 Event
e2) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
                Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"last non-voice " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Event -> Text
forall a. Pretty a => a -> Text
pretty Event
e1
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" overlaps first voice " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Event -> Text
forall a. Pretty a => a -> Text
pretty Event
e2
        ([Event], [Event]) -> Either Text ([Event], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Event]
without, [Event]
remain)

-- | Span events until they don't have a 'Constants.v_voice' val.
--
-- Previously I tried to only split voices where necessary by only spanning
-- overlapping notes, or notes with differing voices.  But even when it worked
-- as intended, joining voices this aggressively led to oddities because it
-- would turn any two voices with the same duration notes into a chord.  So now
-- I simplify voices only at the measure level, in 'simplify_voices'.
collect_voices :: [Event] -> Either Text (VoiceMap Event, [Event])
collect_voices :: [Event] -> Either Text (VoiceMap Event, [Event])
collect_voices [Event]
events = do
    let ([(Either Text Voice, Event)]
voice, [Event]
remain) = (Event -> Maybe (Either Text Voice, Event))
-> [Event] -> ([(Either Text Voice, Event)], [Event])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Seq.span_while (\Event
e -> (,Event
e) (Either Text Voice -> (Either Text Voice, Event))
-> Maybe (Either Text Voice) -> Maybe (Either Text Voice, Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe (Either Text Voice)
event_voice Event
e) [Event]
events
    [(Voice, Event)]
voice <- [(Either Text Voice, Event)]
-> ((Either Text Voice, Event) -> Either Text (Voice, Event))
-> Either Text [(Voice, Event)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Either Text Voice, Event)]
voice (((Either Text Voice, Event) -> Either Text (Voice, Event))
 -> Either Text [(Voice, Event)])
-> ((Either Text Voice, Event) -> Either Text (Voice, Event))
-> Either Text [(Voice, Event)]
forall a b. (a -> b) -> a -> b
$ \(Either Text Voice
err_or_voice, Event
event) -> (,Event
event) (Voice -> (Voice, Event))
-> Either Text Voice -> Either Text (Voice, Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Voice
err_or_voice
    (VoiceMap Event, [Event]) -> Either Text (VoiceMap Event, [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Voice, Event)] -> VoiceMap Event
forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Seq.group_fst [(Voice, Event)]
voice, [Event]
remain)

insert_rests_chunks :: Time -> Time -> [Chunk] -> [Chunk]
insert_rests_chunks :: Time -> Time -> [Chunk] -> [Chunk]
insert_rests_chunks Time
start Time
end = (Time -> Chunk -> (Time, Chunk))
-> Time -> (Time -> [Chunk]) -> [Chunk] -> [Chunk]
forall acc x y.
(acc -> x -> (acc, y)) -> acc -> (acc -> [y]) -> [x] -> [y]
Then.mapAccumL Time -> Chunk -> (Time, Chunk)
insert Time
start Time -> [Chunk]
final
    where
    insert :: Time -> Chunk -> (Time, Chunk)
insert !Time
t (ChunkNotes [Event]
events) =
        [Event] -> Chunk
ChunkNotes ([Event] -> Chunk) -> (Time, [Event]) -> (Time, Chunk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests Maybe Time
forall a. Maybe a
Nothing Time
t [Event]
events
    insert !Time
t (ChunkVoices VoiceMap Event
voices) = case VoiceMap Event -> Maybe Time
forall {a}. [(a, [Event])] -> Maybe Time
get_end VoiceMap Event
voices of
        Maybe Time
Nothing -> (Time
t, VoiceMap Event -> Chunk
ChunkVoices [])
        Just Time
end -> (Time
end, VoiceMap Event -> Chunk
ChunkVoices VoiceMap Event
voices2)
            where
            voices2 :: VoiceMap Event
voices2 = ((Voice, [Event]) -> (Voice, [Event]))
-> VoiceMap Event -> VoiceMap Event
forall a b. (a -> b) -> [a] -> [b]
map (([Event] -> [Event]) -> (Voice, [Event]) -> (Voice, [Event])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Time, [Event]) -> [Event]
forall a b. (a, b) -> b
snd ((Time, [Event]) -> [Event])
-> ([Event] -> (Time, [Event])) -> [Event] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
end) Time
t)) VoiceMap Event
voices
    get_end :: [(a, [Event])] -> Maybe Time
get_end = [Time] -> Maybe Time
forall a. Ord a => [a] -> Maybe a
Seq.maximum ([Time] -> Maybe Time)
-> ([(a, [Event])] -> [Time]) -> [(a, [Event])] -> Maybe Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Time) -> [Event] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Time
event_end ([Event] -> [Time])
-> ([(a, [Event])] -> [Event]) -> [(a, [Event])] -> [Time]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, [Event]) -> Maybe Event) -> [(a, [Event])] -> [Event]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.last ([Event] -> Maybe Event)
-> ((a, [Event]) -> [Event]) -> (a, [Event]) -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [Event]) -> [Event]
forall a b. (a, b) -> b
snd)
    final :: Time -> [Chunk]
final Time
t
        | Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
end = [[Event] -> Chunk
ChunkNotes [Time -> Time -> Event
rest_event Time
t (Time
endTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
t)]]
        | Bool
otherwise = []

-- | Fill gaps between events with explicit rests.  Zero duration note code
-- events have the effect of splitting up the rests.
insert_rests :: Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests :: Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests Maybe Time
maybe_end = Time -> [Event] -> (Time, [Event])
go
    where
    go :: Time -> [Event] -> (Time, [Event])
go Time
t [] = case Maybe Time
maybe_end of
        Just Time
end | Time
end Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
t -> (Time
end, [Time -> Time -> Event
rest_event Time
t (Time
end Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
t)])
        Maybe Time
_ -> (Time
t, [])
    go Time
t (Event
event : [Event]
events) =
        (([Event]
rest [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ Event
event Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
here) ++) ([Event] -> [Event]) -> (Time, [Event]) -> (Time, [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Time -> [Event] -> (Time, [Event])
go (Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
t ([Time] -> Time
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Event -> Time) -> [Event] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Time
event_end (Event
event Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
here)))) [Event]
there
        where
        rest :: [Event]
rest = if Time
gap Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
0 then [] else [Time -> Time -> Event
rest_event Time
t Time
gap]
        ([Event]
here, [Event]
there) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Event -> Time
event_start Event
event) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start) [Event]
events
        gap :: Time
gap = Event -> Time
event_start Event
event Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
t

rest_event :: Time -> Time -> Event
rest_event :: Time -> Time -> Event
rest_event Time
start Time
dur = Event
    { event_start :: Time
event_start = Time
start
    , event_duration :: Time
event_duration = Time
dur
    , event_pitch :: Maybe Pitch
event_pitch = Maybe Pitch
forall a. Maybe a
Nothing
    , event_instrument :: Instrument
event_instrument = Instrument
ScoreT.empty_instrument
    , event_environ :: Environ
event_environ = Environ
forall a. Monoid a => a
mempty
    , event_stack :: Stack
event_stack = Stack
Stack.empty
    , event_clipped :: Bool
event_clipped = Bool
False
    }

merge_note_code_chunks :: [Chunk] -> [Chunk]
merge_note_code_chunks :: [Chunk] -> [Chunk]
merge_note_code_chunks = (Chunk -> Chunk) -> [Chunk] -> [Chunk]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> Chunk
merge
    where
    merge :: Chunk -> Chunk
merge (ChunkNotes [Event]
events) = [Event] -> Chunk
ChunkNotes ([Event] -> [Event]
merge_note_code [Event]
events)
    merge (ChunkVoices VoiceMap Event
voices) =
        VoiceMap Event -> Chunk
ChunkVoices (((Voice, [Event]) -> (Voice, [Event]))
-> VoiceMap Event -> VoiceMap Event
forall a b. (a -> b) -> [a] -> [b]
map (([Event] -> [Event]) -> (Voice, [Event]) -> (Voice, [Event])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Event] -> [Event]
merge_note_code) VoiceMap Event
voices)

-- This has to be done after rests are present, so it can attach to rests.
merge_note_code :: [Event] -> [Event]
merge_note_code :: [Event] -> [Event]
merge_note_code = [Event] -> [Event]
go
    where
    go :: [Event] -> [Event]
go [] = []
    go (Event
event : [Event]
events) = case [Event]
nonzero of
        Event
p : [Event]
ps -> [(CodePosition, Text)] -> Event -> Event
add_note_code [(CodePosition, Text)]
codes Event
p Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
ps [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [Event] -> [Event]
go [Event]
there
        [] -> [Event] -> [Event]
go [Event]
there -- TODO warn about dropped zero events
        -- TODO also warn about zero dur events with no code
        where
        ([Event]
here, [Event]
there) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Event -> Time
event_start Event
event) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start) [Event]
events
        ([Event]
zero, [Event]
nonzero) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition Event -> Bool
code_event (Event
event Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
here)
        codes :: [(CodePosition, Text)]
codes = (Event -> [(CodePosition, Text)])
-> [Event] -> [(CodePosition, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Environ -> [(CodePosition, Text)]
Constants.environ_code (Environ -> [(CodePosition, Text)])
-> (Event -> Environ) -> Event -> [(CodePosition, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ) [Event]
zero
    -- Subdivision events are a special case of zero-dur events which
    -- are not code, but are directives to the meter splitting.
    -- TODO isn't there a better way?
    code_event :: Event -> Bool
code_event Event
e = Event -> Bool
zero_dur Event
e Bool -> Bool -> Bool
&& Event -> Maybe Text
lookup_subdivision Event
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing

add_note_code :: [(Constants.CodePosition, Text)] -> Event -> Event
add_note_code :: [(CodePosition, Text)] -> Event -> Event
add_note_code [(CodePosition, Text)]
codes Event
event =
    Event
event { event_environ :: Environ
event_environ = ((CodePosition, Text) -> Environ -> Environ)
-> Environ -> [(CodePosition, Text)] -> Environ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CodePosition, Text) -> Environ -> Environ
forall {a}.
(Typecheck a, ToVal a, Semigroup a, IsString a) =>
(CodePosition, a) -> Environ -> Environ
merge (Event -> Environ
event_environ Event
event) [(CodePosition, Text)]
codes }
    where
    merge :: (CodePosition, a) -> Environ -> Environ
merge (CodePosition
pos, a
code) Environ
env = case Text -> Environ -> Maybe a
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
k Environ
env of
        Maybe a
Nothing -> Text -> a -> Environ -> Environ
forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
k a
code Environ
env
        Just a
old -> Text -> a -> Environ -> Environ
forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
k (a
old a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
code) Environ
env
        where k :: Text
k = CodePosition -> Text
Constants.position_key CodePosition
pos

-- * convert

-- TODO maybe return Either Voices [Ly] so I can avoid the concat and all the
-- extra Rights?
convert :: [Chunk] -> ConvertM [Either Voices Ly]
convert :: [Chunk] -> ConvertM [Either Voices Ly]
convert = (Chunk -> ConvertM [Either Voices Ly])
-> [Chunk] -> ConvertM [Either Voices Ly]
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM Chunk -> ConvertM [Either Voices Ly]
go
    where
    go :: Chunk -> ConvertM [Either Voices Ly]
    go :: Chunk -> ConvertM [Either Voices Ly]
go (ChunkNotes [Event]
events) =
        (Ly -> Either Voices Ly) -> [Ly] -> [Either Voices Ly]
forall a b. (a -> b) -> [a] -> [b]
map Ly -> Either Voices Ly
forall a b. b -> Either a b
Right ([Ly] -> [Either Voices Ly])
-> StateT State (ExceptT ConvertError Identity) [Ly]
-> ConvertM [Either Voices Ly]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Event]
 -> StateT State (ExceptT ConvertError Identity) ([Ly], [Event]))
-> [Event] -> StateT State (ExceptT ConvertError Identity) [Ly]
forall (m :: * -> *) a b.
Monad m =>
([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete (Bool
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_chunk Bool
True) [Event]
events
    go (ChunkVoices VoiceMap Event
voices) = VoiceMap Ly -> [Either Voices Ly]
simplify_voices (VoiceMap Ly -> [Either Voices Ly])
-> StateT State (ExceptT ConvertError Identity) (VoiceMap Ly)
-> ConvertM [Either Voices Ly]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VoiceMap Event
-> StateT State (ExceptT ConvertError Identity) (VoiceMap Ly)
voices_to_ly VoiceMap Event
voices

-- | Mix code events into the Lys, depending on their prepend or append attrs.
merge_free_code :: Time -> [FreeCode] -> [Either Voices Ly]
    -> [Either Voices Ly]
merge_free_code :: Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
merge_free_code = Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
go
    where
    go :: Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
go Time
start [FreeCode]
codes (Right Ly
ly : [Either Voices Ly]
lys) =
        Ly -> Either Voices Ly
forall a b. b -> Either a b
Right Ly
applied Either Voices Ly -> [Either Voices Ly] -> [Either Voices Ly]
forall a. a -> [a] -> [a]
: Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
go (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Ly -> Time
ly_duration Ly
ly) [FreeCode]
remain [Either Voices Ly]
lys
        where (Ly
applied, [FreeCode]
remain) = Time -> [FreeCode] -> Ly -> (Ly, [FreeCode])
merge_ly Time
start [FreeCode]
codes Ly
ly
    go Time
start [FreeCode]
codes (Left (Voices ((Voice
v, [Ly]
v1_lys) : VoiceMap Ly
voices)) : [Either Voices Ly]
lys) =
        Voices -> Either Voices Ly
forall a b. a -> Either a b
Left (VoiceMap Ly -> Voices
Voices ((Voice
v, [Ly]
applied) (Voice, [Ly]) -> VoiceMap Ly -> VoiceMap Ly
forall a. a -> [a] -> [a]
: VoiceMap Ly
voices)) Either Voices Ly -> [Either Voices Ly] -> [Either Voices Ly]
forall a. a -> [a] -> [a]
: Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
go Time
end [FreeCode]
remain [Either Voices Ly]
lys
        where ([Ly]
applied, (Time
end, [FreeCode]
remain)) = Time -> [FreeCode] -> [Ly] -> ([Ly], (Time, [FreeCode]))
merge_lys Time
start [FreeCode]
codes [Ly]
v1_lys
    go Time
start [FreeCode]
codes (Left (Voices []) : [Either Voices Ly]
lys) = Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
go Time
start [FreeCode]
codes [Either Voices Ly]
lys
    go Time
_ [FreeCode]
codes [] = ((FreeCodePosition, Text) -> Either Voices Ly)
-> [(FreeCodePosition, Text)] -> [Either Voices Ly]
forall a b. (a -> b) -> [a] -> [b]
map (Ly -> Either Voices Ly
forall a b. b -> Either a b
Right (Ly -> Either Voices Ly)
-> ((FreeCodePosition, Text) -> Ly)
-> (FreeCodePosition, Text)
-> Either Voices Ly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Ly
LyCode (Text -> Ly)
-> ((FreeCodePosition, Text) -> Text)
-> (FreeCodePosition, Text)
-> Ly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeCodePosition, Text) -> Text
forall a b. (a, b) -> b
snd) ((FreeCode -> [(FreeCodePosition, Text)])
-> [FreeCode] -> [(FreeCodePosition, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FreeCode -> [(FreeCodePosition, Text)]
forall a b. (a, b) -> b
snd [FreeCode]
codes)

    merge_lys :: Time -> [FreeCode] -> [Ly] -> ([Ly], (Time, [FreeCode]))
merge_lys Time
start [FreeCode]
codes (Ly
ly : [Ly]
lys) =
        ([Ly] -> [Ly])
-> ([Ly], (Time, [FreeCode])) -> ([Ly], (Time, [FreeCode]))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Ly
applied:) (([Ly], (Time, [FreeCode])) -> ([Ly], (Time, [FreeCode])))
-> ([Ly], (Time, [FreeCode])) -> ([Ly], (Time, [FreeCode]))
forall a b. (a -> b) -> a -> b
$ Time -> [FreeCode] -> [Ly] -> ([Ly], (Time, [FreeCode]))
merge_lys (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Ly -> Time
ly_duration Ly
ly) [FreeCode]
remain [Ly]
lys
        where (Ly
applied, [FreeCode]
remain) = Time -> [FreeCode] -> Ly -> (Ly, [FreeCode])
merge_ly Time
start [FreeCode]
codes Ly
ly
    merge_lys Time
start [FreeCode]
codes [] = ([], (Time
start, [FreeCode]
codes))

    merge_ly :: Time -> [FreeCode] -> Ly -> (Ly, [FreeCode])
merge_ly Time
start [FreeCode]
codes Ly
ly = case Ly
ly of
        Ly
_ | [FreeCode] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FreeCode]
here -> (Ly
ly, [FreeCode]
codes)
        LyBarline {} -> (Ly
ly, [FreeCode]
codes)
        LyCode {} -> (Ly
ly, [FreeCode]
codes)
        Ly
_ -> case [(FreeCodePosition, Text)] -> Ly -> Maybe Ly
apply_free_code ((FreeCode -> [(FreeCodePosition, Text)])
-> [FreeCode] -> [(FreeCodePosition, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FreeCode -> [(FreeCodePosition, Text)]
forall a b. (a, b) -> b
snd [FreeCode]
here) Ly
ly of
            -- TODO I couldn't find anything to attach to, so I should drop it
            -- and emit a warning instead of just attaching it to the next one.
            Maybe Ly
Nothing -> (Ly
ly, [FreeCode]
codes)
            Just Ly
applied -> (Ly
applied, [FreeCode]
there)
        where
        ([FreeCode]
here, [FreeCode]
there) = (FreeCode -> Bool) -> [FreeCode] -> ([FreeCode], [FreeCode])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<Time
end) (Time -> Bool) -> (FreeCode -> Time) -> FreeCode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeCode -> Time
forall a b. (a, b) -> a
fst) [FreeCode]
codes
        end :: Time
end = Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Ly -> Time
ly_duration Ly
ly

apply_free_code :: [(Constants.FreeCodePosition, Code)] -> Ly -> Maybe Ly
apply_free_code :: [(FreeCodePosition, Text)] -> Ly -> Maybe Ly
apply_free_code [(FreeCodePosition, Text)]
codes Ly
ly = case Ly
ly of
    LyNote Note
note -> Ly -> Maybe Ly
forall a. a -> Maybe a
Just (Ly -> Maybe Ly) -> Ly -> Maybe Ly
forall a b. (a -> b) -> a -> b
$ Note -> Ly
LyNote (Note -> Ly) -> Note -> Ly
forall a b. (a -> b) -> a -> b
$ Note
note
        { note_prepend :: [Text]
note_prepend = [Text]
prepend [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Note -> [Text]
note_prepend Note
note
        , note_append :: [Text]
note_append = Note -> [Text]
note_append Note
note [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
append
        }
    LyRest Rest
rest -> Ly -> Maybe Ly
forall a. a -> Maybe a
Just (Ly -> Maybe Ly) -> Ly -> Maybe Ly
forall a b. (a -> b) -> a -> b
$ Rest -> Ly
LyRest (Rest -> Ly) -> Rest -> Ly
forall a b. (a -> b) -> a -> b
$ Rest
rest
        { rest_prepend :: [Text]
rest_prepend = [Text]
prepend [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Rest -> [Text]
rest_prepend Rest
rest
        , rest_append :: [Text]
rest_append = Rest -> [Text]
rest_append Rest
rest [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
append
        }
    LyNested Nested
nested -> do
        [Ly]
lys <- [Ly] -> Maybe [Ly]
apply_nested ([Ly] -> Maybe [Ly]) -> [Ly] -> Maybe [Ly]
forall a b. (a -> b) -> a -> b
$ NonEmpty Ly -> [Ly]
forall a. NonEmpty a -> [a]
NonEmpty.toList (Nested -> NonEmpty Ly
nested_contents Nested
nested)
        NonEmpty Ly
lys <- [Ly] -> Maybe (NonEmpty Ly)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Ly]
lys
        Ly -> Maybe Ly
forall (m :: * -> *) a. Monad m => a -> m a
return (Ly -> Maybe Ly) -> Ly -> Maybe Ly
forall a b. (a -> b) -> a -> b
$ Nested -> Ly
LyNested (Nested -> Ly) -> Nested -> Ly
forall a b. (a -> b) -> a -> b
$ Nested
nested { nested_contents :: NonEmpty Ly
nested_contents = NonEmpty Ly
lys }
    Ly
_ -> Maybe Ly
forall a. Maybe a
Nothing
    where
    ([Text]
prepend, [Text]
append) = ([(FreeCodePosition, Text)] -> [Text])
-> ([(FreeCodePosition, Text)] -> [Text])
-> ([(FreeCodePosition, Text)], [(FreeCodePosition, Text)])
-> ([Text], [Text])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (((FreeCodePosition, Text) -> Text)
-> [(FreeCodePosition, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FreeCodePosition, Text) -> Text
forall a b. (a, b) -> b
snd) (((FreeCodePosition, Text) -> Text)
-> [(FreeCodePosition, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FreeCodePosition, Text) -> Text
forall a b. (a, b) -> b
snd) (([(FreeCodePosition, Text)], [(FreeCodePosition, Text)])
 -> ([Text], [Text]))
-> ([(FreeCodePosition, Text)], [(FreeCodePosition, Text)])
-> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$
        ((FreeCodePosition, Text) -> Bool)
-> [(FreeCodePosition, Text)]
-> ([(FreeCodePosition, Text)], [(FreeCodePosition, Text)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((FreeCodePosition -> FreeCodePosition -> Bool
forall a. Eq a => a -> a -> Bool
==FreeCodePosition
Constants.FreePrepend) (FreeCodePosition -> Bool)
-> ((FreeCodePosition, Text) -> FreeCodePosition)
-> (FreeCodePosition, Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FreeCodePosition, Text) -> FreeCodePosition
forall a b. (a, b) -> a
fst) [(FreeCodePosition, Text)]
codes
    -- Apply to the first place that takes it, or Nothing if there was none.
    apply_nested :: [Ly] -> Maybe [Ly]
apply_nested [] = Maybe [Ly]
forall a. Maybe a
Nothing
    apply_nested (Ly
ly : [Ly]
lys) = case [(FreeCodePosition, Text)] -> Ly -> Maybe Ly
apply_free_code [(FreeCodePosition, Text)]
codes Ly
ly of
        Maybe Ly
Nothing -> (Ly
ly:) ([Ly] -> [Ly]) -> Maybe [Ly] -> Maybe [Ly]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ly] -> Maybe [Ly]
apply_nested [Ly]
lys
        Just Ly
applied -> [Ly] -> Maybe [Ly]
forall a. a -> Maybe a
Just ([Ly] -> Maybe [Ly]) -> [Ly] -> Maybe [Ly]
forall a b. (a -> b) -> a -> b
$ Ly
applied Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
: [Ly]
lys

type FreeCode = (Time, [(Constants.FreeCodePosition, Code)])

free_code :: Event -> Maybe FreeCode
free_code :: Event -> Maybe FreeCode
free_code Event
event
    | [(FreeCodePosition, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FreeCodePosition, Text)]
code = Maybe FreeCode
forall a. Maybe a
Nothing
    | Bool
otherwise = FreeCode -> Maybe FreeCode
forall a. a -> Maybe a
Just (Event -> Time
event_start Event
event, [(FreeCodePosition, Text)]
code)
    where code :: [(FreeCodePosition, Text)]
code = Environ -> [(FreeCodePosition, Text)]
Constants.environ_free_code (Event -> Environ
event_environ Event
event)

until_complete :: Monad m => ([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete :: forall (m :: * -> *) a b.
Monad m =>
([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete [a] -> m ([b], [a])
f = [a] -> m [b]
go
    where
    go :: [a] -> m [b]
go [] = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go [a]
as = do
        ([b]
bs, [a]
as) <- [a] -> m ([b], [a])
f [a]
as
        ([b]
bs++) ([b] -> [b]) -> m [b] -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> m [b]
go [a]
as

-- ** convert_chunk

-- | Convert the rests for the first event, and a single slice of time.
-- If notes had to be split and tied, they are put back into the remaining
-- events.
-- TODO the name should change, now that Chunk is something else
convert_chunk :: Bool -> [Event] -> ConvertM ([Ly], [Event])
convert_chunk :: Bool
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_chunk Bool
_ [] = ([Ly], [Event])
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
convert_chunk Bool
metered (Event
event : [Event]
events) = Event
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
forall a. Event -> ConvertM a -> ConvertM a
with_event Event
event (StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
 -> StateT State (ExceptT ConvertError Identity) ([Ly], [Event]))
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
forall a b. (a -> b) -> a -> b
$ if
    | Just ((RealTime
score_dur, RealTime
real_dur), (Event
_, [Event]
remain))
            <- (Environ -> Maybe (RealTime, RealTime))
-> Maybe ((RealTime, RealTime), (Event, [Event]))
forall {a}. (Environ -> Maybe a) -> Maybe (a, (Event, [Event]))
find Environ -> Maybe (RealTime, RealTime)
Constants.get_tuplet -> do
        Time
score_dur <- RealTime -> ConvertM Time
real_to_time RealTime
score_dur
        Time
real_dur <- RealTime -> ConvertM Time
real_to_time RealTime
real_dur
        Time
-> Time
-> Time
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_tuplet Time
start Time
score_dur Time
real_dur [Event]
remain
    | Just ((), (Event
event, [Event]
remain)) <- (Environ -> Maybe ()) -> Maybe ((), (Event, [Event]))
forall {a}. (Environ -> Maybe a) -> Maybe (a, (Event, [Event]))
find Environ -> Maybe ()
has_tremolo ->
        Event
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_tremolo Event
event [Event]
remain
    | Bool
otherwise -> Bool
-> NonEmpty Event
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_chord Bool
metered (Event
event Event -> [Event] -> NonEmpty Event
forall a. a -> [a] -> NonEmpty a
:| [Event]
events)
    where
    has_tremolo :: Environ -> Maybe ()
has_tremolo Environ
env
        | Text -> Environ -> Bool
Env.is_set Text
Constants.v_tremolo Environ
env = () -> Maybe ()
forall a. a -> Maybe a
Just ()
        | Bool
otherwise = Maybe ()
forall a. Maybe a
Nothing
    start :: Time
start = Event -> Time
event_start Event
event
    find :: (Environ -> Maybe a) -> Maybe (a, (Event, [Event]))
find Environ -> Maybe a
match = Time
-> (Event -> Maybe a) -> [Event] -> Maybe (a, (Event, [Event]))
forall a.
Time
-> (Event -> Maybe a) -> [Event] -> Maybe (a, (Event, [Event]))
find_here Time
start (Environ -> Maybe a
match (Environ -> Maybe a) -> (Event -> Environ) -> Event -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ) (Event
event Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
events)

find_here :: Time -> (Event -> Maybe a) -> [Event]
    -> Maybe (a, (Event, [Event]))
find_here :: forall a.
Time
-> (Event -> Maybe a) -> [Event] -> Maybe (a, (Event, [Event]))
find_here Time
start Event -> Maybe a
match [Event]
events = [Maybe (a, (Event, [Event]))] -> Maybe (a, (Event, [Event]))
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe (a, (Event, [Event]))] -> Maybe (a, (Event, [Event])))
-> [Maybe (a, (Event, [Event]))] -> Maybe (a, (Event, [Event]))
forall a b. (a -> b) -> a -> b
$ ((Event, [Event]) -> Maybe (a, (Event, [Event])))
-> [(Event, [Event])] -> [Maybe (a, (Event, [Event]))]
forall a b. (a -> b) -> [a] -> [b]
map (Event, [Event]) -> Maybe (a, (Event, [Event]))
find ([Event] -> [(Event, [Event])]
forall a. [a] -> [(a, [a])]
focus [Event]
here)
    where
    find :: (Event, [Event]) -> Maybe (a, (Event, [Event]))
find (Event
e, [Event]
es) = (, (Event
e, [Event]
es [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [Event]
later)) (a -> (a, (Event, [Event])))
-> Maybe a -> Maybe (a, (Event, [Event]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe a
match Event
e
    ([Event]
here, [Event]
later) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<=Time
start) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start) [Event]
events

-- | Focus on each element in turn, removing it from the list.
focus :: [a] -> [(a, [a])]
focus :: forall a. [a] -> [(a, [a])]
focus (a
x:[a]
xs) = (a
x, [a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: ((a, [a]) -> (a, [a])) -> [(a, [a])] -> [(a, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (([a] -> [a]) -> (a, [a]) -> (a, [a])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a
x:)) ([a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
focus [a]
xs)
focus [] = []

lookup_env :: Typecheck.Typecheck a => Env.Key -> Event -> Maybe a
lookup_env :: forall a. Typecheck a => Text -> Event -> Maybe a
lookup_env Text
k = Text -> Environ -> Maybe a
forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
k (Environ -> Maybe a) -> (Event -> Environ) -> Event -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ

lookup_subdivision :: Event -> Maybe Text
lookup_subdivision :: Event -> Maybe Text
lookup_subdivision = Text -> Event -> Maybe Text
forall a. Typecheck a => Text -> Event -> Maybe a
lookup_env Text
Constants.v_subdivision

get_code :: Env.Key -> Event -> Code
get_code :: Text -> Event -> Text
get_code Text
k = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> (Event -> Maybe Text) -> Event -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Event -> Maybe Text
forall a. Typecheck a => Text -> Event -> Maybe a
lookup_env Text
k

zero_dur :: Event -> Bool
zero_dur :: Event -> Bool
zero_dur = (Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
==Time
0) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_duration

-- ** convert_tuplet

-- | Collect the notes inside the duration, run a special 'convert_chunk' on
-- them where the meter is ok with any duration, then wrap that in \tuplet,
-- and increment time by duration * 3/2.
convert_tuplet :: Time
    -> Time -- ^ score duration of notes of the tuplet
    -> Time
    -> [Event] -- ^ extract the overlapped events and render in the tuplet
    -> ConvertM ([Ly], [Event])
convert_tuplet :: Time
-> Time
-> Time
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_tuplet Time
start Time
score_dur Time
real_dur [Event]
events = do
    let ([Event]
in_tuplet, [Event]
out) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
score_dur) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start) [Event]
events
    State
old <- StateT State (ExceptT ConvertError Identity) State
forall s (m :: * -> *). MonadState s m => m s
State.get

    -- The usual convention for tuplets is that the notes have longer values
    -- but are shortened to fit, e.g. 3/8 into the time of 2/8.  But duplets
    -- are the opposite, they are shorter and are made longer, e.g. 2/8 in the
    -- time of 3/8.  Don't ask me why, that's just the convention.  I always
    -- get shorter notes so they fit under the parent tuplet event, so for
    -- triplet 1/8s, I get score_dur = 3/16, real_dur = 2/8, then double to
    -- score_dur = 3/8s.
    let is_duplet :: Bool
is_duplet = Rational -> Integer
forall a. Ratio a -> a
Ratio.numerator (Time -> Rational
Types.to_whole Time
score_dur) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
    let factor :: Int
factor = if Bool
is_duplet then Int
1 else Int
2
    Time
score_dur <- Time -> ConvertM Time
forall (m :: * -> *) a. Monad m => a -> m a
return (Time -> ConvertM Time) -> Time -> ConvertM Time
forall a b. (a -> b) -> a -> b
$ if Bool
is_duplet then Time
score_dur else Time
score_dur Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
2
    Bool
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
real_dur Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
0) (StateT State (ExceptT ConvertError Identity) ()
 -> StateT State (ExceptT ConvertError Identity) ())
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$
        Text -> StateT State (ExceptT ConvertError Identity) ()
forall a. Text -> ConvertM a
throw (Text -> StateT State (ExceptT ConvertError Identity) ())
-> Text -> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ Text
"tuplet with a real_dur of 0: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Time, Time, Time) -> Text
forall a. Pretty a => a -> Text
pretty (Time
start, Time
score_dur, Time
real_dur)
    let divisor :: Rational
divisor = Time -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
score_dur Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Time -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
real_dur :: Rational
    -- This probably means the notes have been stretched or something and
    -- aren't on simple divisions.
    Bool
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rational -> Integer
forall a. Ratio a -> a
Ratio.numerator Rational
divisor Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
15 Bool -> Bool -> Bool
|| Rational -> Integer
forall a. Ratio a -> a
Ratio.denominator Rational
divisor Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
15) (StateT State (ExceptT ConvertError Identity) ()
 -> StateT State (ExceptT ConvertError Identity) ())
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$
        Text -> StateT State (ExceptT ConvertError Identity) ()
forall a. Text -> ConvertM a
throw (Text -> StateT State (ExceptT ConvertError Identity) ())
-> Text -> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ Text
"tuplet factor is too complicated: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Show a => a -> Text
showt Time
score_dur
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Show a => a -> Text
showt Time
real_dur

    -- TODO it's probably wrong to do this unmetered.  I should instead act as
    -- if the meter has changed.
    [Ly]
lys <- ([Event]
 -> StateT State (ExceptT ConvertError Identity) ([Ly], [Event]))
-> [Event] -> StateT State (ExceptT ConvertError Identity) [Ly]
forall (m :: * -> *) a b.
Monad m =>
([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete (Bool
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_chunk Bool
False) ([Event] -> StateT State (ExceptT ConvertError Identity) [Ly])
-> [Event] -> StateT State (ExceptT ConvertError Identity) [Ly]
forall a b. (a -> b) -> a -> b
$
        (Time, [Event]) -> [Event]
forall a b. (a, b) -> b
snd ((Time, [Event]) -> [Event]) -> (Time, [Event]) -> [Event]
forall a b. (a -> b) -> a -> b
$ Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests (Time -> Maybe Time
forall a. a -> Maybe a
Just (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
score_dur)) Time
start ([Event] -> (Time, [Event])) -> [Event] -> (Time, [Event])
forall a b. (a -> b) -> a -> b
$
        (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Time -> Event -> Event
stretch Int
factor Time
start) [Event]
in_tuplet
    NonEmpty Ly
lys <- StateT State (ExceptT ConvertError Identity) (NonEmpty Ly)
-> (NonEmpty Ly
    -> StateT State (ExceptT ConvertError Identity) (NonEmpty Ly))
-> Maybe (NonEmpty Ly)
-> StateT State (ExceptT ConvertError Identity) (NonEmpty Ly)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> StateT State (ExceptT ConvertError Identity) (NonEmpty Ly)
forall a. Text -> ConvertM a
throw Text
"empty tuplet") NonEmpty Ly
-> StateT State (ExceptT ConvertError Identity) (NonEmpty Ly)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (NonEmpty Ly)
 -> StateT State (ExceptT ConvertError Identity) (NonEmpty Ly))
-> Maybe (NonEmpty Ly)
-> StateT State (ExceptT ConvertError Identity) (NonEmpty Ly)
forall a b. (a -> b) -> a -> b
$ [Ly] -> Maybe (NonEmpty Ly)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Ly]
lys

    -- Rewind time back to before the tuplet.
    (State -> State) -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((State -> State)
 -> StateT State (ExceptT ConvertError Identity) ())
-> (State -> State)
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
        { state_time :: Time
state_time = State -> Time
state_time State
old
        , state_meters :: [Meter]
state_meters = State -> [Meter]
state_meters State
old
        , state_measure_start :: Time
state_measure_start = State -> Time
state_measure_start State
old
        , state_measure_end :: Time
state_measure_end = State -> Time
state_measure_end State
old
        }
    Maybe Ly
barline <- Text -> ConvertM (Maybe Ly) -> ConvertM (Maybe Ly)
forall a. Text -> ConvertM a -> ConvertM a
with_context Text
"converting tuplet" (ConvertM (Maybe Ly) -> ConvertM (Maybe Ly))
-> ConvertM (Maybe Ly) -> ConvertM (Maybe Ly)
forall a b. (a -> b) -> a -> b
$
        Time -> ConvertM (Maybe Ly)
advance_measure (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
real_dur)
    let code :: Ly
code = Time -> Rational -> Int -> NonEmpty Ly -> Ly
tuplet_code Time
real_dur Rational
divisor
            ([Ly] -> Int
count_notes_rests (NonEmpty Ly -> [Ly]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Ly
lys)) NonEmpty Ly
lys
    ([Ly], [Event])
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ly
code Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
: [Ly] -> (Ly -> [Ly]) -> Maybe Ly -> [Ly]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
:[]) Maybe Ly
barline, [Event]
out)

-- | Convention is that the number on the tuplet is at least the number of
-- notes inside, but lilypond doesn't do that automatically.
tuplet_code :: Time -> Rational -> Int -> NonEmpty Ly -> Ly
tuplet_code :: Time -> Rational -> Int -> NonEmpty Ly -> Ly
tuplet_code Time
dur Rational
ratio Int
notes NonEmpty Ly
contents = Nested -> Ly
LyNested (Nested -> Ly) -> Nested -> Ly
forall a b. (a -> b) -> a -> b
$ Nested
    { nested_prefix :: Text
nested_prefix = Text
"\\tuplet " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
showt Integer
num Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. Show a => a -> Text
showt Integer
denom Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" {"
    , nested_contents :: NonEmpty Ly
nested_contents = NonEmpty Ly
contents
    , nested_suffix :: Text
nested_suffix = Text
"}"
    , nested_duration :: Time
nested_duration = Time
dur
    }
    where
    num :: Integer
num = Rational -> Integer
forall a. Ratio a -> a
Ratio.numerator Rational
ratio Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
factor
    denom :: Integer
denom = Rational -> Integer
forall a. Ratio a -> a
Ratio.denominator Rational
ratio Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
factor
    factor :: Integer
factor = (Integer
2^) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Integer) -> Double -> Integer
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$
        Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
notes Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rational -> Integer
forall a. Ratio a -> a
Ratio.numerator Rational
ratio)

real_to_time :: RealTime -> ConvertM Time
real_to_time :: RealTime -> ConvertM Time
real_to_time RealTime
t = do
    RealTime
quarter <- (State -> RealTime)
-> StateT State (ExceptT ConvertError Identity) RealTime
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ((State -> RealTime)
 -> StateT State (ExceptT ConvertError Identity) RealTime)
-> (State -> RealTime)
-> StateT State (ExceptT ConvertError Identity) RealTime
forall a b. (a -> b) -> a -> b
$ Config -> RealTime
Types.config_quarter_duration (Config -> RealTime) -> (State -> Config) -> State -> RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
state_config
    Time -> ConvertM Time
forall (m :: * -> *) a. Monad m => a -> m a
return (Time -> ConvertM Time) -> Time -> ConvertM Time
forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> Time
Types.real_to_time RealTime
quarter RealTime
t

stretch :: Int -> Time -> Event -> Event
stretch :: Int -> Time -> Event -> Event
stretch Int
factor Time
start Event
event
    | Int
factor Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Event
event
    | Bool
otherwise = Event
event
        { event_start :: Time
event_start =
            Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
factor Time -> Time -> Time
forall a. Num a => a -> a -> a
* (Event -> Time
event_start Event
event Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
start) Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
start
        , event_duration :: Time
event_duration = Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
factor Time -> Time -> Time
forall a. Num a => a -> a -> a
* Event -> Time
event_duration Event
event
        }

-- ** convert_tremolo

-- | Get just pitch and code from in_tremolo notes, force them to 32nd note
-- duration, wrap in (), and wrap the whole thing in \repeat tremolo { ... }.
--
-- TODO This is sort of an ad-hoc reimplementation of 'convert_chord', which is
-- grody.  But the rules are different in a tremolo, duration-wise it's like
-- a chord, but code always has to go on the notes inside, not after the whole
-- thing.
convert_tremolo :: Event -> [Event] -> ConvertM ([Ly], [Event])
convert_tremolo :: Event
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_tremolo Event
tremolo_event [Event]
events = do
    Time
dur <- ConvertM Time
get_allowed_dur
    let ([Event]
in_tremolo, [Event]
out) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dur) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start) [Event]
events
    [Event]
in_tremolo <- [Event] -> ConvertM [Event]
consume_subdivisions [Event]
in_tremolo
    Attributes
prev_attrs <- (State -> Attributes)
-> StateT State (ExceptT ConvertError Identity) Attributes
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Attributes
state_prev_attrs
    let (Attributes
next_attrs, [Note]
notes) = Attributes -> [Event] -> (Attributes, [Note])
tremolo_notes Attributes
prev_attrs [Event]
in_tremolo
    (State -> State) -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((State -> State)
 -> StateT State (ExceptT ConvertError Identity) ())
-> (State -> State)
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state { state_prev_attrs :: Attributes
state_prev_attrs = Attributes
next_attrs }

    -- TODO promote this to the caller so everyone doesn't have to do it?
    Maybe Ly
barline <- Time -> ConvertM (Maybe Ly)
advance_measure (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dur)

    let (Int
times, Rational
frac) = Rational -> (Int, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Rational -> (Int, Rational)) -> Rational -> (Int, Rational)
forall a b. (a -> b) -> a -> b
$ Time -> Rational
Types.to_whole Time
dur Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
16
    Bool
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rational
frac Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0) (StateT State (ExceptT ConvertError Identity) ()
 -> StateT State (ExceptT ConvertError Identity) ())
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ Text -> StateT State (ExceptT ConvertError Identity) ()
forall a. Text -> ConvertM a
throw (Text -> StateT State (ExceptT ConvertError Identity) ())
-> Text -> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ Text
"dur " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty Time
dur
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" doesn't yield an integral number of 16th notes: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Rational -> Text
forall a. Pretty a => a -> Text
pretty (Time -> Rational
Types.to_whole Time
dur Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
16)
    let ([Text]
prepend, [Text]
append) =
            Attach -> Bool -> Bool -> [Event] -> ([Text], [Text])
events_note_code Attach
Constants.Chord Bool
True Bool
True [Event]
in_tremolo
        ([Text]
nprepend, [Text]
nappend) =
            Attach -> Bool -> Bool -> [Event] -> ([Text], [Text])
events_note_code Attach
Constants.Note Bool
True Bool
True [Event]
in_tremolo

    let clipped :: [Event]
clipped
            | Time
dur Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
total_dur = []
            | Bool
otherwise = (Event -> Maybe Event) -> [Event] -> [Event]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time -> Event -> Maybe Event
clip_event (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dur))
                (Event
tremolo_event Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
in_tremolo)
    NonEmpty Note
notes <- StateT State (ExceptT ConvertError Identity) (NonEmpty Note)
-> (NonEmpty Note
    -> StateT State (ExceptT ConvertError Identity) (NonEmpty Note))
-> Maybe (NonEmpty Note)
-> StateT State (ExceptT ConvertError Identity) (NonEmpty Note)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text
-> StateT State (ExceptT ConvertError Identity) (NonEmpty Note)
forall a. Text -> ConvertM a
throw Text
"no notes in tremolo") NonEmpty Note
-> StateT State (ExceptT ConvertError Identity) (NonEmpty Note)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (NonEmpty Note)
 -> StateT State (ExceptT ConvertError Identity) (NonEmpty Note))
-> Maybe (NonEmpty Note)
-> StateT State (ExceptT ConvertError Identity) (NonEmpty Note)
forall a b. (a -> b) -> a -> b
$
        [Note] -> Maybe (NonEmpty Note)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Note]
notes
    let note :: Nested
note = Time -> Int -> NonEmpty Note -> [Text] -> [Text] -> Nested
tremolo_note Time
dur Int
times NonEmpty Note
notes
            ([Text]
prepend [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
nprepend) ([Text]
nappend [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
append)
    ([Ly], [Event])
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (Nested -> Ly
LyNested Nested
note Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
: [Ly] -> (Ly -> [Ly]) -> Maybe Ly -> [Ly]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
:[]) Maybe Ly
barline, [Event]
clipped [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [Event]
out)

    where
    start :: Time
start = Event -> Time
event_start Event
tremolo_event
    total_dur :: Time
total_dur = Event -> Time
event_duration Event
tremolo_event
    get_allowed_dur :: ConvertM Time
get_allowed_dur = do
        Meter
meter <- ConvertM Meter
get_subdivision
        Time
measure_start <- (State -> Time) -> ConvertM Time
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Time
state_measure_start
        Time -> ConvertM Time
forall (m :: * -> *) a. Monad m => a -> m a
return (Time -> ConvertM Time) -> Time -> ConvertM Time
forall a b. (a -> b) -> a -> b
$ NoteDuration -> Time
Types.note_dur_to_time (NoteDuration -> Time) -> NoteDuration -> Time
forall a b. (a -> b) -> a -> b
$ Bool -> Meter -> Time -> Time -> NoteDuration
Meter.allowed_duration Bool
use_dot Meter
meter
            (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
measure_start)
            (Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
measure_start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Event -> Time
event_duration Event
tremolo_event)
        where use_dot :: Bool
use_dot = Bool
True

tremolo_note :: Time -> Int -> NonEmpty Note -> [Code] -> [Code] -> Nested
tremolo_note :: Time -> Int -> NonEmpty Note -> [Text] -> [Text] -> Nested
tremolo_note Time
dur Int
times (Note
note :| [Note]
notes) [Text]
prepend [Text]
append = Nested
    { nested_prefix :: Text
nested_prefix = Text
"\\repeat tremolo " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
times Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" {"
    , nested_contents :: NonEmpty Ly
nested_contents = (Note -> Ly) -> NonEmpty Note -> NonEmpty Ly
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Note -> Ly
LyNote (Note
with_code Note -> [Note] -> NonEmpty Note
forall a. a -> [a] -> NonEmpty a
:| [Note]
notes)
    , nested_suffix :: Text
nested_suffix = Text
"}"
    , nested_duration :: Time
nested_duration = Time
dur
    }
    where
    with_code :: Note
with_code = Note
note
        { note_prepend :: [Text]
note_prepend = [Text]
prepend [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Note -> [Text]
note_prepend Note
note
        , note_append :: [Text]
note_append = Note -> [Text]
note_append Note
note [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
append
        }

tremolo_notes :: Attrs.Attributes -> [Event] -> (Attrs.Attributes, [Note])
tremolo_notes :: Attributes -> [Event] -> (Attributes, [Note])
tremolo_notes Attributes
prev_attrs = (Attributes -> (Bool, Event, Bool) -> (Attributes, Note))
-> Attributes -> [(Bool, Event, Bool)] -> (Attributes, [Note])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Attributes -> (Bool, Event, Bool) -> (Attributes, Note)
make Attributes
prev_attrs ([(Bool, Event, Bool)] -> (Attributes, [Note]))
-> ([Event] -> [(Bool, Event, Bool)])
-> [Event]
-> (Attributes, [Note])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> [(Bool, Event, Bool)]
forall a. [a] -> [(Bool, a, Bool)]
zip_first_last
    where
    make :: Attributes -> (Bool, Event, Bool) -> (Attributes, Note)
make Attributes
prev_attrs (Bool
is_first, Event
event, Bool
is_last) = (Attributes
next_attrs,) (Note -> (Attributes, Note)) -> Note -> (Attributes, Note)
forall a b. (a -> b) -> a -> b
$ Note
        { note_pitches :: NonEmpty NotePitch
note_pitches = NotePitch
            { pitch_pitch :: Text
pitch_pitch = Bool -> Event -> Text
pitch_code Bool
is_first Event
event
            , pitch_tie :: Tie
pitch_tie = Tie
NoTie
            , pitch_prepend :: [Text]
pitch_prepend = []
            , pitch_append :: [Text]
pitch_append = [Text]
slur
            } NotePitch -> [NotePitch] -> NonEmpty NotePitch
forall a. a -> [a] -> NonEmpty a
:| []
        , note_duration :: NoteDuration
note_duration = Duration -> Bool -> NoteDuration
Types.NoteDuration Duration
Types.D32 Bool
False
        , note_prepend :: [Text]
note_prepend = []
        , note_append :: [Text]
note_append = [Text]
attrs_codes
        , note_stack :: Maybe UiFrame
note_stack = [UiFrame] -> Maybe UiFrame
forall a. [a] -> Maybe a
Seq.last ([UiFrame] -> Maybe UiFrame) -> [UiFrame] -> Maybe UiFrame
forall a b. (a -> b) -> a -> b
$ Stack -> [UiFrame]
Stack.to_ui (Event -> Stack
event_stack Event
event)
        }
        where
        slur :: [Text]
slur
            | Bool
is_first Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
is_last = [Text
"("]
            | Bool -> Bool
not Bool
is_first Bool -> Bool -> Bool
&& Bool
is_last = [Text
")"]
            | Bool
otherwise = []
        ([Text]
attrs_codes, Attributes
next_attrs) =
            Attributes -> Attributes -> ([Text], Attributes)
attrs_to_code Attributes
prev_attrs (Event -> Attributes
event_attributes Event
event)

zip_first_last :: [a] -> [(Bool, a, Bool)]
zip_first_last :: forall a. [a] -> [(Bool, a, Bool)]
zip_first_last = ((Maybe a, a, Maybe a) -> (Bool, a, Bool))
-> [(Maybe a, a, Maybe a)] -> [(Bool, a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a, a, Maybe a) -> (Bool, a, Bool)
forall {a} {b} {a}. (Maybe a, b, Maybe a) -> (Bool, b, Bool)
to_bool ([(Maybe a, a, Maybe a)] -> [(Bool, a, Bool)])
-> ([a] -> [(Maybe a, a, Maybe a)]) -> [a] -> [(Bool, a, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [(Maybe a, a, Maybe a)]
forall a. [a] -> [(Maybe a, a, Maybe a)]
Seq.zip_neighbors
    where
    to_bool :: (Maybe a, b, Maybe a) -> (Bool, b, Bool)
to_bool (Maybe a
prev, b
cur, Maybe a
next) =
        (Maybe a -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing Maybe a
prev, b
cur, Maybe a -> Bool
forall a. Maybe a -> Bool
Maybe.isNothing Maybe a
next)


-- ** convert_chord

-- | This is the lowest level of conversion.  It converts a vertical slice of
-- notes starting at the first event, and returns the rest.
convert_chord :: Bool -> NonEmpty Event -> ConvertM ([Ly], [Event])
convert_chord :: Bool
-> NonEmpty Event
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_chord Bool
metered NonEmpty Event
events = do
    Key
key <- Event -> ConvertM Key
lookup_key (NonEmpty Event -> Event
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
events)
    State
state <- StateT State (ExceptT ConvertError Identity) State
forall s (m :: * -> *). MonadState s m => m s
State.get
    Config
config <- (State -> Config)
-> StateT State (ExceptT ConvertError Identity) Config
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Config
state_config
    let ([Event]
here, [Event]
there) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break
            ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Event -> Time
event_start (NonEmpty Event -> Event
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
events)) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start)
            (NonEmpty Event -> [Event]
forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty Event
events)
        next :: Maybe Time
next = Event -> Time
event_start (Event -> Time) -> Maybe Event -> Maybe Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Event -> Bool) -> [Event] -> Maybe Event
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool -> Bool
not (Bool -> Bool) -> (Event -> Bool) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Bool
zero_dur) [Event]
there
    [Event]
here <- [Event] -> ConvertM [Event]
consume_subdivisions (NonEmpty Event -> Event
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
events Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
here)
    Maybe Meter
meter <- if Bool
metered then Meter -> Maybe Meter
forall a. a -> Maybe a
Just (Meter -> Maybe Meter)
-> ConvertM Meter
-> StateT State (ExceptT ConvertError Identity) (Maybe Meter)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertM Meter
get_subdivision else Maybe Meter
-> StateT State (ExceptT ConvertError Identity) (Maybe Meter)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Meter
forall a. Maybe a
Nothing
    case [Event] -> Maybe (NonEmpty Event)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Event]
here of
        Maybe (NonEmpty Event)
Nothing -> ([Ly], [Event])
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Event]
there)
        Just NonEmpty Event
here -> do
            let (Ly
chord_ly, Time
end, Attributes
last_attrs, [Event]
clipped) = Config
-> Time
-> Attributes
-> Maybe Meter
-> NonEmpty Event
-> Maybe Time
-> (Ly, Time, Attributes, [Event])
make_note
                    Config
config (State -> Time
state_measure_start State
state) (State -> Attributes
state_prev_attrs State
state)
                    Maybe Meter
meter NonEmpty Event
here Maybe Time
next
            Maybe Ly
barline <- if Bool
metered then Time -> ConvertM (Maybe Ly)
advance_measure Time
end
                else Time -> StateT State (ExceptT ConvertError Identity) ()
advance_unmetered Time
end StateT State (ExceptT ConvertError Identity) ()
-> ConvertM (Maybe Ly) -> ConvertM (Maybe Ly)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Ly -> ConvertM (Maybe Ly)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Ly
forall a. Maybe a
Nothing
            -- Rests don't affect the key, or emit key changes.  This is
            -- because rests are created with an empty environ, so otherwise
            -- they would be constantly unsetting the key.
            [Ly]
key_change <- case Ly
chord_ly of
                LyRest {} -> [Ly] -> StateT State (ExceptT ConvertError Identity) [Ly]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                Ly
_ -> do
                    (State -> State) -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((State -> State)
 -> StateT State (ExceptT ConvertError Identity) ())
-> (State -> State)
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
                        { state_key :: Key
state_key = Key
key
                        , state_prev_attrs :: Attributes
state_prev_attrs = Attributes
last_attrs
                        }
                    [Ly] -> StateT State (ExceptT ConvertError Identity) [Ly]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Ly
LyCode (Key -> Text
forall a. ToLily a => a -> Text
to_lily Key
key) | Key
key Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= State -> Key
state_key State
state]
            ([Ly], [Event])
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return
                ( [Ly]
key_change [Ly] -> [Ly] -> [Ly]
forall a. [a] -> [a] -> [a]
++ [Ly
chord_ly] [Ly] -> [Ly] -> [Ly]
forall a. [a] -> [a] -> [a]
++ [Ly] -> (Ly -> [Ly]) -> Maybe Ly -> [Ly]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
:[]) Maybe Ly
barline
                , [Event]
clipped [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [Event]
there
                )

-- | Handle any Constants.v_subdivision events and filter them out.
consume_subdivisions :: [Event] -> ConvertM [Event]
consume_subdivisions :: [Event] -> ConvertM [Event]
consume_subdivisions [Event]
events = (Text -> StateT State (ExceptT ConvertError Identity) ())
-> [Text] -> StateT State (ExceptT ConvertError Identity) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> StateT State (ExceptT ConvertError Identity) ()
update [Text]
subdivisions StateT State (ExceptT ConvertError Identity) ()
-> ConvertM [Event] -> ConvertM [Event]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Event] -> ConvertM [Event]
forall (m :: * -> *) a. Monad m => a -> m a
return [Event]
normal
    where
    ([Text]
subdivisions, [Event]
normal) = (Event -> Maybe Text) -> [Event] -> ([Text], [Event])
forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Seq.partition_on Event -> Maybe Text
lookup_subdivision [Event]
events
    update :: Text -> StateT State (ExceptT ConvertError Identity) ()
update Text
"" = (State -> State) -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((State -> State)
 -> StateT State (ExceptT ConvertError Identity) ())
-> (State -> State)
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ \State
state ->
        State
state { state_subdivision :: Maybe Meter
state_subdivision = Maybe Meter
forall a. Maybe a
Nothing }
    update Text
m = do
        Meter
meter <- (Text -> ConvertM Meter)
-> (Meter -> ConvertM Meter) -> Either Text Meter -> ConvertM Meter
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> ConvertM Meter
forall a. Text -> ConvertM a
throw Meter -> ConvertM Meter
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Meter -> ConvertM Meter)
-> Either Text Meter -> ConvertM Meter
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> Either Text Meter -> Either Text Meter
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
            ((Text
"can't parse meter in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
Constants.v_subdivision
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt Text
m Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>)
            (Text -> Either Text Meter
Meter.parse_meter Text
m)
        (State -> State) -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((State -> State)
 -> StateT State (ExceptT ConvertError Identity) ())
-> (State -> State)
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state { state_subdivision :: Maybe Meter
state_subdivision = Meter -> Maybe Meter
forall a. a -> Maybe a
Just Meter
meter }

make_note :: Types.Config -> Time -> Attrs.Attributes
    -- ^ Previous note's Attributes, to track 'modal_articulations'.
    -> Maybe Meter.Meter
    -> NonEmpty Event -- ^ Events that occur at the same time.
    -> Maybe Time -- ^ start of the next note
    -> (Ly, Time, Attrs.Attributes, [Event]) -- ^ (note, note end time, clipped)
make_note :: Config
-> Time
-> Attributes
-> Maybe Meter
-> NonEmpty Event
-> Maybe Time
-> (Ly, Time, Attributes, [Event])
make_note Config
config Time
measure_start Attributes
prev_attrs Maybe Meter
maybe_meter NonEmpty Event
chord Maybe Time
next =
    (Ly
ly, Time
allowed_end, Attributes
next_attrs, [Event]
clipped)
    where
    -- If the time is a full measure, then it uses allowed_time, not
    -- allowed_dur.
    ly :: Ly
ly = case [NotePitch] -> Maybe (NonEmpty NotePitch)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [NotePitch]
note_pitches of
        Maybe (NonEmpty NotePitch)
Nothing -> Rest -> Ly
LyRest (Rest -> Ly) -> Rest -> Ly
forall a b. (a -> b) -> a -> b
$ Rest
            { rest_type :: RestType
rest_type = case Maybe Meter
maybe_meter of
                Just Meter
meter | Bool
full_measure_rest ->
                    Duration -> Int -> RestType
FullMeasure (Meter -> Duration
Meter.meter_denom Meter
meter) (Meter -> Int
Meter.time_num Meter
meter)
                Maybe Meter
_ -> NoteDuration -> RestType
NormalRest NoteDuration
allowed_dur
            , rest_prepend :: [Text]
rest_prepend = [Text]
prepend_chord
            , rest_append :: [Text]
rest_append = [Text]
append_chord
            }
        Just NonEmpty NotePitch
pitches -> Note -> Ly
LyNote (Note -> Ly) -> Note -> Ly
forall a b. (a -> b) -> a -> b
$ Note
            { note_pitches :: NonEmpty NotePitch
note_pitches = NonEmpty NotePitch
pitches
            , note_duration :: NoteDuration
note_duration = NoteDuration
allowed_dur
            , note_prepend :: [Text]
note_prepend = [Text]
prepend_chord
            , note_append :: [Text]
note_append = [Text]
append_chord [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
attrs_codes
            , note_stack :: Maybe UiFrame
note_stack = [UiFrame] -> Maybe UiFrame
forall a. [a] -> Maybe a
Seq.last ([UiFrame] -> Maybe UiFrame) -> [UiFrame] -> Maybe UiFrame
forall a b. (a -> b) -> a -> b
$ Stack -> [UiFrame]
Stack.to_ui (Stack -> [UiFrame]) -> Stack -> [UiFrame]
forall a b. (a -> b) -> a -> b
$ Event -> Stack
event_stack (Event -> Stack) -> Event -> Stack
forall a b. (a -> b) -> a -> b
$
                NonEmpty Event -> Event
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
chord
            }
    note_pitches :: [NotePitch]
note_pitches = do
        -- Sorting by pitch puts the chord notes in a predictable order.  Some
        -- lilypond notation, such as glissandoMap, refers to chord notes by
        -- index.
        Event
event <- (Event -> Maybe Pitch) -> [Event] -> [Event]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on Event -> Maybe Pitch
event_pitch ([Event] -> [Event]) -> [Event] -> [Event]
forall a b. (a -> b) -> a -> b
$ NonEmpty Event -> [Event]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Event
chord
        let pitch :: Text
pitch = Bool -> Event -> Text
pitch_code (Event -> Bool
is_first Event
event) Event
event
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Text -> Bool
Text.null Text
pitch)
        let tie :: Tie
tie = Event -> Tie
note_tie Event
event
        let ([Text]
prepend, [Text]
append) = Attach -> Bool -> Bool -> Event -> ([Text], [Text])
event_note_code Attach
Constants.Note
                (Event -> Bool
is_first Event
event) (Event -> Bool
is_last Event
event) Event
event
        NotePitch -> [NotePitch]
forall (m :: * -> *) a. Monad m => a -> m a
return (NotePitch -> [NotePitch]) -> NotePitch -> [NotePitch]
forall a b. (a -> b) -> a -> b
$ NotePitch
            { pitch_pitch :: Text
pitch_pitch = Text
pitch
            , pitch_tie :: Tie
pitch_tie = Tie
tie
            , pitch_prepend :: [Text]
pitch_prepend = [Text]
prepend
            , pitch_append :: [Text]
pitch_append = [Text]
append
            }
    ([Text]
attrs_codes, Attributes
next_attrs)
        | Bool
is_rest = ([], Attributes
prev_attrs)
        | Bool
otherwise = Attributes -> Attributes -> ([Text], Attributes)
attrs_to_code Attributes
prev_attrs (Attributes -> ([Text], Attributes))
-> Attributes -> ([Text], Attributes)
forall a b. (a -> b) -> a -> b
$
            [Attributes] -> Attributes
forall a. Monoid a => [a] -> a
mconcat ([Attributes] -> Attributes) -> [Attributes] -> Attributes
forall a b. (a -> b) -> a -> b
$ (Event -> Attributes) -> [Event] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Attributes
event_attributes ([Event] -> [Attributes]) -> [Event] -> [Attributes]
forall a b. (a -> b) -> a -> b
$ NonEmpty Event -> [Event]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Event
chord

    ([Text]
prepend_chord, [Text]
append_chord) =
        ([[Text]] -> [Text])
-> ([[Text]] -> [Text]) -> ([[Text]], [[Text]]) -> ([Text], [Text])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
Seq.unique ([Text] -> [Text]) -> ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
Seq.unique ([Text] -> [Text]) -> ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (([[Text]], [[Text]]) -> ([Text], [Text]))
-> ([[Text]], [[Text]]) -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ [([Text], [Text])] -> ([[Text]], [[Text]])
forall a b. [(a, b)] -> ([a], [b])
unzip
            [ Attach -> Bool -> Bool -> Event -> ([Text], [Text])
event_note_code Attach
Constants.Chord (Event -> Bool
is_first Event
e) (Event -> Bool
is_last Event
e) Event
e
            | Event
e <- NonEmpty Event -> [Event]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Event
chord
            ]

    note_tie :: Event -> Tie
note_tie Event
event
        | Event -> Time
event_end Event
event Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
allowed_end = Tie
NoTie
        | Text -> Bool
Text.null Text
direction = Tie
TieNeutral
        | Text
direction Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"^" = Tie
TieUp
        | Bool
otherwise = Tie
TieDown
        where
        direction :: Text
        direction :: Text
direction = Text -> Event -> Text
get_code Text
Constants.v_tie_direction Event
event
    is_first :: Event -> Bool
is_first = Bool -> Bool
not (Bool -> Bool) -> (Event -> Bool) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Bool
event_clipped
    is_last :: Event -> Bool
is_last Event
event = case Event -> Tie
note_tie Event
event of
        Tie
NoTie -> Bool
True
        Tie
_ -> Bool
False

    clipped :: [Event]
clipped = (Event -> Maybe Event) -> [Event] -> [Event]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time -> Event -> Maybe Event
clip_event Time
allowed_end) (NonEmpty Event -> [Event]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Event
chord)
    start :: Time
start = Event -> Time
event_start (NonEmpty Event -> Event
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
chord)

    -- FullMeasure rests are special because they can have a non-Duration
    -- time.
    allowed_end :: Time
allowed_end = Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
allowed_time
    (Bool
full_measure_rest, Time
allowed_time) = case Maybe Meter
maybe_meter of
        Just Meter
meter | Bool
is_rest Bool -> Bool -> Bool
&& Time
start Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
measure_start
                Bool -> Bool -> Bool
&& Time
max_end Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
start Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Meter -> Time
Meter.measure_time Meter
meter ->
            (Bool
True, Meter -> Time
Meter.measure_time Meter
meter)
        Maybe Meter
_ -> (Bool
False, NoteDuration -> Time
Types.note_dur_to_time NoteDuration
allowed_dur)
    allowed_dur :: NoteDuration
allowed_dur = case Maybe Meter
maybe_meter of
        Maybe Meter
Nothing -> Time -> NoteDuration
Types.time_to_note_dur (Time
max_end Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
start)
        Just Meter
meter ->
            Bool -> Meter -> Time -> Time -> NoteDuration
Meter.allowed_duration Bool
use_dot Meter
meter Time
in_measure (Time
max_end Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
start)
            where
            -- Dots are always allowed for non-binary meters.
            use_dot :: Bool
use_dot = Bool -> Bool
not Bool
is_rest Bool -> Bool -> Bool
|| Config -> Bool
Types.config_dotted_rests Config
config
                Bool -> Bool -> Bool
|| Bool -> Bool
not (Meter -> Bool
Meter.is_binary Meter
meter)
            in_measure :: Time
in_measure = Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
measure_start
    -- Maximum end, the actual end may be shorter since it has to conform to
    -- a Duration.
    max_end :: Time
max_end = Maybe Time -> Time -> Time
forall a. Ord a => Maybe a -> a -> a
min_if Maybe Time
next (Time -> Time) -> Time -> Time
forall a b. (a -> b) -> a -> b
$ NonEmpty Time -> Time
forall a. Ord a => NonEmpty a -> a
Seq.ne_minimum ((Event -> Time) -> NonEmpty Event -> NonEmpty Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> Time
event_end NonEmpty Event
chord)
    is_rest :: Bool
is_rest = [NotePitch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NotePitch]
note_pitches

events_note_code :: Constants.Attach -> Bool -> Bool -> [Event]
    -> ([Text], [Text])
events_note_code :: Attach -> Bool -> Bool -> [Event] -> ([Text], [Text])
events_note_code Attach
attach Bool
is_first Bool
is_last =
    ([[Text]] -> [Text])
-> ([[Text]] -> [Text]) -> ([[Text]], [[Text]]) -> ([Text], [Text])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
Seq.unique ([Text] -> [Text]) -> ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
Seq.unique ([Text] -> [Text]) -> ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
    (([[Text]], [[Text]]) -> ([Text], [Text]))
-> ([Event] -> ([[Text]], [[Text]])) -> [Event] -> ([Text], [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Text], [Text])] -> ([[Text]], [[Text]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Text], [Text])] -> ([[Text]], [[Text]]))
-> ([Event] -> [([Text], [Text])])
-> [Event]
-> ([[Text]], [[Text]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> ([Text], [Text])) -> [Event] -> [([Text], [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (Attach -> Bool -> Bool -> Event -> ([Text], [Text])
event_note_code Attach
attach Bool
is_first Bool
is_last)

event_note_code :: Constants.Attach -> Bool -> Bool -> Event -> ([Text], [Text])
event_note_code :: Attach -> Bool -> Bool -> Event -> ([Text], [Text])
event_note_code Attach
attach Bool
is_first Bool
is_last =
    [(CodePosition, Text)] -> ([Text], [Text])
forall {a}. [(CodePosition, a)] -> ([a], [a])
extract ([(CodePosition, Text)] -> ([Text], [Text]))
-> (Event -> [(CodePosition, Text)]) -> Event -> ([Text], [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(CodePosition, Text)]
Constants.environ_code (Environ -> [(CodePosition, Text)])
-> (Event -> Environ) -> Event -> [(CodePosition, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ
    where
    extract :: [(CodePosition, a)] -> ([a], [a])
extract [(CodePosition, a)]
codes =
        (Position -> [(CodePosition, a)] -> [a]
forall {a}. Position -> [(CodePosition, a)] -> [a]
get Position
Constants.Prepend [(CodePosition, a)]
codes, Position -> [(CodePosition, a)] -> [a]
forall {a}. Position -> [(CodePosition, a)] -> [a]
get Position
Constants.Append [(CodePosition, a)]
codes)
    get :: Position -> [(CodePosition, a)] -> [a]
get Position
pos [(CodePosition, a)]
codes =
        [ a
code
        | (Constants.CodePosition Attach
a Position
p Distribution
d, a
code) <- [(CodePosition, a)]
codes
        , Attach
a Attach -> Attach -> Bool
forall a. Eq a => a -> a -> Bool
== Attach
attach, Position
p Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
pos, Distribution
d Distribution -> [Distribution] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Distribution]
dists
        ]
    dists :: [Distribution]
dists = Distribution
Constants.All Distribution -> [Distribution] -> [Distribution]
forall a. a -> [a] -> [a]
: [Distribution
Constants.First | Bool
is_first]
        [Distribution] -> [Distribution] -> [Distribution]
forall a. [a] -> [a] -> [a]
++ [Distribution
Constants.Last | Bool
is_last]

min_if :: Ord a => Maybe a -> a -> a
min_if :: forall a. Ord a => Maybe a -> a -> a
min_if Maybe a
ma a
b = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
b (a -> a -> a
forall a. Ord a => a -> a -> a
min a
b) Maybe a
ma

-- ** ly code env vars

t_unwords :: [Text] -> Text
t_unwords :: [Text] -> Text
t_unwords = [Text] -> Text
Text.unwords ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.strip

pitch_code :: Bool -> Event -> Code
pitch_code :: Bool -> Event -> Text
pitch_code Bool
is_first Event
event =
    Text -> (Pitch -> Text) -> Maybe Pitch -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Pitch -> Text
forall a. ToLily a => a -> Text
to_lily (Event -> Maybe Pitch
event_pitch Event
event)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool
is_first then Text -> Event -> Text
get_code Text
Constants.v_append_pitch Event
event else Text
""

attrs_to_code :: Attrs.Attributes -> Attrs.Attributes
    -> ([Code], Attrs.Attributes)
    -- ^ (code to append, prev attrs for the next note)
attrs_to_code :: Attributes -> Attributes -> ([Text], Attributes)
attrs_to_code Attributes
prev Attributes
current =
    ([Text]
simple [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
starts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe Text]
ends, [Attributes] -> Attributes
forall a. Monoid a => [a] -> a
mconcat (Attributes
current Attributes -> [Attributes] -> [Attributes]
forall a. a -> [a] -> [a]
: [Attributes]
extras))
    where
    starts :: [Text]
starts =
        [ Text
start
        | (Attributes
attr, Text
start, Text
_) <- [(Attributes, Text, Text)]
modal_articulations
        , Attributes
current Attributes -> Attributes -> Bool
`has` Attributes
attr, Bool -> Bool
not (Attributes
prev Attributes -> Attributes -> Bool
`has` Attributes
attr)
        ]
    ([Maybe Text]
ends, [Attributes]
extras) = [(Maybe Text, Attributes)] -> ([Maybe Text], [Attributes])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Text, Attributes)] -> ([Maybe Text], [Attributes]))
-> [(Maybe Text, Attributes)] -> ([Maybe Text], [Attributes])
forall a b. (a -> b) -> a -> b
$ ((Attributes, Text, Text) -> (Maybe Text, Attributes))
-> [(Attributes, Text, Text)] -> [(Maybe Text, Attributes)]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> (Attributes, Text, Text) -> (Maybe Text, Attributes)
forall {b} {a}.
Attributes -> (Attributes, b, a) -> (Maybe a, Attributes)
cancel Attributes
prev) [(Attributes, Text, Text)]
modal_articulations
    simple :: [Text]
simple = [Text
code | (Attributes
attr, Text
code) <- [(Attributes, Text)]
simple_articulations, Attributes
current Attributes -> Attributes -> Bool
`has` Attributes
attr]
    cancel :: Attributes -> (Attributes, b, a) -> (Maybe a, Attributes)
cancel Attributes
prev (Attributes
attr, b
_, a
end)
        -- If prev doesn't have +nv, but this one is +staccato, then consider
        -- that this one also has +nv.  This avoids spurious vib marks on
        -- every staccato note.
        | Attributes
prev Attributes -> Attributes -> Bool
`has` Attributes
attr Bool -> Bool -> Bool
&& Bool -> Bool
not (Attributes
current Attributes -> Attributes -> Bool
`has` Attributes
attr) =
            if Attributes
attr Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
== Attributes
Attrs.nv Bool -> Bool -> Bool
&& (Attributes -> Bool) -> [Attributes] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes
current `has`) [Attributes]
inherently_nv
                then (Maybe a
forall a. Maybe a
Nothing, Attributes
Attrs.nv)
                else (a -> Maybe a
forall a. a -> Maybe a
Just a
end, Attributes
forall a. Monoid a => a
mempty)
        | Bool
otherwise = (Maybe a
forall a. Maybe a
Nothing, Attributes
forall a. Monoid a => a
mempty)
    inherently_nv :: [Attributes]
inherently_nv = [Attributes
Attrs.staccato, Attributes
Attrs.harm, Attributes
Attrs.pizz]
    has :: Attributes -> Attributes -> Bool
has = Attributes -> Attributes -> Bool
Attrs.contain

-- ** voices_to_ly

-- | Like 'convert_chunk', but converts within a voice, which means no nested
-- voices are expected.
voices_to_ly :: VoiceMap Event -> ConvertM (VoiceMap Ly)
voices_to_ly :: VoiceMap Event
-> StateT State (ExceptT ConvertError Identity) (VoiceMap Ly)
voices_to_ly [] = VoiceMap Ly
-> StateT State (ExceptT ConvertError Identity) (VoiceMap Ly)
forall (m :: * -> *) a. Monad m => a -> m a
return []
voices_to_ly VoiceMap Event
voices = do
    State
state <- StateT State (ExceptT ConvertError Identity) State
forall s (m :: * -> *). MonadState s m => m s
State.get
    ([State]
states, VoiceMap Ly
voice_lys) <- [(State, (Voice, [Ly]))] -> ([State], VoiceMap Ly)
forall a b. [(a, b)] -> ([a], [b])
unzip ([(State, (Voice, [Ly]))] -> ([State], VoiceMap Ly))
-> StateT
     State (ExceptT ConvertError Identity) [(State, (Voice, [Ly]))]
-> StateT
     State (ExceptT ConvertError Identity) ([State], VoiceMap Ly)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Voice, [Event])
 -> StateT
      State (ExceptT ConvertError Identity) (State, (Voice, [Ly])))
-> VoiceMap Event
-> StateT
     State (ExceptT ConvertError Identity) [(State, (Voice, [Ly]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (State
-> (Voice, [Event])
-> StateT
     State (ExceptT ConvertError Identity) (State, (Voice, [Ly]))
forall {m :: * -> *} {a}.
MonadError ConvertError m =>
State -> (a, [Event]) -> m (State, (a, [Ly]))
convert State
state) VoiceMap Event
voices
    case [State]
states of
        State
st : [State]
sts -> do
            Bool
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((State -> Bool) -> [State] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== State -> Time
state_time State
st) (Time -> Bool) -> (State -> Time) -> State -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Time
state_time) [State]
sts) (StateT State (ExceptT ConvertError Identity) ()
 -> StateT State (ExceptT ConvertError Identity) ())
-> StateT State (ExceptT ConvertError Identity) ()
-> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$
                Text -> StateT State (ExceptT ConvertError Identity) ()
forall a. Text -> ConvertM a
throw (Text -> StateT State (ExceptT ConvertError Identity) ())
-> Text -> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ Text
"inconsistent states after voices: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [State] -> Text
forall a. Pretty a => a -> Text
pretty (State
stState -> [State] -> [State]
forall a. a -> [a] -> [a]
:[State]
sts)
            State -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put State
st
        [] -> () -> StateT State (ExceptT ConvertError Identity) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    VoiceMap Ly
-> StateT State (ExceptT ConvertError Identity) (VoiceMap Ly)
forall (m :: * -> *) a. Monad m => a -> m a
return VoiceMap Ly
voice_lys
    where
    convert :: State -> (a, [Event]) -> m (State, (a, [Ly]))
convert State
state (a
v, [Event]
events) = do
        ([Ly]
measures, State
final_state) <- Either ConvertError ([Ly], State) -> m ([Ly], State)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight (Either ConvertError ([Ly], State) -> m ([Ly], State))
-> Either ConvertError ([Ly], State) -> m ([Ly], State)
forall a b. (a -> b) -> a -> b
$ State
-> StateT State (ExceptT ConvertError Identity) [Ly]
-> Either ConvertError ([Ly], State)
forall a. State -> ConvertM a -> Either ConvertError (a, State)
run_convert State
state (StateT State (ExceptT ConvertError Identity) [Ly]
 -> Either ConvertError ([Ly], State))
-> StateT State (ExceptT ConvertError Identity) [Ly]
-> Either ConvertError ([Ly], State)
forall a b. (a -> b) -> a -> b
$
            ([Event]
 -> StateT State (ExceptT ConvertError Identity) ([Ly], [Event]))
-> [Event] -> StateT State (ExceptT ConvertError Identity) [Ly]
forall (m :: * -> *) a b.
Monad m =>
([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete (Bool
-> [Event]
-> StateT State (ExceptT ConvertError Identity) ([Ly], [Event])
convert_chunk Bool
True) [Event]
events
        (State, (a, [Ly])) -> m (State, (a, [Ly]))
forall (m :: * -> *) a. Monad m => a -> m a
return (State
final_state, (a
v, [Ly]
measures))

-- | If a whole measure of a voice is empty, omit the voice for that measure.
--
-- Previously, I tried a more fine-grained approach, documented in
-- 'span_voices'.  This way is more complicated because it has to operate on
-- Lys since it needs to know where the measure boundaries are, but gives much
-- better results.
simplify_voices :: VoiceMap Ly -> [Either Voices Ly]
simplify_voices :: VoiceMap Ly -> [Either Voices Ly]
simplify_voices VoiceMap Ly
voices =
    (VoiceMap Ly -> [Either Voices Ly])
-> [VoiceMap Ly] -> [Either Voices Ly]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (VoiceMap Ly -> [Either Voices Ly]
flatten (VoiceMap Ly -> [Either Voices Ly])
-> (VoiceMap Ly -> VoiceMap Ly)
-> VoiceMap Ly
-> [Either Voices Ly]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VoiceMap Ly -> VoiceMap Ly
forall {t :: * -> *} {a}. Foldable t => [(a, t Ly)] -> [(a, t Ly)]
strip) ([VoiceMap Ly] -> [Either Voices Ly])
-> [VoiceMap Ly] -> [Either Voices Ly]
forall a b. (a -> b) -> a -> b
$ [Time] -> VoiceMap Ly -> [VoiceMap Ly]
split_voices_at [Time]
rest_starts VoiceMap Ly
voices
    where
    rest_starts :: [Time]
rest_starts = (Time -> Time) -> [Time] -> [Time]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_dups Time -> Time
forall a. a -> a
id ([Time] -> [Time]) -> [Time] -> [Time]
forall a b. (a -> b) -> a -> b
$ (Time -> Time) -> [[Time]] -> [Time]
forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Seq.merge_lists Time -> Time
forall a. a -> a
id ([[Time]] -> [Time]) -> [[Time]] -> [Time]
forall a b. (a -> b) -> a -> b
$
        ((Voice, [Ly]) -> [[Time]]) -> VoiceMap Ly -> [[Time]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Ly] -> [[Time]]
rests_at ([Ly] -> [[Time]])
-> ((Voice, [Ly]) -> [Ly]) -> (Voice, [Ly]) -> [[Time]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Voice, [Ly]) -> [Ly]
forall a b. (a, b) -> b
snd) VoiceMap Ly
voices
    rests_at :: [Ly] -> [[Time]]
rests_at [Ly]
lys =
        [ [Time
start, Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Ly -> Time
ly_duration Ly
ly]
        | (Time
start, Ly
ly) <- Time -> [Ly] -> [(Time, Ly)]
with_starts Time
0 [Ly]
lys, Ly -> Bool
is_full_measure_rest Ly
ly
        ]
    is_full_measure_rest :: Ly -> Bool
is_full_measure_rest (LyRest (Rest { rest_type :: Rest -> RestType
rest_type = FullMeasure {} })) = Bool
True
    is_full_measure_rest Ly
_ = Bool
False

    -- Strip out voices that consist entirely of rests, keeping at least one.
    strip :: [(a, t Ly)] -> [(a, t Ly)]
strip [(a, t Ly)]
voices = case ((a, t Ly) -> Bool) -> [(a, t Ly)] -> [(a, t Ly)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((a, t Ly) -> Bool) -> (a, t Ly) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Ly -> Bool
rest_measure (t Ly -> Bool) -> ((a, t Ly) -> t Ly) -> (a, t Ly) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, t Ly) -> t Ly
forall a b. (a, b) -> b
snd) [(a, t Ly)]
voices of
            [] -> Int -> [(a, t Ly)] -> [(a, t Ly)]
forall a. Int -> [a] -> [a]
take Int
1 [(a, t Ly)]
voices
            [(a, t Ly)]
voices -> [(a, t Ly)]
voices
        where
        rest_measure :: t Ly -> Bool
rest_measure = (Ly -> Bool) -> t Ly -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Ly -> Bool) -> t Ly -> Bool) -> (Ly -> Bool) -> t Ly -> Bool
forall a b. (a -> b) -> a -> b
$
            \Ly
ly -> Ly -> Bool
is_full_measure_rest Ly
ly Bool -> Bool -> Bool
|| Ly -> Time
ly_duration Ly
ly Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
0
    flatten :: VoiceMap Ly -> [Either Voices Ly]
    flatten :: VoiceMap Ly -> [Either Voices Ly]
flatten [] = []
    flatten [(Voice
_, [Ly]
lys)] = (Ly -> Either Voices Ly) -> [Ly] -> [Either Voices Ly]
forall a b. (a -> b) -> [a] -> [b]
map Ly -> Either Voices Ly
forall a b. b -> Either a b
Right [Ly]
lys
    flatten VoiceMap Ly
voices = [Voices -> Either Voices Ly
forall a b. a -> Either a b
Left (VoiceMap Ly -> Voices
Voices VoiceMap Ly
voices)]

-- | Split voices every place any of them has a full measure rest.
--
-- > [(1, xs), (2, ys)] -> [(1, x), (2, y)], [(1, x), (2, y)]
-- > [(1, xs), (2, ys)] -> [(1, [xs]), (2, [ys])]
split_voices_at :: [Time] -> VoiceMap Ly -> [VoiceMap Ly]
split_voices_at :: [Time] -> VoiceMap Ly -> [VoiceMap Ly]
split_voices_at [Time]
ts = VoiceMap [Ly] -> [VoiceMap Ly]
rotate (VoiceMap [Ly] -> [VoiceMap Ly])
-> (VoiceMap Ly -> VoiceMap [Ly]) -> VoiceMap Ly -> [VoiceMap Ly]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Voice, [Ly]) -> (Voice, [[Ly]])) -> VoiceMap Ly -> VoiceMap [Ly]
forall a b. (a -> b) -> [a] -> [b]
map (([Ly] -> [[Ly]]) -> (Voice, [Ly]) -> (Voice, [[Ly]])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Time] -> [Ly] -> [[Ly]]
split_at [Time]
ts))
    where
    -- This is really hard for me to understand, but I don't need to because
    -- the types work out :)
    -- [(1, [x, y]), (2, [a, b])] -> [[(1, x), (2, a)], [(1, y), (2, b)]]
    -- split_at should produce a [Ly] group for every split Time, but if it
    -- doesn't the rotate will drop all the other voices.
    rotate :: VoiceMap [Ly] -> [VoiceMap Ly]
    rotate :: VoiceMap [Ly] -> [VoiceMap Ly]
rotate VoiceMap [Ly]
voice_groups = ([[Ly]] -> VoiceMap Ly) -> [[[Ly]]] -> [VoiceMap Ly]
forall a b. (a -> b) -> [a] -> [b]
map ([Voice] -> [[Ly]] -> VoiceMap Ly
forall a b. [a] -> [b] -> [(a, b)]
zip [Voice]
voices) ([[[Ly]]] -> [[[Ly]]]
forall a. [[a]] -> [[a]]
Seq.rotate [[[Ly]]]
lys)
        where ([Voice]
voices, [[[Ly]]]
lys) = VoiceMap [Ly] -> ([Voice], [[[Ly]]])
forall a b. [(a, b)] -> ([a], [b])
unzip VoiceMap [Ly]
voice_groups
    -- Ly times should always line up at measure boundaries, and the split
    -- times should all be at measure boundaries.  So this should return one
    -- [Ly] for each Time.
    split_at :: [Time] -> [Ly] -> [[Ly]]
    split_at :: [Time] -> [Ly] -> [[Ly]]
split_at [Time]
times [Ly]
lys = [Time] -> [(Time, Ly)] -> [[Ly]]
forall {a} {b}. Ord a => [a] -> [(a, b)] -> [[b]]
go [Time]
times ([(Time, Ly)] -> [[Ly]]) -> [(Time, Ly)] -> [[Ly]]
forall a b. (a -> b) -> a -> b
$ [Time] -> [Ly] -> [(Time, Ly)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Time] -> [Time]
forall a. Int -> [a] -> [a]
drop Int
1 ([Time] -> [Time]) -> [Time] -> [Time]
forall a b. (a -> b) -> a -> b
$ Time -> [Ly] -> [Time]
ly_start_times Time
0 [Ly]
lys) [Ly]
lys
        where
        go :: [a] -> [(a, b)] -> [[b]]
go [a]
_ [] = []
        go [] [(a, b)]
rest = [((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
rest]
        go (a
t:[a]
ts) [(a, b)]
lys = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd [(a, b)]
pre [b] -> [[b]] -> [[b]]
forall a. a -> [a] -> [a]
: [a] -> [(a, b)] -> [[b]]
go [a]
ts [(a, b)]
post
            where ([(a, b)]
pre, [(a, b)]
post) = ((a, b) -> Bool) -> [(a, b)] -> ([(a, b)], [(a, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
t) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
lys

with_starts :: Time -> [Ly] -> [(Time, Ly)]
with_starts :: Time -> [Ly] -> [(Time, Ly)]
with_starts Time
start [Ly]
lys = [Time] -> [Ly] -> [(Time, Ly)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Time -> [Ly] -> [Time]
ly_start_times Time
start [Ly]
lys) [Ly]
lys

-- | drop 1 for end times.
ly_start_times :: Time -> [Ly] -> [Time]
ly_start_times :: Time -> [Ly] -> [Time]
ly_start_times Time
start = (Time -> Time -> Time) -> Time -> [Time] -> [Time]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Time -> Time -> Time
forall a. Num a => a -> a -> a
(+) Time
start ([Time] -> [Time]) -> ([Ly] -> [Time]) -> [Ly] -> [Time]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ly -> Time) -> [Ly] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Ly -> Time
ly_duration

-- * misc

-- | Advance now to the given time, up to and including the end of the measure,
-- but it's an error to try to go past.  Return Ly with a LyBarline if this is
-- a new measure.
--
-- If I wanted to emit Barlines automatically I'd have to collect the output
-- [Ly] in the State, which I'd then need to parameterize since it can be
-- [Either Voices Ly] too.
advance_measure :: Time -> ConvertM (Maybe Ly)
advance_measure :: Time -> ConvertM (Maybe Ly)
advance_measure Time
time = State -> ConvertM (Maybe Ly)
advance (State -> ConvertM (Maybe Ly))
-> StateT State (ExceptT ConvertError Identity) State
-> ConvertM (Maybe Ly)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT State (ExceptT ConvertError Identity) State
forall s (m :: * -> *). MonadState s m => m s
State.get
    where
    advance :: State -> ConvertM (Maybe Ly)
advance State
state
        | Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< State -> Time
state_time State
state =
            Text -> ConvertM (Maybe Ly)
forall a. Text -> ConvertM a
throw (Text -> ConvertM (Maybe Ly)) -> Text -> ConvertM (Maybe Ly)
forall a b. (a -> b) -> a -> b
$ Text
"can't advance time backward: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty Time
time
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" < " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty (State -> Time
state_time State
state)
        | Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< State -> Time
state_measure_end State
state = do
            State -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> StateT State (ExceptT ConvertError Identity) ())
-> State -> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ State
state { state_time :: Time
state_time = Time
time }
            Maybe Ly -> ConvertM (Maybe Ly)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Ly
forall a. Maybe a
Nothing
        | Time
time Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== State -> Time
state_measure_end State
state =
            case State -> [Meter]
state_meters State
state of
                Meter
prev_meter : [Meter]
meters -> Meter -> [Meter] -> ConvertM (Maybe Ly)
forall {m :: * -> *}.
MonadState State m =>
Meter -> [Meter] -> m (Maybe Ly)
advance1 Meter
prev_meter [Meter]
meters
                [Meter]
_ -> Text -> ConvertM (Maybe Ly)
forall a. Text -> ConvertM a
throw (Text -> ConvertM (Maybe Ly)) -> Text -> ConvertM (Maybe Ly)
forall a b. (a -> b) -> a -> b
$ Text
"out of meters, can't advance time to "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty Time
time
        | Bool
otherwise =
            Text -> ConvertM (Maybe Ly)
forall a. Text -> ConvertM a
throw (Text -> ConvertM (Maybe Ly)) -> Text -> ConvertM (Maybe Ly)
forall a b. (a -> b) -> a -> b
$ Text
"can't advance time past barline: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty Time
time
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" > " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty (State -> Time
state_measure_end State
state)
    advance1 :: Meter -> [Meter] -> m (Maybe Ly)
advance1 Meter
prev_meter [Meter]
meters = do
        (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
            { state_meters :: [Meter]
state_meters = [Meter]
meters
            , state_measure_start :: Time
state_measure_start = State -> Time
state_measure_end State
state
            , state_measure_end :: Time
state_measure_end = State -> Time
state_measure_end State
state
                Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Meter -> Time
Meter.measure_time (Meter -> Maybe Meter -> Meter
forall a. a -> Maybe a -> a
fromMaybe Meter
prev_meter ([Meter] -> Maybe Meter
forall a. [a] -> Maybe a
Seq.head [Meter]
meters))
            , state_time :: Time
state_time = Time
time
            }
        Maybe Ly -> m (Maybe Ly)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Ly -> m (Maybe Ly)) -> Maybe Ly -> m (Maybe Ly)
forall a b. (a -> b) -> a -> b
$ case [Meter] -> Maybe Meter
forall a. [a] -> Maybe a
Seq.head [Meter]
meters of
            Just Meter
meter -> Ly -> Maybe Ly
forall a. a -> Maybe a
Just (Ly -> Maybe Ly) -> Ly -> Maybe Ly
forall a b. (a -> b) -> a -> b
$ Maybe Meter -> Ly
LyBarline (Maybe Meter -> Ly) -> Maybe Meter -> Ly
forall a b. (a -> b) -> a -> b
$
                if Meter -> Text
forall a. ToLily a => a -> Text
to_lily Meter
prev_meter Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Meter -> Text
forall a. ToLily a => a -> Text
to_lily Meter
meter
                    then Maybe Meter
forall a. Maybe a
Nothing else Meter -> Maybe Meter
forall a. a -> Maybe a
Just Meter
meter
            Maybe Meter
_ -> Maybe Ly
forall a. Maybe a
Nothing

-- | Advance time without regard to meter or barlines.
advance_unmetered :: Time -> ConvertM ()
advance_unmetered :: Time -> StateT State (ExceptT ConvertError Identity) ()
advance_unmetered Time
time = State -> StateT State (ExceptT ConvertError Identity) ()
advance (State -> StateT State (ExceptT ConvertError Identity) ())
-> StateT State (ExceptT ConvertError Identity) State
-> StateT State (ExceptT ConvertError Identity) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT State (ExceptT ConvertError Identity) State
forall s (m :: * -> *). MonadState s m => m s
State.get
    where
    advance :: State -> StateT State (ExceptT ConvertError Identity) ()
advance State
state
        | Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< State -> Time
state_time State
state =
            Text -> StateT State (ExceptT ConvertError Identity) ()
forall a. Text -> ConvertM a
throw (Text -> StateT State (ExceptT ConvertError Identity) ())
-> Text -> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ Text
"can't advance unmetered time backward: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty Time
time
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" < " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty (State -> Time
state_time State
state)
        | Bool
otherwise = State -> StateT State (ExceptT ConvertError Identity) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put (State -> StateT State (ExceptT ConvertError Identity) ())
-> State -> StateT State (ExceptT ConvertError Identity) ()
forall a b. (a -> b) -> a -> b
$ State
state { state_time :: Time
state_time = Time
time }

-- | Get the current subdivision and check it against the meter.  This is a way
-- to override the meter for the purposes of how durations are spelled.
get_subdivision :: ConvertM Meter.Meter
get_subdivision :: ConvertM Meter
get_subdivision = do
    [Meter]
meters <- (State -> [Meter])
-> StateT State (ExceptT ConvertError Identity) [Meter]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> [Meter]
state_meters
    Meter
meter <- ConvertM Meter
-> (Meter -> ConvertM Meter) -> Maybe Meter -> ConvertM Meter
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> ConvertM Meter
forall a. Text -> ConvertM a
throw Text
"out of meters") Meter -> ConvertM Meter
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Meter -> ConvertM Meter) -> Maybe Meter -> ConvertM Meter
forall a b. (a -> b) -> a -> b
$ [Meter] -> Maybe Meter
forall a. [a] -> Maybe a
Seq.head [Meter]
meters
    Maybe Meter
subdivision <- (State -> Maybe Meter)
-> StateT State (ExceptT ConvertError Identity) (Maybe Meter)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Maybe Meter
state_subdivision
    case Maybe Meter
subdivision of
        Just Meter
sub
            | Meter -> Time
Meter.measure_time Meter
meter Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Meter -> Time
Meter.measure_time Meter
sub -> Meter -> ConvertM Meter
forall (m :: * -> *) a. Monad m => a -> m a
return Meter
sub
            | Bool
otherwise -> Text -> ConvertM Meter
forall a. Text -> ConvertM a
throw (Text -> ConvertM Meter) -> Text -> ConvertM Meter
forall a b. (a -> b) -> a -> b
$ Text
"subdivision " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Meter -> Text
forall a. ToLily a => a -> Text
to_lily Meter
sub
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" incompatible with meter " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Meter -> Text
forall a. ToLily a => a -> Text
to_lily Meter
meter
        Maybe Meter
Nothing -> Meter -> ConvertM Meter
forall (m :: * -> *) a. Monad m => a -> m a
return Meter
meter

-- * ConvertM

type ConvertM =
    State.StateT State (Except.ExceptT ConvertError Identity.Identity)

data ConvertError = ConvertError !(Maybe Stack.Stack) !Error
    deriving (ConvertError -> ConvertError -> Bool
(ConvertError -> ConvertError -> Bool)
-> (ConvertError -> ConvertError -> Bool) -> Eq ConvertError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConvertError -> ConvertError -> Bool
$c/= :: ConvertError -> ConvertError -> Bool
== :: ConvertError -> ConvertError -> Bool
$c== :: ConvertError -> ConvertError -> Bool
Eq, Int -> ConvertError -> ShowS
[ConvertError] -> ShowS
ConvertError -> String
(Int -> ConvertError -> ShowS)
-> (ConvertError -> String)
-> ([ConvertError] -> ShowS)
-> Show ConvertError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConvertError] -> ShowS
$cshowList :: [ConvertError] -> ShowS
show :: ConvertError -> String
$cshow :: ConvertError -> String
showsPrec :: Int -> ConvertError -> ShowS
$cshowsPrec :: Int -> ConvertError -> ShowS
Show)

to_log :: ConvertError -> Log.Msg
to_log :: ConvertError -> Msg
to_log (ConvertError Maybe Stack
stack Text
msg) = Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn Maybe Stack
stack Text
msg

type Error = Text

run_convert :: State -> ConvertM a -> Either ConvertError (a, State)
run_convert :: forall a. State -> ConvertM a -> Either ConvertError (a, State)
run_convert State
state = Identity (Either ConvertError (a, State))
-> Either ConvertError (a, State)
forall a. Identity a -> a
Identity.runIdentity (Identity (Either ConvertError (a, State))
 -> Either ConvertError (a, State))
-> (ConvertM a -> Identity (Either ConvertError (a, State)))
-> ConvertM a
-> Either ConvertError (a, State)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT ConvertError Identity (a, State)
-> Identity (Either ConvertError (a, State))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT
    (ExceptT ConvertError Identity (a, State)
 -> Identity (Either ConvertError (a, State)))
-> (ConvertM a -> ExceptT ConvertError Identity (a, State))
-> ConvertM a
-> Identity (Either ConvertError (a, State))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConvertM a -> State -> ExceptT ConvertError Identity (a, State))
-> State -> ConvertM a -> ExceptT ConvertError Identity (a, State)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvertM a -> State -> ExceptT ConvertError Identity (a, State)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.runStateT State
state

with_event :: Event -> ConvertM a -> ConvertM a
with_event :: forall a. Event -> ConvertM a -> ConvertM a
with_event Event
event = (ConvertM a -> (ConvertError -> ConvertM a) -> ConvertM a)
-> (ConvertError -> ConvertM a) -> ConvertM a -> ConvertM a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvertM a -> (ConvertError -> ConvertM a) -> ConvertM a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
Except.catchError ((ConvertError -> ConvertM a) -> ConvertM a -> ConvertM a)
-> (ConvertError -> ConvertM a) -> ConvertM a -> ConvertM a
forall a b. (a -> b) -> a -> b
$ \(ConvertError Maybe Stack
_ Text
msg) ->
    ConvertError -> ConvertM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError (ConvertError -> ConvertM a) -> ConvertError -> ConvertM a
forall a b. (a -> b) -> a -> b
$ Maybe Stack -> Text -> ConvertError
ConvertError (Stack -> Maybe Stack
forall a. a -> Maybe a
Just (Event -> Stack
event_stack Event
event)) Text
msg

with_context :: Text -> ConvertM a -> ConvertM a
with_context :: forall a. Text -> ConvertM a -> ConvertM a
with_context Text
prefix = (ConvertM a -> (ConvertError -> ConvertM a) -> ConvertM a)
-> (ConvertError -> ConvertM a) -> ConvertM a -> ConvertM a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvertM a -> (ConvertError -> ConvertM a) -> ConvertM a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
Except.catchError ((ConvertError -> ConvertM a) -> ConvertM a -> ConvertM a)
-> (ConvertError -> ConvertM a) -> ConvertM a -> ConvertM a
forall a b. (a -> b) -> a -> b
$ \(ConvertError Maybe Stack
stack Text
msg) ->
    ConvertError -> ConvertM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError (ConvertError -> ConvertM a) -> ConvertError -> ConvertM a
forall a b. (a -> b) -> a -> b
$ Maybe Stack -> Text -> ConvertError
ConvertError Maybe Stack
stack (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg)

data State = State {
    -- Constant:
    State -> Config
state_config :: !Types.Config

    -- Changes on each measure:
    -- | One Meter for each expected measure in the output.
    -- The head of the list is the current meter.  It's valid for the meters to
    -- be [] as long as you don't have any more notes or rests to generate.
    , State -> [Meter]
state_meters :: ![Meter.Meter]
    , State -> Time
state_measure_start :: !Time
    , State -> Time
state_measure_end :: !Time

    -- Changes on each note:
    -- | Current position in time, aka the end of the previous note.
    , State -> Time
state_time :: !Time
        -- | Used in conjunction with 'modal_articulations'.
    , State -> Attributes
state_prev_attrs :: Attrs.Attributes
    , State -> Key
state_key :: !Key

    -- Changes on a directive.
    , State -> Maybe Meter
state_subdivision :: !(Maybe Meter.Meter)
    } deriving (Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show)

instance Pretty State where
    format :: State -> Doc
format (State Config
config [Meter]
meters Time
mstart Time
mend Time
time Attributes
prev_attrs Key
key Maybe Meter
subdiv) =
        Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"State"
            [ (Text
"config", Config -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Config
config)
            , (Text
"meters", [Meter] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Meter]
meters)
            , (Text
"measure_start", Time -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Time
mstart)
            , (Text
"measure_end", Time -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Time
mend)
            , (Text
"time", Time -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Time
time)
            , (Text
"prev_attrs", Attributes -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Attributes
prev_attrs)
            , (Text
"key", Key -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Key
key)
            , (Text
"subdivision", Maybe Meter -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Maybe Meter
subdiv)
            ]

make_state :: Types.Config -> Time -> [Meter.Meter] -> Key -> State
make_state :: Config -> Time -> [Meter] -> Key -> State
make_state Config
config Time
start [Meter]
meters Key
key = State
    { state_config :: Config
state_config = Config
config
    , state_meters :: [Meter]
state_meters = [Meter]
meters
    , state_measure_start :: Time
state_measure_start = Time
start
    , state_measure_end :: Time
state_measure_end = Time
start Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> (Meter -> Time) -> Maybe Meter -> Time
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Time
0 Meter -> Time
Meter.measure_time ([Meter] -> Maybe Meter
forall a. [a] -> Maybe a
Seq.head [Meter]
meters)
    , state_time :: Time
state_time = Time
start
    , state_prev_attrs :: Attributes
state_prev_attrs = Attributes
forall a. Monoid a => a
mempty
    , state_key :: Key
state_key = Key
key
    , state_subdivision :: Maybe Meter
state_subdivision = Maybe Meter
forall a. Maybe a
Nothing
    }

-- ** util

throw :: Error -> ConvertM a
throw :: forall a. Text -> ConvertM a
throw Text
msg = do
    Time
now <- (State -> Time) -> ConvertM Time
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Time
state_time
    ConvertError -> ConvertM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError (ConvertError -> ConvertM a) -> ConvertError -> ConvertM a
forall a b. (a -> b) -> a -> b
$ Maybe Stack -> Text -> ConvertError
ConvertError Maybe Stack
forall a. Maybe a
Nothing (Time -> Text
forall a. Pretty a => a -> Text
pretty Time
now Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg)

lookup_val :: Env.Key -> (Error -> Either Error a) -> a -> Event -> ConvertM a
lookup_val :: forall a.
Text -> (Text -> Either Text a) -> a -> Event -> ConvertM a
lookup_val Text
key Text -> Either Text a
parse a
deflt Event
event = Either Text a -> ConvertM a
forall {a}. Either Text a -> ConvertM a
prefix (Either Text a -> ConvertM a) -> Either Text a -> ConvertM a
forall a b. (a -> b) -> a -> b
$ do
    Maybe Text
maybe_val <- Text -> Environ -> Either Text (Maybe Text)
forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
key (Event -> Environ
event_environ Event
event)
    Either Text a
-> (Text -> Either Text a) -> Maybe Text -> Either Text a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either Text a
forall a b. b -> Either a b
Right a
deflt) Text -> Either Text a
parse Maybe Text
maybe_val
    where
    prefix :: Either Text a -> ConvertM a
prefix = (Text -> ConvertM a)
-> (a -> ConvertM a) -> Either Text a -> ConvertM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> ConvertM a
forall a. Text -> ConvertM a
throw (Text -> ConvertM a) -> (Text -> Text) -> Text -> ConvertM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text -> Text
forall a. Pretty a => a -> Text
pretty Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)) a -> ConvertM a
forall (m :: * -> *) a. Monad m => a -> m a
return


-- * types

-- | Ultimately, the contants of Ly is just a bit of lilypond code.  They are
-- all converted to text via 'to_lily' and concatenated to form the full score.
-- But I encode a fair amount of structure into the data type, which is
-- convenient for debugging.  It could also could theoretically be further
-- modified, though I don't think I ever do that.  However, 'ly_duration' at
-- least is used to merge 'FreeCode' into a Ly stream.
data Ly =
    LyNote !Note
    | LyRest !Rest
    | LyNested Nested
    | LyBarline !(Maybe Meter.Meter)
    | LyCode !Code
    deriving (Int -> Ly -> ShowS
[Ly] -> ShowS
Ly -> String
(Int -> Ly -> ShowS)
-> (Ly -> String) -> ([Ly] -> ShowS) -> Show Ly
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ly] -> ShowS
$cshowList :: [Ly] -> ShowS
show :: Ly -> String
$cshow :: Ly -> String
showsPrec :: Int -> Ly -> ShowS
$cshowsPrec :: Int -> Ly -> ShowS
Show)

ly_duration :: Ly -> Time
ly_duration :: Ly -> Time
ly_duration Ly
ly = case Ly
ly of
    LyNote Note
note -> NoteDuration -> Time
Types.note_dur_to_time (Note -> NoteDuration
note_duration Note
note)
    LyRest Rest
rest -> Rest -> Time
rest_time Rest
rest
    LyNested Nested
n -> Nested -> Time
nested_duration Nested
n
    Ly
_ -> Time
0

instance Pretty Ly where pretty :: Ly -> Text
pretty = Ly -> Text
forall a. ToLily a => a -> Text
to_lily

instance ToLily Ly where
    to_lily :: Ly -> Text
to_lily Ly
ly = case Ly
ly of
        LyBarline Maybe Meter
Nothing -> Text
"|"
        LyBarline (Just Meter
meter) -> Text
"| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\\time " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Meter -> Text
forall a. ToLily a => a -> Text
to_lily Meter
meter
        LyNote Note
note -> Note -> Text
forall a. ToLily a => a -> Text
to_lily Note
note
        LyRest Rest
rest -> Rest -> Text
forall a. ToLily a => a -> Text
to_lily Rest
rest
        LyNested Nested
nested -> Nested -> Text
forall a. ToLily a => a -> Text
to_lily Nested
nested
        LyCode Text
code -> Text
code

count_notes_rests :: [Ly] -> Int
count_notes_rests :: [Ly] -> Int
count_notes_rests = (Ly -> Bool) -> [Ly] -> Int
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Seq.count ((Ly -> Bool) -> [Ly] -> Int) -> (Ly -> Bool) -> [Ly] -> Int
forall a b. (a -> b) -> a -> b
$ \Ly
ly -> case Ly
ly of
    LyNote {} -> Bool
True
    LyRest {} -> Bool
True
    Ly
_ -> Bool
False

-- | This represents a bit of nested lilypond code, e.g.
-- \something { contents }.
data Nested = Nested {
    Nested -> Text
nested_prefix :: !Code
    , Nested -> NonEmpty Ly
nested_contents :: !(NonEmpty Ly)
    , Nested -> Text
nested_suffix :: !Code
    , Nested -> Time
nested_duration :: !Time
    } deriving (Int -> Nested -> ShowS
[Nested] -> ShowS
Nested -> String
(Int -> Nested -> ShowS)
-> (Nested -> String) -> ([Nested] -> ShowS) -> Show Nested
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Nested] -> ShowS
$cshowList :: [Nested] -> ShowS
show :: Nested -> String
$cshow :: Nested -> String
showsPrec :: Int -> Nested -> ShowS
$cshowsPrec :: Int -> Nested -> ShowS
Show)

instance ToLily Nested where
    to_lily :: Nested -> Text
to_lily (Nested Text
prefix NonEmpty Ly
contents Text
suffix Time
_) =
        [Text] -> Text
t_unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
prefix Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Ly -> Text) -> [Ly] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Ly -> Text
forall a. ToLily a => a -> Text
to_lily (NonEmpty Ly -> [Ly]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Ly
contents) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
suffix]

-- ** Note

data Note = Note {
    -- | Greater than one pitch indicates a chord.
    Note -> NonEmpty NotePitch
note_pitches :: !(NonEmpty NotePitch)
    , Note -> NoteDuration
note_duration :: !Types.NoteDuration
    -- | Additional code to prepend to the note.
    , Note -> [Text]
note_prepend :: ![Code]
    -- | Additional code to append to the note.
    , Note -> [Text]
note_append :: ![Code]
    , Note -> Maybe UiFrame
note_stack :: !(Maybe Stack.UiFrame)
    } deriving (Int -> Note -> ShowS
[Note] -> ShowS
Note -> String
(Int -> Note -> ShowS)
-> (Note -> String) -> ([Note] -> ShowS) -> Show Note
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note] -> ShowS
$cshowList :: [Note] -> ShowS
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Int -> Note -> ShowS
$cshowsPrec :: Int -> Note -> ShowS
Show)

data NotePitch = NotePitch {
    NotePitch -> Text
pitch_pitch :: !Text
    , NotePitch -> Tie
pitch_tie :: !Tie
    , NotePitch -> [Text]
pitch_prepend :: ![Code]
    , NotePitch -> [Text]
pitch_append :: ![Code]
    } deriving (Int -> NotePitch -> ShowS
[NotePitch] -> ShowS
NotePitch -> String
(Int -> NotePitch -> ShowS)
-> (NotePitch -> String)
-> ([NotePitch] -> ShowS)
-> Show NotePitch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotePitch] -> ShowS
$cshowList :: [NotePitch] -> ShowS
show :: NotePitch -> String
$cshow :: NotePitch -> String
showsPrec :: Int -> NotePitch -> ShowS
$cshowsPrec :: Int -> NotePitch -> ShowS
Show)

data Tie = NoTie | TieNeutral | TieUp | TieDown deriving (Int -> Tie -> ShowS
[Tie] -> ShowS
Tie -> String
(Int -> Tie -> ShowS)
-> (Tie -> String) -> ([Tie] -> ShowS) -> Show Tie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tie] -> ShowS
$cshowList :: [Tie] -> ShowS
show :: Tie -> String
$cshow :: Tie -> String
showsPrec :: Int -> Tie -> ShowS
$cshowsPrec :: Int -> Tie -> ShowS
Show)

-- | Arbitrary bit of lilypond code.  This type isn't used for non-arbitrary
-- chunks, like 'note_pitches'.
type Code = Text

instance ToLily Note where
    to_lily :: Note -> Text
to_lily (Note NonEmpty NotePitch
pitches NoteDuration
dur [Text]
prepend [Text]
append Maybe UiFrame
_) =
        [Text] -> Text
t_unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
prepend [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
note] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
append
        where
        ly_dur :: Text
ly_dur = NoteDuration -> Text
forall a. ToLily a => a -> Text
to_lily NoteDuration
dur
        note :: Text
note = case NonEmpty NotePitch
pitches of
            NotePitch Text
pitch Tie
tie [Text]
prepend [Text]
append :| [] -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ [Text] -> Text
t_unwords [Text]
prepend, Text
" "
                , Text
pitch, Text
ly_dur, Tie -> Text
forall a. ToLily a => a -> Text
to_lily Tie
tie
                , [Text] -> Text
t_unwords [Text]
append
                ]
            NonEmpty NotePitch
_ -> Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
t_unwords ((NotePitch -> Text) -> [NotePitch] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map NotePitch -> Text
forall a. ToLily a => a -> Text
to_lily (NonEmpty NotePitch -> [NotePitch]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty NotePitch
pitches))
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ly_dur

instance ToLily NotePitch where
    to_lily :: NotePitch -> Text
to_lily (NotePitch Text
pitch Tie
tie [Text]
prepend [Text]
append) = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ [Text] -> Text
t_unwords [Text]
prepend, Text
" "
        , Text
pitch, Tie -> Text
forall a. ToLily a => a -> Text
to_lily Tie
tie
        , [Text] -> Text
t_unwords [Text]
append
        ]

instance ToLily Tie where
    to_lily :: Tie -> Text
to_lily Tie
t = case Tie
t of
        Tie
NoTie -> Text
""
        Tie
TieNeutral -> Text
"~"
        Tie
TieUp -> Text
"^~"
        Tie
TieDown -> Text
"_~"

-- ** Rest

data Rest = Rest {
    Rest -> RestType
rest_type :: !RestType
    , Rest -> [Text]
rest_prepend :: ![Code]
    , Rest -> [Text]
rest_append :: ![Code]
    } deriving (Int -> Rest -> ShowS
[Rest] -> ShowS
Rest -> String
(Int -> Rest -> ShowS)
-> (Rest -> String) -> ([Rest] -> ShowS) -> Show Rest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Rest] -> ShowS
$cshowList :: [Rest] -> ShowS
show :: Rest -> String
$cshow :: Rest -> String
showsPrec :: Int -> Rest -> ShowS
$cshowsPrec :: Int -> Rest -> ShowS
Show)

make_rest :: RestType -> Rest
make_rest :: RestType -> Rest
make_rest RestType
typ = Rest
    { rest_type :: RestType
rest_type = RestType
typ
    , rest_prepend :: [Text]
rest_prepend = []
    , rest_append :: [Text]
rest_append = []
    }

data RestType =
    NormalRest !Types.NoteDuration
    | HiddenRest !Types.NoteDuration
    | FullMeasure !Types.Duration !Int
    deriving (Int -> RestType -> ShowS
[RestType] -> ShowS
RestType -> String
(Int -> RestType -> ShowS)
-> (RestType -> String) -> ([RestType] -> ShowS) -> Show RestType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RestType] -> ShowS
$cshowList :: [RestType] -> ShowS
show :: RestType -> String
$cshow :: RestType -> String
showsPrec :: Int -> RestType -> ShowS
$cshowsPrec :: Int -> RestType -> ShowS
Show)

rest_time :: Rest -> Time
rest_time :: Rest -> Time
rest_time Rest
rest = case Rest -> RestType
rest_type Rest
rest of
    NormalRest NoteDuration
dur -> NoteDuration -> Time
Types.note_dur_to_time NoteDuration
dur
    HiddenRest NoteDuration
dur -> NoteDuration -> Time
Types.note_dur_to_time NoteDuration
dur
    FullMeasure Duration
dur Int
mult -> Int -> Time -> Time
Types.multiply_int Int
mult (Duration -> Time
Types.dur_to_time Duration
dur)

instance ToLily Rest where
    to_lily :: Rest -> Text
to_lily (Rest RestType
typ [Text]
prepend [Text]
append) =
        [Text] -> Text
t_unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
prepend [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [RestType -> Text
forall a. ToLily a => a -> Text
to_lily RestType
typ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
append

instance ToLily RestType where
    to_lily :: RestType -> Text
to_lily RestType
r = case RestType
r of
        NormalRest NoteDuration
dur -> Text
"r" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NoteDuration -> Text
forall a. ToLily a => a -> Text
to_lily NoteDuration
dur
        HiddenRest NoteDuration
dur -> Text
"s" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NoteDuration -> Text
forall a. ToLily a => a -> Text
to_lily NoteDuration
dur
        FullMeasure Duration
dur Int
mult -> Text
"R" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Duration -> Text
forall a. ToLily a => a -> Text
to_lily Duration
dur Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
mult

-- ** Key

data Key = Key !Text !Mode deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show)
type Mode = Text

instance Pretty Key where pretty :: Key -> Text
pretty = Key -> Text
forall a. ToLily a => a -> Text
to_lily
instance ToLily Key where
    to_lily :: Key -> Text
to_lily (Key Text
tonic Text
mode) = Text
"\\key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tonic Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" \\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mode

parse_key :: Text -> Either Error Key
parse_key :: Text -> Either Text Key
parse_key Text
key_name = do
    Key
key <- Text -> Maybe Key -> Either Text Key
forall err a. err -> Maybe a -> Either err a
justErr (Text
"unknown key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key_name) (Maybe Key -> Either Text Key) -> Maybe Key -> Either Text Key
forall a b. (a -> b) -> a -> b
$
        Maybe Key -> Maybe Key
Twelve.lookup_key (Key -> Maybe Key
forall a. a -> Maybe a
Just (Text -> Key
Pitch.Key Text
key_name))
    (PitchClass
pc, Accidental
acc) <- Degree -> Either Text (PitchClass, Accidental)
Types.parse_degree (Key -> Degree
Theory.key_tonic Key
key)
    let tonic :: Text
tonic = PitchClass -> Text
forall a. ToLily a => a -> Text
to_lily PitchClass
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidental -> Text
forall a. ToLily a => a -> Text
to_lily Accidental
acc
    Text
mode <- Text -> Maybe Text -> Either Text Text
forall err a. err -> Maybe a -> Either err a
justErr (Text
"unknown mode: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
Theory.key_name Key
key) (Maybe Text -> Either Text Text) -> Maybe Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$
        Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Key -> Text
Theory.key_name Key
key) Map Text Text
modes
    Key -> Either Text Key
forall (m :: * -> *) a. Monad m => a -> m a
return (Key -> Either Text Key) -> Key -> Either Text Key
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Key
Key Text
tonic Text
mode
    where
    modes :: Map Text Text
modes = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"min", Text
"minor"), (Text
"locrian", Text
"locrian"), (Text
"maj", Text
"major")
        , (Text
"dorian", Text
"dorian"), (Text
"phrygian", Text
"phrygian"), (Text
"lydian", Text
"lydian")
        , (Text
"mixolydian", Text
"mixolydian")
        ]

lookup_key :: Event -> ConvertM Key
lookup_key :: Event -> ConvertM Key
lookup_key = Text -> (Text -> Either Text Key) -> Key -> Event -> ConvertM Key
forall a.
Text -> (Text -> Either Text a) -> a -> Event -> ConvertM a
lookup_val Text
EnvKey.key Text -> Either Text Key
parse_key Key
default_key

default_key :: Key
default_key :: Key
default_key = Text -> Text -> Key
Key Text
"c" Text
"major"

-- ** voice

-- | Each Ly list should be the same duration and have the same number of
-- barlines.
newtype Voices = Voices (VoiceMap Ly) deriving ([Voices] -> Doc
Voices -> Text
Voices -> Doc
(Voices -> Text)
-> (Voices -> Doc) -> ([Voices] -> Doc) -> Pretty Voices
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Voices] -> Doc
$cformatList :: [Voices] -> Doc
format :: Voices -> Doc
$cformat :: Voices -> Doc
pretty :: Voices -> Text
$cpretty :: Voices -> Text
Pretty, Int -> Voices -> ShowS
[Voices] -> ShowS
Voices -> String
(Int -> Voices -> ShowS)
-> (Voices -> String) -> ([Voices] -> ShowS) -> Show Voices
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Voices] -> ShowS
$cshowList :: [Voices] -> ShowS
show :: Voices -> String
$cshow :: Voices -> String
showsPrec :: Int -> Voices -> ShowS
$cshowsPrec :: Int -> Voices -> ShowS
Show)

-- | Voices shouldn't be repeated, so this would be more appropriate as a
-- @Map Voice [a]@, but it turns out all the consumers work best with a list
-- so list it is.
type VoiceMap a = [(Voice, [a])]

data Voice = VoiceOne | VoiceTwo | VoiceThree | VoiceFour
    deriving (Voice -> Voice -> Bool
(Voice -> Voice -> Bool) -> (Voice -> Voice -> Bool) -> Eq Voice
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Voice -> Voice -> Bool
$c/= :: Voice -> Voice -> Bool
== :: Voice -> Voice -> Bool
$c== :: Voice -> Voice -> Bool
Eq, Eq Voice
Eq Voice
-> (Voice -> Voice -> Ordering)
-> (Voice -> Voice -> Bool)
-> (Voice -> Voice -> Bool)
-> (Voice -> Voice -> Bool)
-> (Voice -> Voice -> Bool)
-> (Voice -> Voice -> Voice)
-> (Voice -> Voice -> Voice)
-> Ord Voice
Voice -> Voice -> Bool
Voice -> Voice -> Ordering
Voice -> Voice -> Voice
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Voice -> Voice -> Voice
$cmin :: Voice -> Voice -> Voice
max :: Voice -> Voice -> Voice
$cmax :: Voice -> Voice -> Voice
>= :: Voice -> Voice -> Bool
$c>= :: Voice -> Voice -> Bool
> :: Voice -> Voice -> Bool
$c> :: Voice -> Voice -> Bool
<= :: Voice -> Voice -> Bool
$c<= :: Voice -> Voice -> Bool
< :: Voice -> Voice -> Bool
$c< :: Voice -> Voice -> Bool
compare :: Voice -> Voice -> Ordering
$ccompare :: Voice -> Voice -> Ordering
Ord, Int -> Voice -> ShowS
[Voice] -> ShowS
Voice -> String
(Int -> Voice -> ShowS)
-> (Voice -> String) -> ([Voice] -> ShowS) -> Show Voice
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Voice] -> ShowS
$cshowList :: [Voice] -> ShowS
show :: Voice -> String
$cshow :: Voice -> String
showsPrec :: Int -> Voice -> ShowS
$cshowsPrec :: Int -> Voice -> ShowS
Show)

instance ToLily Voice where
    to_lily :: Voice -> Text
to_lily Voice
v = case Voice
v of
        Voice
VoiceOne -> Text
"\\voiceOne"; Voice
VoiceTwo -> Text
"\\voiceTwo"
        Voice
VoiceThree -> Text
"\\voiceThree"; Voice
VoiceFour -> Text
"\\voiceFour"

instance Pretty Voice where pretty :: Voice -> Text
pretty = Voice -> Text
forall a. Show a => a -> Text
showt

parse_voice :: Int -> Maybe Voice
parse_voice :: Int -> Maybe Voice
parse_voice Int
v = case Int
v of
    Int
1 -> Voice -> Maybe Voice
forall a. a -> Maybe a
Just Voice
VoiceOne; Int
2 -> Voice -> Maybe Voice
forall a. a -> Maybe a
Just Voice
VoiceTwo
    Int
3 -> Voice -> Maybe Voice
forall a. a -> Maybe a
Just Voice
VoiceThree; Int
4 -> Voice -> Maybe Voice
forall a. a -> Maybe a
Just Voice
VoiceFour
    Int
_ -> Maybe Voice
forall a. Maybe a
Nothing

event_voice :: Event -> Maybe (Either Error Voice)
event_voice :: Event -> Maybe (Either Text Voice)
event_voice Event
event =
    Either Text Voice -> Either Text Voice
forall {c}. Either Text c -> Either Text c
event_context (Either Text Voice -> Either Text Voice)
-> (Either Text Int -> Either Text Voice)
-> Either Text Int
-> Either Text Voice
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text Int -> Either Text Voice
parse (Either Text Int -> Either Text Voice)
-> Maybe (Either Text Int) -> Maybe (Either Text Voice)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Text -> Environ -> Maybe (Either Text Int)
forall a. Typecheck a => Text -> Environ -> Maybe (Either Text a)
Env.checked_val2 Text
EnvKey.voice (Event -> Environ
event_environ Event
event)
    where
    parse :: Either Text Int -> Either Text Voice
parse (Left Text
err) = Text -> Either Text Voice
forall a b. a -> Either a b
Left Text
err
    parse (Right Int
voice) =
        Text -> Maybe Voice -> Either Text Voice
forall err a. err -> Maybe a -> Either err a
justErr (Text
"voice should be 1--4: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
voice) (Maybe Voice -> Either Text Voice)
-> Maybe Voice -> Either Text Voice
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Voice
parse_voice Int
voice
    event_context :: Either Text c -> Either Text c
event_context = (Text -> Text) -> Either Text c -> Either Text c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Event -> Text
forall a. Pretty a => a -> Text
pretty Event
event Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")<>)

-- * Event

-- | Clip off the part of the event before the given time, or Nothing if it
-- was entirely clipped off.
clip_event :: Time -> Event -> Maybe Event
clip_event :: Time -> Event -> Maybe Event
clip_event Time
end Event
e
    | Time
left Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
0 = Maybe Event
forall a. Maybe a
Nothing
    | Bool
otherwise = Event -> Maybe Event
forall a. a -> Maybe a
Just (Event -> Maybe Event) -> Event -> Maybe Event
forall a b. (a -> b) -> a -> b
$
        Event
e { event_start :: Time
event_start = Time
end, event_duration :: Time
event_duration = Time
left, event_clipped :: Bool
event_clipped = Bool
True }
    where left :: Time
left = Event -> Time
event_end Event
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
end