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

-- | Utilities for calls to cooperate with the lilypond backend.
module Derive.Call.Ly where
import qualified Data.Map as Map

import qualified Util.Seq as Seq
import qualified Util.Texts as Texts
import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Post as Post
import qualified Derive.Call.Sub as Sub
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Flags as Flags
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Lilypond.Constants as Constants
import qualified Perform.Lilypond.Convert as Convert
import qualified Perform.Lilypond.Types as Types

import           Global
import           Types


-- * utils for ly calls

when_lilypond :: Derive.Deriver a -- ^ Run if this is a lilypond derive.
    -> Derive.Deriver a -- ^ Run if this is a normal derive.
    -> Derive.Deriver a
when_lilypond :: forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond Deriver a
lily = (Config -> Deriver a) -> Deriver a -> Deriver a
forall a. (Config -> Deriver a) -> Deriver a -> Deriver a
when_lilypond_config (Deriver a -> Config -> Deriver a
forall a b. a -> b -> a
const Deriver a
lily)

when_lilypond_config :: (Types.Config -> Derive.Deriver a)
    -- ^ Run if this is a lilypond derive.
    -> Derive.Deriver a -- ^ Run if this is a normal derive.
    -> Derive.Deriver a
when_lilypond_config :: forall a. (Config -> Deriver a) -> Deriver a -> Deriver a
when_lilypond_config Config -> Deriver a
lily Deriver a
not_lily =
    Deriver a -> (Config -> Deriver a) -> Maybe Config -> Deriver a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a
not_lily Config -> Deriver a
lily (Maybe Config -> Deriver a)
-> Deriver State Error (Maybe Config) -> Deriver a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver State Error (Maybe Config)
Derive.lookup_lilypond_config

-- | Only emit the deriver if I'm in lilypond mode.
only_lilypond :: Derive.NoteDeriver -> Derive.NoteDeriver
only_lilypond :: Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
only_lilypond Deriver State Error (Stream Event)
deriver = Deriver State Error Bool
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Deriver State Error Bool
Derive.is_lilypond_mode Deriver State Error (Stream Event)
deriver Deriver State Error (Stream Event)
forall a. Monoid a => a
mempty

-- | When in lilypond mode, generate a note with the given Code.
note_code :: Code -> Derive.PassedArgs d -> Derive.NoteDeriver
    -> Derive.NoteDeriver
