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

{- | This module defines basic tracklang types.

    The Derive.PSignal section is re-exported from "Derive.PSignal".  I'd rather
    move it to PSignal, but it needs to be here to avoid circular imports.

    Here are the names for various aspects of signals:

    >           numbers                   pitches                 both
    > scalar    Signal.Y                  PSignal.Y
    > name      ScoreT.Control            ScoreT.PControl
    > signal    Signal.Control            PSignal.PSignal
    > ref       DeriveT.ControlRef        DeriveT.PControlRef     Ref
-}
module Derive.DeriveT (
    -- * Derive.PSignal
    PSignal(..)
    , _signal
    , interpolate
    , Pitch
    , Transposed
    , RawPitch(..)
    , pitch
    , coerce
    , pitch_nn, pitch_note
    , PitchConfig(..)
    , Scale(..)
    , detailed_error
    , PitchError(..)
    , OutOfRange(..)
    , out_of_range, out_of_range_error
    , pitches_equal

    -- * Duration
    , Duration(..)
    , TimeType(..)
    , multiply_duration

    -- * Environ
    , Environ(..)
    , null
    , insert
    , lookup
    , environ_attributes

    -- * Val
    , Val(..)
    , vals_equal
    , types_equal
    , val_to_mini
    , Quoted(..)
    , show_call_val
    -- ** val utils
    , num
    , constant_val
    , constant
    , score_time, real_time
    , transposition
    , str
    , to_scale_id
    , quoted, quoted0
    -- * Ref
    , ControlRef, PControlRef, Ref(..)

    -- * Expr
    , Expr, Call, Term
    , PitchCall
    -- ** call utils
    , map_str

    -- * type aliases
    , PitchMap
    , PitchFunction

    -- * ControlFunction
    , CFunction(..)
    , call_cfunction
    , PFunction(..)
    , Dynamic(..)
    , empty_dynamic
) where
import           Prelude hiding (lookup, null)
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Coerce as Coerce
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Segment as Segment
import qualified Util.Lists as Lists
import qualified Util.Serialize as Serialize

import qualified Derive.Attrs as Attrs
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Warp as Warp

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

import qualified Ui.Ruler as Ruler
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


{-
    This file is pretty much unreducable, as far as dependencies go:
    For TrackLang: ControlFunction -> Environ -> Val <- ControlFunction
    For PSignal: PitchConfig -> Environ -> Val <- Pitch <- PitchConfig

    So 'ControlFunction', 'Pitch', and 'Val' must all be together.  'Signal'
    also gets dragged in, and winds up being everything in this file.

    The real key is Val, which has a ControlFunction, which means
    ControlFunction can't be in Deriver (since Deriver.Monad imports this),
    and PControlRef, which requires PSignal.
-}

-- * Derive.PSignal

-- | A pitch signal is similar to a 'Signal.Control', except that its values
-- are 'Pitch'es instead of plain floating point values.
newtype PSignal = PSignal (Segment.Boxed Pitch)
    deriving (Int -> PSignal -> ShowS
[PSignal] -> ShowS
PSignal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PSignal] -> ShowS
$cshowList :: [PSignal] -> ShowS
show :: PSignal -> String
$cshow :: PSignal -> String
showsPrec :: Int -> PSignal -> ShowS
$cshowsPrec :: Int -> PSignal -> ShowS
Show, [PSignal] -> Doc
PSignal -> Text
PSignal -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [PSignal] -> Doc
$cformatList :: [PSignal] -> Doc
format :: PSignal -> Doc
$cformat :: PSignal -> Doc
pretty :: PSignal -> Text
$cpretty :: PSignal -> Text
Pretty)

_signal :: PSignal -> Segment.Boxed Pitch
_signal :: PSignal -> Boxed Pitch
_signal (PSignal Boxed Pitch
sig) = Boxed Pitch
sig

instance Semigroup PSignal where
    PSignal
s1 <> :: PSignal -> PSignal -> PSignal
<> PSignal
s2
        | forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null (PSignal -> Boxed Pitch
_signal PSignal
s1) = PSignal
s2
        | forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null (PSignal -> Boxed Pitch
_signal PSignal
s2) = PSignal
s1
        | Bool
otherwise = forall a. Monoid a => [a] -> a
mconcat [PSignal
s1, PSignal
s2]
instance Monoid PSignal where
    mempty :: PSignal
mempty = Boxed Pitch -> PSignal
PSignal forall (v :: * -> *) a. Vector v a => Signal (v a)
Segment.empty
    mappend :: PSignal -> PSignal -> PSignal
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [PSignal] -> PSignal
mconcat [] = forall a. Monoid a => a
mempty
    mconcat [PSignal]
sigs = Boxed Pitch -> PSignal
PSignal forall a b. (a -> b) -> a -> b
$
        forall (v :: * -> *) y.
Vector v (Sample y) =>
Maybe (y -> y -> Bool)
-> Interpolate y -> [SignalS v y] -> SignalS v y
Segment.concat forall a. Maybe a
Nothing Interpolate Pitch
interpolate forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map PSignal -> Boxed Pitch
_signal [PSignal]
sigs

instance DeepSeq.NFData PSignal where
    rnf :: PSignal -> ()
rnf (PSignal Boxed Pitch
vec) = Boxed Pitch
vec seq :: forall a b. a -> b -> b
`seq` ()

-- | A pitch interpolated a certain distance between two other pitches.
interpolate :: Segment.Interpolate Pitch
interpolate :: Interpolate Pitch
interpolate (Segment.Sample RealTime
x1 Pitch
p1) (Segment.Sample RealTime
x2 Pitch
p2) RealTime
x
    | RealTime
x forall a. Ord a => a -> a -> Bool
<= RealTime
x1 = Pitch
p1
    | RealTime
x forall a. Ord a => a -> a -> Bool
>= RealTime
x2 = Pitch
p2
    | Bool
otherwise = Pitch
        { pitch_eval_nn :: PitchConfig -> Either PitchError NoteNumber
pitch_eval_nn = PitchConfig -> Either PitchError NoteNumber
nn
        , pitch_eval_note :: PitchConfig -> Either PitchError Note
pitch_eval_note = PitchConfig -> Either PitchError Note
note
        , pitch_scale :: Scale
pitch_scale = forall a. RawPitch a -> Scale
pitch_scale Pitch
p1
        , pitch_config :: PitchConfig
pitch_config = forall a. Monoid a => a
mempty
        }
    where
    nn :: PitchConfig -> Either PitchError NoteNumber
nn PitchConfig
config = do
        NoteNumber
p1_nn <- Transposed -> Either PitchError NoteNumber
pitch_nn forall a b. (a -> b) -> a -> b
$ forall a b. RawPitch a -> RawPitch b
coerce forall a b. (a -> b) -> a -> b
$ forall {a} {a}. PitchConfig -> RawPitch a -> RawPitch a
apply_config PitchConfig
config Pitch
p1
        NoteNumber
p2_nn <- Transposed -> Either PitchError NoteNumber
pitch_nn forall a b. (a -> b) -> a -> b
$ forall a b. RawPitch a -> RawPitch b
coerce forall a b. (a -> b) -> a -> b
$ forall {a} {a}. PitchConfig -> RawPitch a -> RawPitch a
apply_config PitchConfig
config Pitch
p2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
p1_nn NoteNumber
p2_nn forall a b. (a -> b) -> a -> b
$
            Y -> NoteNumber
Pitch.NoteNumber forall a b. (a -> b) -> a -> b
$ RealTime -> Y
RealTime.to_seconds forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize RealTime
x1 RealTime
x2 RealTime
x
    note :: PitchConfig -> Either PitchError Note
note PitchConfig
config = Transposed -> Either PitchError Note
pitch_note forall a b. (a -> b) -> a -> b
$ forall a b. RawPitch a -> RawPitch b
coerce forall a b. (a -> b) -> a -> b
$ forall {a} {a}. PitchConfig -> RawPitch a -> RawPitch a
apply_config PitchConfig
config forall a b. (a -> b) -> a -> b
$
        if RealTime
x forall a. Ord a => a -> a -> Bool
< RealTime
x1 then Pitch
p1 else Pitch
p2
    apply_config :: PitchConfig -> RawPitch a -> RawPitch a
apply_config PitchConfig
c RawPitch a
pitch = RawPitch a
pitch { pitch_config :: PitchConfig
pitch_config = PitchConfig
c forall a. Semigroup a => a -> a -> a
<> forall a. RawPitch a -> PitchConfig
pitch_config RawPitch a
pitch }

