-- 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 DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ConstraintKinds #-}
module Derive.Typecheck (
    -- * signal functions
    TypedFunction, Function

    -- * 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(..)

    -- ** numeric types
    , num_to_scalar

    -- * util
    , TimeType(..), time_type
    , TransposeType(..), transpose_type, to_transpose, transpose_control

    -- ** to_typed_function
    , to_typed_function
    , to_function
    , convert_to_function
    , to_signal_or_function
    , pitch_at
) 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.Seq as Seq
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


-- * signal functions

type TypedFunction = RealTime -> ScoreT.Typed Signal.Y
type Function = RealTime -> Signal.Y

-- * 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
(DefaultReal -> DefaultReal -> Bool)
-> (DefaultReal -> DefaultReal -> Bool) -> Eq DefaultReal
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
(Int -> DefaultReal -> ShowS)
-> (DefaultReal -> String)
-> ([DefaultReal] -> ShowS)
-> Show DefaultReal
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
(DefaultReal -> Text) -> ShowVal DefaultReal
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 = Duration -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Internal.real (Duration -> Deriver RealTime)
-> (DefaultReal -> Duration) -> DefaultReal -> Deriver RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultReal -> Duration
_real
    score :: DefaultReal -> Deriver ScoreTime
score = Duration -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Internal.score (Duration -> Deriver ScoreTime)
-> (DefaultReal -> Duration) -> DefaultReal -> Deriver ScoreTime
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
(DefaultScore -> DefaultScore -> Bool)
-> (DefaultScore -> DefaultScore -> Bool) -> Eq DefaultScore
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
(Int -> DefaultScore -> ShowS)
-> (DefaultScore -> String)
-> ([DefaultScore] -> ShowS)
-> Show DefaultScore
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
(DefaultScore -> Text) -> ShowVal DefaultScore
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 = Duration -> Deriver RealTime
forall a. Time a => a -> Deriver RealTime
Internal.real (Duration -> Deriver RealTime)
-> (DefaultScore -> Duration) -> DefaultScore -> Deriver RealTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultScore -> Duration
_score
    score :: DefaultScore -> Deriver ScoreTime
score = Duration -> Deriver ScoreTime
forall a. Time a => a -> Deriver ScoreTime
Internal.score (Duration -> Deriver ScoreTime)
-> (DefaultScore -> Duration) -> DefaultScore -> Deriver ScoreTime
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 (Duration -> DefaultReal)
-> (RealTime -> Duration) -> RealTime -> 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 (Duration -> DefaultScore)
-> (ScoreTime -> Duration) -> ScoreTime -> 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
[Positive a] -> ShowS
Positive a -> String
(Int -> Positive a -> ShowS)
-> (Positive a -> String)
-> ([Positive a] -> ShowS)
-> Show (Positive a)
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
(Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool) -> Eq (Positive a)
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
(Positive a -> Text) -> ShowVal (Positive a)
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
(Positive a -> Positive a -> Positive a)
-> (Positive a -> Positive a -> Positive a)
-> (Positive a -> Positive a -> Positive a)
-> (Positive a -> Positive a)
-> (Positive a -> Positive a)
-> (Positive a -> Positive a)
-> (Integer -> Positive a)
-> Num (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, Num (Positive a)
Num (Positive a)
-> (Positive a -> Positive a -> Positive a)
-> (Positive a -> Positive a)
-> (Rational -> Positive a)
-> Fractional (Positive a)
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
[NonNegative a] -> ShowS
NonNegative a -> String
(Int -> NonNegative a -> ShowS)
-> (NonNegative a -> String)
-> ([NonNegative a] -> ShowS)
-> Show (NonNegative a)
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
(NonNegative a -> NonNegative a -> Bool)
-> (NonNegative a -> NonNegative a -> Bool) -> Eq (NonNegative a)
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
(NonNegative a -> Text) -> ShowVal (NonNegative a)
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
(NonNegative a -> NonNegative a -> NonNegative a)
-> (NonNegative a -> NonNegative a -> NonNegative a)
-> (NonNegative a -> NonNegative a -> NonNegative a)
-> (NonNegative a -> NonNegative a)
-> (NonNegative a -> NonNegative a)
-> (NonNegative a -> NonNegative a)
-> (Integer -> NonNegative a)
-> Num (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, Num (NonNegative a)
Num (NonNegative a)
-> (NonNegative a -> NonNegative a -> NonNegative a)
-> (NonNegative a -> NonNegative a)
-> (Rational -> NonNegative a)
-> Fractional (NonNegative a)
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
(Int -> Normalized -> ShowS)
-> (Normalized -> String)
-> ([Normalized] -> ShowS)
-> Show Normalized
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
(Normalized -> Normalized -> Bool)
-> (Normalized -> Normalized -> Bool) -> Eq Normalized
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
(Normalized -> Text) -> ShowVal Normalized
forall a. (a -> Text) -> ShowVal a
show_val :: Normalized -> Text
$cshow_val :: Normalized -> Text
ShowVal.ShowVal, [Normalized] -> Doc
Normalized -> Text
Normalized -> Doc
(Normalized -> Text)
-> (Normalized -> Doc)
-> ([Normalized] -> Doc)
-> Pretty Normalized
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
(Int -> NormalizedBipolar -> ShowS)
-> (NormalizedBipolar -> String)
-> ([NormalizedBipolar] -> ShowS)
-> Show NormalizedBipolar
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
(NormalizedBipolar -> NormalizedBipolar -> Bool)
-> (NormalizedBipolar -> NormalizedBipolar -> Bool)
-> Eq NormalizedBipolar
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
(NormalizedBipolar -> Text) -> ShowVal NormalizedBipolar
forall a. (a -> Text) -> ShowVal a
show_val :: NormalizedBipolar -> Text
$cshow_val :: NormalizedBipolar -> Text
ShowVal.ShowVal, [NormalizedBipolar] -> Doc
NormalizedBipolar -> Text
NormalizedBipolar -> Doc
(NormalizedBipolar -> Text)
-> (NormalizedBipolar -> Doc)
-> ([NormalizedBipolar] -> Doc)
-> Pretty NormalizedBipolar
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
(Int -> DefaultDiatonic -> ShowS)
-> (DefaultDiatonic -> String)
-> ([DefaultDiatonic] -> ShowS)
-> Show DefaultDiatonic
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
(DefaultDiatonic -> DefaultDiatonic -> Bool)
-> (DefaultDiatonic -> DefaultDiatonic -> Bool)
-> Eq DefaultDiatonic
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
(DefaultDiatonic -> Text) -> ShowVal DefaultDiatonic
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 (Transpose -> DefaultDiatonic)
-> (Double -> Transpose) -> Double -> 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 -> DeriveT.Val
    -> Derive.Deriver a
typecheck :: forall a. Typecheck a => Text -> ScoreTime -> Val -> Deriver a
typecheck Text
msg ScoreTime
pos Val
val = ScoreTime -> Val -> Deriver (Maybe a)
forall a. Typecheck a => ScoreTime -> Val -> Deriver (Maybe a)
from_val_eval ScoreTime
pos Val
val Deriver (Maybe a)
-> (Maybe a -> Deriver State Error a) -> Deriver State Error a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just a
a -> a -> Deriver State Error a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    Maybe a
Nothing -> Text -> Deriver State Error a
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text -> Deriver State Error a) -> Text -> Deriver State Error a
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> Text -> Text
forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
": " Text
msg (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a -> Val -> Text
forall a. Typecheck a => Proxy a -> Val -> Text
type_error_msg (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: 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 => DeriveT.Val -> Either Text a
typecheck_simple :: forall a. Typecheck a => Val -> Either Text a
typecheck_simple Val
val =
    Text -> Maybe a -> Either Text a
forall err a. err -> Maybe a -> Either err a
justErr (Proxy a -> Val -> Text
forall a. Typecheck a => Proxy a -> Val -> Text
type_error_msg (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Val
val) (Val -> Maybe a
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 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty (Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
to_type Proxy a
expected)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.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 -> b) -> Checked a -> Checked b)
-> (forall a b. a -> Checked b -> Checked a) -> Functor Checked
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 -> b) -> Result a -> Result b)
-> (forall a b. a -> Result b -> Result a) -> Functor Result
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 = Result a -> Checked a
forall a. Result a -> Checked a
Val (Result a -> Checked a) -> (a -> Result a) -> a -> Checked a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result a
forall a. a -> Result a
Success

failure :: Checked a
failure :: forall a. Checked a
failure = Result a -> Checked a
forall a. Result a -> Checked a
Val Result a
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) = Result b -> Checked b
forall a. Result a -> Checked a
Val (Result b -> Checked b) -> Result b -> Checked b
forall a b. (a -> b) -> a -> b
$ case Result a
a of
    Success a
