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

{-# OPTIONS_HADDOCK not-home #-}
-- | Low-dependency basic types for derivation.
module Derive.ScoreT (
    -- * Instrument
    Instrument(..)
    , instrument_name
    , empty_instrument

    -- * Control
    , Control(..)
    , control_name
    , checked_control

    -- * PControl
    , PControl(..)
    , pcontrol_name
    , default_pitch
    , checked_pcontrol
    , parse_generic_control

    -- * Type
    , Type(..)
    , all_types
    , type_to_code, code_to_type
    , TimeT(..), TransposeT(..), Duration(..)
    , time_t, transpose_t, duration
    , Typed(..), type_of, val_of
    , merge_typed
    , untyped
    , type_to_transpose

    -- * type aliases
    , ControlValMap
    , TypedControlValMap
    , ControlMap
    , FunctionMap
    , Function
    , TypedFunction
    , TypedSignal
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Data.Aeson as Aeson
import qualified Data.Hashable as Hashable
import qualified Data.Map as Map
import qualified Data.String as String
import qualified Data.Text as Text

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

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

import qualified Ui.Id as Id
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- | An Instrument is identified by a plain string.  This will be looked up in
-- the instrument db to get the backend specific Instrument type as well as
-- the backend itself, but things at the Derive layer and above don't care
-- about all that.
--
-- This should be a valid symbol as defined by 'Ui.Id.valid_symbol'.  This
-- way it can be parsed without quotes.
newtype Instrument = Instrument Text
    deriving
        ( Instrument -> Instrument -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Instrument -> Instrument -> Bool
$c/= :: Instrument -> Instrument -> Bool
== :: Instrument -> Instrument -> Bool
$c== :: Instrument -> Instrument -> Bool
Eq, Eq Instrument
Instrument -> Instrument -> Bool
Instrument -> Instrument -> Ordering
Instrument -> Instrument -> Instrument
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Instrument -> Instrument -> Instrument
$cmin :: Instrument -> Instrument -> Instrument
max :: Instrument -> Instrument -> Instrument
$cmax :: Instrument -> Instrument -> Instrument
>= :: Instrument -> Instrument -> Bool
$c>= :: Instrument -> Instrument -> Bool
> :: Instrument -> Instrument -> Bool
$c> :: Instrument -> Instrument -> Bool
<= :: Instrument -> Instrument -> Bool
$c<= :: Instrument -> Instrument -> Bool
< :: Instrument -> Instrument -> Bool
$c< :: Instrument -> Instrument -> Bool
compare :: Instrument -> Instrument -> Ordering
$ccompare :: Instrument -> Instrument -> Ordering
Ord, Int -> Instrument -> ShowS
[Instrument] -> ShowS
Instrument -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instrument] -> ShowS
$cshowList :: [Instrument] -> ShowS
show :: Instrument -> String
$cshow :: Instrument -> String
showsPrec :: Int -> Instrument -> ShowS
$cshowsPrec :: Int -> Instrument -> ShowS
Show, ReadPrec [Instrument]
ReadPrec Instrument
Int -> ReadS Instrument
ReadS [Instrument]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Instrument]
$creadListPrec :: ReadPrec [Instrument]
readPrec :: ReadPrec Instrument
$creadPrec :: ReadPrec Instrument
readList :: ReadS [Instrument]
$creadList :: ReadS [Instrument]
readsPrec :: Int -> ReadS Instrument
$creadsPrec :: Int -> ReadS Instrument
Read, Eq Instrument
Int -> Instrument -> Int
Instrument -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Instrument -> Int
$chash :: Instrument -> Int
hashWithSalt :: Int -> Instrument -> Int
$chashWithSalt :: Int -> Instrument -> Int
Hashable.Hashable, Instrument -> ()
forall a. (a -> ()) -> NFData a
rnf :: Instrument -> ()
$crnf :: Instrument -> ()
DeepSeq.NFData
        , Get Instrument
Putter Instrument
forall a. Putter a -> Get a -> Serialize a
get :: Get Instrument
$cget :: Get Instrument
put :: Putter Instrument
$cput :: Putter Instrument
Serialize.Serialize, String -> Instrument
forall a. (String -> a) -> IsString a
fromString :: String -> Instrument
$cfromString :: String -> Instrument
String.IsString
        , [Instrument] -> Encoding
[Instrument] -> Value
Instrument -> Encoding
Instrument -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Instrument] -> Encoding
$ctoEncodingList :: [Instrument] -> Encoding
toJSONList :: [Instrument] -> Value
$ctoJSONList :: [Instrument] -> Value
toEncoding :: Instrument -> Encoding
$ctoEncoding :: Instrument -> Encoding
toJSON :: Instrument -> Value
$ctoJSON :: Instrument -> Value
Aeson.ToJSON, Value -> Parser [Instrument]
Value -> Parser Instrument
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Instrument]
$cparseJSONList :: Value -> Parser [Instrument]
parseJSON :: Value -> Parser Instrument
$cparseJSON :: Value -> Parser Instrument
Aeson.FromJSON
        )

