ec2eadb · typeable/reflex-dom-nested-routing

git.iko.soy/typeable/reflex-dom-nested-routing

Fix missing extensions & Adjustable changes

commitec2eadb447c6646b9acdbee621eb4c86685c77ee author3noch <eacameron@gmail.com> dateWed 8 Nov 2017, 00:21 (9 years ago) parentdf4240d

2 files changed+31−10

compare with master

unifiedsplit

Reflex/Dom/NestedRoute.hs+15−4 Reflex/Dom/RouteWriter.hs+16−6

Reflex/Dom/NestedRoute.hs+15−4

@@ -7,6 +7,7 @@

77{-# LANGUAGE RankNTypes #-}

88{-# LANGUAGE RecursiveDo #-}

99{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE StandaloneDeriving #-}

1011{-# LANGUAGE TypeFamilies #-}

1112{-# LANGUAGE UndecidableInstances #-}

1213

@@ -142,7 +143,9 @@ instance PrimMonad m => PrimMonad (RouteT t segment m) where

142143--instance HasMountStatus t m => HasMountStatus t (RouteT segment r m) where

143144-- getMountStatus = lift getMountStatus

144145

145−

146+-- | Runs a monadic action (in 'RouteT') over the current URL as "interpreted"

147+-- by the given URL-parser. The action must return an 'Event' which can trigger

148+-- the route to change.

146149runRoute :: forall segment t m. (MonadWidget t m, Eq segment)

147150 => (forall a. URIRef a -> [segment])

148151 -> (forall a. URIRef a -> [segment] -> URIRef a)

@@ -170,7 +173,8 @@ runRoute toSegments fromSegments (RouteT f) = do

170173 let x = ffor uri $ \uri' -> fromSegments uri' <$> newSegments

171174 pure (switch (current x))

172175

173−

176+-- | A very simple version of 'runRoute' that parses only the URL fragment

177+-- and splits it over @/@. Each path segment is therefore nothing more than 'Text'.

174178runRouteWithPathInFragment

175179 :: forall t m. (MonadWidget t m)

176180 => RouteT t Text m (Event t [Text])

@@ -179,7 +183,8 @@ runRouteWithPathInFragment = runRoute

179183 (T.splitOn "/" . T.dropAround (=='/') . fragAsText)

180184 (\oldUrl -> setFrag oldUrl . T.intercalate "/")

181185

182−

186+-- | Introduces a new "layer" in the nested routing tree. The given function takes

187+-- the current layer's route segment and builds the DOM for that segment.

183188withRoute

184189 :: forall a segment t m. (DomBuilder t m, MonadFix m, PostBuild t m, MonadHold t m, HasRoute t segment m, Eq segment)

185190 => (Maybe segment -> m a)

@@ -218,18 +223,23 @@ withRoute f = do

218223

219224 switchPromptly never =<< dyn component

220225

221−

226+-- | All routing segments in the current URL.

222227allRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])

223228allRouteSegments = _routeContext_allSegments <$> routeContext

224229

230+-- | The routing segment at "this layer" in the tree. "This layer" is defined by how many

231+-- nested 'withRoute's exist above the caller of this function.

225232currentRouteSegment :: (Functor m, HasRoute t segment m) => m (Dynamic t (Maybe segment))

226233currentRouteSegment = _routeContext_currentSegment <$> routeContext

227234

235+-- | The next layer's segment in the tree. Like 'withRoute' this can be used to switch

236+-- over route segments, but it does not place a new layer in the tree.

228237nextRouteSegment :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t (Maybe segment))

229238nextRouteSegment = do

230239 ctx <- routeContext

231240 holdUniqDyn (listToMaybe <$> _routeContext_nextSegments ctx)

232241

242+-- | Route segments from parent layers.

233243parentRouteSegments :: (MonadHold t m, MonadFix m, HasRoute t segment m, Eq segment) => m (Dynamic t [segment])

234244parentRouteSegments = do

235245 ctx <- routeContext

@@ -237,6 +247,7 @@ parentRouteSegments = do

237247 allSegments <- _routeContext_allSegments ctx

238248 pure $ take (_routeContext_currentDepth ctx - 1) allSegments

239249

250+-- | A simple helper that produces a routing event on 'getPostBuild'.

240251redirectLocally :: (PostBuild t m) => [segment] -> m (Event t [segment])

241252redirectLocally segments = (segments <$) <$> getPostBuild

242253

Reflex/Dom/RouteWriter.hs+16−6

@@ -5,13 +5,15 @@

55{-# LANGUAGE MultiParamTypeClasses #-}

66{-# LANGUAGE RankNTypes #-}

77{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE StandaloneDeriving #-}

89{-# LANGUAGE TypeFamilies #-}

910{-# LANGUAGE UndecidableInstances #-}

1011

1112module Reflex.Dom.RouteWriter where

1213

13−import Control.Lens (Rewrapped, Wrapped(..), iso)

14−import Control.Monad.Exception (MonadAsyncException, MonadException)

14+import Control.Lens (Rewrapped, Wrapped (..), iso)

15+import Control.Monad.Exception (MonadAsyncException,

16+ MonadException)

1517import Control.Monad.Fix

1618import Control.Monad.Primitive (PrimMonad, PrimState, primitive)

1719import Control.Monad.Reader

@@ -26,14 +28,12 @@ import Reflex.Dom.Builder.Immediate

2628import Reflex.Dom.Core

2729import Reflex.Host.Class

2830

29−import Reflex.Dom.NestedRoute

30−

31+import Reflex.Dom.NestedRoute

3132

3233

3334class (Reflex t, Monad m) => RouteWriter t segment m | m -> segment, m -> t where

3435 tellRoute :: Event t [segment] -> m ()

3536

36−

3737newtype RouteWriterT t segment m a = RouteWriterT { unRouteWriterT :: EventWriterT t [segment] m a }

3838 deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t,

3939 MonadSample t, MonadAsyncException, MonadException, MonadTrans, PostBuild t,

@@ -75,7 +75,7 @@ instance MonadRef m => MonadRef (RouteWriterT t segment m) where

7575 {-# INLINABLE writeRef #-}

7676 writeRef r = lift . writeRef r

7777

78−instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (RouteWriterT t segment m) where

78+instance (Adjustable t m, MonadHold t m) => Adjustable t (RouteWriterT t segment m) where

7979 runWithReplace a0 a' = RouteWriterT $ runWithReplace (unRouteWriterT a0) (fmapCheap unRouteWriterT a')

8080 traverseDMapWithKeyWithAdjust f dm edm = RouteWriterT $ traverseDMapWithKeyWithAdjust (\k v -> unRouteWriterT $ f k v) (coerce dm) (coerceEvent edm)

8181 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

@@ -125,6 +125,10 @@ runRouteWriterT (RouteWriterT m) = runEventWriterT m

125125tellRedirectLocally :: (PostBuild t m, RouteWriter t segment m) => [segment] -> m ()

126126tellRedirectLocally segments = tellRoute =<< redirectLocally segments

127127

128+-- | Alias for 'tellRedirectLocally'

129+localRedirect :: (PostBuild t m, RouteWriter t segment m) => [segment] -> m ()

130+localRedirect = tellRedirectLocally

131+

128132

129133-- | Sets a new route to the given route whenever the given 'Event' fires, ignoring the 'Event' payload.

130134tellRouteAs :: (RouteWriter t segment m) => [segment] -> Event t a -> m ()

@@ -149,3 +153,9 @@ tellRouteRelative

149153tellRouteRelative ev = do

150154 parents <- parentRouteSegments

151155 tellRoute $ attachWith (++) (current parents) ev

156+

157+-- Like 'tellRouteAs' and 'tellRouteRelative'.

158+tellRouteRelativeAs

159+ :: (RouteWriter t segment m, HasRoute t segment m, MonadHold t m, MonadFix m, Eq segment)

160+ => [segment] -> Event t a -> m ()

161+tellRouteRelativeAs segments ev = tellRouteRelative (segments <$ ev)