{- | This is an untransposed pitch.  All pitches have transposition signals
    from the dynamic state applied when they are converted to MIDI or whatever
    backend.  So if I want the final concrete pitch, I have to apply the
    transposition signals.  But if I want to emit a note with this pitch,
    I want the untransposed one, or the transposition will be applied twice.
    I use a phantom type parameter to keep them straight.
-}
type Pitch = RawPitch Untransposed_
-- | The transposed version of 'Pitch'.
type Transposed = RawPitch Transposed_
data Transposed_
data Untransposed_

-- | A pitch is an abstract value that can generate a 'Pitch.NoteNumber' or
-- symbolic 'Pitch.Note'.
data RawPitch a = Pitch {
    forall a. RawPitch a -> PitchConfig -> Either PitchError NoteNumber
pitch_eval_nn :: !(PitchConfig -> Either PitchError Pitch.NoteNumber)
    , forall a. RawPitch a -> PitchConfig -> Either PitchError Note
pitch_eval_note :: !(PitchConfig -> Either PitchError Pitch.Note)
    , forall a. RawPitch a -> Scale
pitch_scale :: !Scale
    , forall a. RawPitch a -> PitchConfig
pitch_config :: !PitchConfig
    }

-- | Make an abstract Pitch.
pitch :: Scale
    -> (PitchConfig -> Either PitchError Pitch.NoteNumber)
    -> (PitchConfig -> Either PitchError Pitch.Note)
    -> PitchConfig -> Pitch
pitch :: Scale
-> (PitchConfig -> Either PitchError NoteNumber)
-> (PitchConfig -> Either PitchError Note)
-> PitchConfig
-> Pitch
pitch Scale
scale PitchConfig -> Either PitchError NoteNumber
nn PitchConfig -> Either PitchError Note
note PitchConfig
config = Pitch
    { pitch_eval_nn :: PitchConfig -> Either PitchError NoteNumber
pitch_eval_nn = PitchConfig -> Either PitchError NoteNumber
nn
    , pitch_eval_note :: PitchConfig -> Either PitchError Note
pitch_eval_note = PitchConfig -> Either PitchError Note
note
    , pitch_scale :: Scale
pitch_scale = Scale
scale
    , pitch_config :: PitchConfig
pitch_config = PitchConfig
config
    }

coerce :: RawPitch a -> RawPitch b
coerce :: forall a b. RawPitch a -> RawPitch b
coerce = coerce :: forall a b. Coercible a b => a -> b
Coerce.coerce

-- | Usually I only want to evaluate a fully transposed pitch.  Exceptions
-- are documented by applying 'coerce'.
pitch_nn :: Transposed -> Either PitchError Pitch.NoteNumber
pitch_nn :: Transposed -> Either PitchError NoteNumber
pitch_nn Transposed
pitch = do
    NoteNumber
nn <- forall a. RawPitch a -> PitchConfig -> Either PitchError NoteNumber
pitch_eval_nn Transposed
pitch (forall a. RawPitch a -> PitchConfig
pitch_config Transposed
pitch)
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a.
RawPitch a -> Maybe NoteNumber -> PitchError -> PitchError
annotate_out_of_range Transposed
pitch (forall a. a -> Maybe a
Just NoteNumber
nn)) forall a b. (a -> b) -> a -> b
$
        if NoteNumber
0 forall a. Ord a => a -> a -> Bool
<= NoteNumber
nn Bool -> Bool -> Bool
&& NoteNumber
nn forall a. Ord a => a -> a -> Bool
<= NoteNumber
127 then forall (m :: * -> *) a. Monad m => a -> m a
return NoteNumber
nn
            else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ OutOfRange -> PitchError
OutOfRangeError OutOfRange
out_of_range

-- | Usually I only want to evaluate a fully transposed pitch.  Exceptions
-- are documented by applying 'coerce'.
pitch_note :: Transposed -> Either PitchError Pitch.Note
pitch_note :: Transposed -> Either PitchError Note
pitch_note Transposed
pitch = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a.
RawPitch a -> Maybe NoteNumber -> PitchError -> PitchError
annotate_out_of_range Transposed
pitch forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
    forall a. RawPitch a -> PitchConfig -> Either PitchError Note
pitch_eval_note Transposed
pitch (forall a. RawPitch a -> PitchConfig
pitch_config Transposed
pitch)

annotate_out_of_range :: RawPitch a -> Maybe Pitch.NoteNumber -> PitchError
    -> PitchError
annotate_out_of_range :: forall a.
RawPitch a -> Maybe NoteNumber -> PitchError -> PitchError
annotate_out_of_range RawPitch a
pitch Maybe NoteNumber
maybe_nn = (OutOfRange -> OutOfRange) -> PitchError -> PitchError
modify_out_of_range forall a b. (a -> b) -> a -> b
$ \OutOfRange
err -> OutOfRange
err
    { oor_nn :: Maybe NoteNumber
oor_nn = Maybe NoteNumber
maybe_nn
    , oor_transposers :: ControlValMap
oor_transposers = ControlValMap
filtered forall a. Semigroup a => a -> a -> a
<> OutOfRange -> ControlValMap
oor_transposers OutOfRange
err
    }
    where
    filtered :: ControlValMap
filtered = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Control
k Y
v -> Control
k forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Control
transposers Bool -> Bool -> Bool
&& Y
v forall a. Eq a => a -> a -> Bool
/= Y
0)
        ControlValMap
cmap
    PitchConfig Environ
_ ControlValMap
cmap = forall a. RawPitch a -> PitchConfig
pitch_config RawPitch a
pitch
    transposers :: Set Control
transposers = Scale -> Set Control
pscale_transposers (forall a. RawPitch a -> Scale
pitch_scale RawPitch a
pitch)

{- | A PitchConfig is the data that can continue to influence the pitch's
    frequency.

    Pitches are configured by controls and by an environ.  The controls
    are for values that change over time, such as transposition or tuning.
    They're combined additively, which is really only appropriate for
    transposition.  Controls are mostly applied only on conversion to the
    performer.  TODO I don't entirely remember why.  However, this leads to
    some trickiness because if I want to compare a pitch to an absolute
    NoteNumber, I need the final transposed value, but if I put it in an event
    it must be untransposed, or transposition will be applied twice.
    To avoid double.  To avoid this, there's a phantom type parameter to
    distinguish an untransposed 'Pitch' from a 'Transposed' one.

    The Environ is for symbolic configuration, such as key or tuning mode.
    Unlike controls, though, it's taken from the environ in scope when the pith
    is created.  Otherwise, you can't evaluate a pitch with a different key by
    setting the environ.
-}
data PitchConfig = PitchConfig !Environ !ScoreT.ControlValMap
    deriving (Int -> PitchConfig -> ShowS
[PitchConfig] -> ShowS
PitchConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PitchConfig] -> ShowS
$cshowList :: [PitchConfig] -> ShowS
show :: PitchConfig -> String
$cshow :: PitchConfig -> String
showsPrec :: Int -> PitchConfig -> ShowS
$cshowsPrec :: Int -> PitchConfig -> ShowS
Show)

instance Semigroup PitchConfig where
    PitchConfig Environ
env1 ControlValMap
c1 <> :: PitchConfig -> PitchConfig -> PitchConfig
<> PitchConfig Environ
env2 ControlValMap
c2 =
        Environ -> ControlValMap -> PitchConfig
PitchConfig (Environ
env1 forall a. Semigroup a => a -> a -> a
<> Environ
env2) (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Num a => a -> a -> a
(+) ControlValMap
c1 ControlValMap
c2)

instance Monoid PitchConfig where
    mempty :: PitchConfig
mempty = Environ -> ControlValMap -> PitchConfig
PitchConfig forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: PitchConfig -> PitchConfig -> PitchConfig
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | PSignal can't take a Scale because that would be a circular import.
-- Fortunately it only needs a few fields.  However, because of the
-- circularity, the Scale.Scale -> PSignal.Scale constructor is in
-- "Derive.Derive".
data Scale = Scale {
    -- | It can be useful to see the scale of a pitch, e.g. to create more
    -- pitches in the same scale as an existing pitch.
    Scale -> ScaleId
pscale_scale_id :: !Pitch.ScaleId
    -- | The set of transposer signals for this scale, as documented in
    -- 'Derive.Scale.scale_transposers'.
    --
    -- They are stored here because they're needed by 'to_nn'.  I could
    -- store them separately, e.g. in the 'Score.Event' alongside the
    -- event_pitch, but the scale at event creation time is not guaranteed to
    -- be the same as the one when the pitch was created, so the safest thing
    -- to do is keep it with the pitch itself.
    , Scale -> Set Control
pscale_transposers :: !(Set ScoreT.Control)
    } deriving (Int -> Scale -> ShowS
[Scale] -> ShowS
Scale -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scale] -> ShowS
$cshowList :: [Scale] -> ShowS
show :: Scale -> String
$cshow :: Scale -> String
showsPrec :: Int -> Scale -> ShowS
$cshowsPrec :: Int -> Scale -> ShowS
Show)