a -> Result b -> (b -> Result b) -> Maybe b -> Result b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Result b
forall a. Result a
Failure b -> Result b
forall a. a -> Result a
Success (Maybe b -> Result b) -> Maybe b -> Result b
forall a b. (a -> b) -> a -> b
$ a -> Maybe b
f a
a
    Result a
Failure -> Result b
forall a. Result a
Failure
    Derive {} -> Result b
forall a. Result a
Failure -- can't really check one of these
check a -> Maybe b
f (Eval RealTime -> Deriver (Maybe a)
fa) = (RealTime -> Deriver (Maybe b)) -> Checked b
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval (\RealTime
t -> (a -> Maybe b
f =<<) (Maybe a -> Maybe b) -> Deriver (Maybe a) -> Deriver (Maybe b)
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 = Map Text a -> Val -> Checked a
forall a. Map Text a -> Val -> Checked a
from_val_symbol Map Text a
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 = [a] -> Type
forall a. ShowVal a => [a] -> Type
to_type_symbol [a
forall a. Bounded a => a
minBound :: a .. a
forall a. Bounded a => a
maxBound]

    from_subtrack :: SubT.Track -> Maybe a
    from_subtrack = Maybe a -> Track -> Maybe a
forall a b. a -> b -> a
const Maybe a
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 Val -> Checked a
forall a. Typecheck a => Val -> Checked a
from_val Val
val of
    Val (Success a
a) -> Maybe a -> Deriver (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Deriver (Maybe a)) -> Maybe a -> Deriver (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
    Val Result a
Failure -> Maybe a -> Deriver (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    -- This is a deriver, which needs a Derive.Context.
    Val (Derive Context Tagged -> a
_) -> Maybe a -> Deriver (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Eval RealTime -> Deriver (Maybe a)
deriver -> RealTime -> Deriver (Maybe a)
deriver (RealTime -> Deriver (Maybe a))
-> Deriver RealTime -> Deriver (Maybe a)
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 Val -> Checked a
forall a. Typecheck a => Val -> Checked a
from_val Val
val of
    Val (Success a
a) -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
    Checked a
_ -> Maybe 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 = (RealTime -> Deriver (Maybe b)) -> Checked b
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval ((RealTime -> Deriver (Maybe b)) -> Checked b)
-> (RealTime -> Deriver (Maybe b)) -> Checked b
forall a b. (a -> b) -> a -> b
$ \RealTime
_ -> case Val -> Maybe a
forall a. Typecheck a => Val -> Maybe a
from_val_simple Val
val of
    Maybe a
Nothing -> Maybe b -> Deriver (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
    Just a
x -> b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> Deriver b -> Deriver (Maybe b)
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 (Str -> Val) -> (a -> Str) -> a -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str (Text -> Str) -> (a -> Text) -> a -> Str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
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 (Maybe [Text] -> Type) -> ([a] -> Maybe [Text]) -> [a] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text]) -> ([a] -> [Text]) -> [a] -> Maybe [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
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) -> Result a -> Checked a
forall a. Result a -> Checked a
Val (Result a -> Checked a) -> Result a -> Checked a
forall a b. (a -> b) -> a -> b
$ Result a -> (a -> Result a) -> Maybe a -> Result a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Result a
forall a. Result a
Failure a -> Result a
forall a. a -> Result a
Success (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ Text -> Map Text a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
str Map Text a
syms
    Val
_ -> Checked a
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 = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, a)] -> Map Text a) -> [(Text, a)] -> Map Text a
forall a b. (a -> b) -> a -> b
$ (a -> Text) -> [a] -> [(Text, a)]
forall a k. (a -> k) -> [a] -> [(k, a)]
Seq.key_on a -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val [a]
vals
    where vals :: [a]
vals = [a
forall a. Bounded a => a
minBound :: a .. a
forall a. Bounded a => a
maxBound]

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.TNum (Proxy a -> NumType
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

-- * Typecheck instances

instance ToVal Val where to_val :: Val -> Val
to_val = Val -> Val
forall a. a -> a
id
instance Typecheck Val where
    from_val :: Val -> Checked Val
from_val = Val -> Checked 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 = Maybe a -> Checked (Maybe a)
forall a. a -> Checked a
success Maybe a
forall a. Maybe a
Nothing
    from_val Val
a = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Checked a -> Checked (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Checked a
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 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToVal a => ToVal (Maybe a) where
    to_val :: Maybe a -> Val
to_val = Val -> (a -> Val) -> Maybe a -> Val
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Val
VNotGiven a -> Val
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) = [Val] -> Checked [a]
forall {a}. Typecheck a => [Val] -> Checked [a]
check [Val]
xs
        where
        check :: [Val] -> Checked [a]
check [] = [a] -> Checked [a]
forall a. a -> Checked a
success []
        check (Val
x:[Val]
xs) = case Val -> Checked a
forall a. Typecheck a => Val -> Checked a
from_val Val
x of
            Val Result a
Failure -> Result [a] -> Checked [a]
forall a. Result a -> Checked a
Val Result [a]
forall a. Result a
Failure
            Val (Success a
a) -> (a
a:) ([a] -> [a]) -> Checked [a] -> Checked [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) -> Result [a] -> Checked [a]
forall a. Result a -> Checked a
Val (Result [a] -> Checked [a]) -> Result [a] -> Checked [a]
forall a b. (a -> b) -> a -> b
$ (Context Tagged -> [a]) -> Result [a]
forall a. (Context Tagged -> a) -> Result a
Derive ((Context Tagged -> [a]) -> Result [a])
-> (Context Tagged -> [a]) -> Result [a]
forall a b. (a -> b) -> a -> b
$ \Context Tagged
ctx ->
                    Context Tagged -> a
deriver Context Tagged
ctx a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Context Tagged -> [a]
rest Context Tagged
ctx
                Checked [a]
_ -> Result [a] -> Checked [a]
forall a. Result a -> Checked a
Val Result [a]
forall a. Result a
Failure
            Eval RealTime -> Deriver (Maybe a)
a -> case [Val] -> Checked [a]
check [Val]
xs of
                Val Result [a]
Failure -> Result [a] -> Checked [a]
forall a. Result a -> Checked a
Val Result [a]
forall a. Result a
Failure
                Val (Derive {}) -> Result [a] -> Checked [a]
forall a. Result a -> Checked a
Val Result [a]
forall a. Result a
Failure
                Val (Success [a]
as) -> (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as) (a -> [a]) -> Checked a -> Checked [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval RealTime -> Deriver (Maybe a)
a
                Eval RealTime -> Deriver (Maybe [a])
as -> (RealTime -> Deriver (Maybe [a])) -> Checked [a]
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval ((RealTime -> Deriver (Maybe [a])) -> Checked [a])
-> (RealTime -> Deriver (Maybe [a])) -> Checked [a]
forall a b. (a -> b) -> a -> b
$ \RealTime
p -> Maybe a -> Maybe [a] -> Maybe [a]
forall {f :: * -> *} {a}. Applicative f => f a -> f [a] -> f [a]
cons (Maybe a -> Maybe [a] -> Maybe [a])
-> Deriver (Maybe a)
-> Deriver State Error (Maybe [a] -> Maybe [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> Deriver (Maybe a)
a RealTime
p Deriver State Error (Maybe [a] -> Maybe [a])
-> Deriver (Maybe [a]) -> Deriver (Maybe [a])
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 = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [a]
as
    from_val Val
v = (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) (a -> [a]) -> Checked a -> Checked [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Checked a
forall a. Typecheck a => Val -> Checked a
from_val Val
v
    to_type :: Proxy [a] -> Type
to_type Proxy [a]
_ = Type -> Type
ValType.TList (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
instance ToVal a => ToVal [a] where to_val :: [a] -> Val
to_val = [Val] -> Val
VList ([Val] -> Val) -> ([a] -> [Val]) -> [a] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Val) -> [a] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map a -> Val
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 = ([a] -> Set a) -> Checked [a] -> Checked (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList (Checked [a] -> Checked (Set a))
-> (Val -> Checked [a]) -> Val -> Checked (Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Checked [a]
forall a. Typecheck a => Val -> Checked a
from_val
    to_type :: Proxy (Set a) -> Type
to_type Proxy (Set a)
_ = Type -> Type
ValType.TList (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
to_type (Proxy a
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 ([Val] -> Val) -> (Set a -> [Val]) -> Set a -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Val) -> [a] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map a -> Val
forall a. ToVal a => a -> Val
to_val ([a] -> [Val]) -> (Set a -> [a]) -> Set a -> [Val]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList

instance Typecheck a => Typecheck (NonEmpty a) where
    from_val :: Val -> Checked (NonEmpty a)
from_val Val
val = ([a] -> Maybe (NonEmpty a)) -> Checked [a] -> Checked (NonEmpty a)
forall a b. (a -> Maybe b) -> Checked a -> Checked b
check [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty (Val -> Checked [a]
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 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
to_type (Proxy a
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 Val -> Checked a
forall a. Typecheck a => Val -> Checked a
from_val Val
a of
        Val Result a
Failure -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Checked b -> Checked (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Checked b
forall a. Typecheck a => Val -> Checked a
from_val Val
a
        Checked a
a -> a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Checked a -> Checked (Either a b)
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 (Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
to_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
        (Proxy b -> Type
forall a. Typecheck a => Proxy a -> Type
to_type (Proxy b
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 = (a -> Val) -> (b -> Val) -> Either a b -> Val
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Val
forall a. ToVal a => a -> Val
to_val b -> Val
forall a. ToVal a => a -> Val
to_val


-- ** numeric types

-- | Coerce any numeric value to a ScoreT.Typed Signal.Y, and check it against
-- the given function.
num_to_scalar :: (ScoreT.Typed Signal.Y -> Maybe a) -> Val -> Checked a
num_to_scalar :: forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar Typed Double -> Maybe a
check Val
val = case Val
val of
    VNum Typed Double
a -> Result a -> Checked a
forall a. Result a -> Checked a
Val (Result a -> Checked a) -> Result a -> Checked a
forall a b. (a -> b) -> a -> b
$ Result a -> (a -> Result a) -> Maybe a -> Result a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Result a
forall a. Result a
Failure a -> Result a
forall a. a -> Result a
Success (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ Typed Double -> Maybe a
check Typed Double
a
    VControlRef ControlRef
cref -> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval ((RealTime -> Deriver (Maybe a)) -> Checked a)
-> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a b. (a -> b) -> a -> b
$ \RealTime
p -> Typed Double -> Maybe a
check (Typed Double -> Maybe a)
-> (TypedFunction -> Typed Double) -> TypedFunction -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypedFunction -> TypedFunction
forall a b. (a -> b) -> a -> b
$RealTime
p) (TypedFunction -> Maybe a)
-> Deriver State Error TypedFunction -> Deriver (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlRef -> Deriver State Error TypedFunction
to_typed_function ControlRef
cref
    VControlFunction ControlFunction
cf -> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval ((RealTime -> Deriver (Maybe a)) -> Checked a)
-> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a b. (a -> b) -> a -> b
$ \RealTime
p -> Typed Double -> Maybe a
check (Typed Double -> Maybe a)
-> (TypedFunction -> Typed Double) -> TypedFunction -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypedFunction -> TypedFunction
forall a b. (a -> b) -> a -> b
$RealTime
p) (TypedFunction -> Maybe a)
-> Deriver State Error TypedFunction -> Deriver (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlFunction -> Deriver State Error TypedFunction
control_function ControlFunction
cf
    Val
_ -> Checked a
forall a. Checked a
failure

-- | Coerce any numeric value to a function, and check it against the given
-- function.
num_to_function :: (TypedFunction -> Maybe a) -> Val -> Checked a
num_to_function :: forall a. (TypedFunction -> Maybe a) -> Val -> Checked a
num_to_function TypedFunction -> Maybe a
check Val
val = case Val
val of
    VNum Typed Double
a -> Result a -> Checked a
forall a. Result a -> Checked a
Val (Result a -> Checked a) -> Result a -> Checked a
forall a b. (a -> b) -> a -> b
$ Result a -> (a -> Result a) -> Maybe a -> Result a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Result a
forall a. Result a
Failure a -> Result a
forall a. a -> Result a
Success (Maybe a -> Result a) -> Maybe a -> Result a
forall a b. (a -> b) -> a -> b
$ TypedFunction -> Maybe a
check (TypedFunction -> Maybe a) -> TypedFunction -> Maybe a
forall a b. (a -> b) -> a -> b
$ Typed Double -> TypedFunction
forall a b. a -> b -> a
const Typed Double
a
    VControlRef ControlRef
cref -> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval ((RealTime -> Deriver (Maybe a)) -> Checked a)
-> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a b. (a -> b) -> a -> b
$ Deriver (Maybe a) -> RealTime -> Deriver (Maybe a)
forall a b. a -> b -> a
const (Deriver (Maybe a) -> RealTime -> Deriver (Maybe a))
-> Deriver (Maybe a) -> RealTime -> Deriver (Maybe a)
forall a b. (a -> b) -> a -> b
$ TypedFunction -> Maybe a
check (TypedFunction -> Maybe a)
-> Deriver State Error TypedFunction -> Deriver (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlRef -> Deriver State Error TypedFunction
to_typed_function ControlRef
cref
    VControlFunction ControlFunction
cf -> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval ((RealTime -> Deriver (Maybe a)) -> Checked a)
-> (RealTime -> Deriver (Maybe a)) -> Checked a
forall a b. (a -> b) -> a -> b
$ Deriver (Maybe a) -> RealTime -> Deriver (Maybe a)
forall a b. a -> b -> a
const (Deriver (Maybe a) -> RealTime -> Deriver (Maybe a))
-> Deriver (Maybe a) -> RealTime -> Deriver (Maybe a)
forall a b. (a -> b) -> a -> b
$ TypedFunction -> Maybe a
check (TypedFunction -> Maybe a)
-> Deriver State Error TypedFunction -> Deriver (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ControlFunction -> Deriver State Error TypedFunction
control_function ControlFunction
cf
    Val
_ -> Checked a
forall a. Checked a
failure

-- | Like 'num_to_function', but take a constructor with a type argument,
-- and a separate function to verify the type.
num_to_checked_function :: (Function -> typ -> b)
    -> (ScoreT.Type -> Maybe typ) -> Val -> Checked b
num_to_checked_function :: forall typ b.
(Function -> typ -> b) -> (Type -> Maybe typ) -> Val -> Checked b
num_to_checked_function Function -> typ -> b
make Type -> Maybe typ
check_type = (TypedFunction -> Maybe b) -> Val -> Checked b
forall a. (TypedFunction -> Maybe a) -> Val -> Checked a
num_to_function ((TypedFunction -> Maybe b) -> Val -> Checked b)
-> (TypedFunction -> Maybe b) -> Val -> Checked b
forall a b. (a -> b) -> a -> b
$ \TypedFunction
f ->
    Function -> typ -> b
make (Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val (Typed Double -> Double) -> TypedFunction -> Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedFunction
f) (typ -> b) -> Maybe typ -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe typ
check_type (Typed Double -> Type
forall a. Typed a -> Type
ScoreT.type_of (TypedFunction
f RealTime
0))

-- | Evaluate a control function with no backing control.
control_function :: DeriveT.ControlFunction -> Derive.Deriver TypedFunction
control_function :: ControlFunction -> Deriver State Error TypedFunction
control_function ControlFunction
cf = ControlFunction -> Control -> Dynamic -> TypedFunction
DeriveT.call_control_function ControlFunction
cf Control
Controls.null (Dynamic -> TypedFunction)
-> Deriver State Error Dynamic -> Deriver State Error TypedFunction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Deriver State Error Dynamic
Internal.get_control_function_dynamic

-- *** eval only

-- These don't have ToVal instances.

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

instance Typecheck Function where
    from_val :: Val -> Checked Function
from_val = (TypedFunction -> Maybe Function) -> Val -> Checked Function
forall a. (TypedFunction -> Maybe a) -> Val -> Checked a
num_to_function (Function -> Maybe Function
forall a. a -> Maybe a
Just (Function -> Maybe Function)
-> (TypedFunction -> Function) -> TypedFunction -> Maybe Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Typed Double -> Double) -> TypedFunction -> Function
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val)
    to_type :: Proxy Function -> Type
to_type Proxy Function
_ = Text -> Type
ValType.TOther Text
"untyped number or signal"

data DefaultRealTimeFunction = DefaultRealTimeFunction !Function !TimeType

instance Typecheck DefaultRealTimeFunction where
    from_val :: Val -> Checked DefaultRealTimeFunction
from_val = (Function -> TimeType -> DefaultRealTimeFunction)
-> (Type -> Maybe TimeType)
-> Val
-> Checked DefaultRealTimeFunction
forall typ b.
(Function -> typ -> b) -> (Type -> Maybe typ) -> Val -> Checked b
num_to_checked_function Function -> TimeType -> DefaultRealTimeFunction
DefaultRealTimeFunction (TimeType -> Type -> Maybe TimeType
time_type TimeType
Real)
    to_type :: Proxy DefaultRealTimeFunction -> Type
to_type Proxy DefaultRealTimeFunction
_ = Text -> Type
ValType.TOther Text
"time number or signal"

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

data TransposeFunctionDiatonic =
    TransposeFunctionDiatonic !Function !ScoreT.Control
instance Typecheck TransposeFunctionDiatonic where
    from_val :: Val -> Checked TransposeFunctionDiatonic
from_val = (Function -> Control -> TransposeFunctionDiatonic)
-> (Type -> Maybe Control)
-> Val
-> Checked TransposeFunctionDiatonic
forall typ b.
(Function -> typ -> b) -> (Type -> Maybe typ) -> Val -> Checked b
num_to_checked_function Function -> Control -> TransposeFunctionDiatonic
TransposeFunctionDiatonic
        (TransposeType -> Type -> Maybe Control
type_to_control TransposeType
Diatonic)
    to_type :: Proxy TransposeFunctionDiatonic -> Type
to_type Proxy TransposeFunctionDiatonic
_ = Text -> Type
ValType.TOther Text
"transpose number or signal, default diatonic"

data TransposeFunctionChromatic =
    TransposeFunctionChromatic !Function !ScoreT.Control
instance Typecheck TransposeFunctionChromatic where
    from_val :: Val -> Checked TransposeFunctionChromatic
from_val = (Function -> Control -> TransposeFunctionChromatic)
-> (Type -> Maybe Control)
-> Val
-> Checked TransposeFunctionChromatic
forall typ b.
(Function -> typ -> b) -> (Type -> Maybe typ) -> Val -> Checked b
num_to_checked_function Function -> Control -> TransposeFunctionChromatic
TransposeFunctionChromatic
        (TransposeType -> Type -> Maybe Control
type_to_control TransposeType
Chromatic)
    to_type :: Proxy TransposeFunctionChromatic -> Type
to_type Proxy TransposeFunctionChromatic
_ = Text -> Type
ValType.TOther Text
"transpose number or signal, default chromatic"

data TransposeFunctionNn = TransposeFunctionNn !Function !ScoreT.Control
instance Typecheck TransposeFunctionNn where
    from_val :: Val -> Checked TransposeFunctionNn
from_val = (Function -> Control -> TransposeFunctionNn)
-> (Type -> Maybe Control) -> Val -> Checked TransposeFunctionNn
forall typ b.
(Function -> typ -> b) -> (Type -> Maybe typ) -> Val -> Checked b
num_to_checked_function Function -> Control -> TransposeFunctionNn
TransposeFunctionNn
        (TransposeType -> Type -> Maybe Control
type_to_control TransposeType
Nn)
    to_type :: Proxy TransposeFunctionNn -> Type
to_type Proxy TransposeFunctionNn
_ = Text -> Type
ValType.TOther Text
"transpose number or signal, default nn"

type_to_control :: TransposeType -> ScoreT.Type -> Maybe ScoreT.Control
type_to_control :: TransposeType -> Type -> Maybe Control
type_to_control TransposeType
deflt = (TransposeType -> Control) -> Maybe TransposeType -> Maybe Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TransposeType -> Control
transpose_control (Maybe TransposeType -> Maybe Control)
-> (Type -> Maybe TransposeType) -> Type -> Maybe Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransposeType -> Type -> Maybe TransposeType
transpose_type TransposeType
deflt

-- *** scalar

instance Typecheck (ScoreT.Typed Signal.Y) where
    from_val :: Val -> Checked (Typed Double)
from_val = (Typed Double -> Maybe (Typed Double))
-> Val -> Checked (Typed Double)
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar Typed Double -> Maybe (Typed Double)
forall a. a -> Maybe a
Just
    to_type :: Proxy (Typed Double) -> Type
to_type = Proxy (Typed Double) -> 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 = Typed Double -> Val
VNum
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 = (Typed Double -> Maybe Double) -> Val -> Checked Double
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double -> Maybe Double)
-> (Typed Double -> Double) -> Typed Double -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val)
    to_type :: Proxy Double -> Type
to_type = Proxy Double -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal Double where to_val :: Double -> Val
to_val = Typed Double -> Val
VNum (Typed Double -> Val) -> (Double -> Typed Double) -> Double -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Typed Double
forall a. a -> Typed a
ScoreT.untyped
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 = (Typed Double -> Maybe (Ratio Int)) -> Val -> Checked (Ratio Int)
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe (Ratio Int)) -> Val -> Checked (Ratio Int))
-> (Typed Double -> Maybe (Ratio Int))
-> Val
-> Checked (Ratio Int)
forall a b. (a -> b) -> a -> b
$
        Ratio Int -> Maybe (Ratio Int)
forall a. a -> Maybe a
Just (Ratio Int -> Maybe (Ratio Int))
-> (Typed Double -> Ratio Int) -> Typed Double -> Maybe (Ratio Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Ratio Int
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Rational -> Ratio Int)
-> (Typed Double -> Rational) -> Typed Double -> Ratio Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Rational) -> Double -> Double -> Rational
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Rational
forall a. RealFrac a => a -> a -> Rational
Ratio.approxRational Double
0.001 (Double -> Rational)
-> (Typed Double -> Double) -> Typed Double -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val
    to_type :: Proxy (Ratio Int) -> Type
to_type = Proxy (Ratio Int) -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal (Ratio.Ratio Int) where
    to_val :: Ratio Int -> Val
to_val = Typed Double -> Val
VNum (Typed Double -> Val)
-> (Ratio Int -> Typed Double) -> Ratio Int -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Typed Double
forall a. a -> Typed a
ScoreT.untyped (Double -> Typed Double)
-> (Ratio Int -> Double) -> Ratio Int -> Typed Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio Int -> Double
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 = Val -> Checked Int
forall a. Integral a => Val -> Checked a
from_integral_val
    to_type :: Proxy Int -> Type
to_type = Proxy Int -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type

instance Typecheck Integer where
    from_val :: Val -> Checked Integer
from_val = Val -> Checked Integer
forall a. Integral a => Val -> Checked a
from_integral_val
    to_type :: Proxy Integer -> Type
to_type = Proxy Integer -> 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 = (Typed Double -> Maybe a) -> Val -> Checked a
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar (Double -> Maybe a
forall {a} {a}. (RealFrac a, Integral a) => a -> Maybe a
check (Double -> Maybe a)
-> (Typed Double -> Double) -> Typed Double -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val)
    where
    check :: a -> Maybe a
check a
a = if a
frac a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then a -> Maybe a
forall a. a -> Maybe a
Just a
int else Maybe a
forall a. Maybe a
Nothing
        where (a
int, a
frac) = a -> (a, a)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction a
a

instance ToVal Int where to_val :: Int -> Val
to_val = Typed Double -> Val
VNum (Typed Double -> Val) -> (Int -> Typed Double) -> Int -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Typed Double
forall a. a -> Typed a
ScoreT.untyped (Double -> Typed Double) -> (Int -> Double) -> Int -> Typed Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
instance ToVal Integer where to_val :: Integer -> Val
to_val = Typed Double -> Val
VNum (Typed Double -> Val)
-> (Integer -> Typed Double) -> Integer -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Typed Double
forall a. a -> Typed a
ScoreT.untyped (Double -> Typed Double)
-> (Integer -> Double) -> Integer -> Typed Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
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

-- | VNums 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 = (Typed Double -> Maybe Transpose) -> Val -> Checked Transpose
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe Transpose) -> Val -> Checked Transpose)
-> (Typed Double -> Maybe Transpose) -> Val -> Checked Transpose
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) -> case Type
typ of
        Type
ScoreT.Untyped -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Chromatic Double
val)
        Type
ScoreT.Chromatic -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Chromatic Double
val)
        Type
ScoreT.Diatonic -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Diatonic Double
val)
        Type
ScoreT.Nn -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Nn Double
val)
        Type
_ -> Maybe Transpose
forall a. Maybe a
Nothing
    to_type :: Proxy Transpose -> Type
to_type = Proxy Transpose -> 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 (Pitch.Chromatic Double
a) = Typed Double -> Val
VNum (Typed Double -> Val) -> Typed Double -> Val
forall a b. (a -> b) -> a -> b
$ Type -> Double -> Typed Double
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Chromatic Double
a
    to_val (Pitch.Diatonic Double
a) = Typed Double -> Val
VNum (Typed Double -> Val) -> Typed Double -> Val
forall a b. (a -> b) -> a -> b
$ Type -> Double -> Typed Double
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Diatonic Double
a
    to_val (Pitch.Nn Double
a) = Typed Double -> Val
VNum (Typed Double -> Val) -> Typed Double -> Val
forall a b. (a -> b) -> a -> b
$ Type -> Double -> Typed Double
forall a. Type -> a -> Typed a
ScoreT.Typed 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 = (Typed Double -> Maybe DefaultDiatonic)
-> Val -> Checked DefaultDiatonic
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe DefaultDiatonic)
 -> Val -> Checked DefaultDiatonic)
-> (Typed Double -> Maybe DefaultDiatonic)
-> Val
-> Checked DefaultDiatonic
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Transpose -> DefaultDiatonic
DefaultDiatonic (Transpose -> DefaultDiatonic)
-> Maybe Transpose -> Maybe DefaultDiatonic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Diatonic Double
val)
            Type
ScoreT.Chromatic -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Chromatic Double
val)
            Type
ScoreT.Diatonic -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Diatonic Double
val)
            Type
ScoreT.Nn -> Transpose -> Maybe Transpose
forall a. a -> Maybe a
Just (Double -> Transpose
Pitch.Nn Double
val)
            Type
_ -> Maybe Transpose
forall a. Maybe a
Nothing
    to_type :: Proxy DefaultDiatonic -> Type
to_type = Proxy DefaultDiatonic -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal DefaultDiatonic where to_val :: DefaultDiatonic -> Val
to_val (DefaultDiatonic Transpose
a) = Transpose -> Val
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 = (Typed Double -> Maybe NoteNumber) -> Val -> Checked NoteNumber
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe NoteNumber) -> Val -> Checked NoteNumber)
-> (Typed Double -> Maybe NoteNumber) -> Val -> Checked NoteNumber
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Double -> NoteNumber) -> Maybe Double -> Maybe NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
val
            Type
