-- Copyright 2014 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Calls for Carnatic gamakam.
module Derive.C.India.Gamakam2 where
import qualified Control.Monad.State.Strict as Monad.State
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Pretty as Pretty

import qualified Derive.Args as Args
import qualified Derive.C.Prelude.Trill as Trill
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Module as Module
import qualified Derive.Call.PitchUtil as PitchUtil
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Eval as Eval
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Pitches as Pitches
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal
import qualified Ui.Event as Event

import           Global
import           Types


module_ :: Module.Module
module_ :: Module
module_ = Module
"india" forall a. Semigroup a => a -> a -> a
<> Module
"gamakam2"

-- | Calls in these modules are meant to be used via the sequence call, so they
-- are only in scope under the relevant phase.
begin_module, middle_module, end_module :: Module.Module
begin_module :: Module
begin_module = Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"begin"
middle_module :: Module
middle_module = Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"middle"
end_module :: Module
end_module = Module
module_ forall a. Semigroup a => a -> a -> a
<> Module
"end"

library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators [(Symbol
"@", Generator Note
c_sequence)]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"@", Transformer Note
c_sequence_transform)
        , (Symbol
"sahitya", forall a. Taggable a => Transformer a
c_sahitya)
        ]
    -- Pitch
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [(Symbol, Generator Pitch)]
begin_calls
        , [(Symbol, Generator Pitch)]
begin_aliases
        , [(Symbol, Generator Pitch)]
middle_calls
        , [(Symbol, Generator Pitch)]
middle_aliases
        , [(Symbol, Generator Pitch)]
end_calls
        , [(Symbol, Generator Pitch)]
end_aliases
        ]
    ]

begin_calls :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]
begin_calls :: [(Symbol, Generator Pitch)]
begin_calls =
    [ (Symbol
"set-pitch", Generator Pitch
c_set_pitch)
    , (Symbol
"flat-start", Generator Pitch
c_flat_start)
    , (Symbol
"cur", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromCurrent Fade
NoFade)
    , (Symbol
"cur<", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromCurrent Fade
Fade)
    , (Symbol
"prev", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromPrev Fade
NoFade)
    , (Symbol
"prev<", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromPrev Fade
Fade)
    , (Symbol
"jaru", Bool -> Generator Pitch
c_jaru Bool
False)
    , (Symbol
"jaru0", Bool -> Generator Pitch
c_jaru Bool
True)
    , (Symbol
"fade-in", Bool -> Generator Pitch
c_fade Bool
True)
    ]

-- | I don't want to take up short names for the whole track scope, but within
-- a sequence call it seems reasonable.  In addition, I know if it's a begin or
-- end call, and use the same name for logically similar things.
begin_aliases :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]
begin_aliases :: [(Symbol, Generator Pitch)]
begin_aliases = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall f. Module -> Call f -> Call f
Derive.set_module Module
begin_module))
    [ (Symbol
"-", Generator Pitch
c_flat_start)
    , (Symbol
"c", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromCurrent Fade
NoFade)
    , (Symbol
"c<", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromCurrent Fade
Fade)
    , (Symbol
"p", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromPrev Fade
NoFade)
    , (Symbol
"p<", PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
PitchFromPrev Fade
Fade)
    , (Symbol
"J", Bool -> Generator Pitch
c_jaru Bool
False)
    , (Symbol
"j", Bool -> Generator Pitch
c_jaru Bool
True)
    , (Symbol
fade_in_call, Bool -> Generator Pitch
c_fade Bool
True)
    ]

middle_calls :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]
middle_calls :: [(Symbol, Generator Pitch)]
middle_calls = (Symbol
"flat", Generator Pitch
c_flat)
    forall a. a -> [a] -> [a]
: forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
"kam" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_kampita Doc
"" KampitaArgs
neighbor)
    forall a. [a] -> [a] -> [a]
++ forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
"kam2" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_kampita Doc
"" KampitaArgs
Kampita2)
    forall a. [a] -> [a] -> [a]
++ forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
"nkam" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_nkampita Doc
"" KampitaArgs
neighbor)
    forall a. [a] -> [a] -> [a]
++ forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
"nkam2" (Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_nkampita Doc
"" KampitaArgs
Kampita2)
    where neighbor :: KampitaArgs
neighbor = Double -> KampitaArgs
Kampita1 Double
0

kampita_variations :: Text -> (Maybe Trill.Direction -> call)
    -> [(Expr.Symbol, call)]
kampita_variations :: forall call. Text -> (Maybe Direction -> call) -> [(Symbol, call)]
kampita_variations Text
name Maybe Direction -> call
call =
    [ (Text -> Symbol
Expr.Symbol forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Maybe Direction -> Text
Trill.direction_affix Maybe Direction
end, Maybe Direction -> call
call Maybe Direction
end)
    | Maybe Direction
end <- [Maybe Direction]
dirs
    ]
    where dirs :: [Maybe Direction]
dirs = [forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Direction
Trill.Low, forall a. a -> Maybe a
Just Direction
Trill.High]

middle_aliases :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]
middle_aliases :: [(Symbol, Generator Pitch)]
middle_aliases = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall f. Module -> Call f -> Call f
Derive.set_module Module
middle_module)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    [ (Symbol
"-", Generator Pitch
c_flat)
    ] forall a. a -> [a] -> [a]
:
    [ forall {a}.
(Semigroup a, IsString a) =>
a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)]
hardcoded Symbol
"o^" (Double -> Double -> KampitaArgs
Kampita0 Double
1 Double
0) (forall a. a -> Maybe a
Just Direction
Trill.High)
    , forall {a}.
(Semigroup a, IsString a) =>
a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)]
hardcoded Symbol
"o_" (Double -> Double -> KampitaArgs
Kampita0 (-Double
1) Double
0) (forall a. a -> Maybe a
Just Direction
Trill.Low)
    , forall {a}.
(Semigroup a, IsString a) =>
a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)]
hardcoded Symbol
"o*" (Double -> Double -> KampitaArgs
Kampita0 (-Double
1) Double
1) (forall a. a -> Maybe a
Just Direction
Trill.Low)
    , forall call. Text -> Text -> [(Symbol, call)] -> [(Symbol, call)]
alias_prefix Text
"k" Text
"kam" [(Symbol, Generator Pitch)]
middle_calls
    , forall call. Text -> Text -> [(Symbol, call)] -> [(Symbol, call)]
alias_prefix Text
"nk" Text
"nkam" [(Symbol, Generator Pitch)]
middle_calls
    ]
    where
    hardcoded :: a -> KampitaArgs -> Maybe Direction -> [(a, Generator Pitch)]
hardcoded a
name KampitaArgs
arg Maybe Direction
dir =
        [ (a
name, Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_kampita Doc
doc KampitaArgs
arg Maybe Direction
dir)
        , (a
"n" forall a. Semigroup a => a -> a -> a
<> a
name, Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_nkampita Doc
doc KampitaArgs
arg Maybe Direction
dir)
        ]
    doc :: Doc
doc = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines
        [ Text
"These are hardcoded `k` variants:"
        , Text
"`o^` touches the swaram from above, like `k2^ 1 0`."
        , Text
"`o_` touches the swaram from below, like `k2_ -1 0`."
        , Text
"`o*` avoids the swaram, like `k2_ -1 1`."
        ]

alias_prefix :: Text -> Text -> [(Expr.Symbol, call)] -> [(Expr.Symbol, call)]
alias_prefix :: forall call. Text -> Text -> [(Symbol, call)] -> [(Symbol, call)]
alias_prefix Text
from Text
to [(Symbol, call)]
calls = do
    (Expr.Symbol Text
name, call
call) <- [(Symbol, call)]
calls
    Just Text
rest <- [Text -> Text -> Maybe Text
Text.stripPrefix Text
to Text
name]
    forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Symbol
Expr.Symbol (Text
from forall a. Semigroup a => a -> a -> a
<> Text
rest), call
call)

end_calls :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]
end_calls :: [(Symbol, Generator Pitch)]
end_calls =
    [ (Symbol
"flat-end", Generator Pitch
c_flat_end)
    , (Symbol
"to", Fade -> Generator Pitch
c_to Fade
NoFade)
    , (Symbol
"to>", Fade -> Generator Pitch
c_to Fade
Fade)
    , (Symbol
"fade-out", Bool -> Generator Pitch
c_fade Bool
False)
    ]

