-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE DefaultSignatures #-}
-- | This is a serializable subset of 'DeriveT.Val' and 'DeriveT.Environ'.
-- It omits pitches, which are code and can't be serialized.
module Derive.REnv (
    Environ
    , to_map, from_list, convert, lookup, null
    -- * val
    , Val(..)
    , ConstantPitch(..)
    , ToVal(..)
    , Expr, Call, Term
) where
import           Prelude hiding (lookup, null)
import qualified Data.Map as Map

import qualified Util.Pretty as Pretty
import qualified Util.Serialize as Serialize
import           Util.Serialize (get, put)

import qualified Derive.Attrs as Attrs
import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
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 Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal

import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


-- * Environ

newtype Environ = Environ (Map EnvKey.Key Val)
    deriving (Int -> Environ -> ShowS
[Environ] -> ShowS
Environ -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environ] -> ShowS
$cshowList :: [Environ] -> ShowS
show :: Environ -> String
$cshow :: Environ -> String
showsPrec :: Int -> Environ -> ShowS
$cshowsPrec :: Int -> Environ -> ShowS
Show, Environ -> Environ -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Environ -> Environ -> Bool
$c/= :: Environ -> Environ -> Bool
== :: Environ -> Environ -> Bool
$c== :: Environ -> Environ -> Bool
Eq, NonEmpty Environ -> Environ
Environ -> Environ -> Environ
forall b. Integral b => b -> Environ -> Environ
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Environ -> Environ
$cstimes :: forall b. Integral b => b -> Environ -> Environ
sconcat :: NonEmpty Environ -> Environ
$csconcat :: NonEmpty Environ -> Environ
<> :: Environ -> Environ -> Environ
$c<> :: Environ -> Environ -> Environ
Semigroup, Semigroup Environ
Environ
[Environ] -> Environ
Environ -> Environ -> Environ
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Environ] -> Environ
$cmconcat :: [Environ] -> Environ
mappend :: Environ -> Environ -> Environ
$cmappend :: Environ -> Environ -> Environ
mempty :: Environ
$cmempty :: Environ
Monoid, Get Environ
Putter Environ
forall a. Putter a -> Get a -> Serialize a
get :: Get Environ
$cget :: Get Environ
put :: Putter Environ
$cput :: Putter Environ
Serialize.Serialize)

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

to_map :: Environ -> Map EnvKey.Key Val
to_map :: Environ -> Map Key Val
to_map (Environ Map Key Val
m) = Map Key Val
m

from_list :: [(EnvKey.Key, Val)] -> Environ
from_list :: [(Key, Val)] -> Environ
from_list = Map Key Val -> Environ
Environ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

convert :: Environ -> DeriveT.Environ
convert :: Environ -> Environ
convert (Environ Map Key Val
env) = Map Key Val -> Environ
DeriveT.Environ forall a b. (a -> b) -> a -> b
$ Val -> Val
promote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Key Val
env

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

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

-- * val

-- | This is like 'DeriveT.Val', except missing fields that can't be
-- serialized, or require Deriver and hence couldn't go in a module below
-- Deriver without incurring a circular dependency.
--
-- Namely: 'DeriveT.VPitch', 'DeriveT.VCFunction'.
-- NOTE [val-and-minival].
data Val =
    VNum !(ScoreT.Typed Signal.Y)
    | VAttributes !Attrs.Attributes
    | VControlRef !DeriveT.ControlRef
    | VConstantPitch !ConstantPitch
    | VNotePitch !Pitch.Pitch
    | VStr !Expr.Str
    | VQuoted !Expr
    | VList ![Val]
    deriving (Val -> Val -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Val -> Val -> Bool
$c/= :: Val -> Val -> Bool
== :: Val -> Val -> Bool
$c== :: Val -> Val -> Bool
Eq, Int -> Val -> ShowS
[Val] -> ShowS
Val -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Val] -> ShowS
$cshowList :: [Val] -> ShowS
show :: Val -> String
$cshow :: Val -> String
showsPrec :: Int -> Val -> ShowS
$cshowsPrec :: Int -> Val -> ShowS
Show)

