@@ -3,6 +3,7 @@
33{-# LANGUAGE RecursiveDo #-}
44{-# LANGUAGE StandaloneDeriving #-}
55{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE DefaultSignatures #-}
67{-# LANGUAGE FlexibleContexts #-}
78{-# LANGUAGE FlexibleInstances #-}
89{-# LANGUAGE GADTs #-}
@@ -14,6 +15,7 @@
1415{-# LANGUAGE RankNTypes #-}
1516{-# LANGUAGE ScopedTypeVariables #-}
1617{-# LANGUAGE TemplateHaskell #-}
18+{-# LANGUAGE TupleSections #-}
1719{-# LANGUAGE TypeFamilies #-}
1820{-# LANGUAGE TypeOperators #-}
1921{-# LANGUAGE ViewPatterns #-}
@@ -36,6 +38,9 @@ module Obelisk.Route.Frontend
3638 , maybeRoute
3739 , maybeRoute_
3840 , maybeRouted
41+ , eitherRoute
42+ , eitherRoute_
43+ , eitherRouted
3944 , runRouteViewT
4045 , SetRouteT(..)
4146 , SetRoute(..)
@@ -46,6 +51,9 @@ module Obelisk.Route.Frontend
4651 , runRouteToUrlT
4752 , mapRouteToUrlT
4853 , routeLink
54+ , dynRouteLink
55+ , adaptedUriPath
56+ , setAdaptedUriPath
4957 ) where
5058
5159import Prelude hiding ((.), id)
@@ -55,14 +63,13 @@ import Obelisk.Route
5563import Control.Category (Category (..), (.))
5664import Control.Category.Cartesian
5765import Control.Lens hiding (Bifunctor, bimap, universe, element)
66+import Control.Monad ((<=<))
5867import Control.Monad.Fix
5968import Control.Monad.Primitive
69+import Control.Monad.Reader
6070import Control.Monad.Ref
61−import Control.Monad.Trans
6271import Control.Monad.Trans.Control
63−import Control.Monad.Trans.Reader
6472import Data.Coerce
65−import Data.Constraint (Dict (..))
6673import Data.Dependent.Sum (DSum (..))
6774import Data.GADT.Compare
6875import Data.Monoid
@@ -84,32 +91,43 @@ import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can
8491import Reflex.Dom.Core
8592import qualified GHCJS.DOM.Types as DOM
8693import Network.URI
87−#if defined(ios_HOST_OS)
8894import Data.Maybe (fromMaybe)
8995import qualified Data.List as L
90−#endif
9196
9297import Unsafe.Coerce
9398
99+import Obelisk.Configs
100+
94101infixr 5 :~
95102pattern (:~) :: Reflex t => f a -> Dynamic t a -> DSum f (Compose (Dynamic t) Identity)
96103pattern a :~ b <- a :=> (coerceDynamic . getCompose -> b)
97104
98105class Routed t r m | m -> t r where
99106 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
100109
101110instance Monad m => Routed t r (RoutedT t r m) where
102111 askRoute = RoutedT ask
103112
113+instance (Monad m, Routed t r m) => Routed t r (ReaderT r' m)
114+
104115newtype RoutedT t r m a = RoutedT { unRoutedT :: ReaderT (Dynamic t r) m a }
105− deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument)
116+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
117+
118+instance MonadReader r' m => MonadReader r' (RoutedT t r m) where
119+ ask = lift ask
120+ local = mapRoutedT . local
106121
107122instance HasJSContext m => HasJSContext (RoutedT t r m) where
108123 type JSContextPhantom (RoutedT t r m) = JSContextPhantom m
109124 askJSContext = lift askJSContext
110125
111−instance Prerender js m => Prerender js (RoutedT t r m) where
112− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
126+instance (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)
113131
114132instance Requester t m => Requester t (RoutedT t r m) where
115133 type Request (RoutedT t r m) = Request m
@@ -161,17 +179,20 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RoutedT t r m) where
161179 askQueryResult = lift askQueryResult
162180 queryIncremental = lift . queryIncremental
163181
164−instance (Monad m, RouteToUrl r m) => RouteToUrl r (QueryT t q m) where
165− askRouteToUrl = lift askRouteToUrl
182+instance HasConfigs m => HasConfigs (RoutedT t r m)
166183
167−instance (Monad m, SetRoute t r m) => SetRoute t r (QueryT t q m) where
168− setRoute = lift . setRoute
169− modifyRoute = lift . modifyRoute
184+instance (Monad m, RouteToUrl r m) => RouteToUrl r (QueryT t q m)
185+
186+instance (Monad m, SetRoute t r m) => SetRoute t r (QueryT t q m)
187+
188+instance (Monad m, RouteToUrl r m) => RouteToUrl r (EventWriterT t w m)
189+
190+instance (Monad m, SetRoute t r m) => SetRoute t r (EventWriterT t w m)
170191
171192runRoutedT :: RoutedT t r m a -> Dynamic t r -> m a
172193runRoutedT = runReaderT . unRoutedT
173194
174−mapRoutedT :: (m a -> n a) -> RoutedT t r m a -> RoutedT t r n a
195+mapRoutedT :: (m a -> n b) -> RoutedT t r m a -> RoutedT t r n b
175196mapRoutedT f = RoutedT . mapReaderT f . unRoutedT
176197
177198withRoutedT :: (Dynamic t r -> Dynamic t r') -> RoutedT t r' m a -> RoutedT t r m a
@@ -201,6 +222,20 @@ maybeRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do
201222 runRoutedT (f c) r'
202223-}
203224
225+eitherRoute_
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 ()
230+eitherRoute_ l r = eitherRouted $ strictDynWidget_ $ either (runRoutedT l) (runRoutedT r)
231+
232+eitherRoute
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)
237+eitherRoute l r = eitherRouted $ strictDynWidget $ either (runRoutedT l) (runRoutedT r)
238+
204239dsumValueCoercion :: Coercion f g -> Coercion (DSum k f) (DSum k g)
205240dsumValueCoercion Coercion = Coercion
206241
@@ -217,6 +252,9 @@ maybeRouted r = RoutedT $ ReaderT $ \d -> do
217252 d' <- maybeDyn d
218253 runRoutedT r d'
219254
255+eitherRouted :: (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
256+eitherRouted r = RoutedT $ ReaderT $ runRoutedT r <=< eitherDyn
257+
220258-- | WARNING: The input 'Dynamic' must be fully constructed when this is run
221259strictDynWidget :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m b) -> RoutedT t a m (Dynamic t b)
222260strictDynWidget f = RoutedT $ ReaderT $ \r -> do
@@ -231,7 +269,7 @@ strictDynWidget_ f = RoutedT $ ReaderT $ \r -> do
231269 pure ()
232270
233271newtype SetRouteT t r m a = SetRouteT { unSetRouteT :: EventWriterT t (Endo r) m a }
234− deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, MonadIO, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadReflexCreateTrigger t, HasDocument)
272+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, MonadIO, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
235273
236274instance (MonadFix m, MonadHold t m, DomBuilder t m) => DomBuilder t (SetRouteT t r m) where
237275 type DomBuilderSpace (SetRouteT t r m) = DomBuilderSpace m
@@ -253,16 +291,26 @@ runSetRouteT = runEventWriterT . unSetRouteT
253291class Reflex t => SetRoute t r m | m -> t r where
254292 setRoute :: Event t r -> m ()
255293 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
296+
256297 setRoute = modifyRoute . fmap const
257298
258299instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
259300 modifyRoute = SetRouteT . tellEvent . fmap Endo
260301
261−instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m) where
262− modifyRoute = lift . modifyRoute
302+instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m)
263303
264−instance Prerender js m => Prerender js (SetRouteT t r m) where
265− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
304+instance (Monad m, SetRoute t r m) => SetRoute t r (ReaderT r' m)
305+
306+instance (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
266314
267315instance Requester t m => Requester t (SetRouteT t r m) where
268316 type Request (SetRouteT t r m) = Request m
@@ -270,6 +318,8 @@ instance Requester t m => Requester t (SetRouteT t r m) where
270318 requesting = SetRouteT . requesting
271319 requesting_ = SetRouteT . requesting_
272320
321+instance (Monad m, SetRoute t r m) => SetRoute t r (RequesterT t req rsp m)
322+
273323#ifndef ghcjs_HOST_OS
274324deriving instance MonadJSM m => MonadJSM (SetRouteT t r m)
275325#endif
@@ -293,6 +343,8 @@ instance PrimMonad m => PrimMonad (SetRouteT t r m ) where
293343 type PrimState (SetRouteT t r m) = PrimState m
294344 primitive = lift . primitive
295345
346+instance HasConfigs m => HasConfigs (SetRouteT t r m)
347+
296348instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
297349 runWithReplace a0 a' = SetRouteT $ runWithReplace (coerce a0) $ coerceEvent a'
298350 traverseIntMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
@@ -306,9 +358,11 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
306358
307359class RouteToUrl r m | m -> r where
308360 askRouteToUrl :: m (r -> Text)
361+ default askRouteToUrl :: (Monad m', MonadTrans f, RouteToUrl r m', m ~ f m') => m (r -> Text)
362+ askRouteToUrl = lift askRouteToUrl
309363
310364newtype RouteToUrlT r m a = RouteToUrlT { unRouteToUrlT :: ReaderT (r -> Text) m a }
311− deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument)
365+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
312366
313367runRouteToUrlT
314368 :: RouteToUrlT r m a
@@ -323,17 +377,22 @@ instance Monad m => RouteToUrl r (RouteToUrlT r m) where
323377 askRouteToUrl = RouteToUrlT ask
324378
325379instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where
326− askRouteToUrl = lift askRouteToUrl
327380
328381instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where
329− askRouteToUrl = lift askRouteToUrl
382+
383+instance (Monad m, RouteToUrl r m) => RouteToUrl r (ReaderT r' m) where
384+
385+instance (Monad m, RouteToUrl r m) => RouteToUrl r (RequesterT t req rsp m)
330386
331387instance HasJSContext m => HasJSContext (RouteToUrlT r m) where
332388 type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m
333389 askJSContext = lift askJSContext
334390
335−instance Prerender js m => Prerender js (RouteToUrlT r m) where
336− prerenderClientDict = fmap (\Dict -> Dict) (prerenderClientDict :: Maybe (Dict (PrerenderClientConstraint js m)))
391+instance (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)
337396
338397instance Requester t m => Requester t (RouteToUrlT r m) where
339398 type Request (RouteToUrlT r m) = Request m
@@ -383,6 +442,8 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where
383442 askQueryResult = lift askQueryResult
384443 queryIncremental = lift . queryIncremental
385444
445+instance HasConfigs m => HasConfigs (RouteToUrlT t m)
446+
386447runRouteViewT
387448 :: forall t m r a.
388449 ( TriggerEvent t m
@@ -393,16 +454,20 @@ runRouteViewT
393454 , MonadFix m
394455 )
395456 => (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
396461 -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a
397462 -> m a
398−runRouteViewT routeEncoder a = do
399− rec historyState <- manageHistory $ HistoryCommand_PushState <$> setState
463+runRouteViewT routeEncoder switchover useHash a = do
464+ rec historyState <- manageHistory' switchover $ HistoryCommand_PushState <$> setState
400465 let theEncoder = pageNameEncoder . hoistParse (pure . runIdentity) routeEncoder
401466 -- NB: The can only fail if the uriPath doesn't begin with a '/' or if the uriQuery
402467 -- is nonempty, but begins with a character that isn't '?'. Since we don't expect
403468 -- this ever to happen, we'll just handle it by failing completely with 'error'.
404469 route :: Dynamic t r
405− route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath &&& uriQuery) . _historyItem_uri) historyState
470+ route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath useHash &&& uriQuery) . _historyItem_uri) historyState
406471 where
407472 errorLeft (Left e) = error (T.unpack e)
408473 errorLeft (Right x) = x
@@ -423,7 +488,7 @@ runRouteViewT routeEncoder a = do
423488 -- we can change this function later to accommodate.
424489 -- See: https://github.com/whatwg/html/issues/2174
425490 , _historyStateUpdate_title = ""
426− , _historyStateUpdate_uri = Just $ setAdaptedUriPath newPath $ (_historyItem_uri currentHistoryState)
491+ , _historyStateUpdate_uri = Just $ setAdaptedUriPath useHash newPath $ (_historyItem_uri currentHistoryState)
427492 { uriQuery = newQuery
428493 }
429494 }
@@ -450,25 +515,44 @@ routeLink r w = do
450515 setRoute $ r <$ domEvent Click e
451516 return a
452517
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'.
521+dynRouteLink
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
531+dynRouteLink 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
540+
453541-- On ios due to sandboxing when loading the page from a file adapt the
454542-- path to be based on the hash.
455543
456−adaptedUriPath :: URI -> String
457−#if defined(ios_HOST_OS)
458−adaptedUriPath = hashToPath . uriFragment
544+adaptedUriPath :: Bool -> URI -> String
545+adaptedUriPath = \case
546+ True -> hashToPath . uriFragment
547+ False -> uriPath
459548
460−hashToPath :: String -> String
461−hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"
462−#else
463−adaptedUriPath = uriPath
464−#endif
465−
466−setAdaptedUriPath :: String -> URI -> URI
467−#if defined(ios_HOST_OS)
468−setAdaptedUriPath s u = u { uriFragment = pathToHash s }
549+setAdaptedUriPath :: Bool -> String -> URI -> URI
550+setAdaptedUriPath useHash s u = case useHash of
551+ True -> u { uriFragment = pathToHash s }
552+ False -> u { uriPath = s }
469553
470554pathToHash :: String -> String
471555pathToHash = ('#' :) . fromMaybe "" . L.stripPrefix "/"
472−#else
473−setAdaptedUriPath s u = u { uriPath = s }
474−#endif
556+
557+hashToPath :: String -> String
558+hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"