end_aliases :: [(Expr.Symbol, Derive.Generator Derive.Pitch)]
end_aliases :: [(Symbol, Generator Pitch)]
end_aliases = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall f. Module -> Call f -> Call f
Derive.set_module Module
end_module))
    [ (Symbol
"-", Generator Pitch
c_flat_end)
    , (Symbol
"t", Fade -> Generator Pitch
c_to Fade
NoFade)
    , (Symbol
"t>", Fade -> Generator Pitch
c_to Fade
Fade)
    , (Symbol
fade_out_call, Bool -> Generator Pitch
c_fade Bool
False)
    ]

-- | Special behaviour documented in 'sequence_doc'.
fade_out_call :: Expr.Symbol
fade_out_call :: Symbol
fade_out_call = Symbol
"->" -- The leading dash makes these parse as symbols.

-- | Unlike 'fade_out_call', this doesn't need special treatment.
fade_in_call :: Expr.Symbol
fade_in_call :: Symbol
fade_in_call = Symbol
"-<"

-- * sequence

c_sequence :: Derive.Generator Derive.Note
c_sequence :: Generator Note
c_sequence = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"sequence" forall a. Monoid a => a
mempty Doc
sequence_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 (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"Expressions separated by `;`.")
    forall a b. (a -> b) -> a -> b
$ \[Val]
_ -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args -> forall a. PassedArgs Note -> Deriver a -> Deriver a
with_sequence PassedArgs Note
args (forall d. PassedArgs d -> NoteDeriver
Call.placed_note PassedArgs Note
args)

c_sequence_transform :: Derive.Transformer Derive.Note
c_sequence_transform :: Transformer Note
c_sequence_transform = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"sequence" forall a. Monoid a => a
mempty
    Doc
sequence_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 (ArgName -> Doc -> Parser [Val]
Sig.many_vals ArgName
"arg" Doc
"Expressions separated by `;`.") forall a b. (a -> b) -> a -> b
$
        \[Val]
_ -> forall a. PassedArgs Note -> Deriver a -> Deriver a
with_sequence

sequence_doc :: Doc.Doc
sequence_doc :: Doc
sequence_doc = Doc
"Sequence several pitch calls. Calls are divided into\
    \ `begin ; middle1 ; middle2; ... ; end` phases. Calls are pitch\
    \ generators, and are sequenced such that the middle calls stretch\
    \ based on the duration of the note. The " forall a. Semigroup a => a -> a -> a
<> Module -> Doc
doc Module
begin_module forall a. Semigroup a => a -> a -> a
<> Doc
", "
    forall a. Semigroup a => a -> a -> a
<> Module -> Doc
doc Module
middle_module forall a. Semigroup a => a -> a -> a
<> Doc
", and " forall a. Semigroup a => a -> a -> a
<> Module -> Doc
doc Module
end_module forall a. Semigroup a => a -> a -> a
<> Doc
" modules are\
    \ in scope during the begin, middle, and end phases. All calls\
    \ below the " forall a. Semigroup a => a -> a -> a
<> Module -> Doc
doc Module
module_ forall a. Semigroup a => a -> a -> a
<> Doc
" module are designed for\
    \ sequencing. This just means they emit samples at the beginning and end\
    \ of their range, so the sequence call knows their extent. Normal pitch\
    \ calls may not do that.\
    \\nThere's a special hack for the " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Symbol
fade_in_call
    forall a. Semigroup a => a -> a -> a
<> Doc
" and " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Symbol
fade_out_call forall a. Semigroup a => a -> a -> a
<> Doc
" calls: they have 0\
    \ duration, but are overlaid with their neighbors. This is so you can fade\
    \ in or out without having to flatten the pitch."
    where doc :: Module -> Doc
doc = forall a. Pretty a => a -> Doc
Doc.pretty

with_sequence :: Derive.PassedArgs Score.Event -> Derive.Deriver a
    -> Derive.Deriver a
with_sequence :: forall a. PassedArgs Note -> Deriver a -> Deriver a
with_sequence PassedArgs Note
args Deriver a
deriver = do
    let (Expr
begin, [Expr]
middle, Maybe Expr
end) = [Val] -> (Expr, [Expr], Maybe Expr)
parse_sequence (forall val. PassedArgs val -> [Val]
Derive.passed_vals PassedArgs Note
args)
    (Pitch
pitch, [ControlMod]
mods) <- Context Pitch
-> (ScoreTime, ScoreTime)
-> Expr
-> [Expr]
-> Maybe Expr
-> Deriver (Pitch, [ControlMod])
sequence_calls (Context Note -> Context Pitch
pitch_context (forall a. PassedArgs a -> Context a
Args.context PassedArgs Note
args))
        (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Note
args) Expr
begin [Expr]
middle Maybe Expr
end
    RealTime
end_time <- forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs Note
args
    forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch Pitch
pitch forall a b. (a -> b) -> a -> b
$ forall a. [ControlMod] -> RealTime -> Deriver a -> Deriver a
Derive.with_control_mods [ControlMod]
mods RealTime
end_time Deriver a
deriver

pitch_context :: Derive.Context Score.Event -> Derive.Context Derive.Pitch
pitch_context :: Context Note -> Context Pitch
pitch_context Context Note
ctx = Context Note
ctx
    { ctx_prev_val :: Maybe Pitch
Derive.ctx_prev_val = Note -> Pitch
Score.event_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall val. Context val -> Maybe val
Derive.ctx_prev_val Context Note
ctx }

type Signals = (PSignal.PSignal, [Derive.ControlMod])

{- Awkward things:

    - I set call duration with the event (start, dur) instead of warp, so
    I have to modify the event rather than use Derive.place.

    - I deduce the duration of a call by seeing what signal it returns rather
    that having some special call mode, so these calls need to emit samples at
    their start and end.  Actually, just end for begin and middle calls, and
    start for end calls.

    - Prev val is manually passed from one call to the next, so if I don't have
    TrackEval.derive_track handling that for me, I have to do it myself, and be
    careful to not pass it for the speculative evaluation of the end call.
-}

{- | I assume that start and end calls have a fixed duration and don't stretch
    to fill the given space, though they will shrink if necessary.  So
    I evaluate start and end to get their durations, and fit the middle calls
    into the remaining space, evenly divided.

    Actually, there's a circular problem in that I don't know how long the
    middle section can be until I know how long the end call is, but the end
    call likely relies on 'Derive.ctx_prev_val', so it has to be evaluated
    after the middle.  So I evaluate the end twice, once before the middle to
    find out its length, and again after evaluating the middle to get the pitch
    right.

    I considered a specially calling mode where calls could return their
    desired duration rather than a signal, but it seems much simpler to just
    have them do that by returning the signal itself and measuring that.

    A possibly useful extension would be to allow middle calls to be shorter
    than their allotted time, for instance a trill might want to complete
    a cycle and allow a @flat@ call to take up remaining space.  I could put
    the requested time in @Derive.real 1@ and the hard limit in @Args.next@,
    but that wouldn't allow time before the call to stretch, only time after.
    But I could indicate stretchiness with a special tag on the call.
-}
sequence_calls :: Derive.Context Derive.Pitch -> (ScoreTime, ScoreTime)
    -> Expr -> [Expr] -> Maybe Expr -> Derive.Deriver Signals
sequence_calls :: Context Pitch
-> (ScoreTime, ScoreTime)
-> Expr
-> [Expr]
-> Maybe Expr
-> Deriver (Pitch, [ControlMod])
sequence_calls Context Pitch
ctx (ScoreTime
start, ScoreTime
end) Expr
begin [Expr]
middles Maybe Expr
maybe_end =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Monad.State.runStateT Context Pitch
ctx forall a b. (a -> b) -> a -> b
$ do
        (Pitch
begin_pitch, [ControlMod]
begin_mods) <- Module
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval Module
begin_module ScoreTime
start ScoreTime
end Expr
begin
        ScoreTime
middle_start <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ScoreTime -> Pitch -> Deriver ScoreTime
signal_end ScoreTime
start Pitch
begin_pitch
        -- This is a test eval of 'end', just to see how long it is.  The
        -- middle isn't evaluated yet, so it doesn't have the right
        -- ctx_prev_val.
        (Pitch
test_end_pitch, [ControlMod]
_) <- forall a. SequenceM a -> SequenceM a
detached forall a b. (a -> b) -> a -> b
$
            forall {a}.
(a
 -> StateT
      (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]))
-> Maybe a
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
maybe_eval (Module
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval Module
end_module ScoreTime
middle_start ScoreTime
end) Maybe Expr
maybe_end
        ScoreTime
