-- 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.Lists as Lists
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 = forall a. (Config -> Deriver a) -> Deriver a -> Deriver a
when_lilypond_config (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 =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Deriver a
not_lily Config -> Deriver a
lily forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver (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 = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Deriver Bool
Derive.is_lilypond_mode Deriver State Error (Stream Event)
deriver 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 = forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond forall a b. (a -> b) -> a -> b
$ Code
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
add_first Code
code forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ 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 =
    forall a. (a -> Bool) -> (a -> a) -> Stream a -> Stream a
Stream.first (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Bool
is_code) (Code -> Event -> Event
add_note_code Code
code) 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 = forall pos. pos -> Position pos
Position 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 = forall pos. pos -> Position pos
Position 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 = forall pos. pos -> Position pos
Position 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 = 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 = forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond forall a b. (a -> b) -> a -> b
$
    Code
-> Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
add_first Code
code forall a b. (a -> b) -> a -> b
$ 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 =
    forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond forall a b. (a -> b) -> a -> b
$ forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap [Event] -> Deriver State Error (Stream Event)
around forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d. PassedArgs d -> Deriver [[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) 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 = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap [Event] -> Deriver State Error (Stream Event)
around forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall d. PassedArgs d -> Deriver [[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) 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 = forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond
    (ScoreTime -> FreeCode -> Deriver State Error (Stream Event)
code0 (forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs d
args) FreeCode
start
        forall a. Semigroup a => a -> a -> a
<> forall d. PassedArgs d -> Deriver State Error (Stream Event)
Sub.derive_subs PassedArgs d
args forall a. Semigroup a => a -> a -> a
<> ScoreTime -> FreeCode -> Deriver State Error (Stream Event)
code0 (forall a. PassedArgs a -> ScoreTime
Args.end PassedArgs d
args) FreeCode
end)
    (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 = forall a. Deriver a -> Deriver a -> Deriver a
when_lilypond forall a b. (a -> b) -> a -> b
$
    [Event] -> Deriver State Error (Stream Event)
Sub.derive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Deriver State Error (Stream Event)
-> Deriver State Error (Stream Event)
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall d. PassedArgs d -> Deriver [[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 = forall a.
(a -> Bool) -> (a -> a) -> (a -> a) -> Stream a -> Stream a
Stream.first_last (Bool -> Bool
not 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
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
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 " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
key
    pretty (Position pos
p) = forall a. Pretty a => a -> Text
pretty pos
p

instance Typecheck.Typecheck (Position Constants.CodePosition) where
    from_val :: Val -> Checked (Position CodePosition)
from_val = 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 = forall a. ShowVal a => [a] -> Type
Typecheck.to_type_symbol (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 =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn forall a. ShowVal a => a -> Text
ShowVal.show_val forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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-" 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 <- forall a. Time a => a -> Deriver RealTime
Derive.real ScoreTime
start
    forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ (RealTime -> FreeCode -> Event -> Event
code0_event RealTime
rstart FreeCode
code) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 })
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flags -> Event -> Event
Score.add_flags Flags
Flags.ly_code
    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 -> 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 = 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 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) forall a b. (a -> b) -> a -> b
$ case Position CodePosition
pos of
        SetEnviron Text
key -> 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 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 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) -> forall a. a -> Maybe a
Just Duration
dur
    Maybe NoteDuration
_ -> 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 <- forall {a}. Text -> Maybe a -> Deriver a
require Text
"had no event" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head (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
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToLily a => a -> Text
Types.to_lily
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right (Text
"Ly.pitch_to_lily: "<>) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> RealTime
Types.config_quarter_duration