{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoFieldSelectors #-}

-- | A map of 'Dynamic' values.
module Cauldron.Beans
  ( Beans,
    empty,
    insert,
    delete,
    restrictKeys,
    keysSet,
    singleton,
    fromDynList,
    toDynMap,

    -- * Looking for values
    taste,

    -- * Monoidal stuff
    unionBeansMonoidally,
    SomeMonoidTypeRep (..),
    someMonoidTypeRepMempty,

    -- * Re-exported
    toDyn,
  )
where

import Data.Dynamic
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Semigroup qualified
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Typeable
import GHC.IsList
import Type.Reflection (SomeTypeRep (..), eqTypeRep)
import Type.Reflection qualified

empty :: Beans
empty :: Beans
empty = Map TypeRep Dynamic -> Beans
Beans Map TypeRep Dynamic
forall k a. Map k a
Map.empty

insert :: forall bean. (Typeable bean) => bean -> Beans -> Beans
insert :: forall bean. Typeable bean => bean -> Beans -> Beans
insert bean
bean Beans {Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic
beanMap :: Beans -> Map TypeRep Dynamic
beanMap} =
  Beans {beanMap :: Map TypeRep Dynamic
beanMap = TypeRep -> Dynamic -> Map TypeRep Dynamic -> Map TypeRep Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean)) (bean -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn bean
bean) Map TypeRep Dynamic
beanMap}

delete :: TypeRep -> Beans -> Beans
delete :: TypeRep -> Beans -> Beans
delete TypeRep
tr Beans {Map TypeRep Dynamic
beanMap :: Beans -> Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic
beanMap} =
  Beans {beanMap :: Map TypeRep Dynamic
beanMap = TypeRep -> Map TypeRep Dynamic -> Map TypeRep Dynamic
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TypeRep
tr Map TypeRep Dynamic
beanMap}

-- | Restrict a 'Beans' map to only those 'TypeRep's found in a 'Set'.
restrictKeys :: Beans -> Set TypeRep -> Beans
restrictKeys :: Beans -> Set TypeRep -> Beans
restrictKeys Beans {Map TypeRep Dynamic
beanMap :: Beans -> Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic
beanMap} Set TypeRep
trs = Beans {beanMap :: Map TypeRep Dynamic
beanMap = Map TypeRep Dynamic -> Set TypeRep -> Map TypeRep Dynamic
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TypeRep Dynamic
beanMap Set TypeRep
trs}

singleton :: forall bean. (Typeable bean) => bean -> Beans
singleton :: forall bean. Typeable bean => bean -> Beans
singleton bean
bean = Map TypeRep Dynamic -> Beans
Beans do TypeRep -> Dynamic -> Map TypeRep Dynamic
forall k a. k -> a -> Map k a
Map.singleton (Proxy bean -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @bean)) (bean -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn bean
bean)

-- | Check if the 'Beans' map contains a value of type @bean@.
taste :: forall bean. (Typeable bean) => Beans -> Maybe bean
taste :: forall bean. Typeable bean => Beans -> Maybe bean
taste Beans {Map TypeRep Dynamic
beanMap :: Beans -> Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic
beanMap} =
  let tr :: TypeRep bean
tr = forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Type.Reflection.typeRep @bean
   in case TypeRep -> Map TypeRep Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TypeRep bean -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep TypeRep bean
