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

-- | Calls that create code events for the lilypond backend.
module Derive.C.Lily (library) where
import qualified Util.Doc as Doc
import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.Ly as Ly
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.Score as Score
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

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

import           Global
import           Types


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall d.
(ToLibrary (Generator d), ToLibrary (Transformer d)) =>
[(Symbol, Calls d)] -> Library
Library.both
        [ (Symbol
"8va", Calls Note
c_8va)
        , (Symbol
"clef", Calls Note
c_clef)
        , (Symbol
"dyn", Calls Note
c_dyn)
        , (Symbol
"ly-!", CallName -> Doc -> Code -> Calls Note
attach0 CallName
"ly-reminder-accidental"
            Doc
"Force this note to display an accidental."
            (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_append_pitch, Text
"!"))
        , (Symbol
"ly-?", CallName -> Doc -> Code -> Calls Note
attach0 CallName
"ly-cautionary-accidental"
            Doc
"Force this note to display a cautionary accidental."
            (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_append_pitch, Text
"?"))

        , (Symbol
"ly-(", CallName -> Doc -> Code -> Calls Note
attach0 CallName
"ly-begin-slur"
            Doc
"Separately mark a lilypond slur, when `(` isn't cutting it."
            (Distribution -> Position CodePosition
Ly.append Distribution
Constants.First, Text
"("))
        , (Symbol
"ly-)", CallName -> Doc -> Code -> Calls Note
attach0 CallName
"ly-end-slur"
            Doc
"Separately mark a lilypond slur, when `(` isn't cutting it."
            (Distribution -> Position CodePosition
Ly.append Distribution
Constants.Last, Text
")"))
        , (Symbol
"ly-[", CallName -> Doc -> Code -> Calls Note
attach0 CallName
"ly-begin-beam"
            Doc
"Begin a beam. Override lilypond's automatic beaming."
            (Distribution -> Position CodePosition
Ly.append Distribution
Constants.First, Text
"["))
        , (Symbol
"ly-]", CallName -> Doc -> Code -> Calls Note
attach0 CallName
"ly-end-beam"
            Doc
"End a beam. Override lilypond's automatic beaming."
            (Distribution -> Position CodePosition
Ly.append Distribution
Constants.First, Text
"]"))
            -- Constants.First because it's unlikely the beam should go over
            -- a barline.
        , (Symbol
"ly-<", Text -> Calls Note
c_hairpin Text
"\\<")
        , (Symbol
"ly->", Text -> Calls Note
c_hairpin Text
"\\>")
        , (Symbol
"ly-<>", CallName -> Doc -> FreeCode -> Calls Note
emit0 CallName
"ly-crescendo-diminuendo"
            Doc
"Crescendo followed by diminuendo, on one note."
            (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend, Text
"\\espressivo"))
        , (Symbol
"ly-^~", Text -> Calls Note
c_tie_direction Text
"^")
        , (Symbol
"ly-_~", Text -> Calls Note
c_tie_direction Text
"_")
        , (Symbol
"ly-key", Calls Note
c_ly_key)
        , (Symbol
"ly-post", Calls Note
c_ly_post)
        , (Symbol
"ly-attach", Calls Note
c_ly_attach)
        , (Symbol
"ly-emit", Calls Note
c_ly_emit)
        , (Symbol
"ly-pre", Calls Note
c_ly_pre)
        , (Symbol
"ly-span", Calls Note
c_ly_span)
        , (Symbol
"ly-sus", Calls Note
c_ly_sustain)
        , (Symbol
"ly-tr~", Calls Note
c_ly_tr_span)
        , (Symbol
"ly^", Text -> Calls Note
c_ly_text Text
"^")
        , (Symbol
"ly_", Text -> Calls Note
c_ly_text Text
"_")
        , (Symbol
"ly-", Calls Note
c_ly_articulation)
        , (Symbol
"tempo", Calls Note
c_tempo)
        , (Symbol
"meter", Calls Note
c_meter)
        , (Symbol
"subdivision", Calls Note
c_subdivision)
        , (Symbol
"movement", Calls Note
c_movement)
        , (Symbol
"xstaff", Calls Note
c_xstaff)
        , (Symbol
"xstaff-a", Calls Note
c_xstaff_around)
        ]
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators
        [ (Symbol
"if-ly", Generator Note
c_if_ly)
        ]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"ly-global", Transformer Note
c_ly_global)
        , (Symbol
"ly-track", Transformer Note
c_ly_track)
        , (Symbol
"not-ly-track", Transformer Note
c_not_ly_track)
        , (Symbol
"unless-ly", Transformer Note
c_unless_ly)
        , (Symbol
"when-ly", Transformer Note
c_when_ly)
        ]
    ]

c_when_ly :: Derive.Transformer Derive.Note
c_when_ly :: Transformer Note
c_when_ly = forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
"when-ly"
    Doc
