-- 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.Lists as Lists
import qualified Util.Log as Log
import qualified Util.NEs as NEs
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
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(..), Time, ToLily, event_attributes, event_end, to_lily)
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Ly -> Bool
wanted forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = 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) = forall a. a -> Maybe a
Just [Note -> NoteDuration
note_duration Note
n]
    has_duration (LyRest Rest
r) =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Duration -> NoteDuration
Types.dur_to_note_dur forall a b. (a -> b) -> a -> b
$ Time -> [Duration]
Types.time_to_durs forall a b. (a -> b) -> a -> b
$ Rest -> Time
rest_time Rest
r
    has_duration Ly
_ = forall a. Maybe a
Nothing
    hush :: [Ly] -> [Ly]
hush [Ly]
lys = -- TODO simplify durs
        forall a b. (a -> b) -> [a] -> [b]
map (Rest -> Ly
LyRest forall b c a. (b -> c) -> (a -> b) -> a -> c
. RestType -> Rest
make_rest forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDuration -> RestType
HiddenRest) (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NoteDuration]]
durs) forall a. [a] -> [a] -> [a]
++ case [Ly]
non_notes of
            Ly
ly : [Ly]
rest -> Ly
ly forall a. a -> [a] -> [a]
: [Ly] -> [Ly]
hush [Ly]
rest
            [] -> []
        where ([[NoteDuration]]
durs, [Ly]
non_notes) = forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.spanWhile Ly -> Maybe [NoteDuration]
has_duration [Ly]
lys

-- * process

data Chunk = ChunkNotes [Event] | ChunkVoices (VoiceMap Event)
    deriving (Int -> Chunk -> ShowS
[Chunk] -> ShowS
Chunk -> String
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" [forall a. Pretty a => a -> Doc
Pretty.format [Event]
events]
    format (ChunkVoices VoiceMap Event
voices) =
        Text -> [Doc] -> Doc
Pretty.constructor Text
"ChunkVoices" [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_ = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ConvertError -> Msg
to_log forall a b. (a -> b) -> a -> b
$ do
    let ([FreeCode]
free_codes, [Event]
events) = forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.partitionOn Event -> Maybe FreeCode
free_code [Event]
events_
    [Chunk]
chunks <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Stack -> Text -> ConvertError
ConvertError forall a. Maybe a
Nothing) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        [Event] -> Either Text [Chunk]
collect_chunks [Event]
events
    let end :: Time
end = Time
start forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (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 <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Chunk] -> [Chunk]
merge_note_code_chunks 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Key
default_key)
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. State -> ConvertM a -> Either ConvertError (a, State)
run_convert State
state forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> ConvertM Key
lookup_key) (forall a. [a] -> Maybe a
Lists.head [Event]
events)
    State
state <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State
state { state_key :: Key
state_key = Key
key }
    ([Either Voices Ly]
lys, State
_) <- forall a. State -> ConvertM a -> Either ConvertError (a, State)
run_convert State
state forall a b. (a -> b) -> a -> b
$ [Chunk] -> ConvertM [Either Voices Ly]
convert [Chunk]
chunks
    [Either Voices Ly]
lys <- forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. a -> Maybe a -> a
fromMaybe Meter
Meter.default_meter (forall a. [a] -> Maybe a
Lists.head [Meter]
meters)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text -> Ly
LyCode forall a b. (a -> b) -> a -> b
$ Text
"\\time " forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily Meter
meter)
        forall a. a -> [a] -> [a]
: forall a b. b -> Either a b
Right (Text -> Ly
LyCode forall a b. (a -> b) -> a -> b
$ forall a. ToLily a => a -> Text
to_lily Key
key)
        forall a. a -> [a] -> [a]
: [Either Voices Ly]
lys
        forall a. [a] -> [a] -> [a]
++ [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 = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ 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 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 [] = 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 = 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 ++) 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. [a] -> Maybe a
Lists.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) VoiceMap Event
voice
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. [a] -> Maybe a
Lists.head [Event]
remain) forall a b. (a -> b) -> a -> b
$ \Event
e ->
            forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Event -> Event -> Bool
Types.event_overlaps Event
e) [Event]
tails) forall a b. (a -> b) -> a -> b
$ \Event
over ->
                forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"last voice " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Event
over
                    forall a. Semigroup a => a -> a -> a
<> Text
" overlaps first non-voice " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Event
e
        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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Eq a => a -> a -> Bool
==forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Maybe (Either Text Voice)
event_voice) [Event]
events
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall a. [a] -> Maybe a
Lists.last [Event]
without forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. [a] -> Maybe a
Lists.head [Event]
remain) forall a b. (a -> b) -> a -> b
$ \(Event
e1, Event
e2) ->
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> Event -> Bool
Types.event_overlaps Event
e1 Event
e2) forall a b. (a -> b) -> a -> b
$
                    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"last non-voice " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Event
