git.iko.soy/typeable/reflex-dom-nested-routing
on master help sign in
Reorder Route type params; add RouteWriter
commitfdd72ef2cfedde1e298274dc40b372ff13a0755d author3noch <eacameron@gmail.com> dateSat 21 Oct 2017, 13:28 (9 years ago) parent9f97ecc
2 files changed+200−36
compare with master
unifiedsplit
Reflex/Dom/NestedRoute.hs+49−36 Reflex/Dom/RouteWriter.hs+151
Reflex/Dom/NestedRoute.hs+49−36
@@ -47,45 +47,46 @@ data RouteContext segment t = RouteContext
4747 }
4848
4949
50−class (Reflex t, Monad m) => HasRoute segment t m | m -> segment, m -> t where
50+class (Reflex t, Monad m) => HasRoute t segment m | m -> segment, m -> t where
5151 routeContext :: m (RouteContext segment t)
5252 withSegments :: (RouteContext segment t -> RouteContext segment t) -> m a -> m a
5353
5454
55−newtype RouteT segment t m a = RouteT { unRouteT :: ReaderT (RouteContext segment t) m a }
55+newtype RouteT t segment m a = RouteT { unRouteT :: ReaderT (RouteContext segment t) m a }
5656 deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t,
5757 MonadSample t, MonadAsyncException, MonadException, MonadTrans, PostBuild t,
5858 MonadReflexCreateTrigger t, TriggerEvent t, MonadAtomicRef)
5959
60−instance (MonadWidget t m) => HasRoute segment t (RouteT segment t m) where
60+
61+instance (MonadWidget t m) => HasRoute t segment (RouteT t segment m) where
6162 routeContext = RouteT ask
6263 withSegments f (RouteT m) = RouteT $ local f m
6364
64−instance Requester t m => Requester t (RouteT segment t m) where
65− type Request (RouteT segment t m) = Request m
66− type Response (RouteT segment t m) = Response m
65+instance Requester t m => Requester t (RouteT t segment m) where
66+ type Request (RouteT t segment m) = Request m
67+ type Response (RouteT t segment m) = Response m
6768 requesting = lift . requesting
6869 requesting_ = lift . requesting_
6970
70−instance HasRoute segment t m => HasRoute segment t (RequesterT t request response m) where
71+instance HasRoute t segment m => HasRoute t segment (RequesterT t request response m) where
7172 routeContext = lift routeContext
7273 withSegments f (RequesterT a) = RequesterT $ StrictState.mapStateT (mapReaderT $ withSegments f) a
7374
74−instance Wrapped (RouteT segment t m a) where
75− type Unwrapped (RouteT segment t m a) = ReaderT (RouteContext segment t) m a
75+instance Wrapped (RouteT t segment m a) where
76+ type Unwrapped (RouteT t segment m a) = ReaderT (RouteContext segment t) m a
7677 _Wrapped' = iso coerce coerce
7778
78−instance RouteT segment t m a ~ x => Rewrapped (RouteT segment t m a) x
79+instance RouteT t segment m a ~ x => Rewrapped (RouteT t segment m a) x
7980
80−instance PerformEvent t m => PerformEvent t (RouteT segment t m) where
81− type Performable (RouteT segment t m) = Performable m
81+instance PerformEvent t m => PerformEvent t (RouteT t segment m) where
82+ type Performable (RouteT t segment m) = Performable m
8283 {-# INLINABLE performEvent_ #-}
8384 performEvent_ = lift . performEvent_
8485 {-# INLINABLE performEvent #-}
8586 performEvent = lift . performEvent
8687
87−instance MonadRef m => MonadRef (RouteT segment t m) where
88− type Ref (RouteT segment t m) = Ref m
88+instance MonadRef m => MonadRef (RouteT t segment m) where
89+ type Ref (RouteT t segment m) = Ref m
8990 {-# INLINABLE newRef #-}
9091 newRef = lift . newRef
9192 {-# INLINABLE readRef #-}
@@ -93,14 +94,14 @@ instance MonadRef m => MonadRef (RouteT segment t m) where
9394 {-# INLINABLE writeRef #-}
9495 writeRef r = lift . writeRef r
9596
96−instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteT segment t m) where
97+instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteT t segment m) where
9798 runWithReplace a0 a' = RouteT $ runWithReplace (unRouteT a0) (fmapCheap unRouteT a')
9899 traverseDMapWithKeyWithAdjust f dm edm = RouteT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
99100 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
100101 traverseDMapWithKeyWithAdjustWithMove f dm edm = RouteT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
101102
102−instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT segment t m) where
103− type DomBuilderSpace (RouteT segment t m) = DomBuilderSpace m
103+instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT t segment m) where
104+ type DomBuilderSpace (RouteT t segment m) = DomBuilderSpace m
104105 textNode = lift . textNode
105106 element elementTag cfg (RouteT child) = RouteT $ element elementTag cfg child
106107 inputElement = lift . inputElement
@@ -109,29 +110,30 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT seg
109110 placeRawElement = lift . placeRawElement
110111 wrapRawElement e = lift . wrapRawElement e
111112
112−instance MonadReader r m => MonadReader r (RouteT segment t m) where
113+instance MonadReader r m => MonadReader r (RouteT t segment m) where
113114 ask = lift ask
114115 local f (RouteT a) = RouteT $ mapReaderT (local f) a
115116
116−instance MonadState s m => MonadState s (RouteT segment t m) where
117− get = lift get
118− put s = lift $ put s
117+deriving instance MonadState s m => MonadState s (RouteT t segment m)
119118
120−instance EventWriter t w m => EventWriter t w (RouteT segment t m) where
121− tellEvent = lift . tellEvent
119+instance HasRoute t segment m => HasRoute t segment (EventWriterT t w m) where
120+ routeContext = lift routeContext
121+ withSegments f (EventWriterT a) = EventWriterT $ StrictState.mapStateT (withSegments f) a
122122
123+instance EventWriter t w m => EventWriter t w (RouteT t segment m) where
124+ tellEvent = lift . tellEvent
123125
124−instance HasDocument m => HasDocument (RouteT segment t m)
125−instance HasJSContext m => HasJSContext (RouteT segment t m) where
126− type JSContextPhantom (RouteT segment t m) = JSContextPhantom m
126+instance HasDocument m => HasDocument (RouteT t segment m)
127+instance HasJSContext m => HasJSContext (RouteT t segment m) where
128+ type JSContextPhantom (RouteT t segment m) = JSContextPhantom m
127129 askJSContext = RouteT askJSContext
128130#ifndef ghcjs_HOST_OS
129−instance MonadJSM m => MonadJSM (RouteT segment t m)
131+instance MonadJSM m => MonadJSM (RouteT t segment m)
130132#endif
131133
132134
133−instance PrimMonad m => PrimMonad (RouteT segment t m) where
134− type PrimState (RouteT segment t m) = PrimState m
135+instance PrimMonad m => PrimMonad (RouteT t segment m) where
136+ type PrimState (RouteT t segment m) = PrimState m
135137 primitive = lift . primitive
136138
137139--instance HasMountStatus t m => HasMountStatus t (RouteT segment r m) where
@@ -141,7 +143,7 @@ instance PrimMonad m => PrimMonad (RouteT segment t m) where
141143runRoute :: forall segment t m. (MonadWidget t m, Eq segment)
142144 => (forall a. URIRef a -> [segment])
143145 -> (forall a. URIRef a -> [segment] -> URIRef a)
144− -> RouteT segment t m (Event t [segment])
146+ -> RouteT t segment m (Event t [segment])
145147 -> m ()
146148runRoute toSegments fromSegments (RouteT f) = do
147149 let
@@ -167,7 +169,7 @@ runRoute toSegments fromSegments (RouteT f) = do
167169
168170runRouteWithPathInFragment
169171 :: forall t m. (MonadWidget t m)
170− => RouteT Text t m (Event t [Text])
172+ => RouteT t Text m (Event t [Text])
171173 -> m ()
172174runRouteWithPathInFragment = runRoute
173175 (T.splitOn "/" . T.dropAround (=='/') . fragAsText)
@@ -175,7 +177,7 @@ runRouteWithPathInFragment = runRoute
175177
176178
177179withRoute
178− :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute segment t m, Eq segment)
180+ :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute t segment m, Eq segment)
179181 => (Maybe segment -> m a)
180182 -- ^ A routing function that produces a widget from a segment.
181183 -> m (Event t a)
@@ -209,18 +211,26 @@ withRoute f = do
209211 switchPromptly never =<< dyn component
210212
211213
212−allRouteSegments :: (Reflex t, MonadHold t m, MonadFix m, HasRoute segment t m, Eq segment) => m (Dynamic t [segment])
214+allRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])
213215allRouteSegments = _routeContext_allSegments <$> routeContext
214216
215−currentRouteSegment :: (Functor m, HasRoute segment t m) => m (Dynamic t (Maybe segment))
217+currentRouteSegment :: (Functor m, HasRoute t segment m) => m (Dynamic t (Maybe segment))
216218currentRouteSegment = _routeContext_currentSegment <$> routeContext
217219
218−nextRouteSegment :: (Reflex t, MonadHold t m, MonadFix m, HasRoute segment t m, Eq segment) => m (Dynamic t (Maybe segment))
220+nextRouteSegment :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t (Maybe segment))
219221nextRouteSegment = do
220222 ctx <- routeContext
221223 holdUniqDyn (listToMaybe <$> _routeContext_nextSegments ctx)
222224
223−redirectLocally :: (MonadWidget t m, HasRoute segment t m) => [segment] -> m (Event t [segment])
225+parentRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])
226+parentRouteSegments = do
227+ ctx <- routeContext
228+ holdUniqDyn $ do
229+ allSegments <- _routeContext_allSegments ctx
230+ nBelow <- length <$> _routeContext_nextSegments ctx
231+ pure $ take (length allSegments - nBelow) allSegments
232+
233+redirectLocally :: (PostBuild t m) => [segment] -> m (Event t [segment])
224234redirectLocally segments = (segments <$) <$> getPostBuild
225235
226236
@@ -233,3 +243,6 @@ fragAsText uri = maybe "" decodeUtf8 (uri ^. fragmentL)
233243pathSegments :: URIRef a -> [ByteString]
234244pathSegments uri = uri ^. pathL . to (B8.split '/')
235245
246+-- ^ Like 'switchPromptly' but without being prompt.
247+switchTardy :: (MonadHold t m, Reflex t) => Event t (Event t a) -> m (Event t a)
248+switchTardy x = switch <$> hold never x
Reflex/Dom/RouteWriter.hsnew file+151
@@ -0,0 +1,151 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
11+module Reflex.Dom.RouteWriter where
12+
13+import Control.Lens (Rewrapped, Wrapped(..), iso)
14+import Control.Monad.Exception (MonadAsyncException, MonadException)
15+import Control.Monad.Fix
16+import Control.Monad.Primitive (PrimMonad, PrimState, primitive)
17+import Control.Monad.Reader
18+import Control.Monad.Ref
19+import qualified Control.Monad.State.Strict as StrictState
20+import Data.Coerce (coerce)
21+import Foreign.JavaScript.TH
22+import Language.Javascript.JSaddle (MonadJSM)
23+import Reflex
24+import Reflex.Dom.Builder.Class
25+import Reflex.Dom.Builder.Immediate
26+import Reflex.Dom.Core
27+import Reflex.Host.Class
28+
29+import Reflex.Dom.NestedRoute
30+
31+
32+
33+class (Reflex t, Monad m) => RouteWriter t segment m | m -> segment, m -> t where
34+ tellRoute :: Event t [segment] -> m ()
35+
36+
37+newtype RouteWriterT t segment m a = RouteWriterT { unRouteWriterT :: EventWriterT t [segment] m a }
38+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t,
39+ MonadSample t, MonadAsyncException, MonadException, MonadTrans, PostBuild t,
40+ MonadReflexCreateTrigger t, TriggerEvent t, MonadAtomicRef)
41+
42+
43+instance (MonadWidget t m) => RouteWriter t segment (RouteWriterT t segment m) where
44+ tellRoute = RouteWriterT . tellEvent
45+
46+
47+instance Requester t m => Requester t (RouteWriterT t segment m) where
48+ type Request (RouteWriterT t segment m) = Request m
49+ type Response (RouteWriterT t segment m) = Response m
50+ requesting = lift . requesting
51+ requesting_ = lift . requesting_
52+
53+instance RouteWriter t segment m => RouteWriter t segment (RequesterT t request response m) where
54+ tellRoute = lift . tellRoute
55+
56+instance Wrapped (RouteWriterT t segment m a) where
57+ type Unwrapped (RouteWriterT t segment m a) = EventWriterT t [segment] m a
58+ _Wrapped' = iso coerce coerce
59+
60+instance RouteWriterT t segment m a ~ x => Rewrapped (RouteWriterT t segment m a) x
61+
62+instance PerformEvent t m => PerformEvent t (RouteWriterT t segment m) where
63+ type Performable (RouteWriterT t segment m) = Performable m
64+ {-# INLINABLE performEvent_ #-}
65+ performEvent_ = lift . performEvent_
66+ {-# INLINABLE performEvent #-}
67+ performEvent = lift . performEvent
68+
69+instance MonadRef m => MonadRef (RouteWriterT t segment m) where
70+ type Ref (RouteWriterT t segment m) = Ref m
71+ {-# INLINABLE newRef #-}
72+ newRef = lift . newRef
73+ {-# INLINABLE readRef #-}
74+ readRef = lift . readRef
75+ {-# INLINABLE writeRef #-}
76+ writeRef r = lift . writeRef r
77+
78+instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteWriterT t segment m) where
79+ runWithReplace a0 a' = RouteWriterT $ runWithReplace (unRouteWriterT a0) (fmapCheap unRouteWriterT a')
80+ traverseDMapWithKeyWithAdjust f dm edm = RouteWriterT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteWriterT $ f k v) (coerce dm) (coerceEvent edm)
81+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
82+ traverseDMapWithKeyWithAdjustWithMove f dm edm = RouteWriterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRouteWriterT $ f k v) (coerce dm) (coerceEvent edm)
83+
84+instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteWriterT t segment m) where
85+ type DomBuilderSpace (RouteWriterT t segment m) = DomBuilderSpace m
86+ textNode = lift . textNode
87+ element elementTag cfg (RouteWriterT child) = RouteWriterT $ element elementTag cfg child
88+ inputElement = lift . inputElement
89+ textAreaElement = lift . textAreaElement
90+ selectElement cfg (RouteWriterT child) = RouteWriterT $ selectElement cfg child
91+ placeRawElement = lift . placeRawElement
92+ wrapRawElement e = lift . wrapRawElement e
93+
94+deriving instance MonadReader r m => MonadReader r (RouteWriterT t segment m)
95+
96+instance RouteWriter t segment m => RouteWriter t segment (EventWriterT t w m) where
97+ tellRoute = lift . tellRoute
98+
99+instance EventWriter t w m => EventWriter t w (RouteWriterT t segment m) where
100+ tellEvent = lift . tellEvent
101+
102+instance HasDocument m => HasDocument (RouteWriterT t segment m)
103+instance HasJSContext m => HasJSContext (RouteWriterT t segment m) where
104+ type JSContextPhantom (RouteWriterT t segment m) = JSContextPhantom m
105+ askJSContext = RouteWriterT askJSContext
106+#ifndef ghcjs_HOST_OS
107+instance MonadJSM m => MonadJSM (RouteWriterT segment t m)
108+#endif
109+
110+
111+instance PrimMonad m => PrimMonad (RouteWriterT t segment m) where
112+ type PrimState (RouteWriterT t segment m) = PrimState m
113+ primitive = lift . primitive
114+
115+deriving instance HasRoute t segment m => HasRoute t segment (RouteWriterT t segment m)
116+
117+--instance HasMountStatus t m => HasMountStatus t (RouteWriterT r segment m) where
118+-- getMountStatus = lift getMountStatus
119+
120+-- | Runs an action that can easily set new routes at will anywhere in the action.
121+runRouteWriterT :: (Monad m, Reflex t) => RouteWriterT t segment m a -> m (a, Event t [segment])
122+runRouteWriterT (RouteWriterT m) = runEventWriterT m
123+
124+-- | Sets a new route immediately (on post-build) to the given route.
125+tellRedirectLocally :: (PostBuild t m, RouteWriter t segment m) => [segment] -> m ()
126+tellRedirectLocally segments = tellRoute =<< redirectLocally segments
127+
128+
129+-- | Sets a new route to the given route whenever the given 'Event' fires, ignoring the 'Event' payload.
130+tellRouteAs :: (RouteWriter t segment m) => [segment] -> Event t a -> m ()
131+tellRouteAs segments ev = tellRoute (segments <$ ev)
132+
133+-- | Sets a new route by transforming an arbitrary 'Event' payload into a route.
134+tellRouteBy :: (RouteWriter t segment m) => (a -> [segment]) -> Event t a -> m ()
135+tellRouteBy toSegments ev = tellRoute (toSegments <$> ev)
136+
137+-- | Changes the route with an arbitrary function over the current route.
138+tellRouteModifyWith
139+ :: (RouteWriter t segment m, HasRoute t segment m, MonadHold t m, MonadFix m, Eq segment)
140+ => Event t ([segment] -> [segment]) -> m ()
141+tellRouteModifyWith ev = do
142+ segments <- allRouteSegments
143+ tellRoute $ attachWith (&) (current segments) ev
144+
145+-- | Sets a new route relative to the current layer in the routing hierarchy.
146+tellRouteRelative
147+ :: (RouteWriter t segment m, HasRoute t segment m, MonadHold t m, MonadFix m, Eq segment)
148+ => Event t [segment] -> m ()
149+tellRouteRelative ev = do
150+ parents <- parentRouteSegments
151+ tellRoute $ attachWith (++) (current parents) ev