"With no arguments, evaluate the deriver only when in lilypond mode.\
    \ Unlike `ly-track`, this doesn't evaluate subtracks, so you can use it to\
    \ emit an entirely different set of tracks.\n\
    \ With arguments, evaluate them as a transformer and apply it only\
    \ when in lilypond mode.  Otherwise, the deriver is unchanged."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"Call expression.") (Bool
-> [Val]
-> PassedArgs Note
-> Deriver (Stream Note)
-> Deriver (Stream Note)
when_ly Bool
False)

c_unless_ly :: Derive.Transformer Derive.Note
c_unless_ly :: Transformer Note
c_unless_ly = forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
"unless-ly"
    Doc
"The inverse of when-ly, evaluate the deriver or apply the args only when\
    \ not in lilypond mode."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"Call expression.") (Bool
-> [Val]
-> PassedArgs Note
-> Deriver (Stream Note)
-> Deriver (Stream Note)
when_ly Bool
True)

when_ly :: Bool -> [DeriveT.Val] -> Derive.PassedArgs Score.Event
    -> Derive.NoteDeriver -> Derive.NoteDeriver
when_ly :: Bool
-> [Val]
-> PassedArgs Note
-> Deriver (Stream Note)
-> Deriver (Stream Note)
when_ly Bool
inverted [Val]
vals PassedArgs Note
args Deriver (Stream Note)
deriver = case [Val]
vals of
    [] -> forall {a}. Deriver a -> Deriver a -> Deriver a
when_lily Deriver (Stream Note)
deriver forall a. Monoid a => a
mempty
    Val
call : [Val]
vals -> forall {a}. Deriver a -> Deriver a -> Deriver a
when_lily (forall {d}.
Callable (Transformer d) =>
PassedArgs d
-> Symbol -> [Val] -> Deriver (Stream d) -> Deriver (Stream d)
apply PassedArgs Note
args (Val -> Symbol
to_sym Val
call) [Val]
vals Deriver (Stream Note)
deriver) Deriver (Stream Note)
deriver
    where
    to_sym :: Val -> Symbol
to_sym = Text -> Symbol
Expr.Symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Text
DeriveT.show_call_val
    when_lily :: Deriver a -> Deriver a -> Deriver a
when_lily = if Bool
inverted then forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond else forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond
    apply :: PassedArgs d
-> Symbol -> [Val] -> Deriver (Stream d) -> Deriver (Stream d)
apply PassedArgs d
args Symbol
sym [Val]
vals Deriver (Stream d)
deriver = do
        Transformer d
call <- forall d.
Callable (Transformer d) =>
Symbol -> Deriver (Transformer d)
Eval.get_transformer Symbol
sym
        forall d.
Context d
-> Transformer d
-> [Val]
-> Deriver (Stream d)
-> Deriver (Stream d)
Eval.apply_transformer (forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs d
args) Transformer d
call [Val]
vals Deriver (Stream d)
deriver

c_ly_global :: Derive.Transformer Derive.Note
c_ly_global :: Transformer Note
c_ly_global = forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
"ly-global"
    (Doc
"Evaluate the deriver only when in lilypond mode, like `when-ly`, but\
    \ also set the " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Instrument
Constants.ly_global forall a. Semigroup a => a -> a -> a
<> Doc
" instrument."
    ) forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_ Deriver (Stream Note)
deriver ->
        forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall a. Deriver a -> Deriver a
Ly.global Deriver (Stream Note)
deriver) forall a. Monoid a => a
mempty

c_ly_track :: Derive.Transformer Derive.Note
c_ly_track :: Transformer Note
c_ly_track = forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
"ly-track"
    Doc
"Evaluate the deriver only when in lilypond mode, otherwise ignore this\
    \ track but evaluate its subtracks. Apply this to a track\
    \ to omit lilypond-only articulations, or to apply different articulations\
    \ to lilypond and non-lilypond output. Only use it in the track title!"
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args Deriver (Stream Note)
deriver ->
        forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond Deriver (Stream Note)
deriver forall a b. (a -> b) -> a -> b
$ forall d. PassedArgs d -> Deriver (Stream Note)
Sub.derive_subs PassedArgs Note
args

c_not_ly_track :: Derive.Transformer Derive.Note
c_not_ly_track :: Transformer Note
c_not_ly_track = forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
"not-ly-track"
    Doc
"The inverse of `ly-track`, evaluate the track only when not in lilypond\
    \ mode. Only use it in the track title!"
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args Deriver (Stream Note)
deriver -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond Deriver (Stream Note)
deriver forall a b. (a -> b) -> a -> b
$
        forall d. PassedArgs d -> Deriver (Stream Note)
Sub.derive_subs PassedArgs Note
args

c_if_ly :: Derive.Generator Derive.Note
c_if_ly :: Generator Note
c_if_ly = forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
"if-ly"
    Doc
"Conditional for lilypond." forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"is-ly" Doc
"Evaluated in lilypond mode."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"not-ly" Doc
"Evaluated when not in lilypond mode."
    ) forall a b. (a -> b) -> a -> b