instance Pretty Scale where
    pretty :: Scale -> Text
pretty = forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scale -> ScaleId
pscale_scale_id

-- | It can't be reduced since it has lambdas, but at least this way you can
-- easily rnf things that contain it.
instance DeepSeq.NFData (RawPitch a) where
    rnf :: RawPitch a -> ()
rnf RawPitch a
_ = ()

instance Show (RawPitch a) where
    -- Show just the NN, so this is parseable by Util.PPrint.
    show :: RawPitch a -> String
show RawPitch a
p = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Show a => a -> String
show forall a. Pretty a => a -> String
prettys (Transposed -> Either PitchError NoteNumber
pitch_nn (forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p))

-- | Will look like: 62.95nn,4i(*wayang)
instance Pretty (RawPitch a) where
    pretty :: RawPitch a -> Text
pretty RawPitch a
p = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Show a => a -> Text
showt forall a. Pretty a => a -> Text
pretty (Transposed -> Either PitchError NoteNumber
pitch_nn (forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p)) forall a. Semigroup a => a -> a -> a
<> Text
","
        forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Show a => a -> Text
showt Note -> Text
Pitch.note_text (Transposed -> Either PitchError Note
pitch_note (forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p))
        forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. RawPitch a -> Scale
pitch_scale RawPitch a
p) forall a. Semigroup a => a -> a -> a
<> Text
")"

-- | Pitches have no literal syntax, but I have to print something.
instance ShowVal.ShowVal (RawPitch a) where
    show_val :: RawPitch a -> Text
show_val RawPitch a
pitch = Text
"<pitch: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RawPitch a
pitch forall a. Semigroup a => a -> a -> a
<> Text
">"

-- | Annotate a PitchError with additional info.  TODO I should probably
-- accumulate info all the way up to get a full "stack trace" of what happened
-- to a pitch (e.g. interpolation), which maybe means abandon PitchError and
-- just use Text, or go ever further with structure?  Meanwhile, this seems
-- to do ok practically speaking.
detailed_error :: RawPitch a -> PitchError -> Text
detailed_error :: forall a. RawPitch a -> PitchError -> Text
detailed_error RawPitch a
pitch PitchError
err = forall a. Monoid a => [a] -> a
mconcat
    [ forall a. Pretty a => a -> Text
pretty (Scale -> ScaleId
pscale_scale_id Scale
scale)
    , Text
":"
    , forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> Text
pretty forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ forall a. RawPitch a -> PitchConfig -> Either PitchError Note
pitch_eval_note RawPitch a
pitch forall a. Monoid a => a
mempty
    -- TODO the cmap includes non-transposing
    , if forall k a. Map k a -> Bool
Map.null ControlValMap
cmap then Text
"" else Text
" with transposition: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ControlValMap
cmap
    , Text
": ", forall a. Pretty a => a -> Text
pretty PitchError
err
    ]
    where
    PitchConfig Environ
_env ControlValMap
cmap_all = forall a. RawPitch a -> PitchConfig
pitch_config RawPitch a
pitch
    cmap :: ControlValMap
cmap = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection ControlValMap
cmap_all
        (forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const ()) (Scale -> Set Control
pscale_transposers Scale
scale))
    scale :: Scale
scale = forall a. RawPitch a -> Scale
pitch_scale RawPitch a
pitch

-- | Things that can go wrong evaluating a pitch.
data PitchError =
    UnparseableNote !Pitch.Note
    | OutOfRangeError !OutOfRange
    -- | Input note doesn't map to a scale note.
    | InvalidInput
    -- | A required environ value was missing or had the wrong type or value.
    -- Nothing if the value is missing, otherwise a Text description.
    | EnvironError !EnvKey.Key !(Maybe Text)
    -- | Same as EnvironError, but for control vals.
    | ControlError !ScoreT.Control !Text
    -- | The scale doesn't implement that operation.
    | NotImplemented
    -- | Other kind of error.
    | PitchError !Text
    deriving (PitchError -> PitchError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PitchError -> PitchError -> Bool
$c/= :: PitchError -> PitchError -> Bool
== :: PitchError -> PitchError -> Bool
$c== :: PitchError -> PitchError -> Bool
Eq, Eq PitchError
PitchError -> PitchError -> Bool
PitchError -> PitchError -> Ordering
PitchError -> PitchError -> PitchError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PitchError -> PitchError -> PitchError
$cmin :: PitchError -> PitchError -> PitchError
max :: PitchError -> PitchError -> PitchError
$cmax :: PitchError -> PitchError -> PitchError
>= :: PitchError -> PitchError -> Bool
$c>= :: PitchError -> PitchError -> Bool
> :: PitchError -> PitchError -> Bool
$c> :: PitchError -> PitchError -> Bool
<= :: PitchError -> PitchError -> Bool
$c<= :: PitchError -> PitchError -> Bool
< :: PitchError -> PitchError -> Bool
$c< :: PitchError -> PitchError -> Bool
compare :: PitchError -> PitchError -> Ordering
$ccompare :: PitchError -> PitchError -> Ordering
Ord, Int -> PitchError -> ShowS
[PitchError] -> ShowS
PitchError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PitchError] -> ShowS
$cshowList :: [PitchError] -> ShowS
show :: PitchError -> String
$cshow :: PitchError -> String
showsPrec :: Int -> PitchError -> ShowS
$cshowsPrec :: Int -> PitchError -> ShowS
Show)

{- | Note out of the scale's range.  The values are transpositions from
    the environment, in case it was out of range because of a transposition.

    Some scales have a restricted range, in which case they should throw
    'out_of_range', which 'pitch_nn' and 'pitch_note' will annotate with the
    transposition signals.  Other scales have unlimited range, in which case
    they're limited by the backend.  In this case 'pitch_nn' checks 0--127,
    which happens to be MIDI's limitation.
-}
data OutOfRange = OutOfRange {
    OutOfRange -> Maybe NoteNumber
oor_nn :: !(Maybe Pitch.NoteNumber)
    , OutOfRange -> Maybe Y
oor_degree :: !(Maybe Pitch.FSemi)
    , OutOfRange -> Maybe (Int, Int)
oor_valid :: !(Maybe (Int, Int))
    , OutOfRange -> ControlValMap
oor_transposers :: !ScoreT.ControlValMap
    } deriving (OutOfRange -> OutOfRange -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutOfRange -> OutOfRange -> Bool
$c/= :: OutOfRange -> OutOfRange -> Bool
== :: OutOfRange -> OutOfRange -> Bool
$c== :: OutOfRange -> OutOfRange -> Bool
Eq, Eq OutOfRange
OutOfRange -> OutOfRange -> Bool
OutOfRange -> OutOfRange -> Ordering
OutOfRange -> OutOfRange -> OutOfRange
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OutOfRange -> OutOfRange -> OutOfRange
$cmin :: OutOfRange -> OutOfRange -> OutOfRange
max :: OutOfRange -> OutOfRange -> OutOfRange
$cmax :: OutOfRange -> OutOfRange -> OutOfRange
>= :: OutOfRange -> OutOfRange -> Bool
$c>= :: OutOfRange -> OutOfRange -> Bool
> :: OutOfRange -> OutOfRange -> Bool
$c> :: OutOfRange -> OutOfRange -> Bool
<= :: OutOfRange -> OutOfRange -> Bool
$c<= :: OutOfRange -> OutOfRange -> Bool
< :: OutOfRange -> OutOfRange -> Bool
$c< :: OutOfRange -> OutOfRange -> Bool
compare :: OutOfRange -> OutOfRange -> Ordering
$ccompare :: OutOfRange -> OutOfRange -> Ordering
Ord, Int -> OutOfRange -> ShowS
[OutOfRange] -> ShowS
OutOfRange -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutOfRange] -> ShowS
$cshowList :: [OutOfRange] -> ShowS
show :: OutOfRange -> String
$cshow :: OutOfRange -> String
showsPrec :: Int -> OutOfRange -> ShowS
$cshowsPrec :: Int -> OutOfRange -> ShowS
Show)

out_of_range :: OutOfRange
out_of_range :: OutOfRange
out_of_range = Maybe NoteNumber
-> Maybe Y -> Maybe (Int, Int) -> ControlValMap -> OutOfRange
OutOfRange forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Monoid a => a
mempty