end_start <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ScoreTime -> Pitch -> Deriver ScoreTime
signal_start ScoreTime
end Pitch
test_end_pitch
        (Pitch
middle_pitch, [ControlMod]
middle_mods)
            <- ScoreTime
-> ScoreTime
-> [Expr]
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
sequence_middles ScoreTime
middle_start ScoreTime
end_start [Expr]
middles
        (Pitch
end_pitch, [ControlMod]
end_mods) <- forall {a}.
(a
 -> StateT
      (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]))
-> Maybe a
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
maybe_eval
            (ScoreTime
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval_end ScoreTime
start ScoreTime
end_start ScoreTime
end) Maybe Expr
maybe_end
        forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch
begin_pitch forall a. Semigroup a => a -> a -> a
<> Pitch
middle_pitch forall a. Semigroup a => a -> a -> a
<> Pitch
end_pitch,
            [ControlMod]
begin_mods forall a. Semigroup a => a -> a -> a
<> [ControlMod]
middle_mods forall a. Semigroup a => a -> a -> a
<> [ControlMod]
end_mods)
    where
    maybe_eval :: (a
 -> StateT
      (Context Pitch) (Deriver State Error) (Pitch, [ControlMod]))
-> Maybe a
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
maybe_eval = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty))

-- | Special behaviour for the @fade-out@ call, as documented in 'sequence_doc'.
eval_end :: ScoreTime -> ScoreTime -> ScoreTime -> Expr -> SequenceM Signals
eval_end :: ScoreTime
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval_end ScoreTime
sequence_start ScoreTime
start ScoreTime
end Expr
expr = case Expr
expr of
    EvaluatedExpr Symbol
call [Val]
_ | Symbol
call forall a. Eq a => a -> a -> Bool
== Symbol
fade_out_call ->
        Module
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval Module
end_module ScoreTime
sequence_start ScoreTime
end Expr
expr
    Expr
_ -> Module
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval Module
end_module ScoreTime
start ScoreTime
end Expr
expr

-- | I need to thread Derive.ctx_prev_val from each call in the sequence.
type SequenceM = Monad.State.StateT (Derive.Context Derive.Pitch) Derive.Deriver

detached :: SequenceM a -> SequenceM a
detached :: forall a. SequenceM a -> SequenceM a
detached SequenceM a
m = do
    Context Pitch
st <- forall s (m :: * -> *). MonadState s m => m s
Monad.State.get
    a
val <- SequenceM a
m
    forall s (m :: * -> *). MonadState s m => s -> m ()
Monad.State.put Context Pitch
st
    forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Give each middle call an even division of the time left.  The call can
-- use less time if it wishes, and the remaining time will be divided among
-- the remaining middle calls.  It shouldn't use more time, because then it
-- could overlap with the end call, or go past the end of the note.
sequence_middles :: ScoreTime -> ScoreTime -> [Expr] -> SequenceM Signals
sequence_middles :: ScoreTime
-> ScoreTime
-> [Expr]
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
sequence_middles ScoreTime
_ ScoreTime
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
sequence_middles ScoreTime
start ScoreTime
end [Expr]
_ | ScoreTime
start forall a. Ord a => a -> a -> Bool
>= ScoreTime
end = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
sequence_middles ScoreTime
start ScoreTime
end (Expr
expr:[Expr]
exprs) = do
    let dur :: ScoreTime
dur = (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
exprs forall a. Num a => a -> a -> a
+ Int
1)
    (Pitch
pitch, [ControlMod]
mods) <- Module
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval Module
middle_module ScoreTime
start (ScoreTime
start forall a. Num a => a -> a -> a
+ ScoreTime
dur) Expr
expr
    ScoreTime
sig_end <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ScoreTime -> Pitch -> Deriver ScoreTime
signal_end ScoreTime
start Pitch
pitch
    (Pitch
pitch_rest, [ControlMod]
mods_rest) <- ScoreTime
-> ScoreTime
-> [Expr]
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
sequence_middles ScoreTime
sig_end ScoreTime
end [Expr]
exprs
    forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch
pitch forall a. Semigroup a => a -> a -> a
<> Pitch
pitch_rest, [ControlMod]
mods forall a. Semigroup a => a -> a -> a
<> [ControlMod]
mods_rest)

signal_start :: ScoreTime -> PSignal.PSignal -> Derive.Deriver ScoreTime
signal_start :: ScoreTime -> Pitch -> Deriver ScoreTime
signal_start ScoreTime
deflt = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
deflt) (forall a. Time a => a -> Deriver ScoreTime
Derive.score forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Pitch -> Maybe (RealTime, RawPitch Untransposed_)
PSignal.head

signal_end :: ScoreTime -> PSignal.PSignal -> Derive.Deriver ScoreTime
signal_end :: ScoreTime -> Pitch -> Deriver ScoreTime
signal_end ScoreTime
deflt = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ScoreTime
deflt) (forall a. Time a => a -> Deriver ScoreTime
Derive.score forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Pitch -> Maybe (RealTime, RawPitch Untransposed_)
PSignal.last

eval :: Module.Module -> ScoreTime -> ScoreTime -> Expr -> SequenceM Signals
eval :: Module
-> ScoreTime
-> ScoreTime
-> Expr
-> StateT
     (Context Pitch) (Deriver State Error) (Pitch, [ControlMod])
eval Module
module_ ScoreTime
start ScoreTime
end Expr
expr = do
    Context Pitch
ctx <- forall s (m :: * -> *). MonadState s m => m s
Monad.State.get
    (Stream Pitch
result, [ControlMod]
cmods) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Deriver a -> Deriver (a, [ControlMod])
with_empty_collect forall a b. (a -> b) -> a -> b
$
        forall a. Bool -> Module -> Deriver a -> Deriver a
Derive.with_imported Bool
True Module
module_ forall a b. (a -> b) -> a -> b
$
        forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
eval_expr (forall d. ScoreTime -> ScoreTime -> Context d -> Context d
place_event ScoreTime
start (ScoreTime
end forall a. Num a => a -> a -> a
- ScoreTime
start) Context Pitch
ctx) Expr
expr
    Pitch
signal <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. LogMonad m => Stream a -> m [a]
Stream.write_logs Stream Pitch
result
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Pitch -> Bool
PSignal.null Pitch
signal) forall a b. (a -> b) -> a -> b
$
        forall s (m :: * -> *). MonadState s m => s -> m ()
Monad.State.put forall a b. (a -> b) -> a -> b
$ Context Pitch
ctx { ctx_prev_val :: Maybe Pitch
Derive.ctx_prev_val = forall a. a -> Maybe a
Just Pitch
signal }
    forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch
signal, [ControlMod]
cmods)

place_event :: ScoreTime -> ScoreTime -> Derive.Context d -> Derive.Context d
place_event :: forall d. ScoreTime -> ScoreTime -> Context d -> Context d
place_event ScoreTime
start ScoreTime
dur Context d
ctx = Context d
ctx
    { ctx_event :: Event
Derive.ctx_event = ScoreTime -> ScoreTime -> Event -> Event
Event.place ScoreTime
start ScoreTime
dur (forall val. Context val -> Event
Derive.ctx_event Context d
ctx) }

eval_expr :: Derive.CallableExpr d => Derive.Context d -> Expr
    -> Derive.Deriver (Stream.Stream d)
eval_expr :: forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
eval_expr Context d
ctx (QuotedExpr Expr
expr) = forall d. CallableExpr d => Context d -> Expr -> Deriver (Stream d)
Eval.eval_toplevel Context d
ctx Expr
expr
eval_expr Context d
ctx (EvaluatedExpr Symbol
sym [Val]
args) = do
    Generator d
call <- forall d. Callable (Generator d) => Symbol -> Deriver (Generator d)
Eval.get_generator Symbol
sym
    forall d. Context d -> Generator d -> [Val] -> Deriver (Stream d)
Eval.apply_generator Context d
ctx Generator d
call [Val]
args

with_empty_collect :: Derive.Deriver a
    -> Derive.Deriver (a, [Derive.ControlMod])
with_empty_collect :: forall a. Deriver a -> Deriver (a, [ControlMod])
with_empty_collect = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Collect -> [ControlMod]
Derive.collect_control_mods)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Deriver a -> Deriver (a, Collect)
Internal.local_collect

-- ** parse