instrument_name :: Instrument -> Text
instrument_name :: Instrument -> Text
instrument_name (Instrument Text
s) = Text
s

empty_instrument :: Instrument
empty_instrument :: Instrument
empty_instrument = Text -> Instrument
Instrument Text
""

instance Pretty Instrument where pretty :: Instrument -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val
instance ShowVal.ShowVal Instrument where
    show_val :: Instrument -> Text
show_val (Instrument Text
inst) = forall a. ShowVal a => a -> Text
ShowVal.show_val Text
inst

-- * Control

-- | A control is an abstract parameter that influences derivation.  Some of
-- them affect performance and will be rendered as MIDI controls or note
-- parameters or whatever, while others may affect derivation (e.g. tempo) and
-- won't be seen by the backend at all.
--
-- A Control should be a valid identifier as defined by 'Ui.Id.valid_symbol'.
newtype Control = Control Text
    deriving (Control -> Control -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Control -> Control -> Bool
$c/= :: Control -> Control -> Bool
== :: Control -> Control -> Bool
$c== :: Control -> Control -> Bool
Eq, Eq Control
Control -> Control -> Bool
Control -> Control -> Ordering
Control -> Control -> Control
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Control -> Control -> Control
$cmin :: Control -> Control -> Control
max :: Control -> Control -> Control
$cmax :: Control -> Control -> Control
>= :: Control -> Control -> Bool
$c>= :: Control -> Control -> Bool
> :: Control -> Control -> Bool
$c> :: Control -> Control -> Bool
<= :: Control -> Control -> Bool
$c<= :: Control -> Control -> Bool
< :: Control -> Control -> Bool
$c< :: Control -> Control -> Bool
compare :: Control -> Control -> Ordering
$ccompare :: Control -> Control -> Ordering
Ord, ReadPrec [Control]
ReadPrec Control
Int -> ReadS Control
ReadS [Control]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Control]
$creadListPrec :: ReadPrec [Control]
readPrec :: ReadPrec Control
$creadPrec :: ReadPrec Control
readList :: ReadS [Control]
$creadList :: ReadS [Control]
readsPrec :: Int -> ReadS Control
$creadsPrec :: Int -> ReadS Control
Read, Int -> Control -> ShowS
[Control] -> ShowS
Control -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Control] -> ShowS
$cshowList :: [Control] -> ShowS
show :: Control -> String
$cshow :: Control -> String
showsPrec :: Int -> Control -> ShowS
$cshowsPrec :: Int -> Control -> ShowS
Show, Control -> ()
forall a. (a -> ()) -> NFData a
rnf :: Control -> ()
$crnf :: Control -> ()
DeepSeq.NFData, Get Control
Putter Control
forall a. Putter a -> Get a -> Serialize a
get :: Get Control
$cget :: Get Control
put :: Putter Control
$cput :: Putter Control
Serialize.Serialize,
        String -> Control