promote :: Val -> DeriveT.Val
promote :: Val -> Val
promote = \case
    VNum Typed Y
v -> Typed Control -> Val
DeriveT.VSignal forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Y -> Signal kind
Signal.constant forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Y
v
    VAttributes Attributes
v -> Attributes -> Val
DeriveT.VAttributes Attributes
v
    VControlRef ControlRef
v -> ControlRef -> Val
DeriveT.VControlRef ControlRef
v
    VConstantPitch (ConstantPitch ScaleId
scale_id Note
note NoteNumber
nn) ->
        Pitch -> Val
DeriveT.VPitch forall a b. (a -> b) -> a -> b
$ ScaleId -> Note -> NoteNumber -> Pitch
PSignal.constant_pitch ScaleId
scale_id Note
note NoteNumber
nn
    VNotePitch Pitch
v -> Pitch -> Val
DeriveT.VNotePitch Pitch
v
    VStr Str
v -> Str -> Val
DeriveT.VStr Str
v
    VQuoted Expr
v -> Quoted -> Val
DeriveT.VQuoted forall a b. (a -> b) -> a -> b
$ Expr -> Quoted
DeriveT.Quoted forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Expr a -> Expr b
Expr.map_literals Val -> Val
promote Expr
v
    VList [Val]
v -> [Val] -> Val
DeriveT.VList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Val -> Val
promote [Val]
v

instance Pretty Val where format :: Val -> Doc
format = forall a. Pretty a => a -> Doc
Pretty.format forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Val
promote
instance ShowVal.ShowVal Val where show_val :: Val -> Key
show_val = forall a. ShowVal a => a -> Key
ShowVal.show_val forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Val
promote

-- | This duplicates 'TrackLang.Typecheck', but then so does this whole module.
-- In any case, it's convenient for creaing 'Environ's.
--
-- TODO But I wish I could reuse Typecheck.ToVal, otherwise I have to add an
-- extra instance declaration for each type.
class ToVal a where
    to_val :: a -> Val
    default to_val :: ShowVal.ShowVal a => a -> Val
    to_val = Str -> Val
VStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Str
Expr.Str forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Key
ShowVal.show_val

-- ** VNum

instance ToVal Val where to_val :: Val -> Val
to_val = forall a. a -> a
id
instance ToVal Double where to_val :: Y -> Val
to_val = Typed Y -> Val
VNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Typed a
ScoreT.untyped
instance ToVal Int where to_val :: Int -> Val
to_val = Typed Y -> Val
VNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Typed a
ScoreT.untyped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
instance ToVal Pitch.NoteNumber where
    to_val :: NoteNumber -> Val
to_val = Typed Y -> Val
VNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Y
Pitch.nn_to_double
instance ToVal Pitch.Transpose where
    to_val :: Transpose -> Val
to_val Transpose
n = case Transpose
n of
        Pitch.Diatonic Y
n -> Typed Y -> Val
VNum forall a b. (a -> b) -> a -> b
$ forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Diatonic Y
n
        Pitch.Chromatic Y
n -> Typed Y -> Val
VNum forall a b. (a -> b) -> a -> b
$ forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Chromatic Y
n
        Pitch.Nn Y
n -> Typed Y -> Val
VNum forall a b. (a -> b) -> a -> b
$ forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Nn Y
n
instance ToVal ScoreTime where
    to_val :: ScoreTime -> Val
to_val = Typed Y -> Val
VNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Score forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Y
ScoreTime.to_double
instance ToVal RealTime where
    to_val :: RealTime -> Val
to_val = Typed Y -> Val
VNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Type -> a -> Typed a
ScoreT.Typed Type
ScoreT.Real forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Y
RealTime.to_seconds

instance ToVal a => ToVal [a] where to_val :: [a] -> Val
to_val = [Val] -> Val
VList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ToVal a => a -> Val
to_val

-- ** rest

