@@ -41,6 +41,11 @@ module Obelisk.Route.Frontend
4141 , SetRoute(..)
4242 , runSetRouteT
4343 , mapSetRouteT
44+ , RouteToUrl(..)
45+ , RouteToUrlT(..)
46+ , runRouteToUrlT
47+ , mapRouteToUrlT
48+ , routeLink
4449 ) where
4550
4651import Prelude hiding ((.), id)
@@ -61,6 +66,8 @@ import Data.Constraint (Dict (..))
6166import Data.Dependent.Sum (DSum (..))
6267import Data.GADT.Compare
6368import Data.Monoid
69+import Data.Proxy
70+import Data.Text (Text)
6471import qualified Data.Text as T
6572import Data.Functor.Compose
6673import Reflex.Class
@@ -290,6 +297,85 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
290297 askQueryResult = lift askQueryResult
291298 queryIncremental = lift . queryIncremental
292299
300+class RouteToUrl r m | m -> r where
301+ askRouteToUrl :: m (r -> Text)
302+
303+newtype RouteToUrlT r m a = RouteToUrlT { unRouteToUrlT :: ReaderT (r -> Text) m a }
304+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument)
305+
306+runRouteToUrlT
307+ :: RouteToUrlT r m a
308+ -> (r -> Text)
309+ -> m a
310+runRouteToUrlT a = runReaderT (unRouteToUrlT a)
311+
312+mapRouteToUrlT :: (forall x. m x -> n x) -> RouteToUrlT r m a -> RouteToUrlT r n a
313+mapRouteToUrlT f (RouteToUrlT m) = RouteToUrlT $ mapReaderT f m
314+
315+instance Monad m => RouteToUrl r (RouteToUrlT r m) where
316+ askRouteToUrl = RouteToUrlT ask
317+
318+instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where
319+ askRouteToUrl = lift askRouteToUrl
320+
321+instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where
322+ askRouteToUrl = lift askRouteToUrl
323+
324+instance HasJSContext m => HasJSContext (RouteToUrlT r m) where
325+ type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m
326+ askJSContext = lift askJSContext
327+
328+instance Prerender js m => Prerender js (RouteToUrlT r m) where
329+ prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
330+
331+instance Requester t m => Requester t (RouteToUrlT r m) where
332+ type Request (RouteToUrlT r m) = Request m
333+ type Response (RouteToUrlT r m) = Response m
334+ requesting = RouteToUrlT . requesting
335+ requesting_ = RouteToUrlT . requesting_
336+
337+#ifndef ghcjs_HOST_OS
338+deriving instance MonadJSM m => MonadJSM (RouteToUrlT r m)
339+#endif
340+
341+instance PerformEvent t m => PerformEvent t (RouteToUrlT r m) where
342+ type Performable (RouteToUrlT r m) = Performable m
343+ performEvent = lift . performEvent
344+ performEvent_ = lift . performEvent_
345+
346+instance MonadRef m => MonadRef (RouteToUrlT r m) where
347+ type Ref (RouteToUrlT r m) = Ref m
348+ newRef = lift . newRef
349+ readRef = lift . readRef
350+ writeRef r = lift . writeRef r
351+
352+instance HasJS x m => HasJS x (RouteToUrlT r m) where
353+ type JSX (RouteToUrlT r m) = JSX m
354+ liftJS = lift . liftJS
355+
356+instance MonadTransControl (RouteToUrlT r) where
357+ type StT (RouteToUrlT r) a = StT (ReaderT (r -> Text)) a
358+ liftWith = defaultLiftWith RouteToUrlT unRouteToUrlT
359+ restoreT = defaultRestoreT RouteToUrlT
360+
361+instance PrimMonad m => PrimMonad (RouteToUrlT r m ) where
362+ type PrimState (RouteToUrlT r m) = PrimState m
363+ primitive = lift . primitive
364+
365+instance DomBuilder t m => DomBuilder t (RouteToUrlT r m) where
366+ type DomBuilderSpace (RouteToUrlT r m) = DomBuilderSpace m
367+
368+instance Adjustable t m => Adjustable t (RouteToUrlT r m) where
369+ runWithReplace a0 a' = RouteToUrlT $ runWithReplace (coerce a0) $ coerceEvent a'
370+ traverseIntMapWithKeyWithAdjust f a0 a' = RouteToUrlT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
371+ traverseDMapWithKeyWithAdjust f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
372+ traverseDMapWithKeyWithAdjustWithMove f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
373+
374+instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where
375+ tellQueryIncremental = lift . tellQueryIncremental
376+ askQueryResult = lift askQueryResult
377+ queryIncremental = lift . queryIncremental
378+
293379runRouteViewT
294380 :: forall t m r a.
295381 ( TriggerEvent t m
@@ -300,7 +386,7 @@ runRouteViewT
300386 , MonadFix m
301387 )
302388 => (Encoder Identity Identity r PageName)
303− -> RoutedT t r (SetRouteT t r m) a
389+ -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a
304390 -> m a
305391runRouteViewT routeEncoder a = do
306392 rec historyState <- manageHistory $ HistoryCommand_PushState <$> setState
@@ -313,7 +399,7 @@ runRouteViewT routeEncoder a = do
313399 where
314400 errorLeft (Left e) = error (T.unpack e)
315401 errorLeft (Right x) = x
316− (result, changeState) <- runSetRouteT $ runRoutedT a route
402+ (result, changeState) <- runRouteToUrlT (runSetRouteT $ runRoutedT a route) $ (\(p, q) -> T.pack $ p <> q) . encode theEncoder
317403 let f (currentHistoryState, oldRoute) change =
318404 let newRoute = appEndo change oldRoute
319405 (newPath, newQuery) = encode theEncoder newRoute
@@ -337,6 +423,26 @@ runRouteViewT routeEncoder a = do
337423 setState = attachWith f ((,) <$> current historyState <*> current route) changeState
338424 return result
339425
426+-- | A link widget that, when clicked, sets the route to the provided route. In non-javascript
427+-- contexts, this widget falls back to using @href@s to control navigation
428+routeLink
429+ :: forall t m a route.
430+ ( DomBuilder t m
431+ , RouteToUrl (R route) m
432+ , SetRoute t (R route) m
433+ )
434+ => R route -- ^ Target route
435+ -> m a -- ^ Child widget
436+ -> m a
437+routeLink r w = do
438+ enc <- askRouteToUrl
439+ let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
440+ & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
441+ & elementConfig_initialAttributes .~ "href" =: enc r
442+ (e, a) <- element "a" cfg w
443+ setRoute $ r <$ domEvent Click e
444+ return a
445+
340446-- On ios due to sandboxing when loading the page from a file adapt the
341447-- path to be based on the hash.
342448