e1
                        forall a. Semigroup a => a -> a -> a
<> Text
" overlaps first voice " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Event
e2
        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) = forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.spanWhile (\Event
e -> (,Event
e) 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Either Text Voice, Event)]
voice forall a b. (a -> b) -> a -> b
$ \(Either Text Voice
err_or_voice, Event
event) -> (,Event
event) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Voice
err_or_voice
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. Ord a => [(a, b)] -> [(a, NonNull b)]
Lists.groupFst [(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 = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests forall a. Maybe a
Nothing Time
t [Event]
events
    insert !Time
t (ChunkVoices VoiceMap Event
voices) = case 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests (forall a. a -> Maybe a
Just Time
end) Time
t)) VoiceMap Event
voices
    get_end :: [(a, [Event])] -> Maybe Time
get_end = forall a. Ord a => [a] -> Maybe a
Lists.maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Event -> Time
event_end forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. [a] -> Maybe a
Lists.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    final :: Time -> [Chunk]
final Time
t
        | Time
t forall a. Ord a => a -> a -> Bool
< Time
end = [[Event] -> Chunk
ChunkNotes [Time -> Time -> Event
rest_event Time
t (Time
endforall 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 forall a. Ord a => a -> a -> Bool
> Time
t -> (Time
end, [Time -> Time -> Event
rest_event Time
t (Time
end forall a. Num a => a -> a -> a
- Time
t)])
        Maybe Time
_ -> (Time
t, [])
    go Time
t (Event
event : [Event]
events) =
        (([Event]
rest forall a. [a] -> [a] -> [a]
++ Event
event forall a. a -> [a] -> [a]
: [Event]
here) ++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Time -> [Event] -> (Time, [Event])
go (forall a. Ord a => a -> a -> a
max Time
t (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map Event -> Time
event_end (Event
event forall a. a -> [a] -> [a]
: [Event]
here)))) [Event]
there
        where
        rest :: [Event]
rest = if Time
gap forall a. Ord a => a -> a -> Bool
<= Time
0 then [] else [Time -> Time -> Event
rest_event Time
t Time
gap]
        ([Event]
here, [Event]
there) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<= Event -> Time
event_start Event
event) 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 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 = forall a. Maybe a
Nothing
    , event_instrument :: Instrument
event_instrument = Instrument
ScoreT.empty_instrument
    , event_environ :: Environ
event_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 = 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 (forall a b. (a -> b) -> [a] -> [b]
map (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 forall a. a -> [a] -> [a]
: [Event]
ps 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<= Event -> Time
event_start Event
event) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start) [Event]
events
        ([Event]
zero, [Event]
nonzero) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition Event -> Bool
code_event (Event
event forall a. a -> [a] -> [a]
: [Event]
here)
        codes :: [(CodePosition, Text)]
codes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Environ -> [(CodePosition, Text)]
Constants.environ_code 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 forall a. Eq a => a -> a -> Bool
== 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
k Environ
env of
        Maybe a
Nothing -> forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
k a
code Environ
env
        Just a
old -> forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
k (a
old forall a. Semigroup 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 = 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) =
        forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Monad m =>
([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete (Bool -> [Event] -> ConvertM ([Ly], [Event])
convert_chunk Bool
True) [Event]
events
    go (ChunkVoices VoiceMap Event
voices) = VoiceMap Ly -> [Either Voices Ly]
simplify_voices forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VoiceMap Event -> ConvertM (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) =
        forall a b. b -> Either a b
Right Ly
applied forall a. a -> [a] -> [a]
: Time -> [FreeCode] -> [Either Voices Ly] -> [Either Voices Ly]
go (Time
start 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) =
        forall a b. a -> Either a b
Left (VoiceMap Ly -> Voices
Voices ((Voice
v, [Ly]
applied) forall a. a -> [a] -> [a]
: VoiceMap Ly
voices)) 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 [] = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Ly
LyCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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) =
        forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Ly
applied:) forall a b. (a -> b) -> a -> b
$ Time -> [FreeCode] -> [Ly] -> ([Ly], (Time, [FreeCode]))
merge_lys (Time
start 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
_ | 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 (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<Time
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [FreeCode]
codes
        end :: Time
end = Time
start 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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Note -> Ly
LyNote forall a b. (a -> b) -> a -> b
$ Note
note
        { note_prepend :: [Text]
note_prepend = [Text]
prepend forall a. [a] -> [a] -> [a]
++ Note -> [Text]
note_prepend Note
note
        , note_append :: [Text]
note_append = Note -> [Text]
note_append Note
note forall a. [a] -> [a] -> [a]
++ [Text]
append
        }
    LyRest Rest
rest -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Rest -> Ly
LyRest forall a b. (a -> b) -> a -> b
$ Rest
rest
        { rest_prepend :: [Text]
rest_prepend = [Text]
prepend forall a. [a] -> [a] -> [a]
++ Rest -> [Text]
rest_prepend Rest
rest
        , rest_append :: [Text]
rest_append = Rest -> [Text]
rest_append Rest
rest forall a. [a] -> [a] -> [a]
++ [Text]
append
        }
    LyNested Nested
nested -> do
        [Ly]
lys <- [Ly] -> Maybe [Ly]
apply_nested forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NonEmpty.toList (Nested -> NonEmpty Ly
nested_contents Nested
nested)
        NonEmpty Ly
lys <- forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Ly]
lys
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Nested -> Ly
LyNested forall a b. (a -> b) -> a -> b
$ Nested
nested { nested_contents :: NonEmpty Ly
nested_contents = NonEmpty Ly
lys }
    Ly
_ -> forall a. Maybe a
Nothing
    where
    ([Text]
prepend, [Text]
append) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((forall a. Eq a => a -> a -> Bool
==FreeCodePosition
Constants.FreePrepend) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 [] = 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:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ly] -> Maybe [Ly]
apply_nested [Ly]
lys
        Just Ly
applied -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Ly
applied 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
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FreeCodePosition, Text)]
code = forall a. Maybe a
Nothing
    | Bool
otherwise = 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 [] = 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++) 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] -> ConvertM ([Ly], [Event])
convert_chunk Bool
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
convert_chunk Bool
metered (Event
event : [Event]
events) = forall a. Event -> ConvertM a -> ConvertM a
with_event Event
event forall a b. (a -> b) -> a -> b
$ if
    | Just ((RealTime
score_dur, RealTime
real_dur), (Event
_, [Event]
remain))
            <- 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] -> ConvertM ([Ly], [Event])