data Expr =
    -- | This is a call which was embedded in the argument list of the sequence
    -- call, so its arguments have already been evaluated.
    EvaluatedExpr Expr.Symbol [DeriveT.Val]
    -- | A call and its arguments can be protected from evaluation by quoting
    -- it.  This is also necessary to use a transformer, since @;@ has higher
    -- precedence than @|@ (actually it's just a value, not an operator).
    | QuotedExpr !DeriveT.Expr
    deriving Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show

instance Pretty Expr where
    format :: Expr -> Doc
format (EvaluatedExpr Symbol
sym [Val]
vals) =
        (Doc
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Pretty.format Symbol
sym) Doc -> Doc -> Doc
Pretty.<+> (forall a. Pretty a => a -> Doc
Pretty.format [Val]
vals forall a. Semigroup a => a -> a -> a
<> Doc
")")
    format (QuotedExpr Expr
quoted) = Text -> Doc
Pretty.text forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> Text
ShowVal.show_val Expr
quoted

-- | Parse the sequence call's arguments and substitute aliases.  If there is
-- no begin, @set-pitch@ will be added, and if there is no middle, @-@ will be
-- added.  This is so that if there is just an end call, there will still be
-- a signal from the beginning of the note.
--
-- The positions are inferred according to the number of sections:
--
-- > ; middle1;
-- > begin1; middle2
-- > begin1; middle2; middle3; ...; end_n
parse_sequence :: [DeriveT.Val] -> (Expr, [Expr], Maybe Expr)
parse_sequence :: [Val] -> (Expr, [Expr], Maybe Expr)
parse_sequence [Val]
exprs = (Maybe [Val], [[Val]], Maybe [Val]) -> (Expr, [Expr], Maybe Expr)
postproc forall a b. (a -> b) -> a -> b
$
    case forall a. (a -> a) -> [a] -> [a]
Lists.mapTail (forall a. Int -> [a] -> [a]
drop Int
1) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [[a]]
Lists.splitBefore Val -> Bool
is_separator [Val]
exprs of
        [] -> (forall a. Maybe a
Nothing, [], forall a. Maybe a
Nothing)
        [Val]
begin : [[Val]]
rest -> case forall a. [a] -> [a]
reverse [[Val]]
rest of
            [[Val]
middle] -> (forall a. a -> Maybe a
Just [Val]
begin, [[Val]
middle], forall a. Maybe a
Nothing)
            [Val]
end : [[Val]]
middle -> (forall a. a -> Maybe a
Just [Val]
begin, forall a. [a] -> [a]
reverse [[Val]]
middle, forall a. a -> Maybe a
Just [Val]
end)
            [] -> (forall a. a -> Maybe a
Just [Val]
begin, [], forall a. Maybe a
Nothing)
    where
    postproc :: (Maybe [Val], [[Val]], Maybe [Val]) -> (Expr, [Expr], Maybe Expr)
postproc (Maybe [Val]
begin, [[Val]]
middles, Maybe [Val]
end) =
        ( forall a. a -> Maybe a -> a
fromMaybe (Symbol -> [Val] -> Expr
EvaluatedExpr Symbol
"set-pitch" []) forall a b. (a -> b) -> a -> b
$ [Val] -> Maybe Expr
to_expr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Val]
begin
        , [Expr] -> [Expr]
add_hold forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Val] -> Maybe Expr
to_expr [[Val]]
middles
        , [Val] -> Maybe Expr
to_expr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe [Val]
end
        )
    add_hold :: [Expr] -> [Expr]
add_hold [] = [Symbol -> [Val] -> Expr
EvaluatedExpr Symbol
"-" []]
    add_hold [Expr]
xs = [Expr]
xs
    to_expr :: [Val] -> Maybe Expr
to_expr [] = forall a. Maybe a
Nothing
    to_expr (Val
call : [Val]
args) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case Val
call of
        DeriveT.VQuoted (DeriveT.Quoted Expr
expr) -> Expr -> Expr
QuotedExpr Expr
expr
        DeriveT.VStr (Expr.Str Text
sym) -> Symbol -> [Val] -> Expr
EvaluatedExpr (Text -> Symbol
Expr.Symbol Text
sym) [Val]
args
        Val
_ -> Symbol -> [Val] -> Expr
EvaluatedExpr (Text -> Symbol
Expr.Symbol (forall a. ShowVal a => a -> Text
ShowVal.show_val Val
call)) [Val]
args
    is_separator :: Val -> Bool
is_separator Val
DeriveT.VSeparator = Bool
True
    is_separator Val
_ = Bool
False

-- * start

c_flat_start :: Derive.Generator Derive.Pitch
c_flat_start :: Generator Pitch
c_flat_start = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"flat-start" forall a. Monoid a => a
mempty
    Doc
"Emit a flat pitch for the given duration."
    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 deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"pitch" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Emit this pitch, or continue the previous pitch if not given."
    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
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.15)
        Doc
"Pitch lasts for this duration."
    ) forall a b. (a -> b) -> a -> b
$ \(Maybe PitchOrTranspose
maybe_pitch, Typecheck.DefaultReal Duration
time) PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        RealTime
end <- forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime
get_end RealTime
start Duration
time PassedArgs Pitch
args
        RawPitch Untransposed_
pitch <- Maybe PitchOrTranspose
-> RawPitch Untransposed_ -> RawPitch Untransposed_
optional_pitch Maybe PitchOrTranspose
maybe_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch RealTime
start
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(RealTime, RawPitch Untransposed_)] -> Pitch
PSignal.from_pairs [(RealTime
start, RawPitch Untransposed_
pitch), (RealTime
end, RawPitch Untransposed_
pitch)]

c_set_pitch :: Derive.Generator Derive.Pitch
c_set_pitch :: Generator Pitch
c_set_pitch = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"set-pitch" forall a. Monoid a => a
mempty Doc
"Emit the current pitch.\
    \ Sequence pitch calls normally use the previous pitch, and this is an\
    \ implicit begin call so a sequence missing a begin doesn't inherit the\
    \ previous pitch."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 forall a b. (a -> b) -> a -> b
$ \PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        RawPitch Untransposed_
pitch <- RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch RealTime
start
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
start RawPitch Untransposed_
pitch

data PitchFrom = PitchFromPrev | PitchFromCurrent deriving (PitchFrom -> PitchFrom -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PitchFrom -> PitchFrom -> Bool
$c/= :: PitchFrom -> PitchFrom -> Bool
== :: PitchFrom -> PitchFrom -> Bool
$c== :: PitchFrom -> PitchFrom -> Bool
Eq, Int -> PitchFrom -> ShowS
[PitchFrom] -> ShowS
PitchFrom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PitchFrom] -> ShowS
$cshowList :: [PitchFrom] -> ShowS
show :: PitchFrom -> String
$cshow :: PitchFrom -> String
showsPrec :: Int -> PitchFrom -> ShowS
$cshowsPrec :: Int -> PitchFrom -> ShowS
Show)
data Fade = Fade | NoFade deriving (Fade -> Fade -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fade -> Fade -> Bool
$c/= :: Fade -> Fade -> Bool
== :: Fade -> Fade -> Bool
$c== :: Fade -> Fade -> Bool
Eq, Int -> Fade -> ShowS
[Fade] -> ShowS
Fade -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fade] -> ShowS
$cshowList :: [Fade] -> ShowS
show :: Fade -> String
$cshow :: Fade -> String
showsPrec :: Int -> Fade -> ShowS
$cshowsPrec :: Int -> Fade -> ShowS
Show)

c_from :: PitchFrom -> Fade -> Derive.Generator Derive.Pitch
c_from :: PitchFrom -> Fade -> Generator Pitch
c_from PitchFrom
pitch_from Fade
fade = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"from" forall a. Monoid a => a
mempty
    (case PitchFrom
pitch_from of
        PitchFrom
PitchFromPrev -> Doc
"Come for the previous pitch, and possibly fade in."
        PitchFrom
PitchFromCurrent -> Doc
"Come from a pitch, and possibly fade in.")
    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
<$> case PitchFrom
pitch_from of
        PitchFrom
PitchFromPrev -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        PitchFrom
PitchFromCurrent -> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"from" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
            Doc
"Come from this pitch, or the previous one."
    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
"transition" DefaultReal
default_transition Doc
"Time to destination."
    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
"to" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Go to this pitch, or the current one."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(Maybe PitchOrTranspose
from_pitch, Typecheck.DefaultReal Duration
time, Maybe PitchOrTranspose
maybe_to_pitch, Curve
curve)
            PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        RealTime
end <- forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime
get_end RealTime
start Duration
time PassedArgs Pitch
args
        RawPitch Untransposed_
to_pitch <- Maybe PitchOrTranspose
-> RawPitch Untransposed_ -> RawPitch Untransposed_
optional_pitch Maybe PitchOrTranspose
maybe_to_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch RealTime
start
        let from :: RawPitch Untransposed_
