1
{-# LANGUAGE BlockArguments #-}
2
{-# LANGUAGE DataKinds #-}
3
{-# LANGUAGE DerivingStrategies #-}
4
{-# LANGUAGE GADTs #-}
5
{-# LANGUAGE LambdaCase #-}
6
{-# LANGUAGE TypeFamilies #-}
7
{-# LANGUAGE NoFieldSelectors #-}
8
9
-- | A map of 'Dynamic' values.
10
module Cauldron.Beans
11
  ( Beans,
12
    empty,
13
    insert,
14
    delete,
15
    restrictKeys,
16
    keysSet,
17
    singleton,
18
    fromDynList,
19
    toDynMap,
20
21
    -- * Looking for values
22
    taste,
23
24
    -- * Monoidal stuff
25
    unionBeansMonoidally,
26
    SomeMonoidTypeRep (..),
27
    someMonoidTypeRepMempty,
28
29
    -- * Re-exported
30
    toDyn,
31
  )
32
where
33
34
import Data.Dynamic
35
import Data.Function ((&))
36
import Data.Functor ((<&>))
37
import Data.Map.Strict (Map)
38
import Data.Map.Strict qualified as Map
39
import Data.Semigroup qualified
40
import Data.Set (Set)
41
import Data.Set qualified as Set
42
import Data.Typeable
43
import GHC.IsList
44
import Type.Reflection (SomeTypeRep (..), eqTypeRep)
45
import Type.Reflection qualified
46
47
empty :: Beans
48
empty = Beans Map.empty
49
50
insert :: forall bean. (Typeable bean) => bean -> Beans -> Beans
51
insert bean Beans {beanMap} =
52
  Beans {beanMap = Map.insert (typeRep (Proxy @bean)) (toDyn bean) beanMap}
53
54
delete :: TypeRep -> Beans -> Beans
55
delete tr Beans {beanMap} =
56
  Beans {beanMap = Map.delete tr beanMap}
57
58
-- | Restrict a 'Beans' map to only those 'TypeRep's found in a 'Set'.
59
restrictKeys :: Beans -> Set TypeRep -> Beans
60
restrictKeys Beans {beanMap} trs = Beans {beanMap = Map.restrictKeys beanMap trs}
61
62
singleton :: forall bean. (Typeable bean) => bean -> Beans
63
singleton bean = Beans do Map.singleton (typeRep (Proxy @bean)) (toDyn bean)
64
65
-- | Check if the 'Beans' map contains a value of type @bean@.
66
taste :: forall bean. (Typeable bean) => Beans -> Maybe bean
67
taste Beans {beanMap} =
68
  let tr = Type.Reflection.typeRep @bean
69
   in case Map.lookup (SomeTypeRep tr) beanMap of
70
        Just (Dynamic tr' v) | Just HRefl <- tr `eqTypeRep` tr' -> Just v
71
        _ -> Nothing
72
73
-- | A map of 'Dynamic' values, indexed by the 'TypeRep' of each 'Dynamic'.
74
-- Maintains the invariant that the 'TypeRep' of the key matches the 'TypeRep'
75
-- of the 'Dynamic'.
76
newtype Beans = Beans {beanMap :: Map TypeRep Dynamic}
77
  deriving newtype (Show)
78
79
-- | Union of two 'Beans' maps, right-biased: prefers values from the /right/
80
-- 'Beans' map when both contain the same 'TypeRep' key. (Note that
81
-- 'Data.Map.Map' is left-biased.)
82
instance Semigroup Beans where
83
  Beans {beanMap = r1} <> Beans {beanMap = r2} = Beans do Map.unionWith (flip const) r1 r2
84
85
instance Monoid Beans where
86
  mempty = Beans mempty
87
88
instance IsList Beans where
89
  type Item Beans = Dynamic
90
  toList (Beans {beanMap}) = Map.elems beanMap
91
  fromList = fromDynList
92
93
-- |
94
-- >>> :{
95
-- let beans = fromDynList [toDyn False, toDyn @Int 5]
96
--  in (taste @Bool beans, taste @Int beans, taste @String beans)
97
-- :}
98
-- (Just False,Just 5,Nothing)
99
fromDynList :: [Dynamic] -> Beans
100
fromDynList ds = Beans do Map.fromList do ds <&> \d -> (dynTypeRep d, d)
101
102
toDynMap :: Beans -> Map TypeRep Dynamic
103
toDynMap Beans {beanMap} = beanMap
104
105
-- | Like 'SomeTypeRep', but also remembering that the type has a 'Monoid' instance, which can be \"recovered\"
106
-- after pattern-matching on the 'SomeMonoidTypeRep'.
107
data SomeMonoidTypeRep where
108
  SomeMonoidTypeRep ::
109
    forall a.
110
    (Monoid a) =>
111
    Type.Reflection.TypeRep a ->
112
    SomeMonoidTypeRep
113
114
instance Show SomeMonoidTypeRep where
115
  show (SomeMonoidTypeRep tr) = show tr
116
117
instance Eq SomeMonoidTypeRep where
118
  (SomeMonoidTypeRep tr1) == (SomeMonoidTypeRep tr2) =
119
    (SomeTypeRep tr1) == (SomeTypeRep tr2)
120
121
instance Ord SomeMonoidTypeRep where
122
  (SomeMonoidTypeRep tr1) `compare` (SomeMonoidTypeRep tr2) =
123
    (SomeTypeRep tr1) `compare` (SomeTypeRep tr2)
124
125
-- | The 'mempty' value corresponding to the inner 'Type.Reflection.TypeRep'.
126
someMonoidTypeRepMempty :: SomeMonoidTypeRep -> Dynamic
127
someMonoidTypeRepMempty (SomeMonoidTypeRep tr) = Type.Reflection.withTypeable tr (go tr)
128
  where
129
    go :: forall t proxy. (Typeable t, Monoid t) => proxy t -> Dynamic
130
    go _ = toDyn (mempty @t)
131
132
-- | Union of to 'Beans' maps. If both share a 'TypeRep' key and the key is
133
-- present in the 'SomeMonoidTypeRep' 'Set', combine the values monoidally.
134
-- Otherwise, keep the value from the /second/ 'Beans' map.
135
unionBeansMonoidally :: Set SomeMonoidTypeRep -> Beans -> Beans -> Beans
136
unionBeansMonoidally reps (Beans beans1) (Beans beans2) =
137
  let d =
138
        reps
139
          & Set.map (\v@(SomeMonoidTypeRep tr) -> Data.Semigroup.Arg (SomeTypeRep tr) v)
140
          & Map.fromArgSet
141
      combine tr d1 d2 =
142
        case (Map.lookup tr d, d1, d2) of
143
          (Just (SomeMonoidTypeRep tr'), Dynamic tr1 v1, Dynamic tr2 v2)
144
            | Just HRefl <- tr' `eqTypeRep` tr1,
145
              Just HRefl <- tr' `eqTypeRep` tr2 ->
146
                Type.Reflection.withTypeable tr' (toDyn (v1 <> v2))
147
          _ -> d2
148
   in Beans $ Map.unionWithKey combine beans1 beans2
149
150
-- | The set of all 'TypeRep' keys of the map.
151
keysSet :: Beans -> Set TypeRep
152
keysSet Beans {beanMap} = Map.keysSet beanMap