tr) Map TypeRep Dynamic
beanMap of
        Just (Dynamic TypeRep a
tr' a
v) | Just bean :~~: a
HRefl <- TypeRep bean
tr TypeRep bean -> TypeRep a -> Maybe (bean :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a
tr' -> bean -> Maybe bean
forall a. a -> Maybe a
Just bean
a
v
        Maybe Dynamic
_ -> Maybe bean
forall a. Maybe a
Nothing

-- | A map of 'Dynamic' values, indexed by the 'TypeRep' of each 'Dynamic'.
-- Maintains the invariant that the 'TypeRep' of the key matches the 'TypeRep'
-- of the 'Dynamic'.
newtype Beans = Beans {Beans -> Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic}
  deriving newtype (Int -> Beans -> ShowS
[Beans] -> ShowS
Beans -> String
(Int -> Beans -> ShowS)
-> (Beans -> String) -> ([Beans] -> ShowS) -> Show Beans
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Beans -> ShowS
showsPrec :: Int -> Beans -> ShowS
$cshow :: Beans -> String
show :: Beans -> String
$cshowList :: [Beans] -> ShowS
showList :: [Beans] -> ShowS
Show)

-- | Union of two 'Beans' maps, right-biased: prefers values from the /right/
-- 'Beans' map when both contain the same 'TypeRep' key. (Note that
-- 'Data.Map.Map' is left-biased.)
instance Semigroup Beans where
  Beans {beanMap :: Beans -> Map TypeRep Dynamic
beanMap = Map TypeRep Dynamic
r1} <> :: Beans -> Beans -> Beans
<> Beans {beanMap :: Beans -> Map TypeRep Dynamic
beanMap = Map TypeRep Dynamic
r2} = Map TypeRep Dynamic -> Beans
Beans do (Dynamic -> Dynamic -> Dynamic)
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((Dynamic -> Dynamic -> Dynamic) -> Dynamic -> Dynamic -> Dynamic
forall a b c. (a -> b -> c) -> b -> a -> c
flip Dynamic -> Dynamic -> Dynamic
forall a b. a -> b -> a
const) Map TypeRep Dynamic
r1 Map TypeRep Dynamic
r2

instance Monoid Beans where
  mempty :: Beans
mempty = Map TypeRep Dynamic -> Beans
Beans Map TypeRep Dynamic
forall a. Monoid a => a
mempty

instance IsList Beans where
  type Item Beans = Dynamic
  toList :: Beans -> [Item Beans]
toList (Beans {Map TypeRep Dynamic
beanMap :: Beans -> Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic
beanMap}) = Map TypeRep Dynamic -> [Dynamic]
forall k a. Map k a -> [a]
Map.elems Map TypeRep Dynamic
beanMap
  fromList :: [Item Beans] -> Beans
fromList = [Dynamic] -> Beans
[Item Beans] -> Beans
fromDynList

-- |
-- >>> :{
-- let beans = fromDynList [toDyn False, toDyn @Int 5]
--  in (taste @Bool beans, taste @Int beans, taste @String beans)
-- :}
-- (Just False,Just 5,Nothing)
fromDynList :: [Dynamic] -> Beans
fromDynList :: [Dynamic] -> Beans
fromDynList [Dynamic]
ds = Map TypeRep Dynamic -> Beans
Beans do [(TypeRep, Dynamic)] -> Map TypeRep Dynamic
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList do [Dynamic]
ds [Dynamic]
-> (Dynamic -> (TypeRep, Dynamic)) -> [(TypeRep, Dynamic)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Dynamic
d -> (Dynamic -> TypeRep
dynTypeRep Dynamic
d, Dynamic
d)

toDynMap :: Beans -> Map TypeRep Dynamic
toDynMap :: Beans -> Map TypeRep Dynamic
toDynMap Beans {Map TypeRep Dynamic
beanMap :: Beans -> Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic
beanMap} = Map TypeRep Dynamic
beanMap

-- | Like 'SomeTypeRep', but also remembering that the type has a 'Monoid' instance, which can be \"recovered\"
-- after pattern-matching on the 'SomeMonoidTypeRep'.
data SomeMonoidTypeRep where
  SomeMonoidTypeRep ::
    forall a.
    (Monoid a) =>
    Type.Reflection.TypeRep a ->
    SomeMonoidTypeRep

instance Show SomeMonoidTypeRep where
  show :: SomeMonoidTypeRep -> String
show (SomeMonoidTypeRep TypeRep a
tr) = TypeRep a -> String
forall a. Show a => a -> String
show TypeRep a
tr

instance Eq SomeMonoidTypeRep where
  (SomeMonoidTypeRep TypeRep a
tr1) == :: SomeMonoidTypeRep -> SomeMonoidTypeRep -> Bool
== (SomeMonoidTypeRep TypeRep a
tr2) =
    (TypeRep a -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep TypeRep a
tr1) TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== (TypeRep a -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep TypeRep a
tr2)

instance Ord SomeMonoidTypeRep where
  (SomeMonoidTypeRep TypeRep a
tr1) compare :: SomeMonoidTypeRep -> SomeMonoidTypeRep -> Ordering
`compare` (SomeMonoidTypeRep TypeRep a
tr2) =
    (TypeRep a -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep TypeRep a
tr1) TypeRep -> TypeRep -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (TypeRep a -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep TypeRep a
tr2)

-- | The 'mempty' value corresponding to the inner 'Type.Reflection.TypeRep'.
someMonoidTypeRepMempty :: SomeMonoidTypeRep -> Dynamic
someMonoidTypeRepMempty :: SomeMonoidTypeRep -> Dynamic
someMonoidTypeRepMempty (SomeMonoidTypeRep TypeRep a
tr) = TypeRep a -> (Typeable a => Dynamic) -> Dynamic
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
Type.Reflection.withTypeable TypeRep a
tr (TypeRep a -> Dynamic
forall t (proxy :: * -> *).
(Typeable t, Monoid t) =>
proxy t -> Dynamic
go TypeRep a
tr)
  where
    go :: forall t proxy. (Typeable t, Monoid t) => proxy t -> Dynamic
    go :: forall t (proxy :: * -> *).
(Typeable t, Monoid t) =>
proxy t -> Dynamic
go proxy t
_ = t -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (forall a. Monoid a => a
mempty @t)

-- | Union of to 'Beans' maps. If both share a 'TypeRep' key and the key is
-- present in the 'SomeMonoidTypeRep' 'Set', combine the values monoidally.
-- Otherwise, keep the value from the /second/ 'Beans' map.
unionBeansMonoidally :: Set SomeMonoidTypeRep -> Beans -> Beans -> Beans
unionBeansMonoidally :: Set SomeMonoidTypeRep -> Beans -> Beans -> Beans
unionBeansMonoidally Set SomeMonoidTypeRep
reps (Beans Map TypeRep Dynamic
beans1) (Beans Map TypeRep Dynamic
beans2) =
  let d :: Map TypeRep SomeMonoidTypeRep
d =
        Set SomeMonoidTypeRep
reps
          Set SomeMonoidTypeRep
-> (Set SomeMonoidTypeRep -> Set (Arg TypeRep SomeMonoidTypeRep))
-> Set (Arg TypeRep SomeMonoidTypeRep)
forall a b. a -> (a -> b) -> b
& (SomeMonoidTypeRep -> Arg TypeRep SomeMonoidTypeRep)
-> Set SomeMonoidTypeRep -> Set (Arg TypeRep SomeMonoidTypeRep)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\v :: SomeMonoidTypeRep
v@(SomeMonoidTypeRep TypeRep a
tr) -> TypeRep -> SomeMonoidTypeRep -> Arg TypeRep SomeMonoidTypeRep
forall a b. a -> b -> Arg a b
Data.Semigroup.Arg (TypeRep a -> TypeRep
forall k (a :: k). TypeRep a -> TypeRep
SomeTypeRep TypeRep a
tr) SomeMonoidTypeRep
v)
          Set (Arg TypeRep SomeMonoidTypeRep)
-> (Set (Arg TypeRep SomeMonoidTypeRep)
    -> Map TypeRep SomeMonoidTypeRep)
-> Map TypeRep SomeMonoidTypeRep
forall a b. a -> (a -> b) -> b
& Set (Arg TypeRep SomeMonoidTypeRep)
-> Map TypeRep SomeMonoidTypeRep
forall k a. Set (Arg k a) -> Map k a
Map.fromArgSet
      combine :: TypeRep -> Dynamic -> Dynamic -> Dynamic
combine TypeRep
tr Dynamic
d1 Dynamic
d2 =
        case (TypeRep -> Map TypeRep SomeMonoidTypeRep -> Maybe SomeMonoidTypeRep
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
tr Map TypeRep SomeMonoidTypeRep
d, Dynamic
d1, Dynamic
d2) of
          (Just (SomeMonoidTypeRep TypeRep a
tr'), Dynamic TypeRep a
tr1 a
v1, Dynamic TypeRep a
tr2 a
v2)
            | Just a :~~: a
HRefl <- TypeRep a
tr' TypeRep a -> TypeRep a -> Maybe (a :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a
tr1,
              Just a :~~: a
HRefl <- TypeRep a
tr' TypeRep a -> TypeRep a -> Maybe (a :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a
tr2 ->
                TypeRep a -> (Typeable a => Dynamic) -> Dynamic
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
Type.Reflection.withTypeable TypeRep a
tr' (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (a
v1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a
v2))
          (Maybe SomeMonoidTypeRep, Dynamic, Dynamic)
_ -> Dynamic
d2
   in Map TypeRep Dynamic -> Beans
Beans (Map TypeRep Dynamic -> Beans) -> Map TypeRep Dynamic -> Beans
forall a b. (a -> b) -> a -> b
$ (TypeRep -> Dynamic -> Dynamic -> Dynamic)
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
-> Map TypeRep Dynamic
forall k a.
Ord k =>
(k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWithKey TypeRep -> Dynamic -> Dynamic -> Dynamic
combine Map TypeRep Dynamic
beans1 Map TypeRep Dynamic
beans2

-- | The set of all 'TypeRep' keys of the map.
keysSet :: Beans -> Set TypeRep
keysSet :: Beans -> Set TypeRep
keysSet Beans {Map TypeRep Dynamic
beanMap :: Beans -> Map TypeRep Dynamic
beanMap :: Map TypeRep Dynamic
beanMap} = Map TypeRep Dynamic -> Set TypeRep
forall k a. Map k a -> Set k
Map.keysSet Map TypeRep Dynamic
beanMap