convert_tuplet Time
start Time
score_dur Time
real_dur [Event]
remain
    | Just ((), (Event
event, [Event]
remain)) <- forall {a}. (Environ -> Maybe a) -> Maybe (a, (Event, [Event]))
find Environ -> Maybe ()
has_tremolo ->
        Event -> [Event] -> ConvertM ([Ly], [Event])
convert_tremolo Event
event [Event]
remain
    | Bool
otherwise -> Bool -> NonEmpty Event -> ConvertM ([Ly], [Event])
convert_chord Bool
metered (Event
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 = forall a. a -> Maybe a
Just ()
        | Bool
otherwise = 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 = forall a.
Time
-> (Event -> Maybe a) -> [Event] -> Maybe (a, (Event, [Event]))
find_here Time
start (Environ -> Maybe a
match forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ) (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 = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Event, [Event]) -> Maybe (a, (Event, [Event]))
find (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 forall a. [a] -> [a] -> [a]
++ [Event]
later)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe a
match Event
e
    ([Event]
here, [Event]
later) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<=Time
start) 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) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a
x:)) (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 = forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
k 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 = 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 = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Text -> Event -> Maybe a
lookup_env Text
k

zero_dur :: Event -> Bool
zero_dur :: Event -> Bool
zero_dur = (forall a. Eq a => a -> a -> Bool
==Time
0) 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] -> ConvertM ([Ly], [Event])
convert_tuplet Time
start Time
score_dur Time
real_dur [Event]
events = do
    let ([Event]
in_tuplet, [Event]
out) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
< Time
start forall a. Num a => a -> a -> a
+ Time
score_dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start) [Event]
events
    State
old <- 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 = forall a. Ratio a -> a
Ratio.numerator (Time -> Rational
Types.to_whole Time
score_dur) 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 <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
is_duplet then Time
score_dur else Time
score_dur forall a. Num a => a -> a -> a
* Time
2
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
real_dur forall a. Ord a => a -> a -> Bool
<= Time
0) forall a b. (a -> b) -> a -> b
$
        forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"tuplet with a real_dur of 0: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Time
start, Time
score_dur, Time
real_dur)
    let divisor :: Rational
divisor = forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
score_dur forall a. Fractional a => a -> a -> a
/ 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.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ratio a -> a
Ratio.numerator Rational
divisor forall a. Ord a => a -> a -> Bool
> Integer
15 Bool -> Bool -> Bool
|| forall a. Ratio a -> a
Ratio.denominator Rational
divisor forall a. Ord a => a -> a -> Bool
> Integer
15) forall a b. (a -> b) -> a -> b
$
        forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"tuplet factor is too complicated: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Time
