git.iko.soy/obelisk
on master help sign in
Merge pull request #543 from obsidiansystems/path-params
61b54c2Ali Abrar
lib/route/src/Obelisk/Route.hs+47
compare with master
unifiedsplit
@@ -21,6 +21,8 @@
21module Obelisk.Route
21module Obelisk.Route
22 ( R
22 ( R
23 , pattern (:/)
23 , pattern (:/)
24+ , (:.)
25+ , pattern (:.)
24 , hoistR
26 , hoistR
25 , PageName
27 , PageName
26 , PathQuery
28 , PathQuery
@@ -43,6 +45,9 @@ module Obelisk.Route
43 , checkEnum1EncoderFunc
45 , checkEnum1EncoderFunc
44 , unitEncoder
46 , unitEncoder
45 , pathOnlyEncoder
47 , pathOnlyEncoder
48+ , addPathSegmentEncoder
49+ , pathParamEncoder
50+ , pathLiteralEncoder
46 , singletonListEncoder
51 , singletonListEncoder
47 , unpackTextEncoder
52 , unpackTextEncoder
48 , prefixTextEncoder
53 , prefixTextEncoder
@@ -200,6 +205,48 @@ mapSome f (Some a) = Some $ f a
200hoistR :: (forall x. f x -> g x) -> R f -> R g
205hoistR :: (forall x. f x -> g x) -> R f -> R g
201hoistR f (x :=> Identity y) = f x :/ y
206hoistR f (x :=> Identity y) = f x :/ y
202
207
208+--------------------------------------------------------------------------------
209+-- Dealing with pairs (i.e. non-dependently-typed subroutes/paths)
210+--------------------------------------------------------------------------------
211+
212+infixr 5 :.
213+type (:.) = (,)
214+
215+{-# COMPLETE (:.) #-}
216+pattern (:.) :: a -> b -> a :. b
217+pattern a :. b = (a, b)
218+
219+addPathSegmentEncoder
220+ :: ( Applicative check
221+ , MonadError Text parse
222+ )
223+ => Encoder check parse (Text, PageName) PageName
224+addPathSegmentEncoder = unsafeMkEncoder $ EncoderImpl
225+ { _encoderImpl_encode = \(ph, (pt, q)) -> (ph : pt, q)
226+ , _encoderImpl_decode = \(p, q) -> case p of
227+ [] -> throwError "Expected a path segment"
228+ ph : pt -> pure (ph, (pt, q))
229+ }
230+
231+pathParamEncoder
232+ :: forall check parse item rest.
233+ ( Applicative check
234+ , MonadError Text parse
235+ )
236+ => Encoder check parse item Text
237+ -> Encoder check parse rest PageName
238+ -> Encoder check parse (item :. rest) PageName
239+pathParamEncoder itemUnchecked restUnchecked = addPathSegmentEncoder . bimap itemUnchecked restUnchecked
240+
241+pathLiteralEncoder
242+ :: ( Applicative check
243+ , MonadError Text parse
244+ )
245+ => Text
246+ -> Encoder check parse a PageName
247+ -> Encoder check parse a PageName
248+pathLiteralEncoder t e = addPathSegmentEncoder . bimap (unitEncoder t) e . coidl
249+
203--------------------------------------------------------------------------------
250--------------------------------------------------------------------------------
204-- Encoder fundamentals
251-- Encoder fundamentals
205--------------------------------------------------------------------------------
252--------------------------------------------------------------------------------
lib/route/src/Obelisk/Route/Frontend.hs+11
@@ -35,6 +35,8 @@ module Obelisk.Route.Frontend
35 , mapRoutedT
35 , mapRoutedT
36 , subRoute
36 , subRoute
37 , subRoute_
37 , subRoute_
38+ , subPairRoute
39+ , subPairRoute_
38 , maybeRoute
40 , maybeRoute
39 , maybeRoute_
41 , maybeRoute_
40 , maybeRouted
42 , maybeRouted
@@ -77,6 +79,7 @@ import Data.Proxy
77import Data.Text (Text)
79import Data.Text (Text)
78import qualified Data.Text as T
80import qualified Data.Text as T
79import Data.Functor.Compose
81import Data.Functor.Compose
82+import Data.Functor.Misc
80import Reflex.Class
83import Reflex.Class
81import Reflex.Host.Class
84import Reflex.Host.Class
82import Reflex.PostBuild.Class
85import Reflex.PostBuild.Class
@@ -202,10 +205,18 @@ subRoute_ :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r
202subRoute_ f = factorRouted $ strictDynWidget_ $ \(c :=> r') -> do
205subRoute_ f = factorRouted $ strictDynWidget_ $ \(c :=> r') -> do
203 runRoutedT (f c) r'
206 runRoutedT (f c) r'
204
207
208+-- | Like 'subRoute_', but with a pair rather than an R
209+subPairRoute_ :: (MonadFix m, MonadHold t m, Eq a, Adjustable t m) => (a -> RoutedT t b m ()) -> RoutedT t (a, b) m ()
210+subPairRoute_ f = withRoutedT (fmap (\(a, b) -> Const2 a :/ b)) $ subRoute_ (\(Const2 a) -> f a)
211+
205subRoute :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r a -> RoutedT t a m b) -> RoutedT t (R r) m (Dynamic t b)
212subRoute :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r a -> RoutedT t a m b) -> RoutedT t (R r) m (Dynamic t b)
206subRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do
213subRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do
207 runRoutedT (f c) r'
214 runRoutedT (f c) r'
208
215
216+-- | Like 'subRoute_', but with a pair rather than an R
217+subPairRoute :: (MonadFix m, MonadHold t m, Eq a, Adjustable t m) => (a -> RoutedT t b m c) -> RoutedT t (a, b) m (Dynamic t c)
218+subPairRoute f = withRoutedT (fmap (\(a, b) -> Const2 a :/ b)) $ subRoute (\(Const2 a) -> f a)
219+
209maybeRoute_ :: (MonadFix m, MonadHold t m, Adjustable t m) => m () -> RoutedT t r m () -> RoutedT t (Maybe r) m ()
220maybeRoute_ :: (MonadFix m, MonadHold t m, Adjustable t m) => m () -> RoutedT t r m () -> RoutedT t (Maybe r) m ()
210maybeRoute_ n j = maybeRouted $ strictDynWidget_ $ \case
221maybeRoute_ n j = maybeRouted $ strictDynWidget_ $ \case
211 Nothing -> n
222 Nothing -> n