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

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
module Derive.Typecheck (
    -- * signal functions
    RealTimeFunction(..), ScoreTimeFunction(..)
    , RealTimeFunctionT(..), ScoreTimeFunctionT(..)
    , DiatonicTransposeFunctionT(..)
    , ChromaticTransposeFunctionT(..)
    , NnTransposeFunctionT(..)

    -- * type wrappers
    , DefaultReal(..), DefaultScore(..)
    , real, score
    , Positive(..), NonNegative(..), Normalized(..), NormalizedBipolar(..)
    , DefaultDiatonic(..), diatonic

    -- * typecheck
    , typecheck, typecheck_simple
    , Checked(..)
    , Result(..)
    , success, failure
    , Typecheck(..)
    , from_val_eval
    , from_val_simple

    , TEnum
    , ToVal(..)
    , to_type_symbol
    , from_val_symbol
    , num_to_type
    , TypecheckNum(..)

    -- * util
    , to_transpose, transpose_control

    -- * controls
    , coerce_to_scalar
    , lookup_function
    , lookup_signal
    , val_to_signal
    , val_to_function, val_to_function_dyn

    -- * pitch signals
    , val_to_pitch_signal
    , lookup_pitch_signal
    , resolve_pitch_ref

    -- * compatibility
    , resolve_function
#ifdef TESTING
    , resolve_signal
#endif
) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import qualified Data.Set as Set

import qualified Util.Lists as Lists
import qualified Util.Texts as Texts
import qualified Derive.Attrs as Attrs
import qualified Derive.Call.SubT as SubT
import qualified Derive.Controls as Controls
import qualified Derive.DeriveT as DeriveT
import           Derive.DeriveT (Val(..))
import qualified Derive.Deriver.Internal as Internal
import qualified Derive.Deriver.Monad as Derive
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.ValType as ValType

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

import qualified Ui.Meter.Meter as Meter
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- * type wrappers

-- | Either RealTime or ScoreTime, but untyped defaults to RealTime.
-- This has a short accessor to make unwrapping more concise.
newtype DefaultReal = DefaultReal { DefaultReal -> Duration
_real :: DeriveT.Duration }
    deriving (DefaultReal -> DefaultReal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultReal -> DefaultReal -> Bool
$c/= :: DefaultReal -> DefaultReal -> Bool
== :: DefaultReal -> DefaultReal -> Bool
$c== :: DefaultReal -> DefaultReal -> Bool
Eq, Int -> DefaultReal -> ShowS
[DefaultReal] -> ShowS
DefaultReal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultReal] -> ShowS
$cshowList :: [DefaultReal] -> ShowS
show :: DefaultReal -> String
$cshow :: DefaultReal -> String
showsPrec :: Int -> DefaultReal -> ShowS
$cshowsPrec :: Int -> DefaultReal -> ShowS
Show, DefaultReal -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: DefaultReal -> Text
$cshow_val :: DefaultReal -> Text
ShowVal.ShowVal)
instance Internal.Time DefaultReal where
    real :: DefaultReal -> Deriver RealTime
real = forall a. Time a => a -> Deriver RealTime
Internal.real forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultReal -> Duration
_real
    score :: DefaultReal -> Deriver ScoreTime
score = forall a. Time a => a -> Deriver ScoreTime
Internal.score forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultReal -> Duration
_real
    to_duration :: DefaultReal -> Duration
to_duration = DefaultReal -> Duration
_real

-- | Same as 'DefaultReal' but untyped defaults to ScoreTime.
-- This has a short accessor to make unwrapping more concise.
newtype DefaultScore = DefaultScore { DefaultScore -> Duration
_score :: DeriveT.Duration }
    deriving (DefaultScore -> DefaultScore -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultScore -> DefaultScore -> Bool
$c/= :: DefaultScore -> DefaultScore -> Bool
== :: DefaultScore -> DefaultScore -> Bool
$c== :: DefaultScore -> DefaultScore -> Bool
Eq, Int -> DefaultScore -> ShowS
[DefaultScore] -> ShowS
DefaultScore -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultScore] -> ShowS
$cshowList :: [DefaultScore] -> ShowS
show :: DefaultScore -> String
$cshow :: DefaultScore -> String
showsPrec :: Int -> DefaultScore -> ShowS
$cshowsPrec :: Int -> DefaultScore -> ShowS
Show, DefaultScore -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: DefaultScore -> Text
$cshow_val :: DefaultScore -> Text
ShowVal.ShowVal)

instance Internal.Time DefaultScore where
    real :: DefaultScore -> Deriver RealTime
real = forall a. Time a => a -> Deriver RealTime
Internal.real forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultScore -> Duration
_score
    score :: DefaultScore -> Deriver ScoreTime
score = forall a. Time a => a -> Deriver ScoreTime
Internal.score forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultScore -> Duration
_score
    to_duration :: DefaultScore -> Duration
to_duration = DefaultScore -> Duration
_score

-- | Create DefaultReal and DefaultScores for use in "Derive.Sig" signatures
-- for default values.  It would be nice to use literals and let type
-- inference do its thing, but there's no good definition for the rest of
-- the methods in Integral and Fractional.
real :: RealTime -> DefaultReal
real :: RealTime -> DefaultReal
real = Duration -> DefaultReal
DefaultReal forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Duration
DeriveT.RealDuration

score :: ScoreTime -> DefaultScore
score :: ScoreTime -> DefaultScore
score = Duration -> DefaultScore
DefaultScore forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Duration
DeriveT.ScoreDuration

-- | An annotation that says this value must be >0.  Instances only exist
-- for numeric types.
--
-- This is an instance of Num just so numeric literals work.  Of course that
-- means you also have (-) which can make it not positive, but this is only
-- intended to be a type tag for signatures, unwrapped as soon as it gets
-- passed to the call.
newtype Positive a = Positive { forall a. Positive a -> a
positive :: a }
    deriving (Int -> Positive a -> ShowS
forall a. Show a => Int -> Positive a -> ShowS
forall a. Show a => [Positive a] -> ShowS
forall a. Show a => Positive a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Positive a] -> ShowS
$cshowList :: forall a. Show a => [Positive a] -> ShowS
show :: Positive a -> String
$cshow :: forall a. Show a => Positive a -> String
showsPrec :: Int -> Positive a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Positive a -> ShowS
Show, Positive a -> Positive a -> Bool
forall a. Eq a => Positive a -> Positive a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Positive a -> Positive a -> Bool
$c/= :: forall a. Eq a => Positive a -> Positive a -> Bool
== :: Positive a -> Positive a -> Bool
$c== :: forall a. Eq a => Positive a -> Positive a -> Bool
Eq, Positive a -> Text
forall a. ShowVal a => Positive a -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: Positive a -> Text
$cshow_val :: forall a. ShowVal a => Positive a -> Text
ShowVal.ShowVal, Integer -> Positive a
Positive a -> Positive a
Positive a -> Positive a -> Positive a
forall a. Num a => Integer -> Positive a
forall a. Num a => Positive a -> Positive a
forall a. Num a => Positive a -> Positive a -> Positive a
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Positive a
$cfromInteger :: forall a. Num a => Integer -> Positive a
signum :: Positive a -> Positive a
$csignum :: forall a. Num a => Positive a -> Positive a
abs :: Positive a -> Positive a
$cabs :: forall a. Num a => Positive a -> Positive a
negate :: Positive a -> Positive a
$cnegate :: forall a. Num a => Positive a -> Positive a
* :: Positive a -> Positive a -> Positive a
$c* :: forall a. Num a => Positive a -> Positive a -> Positive a
- :: Positive a -> Positive a -> Positive a
$c- :: forall a. Num a => Positive a -> Positive a -> Positive a
+ :: Positive a -> Positive a -> Positive a
$c+ :: forall a. Num a => Positive a -> Positive a -> Positive a
Num, Rational -> Positive a
Positive a -> Positive a
Positive a -> Positive a -> Positive a
forall {a}. Fractional a => Num (Positive a)
forall a. Fractional a => Rational -> Positive a
forall a. Fractional a => Positive a -> Positive a
forall a. Fractional a => Positive a -> Positive a -> Positive a
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> Positive a
$cfromRational :: forall a. Fractional a => Rational -> Positive a
recip :: Positive a -> Positive a
$crecip :: forall a. Fractional a => Positive a -> Positive a
/ :: Positive a -> Positive a -> Positive a
$c/ :: forall a. Fractional a => Positive a -> Positive a -> Positive a
Fractional)

