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

module Derive.Env (
    Key, Environ, null, lookup, insert
    , from_list, to_list
    , to_map, from_map
    , delete
    , is_set
    , map
    , from_controls
    -- * put
    , put_val
    , modify_signal
    , insert_val
    , LookupError(..)
    , get_val
    , maybe_val
    , checked_val, checked_val2
) where
import qualified Prelude
import           Prelude hiding (map, null, lookup)
import qualified Data.Map as Map

import qualified Derive.DeriveT as DeriveT
import           Derive.DeriveT (Environ(..), insert, lookup, null)
import qualified Derive.EnvKey as EnvKey
import           Derive.EnvKey (Key)
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Typecheck as Typecheck
import qualified Derive.ValType as ValType

import           Global


-- * basic functions

from_list :: [(Key, DeriveT.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

to_list :: Environ -> [(Key, DeriveT.Val)]
to_list :: Environ -> [(Key, Val)]
to_list (Environ Map Key Val
env) = forall k a. Map k a -> [(k, a)]
Map.toList Map Key Val
env

to_map :: Environ -> Map Key DeriveT.Val
to_map :: Environ -> Map Key Val
to_map (Environ Map Key Val
env) = Map Key Val
env

from_map :: Map Key DeriveT.Val -> Environ
from_map :: Map Key Val -> Environ
from_map = Map Key Val -> Environ
Environ

delete :: Key -> Environ -> Environ
delete :: Key -> Environ -> Environ
delete Key
key (Environ Map Key Val
env) = Map Key Val -> Environ
Environ forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
key Map Key Val
env

is_set :: Key -> Environ -> Bool
is_set :: Key -> Environ -> Bool
is_set Key
key (Environ Map Key Val
env) = forall k a. Ord k => k -> Map k a -> Bool
Map.member Key
key Map Key Val
env

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

from_controls :: ScoreT.ControlMap -> Environ
from_controls :: ControlMap -> Environ
from_controls = Map Key Val -> Environ
from_map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
Prelude.map (Control, TypedSignal) -> (Key, Val)
convert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
    where
    convert :: (Control, TypedSignal) -> (Key, Val)
convert (ScoreT.Control Key
control, TypedSignal
sig) = (Key
control, TypedSignal -> Val
DeriveT.VSignal TypedSignal
sig)

-- * typechecking

type Error = Text

-- | Insert a new val, but return Left if it changes the type of an existing
-- one, so once you put a key of a given type into the environ, it can only
-- ever be overwritten by a Val of the same type.  The idea is that being
-- inconsistent with types will just lead to confusion.
--
-- 'DeriveT.VNotGiven' is another special case, it deletes the given key.
put_val :: Typecheck.ToVal a => Key -> a -> Environ -> Either Error Environ
put_val :: forall a. ToVal a => Key -> a -> Environ -> Either Key Environ
put_val Key
key a
val Environ
environ = case Key -> Environ -> Maybe Val
lookup Key
key Environ
environ of
    Maybe Val
Nothing -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Map Key Val
hardcoded_types of
        Just Val
expected | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Val -> Val -> Bool
DeriveT.types_equal Val
expected Val
rhs ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> Val -> Type -> Key
type_error Key
key Val
rhs (Val -> Type
ValType.general_type_of Val
expected)
        Maybe Val
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ case Val
rhs of
            Val
DeriveT.VNotGiven -> Environ
environ
            Val
_ -> Key -> Val -> Environ -> Environ
insert Key
key Val
rhs Environ
environ
    Just Val
lhs -> (Val, Val) -> Either Key Environ
assign (Val
lhs, Val
rhs)
    where
    rhs :: Val
rhs = forall a. ToVal a => a -> Val
Typecheck.to_val a
val
    assign :: (Val, Val) -> Either Key Environ
assign = \case
        (Val
_, Val
DeriveT.VNotGiven) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Key -> Environ -> Environ
delete Key
key Environ
environ
        (DeriveT.VCFunction CFunction
cf, Val
rhs)
            | Just Val
cf <- CFunction -> Val -> Maybe Val
merge_cf CFunction
cf Val
rhs -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Val -> Environ
add Val
cf
        (Val
lhs, DeriveT.VCFunction CFunction
cf)
            | Just Val
cf <- CFunction -> Val -> Maybe Val
merge_cf CFunction
cf Val
lhs -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Val -> Environ
add Val
cf
        (Val
lhs, Val
rhs)
            | Val -> Val -> Bool
DeriveT.types_equal Val
lhs Val
rhs -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Val -> Environ
add Val
rhs
            | Bool
otherwise ->
                forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key -> Val -> Type -> Key
type_error Key
key Val
rhs (Val -> Type
ValType.general_type_of Val
lhs)
    merge_cf :: CFunction -> Val -> Maybe Val
merge_cf CFunction
cf = \case
        DeriveT.VSignal TypedSignal
sig ->
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CFunction -> Val
DeriveT.VCFunction forall a b. (a -> b) -> a -> b
$ CFunction
cf { cf_signal :: TypedSignal
DeriveT.cf_signal = TypedSignal
sig }
        -- Anything else gets type checked and replaced.
        Val
_ -> forall a. Maybe a
Nothing
    add :: Val -> Environ
add Val
rhs = Key -> Val -> Environ -> Environ
insert Key
key Val
rhs Environ
environ

modify_signal :: (Maybe ScoreT.TypedSignal -> ScoreT.TypedSignal) -> Key
    -> Environ -> Either Error DeriveT.Val
modify_signal :: (Maybe TypedSignal -> TypedSignal)
-> Key -> Environ -> Either Key Val
modify_signal Maybe TypedSignal -> TypedSignal
modify Key
key Environ
environ = case Key -> Environ -> Maybe Val
lookup Key
key Environ
environ of
    Maybe Val
Nothing -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToVal a => a -> Val
Typecheck.to_val forall a b. (a -> b) -> a -> b
$ Maybe TypedSignal -> TypedSignal
modify forall a. Maybe a
Nothing
    Just Val
val -> (TypedSignal -> TypedSignal) -> Val -> Either Key Val
modify_signal_val (Maybe TypedSignal -> TypedSignal
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Val
val

modify_signal_val :: (ScoreT.TypedSignal -> ScoreT.TypedSignal) -> DeriveT.Val
    -> Either Error DeriveT.Val
modify_signal_val :: (TypedSignal -> TypedSignal) -> Val -> Either Key Val
modify_signal_val TypedSignal -> TypedSignal
modify = \case
    DeriveT.VSignal TypedSignal
sig -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ TypedSignal -> Val
DeriveT.VSignal forall a b. (a -> b) -> a -> b
$ TypedSignal -> TypedSignal
modify TypedSignal
sig
    DeriveT.VCFunction CFunction
cf -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ CFunction -> Val
DeriveT.VCFunction forall a b. (a -> b) -> a -> b
$
        CFunction
cf { cf_signal :: TypedSignal
DeriveT.cf_signal = TypedSignal -> TypedSignal
modify (CFunction -> TypedSignal
DeriveT.cf_signal CFunction
cf) }
    Val
val -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Key
"can't modify " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty (Val -> Type
ValType.general_type_of Val
val)
        forall a. Semigroup a => a -> a -> a
<> Key
" as a signal"

type_error :: Key -> DeriveT.Val -> ValType.Type -> Error
type_error :: Key -> Val -> Type -> Key
type_error Key
key Val
val Type
expected = forall a. Monoid a => [a] -> a
mconcat
    [ Key
"can't set ", forall a. Pretty a => a -> Key
pretty Key
key, Key
" to ", forall a. ShowVal a => a -> Key
ShowVal.show_val Val
val, Key
", expected "
    , forall a. Pretty a => a -> Key
pretty Type
expected, Key
" but got ", forall a. Pretty a => a -> Key
pretty (Val -> Type
ValType.general_type_of Val
val)
    ]

-- | Insert a val without typechecking.
insert_val :: Typecheck.ToVal a => Key -> a -> Environ -> Environ
insert_val :: forall a. ToVal a => Key -> a -> Environ -> Environ
insert_val Key
key = Key -> Val -> Environ -> Environ
insert Key
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToVal a => a -> Val
Typecheck.to_val

-- | If a standard val gets set to the wrong type, it will cause confusing
-- errors later on.
hardcoded_types :: Map Key DeriveT.Val
hardcoded_types :: Map Key Val
hardcoded_types = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Key
EnvKey.attributes,  Attributes -> Val
DeriveT.VAttributes forall a. Monoid a => a
mempty)
    , (Key
EnvKey.block_end,   Type -> Y -> Val
DeriveT.constant Type
ScoreT.Score Y
0)
    , (Key
EnvKey.control,     Val
str)
    , (Key
EnvKey.instrument,  Val
str)
    , (Key
EnvKey.key,         Val
str)
    , (Key
EnvKey.merge,       Val
str)
    , (Key
EnvKey.scale,       Val
str)
    , (Key
EnvKey.seed,        Val
num)
    , (Key
EnvKey.srate,       Val
num)
    , (Key
EnvKey.suppress_until, Type -> Y -> Val
DeriveT.constant Type
ScoreT.Real Y
0)
    , (Key
EnvKey.tuning,      Val
str)
    , (Key
EnvKey.voice,       Val
num)
    ]
    where
    str :: Val
str = Str -> Val
DeriveT.VStr Str
""
    num :: Val
num = Y -> Val
DeriveT.num Y
0

data LookupError = NotFound | WrongType !ValType.Type deriving (Int -> LookupError -> ShowS
[LookupError] -> ShowS
LookupError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LookupError] -> ShowS
$cshowList :: [LookupError] -> ShowS
show :: LookupError -> String
$cshow :: LookupError -> String
showsPrec :: Int -> LookupError -> ShowS
$cshowsPrec :: Int -> LookupError -> ShowS
Show)

