@@ -3,6 +3,7 @@
3{-# LANGUAGE RecursiveDo #-}
3{-# LANGUAGE RecursiveDo #-}
4{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE StandaloneDeriving #-}
5{-# LANGUAGE ConstraintKinds #-}
5{-# LANGUAGE ConstraintKinds #-}
6+{-# LANGUAGE DefaultSignatures #-}
6{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
@@ -37,6 +38,9 @@ module Obelisk.Route.Frontend
37 , maybeRoute
38 , maybeRoute
38 , maybeRoute_
39 , maybeRoute_
39 , maybeRouted
40 , maybeRouted
40 , runRouteViewT
44 , runRouteViewT
41 , SetRouteT(..)
45 , SetRouteT(..)
42 , SetRoute(..)
46 , SetRoute(..)
@@ -52,17 +56,18 @@ module Obelisk.Route.Frontend
53import Prelude hiding ((.), id)
57import Prelude hiding ((.), id)
59+import Obelisk.ExecutableConfig.Frontend
55import Obelisk.Route
60import Obelisk.Route
57import Control.Category (Category (..), (.))
62import Control.Category (Category (..), (.))
58import Control.Category.Cartesian
63import Control.Category.Cartesian
59import Control.Lens hiding (Bifunctor, bimap, universe, element)
64import Control.Lens hiding (Bifunctor, bimap, universe, element)
65+import Control.Monad ((<=<))
60import Control.Monad.Fix
66import Control.Monad.Fix
61import Control.Monad.Primitive
67import Control.Monad.Primitive
68+import Control.Monad.Reader
62import Control.Monad.Ref
69import Control.Monad.Ref
63−import Control.Monad.Trans
64import Control.Monad.Trans.Control
70import Control.Monad.Trans.Control
65−import Control.Monad.Trans.Reader
66import Data.Coerce
71import Data.Coerce
67import Data.Dependent.Sum (DSum (..))
72import Data.Dependent.Sum (DSum (..))
68import Data.GADT.Compare
73import Data.GADT.Compare
@@ -98,13 +103,21 @@ pattern a :~ b <- a :=> (coerceDynamic . getCompose -> b)
99class Routed t r m | m -> t r where
104class Routed t r m | m -> t r where
100 askRoute :: m (Dynamic t r)
105 askRoute :: m (Dynamic t r)
106+ default askRoute :: (Monad m', MonadTrans f, Routed t r m', m ~ f m') => m (Dynamic t r)
107+ askRoute = lift askRoute
102instance Monad m => Routed t r (RoutedT t r m) where
109instance Monad m => Routed t r (RoutedT t r m) where
103 askRoute = RoutedT ask
110 askRoute = RoutedT ask
112+instance (Monad m, Routed t r m) => Routed t r (ReaderT r' m)
105newtype RoutedT t r m a = RoutedT { unRoutedT :: ReaderT (Dynamic t r) m a }
114newtype RoutedT t r m a = RoutedT { unRoutedT :: ReaderT (Dynamic t r) m a }
106 deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
115 deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
117+instance MonadReader r' m => MonadReader r' (RoutedT t r m) where
119+ local = mapRoutedT . local
108instance HasJSContext m => HasJSContext (RoutedT t r m) where
121instance HasJSContext m => HasJSContext (RoutedT t r m) where
109 type JSContextPhantom (RoutedT t r m) = JSContextPhantom m
122 type JSContextPhantom (RoutedT t r m) = JSContextPhantom m
110 askJSContext = lift askJSContext
123 askJSContext = lift askJSContext
@@ -165,17 +178,20 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RoutedT t r m) where
165 askQueryResult = lift askQueryResult
178 askQueryResult = lift askQueryResult
166 queryIncremental = lift . queryIncremental
179 queryIncremental = lift . queryIncremental
168−instance (Monad m, RouteToUrl r m) => RouteToUrl r (QueryT t q m) where
181+instance HasFrontendConfigs m => HasFrontendConfigs (RoutedT t r m)
169− askRouteToUrl = lift askRouteToUrl
183+instance (Monad m, RouteToUrl r m) => RouteToUrl r (QueryT t q m)
171−instance (Monad m, SetRoute t r m) => SetRoute t r (QueryT t q m) where
185+instance (Monad m, SetRoute t r m) => SetRoute t r (QueryT t q m)
172− setRoute = lift . setRoute
186+
173− modifyRoute = lift . modifyRoute
187+instance (Monad m, RouteToUrl r m) => RouteToUrl r (EventWriterT t w m)
189+instance (Monad m, SetRoute t r m) => SetRoute t r (EventWriterT t w m)
175runRoutedT :: RoutedT t r m a -> Dynamic t r -> m a
191runRoutedT :: RoutedT t r m a -> Dynamic t r -> m a
176runRoutedT = runReaderT . unRoutedT
192runRoutedT = runReaderT . unRoutedT
178−mapRoutedT :: (m a -> n a) -> RoutedT t r m a -> RoutedT t r n a
194+mapRoutedT :: (m a -> n b) -> RoutedT t r m a -> RoutedT t r n b
179mapRoutedT f = RoutedT . mapReaderT f . unRoutedT
195mapRoutedT f = RoutedT . mapReaderT f . unRoutedT
181withRoutedT :: (Dynamic t r -> Dynamic t r') -> RoutedT t r' m a -> RoutedT t r m a
197withRoutedT :: (Dynamic t r -> Dynamic t r') -> RoutedT t r' m a -> RoutedT t r m a
@@ -205,6 +221,20 @@ maybeRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do
205 runRoutedT (f c) r'
221 runRoutedT (f c) r'
225+ :: (MonadFix m, MonadHold t m, Adjustable t m)
228+ -> RoutedT t (Either l r) m ()
229+eitherRoute_ l r = eitherRouted $ strictDynWidget_ $ either (runRoutedT l) (runRoutedT r)
232+ :: (MonadFix m, MonadHold t m, Adjustable t m)
235+ -> RoutedT t (Either l r) m (Dynamic t a)
236+eitherRoute l r = eitherRouted $ strictDynWidget $ either (runRoutedT l) (runRoutedT r)
208dsumValueCoercion :: Coercion f g -> Coercion (DSum k f) (DSum k g)
238dsumValueCoercion :: Coercion f g -> Coercion (DSum k f) (DSum k g)
209dsumValueCoercion Coercion = Coercion
239dsumValueCoercion Coercion = Coercion
@@ -221,6 +251,9 @@ maybeRouted r = RoutedT $ ReaderT $ \d -> do
221 d' <- maybeDyn d
251 d' <- maybeDyn d
222 runRoutedT r d'
252 runRoutedT r d'
254+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
255+eitherRouted r = RoutedT $ ReaderT $ runRoutedT r <=< eitherDyn
224-- | WARNING: The input 'Dynamic' must be fully constructed when this is run
257-- | WARNING: The input 'Dynamic' must be fully constructed when this is run
225strictDynWidget :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m b) -> RoutedT t a m (Dynamic t b)
258strictDynWidget :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m b) -> RoutedT t a m (Dynamic t b)
226strictDynWidget f = RoutedT $ ReaderT $ \r -> do
259strictDynWidget f = RoutedT $ ReaderT $ \r -> do
@@ -257,13 +290,17 @@ runSetRouteT = runEventWriterT . unSetRouteT
257class Reflex t => SetRoute t r m | m -> t r where
290class Reflex t => SetRoute t r m | m -> t r where
258 setRoute :: Event t r -> m ()
291 setRoute :: Event t r -> m ()
259 modifyRoute :: Event t (r -> r) -> m ()
292 modifyRoute :: Event t (r -> r) -> m ()
293+ default modifyRoute :: (Monad m', MonadTrans f, SetRoute t r m', m ~ f m') => Event t (r -> r) -> m ()
294+ modifyRoute = lift . modifyRoute
260 setRoute = modifyRoute . fmap const
296 setRoute = modifyRoute . fmap const
262instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
298instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
263 modifyRoute = SetRouteT . tellEvent . fmap Endo
299 modifyRoute = SetRouteT . tellEvent . fmap Endo
265−instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m) where
301+instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m)
266− modifyRoute = lift . modifyRoute
302+
303+instance (Monad m, SetRoute t r m) => SetRoute t r (ReaderT r' m)
268instance (PerformEvent t m, Prerender js t m, Monad m, Reflex t) => Prerender js t (SetRouteT t r m) where
305instance (PerformEvent t m, Prerender js t m, Monad m, Reflex t) => Prerender js t (SetRouteT t r m) where
269 type Client (SetRouteT t r m) = SetRouteT t r (Client m)
306 type Client (SetRouteT t r m) = SetRouteT t r (Client m)
@@ -280,9 +317,7 @@ instance Requester t m => Requester t (SetRouteT t r m) where
280 requesting = SetRouteT . requesting
317 requesting = SetRouteT . requesting
281 requesting_ = SetRouteT . requesting_
318 requesting_ = SetRouteT . requesting_
283−instance (Monad m, SetRoute t r m) => SetRoute t r (RequesterT t req rsp m) where
320+instance (Monad m, SetRoute t r m) => SetRoute t r (RequesterT t req rsp m)
284− setRoute = lift . setRoute
285− modifyRoute = lift . modifyRoute
287#ifndef ghcjs_HOST_OS
322#ifndef ghcjs_HOST_OS
288deriving instance MonadJSM m => MonadJSM (SetRouteT t r m)
323deriving instance MonadJSM m => MonadJSM (SetRouteT t r m)
@@ -307,6 +342,8 @@ instance PrimMonad m => PrimMonad (SetRouteT t r m ) where
307 type PrimState (SetRouteT t r m) = PrimState m
342 type PrimState (SetRouteT t r m) = PrimState m
308 primitive = lift . primitive
343 primitive = lift . primitive
345+instance HasFrontendConfigs m => HasFrontendConfigs (SetRouteT t r m)
310instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
347instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
311 runWithReplace a0 a' = SetRouteT $ runWithReplace (coerce a0) $ coerceEvent a'
348 runWithReplace a0 a' = SetRouteT $ runWithReplace (coerce a0) $ coerceEvent a'
312 traverseIntMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
349 traverseIntMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
@@ -320,6 +357,8 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
321class RouteToUrl r m | m -> r where
358class RouteToUrl r m | m -> r where
322 askRouteToUrl :: m (r -> Text)
359 askRouteToUrl :: m (r -> Text)
360+ default askRouteToUrl :: (Monad m', MonadTrans f, RouteToUrl r m', m ~ f m') => m (r -> Text)
361+ askRouteToUrl = lift askRouteToUrl
324newtype RouteToUrlT r m a = RouteToUrlT { unRouteToUrlT :: ReaderT (r -> Text) m a }
363newtype RouteToUrlT r m a = RouteToUrlT { unRouteToUrlT :: ReaderT (r -> Text) m a }
325 deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
364 deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadIO, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
@@ -337,13 +376,12 @@ instance Monad m => RouteToUrl r (RouteToUrlT r m) where
337 askRouteToUrl = RouteToUrlT ask
376 askRouteToUrl = RouteToUrlT ask
339instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where
378instance (Monad m, RouteToUrl r m) => RouteToUrl r (SetRouteT t r' m) where
340− askRouteToUrl = lift askRouteToUrl
342instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where
380instance (Monad m, RouteToUrl r m) => RouteToUrl r (RoutedT t r' m) where
343− askRouteToUrl = lift askRouteToUrl
345−instance (Monad m, RouteToUrl r m) => RouteToUrl r (RequesterT t req rsp m) where
382+instance (Monad m, RouteToUrl r m) => RouteToUrl r (ReaderT r' m) where
346− askRouteToUrl = lift askRouteToUrl
383+
384+instance (Monad m, RouteToUrl r m) => RouteToUrl r (RequesterT t req rsp m)
348instance HasJSContext m => HasJSContext (RouteToUrlT r m) where
386instance HasJSContext m => HasJSContext (RouteToUrlT r m) where
349 type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m
387 type JSContextPhantom (RouteToUrlT r m) = JSContextPhantom m
@@ -403,6 +441,8 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where
403 askQueryResult = lift askQueryResult
441 askQueryResult = lift askQueryResult
404 queryIncremental = lift . queryIncremental
442 queryIncremental = lift . queryIncremental
444+instance HasFrontendConfigs m => HasFrontendConfigs (RouteToUrlT t m)
406runRouteViewT
446runRouteViewT
407 :: forall t m r a.
447 :: forall t m r a.
408 ( TriggerEvent t m
448 ( TriggerEvent t m