-- | Like Positive, but also includes 0.
newtype NonNegative a = NonNegative { forall a. NonNegative a -> a
non_negative :: a }
    deriving (Int -> NonNegative a -> ShowS
forall a. Show a => Int -> NonNegative a -> ShowS
forall a. Show a => [NonNegative a] -> ShowS
forall a. Show a => NonNegative a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonNegative a] -> ShowS
$cshowList :: forall a. Show a => [NonNegative a] -> ShowS
show :: NonNegative a -> String
$cshow :: forall a. Show a => NonNegative a -> String
showsPrec :: Int -> NonNegative a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NonNegative a -> ShowS
Show, NonNegative a -> NonNegative a -> Bool
forall a. Eq a => NonNegative a -> NonNegative a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonNegative a -> NonNegative a -> Bool
$c/= :: forall a. Eq a => NonNegative a -> NonNegative a -> Bool
== :: NonNegative a -> NonNegative a -> Bool
$c== :: forall a. Eq a => NonNegative a -> NonNegative a -> Bool
Eq, NonNegative a -> Text
forall a. ShowVal a => NonNegative a -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: NonNegative a -> Text
$cshow_val :: forall a. ShowVal a => NonNegative a -> Text
ShowVal.ShowVal, Integer -> NonNegative a
NonNegative a -> NonNegative a
NonNegative a -> NonNegative a -> NonNegative a
forall a. Num a => Integer -> NonNegative a
forall a. Num a => NonNegative a -> NonNegative a
forall a. Num a => NonNegative a -> NonNegative a -> NonNegative a
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> NonNegative a
$cfromInteger :: forall a. Num a => Integer -> NonNegative a
signum :: NonNegative a -> NonNegative a
$csignum :: forall a. Num a => NonNegative a -> NonNegative a
abs :: NonNegative a -> NonNegative a
$cabs :: forall a. Num a => NonNegative a -> NonNegative a
negate :: NonNegative a -> NonNegative a
$cnegate :: forall a. Num a => NonNegative a -> NonNegative a
* :: NonNegative a -> NonNegative a -> NonNegative a
$c* :: forall a. Num a => NonNegative a -> NonNegative a -> NonNegative a
- :: NonNegative a -> NonNegative a -> NonNegative a
$c- :: forall a. Num a => NonNegative a -> NonNegative a -> NonNegative a
+ :: NonNegative a -> NonNegative a -> NonNegative a
$c+ :: forall a. Num a => NonNegative a -> NonNegative a -> NonNegative a
Num, Rational -> NonNegative a
NonNegative a -> NonNegative a
NonNegative a -> NonNegative a -> NonNegative a
forall {a}. Fractional a => Num (NonNegative a)
forall a. Fractional a => Rational -> NonNegative a
forall a. Fractional a => NonNegative a -> NonNegative a
forall a.
Fractional a =>
NonNegative a -> NonNegative a -> NonNegative a
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> NonNegative a
$cfromRational :: forall a. Fractional a => Rational -> NonNegative a
recip :: NonNegative a -> NonNegative a
$crecip :: forall a. Fractional a => NonNegative a -> NonNegative a
/ :: NonNegative a -> NonNegative a -> NonNegative a
$c/ :: forall a.
Fractional a =>
NonNegative a -> NonNegative a -> NonNegative a
Fractional)

-- | 0 <= x <= 1
newtype Normalized = Normalized { Normalized -> Double
normalized :: Double }
    deriving (Int -> Normalized -> ShowS
[Normalized] -> ShowS
Normalized -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Normalized] -> ShowS
$cshowList :: [Normalized] -> ShowS
show :: Normalized -> String
$cshow :: Normalized -> String
showsPrec :: Int -> Normalized -> ShowS
$cshowsPrec :: Int -> Normalized -> ShowS
Show, Normalized -> Normalized -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Normalized -> Normalized -> Bool
$c/= :: Normalized -> Normalized -> Bool
== :: Normalized -> Normalized -> Bool
$c== :: Normalized -> Normalized -> Bool
Eq, Normalized -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: Normalized -> Text
$cshow_val :: Normalized -> Text
ShowVal.ShowVal, [Normalized] -> Doc
Normalized -> Text
Normalized -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [Normalized] -> Doc
$cformatList :: [Normalized] -> Doc
format :: Normalized -> Doc
$cformat :: Normalized -> Doc
pretty :: Normalized -> Text
$cpretty :: Normalized -> Text
Pretty)

-- | -1 <= x <= 1
newtype NormalizedBipolar = NormalizedBipolar { NormalizedBipolar -> Double
normalized_bipolar :: Double }
    deriving (Int -> NormalizedBipolar -> ShowS
[NormalizedBipolar] -> ShowS
NormalizedBipolar -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormalizedBipolar] -> ShowS
$cshowList :: [NormalizedBipolar] -> ShowS
show :: NormalizedBipolar -> String
$cshow :: NormalizedBipolar -> String
showsPrec :: Int -> NormalizedBipolar -> ShowS
$cshowsPrec :: Int -> NormalizedBipolar -> ShowS
Show, NormalizedBipolar -> NormalizedBipolar -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NormalizedBipolar -> NormalizedBipolar -> Bool
$c/= :: NormalizedBipolar -> NormalizedBipolar -> Bool
== :: NormalizedBipolar -> NormalizedBipolar -> Bool
$c== :: NormalizedBipolar -> NormalizedBipolar -> Bool
Eq, NormalizedBipolar -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: NormalizedBipolar -> Text
$cshow_val :: NormalizedBipolar -> Text
ShowVal.ShowVal, [NormalizedBipolar] -> Doc
NormalizedBipolar -> Text
NormalizedBipolar -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [NormalizedBipolar] -> Doc
$cformatList :: [NormalizedBipolar] -> Doc
format :: NormalizedBipolar -> Doc
$cformat :: NormalizedBipolar -> Doc
pretty :: NormalizedBipolar -> Text
$cpretty :: NormalizedBipolar -> Text
Pretty)

-- | Normally Transpose will default to Chromatic if the val is untyped,
-- but some calls would prefer to default to Diatonic.
newtype DefaultDiatonic =
    DefaultDiatonic { DefaultDiatonic -> Transpose
default_diatonic :: Pitch.Transpose }
    deriving (Int -> DefaultDiatonic -> ShowS
[DefaultDiatonic] -> ShowS
DefaultDiatonic -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultDiatonic] -> ShowS
$cshowList :: [DefaultDiatonic] -> ShowS
show :: DefaultDiatonic -> String
$cshow :: DefaultDiatonic -> String
showsPrec :: Int -> DefaultDiatonic -> ShowS
$cshowsPrec :: Int -> DefaultDiatonic -> ShowS
Show, DefaultDiatonic -> DefaultDiatonic -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultDiatonic -> DefaultDiatonic -> Bool
$c/= :: DefaultDiatonic -> DefaultDiatonic -> Bool
== :: DefaultDiatonic -> DefaultDiatonic -> Bool
$c== :: DefaultDiatonic -> DefaultDiatonic -> Bool
Eq, DefaultDiatonic -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: DefaultDiatonic -> Text
$cshow_val :: DefaultDiatonic -> Text
ShowVal.ShowVal)

diatonic :: Double -> DefaultDiatonic
diatonic :: Double -> DefaultDiatonic
diatonic = Transpose -> DefaultDiatonic
DefaultDiatonic forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Transpose
Pitch.Diatonic

-- * typecheck utils

-- | Typecheck a single Val, and throw if it's the wrong type.
typecheck :: forall a. Typecheck a => Text -> ScoreTime -> Val
    -> Derive.Deriver a
typecheck :: forall a. Typecheck a => Text -> ScoreTime -> Val -> Deriver a
typecheck Text
msg ScoreTime
pos Val
val = forall a. Typecheck a => ScoreTime -> Val -> Deriver (Maybe a)
from_val_eval ScoreTime
pos Val
val forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Maybe a
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$
        forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
": " Text
msg forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Proxy a -> Val -> Text
type_error_msg (forall {k} (t :: k). Proxy t
Proxy @a) Val
val
    -- TODO throw a TypeError directly?

-- | Typecheck a simple value, with no evaluation.  This means you can't
-- get a deriver or coerce signal to a number.
typecheck_simple :: forall a. Typecheck a => Val -> Either Text a
typecheck_simple :: forall a. Typecheck a => Val -> Either Text a
typecheck_simple Val
val =
    forall err a. err -> Maybe a -> Either err a
justErr (forall a. Typecheck a => Proxy a -> Val -> Text
type_error_msg (forall {k} (t :: k). Proxy t
Proxy @a) Val
val) (forall a. Typecheck a => Val -> Maybe a
from_val_simple Val
val)

type_error_msg :: Typecheck a => Proxy a -> Val -> Text
type_error_msg :: forall a. Typecheck a => Proxy a -> Val -> Text
type_error_msg Proxy a
expected Val
val = Text
"expected " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. Typecheck a => Proxy a -> Type
to_type Proxy a
expected)
    forall a. Semigroup a => a -> a -> a
<> Text
" but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
val)

-- * Typecheck class

data Checked a =
    Val (Result a)
    -- | This val needs to be evaluated to know if it will typecheck.  The
    -- argument is the call start time.  This is needed when coercing a
    -- function to a scalar, because I only know the value to check after
    -- calling the function.
    | Eval (RealTime -> Derive.Deriver (Maybe a))
    deriving (forall a b. a -> Checked b -> Checked a
forall a b. (a -> b) -> Checked a -> Checked b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Checked b -> Checked a
$c<$ :: forall a b. a -> Checked b -> Checked a
fmap :: forall a b. (a -> b) -> Checked a -> Checked b
$cfmap :: forall a b. (a -> b) -> Checked a -> Checked b
Functor)

