-- 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.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Pretty as Pretty

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 = forall a. Output a -> Text
run_output 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
""]
    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"
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
title) forall a b. (a -> b) -> a -> b
$
            Text -> Output ()
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"
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (StaffGroup, StaffConfig) -> Output ()
write_staves 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) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | StaffConfig -> Bool
Types.staff_add_bass_staff StaffConfig
config =
            forall {a}.
Text
-> StaffConfig
-> (StaffConfig -> StateT OutputState Identity a)
-> Output ()
write_staff_group Text
"StaffGroup" StaffConfig
config 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
                        forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config (forall a. a -> Maybe a
Just Text
"up") [Either Voices Ly]
staff
                        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config forall a. Maybe a
Nothing) [[Either Voices Ly]]
staves
                    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. [a] -> Maybe a
Lists.head [[Either Voices Ly]]
staves) 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] -> forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config forall a. Maybe a
Nothing [Either Voices Ly]
staff
            [[Either Voices Ly]
up, [Either Voices Ly]
down] -> forall {a}.
Text
-> StaffConfig
-> (StaffConfig -> StateT OutputState Identity a)
-> Output ()
write_staff_group Text
"PianoStaff" StaffConfig
config forall a b. (a -> b) -> a -> b
$ \StaffConfig
config -> do
                forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config (forall a. a -> Maybe a
Just Text
"up") [Either Voices Ly]
up
                forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config (forall a. a -> Maybe a
Just Text
"down") [Either Voices Ly]
down
            [[Either Voices Ly]]
_ -> forall {a}.
Text
-> StaffConfig
-> (StaffConfig -> StateT OutputState Identity a)
-> Output ()
write_staff_group Text
"PianoStaff" StaffConfig
config forall a b. (a -> b) -> a -> b
$ \StaffConfig
config ->
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {t :: * -> *}.
Foldable t =>
StaffConfig -> Maybe Text -> t (Either Voices Ly) -> Output ()
normal_staff StaffConfig
config 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 " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" <<"
            , Text -> Text -> Text
ly_set (Text
name forall a. Semigroup a => a -> a -> a
<> Text
".instrumentName") (StaffConfig -> Text
Types.staff_long StaffConfig
config)
            , Text -> Text -> Text
ly_set (Text
name forall a. Semigroup a => a -> a -> a
<> Text
".shortInstrumentName") (StaffConfig -> Text
Types.staff_short StaffConfig
config)
            ]
        StaffConfig -> StateT OutputState Identity a
contents 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 forall a. Maybe a
Nothing (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 (forall a. a -> Maybe a
Just Text
"down") (forall a. a -> Maybe a
Just Text
"\\with { \\RemoveAllEmptyStaves }")forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ly -> Output ()
write_ly forall a b. (a -> b) -> a -> b
$
            Text -> Ly
Process.LyCode Text
"\\clef bass" 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 = forall a. ToLily a => a -> Text
Types.to_lily

(<+>) :: Text -> Text -> Text
Text
x <+> :: Text -> Text -> Text
<+> Text
y = Text
x forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$ Text
"\\new Staff " forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"= "<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
str) Maybe Text
maybe_name
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text
" "<>) Maybe Text
context Text -> Text -> Text
<+> Text
"{\n"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (StaffConfig -> Text
Types.staff_long StaffConfig
config)) 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)]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null (StaffConfig -> Text
Types.staff_short StaffConfig
config)) 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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets OutputState -> Int
output_bar
    [Int]
bars <- 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 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  "
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {a}. Eq a => [a] -> Bool
all_equal [Int]
bars) forall a b. (a -> b) -> a -> b
$
        -- Lilypond will also complain.
        Text -> Output ()
output forall a b. (a -> b) -> a -> b
$ Text
"% WARNING: voices have different numbers of bars: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [Int]
bars
    Int -> Output ()
set_bar (forall a. a -> Maybe a -> a
fromMaybe Int
start (forall a. [a] -> Maybe a
Lists.head [Int]
bars))
    where
    all_equal :: [a] -> Bool