modify_out_of_range :: (OutOfRange -> OutOfRange) -> PitchError -> PitchError
modify_out_of_range :: (OutOfRange -> OutOfRange) -> PitchError -> PitchError
modify_out_of_range OutOfRange -> OutOfRange
modify (OutOfRangeError OutOfRange
err) = OutOfRange -> PitchError
OutOfRangeError (OutOfRange -> OutOfRange
modify OutOfRange
err)
modify_out_of_range OutOfRange -> OutOfRange
_ PitchError
err = PitchError
err

out_of_range_error :: Real a => a -> (Int, Int) -> PitchError
out_of_range_error :: forall a. Real a => a -> (Int, Int) -> PitchError
out_of_range_error a
semi (Int, Int)
valid = OutOfRange -> PitchError
OutOfRangeError forall a b. (a -> b) -> a -> b
$ OutOfRange
    { oor_nn :: Maybe NoteNumber
oor_nn = forall a. Maybe a
Nothing
    , oor_degree :: Maybe Y
oor_degree = forall a. a -> Maybe a
Just (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
semi)
    , oor_valid :: Maybe (Int, Int)
oor_valid = forall a. a -> Maybe a
Just (Int, Int)
valid
    , oor_transposers :: ControlValMap
oor_transposers = forall a. Monoid a => a
mempty
    }

instance Pretty PitchError where
    pretty :: PitchError -> Text
pretty PitchError
err = case PitchError
err of
        UnparseableNote Note
note -> Text
"unparseable note: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note
note
        OutOfRangeError OutOfRange
err -> forall a. Pretty a => a -> Text
pretty OutOfRange
err
        PitchError
InvalidInput -> Text
"invalid input"
        EnvironError Text
key Maybe Text
err ->
            Text
"environ value for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
key forall a. Semigroup a => a -> a -> a
<> Text
": "
                forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe Text
"not found" Maybe Text
err
        ControlError Control
control Text
err ->
            Text
"control value for " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Control
control forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
        PitchError
NotImplemented -> Text
"not implemented"
        PitchError Text
msg -> Text
msg

instance Pretty OutOfRange where
    pretty :: OutOfRange -> Text
pretty (OutOfRange Maybe NoteNumber
nn Maybe Y
semi Maybe (Int, Int)
valid ControlValMap
transposers) =
        [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
            [ Text
"pitch"
            , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" forall a. Pretty a => a -> Text
pretty Maybe NoteNumber
nn
            , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Y
n -> Text
"scale degree " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Y
n) Maybe Y
semi
            , Text
"out of range"
            , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\(Int
a, Int
b) -> forall a. Pretty a => a -> Text
pretty Int
a forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Int
b) Maybe (Int, Int)
valid
            , if ControlValMap
transposers forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then Text
"" else forall a. Pretty a => a -> Text
pretty ControlValMap
transposers
            ]

instance Pretty PitchConfig where
    format :: PitchConfig -> Doc
format (PitchConfig Environ
env ControlValMap
controls) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"PitchConfig"
        [ (Text
"environ", forall a. Pretty a => a -> Doc
Pretty.format Environ
env)
        , (Text
"controls", forall a. Pretty a => a -> Doc
Pretty.format ControlValMap
controls)
        ]

pitches_equal :: RawPitch a -> RawPitch a -> Bool
pitches_equal :: forall a. RawPitch a -> RawPitch a -> Bool
pitches_equal RawPitch a
p1 RawPitch a
p2 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
False) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
    NoteNumber -> NoteNumber -> Bool
Pitch.nns_equal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Either PitchError NoteNumber
pitch_nn (forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Transposed -> Either PitchError NoteNumber
pitch_nn (forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p2)

-- * Duration

-- | Some calls can operate in either RealTime or ScoreTime.
data Duration = RealDuration RealTime
    | ScoreDuration ScoreTime
    deriving (Duration -> Duration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Duration -> Duration -> Bool
$c/= :: Duration -> Duration -> Bool
== :: Duration -> Duration -> Bool
$c== :: Duration -> Duration -> Bool
Eq, Int -> Duration -> ShowS
[Duration] -> ShowS
Duration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Duration] -> ShowS
$cshowList :: [Duration] -> ShowS
show :: Duration -> String
$cshow :: Duration -> String
showsPrec :: Int -> Duration -> ShowS
$cshowsPrec :: Int -> Duration -> ShowS
Show)

data TimeType = Real | Score deriving (TimeType -> TimeType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeType -> TimeType -> Bool
$c/= :: TimeType -> TimeType -> Bool
== :: TimeType -> TimeType -> Bool
$c== :: TimeType -> TimeType -> Bool
Eq, Int -> TimeType -> ShowS
[TimeType] -> ShowS
TimeType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeType] -> ShowS
$cshowList :: [TimeType] -> ShowS
show :: TimeType -> String
$cshow :: TimeType -> String
showsPrec :: Int -> TimeType -> ShowS
$cshowsPrec :: Int -> TimeType -> ShowS
Show)

instance ShowVal.ShowVal Duration where
    show_val :: Duration -> Text
show_val (RealDuration RealTime
x) = forall a. ShowVal a => a -> Text
ShowVal.show_val RealTime
x
    show_val (ScoreDuration ScoreTime
x) = forall a. ShowVal a => a -> Text
ShowVal.show_val ScoreTime
x

instance Pretty Duration where
    pretty :: Duration -> Text
pretty (RealDuration RealTime
t) = forall a. Pretty a => a -> Text
pretty RealTime
t
    pretty (ScoreDuration ScoreTime
t) = forall a. Pretty a => a -> Text
pretty ScoreTime
t

-- | Duration can't be in Fractional since you can't multiple a RealDuration
-- by a ScoreDuration, but scaling operations are still useful.
multiply_duration :: Duration -> Double -> Duration
multiply_duration :: Duration -> Y -> Duration
multiply_duration (RealDuration RealTime
t) Y
n = RealTime -> Duration
RealDuration (RealTime
t forall a. Num a => a -> a -> a
* Y -> RealTime
RealTime.seconds Y
n)
multiply_duration (ScoreDuration ScoreTime
t) Y
n =
    ScoreTime -> Duration
ScoreDuration (ScoreTime
t forall a. Num a => a -> a -> a
* Y -> ScoreTime
ScoreTime.from_double Y
n)

-- * Environ

newtype Environ = Environ (Map EnvKey.Key Val)
    deriving (Int -> Environ -> ShowS
[Environ] -> ShowS
Environ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environ] -> ShowS
$cshowList :: [Environ] -> ShowS
show :: Environ -> String
$cshow :: Environ -> String
showsPrec :: Int -> Environ -> ShowS
$cshowsPrec :: Int -> Environ -> ShowS
Show, NonEmpty Environ -> Environ
Environ -> Environ -> Environ
forall b. Integral b => b -> Environ -> Environ
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Environ -> Environ
$cstimes :: forall b. Integral b => b -> Environ -> Environ
sconcat :: NonEmpty Environ -> Environ
$csconcat :: NonEmpty Environ -> Environ
<> :: Environ -> Environ -> Environ
$c<> :: Environ -> Environ -> Environ
Semigroup, Semigroup Environ
Environ
[Environ] -> Environ
Environ -> Environ -> Environ
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Environ] -> Environ
$cmconcat :: [Environ] -> Environ
mappend :: Environ -> Environ -> Environ
$cmappend :: Environ -> Environ -> Environ
mempty :: Environ
$cmempty :: Environ
Monoid, Environ -> ()
forall a. (a -> ()) -> NFData a
rnf :: Environ -> ()
$crnf :: Environ -> ()
DeepSeq.NFData)

-- Environ keys are always Text, and it's annoying to have quotes on them.
instance Pretty Environ where
    format :: Environ -> Doc
format (Environ Map Text Val
env) = [(Doc, Doc)] -> Doc
Pretty.formatMap
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Doc
Pretty.text forall a. Pretty a => a -> Doc
Pretty.format) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Map Text Val
env

null :: Environ -> Bool
null :: Environ -> Bool
null (Environ Map Text Val
env) = forall k a. Map k a -> Bool
Map.null Map Text Val
env

-- | Insert a val directly, with no typechecking.
insert :: EnvKey.Key -> Val -> Environ -> Environ
insert :: Text -> Val -> Environ -> Environ
insert Text
name Val
val (Environ Map Text Val
env) = Map Text Val -> Environ
Environ forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Val
val Map Text Val
env

lookup :: EnvKey.Key -> Environ -> Maybe Val
lookup :: Text -> Environ -> Maybe Val
lookup Text
name (Environ Map Text Val
env) = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text Val
env