data Result a = Failure | Success !a
    -- | This is a {Note,Control,Pitch}Deriver, which needs a Context to
    -- evaluate.  'DeriveT.Quoted' can be coerced to this, at which point
    -- 'Derive.Eval.eval_quoted' needs a Context.  As with Quoted evaluation in
    -- general, this is only supported by Derive.Sig, not by the general
    -- 'typecehck' mechanism.
    | Derive !(Derive.Context Derive.Tagged -> a)
    deriving (forall a b. a -> Result b -> Result a
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: forall a b. (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor)

success :: a -> Checked a
success :: forall a. a -> Checked a
success = forall a. Result a -> Checked a
Val forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Result a
Success

failure :: Checked a
failure :: forall a. Checked a
failure = forall a. Result a -> Checked a
Val forall a. Result a
Failure

-- | Further check a Checked.  I feel like this should correspond to some kind
-- of monad transformer lift.
check :: (a -> Maybe b) -> Checked a -> Checked b
check :: forall a b. (a -> Maybe b) -> Checked a -> Checked b
check a -> Maybe b
f (Val Result a
a) = forall a. Result a -> Checked a
Val forall a b. (a -> b) -> a -> b
$ case Result a
a of
    Success a
a -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Result a
Failure forall a. a -> Result a
Success forall a b. (a -> b) -> a -> b
$ a -> Maybe b
f a
a
    Result a
Failure -> forall a. Result a
Failure
    Derive {} -> forall a. Result a
Failure -- can't really check one of these
check a -> Maybe b
f (Eval RealTime -> Deriver (Maybe a)
fa) = forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval (\RealTime
t -> (a -> Maybe b
f =<<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver (Maybe a)
fa RealTime
t)

-- | I can automatically derive a Typecheck for enum types.  So a simple enum
-- can get a Typecheck by "just" deriving these plus Typecheck.
type TEnum a = (ShowVal.ShowVal a, Bounded a, Enum a)

-- | This is the class of values which can be converted to a 'Val'.  'ToVal' is
-- the inverse transformation.
class Typecheck a where
    from_val :: Val -> Checked a
    default from_val :: TEnum a => Val -> Checked a
    from_val = forall a. Map Text a -> Val -> Checked a
from_val_symbol forall a. TEnum a => Map Text a
enum_map

    to_type :: Proxy a -> ValType.Type
    default to_type :: TEnum a => Proxy a -> ValType.Type
    to_type Proxy a
Proxy = forall a. ShowVal a => [a] -> Type
to_type_symbol [forall a. Bounded a => a
minBound :: a ..]

    from_subtrack :: SubT.Track -> Maybe a
    from_subtrack = forall a b. a -> b -> a
const forall a. Maybe a
Nothing

-- | 'from_val', but evaluate if it's an Eval.
from_val_eval :: Typecheck a => ScoreTime -> Val -> Derive.Deriver (Maybe a)
from_val_eval :: forall a. Typecheck a => ScoreTime -> Val -> Deriver (Maybe a)
from_val_eval ScoreTime
pos Val
val = case forall a. Typecheck a => Val -> Checked a
from_val Val
val of
    Val (Success a
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
a
    Val Result a
Failure -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    -- This is a deriver, which needs a Derive.Context.
    Val (Derive Context Tagged -> a
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Eval RealTime -> Deriver (Maybe a)
deriver -> RealTime -> Deriver (Maybe a)
deriver forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScoreTime -> Deriver RealTime
Derive.score_to_real ScoreTime
pos

from_val_simple :: Typecheck a => Val -> Maybe a
from_val_simple :: forall a. Typecheck a => Val -> Maybe a
from_val_simple Val
val = case forall a. Typecheck a => Val -> Checked a
from_val Val
val of
    Val (Success a
a) -> forall a. a -> Maybe a
Just a
a
    Checked a
_ -> forall a. Maybe a
Nothing

-- | Return a simple Eval check which doesn't depend on RealTime.
eval :: Typecheck a => (a -> Derive.Deriver b) -> Val -> Checked b
eval :: forall a b. Typecheck a => (a -> Deriver b) -> Val -> Checked b
eval a -> Deriver b
parse Val
val = forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
_ -> case forall a. Typecheck a => Val -> Maybe a
from_val_simple Val
val of
    Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just a
x -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Deriver b
parse a
x

-- | This is the inverse of Typecheck's 'from_val'.
class ToVal a where
    to_val :: a -> Val
    -- This has overly constrictive constraints because generally only TEnum
    -- types correspond to a Str via show_val.
    default to_val :: TEnum a => a -> Val
    to_val = Str -> Val
VStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val

to_type_symbol :: ShowVal.ShowVal a => [a] -> ValType.Type
to_type_symbol :: forall a. ShowVal a => [a] -> Type
to_type_symbol = Maybe [Text] -> Type
ValType.TStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Text
ShowVal.show_val

from_val_symbol :: Map Text a -> Val -> Checked a
from_val_symbol :: forall a. Map Text a -> Val -> Checked a
from_val_symbol Map Text a
syms = \case
    VStr (Expr.Str Text
str) -> forall a. Result a -> Checked a
Val forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Result a
Failure forall a. a -> Result a
Success forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
str Map Text a
syms
    Val
_ -> forall a. Checked a
failure
    -- Debug claims that syms is captured and evaluated only once even without
    -- the explicit lambda, but let's do it anyway, I think it has implications
    -- for inlining.

enum_map :: forall a. TEnum a => Map Text a
enum_map :: forall a. TEnum a => Map Text a
enum_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn forall a. ShowVal a => a -> Text
ShowVal.show_val [forall a. Bounded a => a
minBound ..]

num_to_type :: TypecheckNum a => Proxy a -> ValType.Type
num_to_type :: forall a. TypecheckNum a => Proxy a -> Type
num_to_type Proxy a
proxy = NumType -> NumValue -> Type
ValType.TSignal (forall a. TypecheckNum a => Proxy a -> NumType
num_type Proxy a
proxy) NumValue
ValType.TAny

class Typecheck a => TypecheckNum a where
    num_type :: Proxy a -> ValType.NumType

instance Typecheck Bool
instance ToVal Bool

instance ShowVal.ShowVal Meter.Rank
instance Typecheck Meter.Rank
instance ToVal Meter.Rank

instance Typecheck ScoreT.Type
instance ToVal ScoreT.Type

-- * Typecheck instances

instance ToVal Val where to_val :: Val -> Val
to_val = forall a. a -> a
id
instance Typecheck Val where
    from_val :: Val -> Checked Val
from_val = forall a. a -> Checked a
success
    to_type :: Proxy Val -> Type
to_type Proxy Val
_ = Type
ValType.TVal

-- | Putting Maybe in Typecheck means I can have optional arguments with no
-- defaults.  Further docs in 'Derive.Sig.defaulted'.
instance Typecheck a => Typecheck (Maybe a) where
    from_val :: Val -> Checked (Maybe a)
from_val Val
VNotGiven = forall a. a -> Checked a
success forall a. Maybe a
Nothing
    from_val Val
a = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => Val -> Checked a
from_val Val
a
    to_type :: Proxy (Maybe a) -> Type
to_type Proxy (Maybe a)
_ = Type -> Type
ValType.TMaybe forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Proxy a -> Type
to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    -- Propagate from_subtrack through a Maybe, so they can be optional.
    from_subtrack :: Track -> Maybe (Maybe a)
from_subtrack = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Track -> Maybe a
from_subtrack
instance ToVal a => ToVal (Maybe a) where
    to_val :: Maybe a -> Val
to_val = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Val
VNotGiven forall a. ToVal a => a -> Val
to_val

-- | A non-list is coerced into a singleton list.
instance Typecheck a => Typecheck [a] where
    from_val :: Val -> Checked [a]
from_val (VList [Val]
xs) = forall {a}. Typecheck a => [Val] -> Checked [a]
check [Val]
xs
        where
        check :: [Val] -> Checked [a]
check [] = forall a. a -> Checked a
success []
        check (Val
x:[Val]
xs) = case forall a. Typecheck a => Val -> Checked a
from_val Val
x of
            Val Result a
Failure -> forall a. Result a -> Checked a
Val forall a. Result a
Failure
            Val (Success a
a) -> (a
a:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Val] -> Checked [a]
check [Val]
xs
            Val (Derive Context Tagged -> a
deriver) -> case [Val] -> Checked [a]
check [Val]
xs of
                Val (Derive Context Tagged -> [a]
rest) -> forall a. Result a -> Checked a
Val forall a b. (a -> b) -> a -> b
$ forall a. (Context Tagged -> a) -> Result a
Derive forall a b. (a -> b) -> a -> b
$ \Context Tagged
ctx ->
                    Context Tagged -> a
deriver Context Tagged
ctx forall a. a -> [a] -> [a]
: Context Tagged -> [a]
rest Context Tagged
ctx
                Checked [a]
_ -> forall a. Result a -> Checked a
Val forall a. Result a
Failure
            Eval RealTime -> Deriver (Maybe a)
a -> case [Val] -> Checked [a]
check [Val]
xs of
                Val Result [a]
Failure -> forall a. Result a -> Checked a
Val forall a. Result a
Failure
                Val (Derive {}) -> forall a. Result a -> Checked a
Val forall a. Result a
Failure
                Val (Success [a]
as) -> (forall a. a -> [a] -> [a]
:[a]
as) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval RealTime -> Deriver (Maybe a)
a
                Eval RealTime -> Deriver (Maybe [a])
as -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
p -> forall {f :: * -> *} {a}. Applicative f => f a -> f [a] -> f [a]
cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver (Maybe a)
a RealTime
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RealTime -> Deriver (Maybe [a])
as RealTime
p
        cons :: f a -> f [a] -> f [a]
cons f a
a f [a]
as = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [a]
as
    from_val Val
v = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => Val -> Checked a
from_val Val
v
    to_type :: Proxy [a] -> Type
to_type Proxy [a]
_ = Type -> Type
ValType.TList forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Proxy a -> Type
to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToVal a => ToVal [a] where to_val :: [a] -> Val
to_val = [Val] -> Val
VList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ToVal a => a -> Val
to_val

instance (Typecheck a, Ord a) => Typecheck (Set a) where
    from_val :: Val -> Checked (Set a)
from_val = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Val -> Checked a
from_val
    to_type :: Proxy (Set a) -> Type
to_type Proxy (Set a)
_ = Type -> Type
ValType.TList forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Proxy a -> Type
to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToVal a => ToVal (Set a) where
    to_val :: Set a -> Val
to_val = [Val] -> Val
VList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ToVal a => a -> Val
to_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList

instance Typecheck a => Typecheck (NonEmpty a) where
    from_val :: Val -> Checked (NonEmpty a)
from_val Val
val = forall a b. (a -> Maybe b) -> Checked a -> Checked b
check forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty (forall a. Typecheck a => Val -> Checked a
from_val Val
val)
    to_type :: Proxy (NonEmpty a) -> Type
to_type Proxy (NonEmpty a)
_ = Type -> Type
ValType.TList forall a b. (a -> b) -> a -> b
$ forall a. Typecheck a => Proxy a -> Type
to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

instance (Typecheck a, Typecheck b) => Typecheck (Either a b) where
    from_val :: Val -> Checked (Either a b)
from_val Val
a = case forall a. Typecheck a => Val -> Checked a
from_val Val
a of
        Val Result a
Failure -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => Val -> Checked a
from_val Val
a
        Checked a
a -> forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Checked a
a
    to_type :: Proxy (Either a b) -> Type
to_type Proxy (Either a b)
_ = Type -> Type -> Type
ValType.TEither (forall a. Typecheck a => Proxy a -> Type
to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
        (forall a. Typecheck a => Proxy a -> Type
to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy b))
instance (ToVal a, ToVal b) => ToVal (Either a b) where
    to_val :: Either a b -> Val
to_val = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. ToVal a => a -> Val
to_val forall a. ToVal a => a -> Val
to_val


-- ** numeric types


-- | Signal.Control has ToVal but not Typecheck, because calls should be
-- using Function.
instance ToVal ScoreT.TypedSignal where to_val :: TypedSignal -> Val
to_val = TypedSignal -> Val
VSignal
instance ToVal PSignal.PSignal where to_val :: PSignal -> Val
to_val = PSignal -> Val
VPSignal

instance Typecheck ScoreT.TypedSignal where
    from_val :: Val -> Checked TypedSignal
from_val = Val -> Checked TypedSignal
coerce_to_signal
    to_type :: Proxy TypedSignal -> Type
to_type Proxy TypedSignal
_ = NumType -> NumValue -> Type
ValType.TSignal NumType
ValType.TUntyped NumValue
ValType.TAny

instance Typecheck Signal.Control where
    from_val :: Val -> Checked Control
from_val = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Typed a -> a
ScoreT.val_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Val -> Checked a
from_val
    to_type :: Proxy Control -> Type
to_type Proxy Control
_ = NumType -> NumValue -> Type
ValType.TSignal NumType
ValType.TUntyped NumValue
ValType.TAny

-- *** eval only

-- These don't have ToVal instances.  This means they can be used in a call,
-- but not turned back into a Val to put in the environ, or printed in log
-- msgs.

instance Typecheck ScoreT.TypedFunction where
    from_val :: Val -> Checked TypedFunction
from_val = forall a. (TypedFunction -> Maybe a) -> Val -> Checked a
coerce_to_function forall a. a -> Maybe a
Just
    to_type :: Proxy TypedFunction -> Type
to_type Proxy TypedFunction
_ = Text -> Type
ValType.TOther Text
"typed signal"

instance Typecheck ScoreT.Function where
    from_val :: Val -> Checked Function
from_val = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Typed a -> a
ScoreT.val_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Val -> Checked a
from_val
    to_type :: Proxy Function -> Type
to_type Proxy Function
_ = Text -> Type
ValType.TOther Text
"untyped signal"

instance Typecheck (RealTime -> RealTime) where
    from_val :: Val -> Checked (RealTime -> RealTime)
from_val = forall a. (TypedFunction -> Maybe a) -> Val -> Checked a
coerce_to_function forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Function
f) -> case Type
typ of
        Type
ScoreT.Real -> forall a. a -> Maybe a
Just (Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
f)
        Type
ScoreT.Untyped -> forall a. a -> Maybe a
Just (Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
f)
        Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy (RealTime -> RealTime) -> Type
to_type Proxy (RealTime -> RealTime)
_ = Text -> Type
ValType.TOther Text
"realtime signal"

instance Typecheck PSignal.PSignal where
    from_val :: Val -> Checked PSignal
from_val = Val -> Checked PSignal
coerce_to_pitch_signal
    to_type :: Proxy PSignal -> Type
to_type Proxy PSignal
_ = Type
ValType.TPSignal

instance Typecheck DeriveT.PitchFunction where
    from_val :: Val -> Checked PitchFunction
from_val = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PSignal -> PitchFunction
PSignal.at forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Checked PSignal
coerce_to_pitch_signal
    to_type :: Proxy PitchFunction -> Type
to_type Proxy PitchFunction
_ = Type
ValType.TPSignal

-- Returning Duration is convenient for Derive.real or Derive.score, e.g.
-- Gender.ngoret.
data RealTimeFunction = RealTimeFunction !(RealTime -> DeriveT.Duration)
data ScoreTimeFunction = ScoreTimeFunction !(RealTime -> DeriveT.Duration)

-- | Returning them separately is used in (at least) Speed.starts
data RealTimeFunctionT = RealTimeFunctionT !ScoreT.TimeT !ScoreT.Function
data ScoreTimeFunctionT = ScoreTimeFunctionT !ScoreT.TimeT !ScoreT.Function

instance Typecheck RealTimeFunctionT where
    from_val :: Val -> Checked RealTimeFunctionT
from_val = forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function TimeT -> Function -> RealTimeFunctionT
RealTimeFunctionT
        (TimeT -> Type -> Maybe TimeT
ScoreT.time_t TimeT
ScoreT.TReal)
    to_type :: Proxy RealTimeFunctionT -> Type
to_type Proxy RealTimeFunctionT
_ = Text -> Type
ValType.TOther Text
"time signal (default real)"
instance Typecheck ScoreTimeFunctionT where
    from_val :: Val -> Checked ScoreTimeFunctionT
from_val = forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function TimeT -> Function -> ScoreTimeFunctionT
ScoreTimeFunctionT
        (TimeT -> Type -> Maybe TimeT
ScoreT.time_t TimeT
ScoreT.TScore)
    to_type :: Proxy ScoreTimeFunctionT -> Type
to_type Proxy ScoreTimeFunctionT
_ = Text -> Type
ValType.TOther Text
"time signal (default score)"

instance Typecheck RealTimeFunction where
    from_val :: Val -> Checked RealTimeFunction
from_val = forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function (\Double -> Duration
dur Function
f -> (RealTime -> Duration) -> RealTimeFunction
RealTimeFunction forall a b. (a -> b) -> a -> b
$ Double -> Duration
dur forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
f)
        (TimeT -> Type -> Maybe (Double -> Duration)
time_constructor TimeT
ScoreT.TReal)
    to_type :: Proxy RealTimeFunction -> Type
to_type Proxy RealTimeFunction
_ = Text -> Type
ValType.TOther Text
"time signal (default real)"

instance Typecheck ScoreTimeFunction where
    from_val :: Val -> Checked ScoreTimeFunction
from_val = forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function (\Double -> Duration
dur Function
f -> (RealTime -> Duration) -> ScoreTimeFunction
ScoreTimeFunction forall a b. (a -> b) -> a -> b
$ Double -> Duration
dur forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
f)
        (TimeT -> Type -> Maybe (Double -> Duration)
time_constructor TimeT
ScoreT.TScore)
    to_type :: Proxy ScoreTimeFunction -> Type
to_type Proxy ScoreTimeFunction
_ = Text -> Type
ValType.TOther Text
"time signal (default score)"

time_constructor :: ScoreT.TimeT -> ScoreT.Type
    -> Maybe (Signal.Y -> DeriveT.Duration)
time_constructor :: TimeT -> Type -> Maybe (Double -> Duration)
time_constructor TimeT
deflt Type
typ = case TimeT -> Type -> Maybe TimeT
ScoreT.time_t TimeT
deflt Type
typ of
    Just TimeT
ScoreT.TReal -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> RealTime
RealTime.seconds
    Just TimeT
ScoreT.TScore -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> ScoreTime
ScoreTime.from_double
    Maybe TimeT
Nothing -> forall a. Maybe a
Nothing

-- Originally I used DataKinds e.g.
-- TransposeFunction (deflt :: TransposeType), but it seemed less
-- convenient than separate data types.

data DiatonicTransposeFunctionT =
    DiatonicTransposeFunctionT !ScoreT.TransposeT !ScoreT.Function
instance Typecheck DiatonicTransposeFunctionT where
    from_val :: Val -> Checked DiatonicTransposeFunctionT
from_val = forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function TransposeT -> Function -> DiatonicTransposeFunctionT
DiatonicTransposeFunctionT
        (TransposeT -> Type -> Maybe TransposeT
ScoreT.transpose_t TransposeT
ScoreT.TDiatonic)
    to_type :: Proxy DiatonicTransposeFunctionT -> Type
to_type Proxy DiatonicTransposeFunctionT
_ = Text -> Type
ValType.TOther Text
"transpose signal (default diatonic)"

data ChromaticTransposeFunctionT =
    ChromaticTransposeFunctionT !ScoreT.TransposeT !ScoreT.Function
instance Typecheck ChromaticTransposeFunctionT where
    from_val :: Val -> Checked ChromaticTransposeFunctionT
from_val = forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function TransposeT -> Function -> ChromaticTransposeFunctionT
ChromaticTransposeFunctionT
        (TransposeT -> Type -> Maybe TransposeT
ScoreT.transpose_t TransposeT
ScoreT.TChromatic)
    to_type :: Proxy ChromaticTransposeFunctionT -> Type
to_type Proxy ChromaticTransposeFunctionT
_ = Text -> Type
ValType.TOther Text
"transpose signal (default chromatic)"

data NnTransposeFunctionT =
    NnTransposeFunctionT !ScoreT.TransposeT !ScoreT.Function
instance Typecheck NnTransposeFunctionT where
    from_val :: Val -> Checked NnTransposeFunctionT
from_val = forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function TransposeT -> Function -> NnTransposeFunctionT
NnTransposeFunctionT
        (TransposeT -> Type -> Maybe TransposeT
ScoreT.transpose_t TransposeT
ScoreT.TNn)
    to_type :: Proxy NnTransposeFunctionT -> Type
to_type Proxy NnTransposeFunctionT
_ = Text -> Type
ValType.TOther Text
"transpose signal (default nn)"


-- *** scalar

instance Typecheck (ScoreT.Typed Signal.Y) where
    from_val :: Val -> Checked (Typed Double)
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a. a -> Maybe a
Just
    to_type :: Proxy (Typed Double) -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal (ScoreT.Typed Signal.Y) where
    to_val :: Typed Double -> Val
to_val = TypedSignal -> Val
VSignal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (kind :: k). Double -> Signal kind
Signal.constant
instance TypecheckNum (ScoreT.Typed Signal.Y) where
    num_type :: Proxy (Typed Double) -> NumType
num_type Proxy (Typed Double)
_ = NumType
ValType.TUntyped

instance Typecheck Double where
    from_val :: Val -> Checked Double
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of)
    to_type :: Proxy Double -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal Double where to_val :: Double -> Val
to_val = Double -> Val
DeriveT.num
instance TypecheckNum Double where num_type :: Proxy Double -> NumType
num_type Proxy Double
_ = NumType
ValType.TUntyped

instance Typecheck (Ratio.Ratio Int) where
    from_val :: Val -> Checked (Ratio Int)
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$
        forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. RealFrac a => a -> a -> Rational
Ratio.approxRational Double
0.001 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of
    to_type :: Proxy (Ratio Int) -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal (Ratio.Ratio Int) where
    to_val :: Ratio Int -> Val
to_val = Double -> Val
DeriveT.num forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance TypecheckNum (Ratio.Ratio Int) where num_type :: Proxy (Ratio Int) -> NumType
num_type Proxy (Ratio Int)
_ = NumType
ValType.TUntyped

instance Typecheck Int where
    from_val :: Val -> Checked Int
from_val = forall a. Integral a => Val -> Checked a
from_integral_val
    to_type :: Proxy Int -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type

instance Typecheck Integer where
    from_val :: Val -> Checked Integer
from_val = forall a. Integral a => Val -> Checked a
from_integral_val
    to_type :: Proxy Integer -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type

from_integral_val :: Integral a => Val -> Checked a
from_integral_val :: forall a. Integral a => Val -> Checked a
from_integral_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar (forall {a} {a}. (RealFrac a, Integral a) => a -> Maybe a
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of)
    where
    check :: a -> Maybe a
check a
a = if a
frac forall a. Eq a => a -> a -> Bool
== a
0 then forall a. a -> Maybe a
Just a
int else forall a. Maybe a
Nothing
        where (a
int, a
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction a
a

instance ToVal Int where to_val :: Int -> Val
to_val = Double -> Val
DeriveT.num forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
instance ToVal Integer where to_val :: Integer -> Val
to_val = Double -> Val
DeriveT.num forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
instance TypecheckNum Int where num_type :: Proxy Int -> NumType
num_type Proxy Int
_ = NumType
ValType.TInt
instance TypecheckNum Integer where num_type :: Proxy Integer -> NumType
num_type Proxy Integer
_ = NumType
ValType.TInt

-- | VSignals can also be coerced into chromatic transposition, so you can
-- write a plain number if you don't care about diatonic.
--
-- This is different from 'DeriveT.Duration', which does not default an
-- untyped literal, so you have to supply the type explicitly.  The rationale
-- is that many scales don't have diatonic or chromatic, and it would be
-- annoying to have to specify one or the other when it was definitely
-- irrelevant.  But the RealTime ScoreTime distinction is universal, there is
-- no single default that is appropriate for all calls.  So they have to
-- specify a default by taking a 'DefaultScore' or 'DefaultReal', or require
-- the caller to distinguish with 'DeriveT.Duration'.
instance Typecheck Pitch.Transpose where
    from_val :: Val -> Checked Transpose
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) -> case Type
typ of
        Type
ScoreT.Untyped -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Chromatic Double
val)
        Type
ScoreT.Chromatic -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Chromatic Double
val)
        Type