score_dur
            forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> 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 <- forall (m :: * -> *) a b.
Monad m =>
([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete (Bool -> [Event] -> ConvertM ([Ly], [Event])
convert_chunk Bool
False) forall a b. (a -> b) -> a -> b
$
        forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Maybe Time -> Time -> [Event] -> (Time, [Event])
insert_rests (forall a. a -> Maybe a
Just (Time
start forall a. Num a => a -> a -> a
+ Time
score_dur)) Time
start forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (Int -> Time -> Event -> Event
stretch Int
factor Time
start) [Event]
in_tuplet
    NonEmpty Ly
lys <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> ConvertM a
throw Text
"empty tuplet") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Ly]
lys

    -- Rewind time back to before the tuplet.
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' 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 <- forall a. Text -> ConvertM a -> ConvertM a
with_context Text
"converting tuplet" forall a b. (a -> b) -> a -> b
$
        Time -> ConvertM (Maybe Ly)
advance_measure (Time
start 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 (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Ly
lys)) NonEmpty Ly
lys
    forall (m :: * -> *) a. Monad m => a -> m a
return (Ly
code forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (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 forall a b. (a -> b) -> a -> b
$ Nested
    { nested_prefix :: Text
nested_prefix = Text
"\\tuplet " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Integer
num forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Integer
denom 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 = forall a. Ratio a -> a
Ratio.numerator Rational
ratio forall a. Num a => a -> a -> a
* Integer
factor
    denom :: Integer
denom = forall a. Ratio a -> a
Ratio.denominator Rational
ratio forall a. Num a => a -> a -> a
* Integer
factor
    factor :: Integer
factor = (Integer
2^) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Integer
0 forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a -> a
logBase Double
2 forall a b. (a -> b) -> a -> b
$
        forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
notes forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets forall a b. (a -> b) -> a -> b
$ Config -> RealTime
Types.config_quarter_duration forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Config
state_config
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Eq a => a -> a -> Bool
== Int
1 = Event
event
    | Bool
otherwise = Event
event
        { event_start :: Time
event_start =
            forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
factor forall a. Num a => a -> a -> a
* (Event -> Time
event_start Event
event forall a. Num a => a -> a -> a
- Time
start) forall a. Num a => a -> a -> a
+ Time
start
        , event_duration :: Time
event_duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
factor 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] -> ConvertM ([Ly], [Event])
convert_tremolo Event
tremolo_event [Event]
events = do
    Time
dur <- ConvertM Time
get_allowed_dur
    let ([Event]
in_tremolo, [Event]
out) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
< Time
start forall a. Num a => a -> a -> a
+ Time
dur) 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 <- 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
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' 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 forall a. Num a => a -> a -> a
+ Time
dur)

    let (Int
times, Rational
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction forall a b. (a -> b) -> a -> b
$ Time -> Rational
Types.to_whole Time
dur forall a. Num a => a -> a -> a
* Rational
16
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rational
frac forall a. Eq a => a -> a -> Bool
/= Rational
0) forall a b. (a -> b) -> a -> b
$ forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"dur " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
dur
        forall a. Semigroup a => a -> a -> a
<> Text
" doesn't yield an integral number of 16th notes: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Time -> Rational
Types.to_whole Time
dur 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 forall a. Ord a => a -> a -> Bool
>= Time
total_dur = []
            | Bool
otherwise = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time -> Event -> Maybe Event
clip_event (Time
start forall a. Num a => a -> a -> a
+ Time
dur))
                (Event
tremolo_event forall a. a -> [a] -> [a]
: [Event]
in_tremolo)
    NonEmpty Note
notes <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> ConvertM a
throw Text
"no notes in tremolo") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        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 forall a. [a] -> [a] -> [a]
++ [Text]
nprepend) ([Text]
nappend forall a. [a] -> [a] -> [a]
++ [Text]
append)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Nested -> Ly
LyNested Nested
note forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) Maybe Ly
barline, [Event]
clipped 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Time
state_measure_start
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NoteDuration -> Time
Types.note_dur_to_time forall a b. (a -> b) -> a -> b
$ Bool -> Meter -> Time -> Time -> NoteDuration
Meter.allowed_duration Bool
use_dot Meter
meter
            (Time
start forall a. Num a => a -> a -> a
- Time
measure_start)
            (Time
start forall a. Num a => a -> a -> a
- Time
measure_start 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 " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
times forall a. Semigroup a => a -> a -> a
<> Text
" {"
    , nested_contents :: NonEmpty Ly
nested_contents = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Note -> Ly
LyNote (Note
with_code 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 forall a. [a] -> [a] -> [a]
++ Note -> [Text]
note_prepend Note
note
        , note_append :: [Text]
note_append = Note -> [Text]
note_append Note
note 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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,) 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
            } 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 = forall a. [a] -> Maybe a