ScoreT.Nn -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
val
            Type
_ -> Maybe Double
forall a. Maybe a
Nothing
    to_type :: Proxy NoteNumber -> Type
to_type = Proxy NoteNumber -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal Pitch.NoteNumber where
    to_val :: NoteNumber -> Val
to_val = Typed Double -> Val
VNum (Typed Double -> Val)
-> (NoteNumber -> Typed Double) -> NoteNumber -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Double -> Typed Double
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Nn (Double -> Typed Double)
-> (NoteNumber -> Double) -> NoteNumber -> Typed Double
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 = (Typed Double -> Maybe ScoreTime) -> Val -> Checked ScoreTime
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe ScoreTime) -> Val -> Checked ScoreTime)
-> (Typed Double -> Maybe ScoreTime) -> Val -> Checked ScoreTime
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Double -> ScoreTime
ScoreTime.from_double (Double -> ScoreTime) -> Maybe Double -> Maybe ScoreTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
val
            Type
ScoreT.Score -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
val
            Type
_ -> Maybe Double
forall a. Maybe a
Nothing
    to_type :: Proxy ScoreTime -> Type
to_type = Proxy ScoreTime -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal ScoreTime where
    to_val :: ScoreTime -> Val
to_val ScoreTime
a = Typed Double -> Val
VNum (Typed Double -> Val) -> Typed Double -> Val
forall a b. (a -> b) -> a -> b
$ Type -> Double -> Typed Double
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Score (ScoreTime -> Double
ScoreTime.to_double ScoreTime
a)
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 = (Typed Double -> Maybe RealTime) -> Val -> Checked RealTime
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe RealTime) -> Val -> Checked RealTime)
-> (Typed Double -> Maybe RealTime) -> Val -> Checked RealTime
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Double -> RealTime
RealTime.seconds (Double -> RealTime) -> Maybe Double -> Maybe RealTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
val
            Type