$ \(Quoted
is_ly, Quoted
not_ly) PassedArgs Note
args -> forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond
        (forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall val. PassedArgs val -> Context val
Args.context PassedArgs Note
args) Quoted
is_ly)
        (forall d.
CallableExpr d =>
Context d -> Quoted -> Deriver (Stream d)
Eval.eval_quoted (forall val. PassedArgs val -> Context val
Args.context PassedArgs Note
args) Quoted
not_ly)

c_8va :: Library.Calls Derive.Note
c_8va :: Calls Note
c_8va = forall a.
CallName
-> Doc -> Parser a -> (a -> (FreeCode, FreeCode)) -> Calls Note
emit_pair CallName
"ottava" Doc
"Emit lilypond ottava mark.\
    \ If it has duration, end with `8va 0`."
    (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"octave" (Double
0 :: Double)
        Doc
"Transpose this many octaves up or down."
    ) forall a b. (a -> b) -> a -> b
$
    \Int
oct -> (Int -> FreeCode
ottava Int
oct, Int -> FreeCode
ottava Int
0)
    where
    ottava :: Int -> FreeCode
ottava Int
n =
        (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, Text
"\\ottava #" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Int
n :: Int))

c_xstaff :: Library.Calls Derive.Note
c_xstaff :: Calls Note
c_xstaff = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"xstaff"
    Doc
"Emit lilypond to put the notes on a different staff."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"staff" Doc
"Switch to this staff.") forall a b. (a -> b) -> a -> b
$ \UpDown
staff ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, UpDown -> Text
change UpDown
staff)
    where change :: UpDown -> Text
change UpDown
staff = Text
"\\change Staff = " forall a. Semigroup a => a -> a -> a
<> Text -> Text
lily_str (UpDown -> Text
to_lily UpDown
staff)

c_xstaff_around :: Library.Calls Derive.Note
c_xstaff_around :: Calls Note
c_xstaff_around = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver (Text, Text)) -> Calls Note
attach_wrap_notes CallName
"xstaff-around"
    Doc
"Emit lilypond to put the notes on a different staff."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"staff" Doc
"Switch to this staff.") forall a b. (a -> b) -> a -> b
$ \UpDown
staff -> forall (m :: * -> *) a. Monad m => a -> m a
return
        (UpDown -> Text
change UpDown
staff, UpDown -> Text
change (UpDown -> UpDown
other UpDown
staff))
    where
    change :: UpDown -> Text
change UpDown
staff = Text
"\\change Staff = " forall a. Semigroup a => a -> a -> a
<> Text -> Text
lily_str (UpDown -> Text
to_lily UpDown
staff)
    other :: UpDown -> UpDown
other UpDown
Call.Up = UpDown
Call.Down
    other UpDown
Call.Down = UpDown
Call.Up

to_lily :: Call.UpDown -> Text
to_lily :: UpDown -> Text
to_lily UpDown
Call.Up = Text
"up"
to_lily UpDown
Call.Down = Text
"down"

c_dyn :: Library.Calls Derive.Note
c_dyn :: Calls Note
c_dyn = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"dyn"
    Doc
"Emit a lilypond dynamic. If there are notes below, they are derived\
    \ unchanged."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"dynamic" Doc
"Should be `p`, `ff`, etc.")
    (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"\\"<>))

c_clef :: Library.Calls Derive.Note
c_clef :: Calls Note
c_clef = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"clef" Doc
"Emit lilypond clef change."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"clef" Doc
"Should be `bass`, `treble`, etc.")
    (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"\\clef "<>))

c_tempo :: Library.Calls Derive.Note
c_tempo :: Calls Note
c_tempo = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"tempo" Doc
"Emit tempo marking."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"text" Doc
"4 = 120, etc.")
    (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"\\tempo "<>))

c_meter :: Library.Calls Derive.Note
c_meter :: Calls Note
c_meter = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_global CallName
"meter"
    Doc
"Emit lilypond meter change. It will be interpreted as global no matter\
    \ where it is. Simultaneous different meters aren't supported yet, but\
    \ `subdivision` supports simultaneous different spellings."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"meter" Doc
"Should be `4/4`, `6/8`, etc. An ambiguous meter like\
        \ `6/8` will default to 3+3, but you can explicitly set the\
        \ subdivision, e.g. `2+2+2/8`.") forall a b. (a -> b) -> a -> b
$
    \Text
meter -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_meter, Text
meter)

c_subdivision :: Library.Calls Derive.Note
c_subdivision :: Calls Note
c_subdivision = forall a.
CallName
-> Doc -> Parser a -> (a -> (FreeCode, FreeCode)) -> Calls Note
emit_pair CallName
"subdivision"
    Doc
"Emit a subdivision change. This is the same format as `meter`, but it\
    \ affects the subdivision for this instrument only, instead of setting\
    \ the global meter. This is useful when instruments are playing\
    \ cross-rhythms and should beam accordingly."
    (forall a. a -> Maybe a -> a
fromMaybe Text
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"meter" Doc
"Same as `meter` call.") forall a b. (a -> b) -> a -> b
$
    \Text
