-- Copyright 2014 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

-- | Convert from Score events to a lilypond score.
module Perform.Lilypond.Lilypond where
import qualified Control.Monad.State.Strict as State
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy
import qualified Data.Text.Lazy.Builder as Builder

import qualified Util.CallStack as CallStack
import qualified Util.Log as Log
import qualified Util.Pretty as Pretty
import qualified Util.Seq as Seq

import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack

import qualified Perform.Lilypond.Constants as Constants
import qualified Perform.Lilypond.Meter as Meter
import qualified Perform.Lilypond.Process as Process
import qualified Perform.Lilypond.Types as Types

import           Global


type Error = Text

-- * config

-- | Lilypond code inserted inside the toplevel paper block.
paper_config :: [Text]
paper_config :: [Text]
paper_config =
    -- Print page numbers centered at the bottom of the page, instead of
    -- in the upper right and upper left corners.
    [ Text
"print-page-number = ##t"
    , Text
"print-first-page-number = ##t"
    , Text
"oddHeaderMarkup = \\markup \\null"
    , Text
"evenHeaderMarkup = \\markup \\null"
    , Text
"oddFooterMarkup = \\markup {"
    , Text
"\\fill-line {"
    , Text
"    \\on-the-fly #print-page-number-check-first"
    , Text
"    \\fromproperty #'page:page-number-string"
    , Text
"    }"
    , Text
"}"
    , Text
"evenFooterMarkup = \\oddFooterMarkup"
    ]

-- * output

type Title = Text

-- | Format a list Movements into a complete lilypond file.
ly_file :: Types.Config -> Title -> [Movement] -> Lazy.Text
ly_file :: Config -> Text -> [Movement] -> Text
ly_file Config
config Text
title [Movement]
movements = Output () -> Text
forall a. Output a -> Text
run_output (Output () -> Text) -> Output () -> Text
forall a b. (a -> b) -> a -> b
$ do
    [Text] -> Output ()
outputs
        -- I only need 2.18.2 due to using \tuplet.  If it's a problem, I can
        -- easily switch back to 2.14.2 by switching back to \times.
        [ Text
"\\version" Text -> Text -> Text
<+> Text -> Text
str Text
"2.18.2"
        , Text
"\\language" Text -> Text -> Text
<+> Text -> Text
str Text
"english"
        -- I'm not using it, and it increases file size a lot.
        , Text
"\\pointAndClickOff"
        , Text
"\\include \"ly/lib.ily\""
        , Text
"\\header { title =" Text -> Text -> Text
<+> Text -> Text
str Text
title Text -> Text -> Text
<+> Text
"tagline = \"\" }"
        , Text
""
        , Text
"\\paper {"
        ]
    [Text] -> Output ()
outputs [Text]
paper_config
    [Text] -> Output ()
outputs [Text
"}", Text
""]
    (Movement -> Output ()) -> [Movement] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Movement -> Output ()
write_movement [Movement]
movements
    where
    write_movement :: Movement -> Output ()
write_movement (Text
title, [StaffGroup]
staff_groups) = do
        Text -> Output ()
output Text
"\\bookpart {\n"
        Bool -> Output () -> Output ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
title) (Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$
            Text -> Output ()
output (Text -> Output ()) -> Text -> Output ()
forall a b. (a -> b) -> a -> b
$ Text
"\\header { piece =" Text -> Text -> Text
<+> Text -> Text
str Text
title Text -> Text -> Text
<+> Text
"}\n"
        Text -> Output ()
output Text
"\\score {\n"
        Text -> Output ()
output Text
"<<\n"
        ((StaffGroup, StaffConfig) -> Output ())
-> [(StaffGroup, StaffConfig)] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StaffGroup, StaffConfig) -> Output ()
write_staves ([(StaffGroup, StaffConfig)] -> Output ())
-> [(StaffGroup, StaffConfig)] -> Output ()
forall a b. (a -> b) -> a -> b
$ [(Instrument, StaffConfig)]
-> [StaffGroup] -> [(StaffGroup, StaffConfig)]
sort_staves (Config -> [(Instrument, StaffConfig)]
Types.config_staves Config
config)
            [StaffGroup]
staff_groups
        Text -> Output ()
output Text
">>\n}\n"
        Text -> Output ()
output Text
"}\n\n"
    write_staves :: (StaffGroup, StaffConfig) -> Output ()
write_staves (StaffGroup Instrument
_ [[Either Voices Ly]]
staves, StaffConfig
config)
        | Bool -> Bool
not (StaffConfig -> Bool
Types.staff_display StaffConfig
config) = () -> Output ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | StaffConfig -> Bool
Types.staff_add_bass_staff StaffConfig
config =
            Text -> StaffConfig -> (StaffConfig -> Output ()) -> Output ()
forall {a}.
Text
-> StaffConfig
-> (StaffConfig -> StateT OutputState Identity a)
-> Output ()
write_staff_group Text
"StaffGroup" StaffConfig
config ((StaffConfig -> Output ()) -> Output ())
-> (StaffConfig -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \StaffConfig
config -> do
                case [[Either Voices Ly]]
staves of
                    [Either Voices Ly]
staff : [[Either Voices Ly]]
staves -> do
                        StaffConfig -> Maybe Text -> [Either Voices Ly] -> Output ()
forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"up") [Either Voices Ly]
staff
                        ([Either Voices Ly] -> Output ())
-> [[Either Voices Ly]] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StaffConfig -> Maybe Text -> [Either Voices Ly] -> Output ()
forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config Maybe Text
forall a. Maybe a
Nothing) [[Either Voices Ly]]
staves
                    [] -> () -> Output ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Maybe [Either Voices Ly]