ScoreT.Real -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
val
            Type
_ -> Maybe Double
forall a. Maybe a
Nothing
    to_type :: Proxy RealTime -> Type
to_type = Proxy RealTime -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal RealTime where
    to_val :: RealTime -> Val
to_val RealTime
a = Typed Double -> Val
VNum (Typed Double -> Val) -> Typed Double -> Val
forall a b. (a -> b) -> a -> b
$ Type -> Double -> Typed Double
forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Real (Function
RealTime.to_seconds RealTime
a)
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 = (Typed Double -> Maybe Duration) -> Val -> Checked Duration
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe Duration) -> Val -> Checked Duration)
-> (Typed Double -> Maybe Duration) -> Val -> Checked Duration
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 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
        Type
ScoreT.Real -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
        Type
_ -> Maybe Duration
forall a. Maybe a
Nothing
    to_type :: Proxy Duration -> Type
to_type = Proxy Duration -> 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) = ScoreTime -> Val
forall a. ToVal a => a -> Val
to_val ScoreTime
a
    to_val (DeriveT.RealDuration RealTime
a) = RealTime -> Val
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 = (Typed Double -> Maybe DefaultReal) -> Val -> Checked DefaultReal
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe DefaultReal) -> Val -> Checked DefaultReal)
-> (Typed Double -> Maybe DefaultReal)
-> Val
-> Checked DefaultReal
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Duration -> DefaultReal
DefaultReal (Duration -> DefaultReal) -> Maybe Duration -> Maybe DefaultReal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped ->
                Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
            Type