meter ->
        ( (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_subdivision, Text
meter)
        , (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_subdivision, Text
"")
        )

c_movement :: Library.Calls Derive.Note
c_movement :: Calls Note
c_movement = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_global CallName
"movement"
    Doc
"Start a new movement with the given title."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"title" Doc
"Title of this movement.") forall a b. (a -> b) -> a -> b
$
    \Text
title -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_movement, Text
title)

c_tie_direction :: Ly.Ly -> Library.Calls Derive.Note
c_tie_direction :: Text -> Calls Note
c_tie_direction Text
code = CallName -> Doc -> Code -> Calls Note
attach0 CallName
"ly-tie-direction"
    Doc
"Force the note's tie to go either up or down."
    (forall pos. Text -> Position pos
Ly.SetEnviron Text
Constants.v_tie_direction, Text
code)

c_hairpin :: Ly.Ly -> Library.Calls Derive.Note
c_hairpin :: Text -> Calls Note
c_hairpin Text
code = forall a.
CallName
-> Doc -> Parser a -> (a -> (FreeCode, FreeCode)) -> Calls Note
emit_pair CallName
"ly-hairpin"
    Doc
"Start a crescendo or diminuendo hairpin.  If it has non-zero duration,\
    \ stop at the event's end, otherwise it will stop at the\
    \ next hairpin or dynamic marking." Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$
    \() ->
        ( (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend, Text
code)
        , (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend, Text
"\\!")
        )

c_ly_text :: Ly.Ly -> Library.Calls Derive.Note
c_ly_text :: Text -> Calls Note
c_ly_text Text
dir = forall a.
AttachTo
-> CallName -> Doc -> Parser a -> (a -> Code) -> Calls Note
attach AttachTo
First CallName
"ly-text" Doc
"Attach text above or below the note."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"text" Doc
"Text to attach.") forall a b. (a -> b) -> a -> b
$
    (Distribution -> Position CodePosition
Ly.append Distribution
Constants.First,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
dir<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
lily_str

c_ly_articulation :: Library.Calls Derive.Note
c_ly_articulation :: Calls Note
c_ly_articulation = forall a.
AttachTo
-> CallName -> Doc -> Parser a -> (a -> Code) -> Calls Note
attach AttachTo
All CallName
"ly-articulation"
    Doc
"Append a `-articulation` to notes."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"text" Doc
"Code to attach. A `-` is prepended.") forall a b. (a -> b) -> a -> b
$
    ((Distribution -> Position CodePosition
Ly.append Distribution
Constants.First,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"-"<>))

c_ly_pre :: Library.Calls Derive.Note
c_ly_pre :: Calls Note
c_ly_pre = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"ly-pre"
    Doc
"Emit arbitrary lilypond code that will go before concurrent notes."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"code" Doc
"A leading \\ will be prepended.") forall a b. (a -> b) -> a -> b
$
    \Text
code -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, Text
"\\" forall a. Semigroup a => a -> a -> a
<> Text
code)

c_ly_post :: Library.Calls Derive.Note
c_ly_post :: Calls Note
c_ly_post = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"ly-post"
    Doc
"Emit arbitrary lilypond code that will go after concurrent notes."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"code" Doc
"A leading \\ will be prepended.") forall a b. (a -> b) -> a -> b
$
    \Text
code -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend, Text
"\\" forall a. Semigroup a => a -> a -> a
<> Text
code)

c_ly_emit :: Library.Calls Derive.Note
c_ly_emit :: Calls Note
c_ly_emit = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"ly-emit"
    Doc
"Emit a single fragment of freestanding lilypond code."
    ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"code" Doc
"Emit this code."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"pos" FreeCodePosition
Constants.FreeAppend
        Doc
"Where to put it: 'Derive.Call.Ly.CodePosition'."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
code, FreeCodePosition
pos) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
pos, Text
code)

c_ly_attach :: Library.Calls Derive.Note
c_ly_attach :: Calls Note
c_ly_attach = forall a.
AttachTo
-> CallName -> Doc -> Parser a -> (a -> Code) -> Calls Note
attach AttachTo
All CallName
"ly-attach"
    Doc
"Attach lilypond code to each transformed note."
    ((,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"code" Doc
"Attach this code."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"pos" (Distribution -> Position CodePosition
Ly.append Distribution
Constants.Last)
        Doc
"Where to put it: 'Derive.Call.Ly.CodePosition'."
    ) forall a b. (a -> b) -> a -> b
$ \(Text
code, Position CodePosition
pos) -> (Position CodePosition
pos, Text
code)

c_ly_key :: Library.Calls Derive.Note
c_ly_key :: Calls Note
c_ly_key = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"ly-key"
    Doc
"Emit a key change. This only emits a lilypond key change, it doesn't\
    \ actually set the key. This means diatonic operations won't work as\
    \ expected. Also, you have to add it to every staff manually.\
    \ On the up side, it doesn't force a structural change like `=` does."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"key" Doc
"You can use any of the keys from the Twelve scale.") forall a b. (a -> b) -> a -> b
$
    \Text