Lists.last 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 = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {a}. (Maybe a, b, Maybe a) -> (Bool, b, Bool)
to_bool forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(Maybe a, a, Maybe a)]
Lists.zipNeighbors
    where
    to_bool :: (Maybe a, b, Maybe a) -> (Bool, b, Bool)
to_bool (Maybe a
prev, b
cur, Maybe a
next) =
        (forall a. Maybe a -> Bool
Maybe.isNothing Maybe a
prev, b
cur, 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 -> ConvertM ([Ly], [Event])
convert_chord Bool
metered NonEmpty Event
events = do
    Key
key <- Event -> ConvertM Key
lookup_key (forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
events)
    State
state <- forall s (m :: * -> *). MonadState s m => m s
State.get
    Config
config <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Config
state_config
    let ([Event]
here, [Event]
there) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break
            ((forall a. Ord a => a -> a -> Bool
> Event -> Time
event_start (forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
events)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
event_start)
            (forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty Event
events)
        next :: Maybe Time
next = Event -> Time
event_start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Bool
zero_dur) [Event]
there
    [Event]
here <- [Event] -> ConvertM [Event]
consume_subdivisions (forall a. NonEmpty a -> a
NonEmpty.head NonEmpty Event
events forall a. a -> [a] -> [a]
: [Event]
here)
    Maybe Meter
meter <- if Bool
metered then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertM Meter
get_subdivision else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    case forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [Event]
here of
        Maybe (NonEmpty Event)
Nothing -> 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return 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 {} -> forall (m :: * -> *) a. Monad m => a -> m a
return []
                Ly
_ -> do
                    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' 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
                        }
                    forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Ly
LyCode (forall a. ToLily a => a -> Text
to_lily Key
key) | Key
key forall a. Eq a => a -> a -> Bool
/= State -> Key
state_key State
state]
            forall (m :: * -> *) a. Monad m => a -> m a
return
                ( [Ly]
key_change forall a. [a] -> [a] -> [a]
++ [Ly
chord_ly] forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
:[]) Maybe Ly
barline
                , [Event]
clipped 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 = 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Event]
normal
    where
    ([Text]
subdivisions, [Event]
normal) = forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
Lists.partitionOn Event -> Maybe Text
lookup_subdivision [Event]
events
    update :: Text -> StateT State (ExceptT ConvertError Identity) ()
update Text
"" = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \State
state ->
        State
state { state_subdivision :: Maybe Meter
state_subdivision = forall a. Maybe a
Nothing }
    update Text
m = do
        Meter
meter <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Text -> ConvertM a
throw forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
            ((Text
"can't parse meter in " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
Constants.v_subdivision
                forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
m forall a. Semigroup a => a -> a -> a
<> Text
": ")<>)
            (Text -> Either Text Meter
Meter.parse_meter Text
m)
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \State
state -> State
state { state_subdivision :: Maybe Meter
state_subdivision = 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 forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [NotePitch]
note_pitches of
        Maybe (NonEmpty NotePitch)
Nothing -> Rest -> Ly
LyRest 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 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 forall a. [a] -> [a] -> [a]
++ [Text]
attrs_codes
            , note_stack :: Maybe UiFrame
note_stack = forall a. [a] -> Maybe a
Lists.last forall a b. (a -> b) -> a -> b
$ Stack -> [UiFrame]
Stack.to_ui forall a b. (a -> b) -> a -> b
$ Event -> Stack
event_stack forall a b. (a -> b) -> a -> b
$
                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 <- forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn Event -> Maybe Pitch
event_pitch forall a b. (a -> b) -> a -> b
$ 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
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard 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
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$
            forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Event -> Attributes
event_attributes forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Event
chord

    ([Text]
prepend_chord, [Text]
append_chord) =
        forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Ord a => [a] -> [a]
Lists.unique forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (forall a. Ord a => [a] -> [a]
Lists.unique forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ 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 <- forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Event
chord
            ]

    note_tie :: Event -> Tie
note_tie Event
event
        | Event -> Time
event_end Event
event forall a. Ord a => a -> a -> Bool
<= Time
allowed_end = Tie
NoTie
        | Text -> Bool
Text.null Text
direction = Tie
TieNeutral
        | Text
direction 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 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Time -> Event -> Maybe Event
clip_event Time
allowed_end) (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Event
chord)
    start :: Time