-> ([Either Voices Ly] -> Output ()) -> Output ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([[Either Voices Ly]] -> Maybe [Either Voices Ly]
forall a. [a] -> Maybe a
Seq.head [[Either Voices Ly]]
staves) (([Either Voices Ly] -> Output ()) -> Output ())
-> ([Either Voices Ly] -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ StaffConfig -> [Either Voices Ly] -> Output ()
write_empty_staff StaffConfig
config
        | Bool
otherwise = case [[Either Voices Ly]]
staves of
            [[Either Voices Ly]
staff] -> StaffConfig -> Maybe Text -> [Either Voices Ly] -> Output ()
forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config Maybe Text
forall a. Maybe a
Nothing [Either Voices Ly]
staff
            [[Either Voices Ly]
up, [Either Voices Ly]
down] -> Text -> StaffConfig -> (StaffConfig -> Output ()) -> Output ()
forall {a}.
Text
-> StaffConfig
-> (StaffConfig -> StateT OutputState Identity a)
-> Output ()
write_staff_group Text
"PianoStaff" StaffConfig
config ((StaffConfig -> Output ()) -> Output ())
-> (StaffConfig -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \StaffConfig
config -> do
                StaffConfig -> Maybe Text -> [Either Voices Ly] -> Output ()
forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"up") [Either Voices Ly]
up
                StaffConfig -> Maybe Text -> [Either Voices Ly] -> Output ()
forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"down") [Either Voices Ly]
down
            [[Either Voices Ly]]
_ -> Text -> StaffConfig -> (StaffConfig -> Output ()) -> Output ()
forall {a}.
Text
-> StaffConfig
-> (StaffConfig -> StateT OutputState Identity a)
-> Output ()
write_staff_group Text
"PianoStaff" StaffConfig
config ((StaffConfig -> Output ()) -> Output ())
-> (StaffConfig -> Output ()) -> Output ()
forall a b. (a -> b) -> a -> b
$ \StaffConfig
config ->
                ([Either Voices Ly] -> Output ())
-> [[Either Voices Ly]] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StaffConfig -> Maybe Text -> [Either Voices Ly] -> Output ()
forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config Maybe Text
forall a. Maybe a
Nothing) [[Either Voices Ly]]
staves
    write_staff_group :: Text
-> StaffConfig
-> (StaffConfig -> StateT OutputState Identity a)
-> Output ()
write_staff_group Text
name StaffConfig
config StaffConfig -> StateT OutputState Identity a
contents = do
        [Text] -> Output ()
outputs
            [ Text
"\\new " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" <<"
            , Text -> Text -> Text
ly_set (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".instrumentName") (StaffConfig -> Text
Types.staff_long StaffConfig
config)
            , Text -> Text -> Text
ly_set (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".shortInstrumentName") (StaffConfig -> Text
Types.staff_short StaffConfig
config)
            ]
        StaffConfig -> StateT OutputState Identity a
contents (StaffConfig -> StateT OutputState Identity a)
-> StaffConfig -> StateT OutputState Identity a
forall a b. (a -> b) -> a -> b
$ StaffConfig
config { staff_long :: Text
Types.staff_long = Text
"", staff_short :: Text
Types.staff_short = Text
"" }
        Text -> Output ()
output Text
">>\n\n"
    normal_staff :: StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config Maybe Text
maybe_name t (Either Voices Ly)
lys =
        StaffConfig -> Maybe Text -> Maybe Text -> Output () -> Output ()
write_staff StaffConfig
config Maybe Text
maybe_name Maybe Text
forall a. Maybe a
Nothing ((Either Voices Ly -> Output ())
-> t (Either Voices Ly) -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Either Voices Ly -> Output ()
write_voice_ly t (Either Voices Ly)
lys)

-- | Convert ly code to all hidden rests, and emit an empty staff with a bass
-- clef.  This is so xstaff commands can later cause it to appear, only when
-- needed.
write_empty_staff :: Types.StaffConfig -> [Either Process.Voices Process.Ly]
    -> Output ()
write_empty_staff :: StaffConfig -> [Either Voices Ly] -> Output ()
write_empty_staff StaffConfig
config_ [Either Voices Ly]
lys =
    StaffConfig -> Maybe Text -> Maybe Text -> Output () -> Output ()