key -> do
        Key
key <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Text -> Either Text Key
Process.parse_key Text
key
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, forall a. ToLily a => a -> Text
Types.to_lily Key
key)

c_ly_sustain :: Library.Calls Derive.Note
c_ly_sustain :: Calls Note
c_ly_sustain = forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
"ly-sus" Doc
"Emit \\sustainOn and \\sustainOff markup."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"state" Doc
"t for \\sustainOn, f for \\sustainOff,\
        \ ft for \\sustainOff\\sustainOn.") forall a b. (a -> b) -> a -> b
$
    \SustainMode
mode -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case SustainMode
mode of
        SustainMode
Off -> (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, Text
"\\sustainOff")
        SustainMode
On -> (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, Text
"\\sustainOn")
        SustainMode
OffOn -> (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, Text
"\\sustainOff\\sustainOn")

c_ly_tr_span :: Library.Calls Derive.Note
c_ly_tr_span :: Calls Note
c_ly_tr_span = forall a.
CallName
-> Doc -> Parser a -> (a -> (FreeCode, FreeCode)) -> Calls Note
emit_pair CallName
"ly-tr-span"
    Doc
"Emit a \\startTrillSpan - \\stopTrillSpan pair."
    Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() ->
        ( (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend, Text
"\\startTrillSpan")
        , (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend, Text
"\\stopTrillSpan")
        )

data SustainMode = Off | On | OffOn deriving (SustainMode
forall a. a -> a -> Bounded a
maxBound :: SustainMode
$cmaxBound :: SustainMode
minBound :: SustainMode
$cminBound :: SustainMode
Bounded, SustainMode -> SustainMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SustainMode -> SustainMode -> Bool
$c/= :: SustainMode -> SustainMode -> Bool
== :: SustainMode -> SustainMode -> Bool
$c== :: SustainMode -> SustainMode -> Bool
Eq, Int -> SustainMode
SustainMode -> Int
SustainMode -> [SustainMode]
SustainMode -> SustainMode
SustainMode -> SustainMode -> [SustainMode]
SustainMode -> SustainMode -> SustainMode -> [SustainMode]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SustainMode -> SustainMode -> SustainMode -> [SustainMode]
$cenumFromThenTo :: SustainMode -> SustainMode -> SustainMode -> [SustainMode]
enumFromTo :: SustainMode -> SustainMode -> [SustainMode]
$cenumFromTo :: SustainMode -> SustainMode -> [SustainMode]
enumFromThen :: SustainMode -> SustainMode -> [SustainMode]
$cenumFromThen :: SustainMode -> SustainMode -> [SustainMode]
enumFrom :: SustainMode -> [SustainMode]
$cenumFrom :: SustainMode -> [SustainMode]
fromEnum :: SustainMode -> Int
$cfromEnum :: SustainMode -> Int
toEnum :: Int -> SustainMode
$ctoEnum :: Int -> SustainMode
pred :: SustainMode -> SustainMode
$cpred :: SustainMode -> SustainMode
succ :: SustainMode -> SustainMode
$csucc :: SustainMode -> SustainMode
Enum, Int -> SustainMode -> ShowS
[SustainMode] -> ShowS
SustainMode -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SustainMode] -> ShowS
$cshowList :: [SustainMode] -> ShowS
show :: SustainMode -> [Char]
$cshow :: SustainMode -> [Char]
showsPrec :: Int -> SustainMode -> ShowS
$cshowsPrec :: Int -> SustainMode -> ShowS
Show)
instance ShowVal.ShowVal SustainMode where
    show_val :: SustainMode -> Text
show_val SustainMode
m = case SustainMode
m of
        SustainMode
Off -> Text
"f"
        SustainMode
On -> Text
"t"
        SustainMode
OffOn -> Text
"ft"
instance Typecheck.Typecheck SustainMode

c_ly_span :: Library.Calls Derive.Note
c_ly_span :: Calls Note
c_ly_span = forall a.
CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit CallName
"ly-span"
    Doc
"Emit a bit of text followed by a dashed line until the end of the event.\
    \ This is useful for things like `accel.` or `cresc.` If it has a\
    \ a zero duration, emit the start if the text is given, or the end if it's\
    \ not."
    (forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"text" Doc
"Text.") Maybe Text
-> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)]
ly_span

-- TODO maybe this should use attach, so it can go on a single note and
-- automatically extend to the end.
ly_span :: Maybe Ly.Ly -> (ScoreTime, ScoreTime)
    -> Derive.Deriver [(ScoreTime, Ly.FreeCode)]
ly_span :: Maybe Text
-> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)]
ly_span Maybe Text
maybe_text (ScoreTime
start, ScoreTime
end)
    | ScoreTime
start forall a. Eq a => a -> a -> Bool
== ScoreTime
end = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Text
maybe_text of
        Just Text