start = Event -> Time
event_start (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 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 forall a. Eq a => a -> a -> Bool
== Time
measure_start
                Bool -> Bool -> Bool
&& Time
max_end forall a. Num a => a -> a -> a
- Time
start 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 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 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 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 = forall a. Ord a => Maybe a -> a -> a
min_if Maybe Time
next forall a b. (a -> b) -> a -> b
$ forall a. Ord a => NonEmpty a -> a
NEs.minimum (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 = 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 =
    forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a. Ord a => [a] -> [a]
Lists.unique forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (forall a. Ord a => [a] -> [a]
Lists.unique forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall {a}. [(CodePosition, a)] -> ([a], [a])
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(CodePosition, Text)]
Constants.environ_code forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ
    where
    extract :: [(CodePosition, a)] -> ([a], [a])
extract [(CodePosition, a)]
codes =
        (forall {a}. Position -> [(CodePosition, a)] -> [a]
get Position
Constants.Prepend [(CodePosition, a)]
codes, 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 forall a. Eq a => a -> a -> Bool
== Attach
attach, Position
p forall a. Eq a => a -> a -> Bool
== Position
pos, Distribution
d forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Distribution]
dists
        ]
    dists :: [Distribution]
dists = Distribution
Constants.All forall a. a -> [a] -> [a]
: [Distribution
Constants.First | Bool
is_first]
        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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
b (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" forall a. ToLily a => a -> Text
to_lily (Event -> Maybe Pitch
event_pitch Event
event)
        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 forall a. [a] -> [a] -> [a]
++ [Text]
starts forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe Text]
ends, forall a. Monoid a => [a] -> a
mconcat (Attributes
current 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) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall a. Eq a => a -> a -> Bool
== Attributes
Attrs.nv Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Attributes
current `has`) [Attributes]
inherently_nv
                then (forall a. Maybe a
Nothing, Attributes
Attrs.nv)
                else (forall a. a -> Maybe a
Just a
end, forall a. Monoid a => a
mempty)
        | Bool
otherwise = (forall a. Maybe a
Nothing, 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 -> ConvertM (VoiceMap Ly)
voices_to_ly [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
voices_to_ly VoiceMap Event
voices = do
    State
state <- forall s (m :: * -> *). MonadState s m => m s
State.get
    ([State]
states, VoiceMap Ly
voice_lys) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall a. Eq a => a -> a -> Bool
== State -> Time
state_time State
st) forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Time
state_time) [State]
sts) forall a b. (a -> b) -> a -> b
$
                forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"inconsistent states after voices: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (State
stforall a. a -> [a] -> [a]
:[State]
sts)
            forall s (m :: * -> *). MonadState s m => s -> m ()
State.put State
st
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    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) <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall a b. (a -> b) -> a -> b
$ forall a. State -> ConvertM a -> Either ConvertError (a, State)
run_convert State
state forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a b.
Monad m =>
([a] -> m ([b], [a])) -> [a] -> m [b]
until_complete (Bool -> [Event] -> ConvertM ([Ly], [Event])
convert_chunk Bool
True) [Event]
events
        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 =
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (VoiceMap Ly -> [Either Voices Ly]
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: * -> *} {a}. Foldable t => [(a, t Ly)] -> [(a, t Ly)]
strip) 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 = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> k) -> [[a]] -> [a]
Lists.mergeLists forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Ly] -> [[Time]]
rests_at forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) VoiceMap Ly
voices
    rests_at :: [Ly] -> [[Time]]
rests_at [Ly]
lys =
        [ [Time
start, Time
start 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 forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Ly -> Bool
rest_measure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, t Ly)]
voices of
            [] -> 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all 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 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)] = forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [Ly]
lys
    flatten VoiceMap Ly
voices = [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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. [a] -> [b] -> [(a, b)]
zip [Voice]
voices) (forall a. [[a]] -> [[a]]
Lists.rotate [[[Ly]]]
lys)
        where ([Voice]
voices, [[[Ly]]]
lys) = 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 = forall {a} {b}. Ord a => [a] -> [(a, b)] -> [[b]]
go [Time]
times forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Int -> [a] -> [a]
drop Int
1 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 = [forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, b)]
rest]
        go (a
t:[a]
ts) [(a, b)]
lys = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, b)]
pre forall a. a -> [a] -> [a]
: [a] -> [(a, b)] -> [[b]]
go [a]
ts [(a, b)]
post
            where ([(a, b)]
pre, [(a, b)]
post) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<=a
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Time
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
State.get
    where
    advance :: State -> ConvertM (Maybe Ly)
advance State
state
        | Time
time forall a. Ord a => a -> a -> Bool
< State -> Time
state_time State
state =
            forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"can't advance time backward: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
time
                forall a. Semigroup a => a -> a -> a
<> Text
" < " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (State -> Time
state_time State
state)
        | Time