environ_attributes :: Environ -> Attrs.Attributes
environ_attributes :: Environ -> Attributes
environ_attributes Environ
environ =
    case Text -> Environ -> Maybe Val
lookup Text
EnvKey.attributes Environ
environ of
        Just (VAttributes Attributes
attrs) -> Attributes
attrs
        Maybe Val
_ -> forall a. Monoid a => a
mempty

-- * Val

-- | This is the type of first class values in the tracklang.  It's main
-- purpose is the type for arguments to tracklang calls, and val calls' return
-- type.
data Val =
    -- | A number with an optional type suffix.  It also has a ratio style
    -- literal, though the output is still a floating point value, not a true
    -- ratio.
    --
    -- Constant literal: @42.23@, @-.4@, @1c@, @-2.4d@, @3/2@, @-3/2@, @0x7f@.
    --
    -- Signal literal: @(signal d 0 0 1 1)@.
    VSignal !(ScoreT.Typed Signal.Control)
    -- | No literal, but is returned from val calls, notably scale calls.
    | VPitch !Pitch
    | VPSignal !PSignal
    -- | A set of Attributes for an instrument.
    --
    -- Literal: @+attr@, @+attr1+attr2@.
    | VAttributes !Attrs.Attributes

    -- | A control name.  An optional value gives a default if the control
    -- isn't present.
    --
    -- Literal: @%control@, @%control,.4@
    | VControlRef !ControlRef
    -- | A pitch control name.  The scale is taken from the environ.  Unlike
    -- a control signal, the empty string is a valid signal name and means the
    -- default pitch signal.  The @#@ val call is needed to make a pitch signal
    -- with a default.
    --
    -- Literal: @\#@, @\#pitch@, @(# pitch (4c))@
    | VPControlRef !PControlRef

    -- | A parsed 'Pitch.Note'.  This is useful for things for which a textual
    -- 'Pitch.Note' is too high level and a numerical 'Pitch.NoteNumber' is too
    -- low level, like instrument ranges.
    --
    -- Literal: @(pitch 4 0 1)@ -> 4c#.
    | VNotePitch !Pitch.Pitch

    -- | A string.  There is an unquoted and a quoted form, parsed at
    -- 'Derive.Parse.p_unquoted_str' and 'Derive.Parse.p_str'.
    --
    -- Literal: @func@, @\'hello\'@, @\'quinn\'\'s hat\'@
    | VStr !Expr.Str

    -- | A quoted expression.  Quoted calls are resolved by "Derive.Sig" when
    -- it typechecks arguments.  This way you can set an argument default to
    -- an expression that will be evaluated every time the call occurs.
    -- Derive.Sig expects that the expression is a valid val call, which means
    -- no pipes.
    --
    -- Literal: @\"(a b c)@
    | VQuoted !Quoted
    | VCFunction !CFunction
    | VPFunction !PFunction
    -- | An explicit not-given arg for functions so you can use positional
    -- args with defaults.
    --
    -- Literal: @_@
    | VNotGiven
    -- | A token used as a separator when calls want to parse their argument
    -- lists via their own complicated means.  TODO only used by old gamakam,
    -- get rid of this
    --
    -- Literal: @;@
    | VSeparator
    -- | List of values.
    --
    -- Literal: @(list)@, @(list 1 2)@, @(list (x) (y))@
    | VList ![Val]
    deriving (Int -> Val -> ShowS
[Val] -> ShowS
Val -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Val] -> ShowS
$cshowList :: [Val] -> ShowS
show :: Val -> String
$cshow :: Val -> String
showsPrec :: Int -> Val -> ShowS
$cshowsPrec :: Int -> Val -> ShowS
Show)

-- | Return Nothing if the Vals can't be compared, and whether or not they're
-- equal otherwise.
vals_equal :: Val -> Val -> Maybe Bool
vals_equal :: Val -> Val -> Maybe Bool
vals_equal Val
x Val
y = case (Val
x, Val
y) of
    (VSignal Typed Control
a, VSignal Typed Control
b) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Typed Control
a forall a. Eq a => a -> a -> Bool
== Typed Control
b
    (VPitch Pitch
a, VPitch Pitch
b) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. RawPitch a -> RawPitch a -> Bool
pitches_equal Pitch
a Pitch
b
    -- I'm not going to implement this right now.  vals_equal is only used in
    -- Conditional anyway, and who is going to be comparing pitch signals?
    (VPSignal PSignal
_, VPSignal PSignal
_) -> forall a. Maybe a
Nothing
    (VAttributes Attributes
a, VAttributes Attributes
b) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Attributes
a forall a. Eq a => a -> a -> Bool
== Attributes
b
    (VControlRef ControlRef
a, VControlRef ControlRef
b) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ControlRef
a forall a. Eq a => a -> a -> Bool
== ControlRef
b
    -- This could use pitches_equal, but don't bother until I have a need for
    -- it.
    (VPControlRef PControlRef
_, VPControlRef PControlRef
_) -> forall a. Maybe a
Nothing
    (VNotePitch Pitch
a, VNotePitch Pitch
b) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Pitch
a forall a. Eq a => a -> a -> Bool
== Pitch
b
    (VStr Str
a, VStr Str
b) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Str
a forall a. Eq a => a -> a -> Bool
== Str
b
    (VQuoted (Quoted Expr
a), VQuoted (Quoted Expr
b)) ->
        forall a. (a -> a -> Maybe Bool) -> [a] -> [a] -> Maybe Bool
lists_equal Call Val -> Call Val -> Maybe Bool
calls_equal (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
a) (forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
b)
    (VCFunction CFunction
_, VCFunction CFunction
_) -> forall a. Maybe a
Nothing
    (Val
VNotGiven, Val
VNotGiven) -> forall a. a -> Maybe a
Just Bool
True
    (Val
VSeparator, Val
VSeparator) -> forall a. a -> Maybe a
Just Bool
True
    (VList [Val]
a, VList [Val]
b) -> forall a. (a -> a -> Maybe Bool) -> [a] -> [a] -> Maybe Bool
lists_equal Val -> Val -> Maybe Bool
vals_equal [Val]
a [Val]
b
    (Val, Val)
_ -> forall a. Maybe a
Nothing

types_equal :: Val -> Val -> Bool
types_equal :: Val -> Val -> Bool
types_equal Val
x Val
y = case (Val
x, Val
y) of
    (VSignal {}, VSignal {}) -> Bool
True
    (VPitch {}, VPitch {}) -> Bool
True
    (VPSignal {}, VPSignal {}) -> Bool
True
    (VAttributes {}, VAttributes {}) -> Bool
True
    (VControlRef {}, VControlRef {}) -> Bool
True
    (VPControlRef {}, VPControlRef {}) -> Bool
True
    (VNotePitch {}, VNotePitch {}) -> Bool
True
    (VStr {}, VStr {}) -> Bool
True
    (VQuoted {}, VQuoted {}) -> Bool
True
    (VCFunction {}, VCFunction {}) -> Bool
True
    (VPFunction {}, VPFunction {}) -> Bool
True
    (Val
VNotGiven, Val
VNotGiven) -> Bool
True
    (Val
VSeparator, Val
VSeparator) -> Bool
True
    (VList {}, VList {}) -> Bool
True
    (Val, Val)
_ -> Bool
False

lists_equal :: (a -> a -> Maybe Bool) -> [a] -> [a] -> Maybe Bool
lists_equal :: forall a. (a -> a -> Maybe Bool) -> [a] -> [a] -> Maybe Bool
lists_equal a -> a -> Maybe Bool
eq = [a] -> [a] -> Maybe Bool
go
    where
    go :: [a] -> [a] -> Maybe Bool
go (a
a:[a]
as) (a
b:[a]
bs) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing
        (\Bool
t -> if Bool
t then [a] -> [a] -> Maybe Bool
go [a]
as [a]
bs else forall a. a -> Maybe a
Just Bool
False) (a -> a -> Maybe Bool
eq a
a a
b)
    go [a]
_ [a]
_ = forall a. a -> Maybe a
Just Bool
False

val_to_mini :: Val -> Maybe Expr.MiniVal
val_to_mini :: Val -> Maybe MiniVal
val_to_mini = \case
    VStr Str
a -> forall a. a -> Maybe a
Just (Str -> MiniVal
Expr.VStr Str
a)
    VSignal Typed Control
sig -> Typed Y -> MiniVal
Expr.VNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {k} (kind :: k). Signal kind -> Maybe Y
Signal.constant_val Typed Control
sig
    Val
_ -> forall a. Maybe a
Nothing