forall a. (String -> a) -> IsString a
fromString :: String -> Control
$cfromString :: String -> Control
String.IsString, Control -> Text
forall a. (a -> Text) -> ShowVal a
show_val :: Control -> Text
$cshow_val :: Control -> Text
ShowVal.ShowVal)

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

control_name :: Control -> Text
control_name :: Control -> Text
control_name (Control Text
name) = Text
name

-- | Use this constructor when making a Control from user input.  Literals
-- can use the IsString instance.
checked_control :: Text -> Either Text Control
checked_control :: Text -> Either Text Control
checked_control Text
name
    | Text -> Bool
Text.null Text
name = forall a b. a -> Either a b
Left Text
"empty control name"
    | Text -> Bool
Id.valid_symbol Text
name = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Control
Control Text
name
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"invalid characters in control: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
name

-- * PControl

-- | The pitch control version of 'Control'.  Unlike Control, this is allowed
-- to be null, which is the name of the default pitch signal.
--
-- A PControl should be a valid identifier as defined by 'Ui.Id.valid_symbol',
-- except that its literal tracklang form starts with a @#@, to differentiate
-- from a Control.
newtype PControl = PControl Text
    deriving (PControl -> PControl -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PControl -> PControl -> Bool
$c/= :: PControl -> PControl -> Bool
== :: PControl -> PControl -> Bool
$c== :: PControl -> PControl -> Bool
Eq, Eq PControl
PControl -> PControl -> Bool
PControl -> PControl -> Ordering
PControl -> PControl -> PControl
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PControl -> PControl -> PControl
$cmin :: PControl -> PControl -> PControl
max :: PControl -> PControl -> PControl
$cmax :: PControl -> PControl -> PControl
>= :: PControl -> PControl -> Bool
$c>= :: PControl -> PControl -> Bool
> :: PControl -> PControl -> Bool
$c> :: PControl -> PControl -> Bool
<= :: PControl -> PControl -> Bool
$c<= :: PControl -> PControl -> Bool
< :: PControl -> PControl -> Bool
$c< :: PControl -> PControl -> Bool
compare :: PControl -> PControl -> Ordering
$ccompare :: PControl -> PControl -> Ordering
Ord, ReadPrec [PControl]
ReadPrec PControl
Int -> ReadS PControl
ReadS [PControl]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PControl]
$creadListPrec :: ReadPrec [PControl]
readPrec :: ReadPrec PControl
$creadPrec :: ReadPrec PControl
readList :: ReadS [PControl]
$creadList :: ReadS [PControl]
readsPrec :: Int -> ReadS PControl
$creadsPrec :: Int -> ReadS PControl
Read, Int -> PControl -> ShowS
[PControl] -> ShowS
PControl -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PControl] -> ShowS
$cshowList :: [PControl] -> ShowS
show :: PControl -> String
$cshow :: PControl -> String
showsPrec :: Int -> PControl -> ShowS
$cshowsPrec :: Int -> PControl -> ShowS
Show, PControl -> ()
forall a. (a -> ()) -> NFData a
rnf :: PControl -> ()
$crnf :: PControl -> ()
DeepSeq.NFData, Get PControl
Putter PControl
forall a. Putter a -> Get a -> Serialize a
get :: Get PControl
$cget :: Get PControl
put :: Putter PControl
$cput :: Putter PControl
Serialize.Serialize,
        String -> PControl
forall a. (String -> a) -> IsString a
fromString :: String -> PControl
$cfromString :: String -> PControl
String.IsString)

pcontrol_name :: PControl -> Text
pcontrol_name :: PControl -> Text
pcontrol_name (PControl Text
name) = Text
name

default_pitch :: PControl
default_pitch :: PControl
default_pitch = PControl
""

instance Pretty PControl where pretty :: PControl -> Text
pretty = forall a. ShowVal a => a -> Text
ShowVal.show_val
instance ShowVal.ShowVal PControl where
    show_val :: PControl -> Text
