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

module Derive.C.Prelude.Val (library) where
import qualified Data.Attoparsec.Text as A
import qualified Data.Map as Map

import qualified Util.Doc as Doc
import qualified Util.ParseText as ParseText
import qualified Util.Seq as Seq

import qualified Derive.Args as Args
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.PitchUtil as PitchUtil
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.PSignal as PSignal
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Theory as Theory
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 Derive.ValType as ValType

import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import qualified Ui.Event as Event
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


library :: Library.Library
library :: Library
library = [(Symbol, ValCall)] -> Library
Library.vals
    [ (Symbol
">", ValCall
c_next_val)
    , (Symbol
"<", ValCall
c_prev_val)
    , (Symbol
"bpm", ValCall
c_bpm)
    , (Symbol
"env", ValCall
c_env)
    , (Symbol
"ts", ValCall
c_timestep)
    , (Symbol
"ts/", ValCall
c_timestep_reciprocal)
    , (Symbol
"1/", ValCall
c_reciprocal)
    , (Symbol
"nn", ValCall
c_nn)
    , (Symbol
"hz", ValCall
c_hz)
    -- literals
    , (Symbol
"list", ValCall
c_list)
    , (Symbol
"lrange", ValCall
c_lrange)
    , (Symbol
"st", ValCall
c_scoretime)
    , (Symbol
"rt", ValCall
c_realtime)
    , (Symbol
"pitch", ValCall
c_pitch)
    , (Symbol
"#", ValCall
c_pcontrol_ref)
    -- lookup
    , (Symbol
"<-#", ValCall
c_get_pitch)
    -- generate signals
    , (Symbol
"i>", ValCall
c_linear_next)
    , (Symbol
"e>", ValCall
c_exp_next)
    , (Symbol
"df", ValCall
c_down_from)
    ]

c_next_val :: Derive.ValCall
c_next_val :: ValCall
c_next_val = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"next-val" Tags
Tags.next
    Doc