-- | This instance is actually invalid due to showing VPitch, which has no
-- literal, and for 'Val', showing 'PControlRef', which amounts to the same
-- thing.  I use this to treat any Val as a Str to re-evaluate it.  Being
-- invalid means that a VPitch or VPControlRef with a default will cause
-- a parse failure, but I'll have to see if this becomes a problem in practice.
instance ShowVal.ShowVal Val where
    show_val :: Val -> Text
show_val = \case
        VSignal Typed Control
sig -> Typed Control -> Text
show_signal Typed Control
sig
        VPitch Pitch
pitch -> forall a. ShowVal a => a -> Text
ShowVal.show_val Pitch
pitch
        VPSignal PSignal
sig -> PSignal -> Text
show_psignal PSignal
sig
        VAttributes Attributes
attrs -> forall a. ShowVal a => a -> Text
ShowVal.show_val Attributes
attrs
        VControlRef ControlRef
ref -> forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
ref
        VPControlRef PControlRef
ref -> forall a. ShowVal a => a -> Text
ShowVal.show_val PControlRef
ref
        VNotePitch Pitch
pitch -> forall a. ShowVal a => a -> Text
ShowVal.show_val Pitch
pitch
        VStr Str
str -> forall a. ShowVal a => a -> Text
ShowVal.show_val Str
str
        VQuoted Quoted
quoted -> forall a. ShowVal a => a -> Text
ShowVal.show_val Quoted
quoted
        VCFunction CFunction
f -> forall a. ShowVal a => a -> Text
ShowVal.show_val CFunction
f
        VPFunction PFunction
f -> forall a. ShowVal a => a -> Text
ShowVal.show_val PFunction
f
        Val
VNotGiven -> Text
"_"
        Val
VSeparator -> Text
";"
        VList [Val]
vals -> forall a. ShowVal a => a -> Text
ShowVal.show_val [Val]
vals

instance ShowVal.ShowVal (ScoreT.Typed Signal.Control) where
    show_val :: Typed Control -> Text
show_val = Typed Control -> Text
show_signal

-- | ShowVal for VSignal.
--
-- > 1c -- constant with chromatic type
-- > (signal 0 1 1 1) -- [(0, 1), (1, 1)], untyped
show_signal :: ScoreT.Typed Signal.Control -> Text
show_signal :: Typed Control -> Text
show_signal (ScoreT.Typed Type
typ Control
sig)
    | Just Y
c <- forall {k} (kind :: k). Signal kind -> Maybe Y
Signal.constant_val Control
sig = forall a. ShowVal a => a -> Text
ShowVal.show_val (forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ Y
c)
    | Bool
otherwise = [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall a. Semigroup a => a -> a -> a
<>Text
")") forall a b. (a -> b) -> a -> b
$
        Text
"(signal" forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Text
"") [forall a. ShowVal a => a -> Text
ShowVal.show_val Type
typ] forall a. [a] -> [a] -> [a]
++
            [ forall a. ShowVal a => a -> Text
ShowVal.show_val Y
v
            | (RealTime
x, Y
y) <- forall {k} (kind :: k). Signal kind -> [(RealTime, Y)]
Signal.to_pairs Control
sig, Y
v <- [RealTime -> Y
RealTime.to_seconds RealTime
x, Y
y]
            ]

instance ShowVal.ShowVal PSignal where show_val :: PSignal -> Text
show_val = PSignal -> Text
show_psignal

-- | ShowVal for VPSignal.
--
-- TODO probably bogus? ShowVal (RawPitch a) just punts and uses <>s
-- Which this also uses.  Ideal if I can get back to symbolic, like (4c).
-- Otherwise, convert to nn, since symbolic depends on what's in scope?
-- The fact that I never trip on <>s implies that improper ShowVal for
-- pitch is not practically a problem.
show_psignal :: PSignal -> Text
show_psignal :: PSignal -> Text
show_psignal PSignal
sig
    | Just Pitch
c <- PSignal -> Maybe Pitch
constant_val PSignal
sig = forall a. ShowVal a => a -> Text
ShowVal.show_val Pitch
c
    | Bool
otherwise = [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> [a] -> [a]
Lists.mapLast (forall a. Semigroup a => a -> a -> a
<>Text
")") forall a b. (a -> b) -> a -> b
$
        Text
"(psignal" forall a. a -> [a] -> [a]
:
            [ Text
s
            | (RealTime
x, Pitch
y) <- PSignal -> [(RealTime, Pitch)]
to_pairs PSignal
sig
            , Text
s <- [forall a. ShowVal a => a -> Text
ShowVal.show_val RealTime
x, forall a. ShowVal a => a -> Text
ShowVal.show_val Pitch
y]
            ]
    where
    -- These are in PSignal, but have to be here too to avoid a circular
    -- import.
    constant_val :: PSignal -> Maybe Pitch
    constant_val :: PSignal -> Maybe Pitch
constant_val = forall (v :: * -> *) a.
Vector v (Sample a) =>
SignalS v a -> Maybe a
Segment.constant_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Boxed Pitch
_signal
    to_pairs :: PSignal -> [(RealTime, Pitch)]
to_pairs = forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> [(RealTime, y)]
Segment.to_pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Boxed Pitch
_signal

instance Pretty Val where
    pretty :: Val -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val

instance DeepSeq.NFData Val where
    rnf :: Val -> ()
rnf (VStr Str
s) = forall a. NFData a => a -> ()
DeepSeq.rnf Str
s
    rnf Val
_ = ()

newtype Quoted = Quoted Expr deriving (Int -> Quoted -> ShowS
[Quoted] -> ShowS
Quoted -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Quoted] -> ShowS
$cshowList :: [Quoted] -> ShowS
show :: Quoted -> String
$cshow :: Quoted -> String
showsPrec :: Int -> Quoted -> ShowS
$cshowsPrec :: Int -> Quoted -> ShowS
Show)

-- | Unlike Exprs in general, a Quoted Expr should be representable with
-- show_val.  This is because a Quoted has only been parsed, not evaluated,
-- so it shouldn't have anything unshowable, like pitches.
instance ShowVal.ShowVal Quoted where
    show_val :: Quoted -> Text
show_val (Quoted Expr
expr) = Text
"\"(" forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Expr
expr forall a. Semigroup a => a -> a -> a
<> Text
")"
instance Pretty Quoted where pretty :: Quoted -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val

-- | Show a str intended for call position.  Call position is special in
-- that it can contain any character except space and equals without quoting.
show_call_val :: Val -> Text
show_call_val :: Val -> Text
show_call_val (VStr (Expr.Str Text
sym)) = Text
sym
show_call_val Val
val = forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val

-- ** val utils

-- | Make an untyped VSignal.
num :: Double -> Val
num :: Y -> Val
num = Type -> Y -> Val
constant Type
ScoreT.Untyped

constant_val :: Val -> Maybe (ScoreT.Typed Signal.Y)
constant_val :: Val -> Maybe (Typed Y)
constant_val (VSignal (ScoreT.Typed Type
typ Control
sig)) =
    forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (kind :: k). Signal kind -> Maybe Y
Signal.constant_val Control
sig
constant_val Val
_ = forall a. Maybe a
Nothing

constant :: ScoreT.Type -> Signal.Y -> Val
constant :: Type -> Y -> Val
constant Type
typ = Typed Control -> Val
VSignal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Y -> Signal kind
Signal.constant

score_time :: ScoreTime -> Val
score_time :: ScoreTime -> Val
score_time = Type -> Y -> Val
constant Type
ScoreT.Score forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Y
ScoreTime.to_double

real_time :: RealTime -> Val
real_time :: RealTime -> Val
real_time = Type -> Y -> Val
constant Type
ScoreT.Real forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Y
RealTime.to_seconds

transposition :: Pitch.Transpose -> Val
transposition :: Transpose -> Val
transposition Transpose
t = case Transpose
t of
    Pitch.Diatonic Y
d -> Type -> Y -> Val
constant Type
ScoreT.Diatonic Y
d
    Pitch.Chromatic Y
d -> Type -> Y -> Val
constant Type
ScoreT.Chromatic Y
d
    Pitch.Nn Y
d -> Type -> Y -> Val
constant Type
ScoreT.Nn Y
d

str :: Text -> Val
str :: Text -> Val
str = Str -> Val
VStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str

to_scale_id :: Val -> Maybe Pitch.ScaleId
to_scale_id :: Val -> Maybe ScaleId
to_scale_id (VStr (Expr.Str Text
a)) = forall a. a -> Maybe a
Just (Text -> ScaleId
Pitch.ScaleId Text
a)
to_scale_id Val
_ = forall a. Maybe a
Nothing