show_val p :: PControl
p@(PControl Text
s)
        -- Invert the # -> default pitch mapping in
        -- Typecheck.lookup_pitch_signal.  This is kind of bogus because the #
        -- syntax belongs to the PControlRef, not the control name itself.
        -- But otherwise I get ''s which look confusing in errors?  I guess
        -- the issue is that there actually is a separate state_pitch, it's
        -- not in state_environ, so '' is not its actual name.
        | PControl
p forall a. Eq a => a -> a -> Bool
== PControl
default_pitch = Text
"#"
        | Bool
otherwise = forall a. ShowVal a => a -> Text
ShowVal.show_val Text
s


-- | Use this constructor when making a PControl from user input.  Literals
-- can use the IsString instance.
checked_pcontrol :: Text -> Either Text PControl
checked_pcontrol :: Text -> Either Text PControl
checked_pcontrol Text
name
    | Text -> Bool
Text.null Text
name Bool -> Bool -> Bool
|| Text -> Bool
Id.valid_symbol Text
name = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> PControl
PControl Text
name
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"invalid characters in pitch control: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
name

-- | Parse either a Control or PControl.
parse_generic_control :: Text
    -> Either Text (Either Control PControl)
parse_generic_control :: Text -> Either Text (Either Control PControl)
parse_generic_control Text
name = case Text -> Maybe (Char, Text)
Text.uncons Text
name of
    Just (Char
'#', Text
rest) -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text PControl
checked_pcontrol Text
rest
    Maybe (Char, Text)
_ -> forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text Control
checked_control Text
name


-- * Type

-- | Tag for the type of the values in a control signal.
-- Untyped goes last because the parser tries them in order.
data Type = Chromatic | Diatonic | Nn | Score | Real | Untyped
    deriving (Type -> Type -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Int -> Type
Type -> Int
Type -> [Type]
Type -> Type
Type -> Type -> [Type]
Type -> Type -> Type -> [Type]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Type -> Type -> Type -> [Type]
$cenumFromThenTo :: Type -> Type -> Type -> [Type]
enumFromTo :: Type -> Type -> [Type]
$cenumFromTo :: Type -> Type -> [Type]
enumFromThen :: Type -> Type -> [Type]
$cenumFromThen :: Type -> Type -> [Type]
enumFrom :: Type -> [Type]
$cenumFrom :: Type -> [Type]
fromEnum :: Type -> Int
$cfromEnum :: Type -> Int
toEnum :: Int -> Type
$ctoEnum :: Int -> Type
pred :: Type -> Type
$cpred :: Type -> Type
succ :: Type -> Type
$csucc :: Type -> Type
Enum, Eq Type
Type -> Type -> Bool
Type -> Type -> Ordering
Type -> Type -> Type
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Type -> Type -> Type
$cmin :: Type -> Type -> Type
max :: Type -> Type -> Type
$cmax :: Type -> Type -> Type
>= :: Type -> Type -> Bool
$c>= :: Type -> Type -> Bool
> :: Type -> Type -> Bool
$c> :: Type -> Type -> Bool
<= :: Type -> Type -> Bool
$c<= :: Type -> Type -> Bool
< :: Type -> Type -> Bool
$c< :: Type -> Type -> Bool
compare :: Type -> Type -> Ordering
$ccompare :: Type -> Type -> Ordering
Ord, Type
forall a. a -> a -> Bounded a
maxBound :: Type
$cmaxBound :: Type
minBound :: Type
$cminBound :: Type
Bounded, Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show)

all_types :: [Type]
all_types :: [Type]
all_types = [forall a. Bounded a => a
minBound ..]

type_to_code :: Type -> Text
type_to_code :: Type -> Text
type_to_code = \case
    Type
Untyped -> Text
""
    Type
Chromatic -> Text
"c"
    Type
Diatonic -> Text
"d"
    Type
Nn -> Text
"nn"
    Type
Score -> Char -> Text
Text.singleton Char
ScoreTime.suffix -- t for time
    Type
Real -> Char -> Text
Text.singleton Char
RealTime.suffix -- s for seconds

