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