from = PassedArgs Pitch
-> RawPitch Untransposed_
-> Maybe PitchOrTranspose
-> RawPitch Untransposed_
resolve_pitch PassedArgs Pitch
args RawPitch Untransposed_
to_pitch Maybe PitchOrTranspose
from_pitch
        case Fade
fade of
            Fade
Fade -> RealTime -> Control -> Deriver State Error ()
ControlUtil.multiply_dyn RealTime
end
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Curve
-> RealTime -> Double -> RealTime -> Double -> Deriver Control
ControlUtil.make_segment Curve
ControlUtil.Linear RealTime
start Double
0 RealTime
end Double
1
            Fade
NoFade -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Curve
-> RealTime
-> RawPitch Untransposed_
-> RealTime
-> RawPitch Untransposed_
-> Deriver Pitch
PitchUtil.make_segment Curve
curve RealTime
start RawPitch Untransposed_
from RealTime
end RawPitch Untransposed_
to_pitch

-- | Get the end time, given a start and a duration.  Don't go beyond the
-- maximum, which is the event's duration, if given explicitly, or the next
-- event if it's 0.
get_end :: RealTime -> DeriveT.Duration -> Derive.PassedArgs a
    -> Derive.Deriver RealTime
get_end :: forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime
get_end RealTime
start Duration
dur PassedArgs a
args = do
    RealTime
time_end <- (RealTime
start +) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
start Duration
dur
    RealTime
max_end <- if forall a. PassedArgs a -> ScoreTime
Args.duration PassedArgs a
args forall a. Eq a => a -> a -> Bool
== ScoreTime
0
        then forall a. Time a => a -> Deriver RealTime
Derive.real forall a b. (a -> b) -> a -> b
$ forall a. PassedArgs a -> ScoreTime
Args.next PassedArgs a
args
        else forall a. PassedArgs a -> Deriver RealTime
Args.real_end PassedArgs a
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min RealTime
time_end RealTime
max_end

{-
    Reliance on the underlying pitch is awkward.  E.g. jaru and p go to 0, but
    sometimes the hold is at -1 or something.  This also leads to kam not being
    able to assume the base.  Maybe there should be a generic way to transpose
    the base pitch.  Or set the middle:

    > j 1 2; -1; p> -- Jaru 1 2 to -1, hold -1, then to 0
    > j 1 2; k^ -1 1; p> -- Jaru 1 2, kam -1 1, to 0

    So maybe the 'from' calls need to know what the first middle pitch is, so
    they can go to it.

    Or kam can start with the previous pitch, just like hold does:

    > j 1 2 -1; - ; p> -- Jaru 1 2 to -1, hold -1, then to 0
    > j 1 2 -1; k^ 0 2; p> -- Jaru 1 2, kam -1 1, to 0

    Since it starts with 0 I can omit:

    > j 1 2 -1; k^ 2; p> -- Jaru 1 2, kam -1 1, to 0

    I think it doesn't read as nicely because each call depends on the previous
    one, and 'j' needs an extra arg.  On the other hand, how is 'start'
    supposed to know the starting pitch of 'middle', especially when 'middle'
    may want to rely on the previous pitch?  I guess the two approaches are
    incompatible.  So to do it that way, I'd need to make middle calls not
    rely on prev_pitch, do a speculative middle eval, and communicate next
    pitch to the 'begin' call via an env var or something.  Seems too
    complicated.
-}

c_jaru :: Bool -> Derive.Generator Derive.Pitch
c_jaru :: Bool -> Generator Pitch
c_jaru Bool
append_zero = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"jaru" forall a. Monoid a => a
mempty
    Doc
"This is a series of grace notes whose pitches are relative to the\
    \ base pitch. The 0 variant appends a 0 on the end."
    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 (NonEmpty a)
Sig.many1 ArgName
"interval" Doc
"Intervals from base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"time" EnvironDefault
Sig.Both DefaultReal
default_transition Doc
"Time for each note."
    -- TODO This should also be a Duration
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"transition" EnvironDefault
Sig.Both (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Time for each slide, defaults to `time`."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(NonEmpty DefaultDiatonic
intervals, Typecheck.DefaultReal Duration
time_, Maybe RealTime
maybe_transition, Curve
curve)
            PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        -- Adjust time per note based on the available duration.
        -- Since transitions can start at 0 and end at the end, I'm dividing
        -- the duration into intervals-1 parts.
        let len :: Int
len = forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty DefaultDiatonic
intervals forall a. Num a => a -> a -> a
- Int
1
        RealTime
end <- forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime
get_end RealTime
start
            (Duration -> Double -> Duration
DeriveT.multiply_duration Duration
time_ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)) PassedArgs Pitch
args
        let time :: RealTime
time = (RealTime
end forall a. Num a => a -> a -> a
- RealTime
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
        RawPitch Untransposed_
pitch <- RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch RealTime
start
        RealTime
srate <- Deriver RealTime
Call.get_srate
        (NonEmpty Double
intervals, Control
control) <- NonEmpty DefaultDiatonic
-> Deriver State Error (NonEmpty Double, Control)
parse NonEmpty DefaultDiatonic
intervals
        let transition :: RealTime
transition = forall a. a -> Maybe a -> a
fromMaybe RealTime
time Maybe RealTime
maybe_transition
        let sig :: Control
sig = Curve
-> RealTime
-> RealTime
-> RealTime
-> RealTime
-> [Double]
-> Control
jaru Curve
curve RealTime
srate RealTime
start RealTime
time RealTime
transition forall a b. (a -> b) -> a -> b
$
                forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Double
intervals forall a. [a] -> [a] -> [a]
++ if Bool
append_zero then [Double
0] else []
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> Pitch -> Pitch
PSignal.apply_control Control
control (forall a. a -> Typed a
ScoreT.untyped Control
sig) forall a b. (a -> b) -> a -> b
$
            RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
start RawPitch Untransposed_
pitch
    where
    parse :: NonEmpty DefaultDiatonic
-> Deriver State Error (NonEmpty Double, Control)
parse NonEmpty DefaultDiatonic
intervals
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Control
control) [Control]
controls = forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty Double
xs, Control
control)
        | Bool
otherwise = forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"all intervals must have the same type"
        where
        (NonEmpty Double
xs, Control
control :| [Control]
controls) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NonEmpty.unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map
            (Transpose -> (Double, Control)
Controls.transpose_control forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultDiatonic -> Transpose
Typecheck.default_diatonic)
            NonEmpty DefaultDiatonic
intervals

jaru :: ControlUtil.Curve -> RealTime -> RealTime -> RealTime -> RealTime
    -> [Signal.Y] -> Signal.Control
jaru :: Curve
-> RealTime
-> RealTime
-> RealTime
-> RealTime
-> [Double]
-> Control
jaru Curve
curve RealTime
srate RealTime
start RealTime
time RealTime
transition [Double]
intervals =
    Curve -> RealTime -> RealTime -> [(RealTime, Double)] -> Control
ControlUtil.smooth_absolute Curve
curve RealTime
srate (-RealTime
transition) forall a b. (a -> b) -> a -> b
$
        forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ RealTime
start RealTime
time) [Double]
intervals

-- * middle

c_flat :: Derive.Generator Derive.Pitch
c_flat :: Generator Pitch
c_flat = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"flat" forall a. Monoid a => a
mempty Doc
"Emit a flat pitch."
    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 a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"pitch" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Emit this pitch, or continue the previous pitch if not given.")
    forall a b. (a -> b) -> a -> b
$ \Maybe PitchOrTranspose
maybe_pitch PassedArgs Pitch
args -> do
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        RealTime
end <- forall a. PassedArgs a -> Deriver RealTime
Args.real_end PassedArgs Pitch
args
        RawPitch Untransposed_
pitch <- case Maybe PitchOrTranspose
maybe_pitch of
            Maybe PitchOrTranspose
Nothing -> RealTime
-> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_)
prev_pitch RealTime
start PassedArgs Pitch
args
            Just PitchOrTranspose
transpose -> do
                RawPitch Untransposed_
pitch <- RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch RealTime
start
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RawPitch Untransposed_
-> PitchOrTranspose -> RawPitch Untransposed_
PitchUtil.resolve_pitch_transpose RawPitch Untransposed_
pitch PitchOrTranspose
transpose
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(RealTime, RawPitch Untransposed_)] -> Pitch
PSignal.from_pairs [(RealTime
start, RawPitch Untransposed_
pitch), (RealTime
end, RawPitch Untransposed_
pitch)]