code_to_type :: Text -> Maybe Type
code_to_type :: Text -> Maybe Type
code_to_type = (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Text Type
enum_map)
    where enum_map :: Map Text Type
enum_map = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn forall a. ShowVal a => a -> Text
ShowVal.show_val [forall a. Bounded a => a
minBound ..]

instance Semigroup Type where
    Type
Untyped <> :: Type -> Type -> Type
<> Type
typed = Type
typed
    Type
typed <> Type
_ = Type
typed
instance Monoid Type where
    mempty :: Type
mempty = Type
Untyped
    mappend :: Type -> Type -> Type
mappend = forall a. Semigroup a => a -> a -> a
(<>)

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

instance Serialize.Serialize Type where
    put :: Putter Type
put = forall a. Serialize a => Putter a
Serialize.put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
    get :: Get Type
get = forall a. Enum a => Int -> a
toEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get

instance ShowVal.ShowVal Type where
    show_val :: Type -> Text
show_val = Type -> Text
type_to_code

-- This feels clumsy.
-- What I want to express is subtyping.

data TimeT = TReal | TScore
    deriving (TimeT -> TimeT -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeT -> TimeT -> Bool
$c/= :: TimeT -> TimeT -> Bool
== :: TimeT -> TimeT -> Bool
$c== :: TimeT -> TimeT -> Bool
Eq, Eq TimeT
TimeT -> TimeT -> Bool
TimeT -> TimeT -> Ordering
TimeT -> TimeT -> TimeT
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TimeT -> TimeT -> TimeT
$cmin :: TimeT -> TimeT -> TimeT
max :: TimeT -> TimeT -> TimeT
$cmax :: TimeT -> TimeT -> TimeT
>= :: TimeT -> TimeT -> Bool
$c>= :: TimeT -> TimeT -> Bool
> :: TimeT -> TimeT -> Bool
$c> :: TimeT -> TimeT -> Bool
<= :: TimeT -> TimeT -> Bool
$c<= :: TimeT -> TimeT -> Bool
< :: TimeT -> TimeT -> Bool
$c< :: TimeT -> TimeT -> Bool
compare :: TimeT -> TimeT -> Ordering
$ccompare :: TimeT -> TimeT -> Ordering
Ord, Int -> TimeT -> ShowS
[TimeT] -> ShowS
TimeT -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeT] -> ShowS
$cshowList :: [TimeT] -> ShowS
show :: TimeT -> String
$cshow :: TimeT -> String
showsPrec :: Int -> TimeT -> ShowS
$cshowsPrec :: Int -> TimeT -> ShowS
Show)

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

data TransposeT = TDiatonic | TChromatic | TNn
    deriving (TransposeT -> TransposeT -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransposeT -> TransposeT -> Bool
$c/= :: TransposeT -> TransposeT -> Bool
== :: TransposeT -> TransposeT -> Bool
$c== :: TransposeT -> TransposeT -> Bool
Eq, Eq TransposeT
TransposeT -> TransposeT -> Bool
TransposeT -> TransposeT -> Ordering
TransposeT -> TransposeT -> TransposeT
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TransposeT -> TransposeT -> TransposeT
$cmin :: TransposeT -> TransposeT -> TransposeT
max :: TransposeT -> TransposeT -> TransposeT
$cmax :: TransposeT -> TransposeT -> TransposeT
>= :: TransposeT -> TransposeT -> Bool
$c>= :: TransposeT -> TransposeT -> Bool
> :: TransposeT -> TransposeT -> Bool
$c> :: TransposeT -> TransposeT -> Bool
<= :: TransposeT -> TransposeT -> Bool
$c<= :: TransposeT -> TransposeT -> Bool
< :: TransposeT -> TransposeT -> Bool
$c< :: TransposeT -> TransposeT -> Bool
compare :: TransposeT -> TransposeT -> Ordering
$ccompare :: TransposeT -> TransposeT -> Ordering
Ord, Int -> TransposeT -> ShowS
[TransposeT] -> ShowS
TransposeT -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransposeT] -> ShowS
$cshowList :: [TransposeT] -> ShowS
show :: TransposeT -> String
$cshow :: TransposeT -> String
showsPrec :: Int -> TransposeT -> ShowS
$cshowsPrec :: Int -> TransposeT -> ShowS
Show)

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

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