write_staff StaffConfig
config (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"down") (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"\\with { \\RemoveAllEmptyStaves }")(Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$
        (Ly -> Output ()) -> [Ly] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ly -> Output ()
write_ly ([Ly] -> Output ()) -> [Ly] -> Output ()
forall a b. (a -> b) -> a -> b
$
            Text -> Ly
Process.LyCode Text
"\\clef bass" Ly -> [Ly] -> [Ly]
forall a. a -> [a] -> [a]
: [Either Voices Ly] -> [Ly]
Process.convert_to_rests [Either Voices Ly]
lys
    where
    config :: StaffConfig
config = StaffConfig
config_ { staff_code :: [Text]
Types.staff_code = StaffConfig -> [Text]
Types.staff_code StaffConfig
config_ }

str :: Text -> Text
str :: Text -> Text
str = Text -> Text
forall a. ToLily a => a -> Text
Types.to_lily

(<+>) :: Text -> Text -> Text
Text
x <+> :: Text -> Text -> Text
<+> Text
y = Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y
infixr 6 <+> -- same as <>

ly_set :: Text -> Text -> Text
ly_set :: Text -> Text -> Text
ly_set Text
name Text
val = Text
"\\set" Text -> Text -> Text
<+> Text
name Text -> Text -> Text
<+> Text
"=" Text -> Text -> Text
<+> Text -> Text
str Text
val

write_staff :: Types.StaffConfig -> Maybe Text -> Maybe Text -> Output ()
    -> Output ()
write_staff :: StaffConfig -> Maybe Text -> Maybe Text -> Output () -> Output ()
write_staff StaffConfig
config Maybe Text
maybe_name Maybe Text
context Output ()
write_contents = do
    Text -> Output ()
output (Text -> Output ()) -> Text -> Output ()
forall a b. (a -> b) -> a -> b
$ Text
"\\new Staff " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"= "<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
str) Maybe Text
maybe_name
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text
" "<>) Maybe Text
context Text -> Text -> Text
<+> Text
"{\n"
    Bool -> Output () -> Output ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (StaffConfig -> Text
Types.staff_long StaffConfig
config)) (Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$
        [Text] -> Output ()
outputs [Text -> Text -> Text
ly_set Text
"Staff.instrumentName" (StaffConfig -> Text
Types.staff_long StaffConfig
config)]
    Bool -> Output () -> Output ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (StaffConfig -> Text
Types.staff_short StaffConfig
config)) (Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$
        [Text] -> Output ()
outputs [Text -> Text -> Text
ly_set Text
"Staff.shortInstrumentName" (StaffConfig -> Text
Types.staff_short StaffConfig
config)]
    [Text] -> Output ()
outputs [Text]
Types.global_staff_code
    [Text] -> Output ()
outputs (StaffConfig -> [Text]
Types.staff_code StaffConfig
config)
    Text -> Output ()
output Text
"{\n"
    Int -> Output ()
set_bar Int
1
    Output ()
write_contents
    Text -> Output ()
output Text
"\n} }\n\n"

write_voice_ly :: Either Process.Voices Process.Ly -> Output ()
write_voice_ly :: Either Voices Ly -> Output ()
write_voice_ly (Left (Process.Voices VoiceMap Ly
voices)) = do
    Text -> Output ()
output Text
"<<\n  "
    Int
start <- (OutputState -> Int) -> StateT OutputState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets OutputState -> Int
output_bar
    [Int]
bars <- ((Voice, [Ly]) -> StateT OutputState Identity Int)
-> VoiceMap Ly -> StateT OutputState Identity [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Voice, [Ly])
v -> Int -> Output ()
set_bar Int
start Output ()
-> StateT OutputState Identity Int
-> StateT OutputState Identity Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Voice, [Ly]) -> StateT OutputState Identity Int
write_voice (Voice, [Ly])
v) VoiceMap Ly
voices
    Text -> Output ()
output Text
">> \\oneVoice\n  "
    Bool -> Output () -> Output ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Int] -> Bool
forall {a}. Eq a => [a] -> Bool
all_equal [Int]
bars) (Output () -> Output ()) -> Output () -> Output ()
forall a b. (a -> b) -> a -> b
$
        -- Lilypond will also complain.
        Text -> Output ()
output (Text -> Output ()) -> Text -> Output ()
forall a b. (a -> b) -> a -> b
$ Text
"% WARNING: voices have different numbers of bars: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> Text
forall a. Show a => a -> Text
showt [Int]
bars
    Int -> Output ()
set_bar (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
start ([Int] -> Maybe Int
forall a. [a] -> Maybe a
Seq.head [Int]
bars))
    where
    all_equal :: [a] -> Bool
all_equal [] = Bool
True
    all_equal (a
x:[a]
xs) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x) [a]
xs
write_voice_ly (Right Ly
ly) = Ly -> Output ()
write_ly Ly
ly

write_ly :: Process.Ly -> Output ()
write_ly :: Ly -> Output ()
write_ly ly :: Ly
ly@(Process.LyBarline {}) = do
    Int
bar <- (OutputState -> Int) -> StateT OutputState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets OutputState -> Int
output_bar
    Maybe UiFrame
stack <- (OutputState -> Maybe UiFrame)
-> StateT OutputState Identity (Maybe UiFrame)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets OutputState -> Maybe UiFrame
output_last_stack
    Text -> Output ()