quoted :: Expr.Symbol -> [Val] -> Quoted
quoted :: Symbol -> [Val] -> Quoted
quoted Symbol
sym [Val]
args = Expr -> Quoted
Quoted forall a b. (a -> b) -> a -> b
$ forall val. Call val -> Expr val
Expr.generator (forall val. Symbol -> [val] -> Call val
Expr.call Symbol
sym [Val]
args)

quoted0 :: Expr.Symbol -> Quoted
quoted0 :: Symbol -> Quoted
quoted0 Symbol
sym = Symbol -> [Val] -> Quoted
quoted Symbol
sym []

-- * Ref

type ControlRef = Ref ScoreT.Control ScoreT.TypedSignal
type PControlRef = Ref ScoreT.PControl PSignal

data Ref control val = Ref control (Maybe val)
    deriving (Ref control val -> Ref control val -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall control val.
(Eq control, Eq val) =>
Ref control val -> Ref control val -> Bool
/= :: Ref control val -> Ref control val -> Bool
$c/= :: forall control val.
(Eq control, Eq val) =>
Ref control val -> Ref control val -> Bool
== :: Ref control val -> Ref control val -> Bool
$c== :: forall control val.
(Eq control, Eq val) =>
Ref control val -> Ref control val -> Bool
Eq, Int -> Ref control val -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall control val.
(Show control, Show val) =>
Int -> Ref control val -> ShowS
forall control val.
(Show control, Show val) =>
[Ref control val] -> ShowS
forall control val.
(Show control, Show val) =>
Ref control val -> String
showList :: [Ref control val] -> ShowS
$cshowList :: forall control val.
(Show control, Show val) =>
[Ref control val] -> ShowS
show :: Ref control val -> String
$cshow :: forall control val.
(Show control, Show val) =>
Ref control val -> String
showsPrec :: Int -> Ref control val -> ShowS
$cshowsPrec :: forall control val.
(Show control, Show val) =>
Int -> Ref control val -> ShowS
Show)

instance (Serialize.Serialize control, Serialize.Serialize val) =>
        Serialize.Serialize (Ref control val) where
    put :: Putter (Ref control val)
put (Ref control
a Maybe val
b) = Word8 -> PutM ()
Serialize.put_tag Word8
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put control
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Maybe val
b
    {-
        This has to be careful to maintain compatibility with the old Ref:

        data Ref control val =
            ControlSignal val
            | DefaultedControl control val
            | LiteralControl control
        get = Serialize.get_tag >>= \case
            0 -> ControlSignal <$> Serialize.get
            1 -> DefaultedControl <$> Serialize.get <*> Serialize.get
            2 -> LiteralControl <$> Serialize.get
    -}
    get :: Get (Ref control val)
get = Get Word8
Serialize.get_tag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Word8
0 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"new Ref doesn't have ControlSignal"
        Word8
1 -> forall control val. control -> Maybe val -> Ref control val
Ref forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get)
        Word8
2 -> forall control val. control -> Maybe val -> Ref control val
Ref forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Word8
3 -> forall control val. control -> Maybe val -> Ref control val
Ref forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get
        Word8
n -> forall a. String -> Word8 -> Get a
Serialize.bad_tag String
"DeriveT.Ref" Word8
n

instance ShowVal.ShowVal ControlRef where
    show_val :: ControlRef -> Text
show_val = forall sig control.
ShowVal sig =>
(control -> Text) -> Ref control sig -> Text
show_ref (Char -> Text -> Text
Text.cons Char
'%' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Text
ScoreT.control_name)

instance Pretty ControlRef where pretty :: ControlRef -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val

-- | There's no way to convert a pitch back into the expression that produced
-- it, so this is the best I can do.
--
-- Similar to ShowVal 'ControlRef', there's no signal literal so I use the
-- value at 0.  A pitch can be turned into an expression, but not necessarily
-- accurately since it doesn't take things like pitch interpolation into
-- account.
instance ShowVal.ShowVal PControlRef where
    show_val :: PControlRef -> Text
show_val = forall sig control.
ShowVal sig =>
(control -> Text) -> Ref control sig -> Text
show_ref (Char -> Text -> Text
Text.cons Char
'#' forall b c a. (b -> c) -> (a -> b) -> a -> c
. PControl -> Text
ScoreT.pcontrol_name)

instance Pretty PControlRef where pretty :: PControlRef -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val

show_ref :: ShowVal.ShowVal sig => (control -> Text) -> Ref control sig -> Text
show_ref :: forall sig control.
ShowVal sig =>
(control -> Text) -> Ref control sig -> Text
show_ref control -> Text
ref_text (Ref control
control Maybe sig
deflt) =
        control -> Text
ref_text control
control forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"," <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val) Maybe sig
deflt

-- * Expr

type Expr = Expr.Expr Val
type Call = Expr.Call Val
type Term = Expr.Term Val

instance ShowVal.ShowVal (Expr.Expr Val) where show_val :: Expr -> Text
show_val = forall val. ShowVal (Call val) => Expr val -> Text
Expr.show_val_expr
instance ShowVal.ShowVal (Expr.Call Val) where
    show_val :: Call Val -> Text
show_val = forall val.
ShowVal (Term val) =>
(val -> Maybe Text) -> Call val -> Text
Expr.show_val_call forall a b. (a -> b) -> a -> b
$ \case
        VStr (Expr.Str Text
op) -> forall a. a -> Maybe a
Just Text
op
        Val
_ -> forall a. Maybe a
Nothing
instance ShowVal.ShowVal (Expr.Term Val) where show_val :: Term Val -> Text
show_val = forall val. (ShowVal val, ShowVal (Call val)) => Term val -> Text
Expr.show_val_term

instance Pretty (Expr.Call Val) where pretty :: Call Val -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val
instance Pretty (Expr.Term Val) where pretty :: Term Val -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val

calls_equal :: Call -> Call -> Maybe Bool
calls_equal :: Call Val -> Call Val -> Maybe Bool
calls_equal (Expr.Call Symbol
sym1 [Term Val]
args1) (Expr.Call Symbol
sym2 [Term Val]
args2)
    | Symbol
sym1 forall a. Eq a => a -> a -> Bool
/= Symbol
sym2 = forall a. a -> Maybe a
Just Bool
False
    | Bool
otherwise = forall a. (a -> a -> Maybe Bool) -> [a] -> [a] -> Maybe Bool
lists_equal Term Val -> Term Val -> Maybe Bool
terms_equal [Term Val]
args1 [Term Val]
args2

terms_equal :: Term -> Term -> Maybe Bool
terms_equal :: Term Val -> Term Val -> Maybe Bool
terms_equal (Expr.ValCall Call Val
call1) (Expr.ValCall Call Val
call2) = Call Val -> Call Val -> Maybe Bool
calls_equal Call Val
call1 Call Val
call2
terms_equal (Expr.Literal Val
val1) (Expr.Literal Val
val2) = Val -> Val -> Maybe Bool
vals_equal Val
val1 Val
val2
terms_equal Term Val
_ Term Val
_ = forall a. a -> Maybe a
Just Bool
False

-- | This is just a 'Call', but it's expected to return a VPitch.
type PitchCall = Call

-- ** call utils

-- | Transform the Symbols in a Call.
map_str :: (Expr.Str -> Expr.Str) -> Call -> Call
map_str :: (Str -> Str) -> Call Val -> Call Val
map_str Str -> Str
f = Call Val -> Call Val
call
    where
    call :: Call Val -> Call Val
call (Expr.Call Symbol
sym [Term Val]
terms) = forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
sym (forall a b. (a -> b) -> [a] -> [b]
map Term Val -> Term Val
term [Term Val]
terms)
    term :: Term Val -> Term Val
term (Expr.ValCall Call Val
c) = forall val. Call val -> Term val
Expr.ValCall (Call Val -> Call Val
call Call Val
c)
    term (Expr.Literal (VStr Str
str)) = forall val. val -> Term val
Expr.Literal (Str -> Val
VStr (Str -> Str
f Str
str))
    term (Expr.Literal Val
lit) = forall val. val -> Term val
Expr.Literal Val
lit

-- * type aliases

type PitchMap = Map ScoreT.PControl PSignal
type PitchFunction = RealTime -> Maybe Pitch

-- * ControlFunction