time_t :: TimeT -> Type -> Maybe TimeT
time_t :: TimeT -> Type -> Maybe TimeT
time_t TimeT
deflt = \case
    Type
Untyped -> forall a. a -> Maybe a
Just TimeT
deflt
    Type
Real -> forall a. a -> Maybe a
Just TimeT
TReal
    Type
Score -> forall a. a -> Maybe a
Just TimeT
TScore
    Type
_ -> forall a. Maybe a
Nothing

transpose_t :: TransposeT -> Type -> Maybe TransposeT
transpose_t :: TransposeT -> Type -> Maybe TransposeT
transpose_t TransposeT
deflt = \case
    Type
Untyped -> forall a. a -> Maybe a
Just TransposeT
deflt
    Type
Diatonic -> forall a. a -> Maybe a
Just TransposeT
TDiatonic
    Type
Chromatic -> forall a. a -> Maybe a
Just TransposeT
TChromatic
    Type
Nn -> forall a. a -> Maybe a
Just TransposeT
TNn
    Type
_ -> forall a. Maybe a
Nothing

duration :: TimeT -> Typed Signal.Y -> Maybe Duration
duration :: TimeT -> Typed Y -> Maybe Duration
duration TimeT
deflt (Typed Type
typ Y
val) = case Type
typ of
    Type
Score -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
ScoreDuration (Y -> ScoreTime
ScoreTime.from_double Y
val)
    Type
Real -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
RealDuration (Y -> RealTime
RealTime.seconds Y
val)
    Type
Untyped -> case TimeT
deflt of
        TimeT
TScore -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ScoreTime -> Duration
ScoreDuration (Y -> ScoreTime
ScoreTime.from_double Y
val)
        TimeT
TReal -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ RealTime -> Duration
RealDuration (Y -> RealTime
RealTime.seconds Y
val)
    Type
_ -> forall a. Maybe a
Nothing

-- The transpose equilavents are in Perform.Pitch.Transpose

{-
data Type = Time TimeT | Transpose TransposeT | Untyped
data TimeT = Real | Score
data TransposeT = Chromatic | Diatonic | Nn

data Duration = RealD RealTime | ScoreD ScoreTime

duration :: TimeT ->
duration deflt (Typed typ val) = case typ of
    Time ttype -> to_duration ttype val
    Untyped -> to_duration deflt val

data Category = TimeT TimeT | TransposeT TransposeT | TUntyped
    deriving (Eq, Ord, Show)

category :: Type -> Category
category = \case
    Chromatic -> TTranspose TChromatic
    Diatonic -> TTranspose TDiatonic
    Nn -> TTranspose TNn
    Real -> TTime TReal
    Score -> TTime TScore
    Untyped -> TUntyped
-}

