-- 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 (
    module Derive.Env
    , Key, Environ, lookup, insert
) where
import           Prelude hiding (null, lookup)
import qualified Data.Map as Map

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

import           Global


-- * basic functions

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

from_list :: [(Key, DeriveT.Val)] -> Environ
from_list :: [(Key, Val)] -> Environ
from_list = Map Key Val -> Environ
Environ (Map Key Val -> Environ)
-> ([(Key, Val)] -> Map Key Val) -> [(Key, Val)] -> Environ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Val)] -> Map Key Val
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) = Map Key Val -> [(Key, Val)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Key Val
env

delete :: Key -> Environ -> Environ
delete :: Key -> Environ -> Environ
delete Key
key (Environ Map Key Val
env) = Map Key Val -> Environ
Environ (Map Key Val -> Environ) -> Map Key Val -> Environ
forall a b. (a -> b) -> a -> b
$ Key -> Map Key Val -> Map Key Val
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) = Key -> Map Key Val -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Key
key Map Key Val
env

-- * typechecking

-- | 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 ValType.Type Environ
put_val :: forall a. ToVal a => Key -> a -> Environ -> Either Type Environ
put_val Key
key a
val Environ
environ
    | Val
DeriveT.VNotGiven <- Val
new_val = Environ -> Either Type Environ
forall a b. b -> Either a b
Right (Environ -> Either Type Environ) -> Environ -> Either Type Environ
forall a b. (a -> b) -> a -> b
$ Key -> Environ -> Environ
delete Key
key Environ
environ
    | Bool
otherwise = case Key -> Environ -> Maybe Val
lookup Key
key Environ
environ of
        Maybe Val
Nothing -> case Key -> Map Key Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key Map Key Type
hardcoded_types of
            Just Type
expected | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
                Type -> Type -> Bool
ValType.types_match Type
expected (Val -> Type
ValType.type_of Val
new_val) ->
                    Type -> Either Type Environ
forall a b. a -> Either a b
Left Type
expected
            Maybe Type
_ -> Environ -> Either Type Environ
forall a b. b -> Either a b
Right (Environ -> Either Type Environ) -> Environ -> Either Type Environ
forall a b. (a -> b) -> a -> b
$ Key -> Val -> Environ -> Environ
insert Key
key Val
new_val Environ
environ
        Just Val
old_val -> case Val -> Val -> Maybe Type
ValType.val_types_match Val
old_val Val
new_val of
            Just Type
expected -> Type -> Either Type Environ
forall a b. a -> Either a b
Left Type
expected
            Maybe Type
Nothing -> Environ -> Either Type Environ
forall a b. b -> Either a b
Right (Environ -> Either Type Environ) -> Environ -> Either Type Environ
forall a b. (a -> b) -> a -> b
$ Key -> Val -> Environ -> Environ
insert Key
key Val
new_val Environ
environ
    where new_val :: Val
new_val = a -> Val
forall a. ToVal a => a -> Val
Typecheck.to_val a
val

-- | Like 'put_val', but format the error msg.
put_val_error :: Typecheck.ToVal a => Key -> a -> Environ -> Either Text Environ
put_val_error :: forall a. ToVal a => Key -> a -> Environ -> Either Key Environ
put_val_error Key
key a
val = (Type -> Key) -> Either Type Environ -> Either Key Environ
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Type -> Key
forall {a}. Pretty a => a -> Key
fmt (Either Type Environ -> Either Key Environ)
-> (Environ -> Either Type Environ)
-> Environ
-> Either Key Environ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> a -> Environ -> Either Type Environ
forall a. ToVal a => Key -> a -> Environ -> Either Type Environ
put_val Key
key a
val
    where
    fmt :: a -> Key
fmt a
typ = Key
"can't set " Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key -> Key
forall {a}. Pretty a => a -> Key
pretty Key
key Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
" to "
        Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Val -> Key
forall a. ShowVal a => a -> Key
ShowVal.show_val (a -> Val
forall a. ToVal a => a -> Val
Typecheck.to_val a
val) Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
", expected "
        Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> a -> Key
forall {a}. Pretty a => a -> Key
pretty a
typ

