@@ -7,13 +7,16 @@
77{-# LANGUAGE RankNTypes #-}
88{-# LANGUAGE RecursiveDo #-}
99{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE StandaloneDeriving #-}
1011{-# LANGUAGE TypeFamilies #-}
1112{-# LANGUAGE UndecidableInstances #-}
1213
13−module Reflex.Dom.NestedRoute where
14+module Reflex.Dom.Routing.Nested where
1415
15−import Control.Lens (Rewrapped, Wrapped(..), iso, to, (^.))
16−import Control.Monad.Exception (MonadAsyncException, MonadException)
16+import Control.Lens (Rewrapped, Wrapped (..), iso, to,
17+ (^.))
18+import Control.Monad.Exception (MonadAsyncException,
19+ MonadException)
1720import Control.Monad.Fix
1821import Control.Monad.Primitive (PrimMonad, PrimState, primitive)
1922import Control.Monad.Reader
@@ -29,7 +32,6 @@ import Data.Maybe (listToMaybe)
2932import Data.Text (Text)
3033import qualified Data.Text as T
3134import Data.Text.Encoding (decodeUtf8, encodeUtf8)
32−import Foreign.JavaScript.TH
3335import Language.Javascript.JSaddle (MonadJSM)
3436import Reflex
3537import Reflex.Dom.Builder.Class
@@ -41,51 +43,53 @@ import URI.ByteString (URIRef, fragmentL, pathL)
4143
4244
4345data RouteContext segment t = RouteContext
44− { _routeContext_allSegments :: Dynamic t [segment]
45− , _routeContext_nextSegments :: Dynamic t [segment]
46− , _routeContext_currentSegment :: Dynamic t (Maybe segment)
46+ { _routeContext_allSegments :: !(Dynamic t [segment])
47+ , _routeContext_nextSegments :: !(Dynamic t [segment])
48+ , _routeContext_currentSegment :: !(Dynamic t (Maybe segment))
49+ , _routeContext_currentDepth :: !Int
4750 }
4851
4952
50−class (Reflex t, Monad m) => HasRoute segment t m | m -> segment, m -> t where
53+class (Reflex t, Monad m) => HasRoute t segment m | m -> segment, m -> t where
5154 routeContext :: m (RouteContext segment t)
5255 withSegments :: (RouteContext segment t -> RouteContext segment t) -> m a -> m a
5356
5457
55−newtype RouteT segment t m a = RouteT { unRouteT :: ReaderT (RouteContext segment t) m a }
58+newtype RouteT t segment m a = RouteT { unRouteT :: ReaderT (RouteContext segment t) m a }
5659 deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t,
5760 MonadSample t, MonadAsyncException, MonadException, MonadTrans, PostBuild t,
5861 MonadReflexCreateTrigger t, TriggerEvent t, MonadAtomicRef)
5962
60−instance (MonadWidget t m) => HasRoute segment t (RouteT segment t m) where
63+
64+instance (MonadWidget t m) => HasRoute t segment (RouteT t segment m) where
6165 routeContext = RouteT ask
6266 withSegments f (RouteT m) = RouteT $ local f m
6367
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
68+instance Requester t m => Requester t (RouteT t segment m) where
69+ type Request (RouteT t segment m) = Request m
70+ type Response (RouteT t segment m) = Response m
6771 requesting = lift . requesting
6872 requesting_ = lift . requesting_
6973
70−instance HasRoute segment t m => HasRoute segment t (RequesterT t request response m) where
74+instance HasRoute t segment m => HasRoute t segment (RequesterT t request response m) where
7175 routeContext = lift routeContext
7276 withSegments f (RequesterT a) = RequesterT $ StrictState.mapStateT (mapReaderT $ withSegments f) a
7377
74−instance Wrapped (RouteT segment t m a) where
75− type Unwrapped (RouteT segment t m a) = ReaderT (RouteContext segment t) m a
78+instance Wrapped (RouteT t segment m a) where
79+ type Unwrapped (RouteT t segment m a) = ReaderT (RouteContext segment t) m a
7680 _Wrapped' = iso coerce coerce
7781
78−instance RouteT segment t m a ~ x => Rewrapped (RouteT segment t m a) x
82+instance RouteT t segment m a ~ x => Rewrapped (RouteT t segment m a) x
7983
80−instance PerformEvent t m => PerformEvent t (RouteT segment t m) where
81− type Performable (RouteT segment t m) = Performable m
84+instance PerformEvent t m => PerformEvent t (RouteT t segment m) where
85+ type Performable (RouteT t segment m) = Performable m
8286 {-# INLINABLE performEvent_ #-}
8387 performEvent_ = lift . performEvent_
8488 {-# INLINABLE performEvent #-}
8589 performEvent = lift . performEvent
8690
87−instance MonadRef m => MonadRef (RouteT segment t m) where
88− type Ref (RouteT segment t m) = Ref m
91+instance MonadRef m => MonadRef (RouteT t segment m) where
92+ type Ref (RouteT t segment m) = Ref m
8993 {-# INLINABLE newRef #-}
9094 newRef = lift . newRef
9195 {-# INLINABLE readRef #-}
@@ -93,14 +97,14 @@ instance MonadRef m => MonadRef (RouteT segment t m) where
9397 {-# INLINABLE writeRef #-}
9498 writeRef r = lift . writeRef r
9599
96−instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteT segment t m) where
100+instance (Adjustable t m, MonadHold t m) => Adjustable t (RouteT t segment m) where
97101 runWithReplace a0 a' = RouteT $ runWithReplace (unRouteT a0) (fmapCheap unRouteT a')
98102 traverseDMapWithKeyWithAdjust f dm edm = RouteT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
99103 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
100104 traverseDMapWithKeyWithAdjustWithMove f dm edm = RouteT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
101105
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
106+instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT t segment m) where
107+ type DomBuilderSpace (RouteT t segment m) = DomBuilderSpace m
104108 textNode = lift . textNode
105109 element elementTag cfg (RouteT child) = RouteT $ element elementTag cfg child
106110 inputElement = lift . inputElement
@@ -109,39 +113,55 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT seg
109113 placeRawElement = lift . placeRawElement
110114 wrapRawElement e = lift . wrapRawElement e
111115
112−instance MonadReader r m => MonadReader r (RouteT segment t m) where
116+instance (Monad m, NotReady t m) => NotReady t (RouteT t segment m)
117+
118+instance MonadReader r m => MonadReader r (RouteT t segment m) where
113119 ask = lift ask
114120 local f (RouteT a) = RouteT $ mapReaderT (local f) a
115121
116−instance MonadState s m => MonadState s (RouteT segment t m) where
117− get = lift get
118− put s = lift $ put s
122+deriving instance MonadState s m => MonadState s (RouteT t segment m)
119123
120−instance EventWriter t w m => EventWriter t w (RouteT segment t m) where
124+instance HasRoute t segment m => HasRoute t segment (EventWriterT t w m) where
125+ routeContext = lift routeContext
126+ withSegments f (EventWriterT a) = EventWriterT $ StrictState.mapStateT (withSegments f) a
127+
128+instance EventWriter t w m => EventWriter t w (RouteT t segment m) where
121129 tellEvent = lift . tellEvent
122130
131+instance HasRoute t segment m => HasRoute t segment (DynamicWriterT t w m) where
132+ routeContext = lift routeContext
133+ withSegments f (DynamicWriterT a) = DynamicWriterT $ StrictState.mapStateT (withSegments f) a
134+
135+instance DynamicWriter t w m => DynamicWriter t w (RouteT t segment m) where
136+ tellDyn = lift . tellDyn
137+
138+instance HasDocument m => HasDocument (RouteT t segment m)
123139
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
127− askJSContext = RouteT askJSContext
128140#ifndef ghcjs_HOST_OS
129−instance MonadJSM m => MonadJSM (RouteT segment t m)
141+instance MonadJSM m => MonadJSM (RouteT t segment m)
130142#endif
131143
144+deriving instance DomRenderHook t m => DomRenderHook t (RouteT t segment m)
145+
146+instance (Prerender t m, Monad m, Reflex t) => Prerender t (RouteT t segment m) where
147+ type Client (RouteT t segment m) = RouteT t segment (Client m)
148+ prerender (RouteT a) (RouteT b) = RouteT $ prerender a b
132149
133−instance PrimMonad m => PrimMonad (RouteT segment t m) where
134− type PrimState (RouteT segment t m) = PrimState m
150+
151+instance PrimMonad m => PrimMonad (RouteT t segment m) where
152+ type PrimState (RouteT t segment m) = PrimState m
135153 primitive = lift . primitive
136154
137155--instance HasMountStatus t m => HasMountStatus t (RouteT segment r m) where
138156-- getMountStatus = lift getMountStatus
139157
140−
158+-- | Runs a monadic action (in 'RouteT') over the current URL as "interpreted"
159+-- by the given URL-parser. The action must return an 'Event' which can trigger
160+-- the route to change.
141161runRoute :: forall segment t m. (MonadWidget t m, Eq segment)
142162 => (forall a. URIRef a -> [segment])
143163 -> (forall a. URIRef a -> [segment] -> URIRef a)
144− -> RouteT segment t m (Event t [segment])
164+ -> RouteT t segment m (Event t [segment])
145165 -> m ()
146166runRoute toSegments fromSegments (RouteT f) = do
147167 let
@@ -159,23 +179,29 @@ runRoute toSegments fromSegments (RouteT f) = do
159179 ctx = RouteContext{ _routeContext_allSegments = allSegments
160180 , _routeContext_nextSegments = allSegments
161181 , _routeContext_currentSegment = pure Nothing
182+ , _routeContext_currentDepth = 0
162183 }
163184 newSegments <- runReaderT f ctx
164185 let x = ffor uri $ \uri' -> fromSegments uri' <$> newSegments
165186 pure (switch (current x))
166187
167−
188+-- | A very simple version of 'runRoute' that parses only the URL fragment
189+-- and splits it over @/@. Each path segment is therefore nothing more than 'Text'.
168190runRouteWithPathInFragment
169191 :: forall t m. (MonadWidget t m)
170− => RouteT Text t m (Event t [Text])
192+ => RouteT t Text m (Event t [Text])
171193 -> m ()
172194runRouteWithPathInFragment = runRoute
173− (T.splitOn "/" . T.dropAround (=='/') . fragAsText)
195+ (nullTextToEmptyList . T.splitOn "/" . T.dropAround (=='/') . fragAsText)
174196 (\oldUrl -> setFrag oldUrl . T.intercalate "/")
197+ where
198+ nullTextToEmptyList [""] = []
199+ nullTextToEmptyList x = x
175200
176−
201+-- | Introduces a new "layer" in the nested routing tree. The given function takes
202+-- the current layer's route segment and builds the DOM for that segment.
177203withRoute
178− :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute segment t m, Eq segment)
204+ :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute t segment m, Eq segment)
179205 => (Maybe segment -> m a)
180206 -- ^ A routing function that produces a widget from a segment.
181207 -> m (Event t a)
@@ -185,12 +211,15 @@ withRoute f = do
185211 segmentsNested <- maybeDyn segmentsFlat
186212
187213 let
214+ nextDepth = 1 + _routeContext_currentDepth ctx
215+
188216 component = ffor segmentsNested $ \x -> case x of
189217 Nothing -> do
190218 let
191219 segment = Nothing
192220 newCtx = ctx{ _routeContext_currentSegment = pure segment
193221 , _routeContext_nextSegments = pure []
222+ , _routeContext_currentDepth = nextDepth
194223 }
195224
196225 a <- withSegments (const newCtx) (f segment)
@@ -201,6 +230,7 @@ withRoute f = do
201230 segmentDyn <- fmap Just <$> holdUniqDyn (fst <$> segmentUncons)
202231 let newCtx = ctx{ _routeContext_currentSegment = segmentDyn
203232 , _routeContext_nextSegments = snd <$> segmentUncons
233+ , _routeContext_currentDepth = nextDepth
204234 }
205235
206236 dyn $ ffor segmentDyn $ \segment ->
@@ -208,19 +238,34 @@ withRoute f = do
208238
209239 switchPromptly never =<< dyn component
210240
211−
212−allRouteSegments :: (Reflex t, MonadHold t m, MonadFix m, HasRoute segment t m, Eq segment) => m (Dynamic t [segment])
241+-- | All routing segments in the current URL.
242+allRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])
213243allRouteSegments = _routeContext_allSegments <$> routeContext
214244
215−currentRouteSegment :: (Functor m, HasRoute segment t m) => m (Dynamic t (Maybe segment))
245+-- | The routing segment at "this layer" in the tree. "This layer" is defined by how many
246+-- nested 'withRoute's exist above the caller of this function.
247+currentRouteSegment :: (Functor m, HasRoute t segment m) => m (Dynamic t (Maybe segment))
216248currentRouteSegment = _routeContext_currentSegment <$> routeContext
217249
218−nextRouteSegment :: (Reflex t, MonadHold t m, MonadFix m, HasRoute segment t m, Eq segment) => m (Dynamic t (Maybe segment))
250+-- | The next layer's segment in the tree. Like 'withRoute' this can be used to switch
251+-- over route segments, but it does not place a new layer in the tree.
252+nextRouteSegment :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t (Maybe segment))
219253nextRouteSegment = do
220254 ctx <- routeContext
221255 holdUniqDyn (listToMaybe <$> _routeContext_nextSegments ctx)
222256
223−redirectLocally :: (MonadWidget t m, HasRoute segment t m) => [segment] -> m (Event t [segment])
257+-- | Route segments from parent layers.
258+parentRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])
259+parentRouteSegments = do
260+ ctx <- routeContext
261+ holdUniqDyn $ take (_routeContext_currentDepth ctx) <$> _routeContext_allSegments ctx
262+
263+-- | Route segments from child layers.
264+childRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])
265+childRouteSegments = holdUniqDyn =<< _routeContext_nextSegments <$> routeContext
266+
267+-- | A simple helper that produces a routing event on 'getPostBuild'.
268+redirectLocally :: (PostBuild t m) => [segment] -> m (Event t [segment])
224269redirectLocally segments = (segments <$) <$> getPostBuild
225270
226271
@@ -232,4 +277,3 @@ fragAsText uri = maybe "" decodeUtf8 (uri ^. fragmentL)
232277
233278pathSegments :: URIRef a -> [ByteString]
234279pathSegments uri = uri ^. pathL . to (B8.split '/')
235−