-- | Additional variables and parameters.
module MCSP.Data.Meta (
    -- * Collection of variables
    VariableMap,
    lookup,

    -- * Data Class
    MetaInputVariable (..),
    MetaOutputVariable (..),

    -- * Monadic operations
    Meta,
    getOrDefine,
    setOutputVar,
    inspect,
    (<::),

    -- ** Execution
    evalMeta,
    runMeta,
) where

import Control.Applicative (Applicative)
import Control.Monad (Monad, (>>))
import Control.Monad.Trans.State.Strict (State, evalState, gets, modify, runState, state)
import Data.Function (id, ($), (.))
import Data.Functor (Functor (..))
import Data.Maybe (Maybe (..))
import Data.TypeMap.Dynamic.Alt qualified as Map (Item, TypeMap, empty, insert, lookup, map, toList)
import Data.Typeable (Typeable, showsTypeRep, typeOf)
import Text.Show (Show (..), showChar, showListWith, showString)

-- ---------- --
-- Collection --

-- | A fully dynamic `TypeMap` mapping from a type to itself.
data Dynamic

type instance Map.Item Dynamic v = v

-- | A polymorphic storage of `MetaVariable`s.
newtype VariableMap = VariableMap (Map.TypeMap Dynamic)

instance Show VariableMap where
    showsPrec :: Int -> VariableMap -> ShowS
showsPrec Int
_ (VariableMap TypeMap Dynamic
vars) =
        String -> ShowS
showString String
"VariableMap"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS) -> [ShowS] -> ShowS
forall a. (a -> ShowS) -> [a] -> ShowS
showListWith ShowS -> ShowS
forall a. a -> a
id [ShowS]
keys
      where
        keys :: [ShowS]
keys = TypeMap (OfType ShowS) -> [ShowS]
forall r. TypeMap (OfType r) -> [r]
Map.toList (TypeMap (OfType ShowS) -> [ShowS])
-> TypeMap (OfType ShowS) -> [ShowS]
forall a b. (a -> b) -> a -> b
$ (forall t. Typeable t => Item Dynamic t -> Item (OfType ShowS) t)
-> TypeMap Dynamic -> TypeMap (OfType ShowS)
forall x y.
(forall t. Typeable t => Item x t -> Item y t)
-> TypeMap x -> TypeMap y
Map.map (TypeRep -> ShowS
showsTypeRep (TypeRep -> ShowS) -> (t -> TypeRep) -> t -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf) TypeMap Dynamic
vars