ScoreT.Diatonic -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Diatonic Double
val)
        Type
ScoreT.Nn -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Nn Double
val)
        Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy Transpose -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance TypecheckNum Pitch.Transpose where num_type :: Proxy Transpose -> NumType
num_type Proxy Transpose
_ = NumType
ValType.TTranspose

instance ToVal Pitch.Transpose where
    to_val :: Transpose -> Val
to_val = \case
        Pitch.Chromatic Double
a -> Type -> Double -> Val
DeriveT.constant Type
ScoreT.Chromatic Double
a
        Pitch.Diatonic Double
a -> Type -> Double -> Val
DeriveT.constant Type
ScoreT.Diatonic Double
a
        Pitch.Nn Double
a -> Type -> Double -> Val
DeriveT.constant Type
ScoreT.Nn Double
a

-- | But some calls want to default to diatonic, not chromatic.
instance Typecheck DefaultDiatonic where
    from_val :: Val -> Checked DefaultDiatonic
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Transpose -> DefaultDiatonic
DefaultDiatonic forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Diatonic Double
val)
            Type
ScoreT.Chromatic -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Chromatic Double
val)
            Type
ScoreT.Diatonic -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Diatonic Double
val)
            Type
ScoreT.Nn -> forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Nn Double
val)
            Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy DefaultDiatonic -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal DefaultDiatonic where to_val :: DefaultDiatonic -> Val