text -> forall {a}. ToLily a => a -> [(ScoreTime, FreeCode)]
start_code Text
text
        Maybe Text
Nothing -> [(ScoreTime, FreeCode)]
end_code
    | Bool
otherwise = case Maybe Text
maybe_text of
        Just Text
text -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. ToLily a => a -> [(ScoreTime, FreeCode)]
start_code Text
text forall a. [a] -> [a] -> [a]
++ [(ScoreTime, FreeCode)]
end_code
        Maybe Text
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"use zero dur to end a span"
    where
    start_code :: a -> [(ScoreTime, FreeCode)]
start_code a
text =
        [ (ScoreTime
start,) forall a b. (a -> b) -> a -> b
$ (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreePrepend,) forall a b. (a -> b) -> a -> b
$
            -- Lilypond likes to put it above, but for tempo and dynamic marks
            -- I think they should go below.
            Text
"\\textSpannerDown\
            \ \\override TextSpanner.bound-details.left.text = \\markup { "
            forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Types.to_lily a
text forall a. Semigroup a => a -> a -> a
<> Text
" }"
        , (ScoreTime
start, (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend, Text
"\\startTextSpan"))
        ]
    end_code :: [(ScoreTime, FreeCode)]
end_code = [(ScoreTime
end, (forall pos. pos -> Position pos
Ly.Position FreeCodePosition
Constants.FreeAppend, Text
"\\stopTextSpan"))]


-- * Attach

data AttachTo = First -- ^ attach code to only the first event
    | All -- ^ attach code to all the events
    deriving (AttachTo -> AttachTo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttachTo -> AttachTo -> Bool
$c/= :: AttachTo -> AttachTo -> Bool
== :: AttachTo -> AttachTo -> Bool
$c== :: AttachTo -> AttachTo -> Bool
Eq, Int -> AttachTo -> ShowS
[AttachTo] -> ShowS
AttachTo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AttachTo] -> ShowS
$cshowList :: [AttachTo] -> ShowS
show :: AttachTo -> [Char]
$cshow :: AttachTo -> [Char]
showsPrec :: Int -> AttachTo -> ShowS
$cshowsPrec :: Int -> AttachTo -> ShowS
Show)

-- | The attach family attaches lilypond code to existing notes.  This is
-- suitable for code which applies directly to a single note.
attach :: AttachTo -> Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> Ly.Code) -> Library.Calls Derive.Note
attach :: forall a.
AttachTo
-> CallName -> Doc -> Parser a -> (a -> Code) -> Calls Note
attach AttachTo
to CallName
name Doc
doc Parser a
sig a -> Code
get_code =
    forall a.
CallName
-> Doc
-> Parser a
-> (a -> Deriver (Stream Note) -> Deriver (Stream Note))
-> Calls Note
transform_notes CallName
name Doc
doc Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
arg Deriver (Stream Note)
deriver -> Code -> Deriver (Stream Note) -> Deriver (Stream Note)
add (a -> Code
get_code a
arg) Deriver (Stream Note)
deriver
    where
    add :: Code -> Deriver (Stream Note) -> Deriver (Stream Note)
add = case AttachTo
to of
        AttachTo
First -> Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_first
        AttachTo
All -> Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_all

-- | 'attach' with no arguments.
attach0 :: Derive.CallName -> Doc.Doc -> Ly.Code -> Library.Calls Derive.Note
attach0 :: CallName -> Doc -> Code -> Calls Note
attach0 CallName
name Doc
doc Code
code =
    forall a.
AttachTo
-> CallName -> Doc -> Parser a -> (a -> Code) -> Calls Note
attach AttachTo
All CallName
name (Doc
doc forall a. Semigroup a => a -> a -> a
<> Doc
"\nLilypond code: " forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Doc.Doc (forall a. Pretty a => a -> Text
pretty Code
code))
        Parser ()
Sig.no_args (forall a b. a -> b -> a
const Code
code)

transform_notes :: Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Library.Calls Derive.Note
transform_notes :: forall a.
CallName
-> Doc
-> Parser a
-> (a -> Deriver (Stream Note) -> Deriver (Stream Note))
-> Calls Note
transform_notes CallName
name Doc
doc Parser a
sig a -> Deriver (Stream Note) -> Deriver (Stream Note)
transform =
    forall a.
Module
-> CallName
-> Tags
-> Doc
-> Parser a
-> (a -> Deriver (Stream Note) -> Deriver (Stream Note))
-> Calls Note
Make.transform_notes Module
Module.ly CallName
name Tags
Tags.ly Doc
doc Parser a
sig forall a b. (a -> b) -> a -> b
$
        \a
arg Deriver (Stream Note)
deriver -> forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (a -> Deriver (Stream Note) -> Deriver (Stream Note)
transform a
arg Deriver (Stream Note)
deriver) Deriver (Stream Note)
deriver

-- * Emit

