-- 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 where
import Prelude hiding (lookup)
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.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
(Int -> PSignal -> ShowS)
-> (PSignal -> String) -> ([PSignal] -> ShowS) -> Show PSignal
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 -> Key
PSignal -> Doc
(PSignal -> Key)
-> (PSignal -> Doc) -> ([PSignal] -> Doc) -> Pretty PSignal
forall a. (a -> Key) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [PSignal] -> Doc
$cformatList :: [PSignal] -> Doc
format :: PSignal -> Doc
$cformat :: PSignal -> Doc
pretty :: PSignal -> Key
$cpretty :: PSignal -> Key
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
        | Boxed Pitch -> Bool
forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null (PSignal -> Boxed Pitch
_signal PSignal
s1) = PSignal
s2
        | Boxed Pitch -> Bool
forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null (PSignal -> Boxed Pitch
_signal PSignal
s2) = PSignal
s1
        | Bool
otherwise = [PSignal] -> PSignal
forall a. Monoid a => [a] -> a
mconcat [PSignal
s1, PSignal
s2]
instance Monoid PSignal where
    mempty :: PSignal
mempty = Boxed Pitch -> PSignal
PSignal Boxed Pitch
forall (v :: * -> *) a. Vector v a => Signal (v a)
Segment.empty
    mappend :: PSignal -> PSignal -> PSignal
mappend = PSignal -> PSignal -> PSignal
forall a. Semigroup a => a -> a -> a
(<>)
    mconcat :: [PSignal] -> PSignal
mconcat [] = PSignal
forall a. Monoid a => a
mempty
    mconcat [PSignal]
sigs = Boxed Pitch -> PSignal
PSignal (Boxed Pitch -> PSignal) -> Boxed Pitch -> PSignal
forall a b. (a -> b) -> a -> b
$
        Maybe (Pitch -> Pitch -> Bool)