to_val (DefaultDiatonic Transpose
a) = forall a. ToVal a => a -> Val
to_val Transpose
a
instance TypecheckNum DefaultDiatonic where
    num_type :: Proxy DefaultDiatonic -> NumType
num_type Proxy DefaultDiatonic
_ = NumType
ValType.TDefaultDiatonic

instance Typecheck Pitch.NoteNumber where
    from_val :: Val -> Checked NoteNumber
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        forall a. Real a => a -> NoteNumber
Pitch.nn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> forall a. a -> Maybe a
Just Double
val
            Type
ScoreT.Nn -> forall a. a -> Maybe a
Just Double
val
            Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy NoteNumber -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal Pitch.NoteNumber where
    to_val :: NoteNumber -> Val
to_val = Type -> Double -> Val
DeriveT.constant Type
ScoreT.Nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Double
Pitch.nn_to_double
instance TypecheckNum Pitch.NoteNumber where num_type :: Proxy NoteNumber -> NumType
num_type Proxy NoteNumber
_ = NumType
ValType.TNoteNumber

instance Typecheck ScoreTime where
    from_val :: Val -> Checked ScoreTime
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Double -> ScoreTime
ScoreTime.from_double forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> forall a. a -> Maybe a
Just Double
val
            Type
ScoreT.Score -> forall a. a -> Maybe a
Just Double
val
            Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy ScoreTime -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal ScoreTime where
    to_val :: ScoreTime -> Val
to_val = Type -> Double -> Val
DeriveT.constant Type
ScoreT.Score forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Double
ScoreTime.to_double
instance TypecheckNum ScoreTime where num_type :: Proxy ScoreTime -> NumType
num_type Proxy ScoreTime
_ = NumType
ValType.TScoreTime

instance Typecheck RealTime where
    from_val :: Val -> Checked RealTime
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Double -> RealTime
RealTime.seconds forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> forall a. a -> Maybe a
Just Double
val
            Type
ScoreT.Real -> forall a. a -> Maybe a
Just Double
val
            Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy RealTime -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal RealTime where
    to_val :: RealTime -> Val
to_val = Type -> Double -> Val
DeriveT.constant Type
ScoreT.Real forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function
RealTime.to_seconds
instance TypecheckNum RealTime where num_type :: Proxy RealTime -> NumType
num_type Proxy RealTime
_ = NumType
ValType.TRealTime

instance Typecheck DeriveT.Duration where
    from_val :: Val -> Checked Duration
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) -> case Type
typ of
        -- Untyped is abiguous, and there doesn't seem to be a natural
        -- default.
        Type
ScoreT.Score -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
        Type
ScoreT.Real -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
        Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy Duration -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type

instance ToVal DeriveT.Duration where
    to_val :: Duration -> Val
to_val (DeriveT.ScoreDuration ScoreTime
a) = forall a. ToVal a => a -> Val
to_val ScoreTime
a
    to_val (DeriveT.RealDuration RealTime
a) = forall a. ToVal a => a -> Val
to_val RealTime
a
instance TypecheckNum DeriveT.Duration where num_type :: Proxy Duration -> NumType
num_type Proxy Duration
_ = NumType
ValType.TTime

instance Typecheck DefaultReal where
    from_val :: Val -> Checked DefaultReal
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Duration -> DefaultReal
DefaultReal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
            Type
ScoreT.Score ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
            Type
ScoreT.Real -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
            Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy DefaultReal -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal DefaultReal where to_val :: DefaultReal -> Val
to_val (DefaultReal Duration
a) = forall a. ToVal a => a -> Val
to_val Duration
a
instance TypecheckNum DefaultReal where num_type :: Proxy DefaultReal -> NumType
num_type Proxy DefaultReal
_ = NumType
ValType.TDefaultReal

instance Typecheck DefaultScore where
    from_val :: Val -> Checked DefaultScore
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Duration -> DefaultScore
DefaultScore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
            Type
ScoreT.Score ->
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
            Type
ScoreT.Real -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
            Type
_ -> forall a. Maybe a
Nothing
    to_type :: Proxy DefaultScore -> Type
to_type = forall a. TypecheckNum a => Proxy a -> Type
num_to_type

