@@ -0,0 +1,235 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE RecursiveDo #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+
13+module Reflex.Dom.NestedRoute where
14+
15+import Control.Lens (Rewrapped, Wrapped(..), iso, to, (^.))
16+import Control.Monad.Exception (MonadAsyncException, MonadException)
17+import Control.Monad.Fix
18+import Control.Monad.Primitive (PrimMonad, PrimState, primitive)
19+import Control.Monad.Reader
20+import Control.Monad.Ref
21+import Control.Monad.State
22+import qualified Control.Monad.State.Strict as StrictState
23+import Data.ByteString (ByteString)
24+import qualified Data.ByteString.Char8 as B8
25+import Data.Coerce (coerce)
26+import Data.Functor ((<$))
27+import qualified Data.List as List
28+import Data.Maybe (listToMaybe)
29+import Data.Text (Text)
30+import qualified Data.Text as T
31+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
32+import Foreign.JavaScript.TH
33+import Language.Javascript.JSaddle (MonadJSM)
34+import Reflex
35+import Reflex.Dom.Builder.Class
36+import Reflex.Dom.Builder.Immediate
37+import Reflex.Dom.Contrib.Router (route')
38+import Reflex.Dom.Core
39+import Reflex.Host.Class
40+import URI.ByteString (URIRef, fragmentL, pathL)
41+
42+
43+data RouteContext segment t = RouteContext
44+ { _routeContext_allSegments :: Dynamic t [segment]
45+ , _routeContext_nextSegments :: Dynamic t [segment]
46+ , _routeContext_currentSegment :: Dynamic t (Maybe segment)
47+ }
48+
49+
50+class (Reflex t, Monad m) => HasRoute segment t m | m -> segment, m -> t where
51+ routeContext :: m (RouteContext segment t)
52+ withSegments :: (RouteContext segment t -> RouteContext segment t) -> m a -> m a
53+
54+
55+newtype RouteT segment t m a = RouteT { unRouteT :: ReaderT (RouteContext segment t) m a }
56+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t,
57+ MonadSample t, MonadAsyncException, MonadException, MonadTrans, PostBuild t,
58+ MonadReflexCreateTrigger t, TriggerEvent t, MonadAtomicRef)
59+
60+instance (MonadWidget t m) => HasRoute segment t (RouteT segment t m) where
61+ routeContext = RouteT ask
62+ withSegments f (RouteT m) = RouteT $ local f m
63+
64+instance Requester t m => Requester t (RouteT segment t m) where
65+ type Request (RouteT segment t m) = Request m
66+ type Response (RouteT segment t m) = Response m
67+ requesting = lift . requesting
68+ requesting_ = lift . requesting_
69+
70+instance HasRoute segment t m => HasRoute segment t (RequesterT t request response m) where
71+ routeContext = lift routeContext
72+ withSegments f (RequesterT a) = RequesterT $ StrictState.mapStateT (mapReaderT $ withSegments f) a
73+
74+instance Wrapped (RouteT segment t m a) where
75+ type Unwrapped (RouteT segment t m a) = ReaderT (RouteContext segment t) m a
76+ _Wrapped' = iso coerce coerce
77+
78+instance RouteT segment t m a ~ x => Rewrapped (RouteT segment t m a) x
79+
80+instance PerformEvent t m => PerformEvent t (RouteT segment t m) where
81+ type Performable (RouteT segment t m) = Performable m
82+ {-# INLINABLE performEvent_ #-}
83+ performEvent_ = lift . performEvent_
84+ {-# INLINABLE performEvent #-}
85+ performEvent = lift . performEvent
86+
87+instance MonadRef m => MonadRef (RouteT segment t m) where
88+ type Ref (RouteT segment t m) = Ref m
89+ {-# INLINABLE newRef #-}
90+ newRef = lift . newRef
91+ {-# INLINABLE readRef #-}
92+ readRef = lift . readRef
93+ {-# INLINABLE writeRef #-}
94+ writeRef r = lift . writeRef r
95+
96+instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteT segment t m) where
97+ runWithReplace a0 a' = RouteT $ runWithReplace (unRouteT a0) (fmapCheap unRouteT a')
98+ traverseDMapWithKeyWithAdjust f dm edm = RouteT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
99+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
100+ traverseDMapWithKeyWithAdjustWithMove f dm edm = RouteT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRouteT $ f k v) (coerce dm) (coerceEvent edm)
101+
102+instance (DomBuilder t m, MonadHold t m, MonadFix m) => DomBuilder t (RouteT segment t m) where
103+ type DomBuilderSpace (RouteT segment t m) = DomBuilderSpace m
104+ textNode = lift . textNode
105+ element elementTag cfg (RouteT child) = RouteT $ element elementTag cfg child
106+ inputElement = lift . inputElement
107+ textAreaElement = lift . textAreaElement
108+ selectElement cfg (RouteT child) = RouteT $ selectElement cfg child
109+ placeRawElement = lift . placeRawElement
110+ wrapRawElement e = lift . wrapRawElement e
111+
112+instance MonadReader r m => MonadReader r (RouteT segment t m) where
113+ ask = lift ask
114+ local f (RouteT a) = RouteT $ mapReaderT (local f) a
115+
116+instance MonadState s m => MonadState s (RouteT segment t m) where
117+ get = lift get
118+ put s = lift $ put s
119+
120+instance EventWriter t w m => EventWriter t w (RouteT segment t m) where
121+ tellEvent = lift . tellEvent
122+
123+
124+instance HasDocument m => HasDocument (RouteT segment t m)
125+instance HasJSContext m => HasJSContext (RouteT segment t m) where
126+ type JSContextPhantom (RouteT segment t m) = JSContextPhantom m
127+ askJSContext = RouteT askJSContext
128+#ifndef ghcjs_HOST_OS
129+instance MonadJSM m => MonadJSM (RouteT segment t m)
130+#endif
131+
132+
133+instance PrimMonad m => PrimMonad (RouteT segment t m) where
134+ type PrimState (RouteT segment t m) = PrimState m
135+ primitive = lift . primitive
136+
137+--instance HasMountStatus t m => HasMountStatus t (RouteT segment r m) where
138+-- getMountStatus = lift getMountStatus
139+
140+
141+runRoute :: forall segment t m. (MonadWidget t m, Eq segment)
142+ => (forall a. URIRef a -> [segment])
143+ -> (forall a. URIRef a -> [segment] -> URIRef a)
144+ -> RouteT segment t m (Event t [segment])
145+ -> m ()
146+runRoute toSegments fromSegments (RouteT f) = do
147+ let
148+ routeHandler = route' (\_ uri -> uri) id
149+ rec
150+ dynamicRoute <- routeHandler routeChanged
151+ routeChanged <- pathToHandler dynamicRoute
152+ pure ()
153+
154+ where
155+ pathToHandler :: Dynamic t (URIRef a) -> m (Event t (URIRef a))
156+ pathToHandler uri = do
157+ let
158+ allSegments = toSegments <$> uri
159+ ctx = RouteContext{ _routeContext_allSegments = allSegments
160+ , _routeContext_nextSegments = allSegments
161+ , _routeContext_currentSegment = pure Nothing
162+ }
163+ newSegments <- runReaderT f ctx
164+ let x = ffor uri $ \uri' -> fromSegments uri' <$> newSegments
165+ pure (switch (current x))
166+
167+
168+runRouteWithPathInFragment
169+ :: forall t m. (MonadWidget t m)
170+ => RouteT Text t m (Event t [Text])
171+ -> m ()
172+runRouteWithPathInFragment = runRoute
173+ (T.splitOn "/" . T.dropAround (=='/') . fragAsText)
174+ (\oldUrl -> setFrag oldUrl . T.intercalate "/")
175+
176+
177+withRoute
178+ :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute segment t m, Eq segment)
179+ => (Maybe segment -> m a)
180+ -- ^ A routing function that produces a widget from a segment.
181+ -> m (Event t a)
182+withRoute f = do
183+ ctx <- routeContext
184+ let segmentsFlat = List.uncons <$> _routeContext_nextSegments ctx
185+ segmentsNested <- maybeDyn segmentsFlat
186+
187+ let
188+ component = ffor segmentsNested $ \x -> case x of
189+ Nothing -> do
190+ let
191+ segment = Nothing
192+ newCtx = ctx{ _routeContext_currentSegment = pure segment
193+ , _routeContext_nextSegments = pure []
194+ }
195+
196+ a <- withSegments (const newCtx) (f segment)
197+ postBuildEv <- getPostBuild
198+ pure (a <$ postBuildEv) -- Wrap the value up in an Event to unify both paths.
199+
200+ Just segmentUncons -> do
201+ segmentDyn <- fmap Just <$> holdUniqDyn (fst <$> segmentUncons)
202+ let newCtx = ctx{ _routeContext_currentSegment = segmentDyn
203+ , _routeContext_nextSegments = snd <$> segmentUncons
204+ }
205+
206+ dyn $ ffor segmentDyn $ \segment ->
207+ withSegments (const newCtx) (f segment)
208+
209+ switchPromptly never =<< dyn component
210+
211+
212+allRouteSegments :: (Reflex t, MonadHold t m, MonadFix m, HasRoute segment t m, Eq segment) => m (Dynamic t [segment])
213+allRouteSegments = _routeContext_allSegments <$> routeContext
214+
215+currentRouteSegment :: (Functor m, HasRoute segment t m) => m (Dynamic t (Maybe segment))
216+currentRouteSegment = _routeContext_currentSegment <$> routeContext
217+
218+nextRouteSegment :: (Reflex t, MonadHold t m, MonadFix m, HasRoute segment t m, Eq segment) => m (Dynamic t (Maybe segment))
219+nextRouteSegment = do
220+ ctx <- routeContext
221+ holdUniqDyn (listToMaybe <$> _routeContext_nextSegments ctx)
222+
223+redirectLocally :: (MonadWidget t m, HasRoute segment t m) => [segment] -> m (Event t [segment])
224+redirectLocally segments = (segments <$) <$> getPostBuild
225+
226+
227+setFrag :: URIRef a -> Text -> URIRef a
228+setFrag uri p = uri & fragmentL .~ (Just $ encodeUtf8 p)
229+
230+fragAsText :: URIRef a -> Text
231+fragAsText uri = maybe "" decodeUtf8 (uri ^. fragmentL)
232+
233+pathSegments :: URIRef a -> [ByteString]
234+pathSegments uri = uri ^. pathL . to (B8.split '/')
235+