data Typed a = Typed !Type !a
    deriving (Typed a -> Typed a -> Bool
forall a. Eq a => Typed a -> Typed a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Typed a -> Typed a -> Bool
$c/= :: forall a. Eq a => Typed a -> Typed a -> Bool
== :: Typed a -> Typed a -> Bool
$c== :: forall a. Eq a => Typed a -> Typed a -> Bool
Eq, Typed a -> Typed a -> Bool
Typed a -> Typed a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Typed a)
forall a. Ord a => Typed a -> Typed a -> Bool
forall a. Ord a => Typed a -> Typed a -> Ordering
forall a. Ord a => Typed a -> Typed a -> Typed a
min :: Typed a -> Typed a -> Typed a
$cmin :: forall a. Ord a => Typed a -> Typed a -> Typed a
max :: Typed a -> Typed a -> Typed a
$cmax :: forall a. Ord a => Typed a -> Typed a -> Typed a
>= :: Typed a -> Typed a -> Bool
$c>= :: forall a. Ord a => Typed a -> Typed a -> Bool
> :: Typed a -> Typed a -> Bool
$c> :: forall a. Ord a => Typed a -> Typed a -> Bool
<= :: Typed a -> Typed a -> Bool
$c<= :: forall a. Ord a => Typed a -> Typed a -> Bool
< :: Typed a -> Typed a -> Bool
$c< :: forall a. Ord a => Typed a -> Typed a -> Bool
compare :: Typed a -> Typed a -> Ordering
$ccompare :: forall a. Ord a => Typed a -> Typed a -> Ordering
Ord, Int -> Typed a -> ShowS
forall a. Show a => Int -> Typed a -> ShowS
forall a. Show a => [Typed a] -> ShowS
forall a. Show a => Typed a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Typed a] -> ShowS
$cshowList :: forall a. Show a => [Typed a] -> ShowS
show :: Typed a -> String
$cshow :: forall a. Show a => Typed a -> String
showsPrec :: Int -> Typed a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Typed a -> ShowS
Show, forall a b. a -> Typed b -> Typed a
forall a b. (a -> b) -> Typed a -> Typed 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 -> Typed b -> Typed a
$c<$ :: forall a b. a -> Typed b -> Typed a
fmap :: forall a b. (a -> b) -> Typed a -> Typed b
$cfmap :: forall a b. (a -> b) -> Typed a -> Typed b
Functor, forall a. Eq a => a -> Typed a -> Bool
forall a. Num a => Typed a -> a
forall a. Ord a => Typed a -> a
forall m. Monoid m => Typed m -> m
forall a. Typed a -> Bool
forall a. Typed a -> Int
forall a. Typed a -> [a]
forall a. (a -> a -> a) -> Typed a -> a
forall m a. Monoid m => (a -> m) -> Typed a -> m
forall b a. (b -> a -> b) -> b -> Typed a -> b
forall a b. (a -> b -> b) -> b -> Typed a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Typed a -> a
$cproduct :: forall a. Num a => Typed a -> a
sum :: forall a. Num a => Typed a -> a
$csum :: forall a. Num a => Typed a -> a
minimum :: forall a. Ord a => Typed a -> a
$cminimum :: forall a. Ord a => Typed a -> a
maximum :: forall a. Ord a => Typed a -> a
$cmaximum :: forall a. Ord a => Typed a -> a
elem :: forall a. Eq a => a -> Typed a -> Bool
$celem :: forall a. Eq a => a -> Typed a -> Bool
length :: forall a. Typed a -> Int
$clength :: forall a. Typed a -> Int
null :: forall a. Typed a -> Bool
$cnull :: forall a. Typed a -> Bool
toList :: forall a. Typed a -> [a]
$ctoList :: forall a. Typed a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Typed a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Typed a -> a
foldr1 :: forall a. (a -> a -> a) -> Typed a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Typed a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Typed a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Typed a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Typed a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Typed a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Typed a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Typed a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Typed a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Typed a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Typed a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Typed a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Typed a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Typed a -> m
fold :: forall m. Monoid m => Typed m -> m
$cfold :: forall m. Monoid m => Typed m -> m
Foldable, Functor Typed
Foldable Typed
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Typed (m a) -> m (Typed a)
forall (f :: * -> *) a. Applicative f => Typed (f a) -> f (Typed a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Typed a -> m (Typed b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Typed a -> f (Typed b)
sequence :: forall (m :: * -> *) a. Monad m => Typed (m a) -> m (Typed a)
$csequence :: forall (m :: * -> *) a. Monad m => Typed (m a) -> m (Typed a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Typed a -> m (Typed b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Typed a -> m (Typed b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Typed (f a) -> f (Typed a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Typed (f a) -> f (Typed a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Typed a -> f (Typed b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Typed a -> f (Typed b)
Traversable)
    -- Not record syntax so Show is more concise.

type_of :: Typed a -> Type
type_of :: forall a. Typed a -> Type
type_of (Typed Type
typ a
_) = Type
typ

val_of :: Typed a -> a
val_of :: forall a. Typed a -> a
val_of (Typed Type
_ a
a) = a
a

instance DeepSeq.NFData a => DeepSeq.NFData (Typed a) where
    rnf :: Typed a -> ()
rnf (Typed Type
typ a
val) = Type
typ seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
DeepSeq.rnf a
val

instance Semigroup a => Semigroup (Typed a) where
    Typed Type
t1 a
v1 <> :: Typed a -> Typed a -> Typed a
<> Typed Type
t2 a
v2 = forall a. Type -> a -> Typed a
Typed (Type
t1forall a. Semigroup a => a -> a -> a
<>Type
t2) (a
v1forall a. Semigroup a => a -> a -> a
<>a
v2)
instance Monoid a => Monoid (Typed a) where
    mempty :: Typed a
mempty = forall a. Type -> a -> Typed a
Typed forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: Typed a -> Typed a -> Typed a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Pretty a => Pretty (Typed a) where
    format :: Typed a -> Doc
format (Typed Type
typ a
val) =
        Text -> Doc
Pretty.text (if Text -> Bool
Text.null Text
c then Text
"" else Text
c forall a. Semigroup a => a -> a -> a
<> Text
":") forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Pretty.format a
val
        where c :: Text
c = Type -> Text
type_to_code Type
typ

instance ShowVal.ShowVal (Typed Control) where
    show_val :: Typed Control -> Text
show_val (Typed Type
typ Control
c) = forall a. ShowVal a => a -> Text
ShowVal.show_val Control
c forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Type -> Text
type_to_code Type
typ

instance Serialize.Serialize a => Serialize.Serialize (Typed a) where
    put :: Putter (Typed a)
put (Typed Type
a a
b) = forall a. Serialize a => Putter a
Serialize.put Type
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put a
b
    get :: Get (Typed a)
get = forall a. Type -> a -> Typed a
Typed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get

merge_typed :: (a -> a -> a) -> Typed a -> Typed a -> Typed a
merge_typed :: forall a. (a -> a -> a) -> Typed a -> Typed a -> Typed a
merge_typed a -> a -> a
f (Typed Type
typ1 a
v1) (Typed Type
typ2 a
v2) = forall a. Type -> a -> Typed a
Typed (Type
typ1forall a. Semigroup a => a -> a -> a
<>Type
typ2) (a -> a -> a
f a
v1 a
v2)

untyped :: a -> Typed a
untyped :: forall a. a -> Typed a
untyped = forall a. Type -> a -> Typed a
Typed Type
Untyped

type_to_transpose :: Typed Signal.Y -> Maybe Pitch.Transpose
type_to_transpose :: Typed Y -> Maybe Transpose
type_to_transpose (Typed Type
typ Y
val) = case Type
typ of
    Type
Diatonic -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Y -> Transpose
Pitch.Diatonic Y
val
    Type
Chromatic -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Y -> Transpose
Pitch.Chromatic Y
val
    Type
Nn -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Y -> Transpose
Pitch.Nn Y
val
    Type
_ -> forall a. Maybe a
Nothing


-- * type aliases

instance ShowVal.ShowVal (Typed Signal.Y) where
    show_val :: Typed Y -> Text
show_val (Typed Type
typ Y
val) = forall a. ShowVal a => a -> Text
ShowVal.show_val Y
val forall a. Semigroup a => a -> a -> a
<> Type -> Text
type_to_code Type
typ

-- | This is a snapshot of the control signals at a certain point in time.
-- It's meant for 'Derive.PSignal.PitchConfig', so the values are expected to
-- be transpositions, and hence untyped.
type ControlValMap = Map Control Signal.Y
type TypedControlValMap = Map Control (Typed Signal.Y)

type ControlMap = Map Control TypedSignal
type FunctionMap = Map Control TypedFunction
type Function = RealTime -> Signal.Y

type TypedFunction = Typed (RealTime -> Signal.Y)
type TypedSignal = Typed Signal.Control