instance ToVal DefaultScore where to_val :: DefaultScore -> Val
to_val (DefaultScore Duration
a) = forall a. ToVal a => a -> Val
to_val Duration
a
instance TypecheckNum DefaultScore where num_type :: Proxy DefaultScore -> NumType
num_type Proxy DefaultScore
_ = NumType
ValType.TDefaultScore

instance TypecheckNum a => Typecheck (Positive a) where
    from_val :: Val -> Checked (Positive a)
from_val v :: Val
v@(VSignal (ScoreT.Typed Type
_ Control
sig))
        | Just Double
n <- forall {k} (kind :: k). Signal kind -> Maybe Double
Signal.constant_val Control
sig, Double
n forall a. Ord a => a -> a -> Bool
> Double
0 = forall a. a -> Positive a
Positive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => Val -> Checked a
from_val Val
v
        | Bool
otherwise = forall a. Checked a
failure
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy (Positive a) -> Type
to_type Proxy (Positive a)
_ = NumType -> NumValue -> Type
ValType.TSignal (forall a. TypecheckNum a => Proxy a -> NumType
num_type (forall {k} (t :: k). Proxy t
Proxy @a)) NumValue
ValType.TPositive
instance ToVal a => ToVal (Positive a) where
    to_val :: Positive a -> Val
to_val (Positive a
val) = forall a. ToVal a => a -> Val
to_val a
val

instance TypecheckNum a => Typecheck (NonNegative a) where
    from_val :: Val -> Checked (NonNegative a)
from_val v :: Val
v@(VSignal (ScoreT.Typed Type
_ Control
sig))
        | Just Double
n <- forall {k} (kind :: k). Signal kind -> Maybe Double
Signal.constant_val Control
sig, Double
n forall a. Ord a => a -> a -> Bool
>= Double
0 = forall a. a -> NonNegative a
NonNegative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => Val -> Checked a
from_val Val
v
        | Bool
otherwise = forall a. Checked a
failure
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy (NonNegative a) -> Type
to_type Proxy (NonNegative a)
_ = NumType -> NumValue -> Type
ValType.TSignal (forall a. TypecheckNum a => Proxy a -> NumType
num_type (forall {k} (t :: k). Proxy t
Proxy @a)) NumValue
ValType.TNonNegative
instance ToVal a => ToVal (NonNegative a) where
    to_val :: NonNegative a -> Val
to_val (NonNegative a
val) = forall a. ToVal a => a -> Val
to_val a
val

instance Typecheck Normalized where
    from_val :: Val -> Checked Normalized
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar (Double -> Maybe Normalized
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of)
        where
        check :: Double -> Maybe Normalized
check Double
a
            | Double
0 forall a. Ord a => a -> a -> Bool
<= Double
a Bool -> Bool -> Bool
&& Double
a forall a. Ord a => a -> a -> Bool
<= Double
1 = forall a. a -> Maybe a
Just (Double -> Normalized
Normalized Double
a)
            | Bool
otherwise = forall a. Maybe a
Nothing
    to_type :: Proxy Normalized -> Type
to_type Proxy Normalized
_ = NumType -> NumValue -> Type
ValType.TSignal NumType
ValType.TUntyped NumValue
ValType.TNormalized
instance ToVal Normalized where to_val :: Normalized -> Val
to_val = Double -> Val
DeriveT.num forall b c a. (b -> c) -> (a -> b) -> a -> c
. Normalized -> Double
normalized

instance Typecheck NormalizedBipolar where
    from_val :: Val -> Checked NormalizedBipolar
from_val = forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar (Double -> Maybe NormalizedBipolar
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typed a -> a
ScoreT.val_of)
        where
        check :: Double -> Maybe NormalizedBipolar
check Double
a
            | -Double
1 forall a. Ord a => a -> a -> Bool
<= Double
a Bool -> Bool -> Bool
&& Double
a forall a. Ord a => a -> a -> Bool
<= Double
1 = forall a. a -> Maybe a
Just (Double -> NormalizedBipolar
NormalizedBipolar Double
a)
            | Bool
otherwise = forall a. Maybe a
Nothing
    to_type :: Proxy NormalizedBipolar -> Type
to_type Proxy NormalizedBipolar
_ = NumType -> NumValue -> Type
ValType.TSignal NumType
ValType.TUntyped NumValue
ValType.TNormalizedBipolar
instance ToVal NormalizedBipolar where
    to_val :: NormalizedBipolar -> Val
to_val = Double -> Val
DeriveT.num forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedBipolar -> Double
normalized_bipolar

-- ** text\/symbol

instance Typecheck Expr.Symbol where
    from_val :: Val -> Checked Symbol
from_val (VStr (Expr.Str Text
sym)) = forall a. a -> Checked a
success forall a b. (a -> b) -> a -> b
$ Text -> Symbol
Expr.Symbol Text
sym
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Symbol -> Type
to_type Proxy Symbol
_ = Maybe [Text] -> Type
ValType.TStr forall a. Maybe a
Nothing
instance ToVal Expr.Symbol where to_val :: Symbol -> Val
to_val = Str -> Val
VStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Text
Expr.unsym

instance Typecheck Expr.Str where
    from_val :: Val -> Checked Str
from_val (VStr Str
a) = forall a. a -> Checked a
success Str
a
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Str -> Type
to_type Proxy Str
_ = Maybe [Text] -> Type
ValType.TStr forall a. Maybe a
Nothing
instance ToVal Expr.Str where to_val :: Str -> Val
to_val = Str -> Val
VStr

instance Typecheck Text where
    from_val :: Val -> Checked Text
from_val (VStr (Expr.Str Text
s)) = forall a. a -> Checked a
success Text
s
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Text -> Type
to_type Proxy Text
_ = Maybe [Text] -> Type
ValType.TStr forall a. Maybe a
Nothing
instance ToVal Text where to_val :: Text -> Val
to_val = Str -> Val
VStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str

instance Typecheck ScoreT.Control where
    from_val :: Val -> Checked Control
from_val (VStr (Expr.Str Text
s)) =
        forall a. Result a -> Checked a
Val forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Result a
Failure) forall a. a -> Result a
Success (Text -> Either Text Control
ScoreT.checked_control Text
s)
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Control -> Type
to_type Proxy Control
_ = Type
ValType.TControl
instance ToVal ScoreT.Control where
    to_val :: Control -> Val
to_val Control
c = Str -> Val
VStr (Text -> Str
Expr.Str (Control -> Text
ScoreT.control_name Control
c))

instance Typecheck ScoreT.PControl where
    from_val :: Val -> Checked PControl
from_val (VStr (Expr.Str Text
s)) =
        forall a. Result a -> Checked a
Val forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Result a
Failure) forall a. a -> Result a
Success (Text -> Either Text PControl
ScoreT.checked_pcontrol Text
s)
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy PControl -> Type
to_type Proxy PControl
_ = Type
ValType.TPControl
instance ToVal ScoreT.PControl where
    to_val :: PControl -> Val
to_val PControl
c = Str -> Val
VStr (Text -> Str
Expr.Str (PControl -> Text
ScoreT.pcontrol_name PControl
c))

-- ** other types

instance Typecheck Attrs.Attributes where
    from_val :: Val -> Checked Attributes
from_val (VAttributes Attributes
a) = forall a. a -> Checked a
success Attributes
a
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Attributes -> Type
to_type Proxy Attributes
_ = Type
ValType.TAttributes
instance ToVal Attrs.Attributes where to_val :: Attributes -> Val
to_val = Attributes -> Val
VAttributes

-- Intentionally no Typecheck ControlRef, use Function instances.
instance ToVal DeriveT.ControlRef where to_val :: ControlRef -> Val
to_val = ControlRef -> Val
VControlRef

-- Intentionally no Typecheck PControlRef, use PSignal instances.
instance ToVal DeriveT.PControlRef where to_val :: PControlRef -> Val
to_val = PControlRef -> Val
VPControlRef

instance Typecheck PSignal.Pitch where
    from_val :: Val -> Checked Pitch
from_val = Val -> Checked Pitch
coerce_to_pitch
    to_type :: Proxy Pitch -> Type
to_type Proxy Pitch
_ = Type
ValType.TPitch
instance ToVal PSignal.Pitch where to_val :: Pitch -> Val
to_val = Pitch -> Val
VPitch

instance Typecheck Pitch.Pitch where
    from_val :: Val -> Checked Pitch
from_val (VNotePitch Pitch
a) = forall a. a -> Checked a
success Pitch
a
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Pitch -> Type
to_type Proxy Pitch
_ = Type
ValType.TNotePitch
instance ToVal Pitch.Pitch where to_val :: Pitch -> Val
to_val = Pitch -> Val
VNotePitch

instance Typecheck ScoreT.Instrument where
    from_val :: Val -> Checked Instrument
from_val (VStr (Expr.Str Text
a)) = forall a. a -> Checked a
success (Text -> Instrument
ScoreT.Instrument Text
a)
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Instrument -> Type
to_type Proxy Instrument
_ = Maybe [Text] -> Type
ValType.TStr forall a. Maybe a
Nothing
instance ToVal ScoreT.Instrument where
    to_val :: Instrument -> Val
to_val (ScoreT.Instrument Text
a) = Str -> Val
VStr (Text -> Str
Expr.Str Text
a)

instance Typecheck DeriveT.CFunction where
    from_val :: Val -> Checked CFunction
from_val (VCFunction CFunction
a) = forall a. a -> Checked a
success CFunction
a
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy CFunction -> Type
to_type Proxy CFunction
_ = Type
ValType.TCFunction
instance ToVal DeriveT.CFunction where to_val :: CFunction -> Val
to_val = CFunction -> Val
VCFunction

instance Typecheck DeriveT.PFunction where
    from_val :: Val -> Checked PFunction
