@@ -12,8 +12,10 @@
1212
1313module Reflex.Dom.NestedRoute where
1414
15−import Control.Lens (Rewrapped, Wrapped(..), iso, to, (^.))
16−import Control.Monad.Exception (MonadAsyncException, MonadException)
15+import Control.Lens (Rewrapped, Wrapped (..), iso, to,
16+ (^.))
17+import Control.Monad.Exception (MonadAsyncException,
18+ MonadException)
1719import Control.Monad.Fix
1820import Control.Monad.Primitive (PrimMonad, PrimState, primitive)
1921import Control.Monad.Reader
@@ -41,9 +43,10 @@ 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
@@ -94,7 +97,7 @@ instance MonadRef m => MonadRef (RouteT t segment m) where
9497 {-# INLINABLE writeRef #-}
9598 writeRef r = lift . writeRef r
9699
97−instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteT t segment m) where
100+instance (Adjustable t m, MonadHold t m) => Adjustable t (RouteT t segment m) where
98101 runWithReplace a0 a' = RouteT $ runWithReplace (unRouteT a0) (fmapCheap unRouteT a')
99102 traverseDMapWithKeyWithAdjust f dm edm = RouteT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
100103 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
@@ -161,6 +164,7 @@ runRoute toSegments fromSegments (RouteT f) = do
161164 ctx = RouteContext{ _routeContext_allSegments = allSegments
162165 , _routeContext_nextSegments = allSegments
163166 , _routeContext_currentSegment = pure Nothing
167+ , _routeContext_currentDepth = 0
164168 }
165169 newSegments <- runReaderT f ctx
166170 let x = ffor uri $ \uri' -> fromSegments uri' <$> newSegments
@@ -187,12 +191,15 @@ withRoute f = do
187191 segmentsNested <- maybeDyn segmentsFlat
188192
189193 let
194+ nextDepth = 1 + _routeContext_currentDepth ctx
195+
190196 component = ffor segmentsNested $ \x -> case x of
191197 Nothing -> do
192198 let
193199 segment = Nothing
194200 newCtx = ctx{ _routeContext_currentSegment = pure segment
195201 , _routeContext_nextSegments = pure []
202+ , _routeContext_currentDepth = nextDepth
196203 }
197204
198205 a <- withSegments (const newCtx) (f segment)
@@ -203,6 +210,7 @@ withRoute f = do
203210 segmentDyn <- fmap Just <$> holdUniqDyn (fst <$> segmentUncons)
204211 let newCtx = ctx{ _routeContext_currentSegment = segmentDyn
205212 , _routeContext_nextSegments = snd <$> segmentUncons
213+ , _routeContext_currentDepth = nextDepth
206214 }
207215
208216 dyn $ ffor segmentDyn $ \segment ->
@@ -227,8 +235,7 @@ parentRouteSegments = do
227235 ctx <- routeContext
228236 holdUniqDyn $ do
229237 allSegments <- _routeContext_allSegments ctx
230− nBelow <- length <$> _routeContext_nextSegments ctx
231− pure $ take (length allSegments - nBelow) allSegments
238+ pure $ take (_routeContext_currentDepth ctx - 1) allSegments
232239
233240redirectLocally :: (PostBuild t m) => [segment] -> m (Event t [segment])
234241redirectLocally segments = (segments <$) <$> getPostBuild
@@ -242,7 +249,3 @@ fragAsText uri = maybe "" decodeUtf8 (uri ^. fragmentL)
242249
243250pathSegments :: URIRef a -> [ByteString]
244251pathSegments uri = uri ^. pathL . to (B8.split '/')
245−
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