all_equal [] = Bool
True
    all_equal (a
x:[a]
xs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets OutputState -> Int
output_bar
    Maybe UiFrame
stack <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets OutputState -> Maybe UiFrame
output_last_stack
    Text -> Output ()
output forall a b. (a -> b) -> a -> b
$ Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Types.to_lily Ly
ly forall a. Semigroup a => a -> a -> a
<> Text
" % " forall a. Semigroup a => a -> a -> a
<> Maybe UiFrame -> Text
show_stack Maybe UiFrame
stack forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
bar
        forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    Int -> Output ()
set_bar (Int
barforall a. Num a => a -> a -> a
+Int
1)
write_ly Ly
ly = do
    Text -> Output ()
output forall a b. (a -> b) -> a -> b
$ Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Types.to_lily Ly
ly
    case Ly
ly of
        Process.LyNote Note
note -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify 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
_ -> 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 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 forall a b. (a -> b) -> a -> b
$ (if Voice
voice forall a. Eq a => a -> a -> Bool
== Voice
Process.VoiceOne then Text
"" else Text
"\\new Voice ")
        forall a. Semigroup a => a -> a -> a
<> Text
"{ " forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Types.to_lily Voice
voice forall a. Semigroup a => a -> a -> a
<> Text
"\n  "
    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
"} "
    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 = forall a b. (a -> b) -> [a] -> [b]
map StaffGroup -> (StaffGroup, StaffConfig)
lookup_name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall {a}. Num a => StaffGroup -> (a, Int)
inst_key
    where
    lookup_name :: StaffGroup -> (StaffGroup, StaffConfig)
lookup_name StaffGroup
staff = case 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 =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a
1, Int
0) (a
0,) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex (StaffGroup -> Instrument
inst_of StaffGroup
staff)
            (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall s a. State s a -> s -> s
State.execState Output a
m (Builder -> Int -> Maybe UiFrame -> OutputState
OutputState forall a. Monoid a => a
mempty Int
1 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
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines

output :: Text -> Output ()
output :: Text -> Output ()
output Text
text = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \OutputState
state -> OutputState
state
    { output_text :: Builder
output_text = OutputState -> Builder
output_text OutputState
state 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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify 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
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", forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst)
        , (Text
"staves", 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, [Event])]
sections forall a b. (a -> b) -> a -> b
$ \(Text
title, [Event]
events) -> do
    let ([Event]
global, [Event]
normal) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition
            ((forall a. Eq a => a -> a -> Bool
==Instrument
Constants.ly_global) 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
    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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition
            ((forall a. Eq a => a -> a -> Bool
==Instrument
Constants.ly_global) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Instrument
Types.event_instrument) [Event]
events
    ([(Time, Text)]
movements, [Event]
global) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Stack => Text -> Either Msg a
warn forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        Text -> [Event] -> Either Text ([(Time, Text)], [Event])
partition_key Text
Constants.v_movement [Event]
global
    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) 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
        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 = forall a. a -> Maybe a -> a
fromMaybe Time
0 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Maybe a
Lists.maximum (forall a b. (a -> b) -> [a] -> [b]
map Event -> Time
Types.event_end [Event]
events)
    ([Meter]
meters, [Event]
global) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Stack => Text -> Either Msg a
warn forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition
            (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> [(FreeCodePosition, Text)]
Constants.environ_free_code forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
Types.event_environ)
            [Event]
global
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
remain) forall a b. (a -> b) -> a -> b
$
        forall a. Stack => Text -> Either Msg a
warn forall a b. (a -> b) -> a -> b
$ Text
"leftover ly-global events: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Event]
global
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Instrument, [[Event]])]
staff_groups 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 forall a b. (a -> b) -> a -> b
$
            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, forall key a. Ord key => (a -> key) -> [a] -> [[a]]
Lists.groupSort (forall {a}. Num a => Environ -> a
lookup_hand 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 = forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort Event -> Instrument
Types.event_instrument [Event]
events
    lookup_hand :: Environ -> a
lookup_hand Environ
environ = case forall a. Typecheck a => Text -> Environ -> Either LookupError a
Env.get_val Text
EnvKey.hand Environ
environ of
        Right (Text
val :: Text)
            | Text
val forall a. Eq a => a -> a -> Bool
== Text
"r" Bool -> Bool -> Bool
|| Text
val forall a. Eq a => a -> a -> Bool
== Text
"right" -> a
0
            | Text
val forall a. Eq a => a -> a -> Bool
== Text
"l" Bool -> Bool -> Bool
|| Text
val 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [[Event]]
staves) forall a b. (a -> b) -> a -> b
$ \(Integer
i, [Event]
es) ->
        forall {p :: * -> * -> *} {a} {c}.
(Bifunctor p, Show a) =>
a -> p Msg c -> p Msg c
annotate Integer
i 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
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> Msg -> Msg
Log.add_prefix (forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> 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 =
    forall k a. Ord k => (a -> k) -> [a] -> [a] -> [a]
Lists.mergeOn Event -> Time
Types.event_start
        (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 =
    forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> c
events_of)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {b}.
(Num a, IsString b) =>
[((a, b), Maybe (Time, b))] -> [Event] -> [(a, b, [Event])]
split (forall a. [a] -> [(a, Maybe a)]
Lists.zipNext ((Time
0, 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) 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((forall a. Ord a => a -> a -> Bool
>=Time
next) 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Time
pos, Text
meter) -> (Time
pos,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Meter
Meter.parse_meter Text
meter) [(Time, Text)]
meters
    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 forall a. Ord a => a -> a -> Bool
< Time
staff_end =
        forall a. Int -> a -> [a]
replicate Int
measures Meter
prev_meter forall a. [a] -> [a] -> [a]
++ Time -> Meter -> [(Time, Meter)] -> [Meter]
generate Time
next Meter
meter [(Time, Meter)]
meters
        where
        measures :: Int
measures = forall {a} {a}. (Integral a, Integral a) => a -> Meter -> a
measures_in (Time
posforall a. Num a => a -> a -> a
-Time
prev) Meter
prev_meter
        next :: Time
next = Time
prev forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
measures forall a. Num a => a -> a -> a
* Meter -> Time
Meter.measure_time Meter
prev_meter
    generate Time
prev Meter
meter [(Time, Meter)]
_ = forall a. Int -> a -> [a]
replicate (forall {a} {a}. (Integral a, Integral a) => a -> Meter -> a
measures_in (Time
staff_endforall 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 = forall a. Ord a => a -> a -> a
max a
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 b. (Integral a, Num b) => a -> b
fromIntegral a
dur forall a. Fractional a => a -> a -> a
/ 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 = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn 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 = forall {b}.
Typecheck b =>
[Event] -> Either Text ([(Time, b)], [Event])
go
    where
    go :: [Event] -> Either Text ([(Time, b)], [Event])
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    go (Event
e : [Event]
es) = case 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 -> forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Event
e:) 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) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Instrument
Constants.ly_global forall a. Semigroup a => a -> a -> a
<> Text
" event at "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Time
pos forall a. Semigroup a => a -> a -> a
<> Text
err
        Just (Right b
val) -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Time
pos, b
val) :) 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