get_val :: Typecheck.Typecheck a => Key -> Environ -> Either LookupError a
get_val :: forall a. Typecheck a => Key -> Environ -> Either LookupError a
get_val Key
key Environ
environ = case Key -> Environ -> Maybe Val
lookup Key
key Environ
environ of
    Maybe Val
Nothing -> forall a b. a -> Either a b
Left LookupError
NotFound
    Just Val
val -> case forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple Val
val of
        Maybe a
Nothing -> forall a b. a -> Either a b
Left (Type -> LookupError
WrongType (Val -> Type
ValType.general_type_of Val
val))
        Just a
a -> forall a b. b -> Either a b
Right a
a

-- | Like 'get_val', except that type errors and not found both turn into
-- Nothing.
maybe_val :: Typecheck.Typecheck a => Key -> Environ -> Maybe a
maybe_val :: forall a. Typecheck a => Key -> Environ -> Maybe a
maybe_val Key
key = forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Key -> Environ -> Maybe Val
lookup Key
key

-- | Like 'get_val' but format a WrongType nicely.
checked_val :: forall a. Typecheck.Typecheck a => Key -> Environ
    -> Either Text (Maybe a)
checked_val :: forall a. Typecheck a => Key -> Environ -> Either Key (Maybe a)
checked_val Key
key Environ
environ = case forall a. Typecheck a => Key -> Environ -> Either LookupError a
get_val Key
key Environ
environ of
    Left LookupError
NotFound -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Left (WrongType Type
typ) ->
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Key
pretty Key
key forall a. Semigroup a => a -> a -> a
<> Key
": expected " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty Type
return_type
            forall a. Semigroup a => a -> a -> a
<> Key
" but env val is " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty Type
typ
    Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
a)
    where return_type :: Type
return_type = forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

-- | Like 'checked_val', but juggle the return type around so NotFound is just
-- Nothing, which is more convenient in some cases.
checked_val2 :: Typecheck.Typecheck a => Key -> Environ
    -> Maybe (Either Text a)
checked_val2 :: forall a. Typecheck a => Key -> Environ -> Maybe (Either Key a)
checked_val2 Key
key Environ
environ = case forall a. Typecheck a => Key -> Environ -> Either Key (Maybe a)
checked_val Key
key Environ
environ of
    Right Maybe a
Nothing -> forall a. Maybe a
Nothing
    Right (Just a
val) -> forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right a
val)
    Left Key
err -> forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left Key
err)