-- | The emit family creates 0 dur events that just carry lilypond code, and
-- are not real notes.  This is suitable for score level directives, such as
-- dynamics or tempo markings.  Technically in lilypond those are attached to
-- notes too, but you wouldn't want to put one on every single note in
-- a section.
emit :: Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> (ScoreTime, ScoreTime)
    -> Derive.Deriver [(ScoreTime, Ly.FreeCode)])
    -> Library.Calls Derive.Note
emit :: forall a.
CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit = forall a.
(Deriver (Stream Note) -> Deriver (Stream Note))
-> Bool
-> CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit_transform forall a. a -> a
id Bool
False

emit_start :: Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> Derive.Deriver Ly.FreeCode) -> Library.Calls Derive.Note
emit_start :: forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_start CallName
name Doc
doc Parser a
sig a -> Deriver FreeCode
get_code = forall a.
(Deriver (Stream Note) -> Deriver (Stream Note))
-> Bool
-> CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit_transform forall a. a -> a
id Bool
True CallName
name Doc
doc Parser a
sig forall a b. (a -> b) -> a -> b
$
    \a
val (ScoreTime
start, ScoreTime
_) -> (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScoreTime
start,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Deriver FreeCode
get_code a
val

-- | Like 'emit_start', but also set the instrument to 'Constants.ly_global'.
emit_global :: Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> Derive.Deriver Ly.FreeCode) -> Library.Calls Derive.Note
emit_global :: forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver FreeCode) -> Calls Note
emit_global CallName
name Doc
doc Parser a
sig a -> Deriver FreeCode
get_code = forall a.
(Deriver (Stream Note) -> Deriver (Stream Note))
-> Bool
-> CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit_transform forall a. Deriver a -> Deriver a
Ly.global Bool
True CallName
name Doc
doc Parser a
sig forall a b. (a -> b) -> a -> b
$
    \a
val (ScoreTime
start, ScoreTime
_) -> (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScoreTime
start,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Deriver FreeCode
get_code a
val

emit_transform :: (Derive.NoteDeriver -> Derive.NoteDeriver)
    -> Bool -- ^ if True, require that the generator have 0 duration
    -> Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> (ScoreTime, ScoreTime)
        -> Derive.Deriver [(ScoreTime, Ly.FreeCode)])
    -> Library.Calls Derive.Note
emit_transform :: forall a.
(Deriver (Stream Note) -> Deriver (Stream Note))
-> Bool
-> CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit_transform Deriver (Stream Note) -> Deriver (Stream Note)
transform Bool
assert_0dur CallName
name Doc
doc_ Parser a
sig a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)]
get_events =
    forall d. Generator d -> Transformer d -> Calls d
Library.Calls Generator Note
gen Transformer Note
trans
    where
    gen :: Generator Note
gen = forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name Doc
doc forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
val PassedArgs Note
args -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.only_lilypond forall a b. (a -> b) -> a -> b
$ do
        forall d. PassedArgs d -> Deriver ()
Sub.assert_no_subs PassedArgs Note
args
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
assert_0dur Bool -> Bool -> Bool
&& forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs Note
args forall a. Eq a => a -> a -> Bool
/= ScoreTime
0) forall a b. (a -> b) -> a -> b
$
            forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"this emits a single bit of lilypond code,\
                \ so it should be either a transformer or a 0 dur generator: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args)
        forall {a}. a -> PassedArgs a -> Deriver (Stream Note)
make a
val PassedArgs Note
args
    trans :: Transformer Note
trans = forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
name Doc
doc forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
val PassedArgs Note
args Deriver (Stream Note)
deriver ->
        forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (forall {a}. a -> PassedArgs a -> Deriver (Stream Note)
make a
val PassedArgs Note
args forall a. Semigroup a => a -> a -> a
<> Deriver (Stream Note)
deriver) Deriver (Stream Note)
deriver
    make :: a -> PassedArgs a -> Deriver (Stream Note)
make a
val PassedArgs a
args = Deriver (Stream Note) -> Deriver (Stream Note)
transform forall a b. (a -> b) -> a -> b
$ forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ScoreTime -> FreeCode -> Deriver (Stream Note)
Ly.code0)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)]
get_events a
val (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs a
args)
    doc :: Doc
doc = Doc
doc_ forall a. Semigroup a => a -> a -> a
<> Doc
"\n" forall a. Semigroup a => a -> a -> a
<> Doc
emit_doc

emit0 :: Derive.CallName -> Doc.Doc -> Ly.FreeCode -> Library.Calls Derive.Note
emit0 :: CallName -> Doc -> FreeCode -> Calls Note
emit0 CallName
name Doc
doc FreeCode
code =
    forall a.
CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit CallName
name (Doc
doc forall a. Semigroup a => a -> a -> a
<> Doc
"\nLilypond code: " forall a. Semigroup a => a -> a -> a
<> Text -> Doc
Doc.Doc (forall a. Pretty a => a -> Text
pretty FreeCode
code))
    Parser ()
