-
Notifications
You must be signed in to change notification settings - Fork 0
/
Model.hs
155 lines (126 loc) · 5.84 KB
/
Model.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Glazier.React.Model where
import Control.Applicative
import Control.Lens
import Control.Monad.Cont
import Control.Monad.Delegate
import Control.Monad.Environ
import Control.Monad.Morph
import Control.Monad.Observer
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Extras
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Maybe
import Data.String
import Data.Tagged.Extras
import Glazier.Command
----------------------------------------------------------------
-- | This newtype prevent impredicative polymorphism
newtype ModifyModel s = ModifyModel { unModifyModel :: forall a. MaybeT (State s) a -> IO (Maybe a) }
-- | @IO (Maybe s)@ allows for a 'ZoomModel' instance without exceptions.
type AskModelEnv s m = (MonadAsk "Model" (Maybe s, IO (Maybe s), ModifyModel s) m)
instance {-# OVERLAPPING #-} Monad m => MonadAsk "Model" (Maybe s, IO (Maybe s), ModifyModel s) (ReaderT (Tagged "Model" (Maybe s, IO (Maybe s), ModifyModel s)) m) where
askEnvP _ = (untag' @"Model") <$> ask
localEnvP _ f = local (Tagged @"Model" . f . untag' @"Model")
askModelEnv :: AskModelEnv s m => m (Maybe s, IO (Maybe s), ModifyModel s)
askModelEnv = askEnvP @"Model" Proxy
localModelEnv :: AskModelEnv s m => ((Maybe s, IO (Maybe s), ModifyModel s) -> (Maybe s, IO (Maybe s), ModifyModel s)) -> m b -> m b
localModelEnv f = localEnvP @"Model" Proxy f
---------------------------------------------------------------------------
-- | Something that has access to a model, to ask an initial value, or read the latest value
-- or write the latest value
class (AlternativeIO m, AskModelEnv s m) => MonadModel s m
-- | Any transformer on top of 'MonadModel' is also a 'MonadModel'
instance {-# OVERLAPPABLE #-} (Alternative (t m), MonadIO (t m), Monad (t m), MonadTrans t, MFunctor t, MonadModel s m) => MonadModel s (t m)
instance (AlternativeIO m) => MonadModel s (ModelT s m)
---------------------------------------------------------------------------
type ModelT' s m = ReaderT (Tagged "Model" (Maybe s, IO (Maybe s), ModifyModel s)) m
-- | 'ModelT' is transformer that add the 'MonadModel' instance.
newtype ModelT s m a = ModelT { unModelT :: ModelT' s m a }
deriving
( Functor
, Applicative
, Monad
, MonadIO
, Alternative
, MonadPlus
, MonadCont
, MonadDelegate
, MonadDischarge
, MonadProgram
, MonadAsk "Model" (Maybe s, IO (Maybe s), ModifyModel s) -- AskModelEnv
)
type instance Command (ModelT s m) = Command m
instance MonadTrans (ModelT s) where
lift = ModelT . lift
instance MFunctor (ModelT s) where
hoist nat (ModelT m) = ModelT (hoist nat m)
deriving via (IdentityT (ModelT' s m)) instance MonadAsk p r m => MonadAsk p r (ModelT s m)
deriving via (IdentityT (ModelT' s m)) instance MonadPut p t m => MonadPut p t (ModelT s m)
-- | This instance of MonadCodify makes sure that the cached state
-- the updated with the latest state from the ref.
-- This also has the effect of allowing GHC to make the same 'StableName'
-- for a codified monad irregardless of the value of cached state.
instance (MonadIO m, MonadCodify m) => MonadCodify (ModelT s m) where
codify f = do
(_, y, z) <- askModelEnv
x <- liftIO y
lift $ codify $ \a -> (`runModelT` (x, y, z)) $ f a
instance (Monad m, Observer p a m) => Observer p a (ModelT s m) where
askObserver p = lift $ (lift .) <$> askObserver p
runModelT :: ModelT s m a -> (Maybe s, IO (Maybe s), ModifyModel s) -> m a
runModelT (ModelT m) t = runReaderT m $ Tagged @"Model" t
fromModelT :: MonadModel s m => ModelT s m a -> m a
fromModelT m = askModelEnv >>= runModelT m
---------------------------------------------------------------------------
class (MonadModel s m, MonadModel t n) => ZoomModel m n s t | m -> s, n -> t, m t -> n, n s -> m where
zoomModel :: Traversal' t s -> m c -> n c
instance AlternativeIO m => ZoomModel (ModelT s m) (ModelT t m) s t where
zoomModel l (ModelT m) = ModelT $ ReaderT $ \(Tagged (x, y, z)) ->
let x' = x >>= r
y' = (>>= r) <$> y
-- z :: (MaybeT (State t) a -> IO (Maybe a)
-- z' :: (MaybeT (State s) a -> IO (Maybe a)
-- f :: MaybeT (State s) a
-- z' zz f = (unModelEnv zz) (g f)
-- g :: MaybeT (State s) a -> MaybeT (State t) a
in runReaderT m $ Tagged @"Model" (x', y', h z)
where
-- r :: t -> Maybe s
r = preview l
-- w :: s -> t -> t
w = set l
h (ModifyModel g) = ModifyModel $ \f ->
g $ do
t <- get
case r t of
Nothing -> empty
Just s -> case runState (runMaybeT f) s of
(Nothing, _) -> empty
(Just a, s') -> do
put $ w s' t
pure a
-- | This instance allows using "plain string" in 'txt', and in props for 'lf', and 'bh'
-- when using @OverloadedString@ with @ExtendedDefaultRules@
instance {-# OVERLAPPABLE #-} (Applicative m, IsString a) => IsString (ModelT s m a) where
fromString = pure . fromString
-- instance {-# OVERLAPPABLE #-} (Applicative m, IsString a) => IsString (GadgetT m (Maybe a)) where
-- fromString = pure . Just . fromString