-- | 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 (Val -> Environ -> Environ)
-> (a -> Val) -> a -> Environ -> Environ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Val
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 ValType.Type
hardcoded_types :: Map Key Type
hardcoded_types = [(Key, Type)] -> Map Key Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Key
EnvKey.attributes,  Type
ValType.TAttributes)
    , (Key
EnvKey.block_end,   NumType -> NumValue -> Type
ValType.TNum NumType
ValType.TScoreTime NumValue
ValType.TAny)
    , (Key
EnvKey.control,     Maybe [Key] -> Type
ValType.TStr Maybe [Key]
forall a. Maybe a
Nothing)
    , (Key
EnvKey.instrument,  Maybe [Key] -> Type
ValType.TStr Maybe [Key]
forall a. Maybe a
Nothing)
    , (Key
EnvKey.key,         Maybe [Key] -> Type
ValType.TStr Maybe [Key]
forall a. Maybe a
Nothing)
    , (Key
EnvKey.merge,       Maybe [Key] -> Type
ValType.TStr Maybe [Key]
forall a. Maybe a
Nothing)
    , (Key
EnvKey.scale,       Maybe [Key] -> Type
ValType.TStr Maybe [Key]
forall a. Maybe a
Nothing)
    , (Key
EnvKey.seed,        NumType -> NumValue -> Type
ValType.TNum NumType
ValType.TUntyped NumValue
ValType.TAny)
    , (Key
EnvKey.srate,       NumType -> NumValue -> Type
ValType.TNum NumType
ValType.TUntyped NumValue
ValType.TAny)
    , (Key
EnvKey.suppress_until, NumType -> NumValue -> Type
ValType.TNum NumType
ValType.TRealTime NumValue
ValType.TAny)
    , (Key
EnvKey.tuning,      Maybe [Key] -> Type
ValType.TStr Maybe [Key]
forall a. Maybe a
Nothing)
    , (Key
EnvKey.voice,       NumType -> NumValue -> Type
ValType.TNum NumType
ValType.TUntyped NumValue
ValType.TAny)
    ]

data LookupError = NotFound | WrongType !ValType.Type deriving (Int -> LookupError -> ShowS
[LookupError] -> ShowS
LookupError -> String
(Int -> LookupError -> ShowS)
-> (LookupError -> String)
-> ([LookupError] -> ShowS)
-> Show LookupError
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 -> LookupError -> Either LookupError a
forall a b. a -> Either a b
Left LookupError
NotFound
    Just Val
val -> case Val -> Maybe a
forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple Val
val of
        Maybe a
Nothing -> LookupError -> Either LookupError a
forall a b. a -> Either a b
Left (Type -> LookupError
WrongType (Val -> Type
ValType.type_of Val
val))
        Just a
v -> a -> Either LookupError a
forall a b. b -> Either a b
Right a
v

-- | 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 = Val -> Maybe a
forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple (Val -> Maybe a) -> (Environ -> Maybe Val) -> Environ -> Maybe a
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 Key -> Environ -> Either LookupError a
forall a. Typecheck a => Key -> Environ -> Either LookupError a
get_val Key
key Environ
environ of
    Left LookupError
NotFound -> Maybe a -> Either Key (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Left (WrongType Type
typ) ->
        Key -> Either Key (Maybe a)
forall a b. a -> Either a b
Left (Key -> Either Key (Maybe a)) -> Key -> Either Key (Maybe a)
forall a b. (a -> b) -> a -> b
$ Key -> Key
forall a. Show a => a -> Key
showt Key
key Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
": expected " Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Type -> Key
forall {a}. Pretty a => a -> Key
pretty Type
return_type
            Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
" but val type is " Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Type -> Key
forall {a}. Pretty a => a -> Key
pretty Type
typ
    Right a
v -> Maybe a -> Either Key (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
v)
    where return_type :: Type
return_type = Proxy a -> Type
forall a. Typecheck a => Proxy a -> Type
Typecheck.to_type (Proxy a
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 Key -> Environ -> Either Key (Maybe a)
forall a. Typecheck a => Key -> Environ -> Either Key (Maybe a)
checked_val Key
key Environ
environ of
    Right Maybe a
Nothing -> Maybe (Either Key a)
forall a. Maybe a
Nothing
    Right (Just a
val) -> Either Key a -> Maybe (Either Key a)
forall a. a -> Maybe a
Just (a -> Either Key a
forall a b. b -> Either a b
Right a
val)
    Left Key
err -> Either Key a -> Maybe (Either Key a)
forall a. a -> Maybe a
Just (Key -> Either Key a
forall a b. a -> Either a b
Left Key
err)