note_code :: forall d.
Code
-> PassedArgs d
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
note_code Code
code PassedArgs d
args = Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond (Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a b. (a -> b) -> a -> b
$ Code
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
add_first Code
code (Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> Deriver State Error (Stream Event)
forall d. PassedArgs d -> Deriver State Error (Stream Event)
Call.placed_note PassedArgs d
args

-- ** transformer

-- | Add the Code to all the events.
add_all :: Code -> Derive.NoteDeriver -> Derive.NoteDeriver
add_all :: Code
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
add_all Code
code = (Stream Event -> Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Stream Event -> Stream Event)
 -> Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> (Stream Event -> Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a b. (a -> b) -> a -> b
$ (Event -> Event) -> Stream Event -> Stream Event
forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (Code -> Event -> Event
add_note_code Code
code)

-- | Add Code to the first event.
add_first :: Code -> Derive.NoteDeriver -> Derive.NoteDeriver
add_first :: Code
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
add_first Code
code Deriver State Error (Stream Event)
deriver =
    (Event -> Bool) -> (Event -> Event) -> Stream Event -> Stream Event
forall a. (a -> Bool) -> (a -> a) -> Stream a -> Stream a
Stream.first (Bool -> Bool
not (Bool -> Bool) -> (Event -> Bool) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Bool
is_code) (Code -> Event -> Event
add_note_code Code
code) (Stream Event -> Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error (Stream Event)
deriver

prepend :: Position Constants.CodePosition
prepend :: Position CodePosition
prepend = CodePosition -> Position CodePosition
forall pos. pos -> Position pos
Position (CodePosition -> Position CodePosition)
-> CodePosition -> Position CodePosition
forall a b. (a -> b) -> a -> b
$
    Attach -> Position -> Distribution -> CodePosition
Constants.CodePosition Attach
Constants.Chord Position
Constants.Prepend Distribution
Constants.First

append, note_append :: Constants.Distribution -> Position Constants.CodePosition
append :: Distribution -> Position CodePosition
append = CodePosition -> Position CodePosition
forall pos. pos -> Position pos
Position (CodePosition -> Position CodePosition)
-> (Distribution -> CodePosition)
-> Distribution
-> Position CodePosition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attach -> Position -> Distribution -> CodePosition
Constants.CodePosition Attach
Constants.Chord Position
Constants.Append
note_append :: Distribution -> Position CodePosition
note_append = CodePosition -> Position CodePosition
forall pos. pos -> Position pos
Position (CodePosition -> Position CodePosition)
-> (Distribution -> CodePosition)
-> Distribution
-> Position CodePosition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attach -> Position -> Distribution -> CodePosition
Constants.CodePosition Attach
Constants.Note Position
Constants.Append

-- ** note parent

-- | Replace a note parent with one that derives its sub-events as-is
-- and adds lilypond code to them.
notes_code :: Code -> Derive.PassedArgs d
    -> Derive.NoteDeriver -> Derive.NoteDeriver
notes_code :: forall d.
Code
-> PassedArgs d
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
notes_code Code
code = (Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> PassedArgs d
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall d.
(Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> PassedArgs d
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
notes_with (Code
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
add_all Code
code)

-- | Like 'notes_code', but only apply the code to the first event, not all of
-- them.
first_note_code :: Code -> Derive.PassedArgs d
    -> Derive.NoteDeriver -> Derive.NoteDeriver
first_note_code :: forall d.
Code
-> PassedArgs d
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
first_note_code Code
code PassedArgs d
args = Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond (Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a b. (a -> b) -> a -> b
$
    Code
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
add_first Code
code (Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a b. (a -> b) -> a -> b
$ PassedArgs d -> Deriver State Error (Stream Event)
forall d. PassedArgs d -> Deriver State Error (Stream Event)
Sub.derive_subs PassedArgs d
args

-- | This is like 'notes_code', but the first event in each track gets the
-- start code, and the last event in each track gets the end code.
notes_around :: Code -> Code -> Derive.PassedArgs d
    -> Derive.NoteDeriver -> Derive.NoteDeriver
notes_around :: forall d.
Code
-> Code
-> PassedArgs d
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
notes_around Code
start Code
end PassedArgs d
args =
    Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond (Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a b. (a -> b) -> a -> b
$ ([Event] -> Deriver State Error (Stream Event))
-> [[Event]] -> Deriver State Error (Stream Event)
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap [Event] -> Deriver State Error (Stream Event)
around ([[Event]] -> Deriver State Error (Stream Event))
-> Deriver State Error [[Event]]
-> Deriver State Error (Stream Event)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs d -> Deriver State Error [[Event]]
forall d. PassedArgs d -> Deriver State Error [[Event]]
Sub.sub_events PassedArgs d
args
    where
    around :: [Event] -> Deriver State Error (Stream Event)
around [Event]
notes = (Event -> Event)
-> (Event -> Event) -> Stream Event -> Stream Event
first_last
        (Code -> Event -> Event
add_note_code Code
start) (Code -> Event -> Event
add_note_code Code
end) (Stream Event -> Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event] -> Deriver State Error (Stream Event)
Sub.derive [Event]
notes

-- | Like 'notes_around', but for use when you already know you're in lilypond
-- mode.
notes_around_ly :: Code -> Code -> Derive.PassedArgs d -> Derive.NoteDeriver
notes_around_ly :: forall d.
Code -> Code -> PassedArgs d -> Deriver State Error (Stream Event)
notes_around_ly Code
start Code
end = ([Event] -> Deriver State Error (Stream Event))
-> [[Event]] -> Deriver State Error (Stream Event)
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap [Event] -> Deriver State Error (Stream Event)
around ([[Event]] -> Deriver State Error (Stream Event))
-> (PassedArgs d -> Deriver State Error [[Event]])
-> PassedArgs d
-> Deriver State Error (Stream Event)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< PassedArgs d -> Deriver State Error [[Event]]
forall d. PassedArgs d -> Deriver State Error [[Event]]
Sub.sub_events
    where
    around :: [Event] -> Deriver State Error (Stream Event)
around [Event]
notes = (Event -> Event)
-> (Event -> Event) -> Stream Event -> Stream Event
first_last
        (Code -> Event -> Event
add_note_code Code
start) (Code -> Event -> Event
add_note_code Code
end) (Stream Event -> Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Event] -> Deriver State Error (Stream Event)
Sub.derive [Event]
notes

-- | Like 'notes_around', but when I'm not in lilypond mode just derive the
-- sub events unchanged.
code_around :: FreeCode -> FreeCode -> Derive.PassedArgs d -> Derive.NoteDeriver
code_around :: forall d.
FreeCode
-> FreeCode -> PassedArgs d -> Deriver State Error (Stream Event)
code_around FreeCode
start FreeCode
end PassedArgs d
args = Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond
    (ScoreTime -> FreeCode -> Deriver State Error (Stream Event)
code0 (PassedArgs d -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs d
args) FreeCode
start
        Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. Semigroup a => a -> a -> a
<> PassedArgs d -> Deriver State Error (Stream Event)
forall d. PassedArgs d -> Deriver State Error (Stream Event)
Sub.derive_subs PassedArgs d
args Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. Semigroup a => a -> a -> a
<> ScoreTime -> FreeCode -> Deriver State Error (Stream Event)
code0 (PassedArgs d -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs d
args) FreeCode
end)
    (PassedArgs d -> Deriver State Error (Stream Event)
forall d. PassedArgs d -> Deriver State Error (Stream Event)
Sub.derive_subs PassedArgs d
args)

-- | Transform and evaluate the sub events.
notes_with :: (Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Derive.PassedArgs d
    -> Derive.NoteDeriver -> Derive.NoteDeriver
notes_with :: forall d.
(Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> PassedArgs d
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
notes_with Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
f PassedArgs d
args = Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond (Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a b. (a -> b) -> a -> b
$
    [Event] -> Deriver State Error (Stream Event)
Sub.derive ([Event] -> Deriver State Error (Stream Event))
-> ([[Event]] -> [Event])
-> [[Event]]
-> Deriver State Error (Stream Event)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Event) -> [Event] -> [Event]
forall a b. (a -> b) -> [a] -> [b]
map ((Deriver State Error (Stream Event)
 -> Deriver State Error (Stream Event))
-> Event -> Event
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
f) ([Event] -> [Event])
-> ([[Event]] -> [Event]) -> [[Event]] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Event]] -> [Event]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Event]] -> Deriver State Error (Stream Event))
-> Deriver State Error [[Event]]
-> Deriver State Error (Stream Event)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs d -> Deriver State Error [[Event]]
forall d. PassedArgs d -> Deriver State Error [[Event]]
Sub.sub_events PassedArgs d
args

-- | Apply a function to the first and last Events, which are not 'is_code0'.
first_last :: (Score.Event -> Score.Event) -> (Score.Event -> Score.Event)
    -> Stream.Stream Score.Event -> Stream.Stream Score.Event
first_last :: (Event -> Event)
-> (Event -> Event) -> Stream Event -> Stream Event
first_last = (Event -> Bool)
-> (Event -> Event)
-> (Event -> Event)
-> Stream Event
-> Stream Event
forall a.
(a -> Bool) -> (a -> a) -> (a -> a) -> Stream a -> Stream a
Stream.first_last (Bool -> Bool
not (Bool -> Bool) -> (Event -> Bool) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Bool
is_code)

-- ** code

-- | Either prepend or append some code to a lilypond note.
type Code = (Position Constants.CodePosition, Ly)
type FreeCode = (Position Constants.FreeCodePosition, Ly)
data Position pos = Position !pos
    -- | Create a note with the given env value set to the Ly code.  This is
    -- for directives to the lilypond performer, not to lilypond itself.
    -- E.g. 'Constants.v_subdivision'.
    | SetEnviron !Env.Key
    deriving (Position pos -> Position pos -> Bool
(Position pos -> Position pos -> Bool)
-> (Position pos -> Position pos -> Bool) -> Eq (Position pos)
forall pos. Eq pos => Position pos -> Position pos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position pos -> Position pos -> Bool
$c/= :: forall pos. Eq pos => Position pos -> Position pos -> Bool
== :: Position pos -> Position pos -> Bool
$c== :: forall pos. Eq pos => Position pos -> Position pos -> Bool
Eq, Int -> Position pos -> ShowS
[Position pos] -> ShowS
Position pos -> String
(Int -> Position pos -> ShowS)
-> (Position pos -> String)
-> ([Position pos] -> ShowS)
-> Show (Position pos)
forall pos. Show pos => Int -> Position pos -> ShowS
forall pos. Show pos => [Position pos] -> ShowS
forall pos. Show pos => Position pos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position pos] -> ShowS
$cshowList :: forall pos. Show pos => [Position pos] -> ShowS
show :: Position pos -> String
$cshow :: forall pos. Show pos => Position pos -> String
showsPrec :: Int -> Position pos -> ShowS
$cshowsPrec :: forall pos. Show pos => Int -> Position pos -> ShowS
Show)

instance Pretty pos => Pretty (Position pos) where
    pretty :: Position pos -> Text
pretty (SetEnviron Text
key) = Text
"SetEnviron " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Pretty a => a -> Text
pretty Text
key
    pretty (Position pos
p) = pos -> Text
forall a. Pretty a => a -> Text
pretty pos
p

instance Typecheck.Typecheck (Position Constants.CodePosition) where
    from_val :: Val -> Checked (Position CodePosition)
from_val = Map Text (Position CodePosition)
-> Val -> Checked (Position CodePosition)
forall a. Map Text a -> Val -> Checked a
Typecheck.from_val_symbol Map Text (Position CodePosition)
code_position_names
    to_type :: Proxy (Position CodePosition) -> Type
to_type Proxy (Position CodePosition)
Proxy = [Text] -> Type
forall a. ShowVal a => [a] -> Type
Typecheck.to_type_symbol (Map Text (Position CodePosition) -> [Text]
forall k a. Map k a -> [k]
Map.keys Map Text (Position CodePosition)
code_position_names)

code_position_names :: Map Text (Position Constants.CodePosition)
code_position_names :: Map Text (Position CodePosition)
code_position_names =
    [(Text, Position CodePosition)] -> Map Text (Position CodePosition)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Position CodePosition)]
 -> Map Text (Position CodePosition))
-> [(Text, Position CodePosition)]
-> Map Text (Position CodePosition)
forall a b. (a -> b) -> a -> b
$ (Position CodePosition -> Text)
-> [Position CodePosition] -> [(Text, Position CodePosition)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Seq.key_on Position CodePosition -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val ([Position CodePosition] -> [(Text, Position CodePosition)])
-> [Position CodePosition] -> [(Text, Position CodePosition)]
forall a b. (a -> b) -> a -> b
$
        (CodePosition -> Position CodePosition)
-> [CodePosition] -> [Position CodePosition]
forall a b. (a -> b) -> [a] -> [b]
map CodePosition -> Position CodePosition
forall pos. pos -> Position pos
Position [CodePosition]
Constants.all_positions

instance Typecheck.ToVal (Position Constants.CodePosition) where
    to_val :: Position CodePosition -> Val
to_val = Str -> Val
DeriveT.VStr (Str -> Val)
-> (Position CodePosition -> Str) -> Position CodePosition -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str (Text -> Str)
-> (Position CodePosition -> Text) -> Position CodePosition -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position CodePosition -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val

instance ShowVal.ShowVal (Position Constants.CodePosition) where
    show_val :: Position CodePosition -> Text
show_val = Text -> Text -> Text
Texts.dropPrefix Text
"ly-" (Text -> Text)
-> (Position CodePosition -> Text) -> Position CodePosition -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position CodePosition -> Text
key_of
        where
        key_of :: Position CodePosition -> Text
key_of (SetEnviron Text
k) = Text
k
        key_of (Position CodePosition
pos) = CodePosition -> Text
Constants.position_key CodePosition
pos

-- | Fragment of Lilypond code.
type Ly = Text

-- | A lilypond \"note\", which is just a chunk of text.
type Note = Ly

-- | Like 'code', but for 0 duration code fragments, and can either put them
-- before or after notes that occur at the same time.
code0 :: ScoreTime -> FreeCode -> Derive.NoteDeriver
code0 :: ScoreTime -> FreeCode -> Deriver State Error (Stream Event)
code0 ScoreTime
start FreeCode
code = do
    RealTime
rstart <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    (Event -> Event) -> Stream Event -> Stream Event
forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (RealTime -> FreeCode -> Event -> Event
code0_event RealTime
rstart FreeCode
code) (Stream Event -> Stream Event)
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScoreTime
-> ScoreTime
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
forall a. ScoreTime -> ScoreTime -> Deriver a -> Deriver a
Derive.place ScoreTime
start ScoreTime
0 Deriver State Error (Stream Event)
Call.note

-- | Make a code0 event directly.  Inherit instrument and environ from an
-- existing note.  Otherwise, the lilypond backend doesn't know how to group
-- the code event.
--
-- TODO aka free_code, maybe rename it?
code0_event :: RealTime -> FreeCode -> Score.Event -> Score.Event
code0_event :: RealTime -> FreeCode -> Event -> Event
code0_event RealTime
start (Position FreeCodePosition
pos, Text
code) =
    -- I don't use Score.move_event because I don't care about signals.
    (\Event
e -> Event
e { event_start :: RealTime
Score.event_start = RealTime
start })
    (Event -> Event) -> (Event -> Event) -> Event -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flags -> Event -> Event
Score.add_flags Flags
Flags.ly_code
    (Event -> Event) -> (Event -> Event) -> Event -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Environ -> Environ) -> Event -> Event
Score.modify_environ Environ -> Environ
modify
    where
    modify :: Environ -> Environ
modify = case Position FreeCodePosition
pos of
        SetEnviron Text
key -> Text -> Text -> Environ -> Environ
forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
key Text
code
        Position FreeCodePosition
pos -> FreeCodePosition -> Text -> Environ -> Environ
Constants.with_free_code FreeCodePosition
pos Text
code

-- | Derive with the 'Constants.ly_global' instrument.
global :: Derive.Deriver a -> Derive.Deriver a
global :: forall a. Deriver a -> Deriver a
global = Text -> Instrument -> Deriver a -> Deriver a
forall val a. ToVal val => Text -> val -> Deriver a -> Deriver a
Derive.with_val_raw Text
EnvKey.instrument Instrument
Constants.ly_global

-- | Test if an event is a 0 duration lilypond code event.
is_code0 :: Score.Event -> Bool
is_code0 :: Event -> Bool
is_code0 Event
event = Event -> RealTime
Score.event_duration Event
event RealTime -> RealTime -> Bool
forall a. Eq a => a -> a -> Bool
== RealTime
0
    Bool -> Bool -> Bool
&& Flags -> Flags -> Bool
Flags.has (Event -> Flags
Score.event_flags Event
event) Flags
Flags.ly_code

is_code :: Score.Event -> Bool
is_code :: Event -> Bool
is_code Event
event = Flags -> Flags -> Bool
Flags.has (Event -> Flags
Score.event_flags Event
event) Flags
Flags.ly_code

-- *** low level

-- | Add lilypond code to a note.  Skip 'is_code' events, since those aren't
-- actual notes.
add_note_code :: Code -> Score.Event -> Score.Event
add_note_code :: Code -> Event -> Event
add_note_code (Position CodePosition
pos, Text
code) Event
event
    | Event -> Bool
is_code Event
event = Event
event
    | Bool
otherwise = ((Environ -> Environ) -> Event -> Event
`Score.modify_environ` Event
event) ((Environ -> Environ) -> Event) -> (Environ -> Environ) -> Event
forall a b. (a -> b) -> a -> b
$ case Position CodePosition
pos of
        SetEnviron Text
key -> Text -> Text -> Environ -> Environ
forall a. ToVal a => Text -> a -> Environ -> Environ
Env.insert_val Text
key Text
code
        Position CodePosition
pos -> CodePosition -> Text -> Environ -> Environ
Constants.with_code CodePosition
pos Text
code

-- ** convert

-- | Round the RealTime to the nearest NoteDuration.
note_duration :: Types.Config -> RealTime -> Types.NoteDuration
note_duration :: Config -> RealTime -> NoteDuration
note_duration Config
config = Time -> NoteDuration
Types.time_to_note_dur (Time -> NoteDuration)
-> (RealTime -> Time) -> RealTime -> NoteDuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> RealTime -> Time
to_time Config
config

-- | Like 'note_duration', but only succeeds if the RealTime is exactly
-- a NoteDuration.
is_note_duration :: Types.Config -> RealTime -> Maybe Types.NoteDuration
is_note_duration :: Config -> RealTime -> Maybe NoteDuration
is_note_duration Config
config = Time -> Maybe NoteDuration
Types.is_note_dur (Time -> Maybe NoteDuration)
-> (RealTime -> Time) -> RealTime -> Maybe NoteDuration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> RealTime -> Time
to_time Config
config

is_duration :: Types.Config -> RealTime -> Maybe Types.Duration
is_duration :: Config -> RealTime -> Maybe Duration
is_duration Config
config RealTime
t = case Config -> RealTime -> Maybe NoteDuration
is_note_duration Config
config RealTime
t of
    Just (Types.NoteDuration Duration
dur Bool
False) -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
dur
    Maybe NoteDuration
_ -> Maybe Duration
forall a. Maybe a
Nothing

note_pitch :: Derive.NoteDeriver -> Derive.Deriver Note
note_pitch :: Deriver State Error (Stream Event) -> Deriver Text
note_pitch Deriver State Error (Stream Event)
deriver = do
    Stream Event
events <- Deriver State Error (Stream Event)
deriver
    Event
event <- Text -> Maybe Event -> Deriver Event
forall {a}. Text -> Maybe a -> Deriver a
require Text
"had no event" (Maybe Event -> Deriver Event) -> Maybe Event -> Deriver Event
forall a b. (a -> b) -> a -> b
$ [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head (Stream Event -> [Event]
forall a. Stream a -> [a]
Stream.events_of Stream Event
events)
    Environ
env <- Deriver Environ
Derive.get_environ
    Environ -> Transposed -> Deriver Text
pitch_to_lily Environ
env
        (Transposed -> Deriver Text)
-> Deriver State Error Transposed -> Deriver Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe Transposed -> Deriver State Error Transposed
forall {a}. Text -> Maybe a -> Deriver a
require Text
"note had no pitch" (Event -> Maybe Transposed
Score.initial_pitch Event
event)
    -- Wow, there are a lot of ways to fail.
    where
    require :: Text -> Maybe a -> Deriver a
require = Text -> Maybe a -> Deriver a
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text -> Maybe a -> Deriver a)
-> (Text -> Text) -> Text -> Maybe a -> Deriver a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
prefix <>)
    prefix :: Text
prefix = Text
"Ly.note_pitch: "

pitch_to_lily :: Env.Environ -> PSignal.Transposed -> Derive.Deriver Note
pitch_to_lily :: Environ -> Transposed -> Deriver Text
pitch_to_lily Environ
env = (Pitch -> Text) -> Deriver State Error Pitch -> Deriver Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Pitch -> Text
forall a. ToLily a => a -> Text
Types.to_lily
    (Deriver State Error Pitch -> Deriver Text)
-> (Transposed -> Deriver State Error Pitch)
-> Transposed
-> Deriver Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Either Text Pitch -> Deriver State Error Pitch
forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right (Text
"Ly.pitch_to_lily: "<>) (Either Text Pitch -> Deriver State Error Pitch)
-> (Transposed -> Either Text Pitch)
-> Transposed
-> Deriver State Error Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Transposed -> Either Text Pitch
Convert.pitch_to_lily Environ
env

to_time :: Types.Config -> RealTime -> Types.Time
to_time :: Config -> RealTime -> Time
to_time = RealTime -> RealTime -> Time
Types.real_to_time (RealTime -> RealTime -> Time)
-> (Config -> RealTime) -> Config -> RealTime -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> RealTime
Types.config_quarter_duration