ScoreT.Score ->
                Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
            Type
ScoreT.Real -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
            Type
_ -> Maybe Duration
forall a. Maybe a
Nothing
    to_type :: Proxy DefaultReal -> Type
to_type = Proxy DefaultReal -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type
instance ToVal DefaultReal where to_val :: DefaultReal -> Val
to_val (DefaultReal Duration
a) = Duration -> Val
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 = (Typed Double -> Maybe DefaultScore) -> Val -> Checked DefaultScore
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar ((Typed Double -> Maybe DefaultScore)
 -> Val -> Checked DefaultScore)
-> (Typed Double -> Maybe DefaultScore)
-> Val
-> Checked DefaultScore
forall a b. (a -> b) -> a -> b
$ \(ScoreT.Typed Type
typ Double
val) ->
        Duration -> DefaultScore
DefaultScore (Duration -> DefaultScore) -> Maybe Duration -> Maybe DefaultScore
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Type
typ of
            Type
ScoreT.Untyped ->
                Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
            Type
ScoreT.Score ->
                Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
DeriveT.ScoreDuration (Double -> ScoreTime
ScoreTime.from_double Double
val)
            Type
ScoreT.Real -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just (Duration -> Maybe Duration) -> Duration -> Maybe Duration
forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
DeriveT.RealDuration (Double -> RealTime
RealTime.seconds Double
val)
            Type
_ -> Maybe Duration
forall a. Maybe a
Nothing
    to_type :: Proxy DefaultScore -> Type
to_type = Proxy DefaultScore -> Type
forall a. TypecheckNum a => Proxy a -> Type
num_to_type

instance ToVal DefaultScore where to_val :: DefaultScore -> Val
to_val (DefaultScore Duration
a) = Duration -> Val
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@(VNum Typed Double
val)
        | Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val Typed Double
val Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 = a -> Positive a
forall a. a -> Positive a
Positive (a -> Positive a) -> Checked a -> Checked (Positive a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Checked a
forall a. Typecheck a => Val -> Checked a
from_val Val
v
        | Bool
otherwise = Checked (Positive a)
forall a. Checked a
failure
    from_val Val
_ = Checked (Positive a)
forall a. Checked a
failure
    to_type :: Proxy (Positive a) -> Type
to_type Proxy (Positive a)
_ = NumType -> NumValue -> Type
ValType.TNum (Proxy a -> NumType
forall a. TypecheckNum a => Proxy a -> NumType
num_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) NumValue
ValType.TPositive
instance ToVal a => ToVal (Positive a) where
    to_val :: Positive a -> Val
to_val (Positive a
val) = 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@(VNum Typed Double
val)
        | Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val Typed Double
val Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 = a -> NonNegative a
forall a. a -> NonNegative a
NonNegative (a -> NonNegative a) -> Checked a -> Checked (NonNegative a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> Checked a
forall a. Typecheck a => Val -> Checked a
from_val Val
v
        | Bool
otherwise = Checked (NonNegative a)
forall a. Checked a
failure
    from_val Val
_ = Checked (NonNegative a)
forall a. Checked a
failure
    to_type :: Proxy (NonNegative a) -> Type
to_type Proxy (NonNegative a)
_ = NumType -> NumValue -> Type
ValType.TNum (Proxy a -> NumType
forall a. TypecheckNum a => Proxy a -> NumType
num_type (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) NumValue
ValType.TNonNegative
instance ToVal a => ToVal (NonNegative a) where
    to_val :: NonNegative a -> Val
to_val (NonNegative a
val) = a -> Val
forall a. ToVal a => a -> Val
to_val a
val

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

instance Typecheck NormalizedBipolar where
    from_val :: Val -> Checked NormalizedBipolar
from_val = (Typed Double -> Maybe NormalizedBipolar)
-> Val -> Checked NormalizedBipolar
forall a. (Typed Double -> Maybe a) -> Val -> Checked a
num_to_scalar (Double -> Maybe NormalizedBipolar
check (Double -> Maybe NormalizedBipolar)
-> (Typed Double -> Double)
-> Typed Double
-> Maybe NormalizedBipolar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val)
        where
        check :: Double -> Maybe NormalizedBipolar
check Double
a
            | -Double
1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
a Bool -> Bool -> Bool
&& Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1 = NormalizedBipolar -> Maybe NormalizedBipolar
forall a. a -> Maybe a
Just (Double -> NormalizedBipolar
NormalizedBipolar Double
a)
            | Bool
otherwise = Maybe NormalizedBipolar
forall a. Maybe a
Nothing
    to_type :: Proxy NormalizedBipolar -> Type
to_type Proxy NormalizedBipolar
_ = NumType -> NumValue -> Type
ValType.TNum NumType
ValType.TUntyped NumValue
ValType.TNormalizedBipolar
instance ToVal NormalizedBipolar where
    to_val :: NormalizedBipolar -> Val
to_val = Typed Double -> Val
VNum (Typed Double -> Val)
-> (NormalizedBipolar -> Typed Double) -> NormalizedBipolar -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Typed Double
forall a. a -> Typed a
ScoreT.untyped (Double -> Typed Double)
-> (NormalizedBipolar -> Double)
-> NormalizedBipolar
-> Typed Double
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)) = Symbol -> Checked Symbol
forall a. a -> Checked a
success (Symbol -> Checked Symbol) -> Symbol -> Checked Symbol
forall a b. (a -> b) -> a -> b
$ Text -> Symbol
Expr.Symbol Text
sym
    from_val Val
_ = Checked Symbol
forall a. Checked a
failure
    to_type :: Proxy Symbol -> Type
to_type Proxy Symbol
_ = Maybe [Text] -> Type
ValType.TStr Maybe [Text]
forall a. Maybe a
Nothing
instance ToVal Expr.Symbol where to_val :: Symbol -> Val
to_val = Str -> Val
VStr (Str -> Val) -> (Symbol -> Str) -> Symbol -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Str
Expr.Str (Text -> Str) -> (Symbol -> Text) -> Symbol -> 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) = Str -> Checked Str
forall a. a -> Checked a
success Str
a
    from_val Val
_ = Checked Str
forall a. Checked a
failure
    to_type :: Proxy Str -> Type
to_type Proxy Str
_ = Maybe [Text] -> Type
ValType.TStr Maybe [Text]
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)) = Text -> Checked Text
forall a. a -> Checked a
success Text
s
    from_val Val
_ = Checked Text
forall a. Checked a
failure
    to_type :: Proxy Text -> Type
to_type Proxy Text
_ = Maybe [Text] -> Type
ValType.TStr Maybe [Text]
forall a. Maybe a
Nothing
instance ToVal Text where to_val :: Text -> Val
to_val = Str -> Val
VStr (Str -> Val) -> (Text -> Str) -> Text -> Val
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)) =
        Result Control -> Checked Control
forall a. Result a -> Checked a
Val (Result Control -> Checked Control)
-> Result Control -> Checked Control
forall a b. (a -> b) -> a -> b
$ (Text -> Result Control)
-> (Control -> Result Control)
-> Either Text Control
-> Result Control
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result Control -> Text -> Result Control
forall a b. a -> b -> a
const Result Control
forall a. Result a
Failure) Control -> Result Control
forall a. a -> Result a
Success (Text -> Either Text Control
ScoreT.control Text
s)
    from_val Val
_ = Checked Control
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)) =
        Result PControl -> Checked PControl
forall a. Result a -> Checked a
Val (Result PControl -> Checked PControl)
-> Result PControl -> Checked PControl
forall a b. (a -> b) -> a -> b
$ (Text -> Result PControl)
-> (PControl -> Result PControl)
-> Either Text PControl
-> Result PControl
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Result PControl -> Text -> Result PControl
forall a b. a -> b -> a
const Result PControl
forall a. Result a
Failure) PControl -> Result PControl
forall a. a -> Result a
Success (Text -> Either Text PControl
ScoreT.pcontrol Text
s)
    from_val Val
_ = Checked PControl
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) = Attributes -> Checked Attributes
forall a. a -> Checked a
success Attributes
a
    from_val Val
_ = Checked Attributes
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

-- | Use a 'TypedFunction' or 'Function' instead of this.
instance Typecheck DeriveT.ControlRef where
    from_val :: Val -> Checked ControlRef
from_val (VControlRef ControlRef
a) = ControlRef -> Checked ControlRef
forall a. a -> Checked a
success ControlRef
a
    from_val (VNum Typed Double
a) = ControlRef -> Checked ControlRef
forall a. a -> Checked a
success (ControlRef -> Checked ControlRef)
-> ControlRef -> Checked ControlRef
forall a b. (a -> b) -> a -> b
$ Typed Control -> ControlRef
forall control val. val -> Ref control val
DeriveT.ControlSignal (Typed Control -> ControlRef) -> Typed Control -> ControlRef
forall a b. (a -> b) -> a -> b
$
        Double -> Control
forall {k} (kind :: k). Double -> Signal kind
Signal.constant (Double -> Control) -> Typed Double -> Typed Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Double
a
    from_val Val
_ = Checked ControlRef
forall a. Checked a
failure
    to_type :: Proxy ControlRef -> Type
to_type Proxy ControlRef
_ = Type
ValType.TControlRef
instance ToVal DeriveT.ControlRef where to_val :: ControlRef -> Val
to_val = ControlRef -> Val
VControlRef

instance Typecheck DeriveT.PControlRef where
    from_val :: Val -> Checked PControlRef
from_val (VPControlRef PControlRef
a) = PControlRef -> Checked PControlRef
forall a. a -> Checked a
success PControlRef
a
    from_val (VPitch Pitch
a) = PControlRef -> Checked PControlRef
forall a. a -> Checked a
success (PControlRef -> Checked PControlRef)
-> PControlRef -> Checked PControlRef
forall a b. (a -> b) -> a -> b
$ PSignal -> PControlRef
forall control val. val -> Ref control val
DeriveT.ControlSignal (PSignal -> PControlRef) -> PSignal -> PControlRef
forall a b. (a -> b) -> a -> b
$
        Pitch -> PSignal
PSignal.constant Pitch
a
    from_val Val
_ = Checked PControlRef
forall a. Checked a
failure
    to_type :: Proxy PControlRef -> Type
to_type Proxy PControlRef
_ = Type
ValType.TPControlRef
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 (VPitch Pitch
a) = Pitch -> Checked Pitch
forall a. a -> Checked a
success Pitch
a
    from_val (VPControlRef PControlRef
pref) = (RealTime -> Deriver (Maybe Pitch)) -> Checked Pitch
forall a. (RealTime -> Deriver (Maybe a)) -> Checked a
Eval ((RealTime -> Deriver (Maybe Pitch)) -> Checked Pitch)
-> (RealTime -> Deriver (Maybe Pitch)) -> Checked Pitch
forall a b. (a -> b) -> a -> b
$ \RealTime
pos -> Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just (Pitch -> Maybe Pitch)
-> Deriver State Error Pitch -> Deriver (Maybe Pitch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> PControlRef -> Deriver State Error Pitch
pitch_at RealTime
pos PControlRef
pref
    from_val (VNum (ScoreT.Typed Type
ScoreT.Nn Double
nn)) =
        Pitch -> Checked Pitch
forall a. a -> Checked a
success (Pitch -> Checked Pitch) -> Pitch -> Checked Pitch
forall a b. (a -> b) -> a -> b
$ NoteNumber -> Pitch
PSignal.nn_pitch (Double -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Double
nn)
    from_val Val
_ = Checked Pitch
forall a. Checked a
failure
    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) = Pitch -> Checked Pitch
forall a. a -> Checked a
success Pitch
a
    from_val Val
_ = Checked Pitch
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)) = Instrument -> Checked Instrument
forall a. a -> Checked a
success (Text -> Instrument
ScoreT.Instrument Text
a)
    from_val Val
_ = Checked Instrument
forall a. Checked a
failure
    to_type :: Proxy Instrument -> Type
to_type Proxy Instrument
_ = Maybe [Text] -> Type
ValType.TStr Maybe [Text]
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.ControlFunction where
    from_val :: Val -> Checked ControlFunction