time forall a. Ord a => a -> a -> Bool
< State -> Time
state_measure_end State
state = do
            forall s (m :: * -> *). MonadState s m => s -> m ()
State.put forall a b. (a -> b) -> a -> b
$ State
state { state_time :: Time
state_time = Time
time }
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        | Time
time 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 -> forall {m :: * -> *}.
MonadState State m =>
Meter -> [Meter] -> m (Maybe Ly)
advance1 Meter
prev_meter [Meter]
meters
                [Meter]
_ -> forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"out of meters, can't advance time to "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
time
        | Bool
otherwise =
            forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"can't advance time past barline: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
time
                forall a. Semigroup a => a -> a -> a
<> Text
" > " forall a. Semigroup a => a -> a -> a
<> 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
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify' 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
                forall a. Num a => a -> a -> a
+ Meter -> Time
Meter.measure_time (forall a. a -> Maybe a -> a
fromMaybe Meter
prev_meter (forall a. [a] -> Maybe a
Lists.head [Meter]
meters))
            , state_time :: Time
state_time = Time
time
            }
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a. [a] -> Maybe a
Lists.head [Meter]
meters of
            Just Meter
meter -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe Meter -> Ly
LyBarline forall a b. (a -> b) -> a -> b
$
                if forall a. ToLily a => a -> Text
to_lily Meter
prev_meter forall a. Eq a => a -> a -> Bool
== forall a. ToLily a => a -> Text
to_lily Meter
meter
                    then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Meter
meter
            Maybe Meter
_ -> 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
State.get
    where
    advance :: State -> StateT State (ExceptT ConvertError Identity) ()
advance State
state
        | Time
time forall a. Ord a => a -> a -> Bool
< State -> Time
state_time State
state =
            forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"can't advance unmetered time backward: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
time
                forall a. Semigroup a => a -> a -> a
<> Text
" < " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (State -> Time
state_time State
state)
        | Bool
otherwise = forall s (m :: * -> *). MonadState s m => s -> m ()
State.put 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> [Meter]
state_meters
    Meter
meter <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> ConvertM a
throw Text
"out of meters") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head [Meter]
meters
    Maybe Meter
subdivision <- 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 forall a. Eq a => a -> a -> Bool
== Meter -> Time
Meter.measure_time Meter
sub -> forall (m :: * -> *) a. Monad m => a -> m a
return Meter
sub
            | Bool
otherwise -> forall a. Text -> ConvertM a
throw forall a b. (a -> b) -> a -> b
$ Text
"subdivision " forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily Meter
sub
                forall a. Semigroup a => a -> a -> a
<> Text
" incompatible with meter " forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily Meter
meter
        Maybe Meter
Nothing -> 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
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
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
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 = forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
Except.catchError forall a b. (a -> b) -> a -> b
$ \(ConvertError Maybe Stack
_ Text
msg) ->
    forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ Maybe Stack -> Text -> ConvertError
ConvertError (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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
Except.catchError forall a b. (a -> b) -> a -> b
$ \(ConvertError Maybe Stack
stack Text
msg) ->
    forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ Maybe Stack -> Text -> ConvertError
ConvertError Maybe Stack
stack (Text
prefix forall a. Semigroup a => a -> a -> a
<> 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
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", forall a. Pretty a => a -> Doc
Pretty.format Config
config)
            , (Text
"meters", forall a. Pretty a => a -> Doc
Pretty.format [Meter]
meters)
            , (Text
"measure_start", forall a. Pretty a => a -> Doc
Pretty.format Time
mstart)
            , (Text
"measure_end", forall a. Pretty a => a -> Doc
Pretty.format Time
mend)
            , (Text
"time", forall a. Pretty a => a -> Doc
Pretty.format Time
time)
            , (Text
"prev_attrs", forall a. Pretty a => a -> Doc
Pretty.format Attributes
prev_attrs)
            , (Text
"key", forall a. Pretty a => a -> Doc
Pretty.format Key
key)
            , (Text
"subdivision", 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 forall a. Num a => a -> a -> a
+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Time
0 Meter -> Time
Meter.measure_time (forall a. [a] -> Maybe a
Lists.head [Meter]
meters)
    , state_time :: Time
state_time = Time
start
    , state_prev_attrs :: Attributes
state_prev_attrs = forall a. Monoid a => a
mempty
    , state_key :: Key
state_key = Key
key
    , state_subdivision :: Maybe Meter
state_subdivision = forall a. Maybe a
Nothing
    }

-- ** util

throw :: Error -> ConvertM a
throw :: forall a. Text -> ConvertM a
throw Text
msg = do
    Time
now <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Time
state_time
    forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ Maybe Stack -> Text -> ConvertError
ConvertError forall a. Maybe a
Nothing (forall a. Pretty a => a -> Text
pretty Time
now forall a. Semigroup a => a -> a -> a
<> 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 = forall {a}. Either Text a -> ConvertM a
prefix forall a b. (a -> b) -> a -> b
$ do
    Maybe Text
maybe_val <- forall a. Typecheck a => Text -> Environ -> Either Text (Maybe a)
Env.checked_val Text
key (Event -> Environ
event_environ Event
event)
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Text -> ConvertM a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a. Pretty a => a -> Text
pretty Text
key forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)) 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
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 = 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
"| " forall a. Semigroup a => a -> a -> a
<> Text
"\\time " forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily Meter
meter
        LyNote Note