-- ** kampita

data KampitaArgs =
    -- | Both interval arguments are hardcoded.
    Kampita0 !Signal.Y !Signal.Y
    -- | The starting pitch is hardcoded.
    | Kampita1 !Signal.Y
    -- | Both arguments must be provided.
    | Kampita2
    deriving (Int -> KampitaArgs -> ShowS
[KampitaArgs] -> ShowS
KampitaArgs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KampitaArgs] -> ShowS
$cshowList :: [KampitaArgs] -> ShowS
show :: KampitaArgs -> String
$cshow :: KampitaArgs -> String
showsPrec :: Int -> KampitaArgs -> ShowS
$cshowsPrec :: Int -> KampitaArgs -> ShowS
Show)

c_kampita:: Doc.Doc -> KampitaArgs -> Maybe Trill.Direction
    -> Derive.Generator Derive.Pitch
c_kampita :: Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_kampita Doc
doc KampitaArgs
kam_args Maybe Direction
end_dir = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"kam" forall a. Monoid a => a
mempty
    (Doc
"This is a kind of trill, but its interval defaults to NNs,\
    \ and transitions between the notes are smooth.  It's intended for\
    \ the vocal microtonal trills common in Carnatic music."
    forall a. Semigroup a => a -> a -> a
<> if Doc
doc forall a. Eq a => a -> a -> Bool
== Doc
"" then Doc
"" else Doc
"\n" forall a. Semigroup a => a -> a -> a
<> 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 ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KampitaArgs -> Parser (NnTransposeFunctionT, NnTransposeFunctionT)
kampita_pitch_args KampitaArgs
kam_args
    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
"speed" (Double
6 :: Double) Doc
"Alternate pitches at this speed."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (RealTime, Duration, Double, Adjust)
kampita_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \((NnTransposeFunctionT, NnTransposeFunctionT)
pitches, RealTimeFunctionT
speed, (RealTime
transition, Duration
hold, Double
lilt, Adjust
adjust), Curve
curve) PassedArgs Pitch
args -> do
        ((Function, Function)
pitches, Control
control) <- KampitaArgs
-> (NnTransposeFunctionT, NnTransposeFunctionT)
-> Deriver ((Function, Function), Control)
resolve_pitches KampitaArgs
kam_args (NnTransposeFunctionT, NnTransposeFunctionT)
pitches
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Pitch
args
        let even :: Maybe Bool
even = RealTime -> (Function, Function) -> Maybe Direction -> Maybe Bool
end_wants_even_transitions RealTime
start (Function, Function)
pitches Maybe Direction
end_dir
        Control
transpose <- Curve
-> Maybe Bool
-> Adjust
-> (Function, Function)
-> RealTimeFunctionT
-> RealTime
-> Duration
-> Double
-> (ScoreTime, ScoreTime)
-> Deriver Control
kampita_transpose Curve
curve Maybe Bool
even Adjust
adjust (Function, Function)
pitches RealTimeFunctionT
speed
            RealTime
transition Duration
hold Double
lilt (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Pitch
args)
        RealTime -> PassedArgs Pitch -> Control -> Control -> Deriver Pitch
kampita RealTime
start PassedArgs Pitch
args Control
control Control
transpose

c_nkampita :: Doc.Doc -> KampitaArgs -> Maybe Trill.Direction
    -> Derive.Generator Derive.Pitch
c_nkampita :: Doc -> KampitaArgs -> Maybe Direction -> Generator Pitch
c_nkampita Doc
doc KampitaArgs
kam_args Maybe Direction
end_dir = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"nkam" forall a. Monoid a => a
mempty
    (Doc
"`kam` with a set number of cycles. The speed adjusts to fit the cycles in\
    \ before the next event."
    forall a. Semigroup a => a -> a -> a
<> if Doc
doc forall a. Eq a => a -> a -> Bool
== Doc
"" then Doc
"" else Doc
"\n" forall a. Semigroup a => a -> a -> a
<> 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 ((,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Positive a -> a
Typecheck.positive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"cycles" (Double
1 :: Double)
        Doc
"Number of cycles.")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KampitaArgs -> Parser (NnTransposeFunctionT, NnTransposeFunctionT)
kampita_pitch_args KampitaArgs
kam_args
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (RealTime, Duration, Double, Adjust)
kampita_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Curve
ControlUtil.curve_env
    ) forall a b. (a -> b) -> a -> b
$ \(Double
cycles, (NnTransposeFunctionT, NnTransposeFunctionT)
pitches, (RealTime
transition, Duration
hold, Double
lilt, Adjust
adjust), Curve
curve) PassedArgs Pitch
args -> do
        ((Function, Function)
pitches, Control
control) <- KampitaArgs
-> (NnTransposeFunctionT, NnTransposeFunctionT)
-> Deriver ((Function, Function), Control)
resolve_pitches KampitaArgs
kam_args (NnTransposeFunctionT, NnTransposeFunctionT)
pitches
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range_or_next PassedArgs Pitch
args
        let even :: Maybe Bool
even = RealTime -> (Function, Function) -> Maybe Direction -> Maybe Bool
end_wants_even_transitions RealTime
start (Function, Function)
pitches Maybe Direction
end_dir
        -- 1 cycle means a complete cycle, which is 3 transitions, but
        -- 'end_dir' may reduce the number of transitions, to a minimum of 2,
        -- which winds up sounding like a single transition: [0, 1].
        let num_transitions :: Double
num_transitions = Double
cycles forall a. Num a => a -> a -> a
* Double
2 forall a. Num a => a -> a -> a
+ if Maybe Bool
even forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True then Double
0 else Double
1
        let speed :: RealTimeFunctionT
speed = TimeT -> Function -> RealTimeFunctionT
Typecheck.RealTimeFunctionT TimeT
ScoreT.TReal
                (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ (Double
num_transitions forall a. Num a => a -> a -> a
- Double
1)
                    forall a. Fractional a => a -> a -> a
/ Function
RealTime.to_seconds (RealTime
end forall a. Num a => a -> a -> a
- RealTime
start))
        Control
transpose <- Curve
-> Maybe Bool
-> Adjust
-> (Function, Function)
-> RealTimeFunctionT
-> RealTime
-> Duration
-> Double
-> (ScoreTime, ScoreTime)
-> Deriver Control
kampita_transpose Curve
curve Maybe Bool
even Adjust
adjust (Function, Function)
pitches RealTimeFunctionT
speed
            RealTime
transition Duration
hold Double
lilt (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range PassedArgs Pitch
args)
        RealTime -> PassedArgs Pitch -> Control -> Control -> Deriver Pitch
kampita RealTime
start PassedArgs Pitch
args Control
control Control
transpose

-- ** implementation

resolve_pitches :: KampitaArgs
    -> (Typecheck.NnTransposeFunctionT, Typecheck.NnTransposeFunctionT)
    -> Derive.Deriver ((ScoreT.Function, ScoreT.Function), ScoreT.Control)
resolve_pitches :: KampitaArgs
-> (NnTransposeFunctionT, NnTransposeFunctionT)
-> Deriver ((Function, Function), Control)
resolve_pitches KampitaArgs
kam_args
        ( Typecheck.NnTransposeFunctionT TransposeT
ttype1 Function
pitch1
        , Typecheck.NnTransposeFunctionT TransposeT
ttype2 Function
pitch2) = do
    let control1 :: Control
control1 = TransposeT -> Control
Typecheck.transpose_control TransposeT
ttype1
    let control2 :: Control
control2 = TransposeT -> Control
Typecheck.transpose_control TransposeT
ttype2
    let two_pitches :: Bool
two_pitches = case KampitaArgs
kam_args of
            KampitaArgs
Kampita2 -> Bool
False
            KampitaArgs
_ -> Bool
True
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
two_pitches Bool -> Bool -> Bool
&& Control
control1 forall a. Eq a => a -> a -> Bool
/= Control
control2) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$
        Text
"pitch1 and pitch2 signals should have the same type: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Control
control1 forall a. Semigroup a => a -> a -> a
<> Text
" /= " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Control
control2
    forall (m :: * -> *) a. Monad m => a -> m a
return ((Function
pitch1, Function
pitch2), Control
control1)

kampita_pitch_args :: KampitaArgs
    -> Sig.Parser
        (Typecheck.NnTransposeFunctionT, Typecheck.NnTransposeFunctionT)
kampita_pitch_args :: KampitaArgs -> Parser (NnTransposeFunctionT, NnTransposeFunctionT)
kampita_pitch_args KampitaArgs
kam_args = case KampitaArgs
kam_args of
    Kampita0 Double
p1 Double
p2 -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> NnTransposeFunctionT
control Double
p1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> NnTransposeFunctionT
control Double
p2)
    Kampita1 Double
