@@ -7,10 +7,11 @@
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
1516import Control.Lens (Rewrapped, Wrapped (..), iso, to,
1617 (^.))
@@ -31,7 +32,6 @@ import Data.Maybe (listToMaybe)
3132import Data.Text (Text)
3233import qualified Data.Text as T
3334import Data.Text.Encoding (decodeUtf8, encodeUtf8)
34−import Foreign.JavaScript.TH
3535import Language.Javascript.JSaddle (MonadJSM)
3636import Reflex
3737import Reflex.Dom.Builder.Class
@@ -113,6 +113,8 @@ instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT t s
113113 placeRawElement = lift . placeRawElement
114114 wrapRawElement e = lift . wrapRawElement e
115115
116+instance (Monad m, NotReady t m) => NotReady t (RouteT t segment m)
117+
116118instance MonadReader r m => MonadReader r (RouteT t segment m) where
117119 ask = lift ask
118120 local f (RouteT a) = RouteT $ mapReaderT (local f) a
@@ -126,14 +128,25 @@ instance HasRoute t segment m => HasRoute t segment (EventWriterT t w m) where
126128instance EventWriter t w m => EventWriter t w (RouteT t segment m) where
127129 tellEvent = lift . tellEvent
128130
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+
129138instance HasDocument m => HasDocument (RouteT t segment m)
130−instance HasJSContext m => HasJSContext (RouteT t segment m) where
131− type JSContextPhantom (RouteT t segment m) = JSContextPhantom m
132− askJSContext = RouteT askJSContext
139+
133140#ifndef ghcjs_HOST_OS
134141instance MonadJSM m => MonadJSM (RouteT t segment m)
135142#endif
136143
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
149+
137150
138151instance PrimMonad m => PrimMonad (RouteT t segment m) where
139152 type PrimState (RouteT t segment m) = PrimState m
@@ -142,7 +155,9 @@ instance PrimMonad m => PrimMonad (RouteT t segment m) where
142155--instance HasMountStatus t m => HasMountStatus t (RouteT segment r m) where
143156-- getMountStatus = lift getMountStatus
144157
145−
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.
146161runRoute :: forall segment t m. (MonadWidget t m, Eq segment)
147162 => (forall a. URIRef a -> [segment])
148163 -> (forall a. URIRef a -> [segment] -> URIRef a)
@@ -170,16 +185,21 @@ runRoute toSegments fromSegments (RouteT f) = do
170185 let x = ffor uri $ \uri' -> fromSegments uri' <$> newSegments
171186 pure (switch (current x))
172187
173−
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'.
174190runRouteWithPathInFragment
175191 :: forall t m. (MonadWidget t m)
176192 => RouteT t Text m (Event t [Text])
177193 -> m ()
178194runRouteWithPathInFragment = runRoute
179− (T.splitOn "/" . T.dropAround (=='/') . fragAsText)
195+ (nullTextToEmptyList . T.splitOn "/" . T.dropAround (=='/') . fragAsText)
180196 (\oldUrl -> setFrag oldUrl . T.intercalate "/")
197+ where
198+ nullTextToEmptyList [""] = []
199+ nullTextToEmptyList x = x
181200
182−
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.
183203withRoute
184204 :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute t segment m, Eq segment)
185205 => (Maybe segment -> m a)
@@ -218,25 +238,33 @@ withRoute f = do
218238
219239 switchPromptly never =<< dyn component
220240
221−
241+-- | All routing segments in the current URL.
222242allRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])
223243allRouteSegments = _routeContext_allSegments <$> routeContext
224244
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.
225247currentRouteSegment :: (Functor m, HasRoute t segment m) => m (Dynamic t (Maybe segment))
226248currentRouteSegment = _routeContext_currentSegment <$> routeContext
227249
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.
228252nextRouteSegment :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t (Maybe segment))
229253nextRouteSegment = do
230254 ctx <- routeContext
231255 holdUniqDyn (listToMaybe <$> _routeContext_nextSegments ctx)
232256
257+-- | Route segments from parent layers.
233258parentRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])
234259parentRouteSegments = do
235260 ctx <- routeContext
236− holdUniqDyn $ do
237− allSegments <- _routeContext_allSegments ctx
238− pure $ take (_routeContext_currentDepth ctx - 1) allSegments
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
239266
267+-- | A simple helper that produces a routing event on 'getPostBuild'.
240268redirectLocally :: (PostBuild t m) => [segment] -> m (Event t [segment])
241269redirectLocally segments = (segments <$) <$> getPostBuild
242270