Sig.no_args forall a b. (a -> b) -> a -> b
$ \() (ScoreTime
start, ScoreTime
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return [(ScoreTime
start, FreeCode
code)]

-- | Like 'emit_start', except that the call can emit 2 Codes.  The second
-- will be used at the end of the event if it has non-zero duration.
emit_pair :: Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> (Ly.FreeCode, Ly.FreeCode)) -> Library.Calls Derive.Note
emit_pair :: forall a.
CallName
-> Doc -> Parser a -> (a -> (FreeCode, FreeCode)) -> Calls Note
emit_pair CallName
name Doc
doc Parser a
sig a -> (FreeCode, FreeCode)
get_code = forall a.
CallName
-> Doc
-> Parser a
-> (a -> (ScoreTime, ScoreTime) -> Deriver [(ScoreTime, FreeCode)])
-> Calls Note
emit CallName
name Doc
doc Parser a
sig (\a
val -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Eq a => a -> (a, a) -> [(a, FreeCode)]
get a
val)
    where
    get :: a -> (a, a) -> [(a, FreeCode)]
get a
val (a
start, a
end)
        | a
start forall a. Eq a => a -> a -> Bool
== a
end = [(a
start, FreeCode
pre)]
        | Bool
otherwise = [(a
start, FreeCode
pre), (a
end, FreeCode
post)]
        where (FreeCode
pre, FreeCode
post) = a -> (FreeCode, FreeCode)
get_code a
val

-- | Wrap each individual note event in code.
attach_wrap_notes :: Derive.CallName -> Doc.Doc -> Sig.Parser a
    -> (a -> Derive.Deriver (Ly.Ly, Ly.Ly)) -> Library.Calls Derive.Note
attach_wrap_notes :: forall a.
CallName
-> Doc -> Parser a -> (a -> Deriver (Text, Text)) -> Calls Note
attach_wrap_notes CallName
name Doc
doc Parser a
sig a -> Deriver (Text, Text)
get_code = forall d. Generator d -> Transformer d -> Calls d
Library.Calls Generator Note
gen Transformer Note
trans
    where
    around_doc :: Doc
around_doc = Doc
emit_doc
        forall a. Semigroup a => a -> a -> a
<> Doc
" The transformer will wrap each event in (start, end) pairs.\
        \ This way you can wrap all notes on a certain track with\
        \ complementary bits of lilypond code."
    gen :: Generator Note
gen = forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name (Doc
doc forall a. Semigroup a => a -> a -> a
<> Doc
around_doc) forall a b. (a -> b) -> a -> b
$
        forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
val PassedArgs Note
args -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.only_lilypond forall a b. (a -> b) -> a -> b
$
            a -> Deriver (Stream Note) -> Deriver (Stream Note)
transform a
val forall a b. (a -> b) -> a -> b
$ forall d. PassedArgs d -> Deriver (Stream Note)
Sub.derive_subs PassedArgs Note
args
    trans :: Transformer Note
trans = forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
name (Doc
doc forall a. Semigroup a => a -> a -> a
<> Doc
around_doc) forall a b. (a -> b) -> a -> b
$
        forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt Parser a
sig forall a b. (a -> b) -> a -> b
$ \a
val PassedArgs Note
_args Deriver (Stream Note)
deriver ->
            forall {a}. Deriver a -> Deriver a -> Deriver a
Ly.when_lilypond (a -> Deriver (Stream Note) -> Deriver (Stream Note)
transform a
val Deriver (Stream Note)
deriver) Deriver (Stream Note)
deriver
    transform :: a -> Deriver (Stream Note) -> Deriver (Stream Note)
transform a
val Deriver (Stream Note)
deriver = do
        (Text
pre, Text
post) <- a -> Deriver (Text, Text)
get_code a
val
        Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_all (Position CodePosition
Ly.prepend, Text
pre) forall a b. (a -> b) -> a -> b
$
            Code -> Deriver (Stream Note) -> Deriver (Stream Note)
Ly.add_all (Distribution -> Position CodePosition
Ly.append Distribution
Constants.Last, Text
post) Deriver (Stream Note)
deriver

emit_doc :: Doc.Doc
emit_doc :: Doc
emit_doc = Doc
"\nThis either be placed in a separate track as a zero-dur\
    \ event, or it can be attached to an individual note as a transformer."

-- * util

lily_str :: Text -> Ly.Ly
lily_str :: Text -> Text
lily_str = forall a. ToLily a => a -> Text
Types.to_lily

generator :: Derive.CallName -> Doc.Doc
    -> Derive.WithArgDoc (Derive.GeneratorF d) -> Derive.Generator d
generator :: forall d.
CallName -> Doc -> WithArgDoc (GeneratorF d) -> Generator d
generator CallName
name = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.ly CallName
name Tags
Tags.ly

transformer :: Derive.CallName -> Doc.Doc
    -> Derive.WithArgDoc (Derive.TransformerF d) -> Derive.Transformer d
transformer :: forall d.
CallName -> Doc -> WithArgDoc (TransformerF d) -> Transformer d
transformer CallName
name = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.ly CallName
name Tags
Tags.ly