from_val (VControlFunction ControlFunction
a) = ControlFunction -> Checked ControlFunction
forall a. a -> Checked a
success ControlFunction
a
    from_val Val
_ = Checked ControlFunction
forall a. Checked a
failure
    to_type :: Proxy ControlFunction -> Type
to_type Proxy ControlFunction
_ = Type
ValType.TControlFunction
instance ToVal DeriveT.ControlFunction where to_val :: ControlFunction -> Val
to_val = ControlFunction -> Val
VControlFunction

-- | 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 -> Quoted -> Checked Quoted
forall a. a -> Checked a
success Quoted
a
        VPitch {} -> Checked Quoted
forall a. Checked a
failure
        VStr (Expr.Str Text
sym) -> Text -> Checked Quoted
to_quoted Text
sym
        Val
_ -> Text -> Checked Quoted
to_quoted (Text -> Checked Quoted) -> Text -> Checked Quoted
forall a b. (a -> b) -> a -> b
$ Val -> Text
forall a. ShowVal a => a -> Text
ShowVal.show_val Val
val
        where
        to_quoted :: Text -> Checked Quoted
to_quoted Text
sym = Quoted -> Checked Quoted
forall a. a -> Checked a
success (Quoted -> Checked Quoted) -> Quoted -> Checked Quoted
forall a b. (a -> b) -> a -> b
$
            Expr -> Quoted
DeriveT.Quoted (Expr -> Quoted) -> Expr -> Quoted
forall a b. (a -> b) -> a -> b
$ Symbol -> [Term Val] -> Call Val
forall val. Symbol -> [Term val] -> Call val
Expr.Call (Text -> Symbol
Expr.Symbol Text
sym) [] Call Val -> [Call Val] -> Expr
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
(Int -> NotGiven -> ShowS)
-> (NotGiven -> String) -> ([NotGiven] -> ShowS) -> Show NotGiven
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
(NotGiven -> NotGiven -> Bool)
-> (NotGiven -> NotGiven -> Bool) -> Eq NotGiven
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 = NotGiven -> Checked NotGiven
forall a. a -> Checked a
success NotGiven
NotGiven
    from_val Val
_ = Checked NotGiven
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?

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

instance Pretty TimeType where pretty :: TimeType -> Text
pretty = TimeType -> Text
forall a. Show a => a -> Text
showt

time_type :: TimeType -> ScoreT.Type -> Maybe TimeType
time_type :: TimeType -> Type -> Maybe TimeType
time_type TimeType
deflt Type
typ = case Type
typ of
    Type
ScoreT.Untyped -> TimeType -> Maybe TimeType
forall a. a -> Maybe a
Just TimeType
deflt
    Type
ScoreT.Real -> TimeType -> Maybe TimeType
forall a. a -> Maybe a
Just TimeType
Real
    Type
ScoreT.Score -> TimeType -> Maybe TimeType
forall a. a -> Maybe a
Just TimeType
Score
    Type
_ -> Maybe TimeType
forall a. Maybe a
Nothing

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

instance Pretty TransposeType where pretty :: TransposeType -> Text
pretty = TransposeType -> Text
forall a. Show a => a -> Text
showt

transpose_type :: TransposeType -> ScoreT.Type -> Maybe TransposeType
transpose_type :: TransposeType -> Type -> Maybe TransposeType
transpose_type TransposeType
deflt Type
typ = case Type
typ of
    Type
ScoreT.Untyped -> TransposeType -> Maybe TransposeType
forall a. a -> Maybe a
Just TransposeType
deflt
    Type
ScoreT.Diatonic -> TransposeType -> Maybe TransposeType
forall a. a -> Maybe a
Just TransposeType
Diatonic
    Type
ScoreT.Chromatic -> TransposeType -> Maybe TransposeType
forall a. a -> Maybe a
Just TransposeType
Chromatic
    Type
ScoreT.Nn -> TransposeType -> Maybe TransposeType
forall a. a -> Maybe a
Just TransposeType
Nn
    Type
_ -> Maybe TransposeType
forall a. Maybe a
Nothing

to_transpose :: TransposeType -> Double -> Pitch.Transpose
to_transpose :: TransposeType -> Double -> Transpose
to_transpose TransposeType
typ Double
val = case TransposeType
typ of
    TransposeType
Diatonic -> Double -> Transpose
Pitch.Diatonic Double
val
    TransposeType
Chromatic -> Double -> Transpose
Pitch.Chromatic Double
val
    TransposeType
Nn -> Double -> Transpose
Pitch.Nn Double
val

transpose_control :: TransposeType -> ScoreT.Control
transpose_control :: TransposeType -> Control
transpose_control TransposeType
Diatonic = Control
Controls.diatonic
transpose_control TransposeType
Chromatic = Control
Controls.chromatic
transpose_control TransposeType
Nn = Control
Controls.nn

-- ** to_typed_function

-- | Convert a 'DeriveT.ControlRef' to a function.
--
-- If a signal exists but doesn't have a type, the type will be inherited from
-- the default.  This way a call can cause a signal parameter to default to
-- a certain type.
to_typed_function :: DeriveT.ControlRef -> Derive.Deriver TypedFunction
to_typed_function :: ControlRef -> Deriver State Error TypedFunction
to_typed_function ControlRef
control =
    ControlRef
-> Either (Typed Control) ControlFunction
-> Deriver State Error TypedFunction
convert_to_function ControlRef
control (Either (Typed Control) ControlFunction
 -> Deriver State Error TypedFunction)
-> Deriver State Error (Either (Typed Control) ControlFunction)
-> Deriver State Error TypedFunction
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ControlRef
-> Deriver State Error (Either (Typed Control) ControlFunction)
to_signal_or_function ControlRef
control

to_function :: DeriveT.ControlRef -> Derive.Deriver Function
to_function :: ControlRef -> Deriver Function
to_function = (TypedFunction -> Function)
-> Deriver State Error TypedFunction -> Deriver Function
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Typed Double -> Double
forall a. Typed a -> a
ScoreT.typed_val .) (Deriver State Error TypedFunction -> Deriver Function)
-> (ControlRef -> Deriver State Error TypedFunction)
-> ControlRef
-> Deriver Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ControlRef -> Deriver State Error TypedFunction
to_typed_function

convert_to_function :: DeriveT.ControlRef
    -> Either (ScoreT.Typed Signal.Control) DeriveT.ControlFunction
    -> Derive.Deriver TypedFunction
convert_to_function :: ControlRef
-> Either (Typed Control) ControlFunction
-> Deriver State Error TypedFunction
convert_to_function ControlRef
control = (Typed Control -> Deriver State Error TypedFunction)
-> (ControlFunction -> Deriver State Error TypedFunction)
-> Either (Typed Control) ControlFunction
-> Deriver State Error TypedFunction
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TypedFunction -> Deriver State Error TypedFunction
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedFunction -> Deriver State Error TypedFunction)
-> (Typed Control -> TypedFunction)
-> Typed Control
-> Deriver State Error TypedFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed Control -> TypedFunction
forall {k} {f :: * -> *} {kind :: k}.
Functor f =>
f (Signal kind) -> RealTime -> f Double
signal_function) ControlFunction -> Deriver State Error TypedFunction
from_function
    where
    signal_function :: f (Signal kind) -> RealTime -> f Double
signal_function f (Signal kind)
sig RealTime
t = RealTime -> Signal kind -> Double
forall {k} (kind :: k). RealTime -> Signal kind -> Double
Signal.at RealTime
t (Signal kind -> Double) -> f (Signal kind) -> f Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Signal kind)
sig
    from_function :: ControlFunction -> Deriver State Error TypedFunction
from_function ControlFunction
f = ControlFunction -> Control -> Dynamic -> TypedFunction
DeriveT.call_control_function ControlFunction
f Control
score_control (Dynamic -> TypedFunction)
-> Deriver State Error Dynamic -> Deriver State Error TypedFunction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Deriver State Error Dynamic
Internal.get_control_function_dynamic
    score_control :: Control
score_control = case ControlRef
control of
        DeriveT.ControlSignal {} -> Control
Controls.null
        DeriveT.DefaultedControl Control
cont Typed Control
_ -> Control
cont
        DeriveT.LiteralControl Control
cont -> Control
cont

to_signal_or_function :: DeriveT.ControlRef
    -> Derive.Deriver (Either (ScoreT.Typed Signal.Control)
        DeriveT.ControlFunction)
to_signal_or_function :: ControlRef
-> Deriver State Error (Either (Typed Control) ControlFunction)
to_signal_or_function ControlRef
control = case ControlRef
control of
    DeriveT.ControlSignal Typed Control