output (Text -> Output ()) -> Text -> Output ()
forall a b. (a -> b) -> a -> b
$ Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ly -> Text
forall a. ToLily a => a -> Text
Types.to_lily Ly
ly Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" % " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe UiFrame -> Text
show_stack Maybe UiFrame
stack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
bar
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    Int -> Output ()
set_bar (Int
barInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
write_ly Ly
ly = do
    Text -> Output ()
output (Text -> Output ()) -> Text -> Output ()
forall a b. (a -> b) -> a -> b
$ Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ly -> Text
forall a. ToLily a => a -> Text
Types.to_lily Ly
ly
    case Ly
ly of
        Process.LyNote Note
note -> (OutputState -> OutputState) -> Output ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((OutputState -> OutputState) -> Output ())
-> (OutputState -> OutputState) -> Output ()
forall a b. (a -> b) -> a -> b
$ \OutputState
state -> OutputState
state
            { output_last_stack :: Maybe UiFrame
output_last_stack = Note -> Maybe UiFrame
Process.note_stack Note
note }
        Ly
_ -> () -> Output ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

show_stack :: Maybe Stack.UiFrame -> Text
show_stack :: Maybe UiFrame -> Text
show_stack (Just UiFrame
stack) =  UiFrame -> Text
Stack.unparse_ui_frame UiFrame
stack Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; "
show_stack Maybe UiFrame
Nothing = Text
""

write_voice :: (Process.Voice, [Process.Ly]) -> Output Int
write_voice :: (Voice, [Ly]) -> StateT OutputState Identity Int
write_voice (Voice
voice, [Ly]
lys) = do
    Text -> Output ()
output (Text -> Output ()) -> Text -> Output ()
forall a b. (a -> b) -> a -> b
$ (if Voice
voice Voice -> Voice -> Bool
forall a. Eq a => a -> a -> Bool
== Voice
Process.VoiceOne then Text
"" else Text
"\\new Voice ")
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Voice -> Text
forall a. ToLily a => a -> Text
Types.to_lily Voice
voice Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n  "
    (Ly -> Output ()) -> [Ly] -> Output ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ly -> Output ()
write_ly [Ly]
lys
    Text -> Output ()
output Text
"} "
    (OutputState -> Int) -> StateT OutputState Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets OutputState -> Int
output_bar

sort_staves :: [(ScoreT.Instrument, Types.StaffConfig)] -> [StaffGroup]
    -> [(StaffGroup, Types.StaffConfig)]
sort_staves :: [(Instrument, StaffConfig)]
-> [StaffGroup] -> [(StaffGroup, StaffConfig)]
sort_staves [(Instrument, StaffConfig)]
inst_configs = (StaffGroup -> (StaffGroup, StaffConfig))
-> [StaffGroup] -> [(StaffGroup, StaffConfig)]
forall a b. (a -> b) -> [a] -> [b]
map StaffGroup -> (StaffGroup, StaffConfig)
lookup_name ([StaffGroup] -> [(StaffGroup, StaffConfig)])
-> ([StaffGroup] -> [StaffGroup])
-> [StaffGroup]
-> [(StaffGroup, StaffConfig)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StaffGroup -> (Integer, Int)) -> [StaffGroup] -> [StaffGroup]
forall k a. Ord k => (a -> k) -> [a] -> [a]
Seq.sort_on StaffGroup -> (Integer, Int)
forall {a}. Num a => StaffGroup -> (a, Int)
inst_key
    where
    lookup_name :: StaffGroup -> (StaffGroup, StaffConfig)
lookup_name StaffGroup
staff = case Instrument -> [(Instrument, StaffConfig)] -> Maybe StaffConfig
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (StaffGroup -> Instrument
inst_of StaffGroup
staff) [(Instrument, StaffConfig)]
inst_configs of
        Maybe StaffConfig
Nothing -> (StaffGroup
staff, Instrument -> StaffConfig
Types.default_staff_config (StaffGroup -> Instrument
inst_of StaffGroup
staff))
        Just StaffConfig
config -> (StaffGroup
staff, StaffConfig
config)
    inst_key :: StaffGroup -> (a, Int)
inst_key StaffGroup
staff =
        (a, Int) -> (Int -> (a, Int)) -> Maybe Int -> (a, Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a
1, Int
0) (a
0,) (Maybe Int -> (a, Int)) -> Maybe Int -> (a, Int)
forall a b. (a -> b) -> a -> b
$ Instrument -> [Instrument] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex (StaffGroup -> Instrument
inst_of StaffGroup
staff)
            (((Instrument, StaffConfig) -> Instrument)
-> [(Instrument, StaffConfig)] -> [Instrument]
forall a b. (a -> b) -> [a] -> [b]
map (Instrument, StaffConfig) -> Instrument
forall a b. (a, b) -> a
fst [(Instrument, StaffConfig)]
inst_configs)
    inst_of :: StaffGroup -> Instrument
inst_of (StaffGroup Instrument
inst [[Either Voices Ly]]
_) = Instrument
inst

type Output a = State.State OutputState a

run_output :: Output a -> Lazy.Text
run_output :: forall a. Output a -> Text
run_output Output a
m = Builder -> Text
Builder.toLazyText (OutputState -> Builder
output_text OutputState
state)
    where state :: OutputState
state = Output a -> OutputState -> OutputState
forall s a. State s a -> s -> s
State.execState Output a
m (Builder -> Int -> Maybe UiFrame -> OutputState
OutputState Builder
forall a. Monoid a => a
mempty Int
1 Maybe UiFrame
forall a. Maybe a
Nothing)

data OutputState = OutputState {
    OutputState -> Builder
output_text :: !Builder.Builder
    , OutputState -> Int
output_bar :: !Int
    , OutputState -> Maybe UiFrame
output_last_stack :: !(Maybe Stack.UiFrame)
    } deriving (Int -> OutputState -> ShowS
[OutputState] -> ShowS
OutputState -> String
(Int -> OutputState -> ShowS)
-> (OutputState -> String)
-> ([OutputState] -> ShowS)
-> Show OutputState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputState] -> ShowS
$cshowList :: [OutputState] -> ShowS
show :: OutputState -> String
$cshow :: OutputState -> String
showsPrec :: Int -> OutputState -> ShowS
$cshowsPrec :: Int -> OutputState -> ShowS
Show)

outputs :: [Text] -> Output ()
outputs :: [Text] -> Output ()
outputs = Text -> Output ()
output (Text -> Output ()) -> ([Text] -> Text) -> [Text] -> Output ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines

output :: Text -> Output ()
output :: Text -> Output ()
output Text
text = (OutputState -> OutputState) -> Output ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((OutputState -> OutputState) -> Output ())
-> (OutputState -> OutputState) -> Output ()
forall a b. (a -> b) -> a -> b
$ \OutputState
state -> OutputState
state
    { output_text :: Builder
output_text = OutputState -> Builder
output_text OutputState
state Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Builder.fromText Text
text }

