git.iko.soy/reflex
on ae@dev-script help sign in
reflex/src/Reflex/Adjustable/Class.hs
139 lines 5.7 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE UndecidableInstances #-}
10#ifdef USE_REFLEX_OPTIMIZER
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12#endif
13-- |
14-- Module:
15-- Reflex.Adjustable.Class
16-- Description:
17-- A class for actions that can be "adjusted" over time based on some 'Event'
18-- such that, when observed after the firing of any such 'Event', the result
19-- is as though the action was originally run with the 'Event's value.
20module Reflex.Adjustable.Class
21 (
22 -- * The Adjustable typeclass
23 Adjustable(..)
24 , sequenceDMapWithAdjust
25 , sequenceDMapWithAdjustWithMove
26 , mapMapWithAdjustWithMove
27 -- * Deprecated aliases
28 , MonadAdjust
29 ) where
31import Control.Monad.Identity
32import Control.Monad.Reader
33import Data.Dependent.Map (DMap, GCompare (..))
34import qualified Data.Dependent.Map as DMap
35import Data.Functor.Constant
36import Data.Functor.Misc
37import Data.IntMap.Strict (IntMap)
38import qualified Data.IntMap.Strict as IntMap
39import Data.Map (Map)
41import Reflex.Class
42import Data.Patch.DMapWithMove
44-- | A 'Monad' that supports adjustment over time. After an action has been
45-- run, if the given events fire, it will adjust itself so that its net effect
46-- is as though it had originally been run with the new value. Note that there
47-- is some issue here with persistent side-effects: obviously, IO (and some
48-- other side-effects) cannot be undone, so it is up to the instance implementer
49-- to determine what the best meaning for this class is in such cases.
50class (Reflex t, Monad m) => Adjustable t m | m -> t where
51 runWithReplace
52 :: m a
53 -> Event t (m b)
54 -> m (a, Event t b)
56 traverseIntMapWithKeyWithAdjust
57 :: (IntMap.Key -> v -> m v')
58 -> IntMap v
59 -> Event t (PatchIntMap v)
60 -> m (IntMap v', Event t (PatchIntMap v'))
62 traverseDMapWithKeyWithAdjust
63 :: GCompare k
64 => (forall a. k a -> v a -> m (v' a))
65 -> DMap k v
66 -> Event t (PatchDMap k v)
67 -> m (DMap k v', Event t (PatchDMap k v'))
68 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
69 traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $
70 traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm'
71 where
72 toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m
73 toNodeInfoWithMove = \case
74 ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing
75 ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing
76 fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m
77 fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of
78 From_Insert v -> Just v
79 From_Delete -> Nothing
80 From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move"
82 traverseDMapWithKeyWithAdjustWithMove
83 :: GCompare k
84 => (forall a. k a -> v a -> m (v' a))
85 -> DMap k v
86 -> Event t (PatchDMapWithMove k v)
87 -> m (DMap k v', Event t (PatchDMapWithMove k v'))
89instance Adjustable t m => Adjustable t (ReaderT r m) where
90 runWithReplace a0 a' = do
91 r <- ask
92 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
93 traverseIntMapWithKeyWithAdjust f dm0 dm' = do
94 r <- ask
95 lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
96 traverseDMapWithKeyWithAdjust f dm0 dm' = do
97 r <- ask
98 lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
99 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
100 r <- ask
101 lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
103-- | Traverse a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches
104-- to the 'DMap' can add, remove, or update values.
105sequenceDMapWithAdjust
106 :: (GCompare k, Adjustable t m)
107 => DMap k m
108 -> Event t (PatchDMap k m)
109 -> m (DMap k Identity, Event t (PatchDMap k Identity))
110sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
112-- | Traverses a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches
113-- to the 'DMap' can add, remove, update, move, or swap values.
114sequenceDMapWithAdjustWithMove
115 :: (GCompare k, Adjustable t m)
116 => DMap k m
117 -> Event t (PatchDMapWithMove k m)
118 -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
119sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
121-- | Traverses a 'Map', running the provided 'Adjustable' action. The provided 'Event' of patches to the 'Map'
122-- can add, remove, update, move, or swap values.
123mapMapWithAdjustWithMove
124 :: forall t m k v v'. (Adjustable t m, Ord k)
125 => (k -> v -> m v')
126 -> Map k v
127 -> Event t (PatchMapWithMove k v)
128 -> m (Map k v', Event t (PatchMapWithMove k v'))
129mapMapWithAdjustWithMove f m0 m' = do
130 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
131 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
133--------------------------------------------------------------------------------
134-- Deprecated functions
135--------------------------------------------------------------------------------
137{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}
138-- | Synonym for 'Adjustable'
139type MonadAdjust = Adjustable