{- | Another representation of a signal, complementary to 'Signal.Control'.
    It's more powerful because it has access to a subset of the Dynamic state,
    as well as the 'Control' is was originally bound to.  However, it's also
    less powerful because you can't inspect it to see if it's constant, or emit
    exactly the samples present without resorting to sampling, or draw it on
    the UI.  This is the ubiquitous code vs. data tradeoff.

    In addition, the main motivation to add control functions was to randomize
    values, which means that, unlike signals, they're not actually functions at
    all, and thus couldn't be rendered as a continuous signal.  This means that
    functions are only suitable for sampling at points, not for slicing over
    time ranges.

    Having both signals and functions is awkward because then some calls may
    ignore a control function if they require a signal, which is inconsistent
    and confusing.  This is the case for all control generators since the
    signal usually is on a control track and will wind up being rendered on the
    UI.  So the convention is that control functions are generally just
    modifications of an underlying signal, rather than synthesizing a signal.

    Another awkward thing about CFunction is that it really wants to
    be in Deriver, but can't, due to circular imports.  The alternative is
    a giant hs-boot file, or lumping thousands of lines into
    "Derive.Deriver.Monad".  Currently it's a plain function but if I want
    logging and exceptions I could use "Derive.Deriver.DeriveM".  It still
    wouldn't solve the main problem, which is that I can't reuse the Deriver
    functions, and instead have to rewrite them.

    See NOTE [control-function].
-}
data CFunction = CFunction {
    -- | Human readable name.
    --
    -- TODO I thought of making it the expression that created this, for
    -- serialization, but not implemented yet.
    CFunction -> Text
cf_name :: !Text
    , CFunction -> Typed Control
cf_signal :: !ScoreT.TypedSignal
    {- | This is modifying an underlying signal.

        The function may be created before the signal it modifies, e.g.
        @dyn=(cf-rnd .2)@ will apply to whatever values the @dyn@ signal later
        takes. There is special hackery in Env.put_val to merge a signal into a
        CFunction if present.  The signal should start at const 0 by
        convention, since many functions make sense against 0 too, and it would
        be annoying to plumb out an error from 'call_cfunction'.
    -}
    , CFunction -> Dynamic -> Control -> RealTime -> Y
cf_function :: !(Dynamic -> Signal.Control -> RealTime -> Signal.Y)
    }

-- | A simple pure function.
data PFunction = PFunction {
    PFunction -> Text
pf_name :: !Text
    , PFunction -> TypedFunction
pf_function :: !ScoreT.TypedFunction
    }

instance Show PFunction where show :: PFunction -> String
show = forall a. Pretty a => a -> String
prettys
instance Pretty PFunction where pretty :: PFunction -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val
instance ShowVal.ShowVal PFunction where show_val :: PFunction -> Text
show_val = PFunction -> Text
pf_name

instance DeepSeq.NFData CFunction where
    rnf :: CFunction -> ()
rnf CFunction
_ = () -- bogus instance so Derive.Dynamic can have one
instance Show CFunction where show :: CFunction -> String
show = Text -> String
untxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty
instance Pretty CFunction where
    pretty :: CFunction -> Text
pretty CFunction
cf = Text
"((CFunction " forall a. Semigroup a => a -> a -> a
<> CFunction -> Text
cf_name CFunction
cf forall a. Semigroup a => a -> a -> a
<> Text
"))"

-- | TODO this isn't a real ShowVal, I'd have to record the whole expression.
instance ShowVal.ShowVal CFunction where
    show_val :: CFunction -> Text
show_val = CFunction -> Text
cf_name

call_cfunction :: Dynamic -> CFunction -> ScoreT.TypedFunction
call_cfunction :: Dynamic -> CFunction -> TypedFunction
call_cfunction Dynamic
cf_dyn CFunction
cf = forall a. Type -> a -> Typed a
ScoreT.Typed Type
typ (CFunction -> Dynamic -> Control -> RealTime -> Y
cf_function CFunction
cf Dynamic
cf_dyn Control
signal)
    where ScoreT.Typed Type
typ Control
signal = CFunction -> Typed Control
cf_signal CFunction
cf

-- | A stripped down "Derive.Deriver.Monad.Dynamic" for ControlFunctions
-- to use.  The duplication is unfortunate, see 'CFunction'.
data Dynamic = Dynamic {
    Dynamic -> PSignal
dyn_pitch :: !PSignal
    , Dynamic -> Environ
dyn_environ :: !Environ
    -- | This is from 'Derive.Deriver.Monad.state_event_serial'.
    , Dynamic -> Int
dyn_event_serial :: !Int
    , Dynamic -> Warp
dyn_warp :: !Warp.Warp
    , Dynamic -> Marklists
dyn_ruler :: Ruler.Marklists -- intentionally lazy
    } deriving (Int -> Dynamic -> ShowS
[Dynamic] -> ShowS
Dynamic -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dynamic] -> ShowS
$cshowList :: [Dynamic] -> ShowS
show :: Dynamic -> String
$cshow :: Dynamic -> String
showsPrec :: Int -> Dynamic -> ShowS
$cshowsPrec :: Int -> Dynamic -> ShowS
Show)

empty_dynamic :: Dynamic
empty_dynamic :: Dynamic
empty_dynamic = Dynamic
    { dyn_pitch :: PSignal
dyn_pitch = forall a. Monoid a => a
mempty
    , dyn_environ :: Environ
dyn_environ = forall a. Monoid a => a
mempty
    , dyn_event_serial :: Int
dyn_event_serial = Int
0
    , dyn_warp :: Warp
dyn_warp = Warp
Warp.identity
    , dyn_ruler :: Marklists
dyn_ruler = forall a. Monoid a => a
mempty
    }

{- NOTE [control-function]

    . The UI is what I want, which is that I write a start=(rnd .1 .3), so
    let's keep that.  Then it gets serialized as an expression (rnd .1 .3).

    Stuff I don't like:

    . The UI where it's in a different namespace than signals, so dyn=(rnd) vs
    %dyn=.5.  Maybe this comes from the signal vs env namespace though.

    . UI where they have an implicit signal backing.  I think I don't need
    that, if it's a random addition it should be explicit, like
    dyn=%dyn + rnd .5.  If they are in the same namespace then something like
    dyn=(+ dyn (rnd .5)), or even dyn=+(rnd .5)

    . Also plenty is wrong with the implementation, extra Dynamic.

    Problems to solve:
    - Unify signal and env namespaces.
    - Unify Val and RVal.  Make Val serializable.
    - Make so calls can coerce to ScoreT.TypedFunction.
    - Unify ControlFunction with ValCall.
      . Why though?  Can't it be its own thing?

    Control functions add unwanted complexity, but I couldn't think of
    a simpler way to randomized or synthesized control values.  Here's the
    history:

    . One way would be look for a corresponding <>"-rnd" control for a range.
      But what about distribution?
    . If I pass RealTime to a Quoted value, I could write the parameter as
      "(rnd-signal x y).  But it would have to be curried to still accept the
      "at" parameter, or have access to it through Context.  It could look at
      the stack, which is how the random seed works.  Seems complicated.  But
      replacing a signal with a function seems like a good idea.
    . Can I replace the Signal.Control itself with something possibly wrapped
      in a function?  That function would need (RandomSeed, RealTime).  But
      that doesn't work for notes that take a slice of the signal.  I think
      I only want to randomize Signal.at access.
    . Or a separate 'Map ScoreT.Control ValCall' and the Signal.at functions in
      derive first look in there.  This is similar to the -rnd control idea,
      except more flexible.  I could use it not just for different
      distributions, but to invert a signal, combine two signals, etc.  Or
      have an entirely synthesized signal, with no backing Signal.Control.
    . dur-rnd could be replaced by randomization on sus-abs.  start-rnd gets
      replaced by a start-offset control, which can then be randomized.
      start-offset could be also useful for e.g. swing time or instruments
      that are aggressively before the beat.
    . At this point I could get rid of the "normal" control map, replacing
      with Signal.at ValCalls.  Except that I still need non-randomized signals
      to slice and send to MIDI perform, and to display on the UI.
    . Also, ValCalls can log and fail and do the other Deriver things.  Of
      course they also have access to State, which they need, or at least the
      Dynamic part.  But to bind in tracklang I still need some sort of
      currying, e.g. '%control = (rnd .1 sig)'.  But the call is
      (rnd, Control, RealTime).  So I could save the Call and append RealTime
      at the end.  I could optimize a bit by looking up 'rnd' at the binding
      time.  But I can't typecheck the args unless I introspect... which
      I actually can do, given the documentation.  I would have to map each
      ArgDoc back to its parser, then apply each parser.  But it would be hard
      to store the types untagged, maybe possible with an existential type but
      seems tricky, and I need access to the function directly.
    . I could also use plain haskell functions, but it would be yet another
      namespace, and I'd still need a way to typecheck and pass args from
      tracklang.  Val calls already do all that, I should reuse it.
    . A better way might be to add a VCFunction, which is just
      RealTime -> Signal.Y, this would also eliminate typechecking the return
      value.  That means I also don't have to quote, e.g. '%x = "(f)'
-}