@@ -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,10 +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
182+instance HasConfigs m => HasConfigs (RoutedT t r m)
183+
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)
191+
164192runRoutedT :: RoutedT t r m a -> Dynamic t r -> m a
165193runRoutedT = runReaderT . unRoutedT
166194
167−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
168196mapRoutedT f = RoutedT . mapReaderT f . unRoutedT
169197
170198withRoutedT :: (Dynamic t r -> Dynamic t r') -> RoutedT t r' m a -> RoutedT t r m a
@@ -194,6 +222,20 @@ maybeRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do
194222 runRoutedT (f c) r'
195223-}
196224
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+
197239dsumValueCoercion :: Coercion f g -> Coercion (DSum k f) (DSum k g)
198240dsumValueCoercion Coercion = Coercion
199241
@@ -210,6 +252,9 @@ maybeRouted r = RoutedT $ ReaderT $ \d -> do
210252 d' <- maybeDyn d
211253 runRoutedT r d'
212254
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+
213258-- | WARNING: The input 'Dynamic' must be fully constructed when this is run
214259strictDynWidget :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m b) -> RoutedT t a m (Dynamic t b)
215260strictDynWidget f = RoutedT $ ReaderT $ \r -> do
@@ -224,7 +269,7 @@ strictDynWidget_ f = RoutedT $ ReaderT $ \r -> do
224269 pure ()
225270
226271newtype SetRouteT t r m a = SetRouteT { unSetRouteT :: EventWriterT t (Endo r) m a }
227− 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)
228273
229274instance (MonadFix m, MonadHold t m, DomBuilder t m) => DomBuilder t (SetRouteT t r m) where
230275 type DomBuilderSpace (SetRouteT t r m) = DomBuilderSpace m
@@ -246,16 +291,26 @@ runSetRouteT = runEventWriterT . unSetRouteT
246291class Reflex t => SetRoute t r m | m -> t r where
247292 setRoute :: Event t r -> m ()
248293 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+
249297 setRoute = modifyRoute . fmap const
250298
251299instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
252300 modifyRoute = SetRouteT . tellEvent . fmap Endo
253301
254−instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m) where
255− modifyRoute = lift . modifyRoute
302+instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m)
256303
257−instance Prerender js m => Prerender js (SetRouteT t r m) where
258− 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
259314
260315instance Requester t m => Requester t (SetRouteT t r m) where
261316 type Request (SetRouteT t r m) = Request m
@@ -263,6 +318,8 @@ instance Requester t m => Requester t (SetRouteT t r m) where
263318 requesting = SetRouteT . requesting
264319 requesting_ = SetRouteT . requesting_
265320
321+instance (Monad m, SetRoute t r m) => SetRoute t r (RequesterT t req rsp m)
322+
266323#ifndef ghcjs_HOST_OS
267324deriving instance MonadJSM m => MonadJSM (SetRouteT t r m)
268325#endif
@@ -286,6 +343,8 @@ instance PrimMonad m => PrimMonad (SetRouteT t r m ) where
286343 type PrimState (SetRouteT t r m) = PrimState m
287344 primitive = lift . primitive
288345
346+instance HasConfigs m => HasConfigs (SetRouteT t r m)
347+
289348instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
290349 runWithReplace a0 a' = SetRouteT $ runWithReplace (coerce a0) $ coerceEvent a'
291350 traverseIntMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
@@ -299,9 +358,11 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
299358
300359class RouteToUrl r m | m -> r where
301360 askRouteToUrl :: m (r -> Text)
361+ default askRouteToUrl :: (Monad m', MonadTrans f, RouteToUrl r m', m ~ f m') => m (r -> Text)
362+ askRouteToUrl = lift askRouteToUrl
302363
303364newtype 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)
365+ deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
305366
306367runRouteToUrlT
307368 :: RouteToUrlT r m a
@@ -316,17 +377,22 @@ instance Monad m => RouteToUrl r (RouteToUrlT r m) where
316377 askRouteToUrl = RouteToUrlT ask
317378
318379instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where
319− askRouteToUrl = lift askRouteToUrl
320380
321381instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where
322− 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)
323386
324387instance HasJSContext m => HasJSContext (RouteToUrlT r m) where
325388 type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m
326389 askJSContext = lift askJSContext
327390
328−instance Prerender js m => Prerender js (RouteToUrlT r m) where
329− 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)
330396
331397instance Requester t m => Requester t (RouteToUrlT r m) where
332398 type Request (RouteToUrlT r m) = Request m
@@ -376,6 +442,8 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where
376442 askQueryResult = lift askQueryResult
377443 queryIncremental = lift . queryIncremental
378444
445+instance HasConfigs m => HasConfigs (RouteToUrlT t m)
446+
379447runRouteViewT
380448 :: forall t m r a.
381449 ( TriggerEvent t m
@@ -386,16 +454,20 @@ runRouteViewT
386454 , MonadFix m
387455 )
388456 => (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
389461 -> RoutedT t r (SetRouteT t r (RouteToUrlT r m)) a
390462 -> m a
391−runRouteViewT routeEncoder a = do
392− rec historyState <- manageHistory $ HistoryCommand_PushState <$> setState
463+runRouteViewT routeEncoder switchover useHash a = do
464+ rec historyState <- manageHistory' switchover $ HistoryCommand_PushState <$> setState
393465 let theEncoder = pageNameEncoder . hoistParse (pure . runIdentity) routeEncoder
394466 -- NB: The can only fail if the uriPath doesn't begin with a '/' or if the uriQuery
395467 -- is nonempty, but begins with a character that isn't '?'. Since we don't expect
396468 -- this ever to happen, we'll just handle it by failing completely with 'error'.
397469 route :: Dynamic t r
398− route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath &&& uriQuery) . _historyItem_uri) historyState
470+ route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath useHash &&& uriQuery) . _historyItem_uri) historyState
399471 where
400472 errorLeft (Left e) = error (T.unpack e)
401473 errorLeft (Right x) = x
@@ -416,7 +488,7 @@ runRouteViewT routeEncoder a = do
416488 -- we can change this function later to accommodate.
417489 -- See: https://github.com/whatwg/html/issues/2174
418490 , _historyStateUpdate_title = ""
419− , _historyStateUpdate_uri = Just $ setAdaptedUriPath newPath $ (_historyItem_uri currentHistoryState)
491+ , _historyStateUpdate_uri = Just $ setAdaptedUriPath useHash newPath $ (_historyItem_uri currentHistoryState)
420492 { uriQuery = newQuery
421493 }
422494 }
@@ -443,25 +515,44 @@ routeLink r w = do
443515 setRoute $ r <$ domEvent Click e
444516 return a
445517
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+
446541-- On ios due to sandboxing when loading the page from a file adapt the
447542-- path to be based on the hash.
448543
449−adaptedUriPath :: URI -> String
450−#if defined(ios_HOST_OS)
451−adaptedUriPath = hashToPath . uriFragment
544+adaptedUriPath :: Bool -> URI -> String
545+adaptedUriPath = \case
546+ True -> hashToPath . uriFragment
547+ False -> uriPath
452548
453−hashToPath :: String -> String
454−hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"
455−#else
456−adaptedUriPath = uriPath
457−#endif
458−
459−setAdaptedUriPath :: String -> URI -> URI
460−#if defined(ios_HOST_OS)
461−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 }
462553
463554pathToHash :: String -> String
464555pathToHash = ('#' :) . fromMaybe "" . L.stripPrefix "/"
465−#else
466−setAdaptedUriPath s u = u { uriPath = s }
467−#endif
556+
557+hashToPath :: String -> String
558+hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"