set_bar :: Int -> Output ()
set_bar :: Int -> Output ()
set_bar Int
n = (OutputState -> OutputState) -> Output ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((OutputState -> OutputState) -> Output ())
-> (OutputState -> OutputState) -> Output ()
forall a b. (a -> b) -> a -> b
$ \OutputState
state -> OutputState
state { output_bar :: Int
output_bar = Int
n }


-- * convert events

type Movement = (Title, [StaffGroup])

-- | If the staff group has >1 staff, it is bracketed as a grand staff.
data StaffGroup =
    StaffGroup ScoreT.Instrument [[Either Process.Voices Process.Ly]]
    deriving (Int -> StaffGroup -> ShowS
[StaffGroup] -> ShowS
StaffGroup -> String
(Int -> StaffGroup -> ShowS)
-> (StaffGroup -> String)
-> ([StaffGroup] -> ShowS)
-> Show StaffGroup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StaffGroup] -> ShowS
$cshowList :: [StaffGroup] -> ShowS
show :: StaffGroup -> String
$cshow :: StaffGroup -> String
showsPrec :: Int -> StaffGroup -> ShowS
$cshowsPrec :: Int -> StaffGroup -> ShowS
Show)

instance Pretty StaffGroup where
    format :: StaffGroup -> Doc
format (StaffGroup Instrument
inst [[Either Voices Ly]]
staves) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"StaffGroup"
        [ (Text
"inst", Instrument -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst)
        , (Text
"staves", [[Either Voices Ly]] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [[Either Voices Ly]]
staves)
        ]

explicit_movements :: Types.Config -> [(Title, [Types.Event])]
    -> Either Log.Msg [Movement]
explicit_movements :: Config -> [(Text, [Event])] -> Either Msg [Movement]
explicit_movements Config
config [(Text, [Event])]
sections = [(Text, [Event])]
-> ((Text, [Event]) -> Either Msg Movement)
-> Either Msg [Movement]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, [Event])]
sections (((Text, [Event]) -> Either Msg Movement) -> Either Msg [Movement])
-> ((Text, [Event]) -> Either Msg Movement)
-> Either Msg [Movement]
forall a b. (a -> b) -> a -> b
$ \(Text
title, [Event]
events) -> do
    let ([Event]
global, [Event]
normal) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition
            ((Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
==Instrument
Constants.ly_global) (Instrument -> Bool) -> (Event -> Instrument) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Types.event_instrument) [Event]
events
    -- TODO filter out the v_movements since I won't be using them?
    [StaffGroup]
staves <- Config -> Time -> [Event] -> [Event] -> Either Msg [StaffGroup]
convert_staff_groups Config
config Time
0 [Event]
global [Event]
normal
    Movement -> Either Msg Movement
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
title, [StaffGroup]
staves)

extract_movements :: Types.Config -> [Types.Event] -> Either Log.Msg [Movement]
extract_movements :: Config -> [Event] -> Either Msg [Movement]
extract_movements Config
config [Event]
events = do
    let ([Event]
global, [Event]
normal) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition
            ((Instrument -> Instrument -> Bool
forall a. Eq a => a -> a -> Bool
==Instrument
Constants.ly_global) (Instrument -> Bool) -> (Event -> Instrument) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Types.event_instrument) [Event]
events
    ([(Time, Text)]
movements, [Event]
global) <- (Text -> Either Msg ([(Time, Text)], [Event]))
-> (([(Time, Text)], [Event])
    -> Either Msg ([(Time, Text)], [Event]))
-> Either Text ([(Time, Text)], [Event])
-> Either Msg ([(Time, Text)], [Event])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Either Msg ([(Time, Text)], [Event])
forall a. Stack => Text -> Either Msg a
warn ([(Time, Text)], [Event]) -> Either Msg ([(Time, Text)], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text ([(Time, Text)], [Event])
 -> Either Msg ([(Time, Text)], [Event]))
-> Either Text ([(Time, Text)], [Event])
-> Either Msg ([(Time, Text)], [Event])
forall a b. (a -> b) -> a -> b
$
        Text -> [Event] -> Either Text ([(Time, Text)], [Event])
partition_key Text
Constants.v_movement [Event]
global
    [(Time, Text, [Event])]
-> ((Time, Text, [Event]) -> Either Msg Movement)
-> Either Msg [Movement]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([(Time, Text)] -> [Event] -> [(Time, Text, [Event])]
split_movements [(Time, Text)]
movements [Event]
normal) (((Time, Text, [Event]) -> Either Msg Movement)
 -> Either Msg [Movement])
-> ((Time, Text, [Event]) -> Either Msg Movement)
-> Either Msg [Movement]
forall a b. (a -> b) -> a -> b
$ \(Time
start, Text
title, [Event]
events) -> do
        [StaffGroup]
staves <- Config -> Time -> [Event] -> [Event] -> Either Msg [StaffGroup]
convert_staff_groups Config
config Time
start [Event]
global [Event]
events
        Movement -> Either Msg Movement
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
title, [StaffGroup]
staves)

-- | Group a stream of events into individual staves based on instrument, and
-- for keyboard instruments, left or right hand.  Then convert each staff of
-- Events to Notes, divided up into measures.
convert_staff_groups :: Types.Config -> Types.Time -> [Types.Event]
    -> [Types.Event] -> Either Log.Msg [StaffGroup]
convert_staff_groups :: Config -> Time -> [Event] -> [Event] -> Either Msg [StaffGroup]
convert_staff_groups Config
config Time
start [Event]
global [Event]
events = do
    let staff_groups :: [(Instrument, [[Event]])]