p1 -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> NnTransposeFunctionT
control Double
p1)
        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
"neighbor" (Double
1 :: Double)
            Doc
"Alternate with a pitch at this interval."
    KampitaArgs
Kampita2 -> (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"pitch1" (Double
0 :: Double) Doc
"First interval."
        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
"pitch2" (Double
1 :: Double) Doc
"Second interval."
    where
    control :: Double -> NnTransposeFunctionT
control Double
val = TransposeT -> Function -> NnTransposeFunctionT
Typecheck.NnTransposeFunctionT TransposeT
ScoreT.TNn (forall a b. a -> b -> a
const Double
val)

kampita_env :: Sig.Parser (RealTime, DeriveT.Duration, Double, Trill.Adjust)
kampita_env :: Parser (RealTime, Duration, Double, Adjust)
kampita_env = (,,,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"transition" EnvironDefault
Sig.Both RealTime
default_transition_
        Doc
"Time for each slide."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
Trill.hold_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Double
lilt_env forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Adjust
Trill.adjust_env
    where
    lilt_env :: Sig.Parser Double
    lilt_env :: Parser Double
lilt_env = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"lilt" EnvironDefault
Sig.Prefixed (Double
0 :: Double)
        Doc
"Lilt is a horizontal bias to the vibrato. A lilt of 1 would place\
        \ each neighbor on top of the following unison, while -1 would place\
        \ it on the previous one. So it should range from -1 < lilt < 1."

default_transition :: Typecheck.DefaultReal
default_transition :: DefaultReal
default_transition = RealTime -> DefaultReal
Typecheck.real RealTime
default_transition_

default_transition_ :: RealTime
default_transition_ :: RealTime
default_transition_ = RealTime
0.12

kampita :: RealTime -> Derive.PitchArgs -> ScoreT.Control -> Signal.Control
    -> Derive.Deriver PSignal.PSignal
kampita :: RealTime -> PassedArgs Pitch -> Control -> Control -> Deriver Pitch
kampita RealTime
start PassedArgs Pitch
args Control
control Control
transpose = do
    RawPitch Untransposed_
pitch <- RealTime
-> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_)
prev_pitch RealTime
start PassedArgs Pitch
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> Pitch -> Pitch
PSignal.apply_control Control
control (forall a. a -> Typed a
ScoreT.untyped Control
transpose) forall a b. (a -> b) -> a -> b
$
        RealTime -> RawPitch Untransposed_ -> Pitch
PSignal.from_sample RealTime
start RawPitch Untransposed_
pitch

-- | You don't think there are too many arguments, do you?
kampita_transpose :: ControlUtil.Curve -> Maybe Bool -> Trill.Adjust
    -> (ScoreT.Function, ScoreT.Function) -> Typecheck.RealTimeFunctionT
    -> RealTime -> DeriveT.Duration -> Double -> (ScoreTime, ScoreTime)
    -> Derive.Deriver Signal.Control
kampita_transpose :: Curve
-> Maybe Bool
-> Adjust
-> (Function, Function)
-> RealTimeFunctionT
-> RealTime
-> Duration
-> Double
-> (ScoreTime, ScoreTime)
-> Deriver Control
kampita_transpose Curve
curve Maybe Bool
even Adjust
adjust (Function
pitch1, Function
pitch2) RealTimeFunctionT
speed RealTime
transition Duration
hold Double
lilt
        (ScoreTime
start, ScoreTime
end) = do
    ScoreTime
hold <- forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver ScoreTime
Call.score_duration ScoreTime
start Duration
hold
    Curve
-> RealTime
-> Function
-> Function
-> [RealTime]
-> Deriver Control
smooth_trill Curve
curve (-RealTime
transition) Function
pitch1 Function
pitch2
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Bool
-> Adjust
-> Double
-> ScoreTime
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
trill_transitions Maybe Bool
even Adjust
adjust Double
lilt ScoreTime
hold RealTimeFunctionT
speed (ScoreTime
start, ScoreTime
end)

smooth_trill :: ControlUtil.Curve -> RealTime -> ScoreT.Function
    -> ScoreT.Function -> [RealTime] -> Derive.Deriver Signal.Control
smooth_trill :: Curve
-> RealTime
-> Function
-> Function
-> [RealTime]
-> Deriver Control
smooth_trill Curve
curve RealTime
time Function
val1 Function
val2 [RealTime]
transitions = do
    RealTime
srate <- Deriver RealTime
Call.get_srate
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> RealTime -> RealTime -> [(RealTime, Double)] -> Control
ControlUtil.smooth_absolute Curve
curve RealTime
srate RealTime
time forall a b. (a -> b) -> a -> b
$
        Function -> Function -> [RealTime] -> [(RealTime, Double)]
trill_from_transitions Function
val1 Function
val2 [RealTime]
transitions

-- | Make a trill signal from a list of transition times.
trill_from_transitions :: ScoreT.Function -> ScoreT.Function
    -> [RealTime] -> [(RealTime, Signal.Y)]
trill_from_transitions :: Function -> Function -> [RealTime] -> [(RealTime, Double)]
trill_from_transitions Function
val1 Function
val2 [RealTime]
transitions =
    [(RealTime
x, Function
sig RealTime
x) | (RealTime
x, Function
sig) <- forall a b. [a] -> [b] -> [(a, b)]
zip [RealTime]
transitions (forall a. [a] -> [a]
cycle [Function
val1, Function
val2])]

trill_transitions :: Maybe Bool -> Trill.Adjust -> Double -> ScoreTime
    -> Typecheck.RealTimeFunctionT -> (ScoreTime, ScoreTime)
    -> Derive.Deriver [RealTime]
trill_transitions :: Maybe Bool
-> Adjust
-> Double
-> ScoreTime
-> RealTimeFunctionT
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
trill_transitions Maybe Bool
even Adjust
adjust Double
bias ScoreTime
hold RealTimeFunctionT
speed (ScoreTime, ScoreTime)
start_end =
    Config
-> ScoreTime
-> Maybe Bool
-> (ScoreTime, ScoreTime)
-> Deriver [RealTime]
Trill.adjusted_transitions Config
config ScoreTime
hold Maybe Bool
even (ScoreTime, ScoreTime)
start_end
    where
    config :: Config
config = Trill.Config
        { _start_dir :: Maybe Direction
_start_dir = forall a. Maybe a
Nothing
        , _end_dir :: Maybe Direction
_end_dir = forall a. Maybe a
Nothing
        , _adjust :: Adjust
_adjust = Adjust
adjust
        , _hold :: Duration
_hold = ScoreTime -> Duration
DeriveT.ScoreDuration ScoreTime
0
        , _speed :: RealTimeFunctionT
_speed = RealTimeFunctionT
speed
        , _bias :: Double
_bias = Double
bias
        -- Trills usually omit the transition that coincides with the end
        -- because that would create a zero duration note.  But these trills
        -- are smoothed and thus will still have a segment leading to the
        -- cut-off transition.
        , _include_end :: Bool
_include_end = Bool
True
        }

end_wants_even_transitions :: RealTime -> (ScoreT.Function, ScoreT.Function)
    -> Maybe Trill.Direction -> Maybe Bool
end_wants_even_transitions :: RealTime -> (Function, Function) -> Maybe Direction -> Maybe Bool
end_wants_even_transitions RealTime
start (Function
pitch1, Function
pitch2) Maybe Direction
dir = case Maybe Direction
dir of
    Maybe Direction
Nothing -> forall a. Maybe a
Nothing
    Just Direction
Trill.Low -> forall a. a -> Maybe a
Just (Bool -> Bool
not Bool
pitch1_low)
    Just Direction
Trill.High -> forall a. a -> Maybe a
Just Bool
pitch1_low
    where pitch1_low :: Bool
pitch1_low = Function
pitch1 RealTime
start forall a. Ord a => a -> a -> Bool
<= Function
pitch2 RealTime
start

-- * end

c_flat_end :: Derive.Generator Derive.Pitch
c_flat_end :: Generator Pitch
c_flat_end = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"flat-end" forall a. Monoid a => a
mempty
    Doc
"Emit a flat pitch for the given duration."
    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 deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"pitch" (forall a. Maybe a
Nothing :: Maybe Sig.Dummy)
        Doc
"Emit this pitch, or continue the previous pitch if not given."
    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
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.15)
        Doc