note -> forall a. ToLily a => a -> Text
to_lily Note
note
        LyRest Rest
rest -> forall a. ToLily a => a -> Text
to_lily Rest
rest
        LyNested Nested
nested -> 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Int
Lists.count 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
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 forall a b. (a -> b) -> a -> b
$ Text
prefix forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. ToLily a => a -> Text
to_lily (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Ly
contents) 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
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
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
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 forall a b. (a -> b) -> a -> b
$ [Text]
prepend forall a. [a] -> [a] -> [a]
++ [Text
note] forall a. [a] -> [a] -> [a]
++ [Text]
append
        where
        ly_dur :: Text
ly_dur = 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 :| [] -> forall a. Monoid a => [a] -> a
mconcat
                [ [Text] -> Text
t_unwords [Text]
prepend, Text
" "
                , Text
pitch, Text
ly_dur, forall a. ToLily a => a -> Text
to_lily Tie
tie
                , [Text] -> Text
t_unwords [Text]
append
                ]
            NonEmpty NotePitch
_ -> Text
"<" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
t_unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToLily a => a -> Text
to_lily (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty NotePitch
pitches))
                forall a. Semigroup a => a -> a -> a
<> 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) = forall a. Monoid a => [a] -> a
mconcat
        [ [Text] -> Text
t_unwords [Text]
prepend, Text
" "
        , Text
pitch, 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
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
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 forall a b. (a -> b) -> a -> b
$ [Text]
prepend forall a. [a] -> [a] -> [a]
++ [forall a. ToLily a => a -> Text
to_lily RestType
typ] 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" forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily NoteDuration
dur
        HiddenRest NoteDuration
dur -> Text
"s" forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily NoteDuration
dur
        FullMeasure Duration
dur Int
mult -> Text
"R" forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily Duration
dur forall a. Semigroup a => a -> a -> a
<> Text
"*" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
mult

-- ** Key

data Key = Key !Text !Mode deriving (Key -> Key -> Bool
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
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 = 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 " forall a. Semigroup a => a -> a -> a
<> Text
tonic forall a. Semigroup a => a -> a -> a
<> 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 <- forall err a. err -> Maybe a -> Either err a
justErr (Text
"unknown key: " forall a. Semigroup a => a -> a -> a
<> Text
key_name) forall a b. (a -> b) -> a -> b
$
        Maybe Key -> Maybe Key
Twelve.lookup_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 = forall a. ToLily a => a -> Text
to_lily PitchClass
pc forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily Accidental
acc
    Text
mode <- forall err a. err -> Maybe a -> Either err a
justErr (Text
"unknown mode: " forall a. Semigroup a => a -> a -> a
<> Key -> Text
Theory.key_name Key
key) forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Key -> Text
Theory.key_name Key
key) Map Text Text
modes
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Text -> Key
Key Text
tonic Text
mode
    where
    modes :: Map Text Text
modes = 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 = 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
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
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
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
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
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 = 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 -> forall a. a -> Maybe a
Just Voice
VoiceOne; Int
2 -> forall a. a -> Maybe a
Just Voice
VoiceTwo
    Int
3 -> forall a. a -> Maybe a
Just Voice
VoiceThree; Int
4 -> forall a. a -> Maybe a
Just Voice
VoiceFour
    Int
_ -> forall a. Maybe a
Nothing

event_voice :: Event -> Maybe (Either Error Voice)
event_voice :: Event -> Maybe (Either Text Voice)
event_voice Event
event =
    forall {c}. Either Text c -> Either Text c
event_context forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text Int -> Either Text Voice
parse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        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) = forall a b. a -> Either a b
Left Text
err
    parse (Right Int
voice) =
        forall err a. err -> Maybe a -> Either err a
justErr (Text
"voice should be 1--4: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
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 = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((forall a. Pretty a => a -> Text
pretty Event
event 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 forall a. Ord a => a -> a -> Bool
<= Time
0 = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just 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 forall a. Num a => a -> a -> a
- Time
end