sig -> Either (Typed Control) ControlFunction
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Typed Control) ControlFunction
 -> Deriver State Error (Either (Typed Control) ControlFunction))
-> Either (Typed Control) ControlFunction
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall a b. (a -> b) -> a -> b
$ Typed Control -> Either (Typed Control) ControlFunction
forall a b. a -> Either a b
Left Typed Control
sig
    DeriveT.DefaultedControl Control
cont Typed Control
deflt ->
        Type
-> Deriver State Error (Either (Typed Control) ControlFunction)
-> Control
-> Deriver State Error (Either (Typed Control) ControlFunction)
get_control (Typed Control -> Type
forall a. Typed a -> Type
ScoreT.type_of Typed Control
deflt) (Either (Typed Control) ControlFunction
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed Control -> Either (Typed Control) ControlFunction
forall a b. a -> Either a b
Left Typed Control
deflt)) Control
cont
    DeriveT.LiteralControl Control
cont ->
        Type
-> Deriver State Error (Either (Typed Control) ControlFunction)
-> Control
-> Deriver State Error (Either (Typed Control) ControlFunction)
get_control Type
ScoreT.Untyped (Text
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall a. HasCallStack => Text -> Deriver a
Derive.throw (Text
 -> Deriver State Error (Either (Typed Control) ControlFunction))
-> Text
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall a b. (a -> b) -> a -> b
$ Text
"not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Control -> Text
forall a. Show a => a -> Text
showt Control
cont)
            Control
cont
    where
    get_control :: Type
-> Deriver State Error (Either (Typed Control) ControlFunction)
-> Control
-> Deriver State Error (Either (Typed Control) ControlFunction)
get_control Type
default_type Deriver State Error (Either (Typed Control) ControlFunction)
deflt Control
cont = Control -> Deriver (Maybe ControlFunction)
get_function Control
cont Deriver (Maybe ControlFunction)
-> (Maybe ControlFunction
    -> Deriver State Error (Either (Typed Control) ControlFunction))
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ControlFunction
f -> Either (Typed Control) ControlFunction
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Typed Control) ControlFunction
 -> Deriver State Error (Either (Typed Control) ControlFunction))
-> Either (Typed Control) ControlFunction
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall a b. (a -> b) -> a -> b
$ ControlFunction -> Either (Typed Control) ControlFunction
forall a b. b -> Either a b
Right (ControlFunction -> Either (Typed Control) ControlFunction)
-> ControlFunction -> Either (Typed Control) ControlFunction
forall a b. (a -> b) -> a -> b
$
            (TypedFunction -> TypedFunction)
-> ControlFunction -> ControlFunction
DeriveT.modify_control_function (Type -> Typed Double -> Typed Double
forall {a}. Type -> Typed a -> Typed a
inherit_type Type
default_type .) ControlFunction
f
        Maybe ControlFunction
Nothing -> Control -> Deriver State Error (Maybe (Typed Control))
get_control_signal Control
cont Deriver State Error (Maybe (Typed Control))
-> (Maybe (Typed Control)
    -> Deriver State Error (Either (Typed Control) ControlFunction))
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Typed Control
sig -> Either (Typed Control) ControlFunction
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Typed Control) ControlFunction
 -> Deriver State Error (Either (Typed Control) ControlFunction))
-> Either (Typed Control) ControlFunction
-> Deriver State Error (Either (Typed Control) ControlFunction)
forall a b. (a -> b) -> a -> b
$ Typed Control -> Either (Typed Control) ControlFunction
forall a b. a -> Either a b
Left Typed Control
sig
            Maybe (Typed Control)
Nothing -> Deriver State Error (Either (Typed Control) ControlFunction)
deflt
    get_function :: Control -> Deriver (Maybe ControlFunction)
get_function Control
cont = (Dynamic -> Maybe ControlFunction)
-> Deriver (Maybe ControlFunction)
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic ((Dynamic -> Maybe ControlFunction)
 -> Deriver (Maybe ControlFunction))
-> (Dynamic -> Maybe ControlFunction)
-> Deriver (Maybe ControlFunction)
forall a b. (a -> b) -> a -> b
$
        Control -> Map Control ControlFunction -> Maybe ControlFunction
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
cont (Map Control ControlFunction -> Maybe ControlFunction)
-> (Dynamic -> Map Control ControlFunction)
-> Dynamic
-> Maybe ControlFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Map Control ControlFunction
Derive.state_control_functions
    -- If the signal was untyped, it gets the type of the default, since
    -- presumably the caller expects that type.
    inherit_type :: Type -> Typed a -> Typed a
inherit_type Type
default_type Typed a
val =
        Typed a
val { type_of :: Type
ScoreT.type_of = Typed a -> Type
forall a. Typed a -> Type
ScoreT.type_of Typed a
val Type -> Type -> Type
forall a. Semigroup a => a -> a -> a
<> Type
default_type }
    get_control_signal :: Control -> Deriver State Error (Maybe (Typed Control))
get_control_signal Control
control = Control -> Map Control (Typed Control) -> Maybe (Typed Control)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
control (Map Control (Typed Control) -> Maybe (Typed Control))
-> Deriver State Error (Map Control (Typed Control))
-> Deriver State Error (Maybe (Typed Control))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Dynamic -> Map Control (Typed Control))
-> Deriver State Error (Map Control (Typed Control))
forall a. (Dynamic -> a) -> Deriver a
Internal.get_dynamic Dynamic -> Map Control (Typed Control)
Derive.state_controls

-- | This is the pitch signal version of 'to_signal_or_function', except
-- simpler because there's no pitch equivalent of ControlFunction.
--
-- I could actually have a pitch version of 'Function', which I guess would be
-- called PitchFunction, except be unlike ControlFunction, in that it actually
-- is a function, where ControlFunction isn't.   What a mess, I wish I could
-- get rid of ControlFunction...
pitch_at :: RealTime -> DeriveT.PControlRef -> Derive.Deriver PSignal.Pitch
pitch_at :: RealTime -> PControlRef -> Deriver State Error Pitch
pitch_at RealTime
pos PControlRef
control = case PControlRef
control of
    DeriveT.ControlSignal PSignal
sig -> PSignal -> Deriver State Error Pitch
require PSignal
sig
    DeriveT.DefaultedControl PControl
control PSignal
deflt ->
        Deriver State Error Pitch
-> (Pitch -> Deriver State Error Pitch)
-> Maybe Pitch
-> Deriver State Error Pitch
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PSignal -> Deriver State Error Pitch
require PSignal
deflt) Pitch -> Deriver State Error Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch -> Deriver State Error Pitch)
-> Deriver (Maybe Pitch) -> Deriver State Error Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PControl -> Deriver (Maybe Pitch)
named_pitch_at PControl
control
    DeriveT.LiteralControl PControl
control -> do
        Text -> Maybe Pitch -> Deriver State Error Pitch
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require
            (Text
"pitch not found and no default given: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PControl -> Text
forall a. Show a => a -> Text
showt PControl
control)
            (Maybe Pitch -> Deriver State Error Pitch)
-> Deriver (Maybe Pitch) -> Deriver State Error Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PControl -> Deriver (Maybe Pitch)
named_pitch_at PControl
control
    where
    -- There is a Derive.named_pitch_at, but it's in Derive.Deriver.Lib, which
    -- imports this.
    named_pitch_at :: PControl -> Deriver (Maybe Pitch)
named_pitch_at PControl
control = do
        Maybe PSignal
maybe_sig <- PControl -> Deriver (Maybe PSignal)
Internal.get_named_pitch PControl
control
        Maybe Pitch -> Deriver (Maybe Pitch)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pitch -> Deriver (Maybe Pitch))
-> Maybe Pitch -> Deriver (Maybe Pitch)
forall a b. (a -> b) -> a -> b
$ RealTime -> PSignal -> Maybe Pitch
PSignal.at RealTime
pos (PSignal -> Maybe Pitch) -> Maybe PSignal -> Maybe Pitch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe PSignal
maybe_sig
    require :: PSignal -> Deriver State Error Pitch
require = Text -> Maybe Pitch -> Deriver State Error Pitch
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"ControlSignal pitch at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RealTime -> Text
forall a. Pretty a => a -> Text
pretty RealTime
pos)
        (Maybe Pitch -> Deriver State Error Pitch)
-> (PSignal -> Maybe Pitch) -> PSignal -> Deriver State Error Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> PSignal -> Maybe Pitch
PSignal.at RealTime
pos

-- * sub tracks

instance Typecheck SubT.Track where
    from_val :: Val -> Checked Track
from_val Val
_ = Checked Track
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 = Track -> Maybe Track
forall a. a -> Maybe a
Just