staff_groups = [Event] -> [(Instrument, [[Event]])]
split_events [Event]
events
    let staff_end :: Time
staff_end = Time -> Maybe Time -> Time
forall a. a -> Maybe a -> a
fromMaybe Time
0 (Maybe Time -> Time) -> Maybe Time -> Time
forall a b. (a -> b) -> a -> b
$ [Time] -> Maybe Time
forall a. Ord a => [a] -> Maybe a
Seq.maximum ((Event -> Time) -> [Event] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Event -> Time
Types.event_end [Event]
events)
    ([Meter]
meters, [Event]
global) <- (Text -> Either Msg ([Meter], [Event]))
-> (([Meter], [Event]) -> Either Msg ([Meter], [Event]))
-> Either Text ([Meter], [Event])
-> Either Msg ([Meter], [Event])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Either Msg ([Meter], [Event])
forall a. Stack => Text -> Either Msg a
warn ([Meter], [Event]) -> Either Msg ([Meter], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text ([Meter], [Event]) -> Either Msg ([Meter], [Event]))
-> Either Text ([Meter], [Event]) -> Either Msg ([Meter], [Event])
forall a b. (a -> b) -> a -> b
$ Time -> Time -> [Event] -> Either Text ([Meter], [Event])
parse_meters Time
start Time
staff_end [Event]
global
    -- It would be nicer to partition_on Process.free_code so I don't have to
    -- re-parse it in each Process.process, but then process would have to
    -- take an Either FreeCode Event or something.
    let ([Event]
global_code, [Event]
remain) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition
            (Bool -> Bool
not (Bool -> Bool) -> (Event -> Bool) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FreeCodePosition, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(FreeCodePosition, Text)] -> Bool)
-> (Event -> [(FreeCodePosition, Text)]) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(FreeCodePosition, Text)]
Constants.environ_free_code (Environ -> [(FreeCodePosition, Text)])
-> (Event -> Environ) -> Event -> [(FreeCodePosition, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Types.event_environ)
            [Event]
global
    Bool -> Either Msg () -> Either Msg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Event] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
remain) (Either Msg () -> Either Msg ()) -> Either Msg () -> Either Msg ()
forall a b. (a -> b) -> a -> b
$
        Text -> Either Msg ()
forall a. Stack => Text -> Either Msg a
warn (Text -> Either Msg ()) -> Text -> Either Msg ()
forall a b. (a -> b) -> a -> b
$ Text
"leftover ly-global events: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Event] -> Text
forall a. Pretty a => a -> Text
pretty [Event]
global
    [(Instrument, [[Event]])]
-> ((Instrument, [[Event]]) -> Either Msg StaffGroup)
-> Either Msg [StaffGroup]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Instrument, [[Event]])]
staff_groups (((Instrument, [[Event]]) -> Either Msg StaffGroup)
 -> Either Msg [StaffGroup])
-> ((Instrument, [[Event]]) -> Either Msg StaffGroup)
-> Either Msg [StaffGroup]
forall a b. (a -> b) -> a -> b
$ \(Instrument
inst, [[Event]]
staves) ->
        Config
-> Time
-> [Meter]
-> Instrument
-> [[Event]]
-> Either Msg StaffGroup
staff_group Config
config Time
start [Meter]
meters Instrument
inst ([[Event]] -> Either Msg StaffGroup)
-> [[Event]] -> Either Msg StaffGroup
forall a b. (a -> b) -> a -> b
$
            ([Event] -> [Event]) -> [[Event]] -> [[Event]]
forall a b. (a -> b) -> [a] -> [b]
map ([Event] -> Instrument -> [Event] -> [Event]
distribute_global [Event]
global_code Instrument
inst) [[Event]]
staves

-- | Split events by instrument, and if they have 'EnvKey.hand', further split
-- into right and left hand.
split_events :: [Types.Event] -> [(ScoreT.Instrument, [[Types.Event]])]
split_events :: [Event] -> [(Instrument, [[Event]])]
split_events [Event]
events =
    [ (Instrument
inst, (Event -> Integer) -> [Event] -> [[Event]]
forall key a. Ord key => (a -> key) -> [a] -> [[a]]
Seq.group_sort (Environ -> Integer
forall {a}. Num a => Environ -> a
lookup_hand (Environ -> Integer) -> (Event -> Environ) -> Event -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Types.event_environ) [Event]
events)
    | (Instrument
inst, [Event]
events) <- [(Instrument, [Event])]
by_inst
    ]
    where
    by_inst :: [(Instrument, [Event])]
by_inst = (Event -> Instrument) -> [Event] -> [(Instrument, [Event])]
forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Seq.keyed_group_sort Event -> Instrument
Types.event_instrument [Event]
events
    lookup_hand :: Environ -> a
lookup_hand Environ
environ = case Text -> Environ -> Either LookupError Text
forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.hand Environ
environ of
        Right (Text
val :: Text)
            | Text
val Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"r" Bool -> Bool -> Bool
|| Text
val Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"right" -> a
0
            | Text
val Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"l" Bool -> Bool -> Bool
|| Text
val Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"left" -> a
1
            | Bool
otherwise -> a
2
        Either LookupError Text
_ -> a
0

-- | Right hand goes at the top, left hand goes at the bottom.  Any other hands
-- go below that.  Events that are don't have a hand are assumed to be in the
-- right hand.
staff_group :: Types.Config -> Types.Time -> [Meter.Meter] -> ScoreT.Instrument
    -> [[Types.Event]] -> Either Log.Msg StaffGroup