"Evaluate the next event. Only works on pitch and control tracks, and\
    \ if the next event doesn't need its previous event."
    (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$ (PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 ((PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> (PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \PassedArgs Tagged
args -> do
        Event
event <- Text -> Maybe Event -> Deriver Event
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"no next event" (Maybe Event -> Deriver Event) -> Maybe Event -> Deriver Event
forall a b. (a -> b) -> a -> b
$
            [Event] -> Maybe Event
forall a. [a] -> Maybe a
Seq.head (PassedArgs Tagged -> [Event]
forall a. PassedArgs a -> [Event]
Args.next_events PassedArgs Tagged
args)
        RealTime
start <- ScoreTime -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Derive.real (Event -> ScoreTime
Event.start Event
event)
        Event -> RealTime -> Maybe Type -> Deriver Val
next_val Event
event RealTime
start (Context Tagged -> Maybe Type
forall val. Context val -> Maybe Type
Derive.ctx_track_type (PassedArgs Tagged -> Context Tagged
forall val. PassedArgs val -> Context val
Derive.passed_ctx PassedArgs Tagged
args))

next_val :: Event.Event -> RealTime -> Maybe ParseTitle.Type
    -> Derive.Deriver DeriveT.Val
next_val :: Event -> RealTime -> Maybe Type -> Deriver Val
next_val Event
event RealTime
start Maybe Type
ttype = case Maybe Type
ttype of
    Just Type
ParseTitle.ControlTrack -> RealTime -> Event -> Deriver Val
eval_control RealTime
start Event
event
    Just Type
ParseTitle.TempoTrack -> RealTime -> Event -> Deriver Val
eval_control RealTime
start Event
event
    Just Type
ParseTitle.PitchTrack -> do
        PSignal
signal <- Event -> Deriver State Error PSignal
forall {b}.
(Monoid b, Callable (Transformer b), Callable (Generator b),
 Callable (TrackCall b), Taggable b) =>
Event -> Deriver State Error b
eval Event
event
        case RealTime -> PSignal -> Maybe Pitch
PSignal.at RealTime
start PSignal
signal of
            Maybe Pitch
Nothing -> Text -> Deriver Val
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"next pitch event didn't emit a pitch"
            Just Pitch
pitch -> Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> Val -> Deriver Val
forall a b. (a -> b) -> a -> b
$ Pitch -> Val
DeriveT.VPitch Pitch
pitch
    Just Type
ParseTitle.NoteTrack ->
        Text -> Deriver Val
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"can't get next value for note tracks"
    Maybe Type
Nothing -> Text -> Deriver Val
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no track type"
    where
    eval_control :: RealTime -> Event -> Deriver Val
eval_control RealTime
start Event
event = do
        Control
signal <- Event -> Deriver State Error Control
forall {b}.
(Monoid b, Callable (Transformer b), Callable (Generator b),
 Callable (TrackCall b), Taggable b) =>
Event -> Deriver State Error b
eval Event
event
        Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> Val -> Deriver Val
forall a b. (a -> b) -> a -> b
$ Typed Y -> Val
DeriveT.VNum (Typed Y -> Val) -> Typed Y -> Val
forall a b. (a -> b) -> a -> b
$ Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped (Y -> Typed Y) -> Y -> Typed Y
forall a b. (a -> b) -> a -> b
$
            RealTime -> Control -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
start (Control
signal :: Signal.Control)
    eval :: Event -> Deriver State Error b
eval Event
event = [b] -> b
forall a. Monoid a => [a] -> a
mconcat ([b] -> b) -> (Stream b -> [b]) -> Stream b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream b -> [b]
forall a. Stream a -> [a]
Stream.events_of (Stream b -> b)
-> Deriver State Error (Stream b) -> Deriver State Error b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ((Text -> Deriver State Error (Stream b))
-> (Stream b -> Deriver State Error (Stream b))
-> Either Text (Stream b)
-> Deriver State Error (Stream b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Deriver State Error (Stream b)
forall a. HasCallStack => Text -> Deriver a
Derive.throw Stream b -> Deriver State Error (Stream b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Stream b) -> Deriver State Error (Stream b))
-> Deriver State Error (Either Text (Stream b))
-> Deriver State Error (Stream b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Event -> Deriver State Error (Either Text (Stream b))
forall d.
CallableExpr d =>
Event -> Deriver (Either Text (Stream d))
Eval.eval_event Event
event)

c_prev_val :: Derive.ValCall
c_prev_val :: ValCall
c_prev_val = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"prev-val" Tags
Tags.prev
    Doc
"Return the previous value. Only works on pitch and control tracks."
    (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$ (PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y d.
Taggable y =>
Generator y d -> WithArgDoc (Generator y d)
Sig.call0 ((PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> (PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \PassedArgs Tagged
args -> do
        RealTime
start <- PassedArgs Tagged -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Tagged
args
        case PassedArgs Tagged -> Maybe Tagged
forall a. PassedArgs a -> Maybe a
Args.prev_val PassedArgs Tagged
args of
            Just (Derive.TagControl Control
sig) ->
                Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> Val -> Deriver Val
forall a b. (a -> b) -> a -> b
$ Y -> Val
DeriveT.num (Y -> Val) -> Y -> Val
forall a b. (a -> b) -> a -> b
$ RealTime -> Control -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
start Control
sig
            Just (Derive.TagPitch PSignal
sig) ->
                Deriver Val -> (Pitch -> Deriver Val) -> Maybe Pitch -> Deriver Val
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Deriver Val
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no previous pitch")
                    (Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> (Pitch -> Val) -> Pitch -> Deriver Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Val
DeriveT.VPitch) (RealTime -> PSignal -> Maybe Pitch
PSignal.at RealTime
start PSignal
sig)
            Maybe Tagged
_ -> Text -> Deriver Val
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"no previous value"

c_bpm :: Derive.ValCall
c_bpm :: ValCall
c_bpm = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"bpm" Tags
forall a. Monoid a => a
mempty Doc
"Convert bpm to tempo.  This is just (/60)."
    (WithArgDoc (PassedArgs Tagged -> Deriver Y) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser Y
-> (Y -> PassedArgs Tagged -> Deriver Y)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser Y
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"bpm" Doc
"")
    ((Y -> PassedArgs Tagged -> Deriver Y)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Y))
-> (Y -> PassedArgs Tagged -> Deriver Y)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
forall a b. (a -> b) -> a -> b
$ \Y
bpm PassedArgs Tagged
_args -> Y -> Deriver Y
forall (m :: * -> *) a. Monad m => a -> m a
return (Y -> Deriver Y) -> Y -> Deriver Y
forall a b. (a -> b) -> a -> b
$ (Y
bpm :: Double) Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y
60

c_env :: Derive.ValCall
c_env :: ValCall
c_env = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"env" Tags
forall a. Monoid a => a
mempty
    Doc
"Look up the given val in the environ."
    (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (Text, Maybe Val)
-> ((Text, Maybe Val) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (Text -> Maybe Val -> (Text, Maybe Val))
-> Parser Text -> Parser (Maybe Val -> (Text, Maybe Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser Text
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"name" Doc
"Look up the value of this key."
    Parser (Maybe Val -> (Text, Maybe Val))
-> Parser (Maybe Val) -> Parser (Text, Maybe Val)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Maybe Val -> Doc -> Parser (Maybe Val)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"default" Maybe Val
forall a. Maybe a
Nothing Doc
"If given, this is the default value\
        \ when the key isn't present. If not given, a missing key will throw an\
        \ exception. The presence of a default will also make the lookup\
        \ expect the same type as the default."
    ) (((Text, Maybe Val) -> PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> ((Text, Maybe Val) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \(Text
name, Maybe Val
maybe_deflt) PassedArgs Tagged
_args -> case Maybe Val
maybe_deflt of
        Maybe Val
Nothing -> Text -> Deriver Val
forall a. Typecheck a => Text -> Deriver a
Derive.get_val Text
name
        Just Val
deflt -> Text -> Val -> Maybe Val -> Deriver Val
forall {a}. Pretty a => a -> Val -> Maybe Val -> Deriver Val
check Text
name Val
deflt (Maybe Val -> Deriver Val)
-> Deriver State Error (Maybe Val) -> Deriver Val
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Deriver State Error (Maybe Val)
forall a. Typecheck a => Text -> Deriver (Maybe a)
Derive.lookup_val Text
name
    where
    check :: a -> Val -> Maybe Val -> Deriver Val
check a
_ Val
deflt Maybe Val
Nothing = Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return Val
deflt
    check a
name Val
deflt (Just Val
val) =
        case Val -> Val -> Maybe Type
ValType.val_types_match Val
deflt Val
val of
            Maybe Type
Nothing -> Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return Val
val
            Just Type
expected -> Text -> Deriver Val
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver Val) -> Text -> Deriver Val
forall a b. (a -> b) -> a -> b
$ Text
"env " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Pretty a => a -> Text
pretty a
name
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty Type
expected
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty (Bool -> Val -> Type
ValType.infer_type_of Bool
False Val
val)

c_timestep :: Derive.ValCall
c_timestep :: ValCall
c_timestep = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"timestep" Tags
forall a. Monoid a => a
mempty
    (Doc
"Compute the duration of the given RelativeMark timestep at the current\
    \ position. This is for durations, so it only works with RelativeMark."
    ) (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (Rank, Int)
-> ((Rank, Int) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (Rank -> Int -> (Rank, Int))
-> Parser Rank -> Parser (Int -> (Rank, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser Rank
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"rank" Doc
"Emit a duration of this rank."
    Parser (Int -> (Rank, Int)) -> Parser Int -> Parser (Rank, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Int -> Doc -> Parser Int
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"steps" Int
1 Doc
"This number of steps of that rank."
    ) (((Rank, Int) -> PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> ((Rank, Int) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \(Rank
rank, Int
steps) PassedArgs Tagged
args -> ScoreTime -> Val
DeriveT.score_time (ScoreTime -> Val) -> Deriver State Error ScoreTime -> Deriver Val
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ScoreTime -> Rank -> Int -> Deriver State Error ScoreTime
Call.meter_duration (PassedArgs Tagged -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs Tagged
args) Rank
rank Int
steps

c_timestep_reciprocal :: Derive.ValCall
c_timestep_reciprocal :: ValCall
c_timestep_reciprocal = ValCall -> Module -> CallName -> Doc -> (Val -> Val) -> ValCall
Make.modify_vcall ValCall
c_timestep Module
Module.prelude
    CallName
"timestep-reciprocal"
    (Doc
"This is the same as `timestep` except it returns the reciprocal. This is\
    \ useful for e.g. trills which take cycles per second rather than duration."
    ) Val -> Val
reciprocal
    where
    reciprocal :: Val -> Val
reciprocal (DeriveT.VNum Typed Y
num) = Typed Y -> Val
DeriveT.VNum (Typed Y -> Val) -> Typed Y -> Val
forall a b. (a -> b) -> a -> b
$ Y -> Y
forall a. Fractional a => a -> a
recip (Y -> Y) -> Typed Y -> Typed Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Y
num
    reciprocal Val
val = Val
val

c_reciprocal :: Derive.ValCall
c_reciprocal :: ValCall
c_reciprocal = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"reciprocal" Tags
forall a. Monoid a => a
mempty
    Doc
"Find the reciprocal of a number. Useful for tempo, e.g. set the tempo to\
    \ 1/time." (WithArgDoc (PassedArgs Tagged -> Deriver Y) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser Y
-> (Y -> PassedArgs Tagged -> Deriver Y)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser Y
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"num" Doc
"") ((Y -> PassedArgs Tagged -> Deriver Y)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Y))
-> (Y -> PassedArgs Tagged -> Deriver Y)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
forall a b. (a -> b) -> a -> b
$ \Y
num PassedArgs Tagged
_ ->
        if Y
num Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
0 then Text -> Deriver Y
forall a. HasCallStack => Text -> Deriver a
Derive.throw Text
"1/0"
            else Y -> Deriver Y
forall (m :: * -> *) a. Monad m => a -> m a
return (Y
1 Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ Y
num :: Double)

c_nn :: Derive.ValCall
c_nn :: ValCall
c_nn = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver NoteNumber)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"nn" Tags
forall a. Monoid a => a
mempty
    Doc
"Convert a pitch, hz, or twelve-tone pitch name to a NoteNumber.\
    \ A pitch name looks like `[a-g]s?[-1-9]`."
    (WithArgDoc (PassedArgs Tagged -> Deriver NoteNumber) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver NoteNumber) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (Either Pitch (Either Y Str))
-> (Either Pitch (Either Y Str)
    -> PassedArgs Tagged -> Deriver NoteNumber)
-> WithArgDoc (PassedArgs Tagged -> Deriver NoteNumber)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser (Either Pitch (Either Y Str))
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"val" Doc
"") ((Either Pitch (Either Y Str)
  -> PassedArgs Tagged -> Deriver NoteNumber)
 -> WithArgDoc (PassedArgs Tagged -> Deriver NoteNumber))
-> (Either Pitch (Either Y Str)
    -> PassedArgs Tagged -> Deriver NoteNumber)
-> WithArgDoc (PassedArgs Tagged -> Deriver NoteNumber)
forall a b. (a -> b) -> a -> b
$ \Either Pitch (Either Y Str)
val PassedArgs Tagged
_ -> case Either Pitch (Either Y Str)
val of
        Left Pitch
pitch -> Transposed -> Deriver NoteNumber
Pitches.pitch_nn (Pitch -> Transposed
forall a b. RawPitch a -> RawPitch b
PSignal.coerce (Pitch
pitch :: PSignal.Pitch))
        Right (Left Y
hz) -> NoteNumber -> Deriver NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Deriver NoteNumber)
-> NoteNumber -> Deriver NoteNumber
forall a b. (a -> b) -> a -> b
$ Y -> NoteNumber
Pitch.hz_to_nn Y
hz
        Right (Right Str
name) -> Str -> Deriver NoteNumber
get_name_nn Str
name

c_hz :: Derive.ValCall
c_hz :: ValCall
c_hz = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"hz" Tags
forall a. Monoid a => a
mempty
    Doc
"Convert a pitch, twelve-tone pitch name, or NoteNumber to hz.\
    \ A pitch name looks like `[a-g]s?[-1-9]`. If the octave isn't given, it\
    \ defaults to 0.  This is useful for `%just-base`, which ignores the\
    \ octave."
    (WithArgDoc (PassedArgs Tagged -> Deriver Y) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (Either Pitch (Either Str Y))
-> (Either Pitch (Either Str Y) -> PassedArgs Tagged -> Deriver Y)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser (Either Pitch (Either Str Y))
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"val" Doc
"") ((Either Pitch (Either Str Y) -> PassedArgs Tagged -> Deriver Y)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Y))
-> (Either Pitch (Either Str Y) -> PassedArgs Tagged -> Deriver Y)
-> WithArgDoc (PassedArgs Tagged -> Deriver Y)
forall a b. (a -> b) -> a -> b
$ \Either Pitch (Either Str Y)
val PassedArgs Tagged
_ -> case Either Pitch (Either Str Y)
val of
        Left Pitch
pitch -> NoteNumber -> Y
Pitch.nn_to_hz (NoteNumber -> Y) -> Deriver NoteNumber -> Deriver Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Transposed -> Deriver NoteNumber
Pitches.pitch_nn (Pitch -> Transposed
forall a b. RawPitch a -> RawPitch b
PSignal.coerce (Pitch
pitch :: PSignal.Pitch))
            -- Not transposed because they asked for a specific pitch.
        Right (Left Str
name) -> NoteNumber -> Y
Pitch.nn_to_hz (NoteNumber -> Y) -> Deriver NoteNumber -> Deriver Y
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Str -> Deriver NoteNumber
get_name_nn Str
name
        Right (Right Y
nn) ->
            Y -> Deriver Y
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Y
Pitch.nn_to_hz (Y -> NoteNumber
Pitch.NoteNumber Y
nn) :: Double)

get_name_nn :: Expr.Str -> Derive.Deriver Pitch.NoteNumber
get_name_nn :: Str -> Deriver NoteNumber
get_name_nn Str
name =
    Text -> Maybe NoteNumber -> Deriver NoteNumber
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"unknown pitch: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Str -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Str
name) (Maybe NoteNumber -> Deriver NoteNumber)
-> Maybe NoteNumber -> Deriver NoteNumber
forall a b. (a -> b) -> a -> b
$
        Text -> Maybe NoteNumber
parse_pitch_name (Str -> Text
Expr.unstr Str
name)

-- | c-1 is 0, g9 is 127.  The octave is optional, and defaults to 1.
parse_pitch_name :: Text -> Maybe Pitch.NoteNumber
parse_pitch_name :: Text -> Maybe NoteNumber
parse_pitch_name = (Text -> Maybe NoteNumber)
-> (NoteNumber -> Maybe NoteNumber)
-> Either Text NoteNumber
-> Maybe NoteNumber
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe NoteNumber -> Text -> Maybe NoteNumber
forall a b. a -> b -> a
const Maybe NoteNumber
forall a. Maybe a
Nothing) NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just (Either Text NoteNumber -> Maybe NoteNumber)
-> (Text -> Either Text NoteNumber) -> Text -> Maybe NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser NoteNumber -> Text -> Either Text NoteNumber
forall a. Parser a -> Text -> Either Text a
ParseText.parse1 Parser NoteNumber
parse
    where
    parse :: Parser NoteNumber
parse = do
        Int
pc <- Parser Text Int
-> (Int -> Parser Text Int) -> Maybe Int -> Parser Text Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Parser Text Int
forall (m :: * -> *) a. MonadPlus m => m a
mzero Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> Parser Text Int)
-> (Char -> Maybe Int) -> Char -> Parser Text Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Map Char Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Char Int
pcs) (Char -> Parser Text Int) -> Parser Text Char -> Parser Text Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Parser Text Char
A.anyChar
        Int
sharp <- Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Int
0 (Parser Text Int -> Parser Text Int)
-> Parser Text Int -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
A.char Char
's' Parser Text Char -> Parser Text Int -> Parser Text Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Parser Text Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
        Int
oct <- Int -> Parser Text Int -> Parser Text Int
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option Int
1 (Parser Text Int -> Parser Text Int)
-> Parser Text Int -> Parser Text Int
forall a b. (a -> b) -> a -> b
$ Parser Text Int
ParseText.p_int
        NoteNumber -> Parser NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Parser NoteNumber)
-> NoteNumber -> Parser NoteNumber
forall a b. (a -> b) -> a -> b
$ Int -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Int -> NoteNumber) -> Int -> NoteNumber
forall a b. (a -> b) -> a -> b
$ Int
pc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sharp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
octInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
12
    pcs :: Map Char Int
pcs = [(Char, Int)] -> Map Char Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Char, Int)] -> Map Char Int) -> [(Char, Int)] -> Map Char Int
forall a b. (a -> b) -> a -> b
$ [Char] -> [Int] -> [(Char, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Char]
"cdefgab" ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 [Int]
Theory.piano_intervals)

c_list :: Derive.ValCall
c_list :: ValCall
c_list = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"list" Tags
forall a. Monoid a => a
mempty Doc
"Create a list." (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$
    Parser [Val]
-> ([Val] -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser [Val]
forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"val" Doc
"Value.") (([Val] -> PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> ([Val] -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \[Val]
vals PassedArgs Tagged
_ ->
        Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> Val -> Deriver Val
forall a b. (a -> b) -> a -> b
$ [Val] -> Val
DeriveT.VList [Val]
vals

c_lrange :: Derive.ValCall
c_lrange :: ValCall
c_lrange = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"range" Tags
forall a. Monoid a => a
mempty Doc
"Make a list range of numbers." (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$
    Parser (Y, Y, Y)
-> ((Y, Y, Y) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
    (Y -> Y -> Y -> (Y, Y, Y))
-> Parser Y -> Parser (Y -> Y -> (Y, Y, Y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser Y
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"start" Doc
"Start value."
    Parser (Y -> Y -> (Y, Y, Y)) -> Parser Y -> Parser (Y -> (Y, Y, Y))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Doc -> Parser Y
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"step" Doc
"Step."
    Parser (Y -> (Y, Y, Y)) -> Parser Y -> Parser (Y, Y, Y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Doc -> Parser Y
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"count" Doc
"Number of values."
    ) (((Y, Y, Y) -> PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> ((Y, Y, Y) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \(Y
start, Y
step, Y
count) PassedArgs Tagged
_ ->
        Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> Val -> Deriver Val
forall a b. (a -> b) -> a -> b
$ [Val] -> Val
DeriveT.VList ([Val] -> Val) -> [Val] -> Val
forall a b. (a -> b) -> a -> b
$ (Y -> Val) -> [Y] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Y -> Val
DeriveT.num ([Y] -> [Val]) -> [Y] -> [Val]
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y -> [Y]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.range Y
start Y
step Y
count

c_scoretime :: Derive.ValCall
c_scoretime :: ValCall
c_scoretime = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver State Error ScoreTime)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"scoretime" Tags
forall a. Monoid a => a
mempty
    Doc
"Convert a number to ScoreTime. This just changes the type annotation, the\
    \ value remains the same." (WithArgDoc (PassedArgs Tagged -> Deriver State Error ScoreTime)
 -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver State Error ScoreTime)
-> ValCall
forall a b. (a -> b) -> a -> b
$
    Parser Y
-> (Y -> PassedArgs Tagged -> Deriver State Error ScoreTime)
-> WithArgDoc (PassedArgs Tagged -> Deriver State Error ScoreTime)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> EnvironDefault -> Doc -> Parser Y
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"val" EnvironDefault
Sig.None Doc
"") ((Y -> PassedArgs Tagged -> Deriver State Error ScoreTime)
 -> WithArgDoc (PassedArgs Tagged -> Deriver State Error ScoreTime))
-> (Y -> PassedArgs Tagged -> Deriver State Error ScoreTime)
-> WithArgDoc (PassedArgs Tagged -> Deriver State Error ScoreTime)
forall a b. (a -> b) -> a -> b
$ \Y
val PassedArgs Tagged
_ ->
        ScoreTime -> Deriver State Error ScoreTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ScoreTime -> Deriver State Error ScoreTime)
-> ScoreTime -> Deriver State Error ScoreTime
forall a b. (a -> b) -> a -> b
$ Y -> ScoreTime
ScoreTime.from_double Y
val

c_realtime :: Derive.ValCall
c_realtime :: ValCall
c_realtime = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver RealTime)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"realtime" Tags
forall a. Monoid a => a
mempty
    Doc
"Convert a number to RealTime. This just changes the type annotation, the\
    \ value remains the same." (WithArgDoc (PassedArgs Tagged -> Deriver RealTime) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver RealTime) -> ValCall
forall a b. (a -> b) -> a -> b
$
    Parser Y
-> (Y -> PassedArgs Tagged -> Deriver RealTime)
-> WithArgDoc (PassedArgs Tagged -> Deriver RealTime)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> EnvironDefault -> Doc -> Parser Y
forall a.
Typecheck a =>
ArgName -> EnvironDefault -> Doc -> Parser a
Sig.required_env ArgName
"val" EnvironDefault
Sig.None Doc
"") ((Y -> PassedArgs Tagged -> Deriver RealTime)
 -> WithArgDoc (PassedArgs Tagged -> Deriver RealTime))
-> (Y -> PassedArgs Tagged -> Deriver RealTime)
-> WithArgDoc (PassedArgs Tagged -> Deriver RealTime)
forall a b. (a -> b) -> a -> b
$ \Y
val PassedArgs Tagged
_ ->
        RealTime -> Deriver RealTime
forall (m :: * -> *) a. Monad m => a -> m a
return (RealTime -> Deriver RealTime) -> RealTime -> Deriver RealTime
forall a b. (a -> b) -> a -> b
$ Y -> RealTime
RealTime.seconds Y
val

c_pitch :: Derive.ValCall
c_pitch :: ValCall
c_pitch = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"pitch" Tags
forall a. Monoid a => a
mempty Doc
"Create a 'Perform.Pitch.Pitch'."
    (WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (Either Int (Either Text Pitch), Int, Int)
-> ((Either Int (Either Text Pitch), Int, Int)
    -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,,)
    (Either Int (Either Text Pitch)
 -> Int -> Int -> (Either Int (Either Text Pitch), Int, Int))
-> Parser (Either Int (Either Text Pitch))
-> Parser
     (Int -> Int -> (Either Int (Either Text Pitch), Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName
-> EnvironDefault
-> Either Int (Either Text Pitch)
-> Doc
-> Parser (Either Int (Either Text Pitch))
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.defaulted_env ArgName
"oct" EnvironDefault
Sig.None (Int -> Either Int (Either Text Pitch)
forall a b. a -> Either a b
Left Int
0)
        Doc
"Octave, or a pitch name or pitch. If it's a pitch name or pitch, the\
        \ `pc` and `accs` args must be 0."
    Parser (Int -> Int -> (Either Int (Either Text Pitch), Int, Int))
-> Parser Int
-> Parser (Int -> (Either Int (Either Text Pitch), Int, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Int -> Doc -> Parser Int
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.defaulted_env ArgName
"pc" EnvironDefault
Sig.None Int
0 Doc
"Pitch class."
    Parser (Int -> (Either Int (Either Text Pitch), Int, Int))
-> Parser Int -> Parser (Either Int (Either Text Pitch), Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> EnvironDefault -> Int -> Doc -> Parser Int
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> EnvironDefault -> a -> Doc -> Parser a
Sig.defaulted_env ArgName
"accs" EnvironDefault
Sig.None Int
0 Doc
"Accidentals."
    ) (((Either Int (Either Text Pitch), Int, Int)
  -> PassedArgs Tagged -> Deriver Pitch)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Pitch))
-> ((Either Int (Either Text Pitch), Int, Int)
    -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall a b. (a -> b) -> a -> b
$ \(Either Int (Either Text Pitch)
oct, Int
pc, Int
accs) PassedArgs Tagged
_ -> Either Int (Either Text Pitch) -> Int -> Int -> Deriver Pitch
make_pitch Either Int (Either Text Pitch)
oct Int
pc Int
accs

make_pitch :: Either Pitch.Octave (Either Text PSignal.Pitch)
    -> Pitch.PitchClass -> Pitch.Accidentals -> Derive.Deriver Pitch.Pitch
make_pitch :: Either Int (Either Text Pitch) -> Int -> Int -> Deriver Pitch
make_pitch (Left Int
oct) Int
pc Int
accs = Pitch -> Deriver Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Deriver Pitch) -> Pitch -> Deriver Pitch
forall a b. (a -> b) -> a -> b
$ Int -> Degree -> Pitch
Pitch.Pitch Int
oct (Int -> Int -> Degree
Pitch.Degree Int
pc Int
accs)
make_pitch (Right Either Text Pitch
name_pitch) Int
pc Int
accs
    | Int
pc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| Int
accs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Text -> Deriver Pitch
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver Pitch) -> Text -> Deriver Pitch
forall a b. (a -> b) -> a -> b
$
        Text
"pc and accs args must be 0 when a pitch is given: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int, Int) -> Text
forall a. Show a => a -> Text
showt (Int
pc, Int
accs)
    | Bool
otherwise = do
        (Note
note, Scale
scale) <- case Either Text Pitch
name_pitch of
            Left Text
name -> (,) (Note -> Scale -> (Note, Scale))
-> Deriver State Error Note
-> Deriver State Error (Scale -> (Note, Scale))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Note -> Deriver State Error Note
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Note
Pitch.Note Text
name) Deriver State Error (Scale -> (Note, Scale))
-> Deriver State Error Scale -> Deriver State Error (Note, Scale)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Deriver State Error Scale
Call.get_scale
            Right Pitch
pitch -> (,)
                (Note -> Scale -> (Note, Scale))
-> Deriver State Error Note
-> Deriver State Error (Scale -> (Note, Scale))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Deriver State Error Note
Pitches.pitch_note (Pitch -> Transposed
forall a b. RawPitch a -> RawPitch b
PSignal.coerce Pitch
pitch)
                Deriver State Error (Scale -> (Note, Scale))
-> Deriver State Error Scale -> Deriver State Error (Note, Scale)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScaleId -> Deriver State Error Scale
Derive.get_scale (Pitch -> ScaleId
forall a. RawPitch a -> ScaleId
PSignal.pitch_scale_id Pitch
pitch)
        Environ
env <- Deriver Environ
Derive.get_environ
        (PitchError -> Deriver Pitch)
-> (Pitch -> Deriver Pitch)
-> Either PitchError Pitch
-> Deriver Pitch
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Deriver Pitch
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver Pitch)
-> (PitchError -> Text) -> PitchError -> Deriver Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PitchError -> Text
forall a. Pretty a => a -> Text
pretty) Pitch -> Deriver Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PitchError Pitch -> Deriver Pitch)
-> Either PitchError Pitch -> Deriver Pitch
forall a b. (a -> b) -> a -> b
$
            Scale -> Environ -> Note -> Either PitchError Pitch
Scale.scale_read Scale
scale Environ
env Note
note

c_pcontrol_ref :: Derive.ValCall
c_pcontrol_ref :: ValCall
c_pcontrol_ref = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver (Ref PControl PSignal))
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"pcontrol-ref" Tags
forall a. Monoid a => a
mempty
    Doc
"Create a 'Derive.DeriveT.PControlRef'. For control literals, the\
    \ `#name` syntax suffices, but if you want to give a default pitch,\
    \ you need this call."
    (WithArgDoc (PassedArgs Tagged -> Deriver (Ref PControl PSignal))
 -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver (Ref PControl PSignal))
-> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (PControl, Maybe Pitch)
-> ((PControl, Maybe Pitch)
    -> PassedArgs Tagged -> Deriver (Ref PControl PSignal))
-> WithArgDoc (PassedArgs Tagged -> Deriver (Ref PControl PSignal))
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (PControl -> Maybe Pitch -> (PControl, Maybe Pitch))
-> Parser PControl
-> Parser (Maybe Pitch -> (PControl, Maybe Pitch))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Doc -> Parser PControl
forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"name" Doc
"Name of pitch signal."
    Parser (Maybe Pitch -> (PControl, Maybe Pitch))
-> Parser (Maybe Pitch) -> Parser (PControl, Maybe Pitch)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Maybe Pitch -> Doc -> Parser (Maybe Pitch)
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"default" Maybe Pitch
forall a. Maybe a
Nothing
        Doc
"Default pitch, if the signal is not set."
    ) (((PControl, Maybe Pitch)
  -> PassedArgs Tagged -> Deriver (Ref PControl PSignal))
 -> WithArgDoc
      (PassedArgs Tagged -> Deriver (Ref PControl PSignal)))
-> ((PControl, Maybe Pitch)
    -> PassedArgs Tagged -> Deriver (Ref PControl PSignal))
-> WithArgDoc (PassedArgs Tagged -> Deriver (Ref PControl PSignal))
forall a b. (a -> b) -> a -> b
$ \(PControl
pcontrol, Maybe Pitch
maybe_default) PassedArgs Tagged
_ -> Ref PControl PSignal -> Deriver (Ref PControl PSignal)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ref PControl PSignal -> Deriver (Ref PControl PSignal))
-> Ref PControl PSignal -> Deriver (Ref PControl PSignal)
forall a b. (a -> b) -> a -> b
$ case Maybe Pitch
maybe_default of
        Maybe Pitch
Nothing -> PControl -> Ref PControl PSignal
forall control val. control -> Ref control val
DeriveT.LiteralControl (PControl
pcontrol :: ScoreT.PControl)
        Just Pitch
pitch -> PControl -> PSignal -> Ref PControl PSignal
forall control val. control -> val -> Ref control val
DeriveT.DefaultedControl PControl
pcontrol
            (Pitch -> PSignal
PSignal.constant Pitch
pitch)

-- * lookup

c_get_pitch :: Derive.ValCall
c_get_pitch :: ValCall
c_get_pitch = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"pitch" Tags
forall a. Monoid a => a
mempty Doc
"Get the current pitch." (WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall
forall a b. (a -> b) -> a -> b
$
    Parser PControl
-> (PControl -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> PControl -> Doc -> Parser PControl
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"control" PControl
""
        Doc
"The default pitch if empty, otherwise, get the named pitch.") ((PControl -> PassedArgs Tagged -> Deriver Pitch)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Pitch))
-> (PControl -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall a b. (a -> b) -> a -> b
$
    \PControl
control PassedArgs Tagged
args -> Text -> Maybe Pitch -> Deriver Pitch
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"pitch"
        (Maybe Pitch -> Deriver Pitch)
-> Deriver State Error (Maybe Pitch) -> Deriver Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PControl -> RealTime -> Deriver State Error (Maybe Pitch)
Derive.named_pitch_at PControl
control (RealTime -> Deriver State Error (Maybe Pitch))
-> Deriver RealTime -> Deriver State Error (Maybe Pitch)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PassedArgs Tagged -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Tagged
args

-- * generate signals

c_linear_next :: Derive.ValCall
c_linear_next :: ValCall
c_linear_next = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"linear-next" Tags
forall a. Monoid a => a
mempty
    Doc
"Create straight lines between the given breakpoints."
    (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (NonEmpty Val)
-> (NonEmpty Val -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call Parser (NonEmpty Val)
breakpoints_arg ((NonEmpty Val -> PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> (NonEmpty Val -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \NonEmpty Val
vals PassedArgs Tagged
args ->
        Int -> Curve -> NonEmpty Val -> PassedArgs Tagged -> Deriver Val
forall a.
Int -> Curve -> NonEmpty Val -> PassedArgs a -> Deriver Val
breakpoints Int
0 Curve
ControlUtil.Linear NonEmpty Val
vals PassedArgs Tagged
args

c_exp_next :: Derive.ValCall
c_exp_next :: ValCall
c_exp_next = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"exp-next" Tags
forall a. Monoid a => a
mempty
    Doc
"Create curved lines between the given breakpoints."
    (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (Y, NonEmpty Val)
-> ((Y, NonEmpty Val) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (Y -> NonEmpty Val -> (Y, NonEmpty Val))
-> Parser Y -> Parser (NonEmpty Val -> (Y, NonEmpty Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"exp" Y
2 Doc
ControlUtil.exponential_doc
    Parser (NonEmpty Val -> (Y, NonEmpty Val))
-> Parser (NonEmpty Val) -> Parser (Y, NonEmpty Val)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (NonEmpty Val)
breakpoints_arg
    ) (((Y, NonEmpty Val) -> PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> ((Y, NonEmpty Val) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \(Y
exp, NonEmpty Val
vals) PassedArgs Tagged
args ->
        Int -> Curve -> NonEmpty Val -> PassedArgs Tagged -> Deriver Val
forall a.
Int -> Curve -> NonEmpty Val -> PassedArgs a -> Deriver Val
breakpoints Int
1 ((Y -> Y) -> Curve
ControlUtil.Function ((Y -> Y) -> Curve) -> (Y -> Y) -> Curve
forall a b. (a -> b) -> a -> b
$ Y -> Y -> Y
ControlUtil.expon Y
exp) NonEmpty Val
vals PassedArgs Tagged
args

breakpoints_arg :: Sig.Parser (NonEmpty DeriveT.Val)
breakpoints_arg :: Parser (NonEmpty Val)
breakpoints_arg = ArgName -> Doc -> Parser (NonEmpty Val)
forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"bp" Doc
"Breakpoints are distributed evenly between\
    \ the event start and the next event. They can be all numbers, or all\
    \ pitches."

c_down_from :: Derive.ValCall
c_down_from :: ValCall
c_down_from = CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
-> ValCall
forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"down-from" Tags
forall a. Monoid a => a
mempty
    Doc
"Go down from a starting value at a certain rate."
    (WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser (Y, Y)
-> ((Y, Y) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call ((,)
    (Y -> Y -> (Y, Y)) -> Parser Y -> Parser (Y -> (Y, Y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"from" Y
1 Doc
"Start at this value."
    Parser (Y -> (Y, Y)) -> Parser Y -> Parser (Y, Y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArgName -> Y -> Doc -> Parser Y
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"speed" Y
1 Doc
"Descend this amount per second."
    ) (((Y, Y) -> PassedArgs Tagged -> Deriver Val)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Val))
-> ((Y, Y) -> PassedArgs Tagged -> Deriver Val)
-> WithArgDoc (PassedArgs Tagged -> Deriver Val)
forall a b. (a -> b) -> a -> b
$ \(Y
from, Y
speed) PassedArgs Tagged
args -> do
        (RealTime
start, RealTime
end) <- PassedArgs Tagged -> Deriver (RealTime, RealTime)
forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range_or_next PassedArgs Tagged
args
        Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> Val -> Deriver Val
forall a b. (a -> b) -> a -> b
$ ControlRef -> Val
DeriveT.VControlRef (ControlRef -> Val) -> ControlRef -> Val
forall a b. (a -> b) -> a -> b
$ Typed Control -> ControlRef
forall control val. val -> Ref control val
DeriveT.ControlSignal (Typed Control -> ControlRef) -> Typed Control -> ControlRef
forall a b. (a -> b) -> a -> b
$
            Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Control -> Typed Control) -> Control -> Typed Control
forall a b. (a -> b) -> a -> b
$
            Maybe Y -> Maybe Y -> Y -> Y -> RealTime -> RealTime -> Control
ControlUtil.slope_to_limit (Y -> Maybe Y
forall a. a -> Maybe a
Just Y
0) Maybe Y
forall a. Maybe a
Nothing Y
from (-Y
speed) RealTime
start RealTime
end

-- ** implementation

breakpoints :: Int -> ControlUtil.Curve -> NonEmpty DeriveT.Val
    -> Derive.PassedArgs a -> Derive.Deriver DeriveT.Val
breakpoints :: forall a.
Int -> Curve -> NonEmpty Val -> PassedArgs a -> Deriver Val
breakpoints Int
argnum Curve
curve NonEmpty Val
vals PassedArgs a
args = do
    (RealTime
start, RealTime
end) <- PassedArgs a -> Deriver (RealTime, RealTime)
forall a. PassedArgs a -> Deriver (RealTime, RealTime)
Args.real_range_or_next PassedArgs a
args
    RealTime
srate <- Deriver RealTime
Call.get_srate
    Either [Y] [Pitch]
vals <- ScoreTime -> Int -> NonEmpty Val -> Deriver (Either [Y] [Pitch])
num_or_pitch (PassedArgs a -> ScoreTime
forall a. PassedArgs a -> ScoreTime
Args.start PassedArgs a
args) Int
argnum NonEmpty Val
vals
    Val -> Deriver Val
forall (m :: * -> *) a. Monad m => a -> m a
return (Val -> Deriver Val) -> Val -> Deriver Val
forall a b. (a -> b) -> a -> b
$ case Either [Y] [Pitch]
vals of
        Left [Y]
nums -> ControlRef -> Val
DeriveT.VControlRef (ControlRef -> Val) -> ControlRef -> Val
forall a b. (a -> b) -> a -> b
$ Typed Control -> ControlRef
forall control val. val -> Ref control val
DeriveT.ControlSignal (Typed Control -> ControlRef) -> Typed Control -> ControlRef
forall a b. (a -> b) -> a -> b
$
            Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Control -> Typed Control) -> Control -> Typed Control
forall a b. (a -> b) -> a -> b
$ RealTime -> Curve -> [(RealTime, Y)] -> Control
ControlUtil.breakpoints RealTime
srate Curve
curve ([(RealTime, Y)] -> Control) -> [(RealTime, Y)] -> Control
forall a b. (a -> b) -> a -> b
$
            RealTime -> RealTime -> [Y] -> [(RealTime, Y)]
forall a. RealTime -> RealTime -> [a] -> [(RealTime, a)]
ControlUtil.distribute RealTime
start RealTime
end [Y]
nums
        Right [Pitch]
pitches -> Ref PControl PSignal -> Val
DeriveT.VPControlRef (Ref PControl PSignal -> Val) -> Ref PControl PSignal -> Val
forall a b. (a -> b) -> a -> b
$ PSignal -> Ref PControl PSignal
forall control val. val -> Ref control val
DeriveT.ControlSignal (PSignal -> Ref PControl PSignal)
-> PSignal -> Ref PControl PSignal
forall a b. (a -> b) -> a -> b
$
            RealTime -> Curve -> [(RealTime, Pitch)] -> PSignal
PitchUtil.breakpoints RealTime
srate Curve
curve ([(RealTime, Pitch)] -> PSignal) -> [(RealTime, Pitch)] -> PSignal
forall a b. (a -> b) -> a -> b
$
            RealTime -> RealTime -> [Pitch] -> [(RealTime, Pitch)]
forall a. RealTime -> RealTime -> [a] -> [(RealTime, a)]
ControlUtil.distribute RealTime
start RealTime
end [Pitch]
pitches

-- | Insist that the vals be either all numbers or pitches.
--
-- TODO If 'Sig.Parser' supported Alternative, maybe I could build this as
-- a parser and get both shorter code and documentation.
num_or_pitch :: ScoreTime -> Int -> NonEmpty DeriveT.Val
    -> Derive.Deriver (Either [Signal.Y] [PSignal.Pitch])
num_or_pitch :: ScoreTime -> Int -> NonEmpty Val -> Deriver (Either [Y] [Pitch])
num_or_pitch ScoreTime
start Int
argnum (Val
val :| [Val]
vals) = case Val
val of
    DeriveT.VNum Typed Y
num -> do
        [Y]
vals <- ((Int, Val) -> Deriver Y)
-> [(Int, Val)] -> Deriver State Error [Y]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> (Int, Val) -> Deriver Y
forall {b}.
Typecheck b =>
Type -> (Int, Val) -> Deriver State Error b
expect Type
tnum) ([Int] -> [Val] -> [(Int, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
argnum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 ..] [Val]
vals)
        Either [Y] [Pitch] -> Deriver (Either [Y] [Pitch])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Y] [Pitch] -> Deriver (Either [Y] [Pitch]))
-> Either [Y] [Pitch] -> Deriver (Either [Y] [Pitch])
forall a b. (a -> b) -> a -> b
$ [Y] -> Either [Y] [Pitch]
forall a b. a -> Either a b
Left (Typed Y -> Y
forall a. Typed a -> a
ScoreT.typed_val Typed Y
num Y -> [Y] -> [Y]
forall a. a -> [a] -> [a]
: [Y]
vals)
    DeriveT.VPitch Pitch
pitch -> do
        [Pitch]
vals <- ((Int, Val) -> Deriver Pitch)
-> [(Int, Val)] -> Deriver State Error [Pitch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> (Int, Val) -> Deriver Pitch
forall {b}.
Typecheck b =>
Type -> (Int, Val) -> Deriver State Error b
expect Type
ValType.TPitch) ([Int] -> [Val] -> [(Int, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
argnum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 ..] [Val]
vals)
        Either [Y] [Pitch] -> Deriver (Either [Y] [Pitch])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Y] [Pitch] -> Deriver (Either [Y] [Pitch]))
-> Either [Y] [Pitch] -> Deriver (Either [Y] [Pitch])
forall a b. (a -> b) -> a -> b
$ [Pitch] -> Either [Y] [Pitch]
forall a b. b -> Either a b
Right (Pitch
pitch Pitch -> [Pitch] -> [Pitch]
forall a. a -> [a] -> [a]
: [Pitch]
vals)
    Val
_ -> Int -> ArgName -> Type -> Val -> Deriver (Either [Y] [Pitch])
forall a. Int -> ArgName -> Type -> Val -> Deriver a
type_error Int
argnum ArgName
"bp" (Type -> Type -> Type
ValType.TEither Type
tnum Type
ValType.TPitch) Val
val
    where
    tnum :: Type
tnum = NumType -> NumValue -> Type
ValType.TNum NumType
ValType.TUntyped NumValue
ValType.TAny
    expect :: Type -> (Int, Val) -> Deriver State Error b
expect Type
typ (Int
argnum, Val
val) =
        Deriver State Error b
-> (b -> Deriver State Error b) -> Maybe b -> Deriver State Error b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> ArgName -> Type -> Val -> Deriver State Error b
forall a. Int -> ArgName -> Type -> Val -> Deriver a
type_error Int
argnum ArgName
"bp" Type
typ Val
val) b -> Deriver State Error b
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Maybe b -> Deriver State Error b)
-> Deriver State Error (Maybe b) -> Deriver State Error b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Val -> Deriver State Error (Maybe b)
forall a. Typecheck a => ScoreTime -> Val -> Deriver (Maybe a)
Typecheck.from_val_eval ScoreTime
start Val
val

type_error :: Int -> Derive.ArgName -> ValType.Type -> DeriveT.Val
    -> Derive.Deriver a
type_error :: forall a. Int -> ArgName -> Type -> Val -> Deriver a
type_error Int
argnum ArgName
name Type
expected Val
received =
    ErrorVal -> Deriver a
forall a. HasCallStack => ErrorVal -> Deriver a
Derive.throw_error (ErrorVal -> Deriver a) -> ErrorVal -> Deriver a
forall a b. (a -> b) -> a -> b
$ CallError -> ErrorVal
Derive.CallError (CallError -> ErrorVal) -> CallError -> ErrorVal
forall a b. (a -> b) -> a -> b
$ TypeErrorT -> CallError
Derive.TypeError (TypeErrorT -> CallError) -> TypeErrorT -> CallError
forall a b. (a -> b) -> a -> b
$ Derive.TypeErrorT
        { error_place :: ErrorPlace
error_place = Int -> ErrorPlace
Derive.TypeErrorArg Int
argnum
        , error_source :: EvalSource
error_source = EvalSource
Derive.Literal
        , error_arg_name :: ArgName
error_arg_name = ArgName
name
        , error_expected :: Type
error_expected = Type
expected
        , error_received :: Maybe Val
error_received = Val -> Maybe Val
forall a. a -> Maybe a
Just Val
received
        , error_derive :: Maybe Error
error_derive = Maybe Error
forall a. Maybe a
Nothing
        }


-- * util

val_call :: Typecheck.ToVal a => Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Derive.WithArgDoc (Derive.PassedArgs Derive.Tagged -> Derive.Deriver a)
    -> Derive.ValCall
val_call :: forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.prelude