git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/route/src/Obelisk/Route/Frontend.hs
558 lines 22 kB history raw
1{-# LANGUAGE ApplicativeDo #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE RecursiveDo #-}
4{-# LANGUAGE StandaloneDeriving #-}
5{-# LANGUAGE ConstraintKinds #-}
6{-# LANGUAGE DefaultSignatures #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE KindSignatures #-}
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE OverloadedStrings #-}
14{-# LANGUAGE PatternSynonyms #-}
15{-# LANGUAGE RankNTypes #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE TemplateHaskell #-}
18{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE TypeFamilies #-}
20{-# LANGUAGE TypeOperators #-}
21{-# LANGUAGE ViewPatterns #-}
22{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23{-# LANGUAGE UndecidableInstances #-}
24{-# LANGUAGE DataKinds #-}
25{-# LANGUAGE FunctionalDependencies #-}
27module Obelisk.Route.Frontend
28 ( module Obelisk.Route
29 , pattern (:~)
30 , Routed
31 , RoutedT
32 , runRoutedT
33 , askRoute
34 , withRoutedT
35 , mapRoutedT
36 , subRoute
37 , subRoute_
38 , maybeRoute
39 , maybeRoute_
40 , maybeRouted
41 , eitherRoute
42 , eitherRoute_
43 , eitherRouted
44 , runRouteViewT
45 , SetRouteT(..)
46 , SetRoute(..)
47 , runSetRouteT
48 , mapSetRouteT
49 , RouteToUrl(..)
50 , RouteToUrlT(..)
51 , runRouteToUrlT
52 , mapRouteToUrlT
53 , routeLink
54 , dynRouteLink
55 , adaptedUriPath
56 , setAdaptedUriPath
57 ) where
59import Prelude hiding ((.), id)
61import Obelisk.Route
63import Control.Category (Category (..), (.))
64import Control.Category.Cartesian
65import Control.Lens hiding (Bifunctor, bimap, universe, element)
66import Control.Monad ((<=<))
67import Control.Monad.Fix
68import Control.Monad.Primitive
69import Control.Monad.Reader
70import Control.Monad.Ref
71import Control.Monad.Trans.Control
72import Data.Coerce
73import Data.Dependent.Sum (DSum (..))
74import Data.GADT.Compare
75import Data.Monoid
76import Data.Proxy
77import Data.Text (Text)
78import qualified Data.Text as T
79import Data.Functor.Compose
80import Reflex.Class
81import Reflex.Host.Class
82import Reflex.PostBuild.Class
83import Reflex.TriggerEvent.Class
84import Reflex.PerformEvent.Class
85import Reflex.EventWriter.Class
86import Reflex.EventWriter.Base
87import Reflex.Dynamic
88import Reflex.Dom.Builder.Class
89import Data.Type.Coercion
90import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can also be routed
91import Reflex.Dom.Core
92import qualified GHCJS.DOM.Types as DOM
93import Network.URI
94import Data.Maybe (fromMaybe)
95import qualified Data.List as L
97import Unsafe.Coerce
99import Obelisk.Configs
101infixr 5 :~
102pattern (:~) :: Reflex t => f a -> Dynamic t a -> DSum f (Compose (Dynamic t) Identity)
103pattern a :~ b <- a :=> (coerceDynamic . getCompose -> b)
105class Routed t r m | m -> t r where
106 askRoute :: m (Dynamic t r)
107 default askRoute :: (Monad m', MonadTrans f, Routed t r m', m ~ f m') => m (Dynamic t r)
108 askRoute = lift askRoute
110instance Monad m => Routed t r (RoutedT t r m) where
111 askRoute = RoutedT ask
113instance (Monad m, Routed t r m) => Routed t r (ReaderT r' m)
115newtype RoutedT t r m a = RoutedT { unRoutedT :: ReaderT (Dynamic t r) m a }
116 deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
118instance MonadReader r' m => MonadReader r' (RoutedT t r m) where
119 ask = lift ask
120 local = mapRoutedT . local
122instance HasJSContext m => HasJSContext (RoutedT t r m) where
123 type JSContextPhantom (RoutedT t r m) = JSContextPhantom m
124 askJSContext = lift askJSContext
126instance (Prerender js t m, Monad m) => Prerender js t (RoutedT t r m) where
127 type Client (RoutedT t r m) = RoutedT t r (Client m)
128 prerender server client = RoutedT $ do
129 r <- ask
130 lift $ prerender (runRoutedT server r) (runRoutedT client r)
132instance Requester t m => Requester t (RoutedT t r m) where
133 type Request (RoutedT t r m) = Request m
134 type Response (RoutedT t r m) = Response m
135 requesting = RoutedT . requesting
136 requesting_ = RoutedT . requesting_
138#ifndef ghcjs_HOST_OS
139deriving instance MonadJSM m => MonadJSM (RoutedT t r m)
140#endif
142instance PerformEvent t m => PerformEvent t (RoutedT t r m) where
143 type Performable (RoutedT t r m) = Performable m
144 performEvent = lift . performEvent
145 performEvent_ = lift . performEvent_
147instance MonadRef m => MonadRef (RoutedT t r m) where
148 type Ref (RoutedT t r m) = Ref m
149 newRef = lift . newRef
150 readRef = lift . readRef
151 writeRef r = lift . writeRef r
153instance HasJS x m => HasJS x (RoutedT t r m) where
154 type JSX (RoutedT t r m) = JSX m
155 liftJS = lift . liftJS
157deriving instance EventWriter t w m => EventWriter t w (RoutedT t r m)
159instance MonadTransControl (RoutedT t r) where
160 type StT (RoutedT t r) a = StT (ReaderT (Dynamic t r)) a
161 liftWith = defaultLiftWith RoutedT unRoutedT
162 restoreT = defaultRestoreT RoutedT
164instance PrimMonad m => PrimMonad (RoutedT t r m ) where
165 type PrimState (RoutedT t r m) = PrimState m
166 primitive = lift . primitive
168instance DomBuilder t m => DomBuilder t (RoutedT t r m) where
169 type DomBuilderSpace (RoutedT t r m) = DomBuilderSpace m
171instance Adjustable t m => Adjustable t (RoutedT t r m) where
172 runWithReplace a0 a' = RoutedT $ runWithReplace (coerce a0) $ coerceEvent a'
173 traverseIntMapWithKeyWithAdjust f a0 a' = RoutedT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
174 traverseDMapWithKeyWithAdjust f a0 a' = RoutedT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
175 traverseDMapWithKeyWithAdjustWithMove f a0 a' = RoutedT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
177instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RoutedT t r m) where
178 tellQueryIncremental = lift . tellQueryIncremental
179 askQueryResult = lift askQueryResult
180 queryIncremental = lift . queryIncremental
182instance HasConfigs m => HasConfigs (RoutedT t r m)
184instance (Monad m, RouteToUrl r m) => RouteToUrl r (QueryT t q m)
186instance (Monad m, SetRoute t r m) => SetRoute t r (QueryT t q m)
188instance (Monad m, RouteToUrl r m) => RouteToUrl r (EventWriterT t w m)
190instance (Monad m, SetRoute t r m) => SetRoute t r (EventWriterT t w m)
192runRoutedT :: RoutedT t r m a -> Dynamic t r -> m a
193runRoutedT = runReaderT . unRoutedT
195mapRoutedT :: (m a -> n b) -> RoutedT t r m a -> RoutedT t r n b
196mapRoutedT f = RoutedT . mapReaderT f . unRoutedT
198withRoutedT :: (Dynamic t r -> Dynamic t r') -> RoutedT t r' m a -> RoutedT t r m a
199withRoutedT f = RoutedT . withReaderT f . unRoutedT
201subRoute_ :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r a -> RoutedT t a m ()) -> RoutedT t (R r) m ()
202subRoute_ f = factorRouted $ strictDynWidget_ $ \(c :=> r') -> do
203 runRoutedT (f c) r'
205subRoute :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r a -> RoutedT t a m b) -> RoutedT t (R r) m (Dynamic t b)
206subRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do
207 runRoutedT (f c) r'
209maybeRoute_ :: (MonadFix m, MonadHold t m, Adjustable t m) => m () -> RoutedT t r m () -> RoutedT t (Maybe r) m ()
210maybeRoute_ n j = maybeRouted $ strictDynWidget_ $ \case
211 Nothing -> n
212 Just r -> runRoutedT j r
214maybeRoute :: (MonadFix m, MonadHold t m, Adjustable t m) => m a -> RoutedT t r m a -> RoutedT t (Maybe r) m (Dynamic t a)
215maybeRoute n j = maybeRouted $ strictDynWidget $ \case
216 Nothing -> n
217 Just r -> runRoutedT j r
219{-
220maybeRoute :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => m a -> RoutedT t r m a -> RoutedT t (Maybe r) m a
221maybeRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do
222 runRoutedT (f c) r'
223-}
225eitherRoute_
226 :: (MonadFix m, MonadHold t m, Adjustable t m)
227 => RoutedT t l m ()
228 -> RoutedT t r m ()
229 -> RoutedT t (Either l r) m ()
230eitherRoute_ l r = eitherRouted $ strictDynWidget_ $ either (runRoutedT l) (runRoutedT r)
232eitherRoute
233 :: (MonadFix m, MonadHold t m, Adjustable t m)
234 => RoutedT t l m a
235 -> RoutedT t r m a
236 -> RoutedT t (Either l r) m (Dynamic t a)
237eitherRoute l r = eitherRouted $ strictDynWidget $ either (runRoutedT l) (runRoutedT r)
239dsumValueCoercion :: Coercion f g -> Coercion (DSum k f) (DSum k g)
240dsumValueCoercion Coercion = Coercion
242dynamicIdentityCoercion :: Coercion (Compose (Dynamic t) Identity) (Dynamic t)
243dynamicIdentityCoercion = unsafeCoerce (Coercion :: Coercion (Identity ()) ()) --TODO: Is it possible to prove this?
245factorRouted :: (Reflex t, MonadFix m, MonadHold t m, GEq f) => RoutedT t (DSum f (Dynamic t)) m a -> RoutedT t (DSum f Identity) m a
246factorRouted r = RoutedT $ ReaderT $ \d -> do
247 d' <- factorDyn d
248 runRoutedT r $ (coerceWith (dynamicCoercion $ dsumValueCoercion dynamicIdentityCoercion) d')
250maybeRouted :: (Reflex t, MonadFix m, MonadHold t m) => RoutedT t (Maybe (Dynamic t a)) m b -> RoutedT t (Maybe a) m b
251maybeRouted r = RoutedT $ ReaderT $ \d -> do
252 d' <- maybeDyn d
253 runRoutedT r d'
255eitherRouted :: (Reflex t, MonadFix m, MonadHold t m) => RoutedT t (Either (Dynamic t a) (Dynamic t b)) m c -> RoutedT t (Either a b) m c
256eitherRouted r = RoutedT $ ReaderT $ runRoutedT r <=< eitherDyn
258-- | WARNING: The input 'Dynamic' must be fully constructed when this is run
259strictDynWidget :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m b) -> RoutedT t a m (Dynamic t b)
260strictDynWidget f = RoutedT $ ReaderT $ \r -> do
261 r0 <- sample $ current r
262 (result0, result') <- runWithReplace (f r0) $ f <$> updated r
263 holdDyn result0 result'
265strictDynWidget_ :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m ()) -> RoutedT t a m ()
266strictDynWidget_ f = RoutedT $ ReaderT $ \r -> do
267 r0 <- sample $ current r
268 (_, _) <- runWithReplace (f r0) $ f <$> updated r
269 pure ()
271newtype SetRouteT t r m a = SetRouteT { unSetRouteT :: EventWriterT t (Endo r) m a }
272 deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, MonadIO, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
274instance (MonadFix m, MonadHold t m, DomBuilder t m) => DomBuilder t (SetRouteT t r m) where
275 type DomBuilderSpace (SetRouteT t r m) = DomBuilderSpace m
276 element t cfg child = SetRouteT $ element t cfg $ unSetRouteT child
277 inputElement = lift . inputElement
278 textAreaElement = lift . textAreaElement
279 selectElement cfg child = SetRouteT $ selectElement cfg $ unSetRouteT child
281instance HasJSContext m => HasJSContext (SetRouteT t r m) where
282 type JSContextPhantom (SetRouteT t r m) = JSContextPhantom m
283 askJSContext = lift askJSContext
285mapSetRouteT :: (forall x. m x -> n x) -> SetRouteT t r m a -> SetRouteT t r n a
286mapSetRouteT f (SetRouteT x) = SetRouteT (mapEventWriterT f x)
288runSetRouteT :: (Reflex t, Monad m) => SetRouteT t r m a -> m (a, Event t (Endo r))
289runSetRouteT = runEventWriterT . unSetRouteT
291class Reflex t => SetRoute t r m | m -> t r where
292 setRoute :: Event t r -> m ()
293 modifyRoute :: Event t (r -> r) -> m ()
294 default modifyRoute :: (Monad m', MonadTrans f, SetRoute t r m', m ~ f m') => Event t (r -> r) -> m ()
295 modifyRoute = lift . modifyRoute
297 setRoute = modifyRoute . fmap const
299instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
300 modifyRoute = SetRouteT . tellEvent . fmap Endo
302instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m)
304instance (Monad m, SetRoute t r m) => SetRoute t r (ReaderT r' m)
306instance (PerformEvent t m, Prerender js t m, Monad m, Reflex t) => Prerender js t (SetRouteT t r m) where
307 type Client (SetRouteT t r m) = SetRouteT t r (Client m)
308 prerender server client = do
309 d <- lift $ prerender (runSetRouteT server) (runSetRouteT client)
310 let (a, r) = splitDynPure d
311 -- Must be prompt here
312 SetRouteT . tellEvent $ switchPromptlyDyn r
313 pure a
315instance Requester t m => Requester t (SetRouteT t r m) where
316 type Request (SetRouteT t r m) = Request m
317 type Response (SetRouteT t r m) = Response m
318 requesting = SetRouteT . requesting
319 requesting_ = SetRouteT . requesting_
321instance (Monad m, SetRoute t r m) => SetRoute t r (RequesterT t req rsp m)
323#ifndef ghcjs_HOST_OS
324deriving instance MonadJSM m => MonadJSM (SetRouteT t r m)
325#endif
327instance PerformEvent t m => PerformEvent t (SetRouteT t r m) where
328 type Performable (SetRouteT t r m) = Performable m
329 performEvent = lift . performEvent
330 performEvent_ = lift . performEvent_
332instance MonadRef m => MonadRef (SetRouteT t r m) where
333 type Ref (SetRouteT t r m) = Ref m
334 newRef = lift . newRef
335 readRef = lift . readRef
336 writeRef r = lift . writeRef r
338instance HasJS x m => HasJS x (SetRouteT t r m) where
339 type JSX (SetRouteT t r m) = JSX m
340 liftJS = lift . liftJS
342instance PrimMonad m => PrimMonad (SetRouteT t r m ) where
343 type PrimState (SetRouteT t r m) = PrimState m
344 primitive = lift . primitive
346instance HasConfigs m => HasConfigs (SetRouteT t r m)
348instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
349 runWithReplace a0 a' = SetRouteT $ runWithReplace (coerce a0) $ coerceEvent a'
350 traverseIntMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
351 traverseDMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
352 traverseDMapWithKeyWithAdjustWithMove f a0 a' = SetRouteT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
354instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
355 tellQueryIncremental = lift . tellQueryIncremental
356 askQueryResult = lift askQueryResult
357 queryIncremental = lift . queryIncremental
359class RouteToUrl r m | m -> r where
360 askRouteToUrl :: m (r -> Text)
361 default askRouteToUrl :: (Monad m', MonadTrans f, RouteToUrl r m', m ~ f m') => m (r -> Text)
362 askRouteToUrl = lift askRouteToUrl
364newtype RouteToUrlT r m a = RouteToUrlT { unRouteToUrlT :: ReaderT (r -> Text) m a }
365 deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
367runRouteToUrlT
368 :: RouteToUrlT r m a
369 -> (r -> Text)
370 -> m a
371runRouteToUrlT a = runReaderT (unRouteToUrlT a)
373mapRouteToUrlT :: (forall x. m x -> n x) -> RouteToUrlT r m a -> RouteToUrlT r n a
374mapRouteToUrlT f (RouteToUrlT m) = RouteToUrlT $ mapReaderT f m
376instance Monad m => RouteToUrl r (RouteToUrlT r m) where
377 askRouteToUrl = RouteToUrlT ask
379instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where
381instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where
383instance (Monad m, RouteToUrl r m) => RouteToUrl r (ReaderT r' m) where
385instance (Monad m, RouteToUrl r m) => RouteToUrl r (RequesterT t req rsp m)
387instance HasJSContext m => HasJSContext (RouteToUrlT r m) where
388 type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m
389 askJSContext = lift askJSContext
391instance (Prerender js t m, Monad m) => Prerender js t (RouteToUrlT r m) where
392 type Client (RouteToUrlT r m) = RouteToUrlT r (Client m)
393 prerender server client = do
394 r <- RouteToUrlT ask
395 lift $ prerender (runRouteToUrlT server r) (runRouteToUrlT client r)
397instance Requester t m => Requester t (RouteToUrlT r m) where
398 type Request (RouteToUrlT r m) = Request m
399 type Response (RouteToUrlT r m) = Response m
400 requesting = RouteToUrlT . requesting
401 requesting_ = RouteToUrlT . requesting_
403#ifndef ghcjs_HOST_OS
404deriving instance MonadJSM m => MonadJSM (RouteToUrlT r m)
405#endif
407instance PerformEvent t m => PerformEvent t (RouteToUrlT r m) where
408 type Performable (RouteToUrlT r m) = Performable m
409 performEvent = lift . performEvent
410 performEvent_ = lift . performEvent_
412instance MonadRef m => MonadRef (RouteToUrlT r m) where
413 type Ref (RouteToUrlT r m) = Ref m
414 newRef = lift . newRef
415 readRef = lift . readRef
416 writeRef r = lift . writeRef r
418instance HasJS x m => HasJS x (RouteToUrlT r m) where
419 type JSX (RouteToUrlT r m) = JSX m
420 liftJS = lift . liftJS
422instance MonadTransControl (RouteToUrlT r) where
423 type StT (RouteToUrlT r) a = StT (ReaderT (r -> Text)) a
424 liftWith = defaultLiftWith RouteToUrlT unRouteToUrlT
425 restoreT = defaultRestoreT RouteToUrlT
427instance PrimMonad m => PrimMonad (RouteToUrlT r m ) where
428 type PrimState (RouteToUrlT r m) = PrimState m
429 primitive = lift . primitive
431instance DomBuilder t m => DomBuilder t (RouteToUrlT r m) where
432 type DomBuilderSpace (RouteToUrlT r m) = DomBuilderSpace m
434instance Adjustable t m => Adjustable t (RouteToUrlT r m) where
435 runWithReplace a0 a' = RouteToUrlT $ runWithReplace (coerce a0) $ coerceEvent a'
436 traverseIntMapWithKeyWithAdjust f a0 a' = RouteToUrlT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
437 traverseDMapWithKeyWithAdjust f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
438 traverseDMapWithKeyWithAdjustWithMove f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
440instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where
441 tellQueryIncremental = lift . tellQueryIncremental
442 askQueryResult = lift askQueryResult
443 queryIncremental = lift . queryIncremental
445instance HasConfigs m => HasConfigs (RouteToUrlT t m)
447runRouteViewT
448 :: forall t m r a.
449 ( TriggerEvent t m
450 , PerformEvent t m
451 , MonadHold t m
452 , MonadJSM m
453 , MonadJSM (Performable m)
454 , MonadFix m
455 )
456 => (Encoder Identity Identity r PageName)
457 --TODO: Get rid of the switchover and useHash arguments
458 -- useHash can probably be baked into the encoder
459 -> Event t () -- ^ Switchover event, nothing is done until this event fires. Used to prevent incorrect DOM expectations at hydration switchover time
460 -> Bool
461 -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a
462 -> m a
463runRouteViewT routeEncoder switchover useHash a = do
464 rec historyState <- manageHistory' switchover $ HistoryCommand_PushState <$> setState
465 let theEncoder = pageNameEncoder . hoistParse (pure . runIdentity) routeEncoder
466 -- NB: The can only fail if the uriPath doesn't begin with a '/' or if the uriQuery
467 -- is nonempty, but begins with a character that isn't '?'. Since we don't expect
468 -- this ever to happen, we'll just handle it by failing completely with 'error'.
469 route :: Dynamic t r
470 route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath useHash &&& uriQuery) . _historyItem_uri) historyState
471 where
472 errorLeft (Left e) = error (T.unpack e)
473 errorLeft (Right x) = x
474 (result, changeState) <- runRouteToUrlT (runSetRouteT $ runRoutedT a route) $ (\(p, q) -> T.pack $ p <> q) . encode theEncoder
475 let f (currentHistoryState, oldRoute) change =
476 let newRoute = appEndo change oldRoute
477 (newPath, newQuery) = encode theEncoder newRoute
478 in HistoryStateUpdate
479 { _historyStateUpdate_state = DOM.SerializedScriptValue jsNull
480 -- We always provide "" as the title. On Firefox, Chrome, and
481 -- Edge, this parameter does nothing. On Safari, "" has the
482 -- same behavior as other browsers (as far as I can tell), but
483 -- anything else sets the title for the back button list item
484 -- the *next* time pushState is called, unless the page title
485 -- is changed in the interim. Since the Safari functionality
486 -- is near-pointless and also confusing, I'm not going to even
487 -- bother exposing it; if there ends up being a real use case,
488 -- we can change this function later to accommodate.
489 -- See: https://github.com/whatwg/html/issues/2174
490 , _historyStateUpdate_title = ""
491 , _historyStateUpdate_uri = Just $ setAdaptedUriPath useHash newPath $ (_historyItem_uri currentHistoryState)
492 { uriQuery = newQuery
493 }
494 }
495 setState = attachWith f ((,) <$> current historyState <*> current route) changeState
496 return result
498-- | A link widget that, when clicked, sets the route to the provided route. In non-javascript
499-- contexts, this widget falls back to using @href@s to control navigation
500routeLink
501 :: forall t m a route.
502 ( DomBuilder t m
503 , RouteToUrl (R route) m
504 , SetRoute t (R route) m
505 )
506 => R route -- ^ Target route
507 -> m a -- ^ Child widget
508 -> m a
509routeLink r w = do
510 enc <- askRouteToUrl
511 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
512 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
513 & elementConfig_initialAttributes .~ "href" =: enc r
514 (e, a) <- element "a" cfg w
515 setRoute $ r <$ domEvent Click e
516 return a
518-- | A link widget that, when clicked, sets the route to current value of the
519-- provided dynamic route. In non-javascript contexts the value of the dynamic post
520-- build is used so the link still works like 'routeLink'.
521dynRouteLink
522 :: forall t m a route.
523 ( DomBuilder t m
524 , PostBuild t m
525 , RouteToUrl (R route) m
526 , SetRoute t (R route) m
527 )
528 => Dynamic t (R route) -- ^ Target route
529 -> m a -- ^ Child widget
530 -> m a
531dynRouteLink dr w = do
532 enc <- askRouteToUrl
533 er <- dynamicAttributesToModifyAttributes $ ("href" =:) . enc <$> dr
534 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
535 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
536 & elementConfig_modifyAttributes .~ er
537 (e, a) <- element "a" cfg w
538 setRoute $ tag (current dr) $ domEvent Click e
539 return a
541-- On ios due to sandboxing when loading the page from a file adapt the
542-- path to be based on the hash.
544adaptedUriPath :: Bool -> URI -> String
545adaptedUriPath = \case
546 True -> hashToPath . uriFragment
547 False -> uriPath
549setAdaptedUriPath :: Bool -> String -> URI -> URI
550setAdaptedUriPath useHash s u = case useHash of
551 True -> u { uriFragment = pathToHash s }
552 False -> u { uriPath = s }
554pathToHash :: String -> String
555pathToHash = ('#' :) . fromMaybe "" . L.stripPrefix "/"
557hashToPath :: String -> String
558hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"