git.iko.soy/patch
on 5e1df2e help sign in
patch/src/Reflex/Adjustable/Class.hs
113 lines 4.9 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
14module Reflex.Adjustable.Class
15 (
16 -- * The Adjustable typeclass
17 Adjustable(..)
18 , sequenceDMapWithAdjust
19 , sequenceDMapWithAdjustWithMove
20 , mapMapWithAdjustWithMove
21 -- * Deprecated aliases
22 , MonadAdjust
23 ) where
25import Control.Monad.Identity
26import Control.Monad.Reader
27import Data.Dependent.Map (DMap, GCompare (..))
28import qualified Data.Dependent.Map as DMap
29import Data.Functor.Constant
30import Data.Functor.Misc
31import Data.IntMap.Strict (IntMap)
32import qualified Data.IntMap.Strict as IntMap
33import Data.Map (Map)
35import Reflex.Class
36import Reflex.Patch.DMapWithMove
38-- | A 'Monad' that supports adjustment over time. After an action has been
39-- run, if the given events fire, it will adjust itself so that its net effect
40-- is as though it had originally been run with the new value. Note that there
41-- is some issue here with persistent side-effects: obviously, IO (and some
42-- other side-effects) cannot be undone, so it is up to the instance implementer
43-- to determine what the best meaning for this class is in such cases.
44class (Reflex t, Monad m) => Adjustable t m | m -> t where
45 runWithReplace
46 :: m a
47 -> Event t (m b)
48 -> m (a, Event t b)
50 traverseIntMapWithKeyWithAdjust
51 :: (IntMap.Key -> v -> m v')
52 -> IntMap v
53 -> Event t (PatchIntMap v)
54 -> m (IntMap v', Event t (PatchIntMap v'))
56 traverseDMapWithKeyWithAdjust
57 :: GCompare k
58 => (forall a. k a -> v a -> m (v' a))
59 -> DMap k v
60 -> Event t (PatchDMap k v)
61 -> m (DMap k v', Event t (PatchDMap k v'))
62 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
63 traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $
64 traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm'
65 where
66 toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m
67 toNodeInfoWithMove = \case
68 ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing
69 ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing
70 fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m
71 fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of
72 From_Insert v -> Just v
73 From_Delete -> Nothing
74 From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move"
76 traverseDMapWithKeyWithAdjustWithMove
77 :: GCompare k
78 => (forall a. k a -> v a -> m (v' a))
79 -> DMap k v
80 -> Event t (PatchDMapWithMove k v)
81 -> m (DMap k v', Event t (PatchDMapWithMove k v'))
83instance Adjustable t m => Adjustable t (ReaderT r m) where
84 runWithReplace a0 a' = do
85 r <- ask
86 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
87 traverseIntMapWithKeyWithAdjust f dm0 dm' = do
88 r <- ask
89 lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
90 traverseDMapWithKeyWithAdjust f dm0 dm' = do
91 r <- ask
92 lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
93 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
94 r <- ask
95 lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
97sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
98sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
100sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
101sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
103mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))
104mapMapWithAdjustWithMove f m0 m' = do
105 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
106 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
108--------------------------------------------------------------------------------
109-- Deprecated functions
110--------------------------------------------------------------------------------
112{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}
113type MonadAdjust = Adjustable