from_val (VPFunction PFunction
a) = forall a. a -> Checked a
success PFunction
a
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy PFunction -> Type
to_type Proxy PFunction
_ = Type
ValType.TPFunction
instance ToVal DeriveT.PFunction where to_val :: PFunction -> Val
to_val = PFunction -> Val
VPFunction

-- | Anything except a pitch can be coerced to a quoted, using ShowVal.  This
-- means you can write a lot of things without quotes.
--
-- Pitches have to be quoted because they explicitly have an invalid ShowVal.
instance Typecheck DeriveT.Quoted where
    from_val :: Val -> Checked Quoted
from_val Val
val = case Val
val of
        VQuoted Quoted
a -> forall a. a -> Checked a
success Quoted
a
        VPitch {} -> forall a. Checked a
failure
        VStr (Expr.Str Text
sym) -> Text -> Checked Quoted
to_quoted Text
sym
        Val
_ -> Text -> Checked Quoted
to_quoted forall a b. (a -> b) -> a -> b
$ forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val
        where
        to_quoted :: Text -> Checked Quoted
to_quoted Text
sym = forall a. a -> Checked a
success forall a b. (a -> b) -> a -> b
$
            Expr -> Quoted
DeriveT.Quoted forall a b. (a -> b) -> a -> b
$ forall val. Symbol -> [Term val] -> Call val
Expr.Call (Text -> Symbol
Expr.Symbol Text
sym) [] forall a. a -> [a] -> NonEmpty a
:| []
    to_type :: Proxy Quoted -> Type
to_type Proxy Quoted
_ = Type
ValType.TQuoted
instance ToVal DeriveT.Quoted where to_val :: Quoted -> Val
to_val = Quoted -> Val
VQuoted

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

instance ShowVal.ShowVal NotGiven where
    show_val :: NotGiven -> Text
show_val NotGiven
NotGiven = Text
"_"

instance Typecheck NotGiven where
    from_val :: Val -> Checked NotGiven
from_val Val
VNotGiven = forall a. a -> Checked a
success NotGiven
NotGiven
    from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy NotGiven -> Type
to_type Proxy NotGiven
_ = Type
ValType.TNotGiven

instance ToVal NotGiven where
    to_val :: NotGiven -> Val
to_val NotGiven
NotGiven = Val
VNotGiven

-- * util

-- TODO There are four types that divide into two kinds.  Then I have
-- every possible combination:
-- any type: ScoreT.Real
-- time type without value: Real
-- time type with value: DeriveT.RealDuration
--
-- This means I wind up with a lot of duplication here to handle time types and
-- transpose types.  Surely there's a better way?  Maybe put the two kinds into
-- a typeclass?

to_transpose :: ScoreT.TransposeT -> Double -> Pitch.Transpose
to_transpose :: TransposeT -> Double -> Transpose
to_transpose TransposeT
typ Double
val = case TransposeT
typ of
    TransposeT
ScoreT.TDiatonic -> Double -> Transpose
Pitch.Diatonic Double
val
    TransposeT
ScoreT.TChromatic -> Double -> Transpose
Pitch.Chromatic Double
val
    TransposeT
ScoreT.TNn -> Double -> Transpose
Pitch.Nn Double
val

transpose_control :: ScoreT.TransposeT -> ScoreT.Control
transpose_control :: TransposeT -> Control
transpose_control = \case
    TransposeT
ScoreT.TDiatonic -> Control
Controls.diatonic
    TransposeT
ScoreT.TChromatic -> Control
Controls.chromatic
    TransposeT
ScoreT.TNn -> Control
Controls.nn

-- ** controls

coerce_to_typed_function :: (typ -> ScoreT.Function -> b)
    -> (ScoreT.Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function :: forall typ b.
(typ -> Function -> b) -> (Type -> Maybe typ) -> Val -> Checked b
coerce_to_typed_function typ -> Function -> b
make Type -> Maybe typ
check = forall a. (TypedFunction -> Maybe a) -> Val -> Checked a
coerce_to_function forall a b. (a -> b) -> a -> b
$
    \(ScoreT.Typed Type
typ Function
f) -> forall a b c. (a -> b -> c) -> b -> a -> c
flip typ -> Function -> b
make Function
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe typ
check Type
typ

-- | Coerce any numeric value to a ScoreT.Typed Signal.Y, and check it against
-- the given function.
coerce_to_scalar :: (ScoreT.Typed Signal.Y -> Maybe a) -> Val -> Checked a
coerce_to_scalar :: forall a. (Typed Double -> Maybe a) -> Val -> Checked a
coerce_to_scalar Typed Double -> Maybe a
check Val
val
    -- It's important that constant VSignals remain Val, which means they don't
    -- need Eval, which means they don't need a time.  This is because
    -- non-signal constants in the environ like srate use from_val_simple,
    -- which ignores Eval.  TODO if I want all numeric values to be variable,
    -- then I should merge control_at with Derive.get_val, so it takes a time.
    | Just Typed Double
num <- Val -> Maybe (Typed Double)
DeriveT.constant_val Val
val =
        forall a. Result a -> Checked a
Val forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Result a
Failure forall a. a -> Result a
Success forall a b. (a -> b) -> a -> b
$ Typed Double -> Maybe a
check Typed Double
num
    | Bool
otherwise = case Val -> Maybe (Either (Deriver TypedFunction) TypedFunction)
val_to_function Val
val of
        Just (Right TypedFunction
tf) -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Typed Double -> Maybe a
check ((forall a b. (a -> b) -> a -> b
$ RealTime
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedFunction
tf)
        Just (Left Deriver TypedFunction
df) -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
t -> Typed Double -> Maybe a
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((forall a b. (a -> b) -> a -> b
$ RealTime
t) <$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver TypedFunction
df
        Maybe (Either (Deriver TypedFunction) TypedFunction)
Nothing -> forall a. Checked a
failure

-- | Coerce any numeric value to a function, and check it against the given
-- function.
coerce_to_function :: (ScoreT.TypedFunction -> Maybe a) -> Val -> Checked a
coerce_to_function :: forall a. (TypedFunction -> Maybe a) -> Val -> Checked a
coerce_to_function TypedFunction -> Maybe a
check Val
val = case Val -> Maybe (Either (Deriver TypedFunction) TypedFunction)
val_to_function Val
val of
    Just (Right TypedFunction
f) -> forall a. Result a -> Checked a
Val forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Result a
Failure forall a. a -> Result a
Success forall a b. (a -> b) -> a -> b
$ TypedFunction -> Maybe a
check TypedFunction
f
    -- Eval's t time is thrown away, because I'm creating a function and thus
    -- don't need to know at which time to evaluate it.
    Just (Left Deriver TypedFunction
df) -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
_t -> TypedFunction -> Maybe a
check forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver TypedFunction
df
    Maybe (Either (Deriver TypedFunction) TypedFunction)
Nothing -> forall a. Checked a
failure

val_to_function :: Val
    -> Maybe (Either (Derive.Deriver ScoreT.TypedFunction) ScoreT.TypedFunction)
val_to_function :: Val -> Maybe (Either (Deriver TypedFunction) TypedFunction)
val_to_function = \case
    VSignal TypedSignal
sig -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> Function
Signal.at forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedSignal
sig
    VControlRef ControlRef
ref -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ControlRef -> Deriver TypedFunction
resolve_function ControlRef
ref
    VCFunction CFunction
cf -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ do
        Dynamic
cf_dyn <- Deriver Dynamic
Internal.get_control_function_dynamic
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dynamic -> CFunction -> TypedFunction
DeriveT.call_cfunction Dynamic
cf_dyn CFunction
cf
    VPFunction PFunction
f -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PFunction -> TypedFunction
DeriveT.pf_function PFunction
f
    Val
_ -> forall a. Maybe a
Nothing

-- | Unfortunately Internal.get_control_function_dynamic is non-trivial,
-- so it makes sense to do it only once when converting many.
--
-- TODO does it really?  It seems like a bogus tradeoff to have to make.
-- I could cache it, but is that not what this is?
-- If it's cheap to call Internal.get_control_function_dynamic and only
-- expensive to force it, then I should always pass it, and rely on laziness.
val_to_function_dyn :: DeriveT.Dynamic -> Val
    -> Maybe (Either (Derive.Deriver ScoreT.TypedFunction) ScoreT.TypedFunction)
val_to_function_dyn :: Dynamic
-> Val -> Maybe (Either (Deriver TypedFunction) TypedFunction)
val_to_function_dyn Dynamic
cf_dyn = \case
    VSignal TypedSignal
sig -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> Function
Signal.at forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedSignal
sig
    -- TODO propagate cf_dyn through
    VControlRef ControlRef
ref -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ControlRef -> Deriver TypedFunction
resolve_function ControlRef
ref
    VCFunction CFunction
cf -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Dynamic -> CFunction -> TypedFunction
DeriveT.call_cfunction Dynamic
cf_dyn CFunction
cf
    Val
_ -> forall a. Maybe a
Nothing

resolve_function :: DeriveT.ControlRef -> Derive.Deriver ScoreT.TypedFunction
resolve_function :: ControlRef -> Deriver TypedFunction
resolve_function ControlRef
ref =
    forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"control not found: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
ref)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ControlRef -> Deriver (Maybe TypedFunction)
lookup_function ControlRef
ref

-- | Resolve a ref to a function, applying a CFunction if there is one.
lookup_function :: DeriveT.ControlRef
    -> Derive.Deriver (Maybe ScoreT.TypedFunction)
lookup_function :: ControlRef -> Deriver (Maybe TypedFunction)
lookup_function (DeriveT.Ref Control
control Maybe TypedSignal
deflt) = do
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TypedFunction
deflt_f) Val -> Deriver (Maybe TypedFunction)
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Val
DeriveT.lookup (Control -> Text
ScoreT.control_name Control
control)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver Environ
Internal.get_environ
    where
    deflt_f :: Maybe TypedFunction
deflt_f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (kind :: k). Signal kind -> Function
Signal.at forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TypedSignal
deflt
    get :: Val -> Derive.Deriver (Maybe ScoreT.TypedFunction)
    get :: Val -> Deriver (Maybe TypedFunction)
get Val
val = case Val -> Maybe (Either (Deriver TypedFunction) TypedFunction)
val_to_function Val
val of
        Maybe (Either (Deriver TypedFunction) TypedFunction)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (Right TypedFunction
tf) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just TypedFunction
tf
        Just (Left Deriver TypedFunction
dtf) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver TypedFunction
dtf

-- *** signal

-- | Resolve ref to a ScoreT.TypedSignal.  This does not take ControlFunctions
-- into account, but is necessary when you need the actual signal.
resolve_signal :: DeriveT.ControlRef
    -> Derive.Deriver (Maybe ScoreT.TypedSignal)
resolve_signal :: ControlRef -> Deriver (Maybe TypedSignal)
resolve_signal (DeriveT.Ref Control
control Maybe TypedSignal
deflt) =
    (forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TypedSignal
deflt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Control -> Deriver (Maybe TypedSignal)
lookup_signal Control
control

coerce_to_signal :: Val -> Checked ScoreT.TypedSignal
coerce_to_signal :: Val -> Checked TypedSignal
coerce_to_signal Val
val = case Val -> Maybe (Either (Deriver TypedSignal) TypedSignal)
val_to_signal Val
val of
    Maybe (Either (Deriver TypedSignal) TypedSignal)
Nothing -> forall a. Checked a
failure
    Just (Left Deriver TypedSignal
dsig) -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver TypedSignal
dsig
    Just (Right TypedSignal
sig) -> forall a. a -> Checked a
success TypedSignal
sig

-- | As with 'lookup_pitch_function', this should be in Deriver.Lib.
lookup_signal :: ScoreT.Control -> Derive.Deriver (Maybe ScoreT.TypedSignal)
lookup_signal :: Control -> Deriver (Maybe TypedSignal)
lookup_signal Control
control =
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Val -> Deriver TypedSignal
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Val
DeriveT.lookup (Control -> Text
ScoreT.control_name Control
control)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver Environ
Internal.get_environ
    where
    get :: Val -> Deriver TypedSignal
get Val
val = case Val -> Maybe (Either (Deriver TypedSignal) TypedSignal)
val_to_signal Val
val of
        Maybe (Either (Deriver TypedSignal) TypedSignal)
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"can't be coerced to signal: "
            forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val
        Just (Left Deriver TypedSignal
df) -> Deriver TypedSignal
df
        Just (Right TypedSignal
f) -> forall (m :: * -> *) a. Monad m => a -> m a
return TypedSignal
f

val_to_signal :: Val
    -> Maybe (Either (Derive.Deriver ScoreT.TypedSignal) ScoreT.TypedSignal)
val_to_signal :: Val -> Maybe (Either (Deriver TypedSignal) TypedSignal)
val_to_signal = \case
    VSignal TypedSignal
a -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right TypedSignal
a
    VControlRef ControlRef
ref -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"control not found: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val ControlRef
ref)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ControlRef -> Deriver (Maybe TypedSignal)
resolve_signal ControlRef
ref
    VCFunction CFunction
cf -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ CFunction -> TypedSignal
DeriveT.cf_signal CFunction
cf
    Val
_ -> forall a. Maybe a
Nothing


-- ** pitch signals

-- Unlike controls, this works with signals instead of functions.  Ultimately
-- this is because there is no equaivalent of CFunction.  Signals are
-- less flexible than functions, but more useful since I can splice a signal
-- back into the environment, while functions are opaque.

-- | This is the pitch version of 'coerce_to_scalar'.
coerce_to_pitch :: Val -> Checked PSignal.Pitch
coerce_to_pitch :: Val -> Checked Pitch
coerce_to_pitch = \case
    VPitch Pitch
a -> forall a. a -> Checked a
success Pitch
a
    Val
val | Just (ScoreT.Typed Type
ScoreT.Nn Double
nn) <- Val -> Maybe (Typed Double)
DeriveT.constant_val Val
val ->
        forall a. a -> Checked a
success forall a b. (a -> b) -> a -> b
$ NoteNumber -> Pitch
PSignal.nn_pitch (forall a. Real a => a -> NoteNumber
Pitch.nn Double
nn)
    Val
val -> case Val -> Maybe (Either (Deriver PSignal) PSignal)
val_to_pitch_signal Val
val of
        Maybe (Either (Deriver PSignal) PSignal)
Nothing -> forall a. Checked a
failure
        Just (Left Deriver PSignal
dsig) -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
pos ->
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. Pretty a => a -> Maybe a -> Deriver a
require RealTime
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PSignal -> PitchFunction
`PSignal.at` RealTime
pos) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver PSignal
dsig
        Just (Right PSignal
sig) -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
pos ->
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {a}. Pretty a => a -> Maybe a -> Deriver a
require RealTime
pos (PSignal -> PitchFunction
PSignal.at PSignal
sig RealTime
pos)
        where
        require :: a -> Maybe a -> Deriver a