instance ToVal Attrs.Attributes where to_val :: Attributes -> Val
to_val = Attributes -> Val
VAttributes
instance ToVal DeriveT.ControlRef where to_val :: ControlRef -> Val
to_val = ControlRef -> Val
VControlRef
instance ToVal Pitch.Pitch where to_val :: Pitch -> Val
to_val = Pitch -> Val
VNotePitch
instance ToVal ScoreT.Instrument where
    to_val :: Instrument -> Val
to_val (ScoreT.Instrument Key
a) = Str -> Val
VStr (Key -> Str
Expr.Str Key
a)
instance ToVal Expr.Str where to_val :: Str -> Val
to_val = Str -> Val
VStr
instance ToVal Text where to_val :: Key -> Val
to_val = Str -> Val
VStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Str
Expr.Str
instance ToVal Expr where to_val :: Expr -> Val
to_val = Expr -> Val
VQuoted

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

instance ToVal ConstantPitch where to_val :: ConstantPitch -> Val
to_val = ConstantPitch -> Val
VConstantPitch

-- * call

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

instance Serialize.Serialize Val where
    put :: Putter Val
put Val
val = case Val
val of
        VNum Typed Y
v -> Word8 -> Put
Serialize.put_tag Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Typed Y
v
        VAttributes Attributes
v -> Word8 -> Put
Serialize.put_tag Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Attributes
v
        VControlRef ControlRef
v -> Word8 -> Put
Serialize.put_tag Word8
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put ControlRef
v
        VNotePitch Pitch
v -> Word8 -> Put
Serialize.put_tag Word8
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Pitch
v
        -- tag 4 was VInstrument
        VStr Str
v -> Word8 -> Put
Serialize.put_tag Word8
5 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Str
v
        VQuoted Expr
v -> Word8 -> Put
Serialize.put_tag Word8
6 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Expr
v
        VList [Val]
v -> Word8 -> Put
Serialize.put_tag Word8
7 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put [Val]
v
        VConstantPitch (ConstantPitch ScaleId
scale_id Note
note NoteNumber
nn) -> Word8 -> Put
Serialize.put_tag Word8
8
            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put ScaleId
scale_id forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Note
note forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put NoteNumber
nn
    get :: Get Val
get = do
        Word8
tag <- Get Word8
Serialize.get_tag
        case Word8
tag of
            Word8
0 -> Typed Y -> Val
VNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
            Word8
1 -> Attributes -> Val
VAttributes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
            Word8
2 -> ControlRef -> Val
VControlRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
            Word8
3 -> Pitch -> Val
VNotePitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
            Word8
4 -> Str -> Val
VStr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get -- tag 4 was VInstrument
            Word8
5 -> Str -> Val
VStr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
            Word8
6 -> Expr -> Val
VQuoted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
            Word8
7 -> [Val] -> Val
VList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
            Word8
8 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConstantPitch -> Val
VConstantPitch forall a b. (a -> b) -> a -> b
$ ScaleId -> Note -> NoteNumber -> ConstantPitch
ConstantPitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get
            Word8
_ -> forall a. String -> Word8 -> Get a
Serialize.bad_tag String
"REnv.Val" Word8
tag

instance Serialize.Serialize Call where
    put :: Putter (Call Val)
put (Expr.Call Symbol
a [Term Val]
b) = forall a. Serialize a => Putter a
put Symbol
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put [Term Val]
b
    get :: Get (Call Val)
get = forall val. Symbol -> [Term val] -> Call val
Expr.Call forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
get

instance Serialize.Serialize Term where
    put :: Putter (Term Val)
put Term Val
term = case Term Val
term of
        Expr.ValCall Call Val
v -> Word8 -> Put
Serialize.put_tag Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Call Val
v
        Expr.Literal Val
v -> Word8 -> Put
Serialize.put_tag Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
put Val
v
    get :: Get (Term Val)
get = Get Word8
Serialize.get_tag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Word8
0 -> forall val. Call val -> Term val
Expr.ValCall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
        Word8
1 -> forall val. val -> Term val
Expr.Literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
get
        Word8
n -> forall a. String -> Word8 -> Get a
Serialize.bad_tag String
"REnv.Term" Word8
n