-- | A map with no variables set.
--
-- >>> empty
-- VariableMap []
empty :: VariableMap
empty :: VariableMap
empty = TypeMap Dynamic -> VariableMap
VariableMap TypeMap Dynamic
forall x. TypeMap x
Map.empty
{-# INLINEABLE empty #-}

-- | Insert a meta-variable into the map.
--
-- >>> import Prelude (Int)
--
-- >>> insert @Int 12 empty
-- VariableMap [Int]
insert :: Typeable v => v -> VariableMap -> VariableMap
insert :: forall v. Typeable v => v -> VariableMap -> VariableMap
insert v
value (VariableMap TypeMap Dynamic
vm) = TypeMap Dynamic -> VariableMap
VariableMap (Item Dynamic v -> TypeMap Dynamic -> TypeMap Dynamic
forall t x. Typeable t => Item x t -> TypeMap x -> TypeMap x
Map.insert v
Item Dynamic v
value TypeMap Dynamic
vm)
{-# INLINEABLE insert #-}

-- | Return `Just` the value a meta-variable of the given type, or `Nothing` if no such variable is
-- available.
--
-- >>> import Prelude (Int)
-- >>> instance MetaOutputVariable Int
--
-- >>> lookup @Int empty
-- Nothing
--
-- >>> let (_, vars) = runMeta (setVar (12 :: Int))
-- >>> lookup @Int vars
-- Just 12
lookup :: Typeable v => VariableMap -> Maybe v
lookup :: forall v. Typeable v => VariableMap -> Maybe v
lookup (VariableMap TypeMap Dynamic
vars) = TypeMap Dynamic -> Maybe (Item Dynamic v)
forall t x. Typeable t => TypeMap x -> Maybe (Item x t)
Map.lookup TypeMap Dynamic
vars
{-# INLINEABLE lookup #-}

-- | Return the previous value of a `MetaVariable` of the given type, or insert and return the
-- default value if no such variable is available.
--
-- >>> import Prelude (Int)
-- >>> instance MetaOutputVariable Int
--
-- >>> lookupOrInsert (12 :: Int) empty
-- (12,VariableMap [Int])
--
-- >>> let (_, vars) = runMeta (setVar (34 :: Int))
-- >>> lookupOrInsert (12 :: Int) vars
-- (34,VariableMap [Int])
lookupOrInsert :: Typeable v => v -> VariableMap -> (v, VariableMap)
lookupOrInsert :: forall v. Typeable v => v -> VariableMap -> (v, VariableMap)
lookupOrInsert v
defaultValue VariableMap
vars = case VariableMap -> Maybe v
forall v. Typeable v => VariableMap -> Maybe v
lookup VariableMap
vars of
    Just v
value -> (v
value, VariableMap
vars)
    Maybe v
Nothing -> (v
defaultValue, v -> VariableMap -> VariableMap
forall v. Typeable v => v -> VariableMap -> VariableMap
insert v
defaultValue VariableMap
vars)
{-# INLINEABLE lookupOrInsert #-}

-- ---------------------- --
-- Dynamic Variable Class --

-- | Represents a additional variable that can be used as input of a computation.
--
-- These variables are set and resolved dynamically inside the `Meta` monad.
class Typeable v => MetaInputVariable v where
    -- | Extracts the input variable, possibly modifying the environment.
    getVar :: Meta v

-- | Represents a additional variable that can be set as output of a computation.
--
-- These variables are set and resolved dynamically inside the `Meta` monad.
class Typeable v => MetaOutputVariable v where
    -- | Updates the output variable, possibly modifying the environment.
    setVar :: v -> Meta ()
    setVar = v -> Meta ()
forall v. MetaOutputVariable v => v -> Meta ()
setOutputVar

-- ----------------- --
-- Monadic Operation --

-- | A monad that represents operation with meta-variables.
--
-- The meta-variables may be used as input, output or both.
newtype Meta a = Meta (State VariableMap a)
    deriving newtype ((forall a b. (a -> b) -> Meta a -> Meta b)
-> (forall a b. a -> Meta b -> Meta a) -> Functor Meta
forall a b. a -> Meta b -> Meta a
forall a b. (a -> b) -> Meta a -> Meta b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Meta a -> Meta b
fmap :: forall a b. (a -> b) -> Meta a -> Meta b
$c<$ :: forall a b. a -> Meta b -> Meta a
<$ :: forall a b. a -> Meta b -> Meta a
Functor, Functor Meta
Functor Meta =>
(forall a. a -> Meta a)
-> (forall a b. Meta (a -> b) -> Meta a -> Meta b)
-> (forall a b c. (a -> b -> c) -> Meta a -> Meta b -> Meta c)
-> (forall a b. Meta a -> Meta b -> Meta b)
-> (forall a b. Meta a -> Meta b -> Meta a)
-> Applicative Meta
forall a. a -> Meta a
forall a b. Meta a -> Meta b -> Meta a
forall a b. Meta a -> Meta b -> Meta b
forall a b. Meta (a -> b) -> Meta a -> Meta b
forall a b c. (a -> b -> c) -> Meta a -> Meta b -> Meta c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Meta a
pure :: forall a. a -> Meta a
$c<*> :: forall a b. Meta (a -> b) -> Meta a -> Meta b
<*> :: forall a b. Meta (a -> b) -> Meta a -> Meta b
$cliftA2 :: forall a b c. (a -> b -> c) -> Meta a -> Meta b -> Meta c
liftA2 :: forall a b c. (a -> b -> c) -> Meta a -> Meta b -> Meta c
$c*> :: forall a b. Meta a -> Meta b -> Meta b
*> :: forall a b. Meta a -> Meta b -> Meta b
$c<* :: forall a b. Meta a -> Meta b -> Meta a
<* :: forall a b. Meta a -> Meta b -> Meta a
Applicative, Applicative Meta
Applicative Meta =>
(forall a b. Meta a -> (a -> Meta b) -> Meta b)
-> (forall a b. Meta a -> Meta b -> Meta b)
-> (forall a. a -> Meta a)
-> Monad Meta
forall a. a -> Meta a
forall a b. Meta a -> Meta b -> Meta b
forall a b. Meta a -> (a -> Meta b) -> Meta b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Meta a -> (a -> Meta b) -> Meta b
>>= :: forall a b. Meta a -> (a -> Meta b) -> Meta b
$c>> :: forall a b. Meta a -> Meta b -> Meta b
>> :: forall a b. Meta a -> Meta b -> Meta b
$creturn :: forall a. a -> Meta a
return :: forall a. a -> Meta a
Monad)

-- | Get the value of an input meta-variable or set a default one.
--
-- >>> import Prelude (String)
-- >>> instance MetaInputVariable String where getVar = getOrDefine ""
--
-- >>> runMeta (getOrDefine "default")
-- ("default",VariableMap [[Char]])
--
-- >>> runMeta (getOrDefine "default" <:: "pre-set")
-- ("pre-set",VariableMap [[Char]])
getOrDefine :: MetaInputVariable v => v -> Meta v
getOrDefine :: forall v. MetaInputVariable v => v -> Meta v
getOrDefine v
value = State VariableMap v -> Meta v
forall a. State VariableMap a -> Meta a
Meta (State VariableMap v -> Meta v) -> State VariableMap v -> Meta v
forall a b. (a -> b) -> a -> b
$ (VariableMap -> (v, VariableMap)) -> State VariableMap v
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (v -> VariableMap -> (v, VariableMap)
forall v. Typeable v => v -> VariableMap -> (v, VariableMap)
lookupOrInsert v
value)
{-# INLINEABLE getOrDefine #-}

-- | Set the value of meta-variable for the given type, without any additional side-effect.
--
-- >>> import Prelude (Int)
-- >>> instance MetaOutputVariable Int where
-- >>>     setVar = setOutputVar
--
-- >>> runMeta (setOutputVar @Int 12)
-- ((),VariableMap [Int])
setOutputVar :: MetaOutputVariable v => v -> Meta ()
setOutputVar :: forall v. MetaOutputVariable v => v -> Meta ()
setOutputVar v
value = State VariableMap () -> Meta ()
forall a. State VariableMap a -> Meta a
Meta ((VariableMap -> VariableMap) -> State VariableMap ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((VariableMap -> VariableMap) -> State VariableMap ())
-> (VariableMap -> VariableMap) -> State VariableMap ()
forall a b. (a -> b) -> a -> b
$ v -> VariableMap -> VariableMap
forall v. Typeable v => v -> VariableMap -> VariableMap
insert v
value)
{-# INLINEABLE setOutputVar #-}

-- | Set an input meta-variable for the given type.
--
-- >>> import Prelude (Int)
-- >>> instance MetaInputVariable Int where getVar = getOrDefine 0
--
-- >>> runMeta (getVar @Int <:: (12 :: Int))
-- (12,VariableMap [Int])
(<::) :: MetaInputVariable v => Meta a -> v -> Meta a
Meta a
m <:: :: forall v a. MetaInputVariable v => Meta a -> v -> Meta a
<:: v
value = State VariableMap () -> Meta ()
forall a. State VariableMap a -> Meta a
Meta ((VariableMap -> VariableMap) -> State VariableMap ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((VariableMap -> VariableMap) -> State VariableMap ())
-> (VariableMap -> VariableMap) -> State VariableMap ()
forall a b. (a -> b) -> a -> b
$ v -> VariableMap -> VariableMap
forall v. Typeable v => v -> VariableMap -> VariableMap
insert v
value) Meta () -> Meta a -> Meta a
forall a b. Meta a -> Meta b -> Meta b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Meta a
m
{-# INLINEABLE (<::) #-}

-- | Get a meta-variable for the expected type.
--
-- >>> import Prelude (Int)
-- >>> instance MetaOutputVariable Int
--
-- >>> runMeta (inspect @Int)
-- (Nothing,VariableMap [])
--
-- >>> runMeta (setVar (12 :: Int) >> inspect @Int)
-- (Just 12,VariableMap [Int])
inspect :: MetaOutputVariable v => Meta (Maybe v)
inspect :: forall v. MetaOutputVariable v => Meta (Maybe v)
inspect = State VariableMap (Maybe v) -> Meta (Maybe v)
forall a. State VariableMap a -> Meta a
Meta (State VariableMap (Maybe v) -> Meta (Maybe v))
-> State VariableMap (Maybe v) -> Meta (Maybe v)
forall a b. (a -> b) -> a -> b
$ (VariableMap -> Maybe v) -> State VariableMap (Maybe v)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets VariableMap -> Maybe v
forall v. Typeable v => VariableMap -> Maybe v
lookup
{-# INLINEABLE inspect #-}

-- | Execute a `Meta` monad and return the output.
evalMeta :: Meta a -> a
evalMeta :: forall a. Meta a -> a
evalMeta (Meta State VariableMap a
m) = State VariableMap a -> VariableMap -> a
forall s a. State s a -> s -> a
evalState State VariableMap a
m VariableMap
empty
{-# INLINEABLE evalMeta #-}

-- | Execute a `Meta` monad and return the output and the final variables.
runMeta :: Meta a -> (a, VariableMap)
runMeta :: forall a. Meta a -> (a, VariableMap)
runMeta (Meta State VariableMap a
m) = State VariableMap a -> VariableMap -> (a, VariableMap)
forall s a. State s a -> s -> (a, s)
runState State VariableMap a
m VariableMap
empty
{-# INLINEABLE runMeta #-}