staff_group :: Config
-> Time
-> [Meter]
-> Instrument
-> [[Event]]
-> Either Msg StaffGroup
staff_group Config
config Time
start [Meter]
meters Instrument
inst [[Event]]
staves = do
    [[Either Voices Ly]]
staff_measures <- [(Integer, [Event])]
-> ((Integer, [Event]) -> Either Msg [Either Voices Ly])
-> Either Msg [[Either Voices Ly]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Integer] -> [[Event]] -> [(Integer, [Event])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [[Event]]
staves) (((Integer, [Event]) -> Either Msg [Either Voices Ly])
 -> Either Msg [[Either Voices Ly]])
-> ((Integer, [Event]) -> Either Msg [Either Voices Ly])
-> Either Msg [[Either Voices Ly]]
forall a b. (a -> b) -> a -> b
$ \(Integer
i, [Event]
es) ->
        Integer
-> Either Msg [Either Voices Ly] -> Either Msg [Either Voices Ly]
forall {p :: * -> * -> *} {a} {c}.
(Bifunctor p, Show a) =>
a -> p Msg c -> p Msg c
annotate Integer
i (Either Msg [Either Voices Ly] -> Either Msg [Either Voices Ly])
-> Either Msg [Either Voices Ly] -> Either Msg [Either Voices Ly]
forall a b. (a -> b) -> a -> b
$ Config
-> Time -> [Meter] -> [Event] -> Either Msg [Either Voices Ly]
Process.process Config
config Time
start [Meter]
meters [Event]
es
    StaffGroup -> Either Msg StaffGroup
forall (m :: * -> *) a. Monad m => a -> m a
return (StaffGroup -> Either Msg StaffGroup)
-> StaffGroup -> Either Msg StaffGroup
forall a b. (a -> b) -> a -> b
$ Instrument -> [[Either Voices Ly]] -> StaffGroup
StaffGroup Instrument
inst [[Either Voices Ly]]
staff_measures
    where
    annotate :: a -> p Msg c -> p Msg c
annotate a
i = (Msg -> Msg) -> p Msg c -> p Msg c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Msg -> Msg
Log.add_prefix (Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
inst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
i))

-- | Global FreeCode events get distributed to all staves.
distribute_global :: [Types.Event] -> ScoreT.Instrument -> [Types.Event]
    -> [Types.Event]
distribute_global :: [Event] -> Instrument -> [Event] -> [Event]
distribute_global [Event]
codes Instrument
inst =
    (Event -> Time) -> [Event] -> [Event] -> [Event]
forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a]
Seq.merge_on Event -> Time
Types.event_start
        ((Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map (\Event
e -> Event
e { event_instrument :: Instrument
Types.event_instrument = Instrument
inst }) [Event]
codes)

-- ** movements

-- | Use the movement break points to group the events by movement.  The events
-- are not shifted in time, so each movement has to start at the proper offset.
-- The reason is that certain calls, like tuplet, bake in lilypond code, and it
-- will be wrong if the events change position.
split_movements :: [(Types.Time, Title)] -> [Types.Event]
    -> [(Types.Time, Title, [Types.Event])]
split_movements :: [(Time, Text)] -> [Event] -> [(Time, Text, [Event])]
split_movements [(Time, Text)]
movements =
    ((Time, Text, [Event]) -> Bool)
-> [(Time, Text, [Event])] -> [(Time, Text, [Event])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Time, Text, [Event]) -> Bool) -> (Time, Text, [Event]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Event] -> Bool)
-> ((Time, Text, [Event]) -> [Event])
-> (Time, Text, [Event])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, Text, [Event]) -> [Event]
forall {a} {b} {c}. (a, b, c) -> c
events_of) ([(Time, Text, [Event])] -> [(Time, Text, [Event])])
-> ([Event] -> [(Time, Text, [Event])])
-> [Event]
-> [(Time, Text, [Event])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((Time, Text), Maybe (Time, Text))]
-> [Event] -> [(Time, Text, [Event])]
forall {a} {b} {b}.
(Num a, IsString b) =>
[((a, b), Maybe (Time, b))] -> [Event] -> [(a, b, [Event])]
split ([(Time, Text)] -> [((Time, Text), Maybe (Time, Text))]
forall a. [a] -> [(a, Maybe a)]
Seq.zip_next ((Time
0, Text
"") (Time, Text) -> [(Time, Text)] -> [(Time, Text)]
forall a. a -> [a] -> [a]
: [(Time, Text)]
movements))
    where
    split :: [((a, b), Maybe (Time, b))] -> [Event] -> [(a, b, [Event])]
split (((a
start, b
title), Just (Time
next, b
_)) : [((a, b), Maybe (Time, b))]
movements) [Event]
events =
        (a
start, b
title, [Event]
pre) (a, b, [Event]) -> [(a, b, [Event])] -> [(a, b, [Event])]
forall a. a -> [a] -> [a]
: [((a, b), Maybe (Time, b))] -> [Event] -> [(a, b, [Event])]
split [((a, b), Maybe (Time, b))]
movements [Event]
post
        where ([Event]
pre, [Event]
post) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>=Time
next) (Time -> Bool) -> (Event -> Time) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Time
Types.event_start) [Event]
events
    split (((a
start, b
title), Maybe (Time, b)
Nothing) : [((a, b), Maybe (Time, b))]
_) [Event]
events = [(a
start, b
title, [Event]
events)]
    split [] [Event]
events = [(a
0, b
"", [Event]
events)]
    events_of :: (a, b, c) -> c
events_of (a
_, b
_, c
x) = c
x

-- ** meter