"Pitch lasts for this duration."
    ) forall a b. (a -> b) -> a -> b
$ \(Maybe PitchOrTranspose
maybe_pitch, Typecheck.DefaultReal Duration
time) PassedArgs Pitch
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range PassedArgs Pitch
args
        RealTime
start <- RealTime -> RealTime -> Duration -> Deriver RealTime
align_to_end RealTime
start RealTime
end Duration
time
        RawPitch Untransposed_
pitch <- Maybe PitchOrTranspose
-> RawPitch Untransposed_ -> RawPitch Untransposed_
optional_pitch Maybe PitchOrTranspose
maybe_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime
-> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_)
prev_pitch RealTime
start PassedArgs Pitch
args
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(RealTime, RawPitch Untransposed_)] -> Pitch
PSignal.from_pairs [(RealTime
start, RawPitch Untransposed_
pitch), (RealTime
end, RawPitch Untransposed_
pitch)]

c_to :: Fade -> Derive.Generator Derive.Pitch
c_to :: Fade -> Generator Pitch
c_to Fade
fade = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"to" forall a. Monoid a => a
mempty Doc
"Go to a pitch, and possibly fade out."
    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
"pitch" Doc
"Go to this pitch or interval."
    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
"transition" DefaultReal
default_transition
        Doc
"Time to destination pitch."
    ) forall a b. (a -> b) -> a -> b
$ \(PitchOrTranspose
to_pitch, Typecheck.DefaultReal Duration
time) PassedArgs Pitch
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range PassedArgs Pitch
args
        RealTime
start <- RealTime -> RealTime -> Duration -> Deriver RealTime
align_to_end RealTime
start RealTime
end Duration
time
        RawPitch Untransposed_
pitch <- RealTime
-> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_)
prev_pitch RealTime
start PassedArgs Pitch
args
        case Fade
fade of
            Fade
Fade -> RealTime -> Control -> Deriver State Error ()
ControlUtil.multiply_dyn RealTime
end
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Curve
-> RealTime -> Double -> RealTime -> Double -> Deriver Control
ControlUtil.make_segment Curve
ControlUtil.Linear RealTime
start Double
1 RealTime
end Double
0
            Fade
NoFade -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Curve
-> RealTime
-> RawPitch Untransposed_
-> RealTime
-> RawPitch Untransposed_
-> Deriver Pitch
PitchUtil.make_segment Curve
ControlUtil.Linear RealTime
start RawPitch Untransposed_
pitch RealTime
end
            (RawPitch Untransposed_
-> PitchOrTranspose -> RawPitch Untransposed_
PitchUtil.resolve_pitch_transpose RawPitch Untransposed_
pitch PitchOrTranspose
to_pitch)

c_fade :: Bool -> Derive.Generator Derive.Pitch
c_fade :: Bool -> Generator Pitch
c_fade Bool
fade_in = forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 CallName
"fade" forall a. Monoid a => a
mempty
    ((if Bool
fade_in then Doc
"Fade in." else Doc
"Fade out.")
    forall a. Semigroup a => a -> a -> a
<> Doc
" This will overlap with the pitch part of the "
    forall a. Semigroup a => a -> a -> a
<> (if Bool
fade_in then Doc
"next" else Doc
"previous") forall a. Semigroup a => a -> a -> a
<> Doc
" call."
    ) 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 a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.15) Doc
"Time to fade.")
    forall a b. (a -> b) -> a -> b
$ \(Typecheck.DefaultReal Duration
time) PassedArgs Pitch
args -> do
        (RealTime
start, RealTime
end) <- forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range PassedArgs Pitch
args
        (RealTime
start, RealTime
end) <- if Bool
fade_in
            then (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => a -> m a
return RealTime
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. RealTime -> Duration -> PassedArgs a -> Deriver RealTime
get_end RealTime
start Duration
time PassedArgs Pitch
args
            else (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> RealTime -> Duration -> Deriver RealTime
align_to_end RealTime
start RealTime
end Duration
time forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Monad m => a -> m a
return RealTime
end
        RealTime -> Control -> Deriver State Error ()
ControlUtil.multiply_dyn RealTime
end
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Curve
-> RealTime -> Double -> RealTime -> Double -> Deriver Control
ControlUtil.make_segment Curve
ControlUtil.Linear RealTime
start Double
1 RealTime
end Double
0
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

-- | Subtract the duration from the given end time, but don't go past the
-- start.
align_to_end :: RealTime -> RealTime -> DeriveT.Duration
    -> Derive.Deriver RealTime
align_to_end :: RealTime -> RealTime -> Duration -> Deriver RealTime
align_to_end RealTime
start RealTime
end Duration
dur = do
    RealTime
dur <- forall a. Ord a => a -> a -> a
min (RealTime
end forall a. Num a => a -> a -> a
- RealTime
start) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t1 t2. (Time t1, Time t2) => t1 -> t2 -> Deriver RealTime
Call.real_duration RealTime
start Duration
dur
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RealTime
end forall a. Num a => a -> a -> a
- RealTime
dur

-- * misc

c_sahitya :: Derive.Taggable a => Derive.Transformer a
c_sahitya :: forall a. Taggable a => Transformer a
c_sahitya = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
module_ CallName
"sahitya" forall a. Monoid a => a
mempty
    Doc
"Ignore the transformed deriver. Put this on a track to ignore its\
    \ contents, and put in sahitya."
    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 a
_args Deriver (Stream a)
_deriver -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Stream a
Stream.empty

-- * util

-- | This defaults to the note's base pitch, in case this call is the first
-- one.  Also, the end call is called before the middle calls to find out how
-- long it is.
prev_pitch :: RealTime -> Derive.PitchArgs -> Derive.Deriver PSignal.Pitch
prev_pitch :: RealTime
-> PassedArgs Pitch -> Deriver State Error (RawPitch Untransposed_)
prev_pitch RealTime
start PassedArgs Pitch
args = case PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_)
Args.prev_pitch PassedArgs Pitch
args of
    Maybe (RealTime, RawPitch Untransposed_)
Nothing -> RealTime -> Deriver State Error (RawPitch Untransposed_)
Call.get_pitch RealTime
start
    Just (RealTime
_, RawPitch Untransposed_
pitch) -> forall (m :: * -> *) a. Monad m => a -> m a
return RawPitch Untransposed_
pitch

resolve_pitch :: Derive.PitchArgs -> PSignal.Pitch
    -> Maybe PitchUtil.PitchOrTranspose -> PSignal.Pitch
resolve_pitch :: PassedArgs Pitch
-> RawPitch Untransposed_
-> Maybe PitchOrTranspose
-> RawPitch Untransposed_
resolve_pitch PassedArgs Pitch
args RawPitch Untransposed_
this_pitch Maybe PitchOrTranspose
maybe_pitch = case Maybe PitchOrTranspose
maybe_pitch of
    Maybe PitchOrTranspose
Nothing -> case PassedArgs Pitch -> Maybe (RealTime, RawPitch Untransposed_)
Args.prev_pitch PassedArgs Pitch
args of
        Maybe (RealTime, RawPitch Untransposed_)
Nothing -> RawPitch Untransposed_
this_pitch
        Just (RealTime
_, RawPitch Untransposed_
prev) -> RawPitch Untransposed_
prev
    Just (Left RawPitch Untransposed_
pitch) -> RawPitch Untransposed_
pitch
    Just (Right Transpose
transpose) -> forall a. Transpose -> RawPitch a -> RawPitch a
Pitches.transpose Transpose
transpose RawPitch Untransposed_
this_pitch

-- | A number of calls take an optional pitch, and default to either
-- the current or previous pitch.
optional_pitch :: Maybe PitchUtil.PitchOrTranspose -> PSignal.Pitch
    -> PSignal.Pitch
optional_pitch :: Maybe PitchOrTranspose
-> RawPitch Untransposed_ -> RawPitch Untransposed_
optional_pitch Maybe PitchOrTranspose
maybe_pitch RawPitch Untransposed_
current_pitch =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawPitch Untransposed_
current_pitch (RawPitch Untransposed_
-> PitchOrTranspose -> RawPitch Untransposed_
PitchUtil.resolve_pitch_transpose RawPitch Untransposed_
current_pitch)
        Maybe PitchOrTranspose
maybe_pitch

generator1 :: Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Derive.WithArgDoc (Derive.PassedArgs d -> Derive.Deriver d)
    -> Derive.Call (Derive.GeneratorFunc d)
generator1 :: forall d.
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Call (GeneratorFunc d)
generator1 = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
module_