-> Interpolate Pitch -> [Boxed Pitch] -> Boxed Pitch
forall (v :: * -> *) y.
Vector v (Sample y) =>
Maybe (y -> y -> Bool)
-> Interpolate y -> [SignalS v y] -> SignalS v y
Segment.concat Maybe (Pitch -> Pitch -> Bool)
forall a. Maybe a
Nothing Interpolate Pitch
interpolate ([Boxed Pitch] -> Boxed Pitch) -> [Boxed Pitch] -> Boxed Pitch
forall a b. (a -> b) -> a -> b
$ (Boxed Pitch -> Bool) -> [Boxed Pitch] -> [Boxed Pitch]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Boxed Pitch -> Bool) -> Boxed Pitch -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Boxed Pitch -> Bool
forall (v :: * -> *) y. Vector v (Sample y) => SignalS v y -> Bool
Segment.null) ([Boxed Pitch] -> [Boxed Pitch]) -> [Boxed Pitch] -> [Boxed Pitch]
forall a b. (a -> b) -> a -> b
$
        (PSignal -> Boxed Pitch) -> [PSignal] -> [Boxed Pitch]
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 Boxed Pitch -> () -> ()
`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 RealTime -> RealTime -> Bool
forall a. Ord a => a -> a -> Bool
<= RealTime
x1 = Pitch
p1
    | RealTime
x RealTime -> RealTime -> Bool
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 = Pitch -> Scale
forall a. RawPitch a -> Scale
pitch_scale Pitch
p1
        , pitch_config :: PitchConfig
pitch_config = PitchConfig
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 (Transposed -> Either PitchError NoteNumber)
-> Transposed -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$ RawPitch Any -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce (RawPitch Any -> Transposed) -> RawPitch Any -> Transposed
forall a b. (a -> b) -> a -> b
$ PitchConfig -> Pitch -> RawPitch Any
forall {a} {a}. PitchConfig -> RawPitch a -> RawPitch a
apply_config PitchConfig
config Pitch
p1
        NoteNumber
p2_nn <- Transposed -> Either PitchError NoteNumber
pitch_nn (Transposed -> Either PitchError NoteNumber)
-> Transposed -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$ RawPitch Any -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce (RawPitch Any -> Transposed) -> RawPitch Any -> Transposed
forall a b. (a -> b) -> a -> b
$ PitchConfig -> Pitch -> RawPitch Any
forall {a} {a}. PitchConfig -> RawPitch a -> RawPitch a
apply_config PitchConfig
config Pitch
p2
        NoteNumber -> Either PitchError NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Either PitchError NoteNumber)
-> NoteNumber -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$ NoteNumber -> NoteNumber -> NoteNumber -> NoteNumber
forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale NoteNumber
p1_nn NoteNumber
p2_nn (NoteNumber -> NoteNumber) -> NoteNumber -> NoteNumber
forall a b. (a -> b) -> a -> b
$
            Y -> NoteNumber
Pitch.NoteNumber (Y -> NoteNumber) -> Y -> NoteNumber
forall a b. (a -> b) -> a -> b
$ RealTime -> Y
RealTime.to_seconds (RealTime -> Y) -> RealTime -> Y
forall a b. (a -> b) -> a -> b
$ RealTime -> RealTime -> RealTime -> RealTime
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 (Transposed -> Either PitchError Note)
-> Transposed -> Either PitchError Note
forall a b. (a -> b) -> a -> b
$ RawPitch Any -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce (RawPitch Any -> Transposed) -> RawPitch Any -> Transposed
forall a b. (a -> b) -> a -> b
$ PitchConfig -> Pitch -> RawPitch Any
forall {a} {a}. PitchConfig -> RawPitch a -> RawPitch a
apply_config PitchConfig
config (Pitch -> RawPitch Any) -> Pitch -> RawPitch Any
forall a b. (a -> b) -> a -> b
$
        if RealTime
x RealTime -> RealTime -> Bool
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 PitchConfig -> PitchConfig -> PitchConfig
forall a. Semigroup a => a -> a -> a
<> RawPitch a -> PitchConfig
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 = RawPitch a -> RawPitch 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 <- Transposed -> PitchConfig -> Either PitchError NoteNumber
forall a. RawPitch a -> PitchConfig -> Either PitchError NoteNumber
pitch_eval_nn Transposed
pitch (Transposed -> PitchConfig
forall a. RawPitch a -> PitchConfig
pitch_config Transposed
pitch)
    (PitchError -> PitchError)
-> Either PitchError NoteNumber -> Either PitchError NoteNumber
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Transposed -> Maybe NoteNumber -> PitchError -> PitchError
forall a.
RawPitch a -> Maybe NoteNumber -> PitchError -> PitchError
annotate_out_of_range Transposed
pitch (NoteNumber -> Maybe NoteNumber
forall a. a -> Maybe a
Just NoteNumber
nn)) (Either PitchError NoteNumber -> Either PitchError NoteNumber)
-> Either PitchError NoteNumber -> Either PitchError NoteNumber
forall a b. (a -> b) -> a -> b
$
        if NoteNumber
0 NoteNumber -> NoteNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= NoteNumber
nn Bool -> Bool -> Bool
&& NoteNumber
nn NoteNumber -> NoteNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= NoteNumber
127 then NoteNumber -> Either PitchError NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return NoteNumber
nn
            else PitchError -> Either PitchError NoteNumber
forall a b. a -> Either a b
Left (PitchError -> Either PitchError NoteNumber)
-> PitchError -> Either PitchError NoteNumber
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 = (PitchError -> PitchError)
-> Either PitchError Note -> Either PitchError Note
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Transposed -> Maybe NoteNumber -> PitchError -> PitchError
forall a.
RawPitch a -> Maybe NoteNumber -> PitchError -> PitchError
annotate_out_of_range Transposed
pitch Maybe NoteNumber
forall a. Maybe a
Nothing) (Either PitchError Note -> Either PitchError Note)
-> Either PitchError Note -> Either PitchError Note
forall a b. (a -> b) -> a -> b
$
    Transposed -> PitchConfig -> Either PitchError Note
forall a. RawPitch a -> PitchConfig -> Either PitchError Note
pitch_eval_note Transposed
pitch (Transposed -> PitchConfig
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 ((OutOfRange -> OutOfRange) -> PitchError -> PitchError)
-> (OutOfRange -> OutOfRange) -> PitchError -> PitchError
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 ControlValMap -> ControlValMap -> ControlValMap
forall a. Semigroup a => a -> a -> a
<> OutOfRange -> ControlValMap
oor_transposers OutOfRange
err
    }
    where
    filtered :: ControlValMap
filtered = (Control -> Y -> Bool) -> ControlValMap -> ControlValMap
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Control
k Y
v -> Control
k Control -> Set Control -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Control
transposers Bool -> Bool -> Bool
&& Y
v Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
/= Y
0)
        ControlValMap
cmap
    PitchConfig Environ
_ ControlValMap
cmap = RawPitch a -> PitchConfig
forall a. RawPitch a -> PitchConfig
pitch_config RawPitch a
pitch
    transposers :: Set Control
transposers = Scale -> Set Control
pscale_transposers (RawPitch a -> Scale
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
(Int -> PitchConfig -> ShowS)
-> (PitchConfig -> String)
-> ([PitchConfig] -> ShowS)
-> Show PitchConfig
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 Environ -> Environ -> Environ
forall a. Semigroup a => a -> a -> a
<> Environ
env2) ((Y -> Y -> Y) -> ControlValMap -> ControlValMap -> ControlValMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Y -> Y -> Y
forall a. Num a => a -> a -> a
(+) ControlValMap
c1 ControlValMap
c2)

instance Monoid PitchConfig where
    mempty :: PitchConfig
mempty = Environ -> ControlValMap -> PitchConfig
PitchConfig Environ
forall a. Monoid a => a
mempty ControlValMap
forall a. Monoid a => a
mempty
    mappend :: PitchConfig -> PitchConfig -> PitchConfig
mappend = PitchConfig -> PitchConfig -> PitchConfig
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
(Int -> Scale -> ShowS)
-> (Scale -> String) -> ([Scale] -> ShowS) -> Show Scale
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 -> Key
pretty = ScaleId -> Key
forall a. Pretty a => a -> Key
pretty (ScaleId -> Key) -> (Scale -> ScaleId) -> Scale -> Key
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 = (PitchError -> String)
-> (NoteNumber -> String) -> Either PitchError NoteNumber -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PitchError -> String
forall a. Show a => a -> String
show NoteNumber -> String
forall a. Pretty a => a -> String
prettys (Transposed -> Either PitchError NoteNumber
pitch_nn (RawPitch a -> Transposed
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 -> Key
pretty RawPitch a
p = (PitchError -> Key)
-> (NoteNumber -> Key) -> Either PitchError NoteNumber -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PitchError -> Key
forall a. Show a => a -> Key
showt NoteNumber -> Key
forall a. Pretty a => a -> Key
pretty (Transposed -> Either PitchError NoteNumber
pitch_nn (RawPitch a -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p)) Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
","
        Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> (PitchError -> Key)
-> (Note -> Key) -> Either PitchError Note -> Key
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PitchError -> Key
forall a. Show a => a -> Key
showt Note -> Key
Pitch.note_text (Transposed -> Either PitchError Note
pitch_note (RawPitch a -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p))
        Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"(" Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Scale -> Key
forall a. Pretty a => a -> Key
pretty (RawPitch a -> Scale
forall a. RawPitch a -> Scale
pitch_scale RawPitch a
p) Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
")"

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

-- | Things that can go wrong evaluating a pitch.
data PitchError =
    UnparseableNote !Pitch.Note
    -- | 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.
    | 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
(PitchError -> PitchError -> Bool)
-> (PitchError -> PitchError -> Bool) -> Eq PitchError
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
Eq PitchError
-> (PitchError -> PitchError -> Ordering)
-> (PitchError -> PitchError -> Bool)
-> (PitchError -> PitchError -> Bool)
-> (PitchError -> PitchError -> Bool)
-> (PitchError -> PitchError -> Bool)
-> (PitchError -> PitchError -> PitchError)
-> (PitchError -> PitchError -> PitchError)
-> Ord 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
(Int -> PitchError -> ShowS)
-> (PitchError -> String)
-> ([PitchError] -> ShowS)
-> Show PitchError
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)

data OutOfRange = OutOfRange {
    OutOfRange -> Maybe NoteNumber
oor_nn :: !(Maybe Pitch.NoteNumber)
    , OutOfRange -> Maybe Y
oor_semi :: !(Maybe Pitch.FSemi)
    , OutOfRange -> Maybe (Int, Int)
oor_valid :: !(Maybe (Int, Int))
    , OutOfRange -> ControlValMap
oor_transposers :: !ScoreT.ControlValMap
    } deriving (OutOfRange -> OutOfRange -> Bool
(OutOfRange -> OutOfRange -> Bool)
-> (OutOfRange -> OutOfRange -> Bool) -> Eq OutOfRange
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
Eq OutOfRange
-> (OutOfRange -> OutOfRange -> Ordering)
-> (OutOfRange -> OutOfRange -> Bool)
-> (OutOfRange -> OutOfRange -> Bool)
-> (OutOfRange -> OutOfRange -> Bool)
-> (OutOfRange -> OutOfRange -> Bool)
-> (OutOfRange -> OutOfRange -> OutOfRange)
-> (OutOfRange -> OutOfRange -> OutOfRange)
-> Ord 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
(Int -> OutOfRange -> ShowS)
-> (OutOfRange -> String)
-> ([OutOfRange] -> ShowS)
-> Show OutOfRange
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 Maybe NoteNumber
forall a. Maybe a
Nothing Maybe Y
forall a. Maybe a
Nothing Maybe (Int, Int)
forall a. Maybe a
Nothing ControlValMap
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 (OutOfRange -> PitchError) -> OutOfRange -> PitchError
forall a b. (a -> b) -> a -> b
$ OutOfRange
    { oor_nn :: Maybe NoteNumber
oor_nn = Maybe NoteNumber
forall a. Maybe a
Nothing
    , oor_semi :: Maybe Y
oor_semi = Y -> Maybe Y
forall a. a -> Maybe a
Just (a -> Y
forall a b. (Real a, Fractional b) => a -> b
realToFrac a
semi)
    , oor_valid :: Maybe (Int, Int)
oor_valid = (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int, Int)
valid
    , oor_transposers :: ControlValMap
oor_transposers = ControlValMap
forall a. Monoid a => a
mempty
    }

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

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

instance Pretty PitchConfig where
    format :: PitchConfig -> Doc
format (PitchConfig Environ
env ControlValMap
controls) = Doc -> [(Key, Doc)] -> Doc
Pretty.record Doc
"PitchConfig"
        [ (Key
"environ", Environ -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Environ
env)
        , (Key
"controls", ControlValMap -> Doc
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 = (PitchError -> Bool)
-> (Bool -> Bool) -> Either PitchError Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> PitchError -> Bool
forall a b. a -> b -> a
const Bool
False) Bool -> Bool
forall a. a -> a
id (Either PitchError Bool -> Bool) -> Either PitchError Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    NoteNumber -> NoteNumber -> Bool
Pitch.nns_equal (NoteNumber -> NoteNumber -> Bool)
-> Either PitchError NoteNumber
-> Either PitchError (NoteNumber -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transposed -> Either PitchError NoteNumber
pitch_nn (RawPitch a -> Transposed
forall a b. RawPitch a -> RawPitch b
coerce RawPitch a
p1) Either PitchError (NoteNumber -> Bool)
-> Either PitchError NoteNumber -> Either PitchError Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Transposed -> Either PitchError NoteNumber
pitch_nn (RawPitch a -> Transposed
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
(Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool) -> Eq Duration
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
(Int -> Duration -> ShowS)
-> (Duration -> String) -> ([Duration] -> ShowS) -> Show Duration
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)

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

instance Pretty Duration where
    pretty :: Duration -> Key
pretty (RealDuration RealTime
t) = RealTime -> Key
forall a. Pretty a => a -> Key
pretty RealTime
t
    pretty (ScoreDuration ScoreTime
t) = ScoreTime -> Key
forall a. Pretty a => a -> Key
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 RealTime -> RealTime -> RealTime
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 ScoreTime -> ScoreTime -> ScoreTime
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
(Int -> Environ -> ShowS)
-> (Environ -> String) -> ([Environ] -> ShowS) -> Show Environ
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
(Environ -> Environ -> Environ)
-> (NonEmpty Environ -> Environ)
-> (forall b. Integral b => b -> Environ -> Environ)
-> Semigroup 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
Semigroup Environ
-> Environ
-> (Environ -> Environ -> Environ)
-> ([Environ] -> Environ)
-> Monoid 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 -> ()
(Environ -> ()) -> NFData 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 Key Val
env) = [(Doc, Doc)] -> Doc
Pretty.formatMap
        ([(Doc, Doc)] -> Doc)
-> (Map Key Val -> [(Doc, Doc)]) -> Map Key Val -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Val) -> (Doc, Doc)) -> [(Key, Val)] -> [(Doc, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Doc) -> (Val -> Doc) -> (Key, Val) -> (Doc, Doc)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Key -> Doc
Pretty.text Val -> Doc
forall a. Pretty a => a -> Doc
Pretty.format) ([(Key, Val)] -> [(Doc, Doc)])
-> (Map Key Val -> [(Key, Val)]) -> Map Key Val -> [(Doc, Doc)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Key Val -> [(Key, Val)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Key Val -> Doc) -> Map Key Val -> Doc
forall a b. (a -> b) -> a -> b
$ Map Key Val
env

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

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

environ_attributes :: Environ -> Attrs.Attributes
environ_attributes :: Environ -> Attributes
environ_attributes Environ
environ =
    case Key -> Environ -> Maybe Val
lookup Key
EnvKey.attributes Environ
environ of
        Just (VAttributes Attributes
attrs) -> Attributes
attrs
        Maybe Val
_ -> Attributes
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.
    --
    -- Literal: @42.23@, @-.4@, @1c@, @-2.4d@, @3/2@, @-3/2@, @0x7f@.
    VNum !(ScoreT.Typed Signal.Y)
    -- | 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

    -- | No literal, but is returned from val calls, notably scale calls.
    | VPitch !Pitch

    -- | 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
    | VControlFunction !ControlFunction
    -- | 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
(Int -> Val -> ShowS)
-> (Val -> String) -> ([Val] -> ShowS) -> Show Val
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
    (VNum Typed Y
a, VNum Typed Y
b) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Typed Y
a Typed Y -> Typed Y -> Bool
forall a. Eq a => a -> a -> Bool
== Typed Y
b
    (VAttributes Attributes
a, VAttributes Attributes
b) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Attributes
a Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
== Attributes
b
    (VControlRef ControlRef
a, VControlRef ControlRef
b) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ControlRef
a ControlRef -> ControlRef -> Bool
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
_) -> Maybe Bool
forall a. Maybe a
Nothing
    (VPitch Pitch
a, VPitch Pitch
b) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Pitch -> Pitch -> Bool
forall a. RawPitch a -> RawPitch a -> Bool
pitches_equal Pitch
a Pitch
b
    (VNotePitch Pitch
a, VNotePitch Pitch
b) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Pitch
a Pitch -> Pitch -> Bool
forall a. Eq a => a -> a -> Bool
== Pitch
b
    (VStr Str
a, VStr Str
b) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Str
a Str -> Str -> Bool
forall a. Eq a => a -> a -> Bool
== Str
b
    (VQuoted (Quoted Expr
a), VQuoted (Quoted Expr
b)) ->
        (Call Val -> Call Val -> Maybe Bool)
-> [Call Val] -> [Call Val] -> Maybe Bool
forall a. (a -> a -> Maybe Bool) -> [a] -> [a] -> Maybe Bool
lists_equal Call Val -> Call Val -> Maybe Bool
calls_equal (Expr -> [Call Val]
forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
a) (Expr -> [Call Val]
forall a. NonEmpty a -> [a]
NonEmpty.toList Expr
b)
    (VControlFunction ControlFunction
_, VControlFunction ControlFunction
_) -> Maybe Bool
forall a. Maybe a
Nothing
    (Val
VNotGiven, Val
VNotGiven) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    (Val
VSeparator, Val
VSeparator) -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    (VList [Val]
a, VList [Val]
b) -> (Val -> Val -> Maybe Bool) -> [Val] -> [Val] -> Maybe Bool
forall a. (a -> a -> Maybe Bool) -> [a] -> [a] -> Maybe Bool
lists_equal Val -> Val -> Maybe Bool
vals_equal [Val]
a [Val]
b
    (Val, Val)
_ -> Maybe Bool
forall a. Maybe a
Nothing

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) = Maybe Bool -> (Bool -> Maybe Bool) -> Maybe Bool -> Maybe Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Bool
forall a. Maybe a
Nothing
        (\Bool
t -> if Bool
t then [a] -> [a] -> Maybe Bool
go [a]
as [a]
bs else Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (a -> a -> Maybe Bool
eq a
a a
b)
    go [a]
_ [a]
_ = Bool -> Maybe Bool
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 -> MiniVal -> Maybe MiniVal
forall a. a -> Maybe a
Just (Str -> MiniVal
Expr.VStr Str
a)
    VNum Typed Y
a -> MiniVal -> Maybe MiniVal
forall a. a -> Maybe a
Just (Typed Y -> MiniVal
Expr.VNum Typed Y
a)
    Val
_ -> Maybe MiniVal
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 -> Key
show_val Val
val = case Val
val of
        VNum Typed Y
d -> Typed Y -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Typed Y
d
        VAttributes Attributes
attrs -> Attributes -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Attributes
attrs
        VControlRef ControlRef
control -> ControlRef -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val ControlRef
control
        VPControlRef PControlRef
control -> PControlRef -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val PControlRef
control
        VPitch Pitch
pitch -> Pitch -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Pitch
pitch
        VNotePitch Pitch
pitch -> Pitch -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Pitch
pitch
        VStr Str
str -> Str -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Str
str
        VQuoted Quoted
quoted -> Quoted -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Quoted
quoted
        VControlFunction ControlFunction
f -> ControlFunction -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val ControlFunction
f
        Val
VNotGiven -> Key
"_"
        Val
VSeparator -> Key
";"
        VList [Val]
vals -> [Val] -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val [Val]
vals

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

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

newtype Quoted = Quoted Expr deriving (Int -> Quoted -> ShowS
[Quoted] -> ShowS
Quoted -> String
(Int -> Quoted -> ShowS)
-> (Quoted -> String) -> ([Quoted] -> ShowS) -> Show Quoted
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 -> Key
show_val (Quoted Expr
expr) = Key
"\"(" Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Expr -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Expr
expr Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
")"
instance Pretty Quoted where pretty :: Quoted -> Key
pretty = Quoted -> Key
forall a. ShowVal a => a -> Key
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 -> Key
show_call_val (VStr (Expr.Str Key
sym)) = Key
sym
show_call_val Val
val = Val -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val Val
val

-- ** val utils

-- | Make an untyped VNum.
num :: Double -> Val
num :: Y -> Val
num = Typed Y -> Val
VNum (Typed Y -> Val) -> (Y -> Typed Y) -> Y -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Typed Y
forall a. a -> Typed a
ScoreT.untyped

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

score_time :: ScoreTime -> Val
score_time :: ScoreTime -> Val
score_time = Typed Y -> Val
VNum (Typed Y -> Val) -> (ScoreTime -> Typed Y) -> ScoreTime -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Y -> Typed Y
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Score (Y -> Typed Y) -> (ScoreTime -> Y) -> ScoreTime -> Typed Y
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 = Typed Y -> Val
VNum (Typed Y -> Val) -> (RealTime -> Typed Y) -> RealTime -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Y -> Typed Y
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Real (Y -> Typed Y) -> (RealTime -> Y) -> RealTime -> Typed Y
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 = Typed Y -> Val
VNum (Typed Y -> Val) -> Typed Y -> Val
forall a b. (a -> b) -> a -> b
$ case Transpose
t of
    Pitch.Diatonic Y
d -> Type -> Y -> Typed Y
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Diatonic Y
d
    Pitch.Chromatic Y
d -> Type -> Y -> Typed Y
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Chromatic Y
d
    Pitch.Nn Y
d -> Type -> Y -> Typed Y
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Nn Y
d

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

quoted :: Expr.Symbol -> [Val] -> Quoted
quoted :: Symbol -> [Val] -> Quoted
quoted Symbol
sym [Val]
args = Expr -> Quoted
Quoted (Expr -> Quoted) -> Expr -> Quoted
forall a b. (a -> b) -> a -> b
$ Call Val -> Expr
forall val. Call val -> Expr val
Expr.generator (Symbol -> [Val] -> Call Val
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

data Ref control val =
    -- | A signal literal.
    ControlSignal val
    -- | If the control isn't present, use the given default.
    | DefaultedControl control val
    -- | Throw an exception if the control isn't present.
    | LiteralControl control
    deriving (Ref control val -> Ref control val -> Bool
(Ref control val -> Ref control val -> Bool)
-> (Ref control val -> Ref control val -> Bool)
-> Eq (Ref control val)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall control val.
(Eq val, Eq control) =>
Ref control val -> Ref control val -> Bool
/= :: Ref control val -> Ref control val -> Bool
$c/= :: forall control val.
(Eq val, Eq control) =>
Ref control val -> Ref control val -> Bool
== :: Ref control val -> Ref control val -> Bool
$c== :: forall control val.
(Eq val, Eq control) =>
Ref control val -> Ref control val -> Bool
Eq, ReadPrec [Ref control val]
ReadPrec (Ref control val)
Int -> ReadS (Ref control val)
ReadS [Ref control val]
(Int -> ReadS (Ref control val))
-> ReadS [Ref control val]
-> ReadPrec (Ref control val)
-> ReadPrec [Ref control val]
-> Read (Ref control val)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall control val.
(Read val, Read control) =>
ReadPrec [Ref control val]
forall control val.
(Read val, Read control) =>
ReadPrec (Ref control val)
forall control val.
(Read val, Read control) =>
Int -> ReadS (Ref control val)
forall control val.
(Read val, Read control) =>
ReadS [Ref control val]
readListPrec :: ReadPrec [Ref control val]
$creadListPrec :: forall control val.
(Read val, Read control) =>
ReadPrec [Ref control val]
readPrec :: ReadPrec (Ref control val)
$creadPrec :: forall control val.
(Read val, Read control) =>
ReadPrec (Ref control val)
readList :: ReadS [Ref control val]
$creadList :: forall control val.
(Read val, Read control) =>
ReadS [Ref control val]
readsPrec :: Int -> ReadS (Ref control val)
$creadsPrec :: forall control val.
(Read val, Read control) =>
Int -> ReadS (Ref control val)
Read, Int -> Ref control val -> ShowS
[Ref control val] -> ShowS
Ref control val -> String
(Int -> Ref control val -> ShowS)
-> (Ref control val -> String)
-> ([Ref control val] -> ShowS)
-> Show (Ref control val)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall control val.
(Show val, Show control) =>
Int -> Ref control val -> ShowS
forall control val.
(Show val, Show control) =>
[Ref control val] -> ShowS
forall control val.
(Show val, Show control) =>
Ref control val -> String
showList :: [Ref control val] -> ShowS
$cshowList :: forall control val.
(Show val, Show control) =>
[Ref control val] -> ShowS
show :: Ref control val -> String
$cshow :: forall control val.
(Show val, Show control) =>
Ref control val -> String
showsPrec :: Int -> Ref control val -> ShowS
$cshowsPrec :: forall control val.
(Show val, Show control) =>
Int -> Ref control val -> ShowS
Show)

type ControlRef = Ref ScoreT.Control (ScoreT.Typed Signal.Control)
type PControlRef = Ref ScoreT.PControl PSignal

instance (Serialize.Serialize val, Serialize.Serialize control) =>
        Serialize.Serialize (Ref control val) where
    put :: Putter (Ref control val)
put Ref control val
val = case Ref control val
val of
        ControlSignal val
a -> Word8 -> Put
Serialize.put_tag Word8
0 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter val
forall a. Serialize a => Putter a
Serialize.put val
a
        DefaultedControl control
a val
b -> Word8 -> Put
Serialize.put_tag Word8
1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter control
forall a. Serialize a => Putter a
Serialize.put control
a
            Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter val
forall a. Serialize a => Putter a
Serialize.put val
b
        LiteralControl control
a -> Word8 -> Put
Serialize.put_tag Word8
2 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter control
forall a. Serialize a => Putter a
Serialize.put control
a
    get :: Get (Ref control val)
get = Get Word8
Serialize.get_tag Get Word8
-> (Word8 -> Get (Ref control val)) -> Get (Ref control val)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Word8
0 -> val -> Ref control val
forall control val. val -> Ref control val
ControlSignal (val -> Ref control val) -> Get val -> Get (Ref control val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get val
forall a. Serialize a => Get a
Serialize.get
        Word8
1 -> control -> val -> Ref control val
forall control val. control -> val -> Ref control val
DefaultedControl (control -> val -> Ref control val)
-> Get control -> Get (val -> Ref control val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get control
forall a. Serialize a => Get a
Serialize.get Get (val -> Ref control val) -> Get val -> Get (Ref control val)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get val
forall a. Serialize a => Get a
Serialize.get
        Word8
2 -> control -> Ref control val
forall control val. control -> Ref control val
LiteralControl (control -> Ref control val)
-> Get control -> Get (Ref control val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get control
forall a. Serialize a => Get a
Serialize.get
        Word8
n -> String -> Word8 -> Get (Ref control val)
forall a. String -> Word8 -> Get a
Serialize.bad_tag String
"DeriveT.Ref" Word8
n

-- | This can only represent constant signals, since there's no literal for an
-- arbitrary signal.  Non-constant signals will turn into a constant of
-- whatever was at 0.
instance ShowVal.ShowVal ControlRef where
    show_val :: ControlRef -> Key
show_val = (Typed Control -> Key) -> ControlRef -> Key
forall control sig.
ShowVal control =>
(sig -> Key) -> Ref control sig -> Key
show_control ((Typed Control -> Key) -> ControlRef -> Key)
-> (Typed Control -> Key) -> ControlRef -> Key
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Control
sig) ->
        Y -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val (RealTime -> Control -> Y
forall {k} (kind :: k). RealTime -> Signal kind -> Y
Signal.at RealTime
0 Control
sig) Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Type -> Key
ScoreT.type_to_code Type
typ

instance Pretty ControlRef where pretty :: ControlRef -> Key
pretty = ControlRef -> Key
forall a. ShowVal a => a -> Key
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 -> Key
show_val = (PSignal -> Key) -> PControlRef -> Key
forall control sig.
ShowVal control =>
(sig -> Key) -> Ref control sig -> Key
show_control ((PSignal -> Key) -> PControlRef -> Key)
-> (PSignal -> Key) -> PControlRef -> Key
forall a b. (a -> b) -> a -> b
$
        Key -> ((RealTime, Pitch) -> Key) -> Maybe (RealTime, Pitch) -> Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Key
"<none>" (Pitch -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val (Pitch -> Key)
-> ((RealTime, Pitch) -> Pitch) -> (RealTime, Pitch) -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealTime, Pitch) -> Pitch
forall a b. (a, b) -> b
snd) (Maybe (RealTime, Pitch) -> Key)
-> (PSignal -> Maybe (RealTime, Pitch)) -> PSignal -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Boxed Pitch -> Maybe (RealTime, Pitch)
forall (v :: * -> *) y.
Vector v (Sample y) =>
SignalS v y -> Maybe (RealTime, y)
Segment.head (Boxed Pitch -> Maybe (RealTime, Pitch))
-> (PSignal -> Boxed Pitch) -> PSignal -> Maybe (RealTime, Pitch)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PSignal -> Boxed Pitch
_signal

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

show_control :: ShowVal.ShowVal control => (sig -> Text) -> Ref control sig
    -> Text
show_control :: forall control sig.
ShowVal control =>
(sig -> Key) -> Ref control sig -> Key
show_control sig -> Key
sig_text Ref control sig
control = case Ref control sig
control of
    ControlSignal sig
sig -> sig -> Key
sig_text sig
sig
    DefaultedControl control
control sig
deflt ->
        control -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val control
control Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"," Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> sig -> Key
sig_text sig
deflt
    LiteralControl control
control -> control -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val control
control

-- | Defaulted control from a RealTime.
real_control :: ScoreT.Control -> RealTime -> ControlRef
real_control :: Control -> RealTime -> ControlRef
real_control Control
c RealTime
deflt = Control -> Typed Control -> ControlRef
forall control val. control -> val -> Ref control val
DefaultedControl Control
c (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
$ Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant (RealTime -> Y
RealTime.to_seconds RealTime
deflt)

constant_control :: Signal.Y -> ControlRef
constant_control :: Y -> ControlRef
constant_control = Typed Control -> ControlRef
forall control val. val -> Ref control val
ControlSignal (Typed Control -> ControlRef)
-> (Y -> Typed Control) -> Y -> ControlRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> Typed Control
forall a. a -> Typed a
ScoreT.untyped (Control -> Typed Control) -> (Y -> Control) -> Y -> Typed Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> Control
forall {k} (kind :: k). Y -> Signal kind
Signal.constant

-- * 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 -> Key
show_val = Expr -> Key
forall val. ShowVal (Call val) => Expr val -> Key
Expr.show_val_expr
instance ShowVal.ShowVal (Expr.Call Val) where
    show_val :: Call Val -> Key
show_val = (Val -> Maybe Key) -> Call Val -> Key
forall val.
ShowVal (Term val) =>
(val -> Maybe Key) -> Call val -> Key
Expr.show_val_call ((Val -> Maybe Key) -> Call Val -> Key)
-> (Val -> Maybe Key) -> Call Val -> Key
forall a b. (a -> b) -> a -> b
$ \case
        VStr (Expr.Str Key
op) -> Key -> Maybe Key
forall a. a -> Maybe a
Just Key
op
        Val
_ -> Maybe Key
forall a. Maybe a
Nothing
instance ShowVal.ShowVal (Expr.Term Val) where show_val :: Term Val -> Key
show_val = Term Val -> Key
forall val. (ShowVal val, ShowVal (Call val)) => Term val -> Key
Expr.show_val_term

instance Pretty (Expr.Call Val) where pretty :: Call Val -> Key
pretty = Call Val -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val
instance Pretty (Expr.Term Val) where pretty :: Term Val -> Key
pretty = Term Val -> Key
forall a. ShowVal a => a -> Key
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 Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
/= Symbol
sym2 = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    | Bool
otherwise = (Term Val -> Term Val -> Maybe Bool)
-> [Term Val] -> [Term Val] -> Maybe Bool
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
_ = Bool -> Maybe Bool
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) = Symbol -> [Term Val] -> Call Val
forall val. Symbol -> [Term val] -> Call val
Expr.Call Symbol
sym ((Term Val -> Term Val) -> [Term Val] -> [Term Val]
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) = Call Val -> Term Val
forall val. Call val -> Term val
Expr.ValCall (Call Val -> Call Val
call Call Val
c)
    term (Expr.Literal (VStr Str
str)) = Val -> Term Val
forall val. val -> Term val
Expr.Literal (Str -> Val
VStr (Str -> Str
f Str
str))
    term (Expr.Literal Val
lit) = Val -> Term Val
forall val. val -> Term val
Expr.Literal Val
lit

-- * Derive.Score

-- ** ControlMap

type ControlMap = Map ScoreT.Control (ScoreT.Typed Signal.Control)
type ControlFunctionMap = Map ScoreT.Control ControlFunction
type PitchMap = Map ScoreT.PControl PSignal

-- * 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 ControlFunction 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 ControlFunction =
    -- | Control is the control name this function was bound to, if it was
    -- bound to one.  Dynamic is a stripped down Derive State.  For
    -- ControlFunctions that represent a control signal, the RealTime is the
    -- desired X value, otherwise it's just some number.
    ControlFunction !Text
        !(ScoreT.Control -> Dynamic -> RealTime -> ScoreT.Typed Signal.Y)

instance Show ControlFunction where show :: ControlFunction -> String
show = Key -> String
untxt (Key -> String)
-> (ControlFunction -> Key) -> ControlFunction -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlFunction -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val
instance Pretty ControlFunction where pretty :: ControlFunction -> Key
pretty = ControlFunction -> Key
forall a. Show a => a -> Key
showt
-- | Not parseable.
instance ShowVal.ShowVal ControlFunction where
    show_val :: ControlFunction -> Key
show_val (ControlFunction Key
name Control -> Dynamic -> RealTime -> Typed Y
_) = Key
"((ControlFunction " Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
name Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"))"
instance DeepSeq.NFData ControlFunction where
    rnf :: ControlFunction -> ()
rnf (ControlFunction Key
a Control -> Dynamic -> RealTime -> Typed Y
b) = Key
a Key -> () -> ()
`seq` Control -> Dynamic -> RealTime -> Typed Y
b (Control -> Dynamic -> RealTime -> Typed Y) -> () -> ()
`seq` ()

call_control_function :: ControlFunction -> ScoreT.Control -> Dynamic
    -> RealTime -> (ScoreT.Typed Signal.Y)
call_control_function :: ControlFunction -> Control -> Dynamic -> RealTime -> Typed Y
call_control_function (ControlFunction Key
_ Control -> Dynamic -> RealTime -> Typed Y
f) = Control -> Dynamic -> RealTime -> Typed Y
f

-- | Modify the underlying function, presumably to compose something onto the
-- input or output.
modify_control_function ::
    ((RealTime -> ScoreT.Typed Signal.Y) -> (RealTime -> ScoreT.Typed Signal.Y))
    -> ControlFunction -> ControlFunction
modify_control_function :: ((RealTime -> Typed Y) -> RealTime -> Typed Y)
-> ControlFunction -> ControlFunction
modify_control_function (RealTime -> Typed Y) -> RealTime -> Typed Y
modify (ControlFunction Key
name Control -> Dynamic -> RealTime -> Typed Y
f) =
    Key
-> (Control -> Dynamic -> RealTime -> Typed Y) -> ControlFunction
ControlFunction Key
name (\Control
dyn Dynamic
control -> (RealTime -> Typed Y) -> RealTime -> Typed Y
modify (Control -> Dynamic -> RealTime -> Typed Y
f Control
dyn Dynamic
control))

-- | A stripped down "Derive.Deriver.Monad.Dynamic" for ControlFunctions
-- to use.  The duplication is unfortunate, see 'ControlFunction'.
data Dynamic = Dynamic {
    Dynamic -> ControlMap
dyn_controls :: !ControlMap
    , Dynamic -> ControlFunctionMap
dyn_control_functions :: !ControlFunctionMap
    , Dynamic -> PitchMap
dyn_pitches :: !PitchMap
    , 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
(Int -> Dynamic -> ShowS)
-> (Dynamic -> String) -> ([Dynamic] -> ShowS) -> Show Dynamic
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_controls :: ControlMap
dyn_controls = ControlMap
forall a. Monoid a => a
mempty
    , dyn_control_functions :: ControlFunctionMap
dyn_control_functions = ControlFunctionMap
forall a. Monoid a => a
mempty
    , dyn_pitches :: PitchMap
dyn_pitches = PitchMap
forall a. Monoid a => a
mempty
    , dyn_pitch :: PSignal
dyn_pitch = PSignal
forall a. Monoid a => a
mempty
    , dyn_environ :: Environ
dyn_environ = 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 = Marklists
forall a. Monoid a => a
mempty
    }

{- NOTE [control-function]

    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 VControlFunction, 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)'
-}