-- | Extract Meters from the Events, and emit one per measure.
parse_meters :: Types.Time -> Types.Time -> [Types.Event]
    -> Either Error ([Meter.Meter], [Types.Event])
parse_meters :: Time -> Time -> [Event] -> Either Text ([Meter], [Event])
parse_meters Time
start Time
staff_end [Event]
events = do
    ([(Time, Text)]
meters, [Event]
remain) <- Text -> [Event] -> Either Text ([(Time, Text)], [Event])
partition_key Text
Constants.v_meter [Event]
events
    [(Time, Meter)]
meters <- ((Time, Text) -> Either Text (Time, Meter))
-> [(Time, Text)] -> Either Text [(Time, Meter)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Time
pos, Text
meter) -> (Time
pos,) (Meter -> (Time, Meter))
-> Either Text Meter -> Either Text (Time, Meter)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Meter
Meter.parse_meter Text
meter) [(Time, Text)]
meters
    ([Meter], [Event]) -> Either Text ([Meter], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return (Time -> Meter -> [(Time, Meter)] -> [Meter]
generate Time
start Meter
Meter.default_meter [(Time, Meter)]
meters, [Event]
remain)
    where
    generate :: Time -> Meter -> [(Time, Meter)] -> [Meter]
generate Time
prev Meter
prev_meter ((Time
pos, Meter
meter) : [(Time, Meter)]
meters) | Time
pos Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
staff_end =
        Int -> Meter -> [Meter]
forall a. Int -> a -> [a]
replicate Int
measures Meter
prev_meter [Meter] -> [Meter] -> [Meter]
forall a. [a] -> [a] -> [a]
++ Time -> Meter -> [(Time, Meter)] -> [Meter]
generate Time
next Meter
meter [(Time, Meter)]
meters
        where
        measures :: Int
measures = Time -> Meter -> Int
forall {a} {a}. (Integral a, Integral a) => a -> Meter -> a
measures_in (Time
posTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
prev) Meter
prev_meter
        next :: Time
next = Time
prev Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
measures Time -> Time -> Time
forall a. Num a => a -> a -> a
* Meter -> Time
Meter.measure_time Meter
prev_meter
    generate Time
prev Meter
meter [(Time, Meter)]
_ = Int -> Meter -> [Meter]
forall a. Int -> a -> [a]
replicate (Time -> Meter -> Int
forall {a} {a}. (Integral a, Integral a) => a -> Meter -> a
measures_in (Time
staff_endTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
prev) Meter
meter) Meter
meter
    -- If you try to change the meter in the middle of a meter, it rounds up to
    -- the next barline.  If you put multiple meter changes before the barline,
    -- only the first one is accepted.  TODO arguably it should be the last.
    -- TODO or an error.
    measures_in :: a -> Meter -> a
measures_in a
dur Meter
meter = a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ Double -> a
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> a) -> Double -> a
forall a b. (a -> b) -> a -> b
$
        a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
dur Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Time -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Meter -> Time
Meter.measure_time Meter
meter)

-- * util

warn :: CallStack.Stack => Text -> Either Log.Msg a
warn :: forall a. Stack => Text -> Either Msg a
warn = Msg -> Either Msg a
forall a b. a -> Either a b
Left (Msg -> Either Msg a) -> (Text -> Msg) -> Text -> Either Msg a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn Maybe Stack
forall a. Maybe a
Nothing

partition_key :: EnvKey.Key -> [Types.Event]
    -> Either Error ([(Types.Time, Text)], [Types.Event])
partition_key :: Text -> [Event] -> Either Text ([(Time, Text)], [Event])
partition_key Text
key = [Event] -> Either Text ([(Time, Text)], [Event])
forall {b}.
Typecheck b =>
[Event] -> Either Text ([(Time, b)], [Event])
go
    where
    go :: [Event] -> Either Text ([(Time, b)], [Event])
go [] = ([(Time, b)], [Event]) -> Either Text ([(Time, b)], [Event])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    go (Event
e : [Event]
es) = case Text -> Environ -> Maybe (Either Text b)
forall a. Typecheck a => Text -> Environ -> Maybe (Either Text a)
Env.checked_val2 Text
key (Event -> Environ
Types.event_environ Event
e) of
        Maybe (Either Text b)
Nothing -> ([Event] -> [Event])
-> ([(Time, b)], [Event]) -> ([(Time, b)], [Event])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Event
e:) (([(Time, b)], [Event]) -> ([(Time, b)], [Event]))
-> Either Text ([(Time, b)], [Event])
-> Either Text ([(Time, b)], [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event] -> Either Text ([(Time, b)], [Event])
go [Event]
es
        Just (Left Text
err) -> Text -> Either Text ([(Time, b)], [Event])
forall a b. a -> Either a b
Left (Text -> Either Text ([(Time, b)], [Event]))
-> Text -> Either Text ([(Time, b)], [Event])
forall a b. (a -> b) -> a -> b
$ Instrument -> Text
forall a. Pretty a => a -> Text
pretty Instrument
Constants.ly_global Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" event at "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Time -> Text
forall a. Pretty a => a -> Text
pretty Time
pos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
        Just (Right b
val) -> ([(Time, b)] -> [(Time, b)])
-> ([(Time, b)], [Event]) -> ([(Time, b)], [Event])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Time
pos, b
val) :) (([(Time, b)], [Event]) -> ([(Time, b)], [Event]))
-> Either Text ([(Time, b)], [Event])
-> Either Text ([(Time, b)], [Event])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event] -> Either Text ([(Time, b)], [Event])
go [Event]
es
        where pos :: Time
pos = Event -> Time
Types.event_start Event
e