require a
pos = forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require forall a b. (a -> b) -> a -> b
$
            Text
"no pitch at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
pos forall a. Semigroup a => a -> a -> a
<> Text
" for " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val

coerce_to_pitch_signal :: Val -> Checked PSignal.PSignal
coerce_to_pitch_signal :: Val -> Checked PSignal
coerce_to_pitch_signal Val
val = case Val -> Maybe (Either (Deriver PSignal) PSignal)
val_to_pitch_signal Val
val of
    Maybe (Either (Deriver PSignal) PSignal)
Nothing -> forall a. Checked a
failure
    Just (Left Deriver PSignal
dsig) -> forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval forall a b. (a -> b) -> a -> b
$ \RealTime
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver PSignal
dsig
    Just (Right PSignal
sig) -> forall a. a -> Checked a
success PSignal
sig

-- | This is the pitch version of 'resolve_control_ref', except simpler
-- because there's no pitch equivalent of CFunction.
resolve_pitch_ref :: DeriveT.PControlRef -> Derive.Deriver PSignal.PSignal
resolve_pitch_ref :: PControlRef -> Deriver PSignal
resolve_pitch_ref (DeriveT.Ref PControl
control Maybe PSignal
deflt) =
    forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require
        (Text
"named pitch not found and no default: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Text
ShowVal.show_val PControl
control)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe PSignal
deflt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PControl -> Deriver (Maybe PSignal)
lookup_pitch_signal PControl
control

-- | This should be in Deriver.Lib, but has to be here so the instance
-- Typecheck PitchFunction can be declared here and avoid circular import.
lookup_pitch_signal :: ScoreT.PControl -> Derive.Deriver (Maybe PSignal.PSignal)
lookup_pitch_signal :: PControl -> Deriver (Maybe PSignal)
lookup_pitch_signal PControl
pcontrol
    | PControl
pcontrol forall a. Eq a => a -> a -> Bool
== PControl
ScoreT.default_pitch =
        forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> PSignal
Derive.state_pitch
    | Bool
otherwise =
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Val -> Deriver PSignal
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Environ -> Maybe Val
DeriveT.lookup (PControl -> Text
ScoreT.pcontrol_name PControl
pcontrol)
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Deriver Environ
Internal.get_environ
    where
    -- This is recursive, because if a PControl resolves to a VPControlRef
    -- it will trigger another lookup.  If the refs point to each other then
    -- we will loop, so don't do that!  This also re-implements Env.checked_val
    -- to avoid circular import.
    get :: Val -> Deriver PSignal
get Val
val = case Val -> Maybe (Either (Deriver PSignal) PSignal)
val_to_pitch_signal Val
val of
        Maybe (Either (Deriver PSignal) PSignal)
Nothing -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$
            forall a. Pretty a => a -> Text
pretty PControl
pcontrol forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
val)
                forall a. Semigroup a => a -> a -> a
<> Text
" can't be coerced to pitch signal"
        Just (Left Deriver PSignal
df) -> Deriver PSignal
df
        Just (Right PSignal
f) -> forall (m :: * -> *) a. Monad m => a -> m a
return PSignal
f

val_to_pitch_signal :: Val
    -> Maybe (Either (Derive.Deriver PSignal.PSignal) PSignal.PSignal)
val_to_pitch_signal :: Val -> Maybe (Either (Deriver PSignal) PSignal)
val_to_pitch_signal = \case
    VPControlRef PControlRef
ref -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PControlRef -> Deriver PSignal
resolve_pitch_ref PControlRef
ref
    VPitch Pitch
pitch -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Pitch -> PSignal
PSignal.constant Pitch
pitch
    VPSignal PSignal
sig -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right PSignal
sig
    Val
val -> case Val -> Maybe (Typed Double)
DeriveT.constant_val Val
val of
        Just (ScoreT.Typed Type
ScoreT.Nn Double
nn) ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Pitch -> PSignal
PSignal.constant forall a b. (a -> b) -> a -> b
$ NoteNumber -> Pitch
PSignal.nn_pitch (forall a. Real a => a -> NoteNumber
Pitch.nn Double
nn)
        Maybe (Typed Double)
_ -> forall a. Maybe a
Nothing

-- * sub tracks

instance Typecheck SubT.Track where
    from_val :: Val -> Checked Track
from_val Val
_ = forall a. Checked a
failure
    to_type :: Proxy Track -> Type
to_type Proxy Track
_ = Text -> Type
ValType.TDeriver Text
"note"
    from_subtrack :: Track -> Maybe Track
from_subtrack = forall a. a -> Maybe a
Just