e44908c · obelisk · git.iko.soy

git.iko.soy/obelisk

Add some new functionality to obelisk-route to support simple parameters in the URL path

commite44908c3e51d219dcdee551aa3608074a72ff292 authorRyan Trinkle <ryan@trinkle.org> dateSun 27 Oct 2019, 10:15 (7 years ago) parente54d3a7

2 files changed+58

compare with master

unifiedsplit

lib/route/src/Obelisk/Route.hs+47 lib/route/src/Obelisk/Route/Frontend.hs+11

lib/route/src/Obelisk/Route.hs+47

@@ -21,6 +21,8 @@

2121module Obelisk.Route

2222 ( R

2323 , pattern (:/)

24+ , (:.)

25+ , pattern (:.)

2426 , hoistR

2527 , PageName

2628 , PathQuery

@@ -43,6 +45,9 @@ module Obelisk.Route

4345 , checkEnum1EncoderFunc

4446 , unitEncoder

4547 , pathOnlyEncoder

48+ , addPathSegmentEncoder

49+ , pathParamEncoder

50+ , pathLiteralEncoder

4651 , singletonListEncoder

4752 , unpackTextEncoder

4853 , prefixTextEncoder

@@ -200,6 +205,48 @@ mapSome f (Some a) = Some $ f a

200205hoistR :: (forall x. f x -> g x) -> R f -> R g

201206hoistR f (x :=> Identity y) = f x :/ y

202207

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+

203250--------------------------------------------------------------------------------

204251-- Encoder fundamentals

205252--------------------------------------------------------------------------------

lib/route/src/Obelisk/Route/Frontend.hs+11

@@ -35,6 +35,8 @@ module Obelisk.Route.Frontend

3535 , mapRoutedT

3636 , subRoute

3737 , subRoute_

38+ , subPairRoute

39+ , subPairRoute_

3840 , maybeRoute

3941 , maybeRoute_

4042 , maybeRouted

@@ -77,6 +79,7 @@ import Data.Proxy

7779import Data.Text (Text)

7880import qualified Data.Text as T

7981import Data.Functor.Compose

82+import Data.Functor.Misc

8083import Reflex.Class

8184import Reflex.Host.Class

8285import Reflex.PostBuild.Class

@@ -202,10 +205,18 @@ subRoute_ :: (MonadFix m, MonadHold t m, GEq r, Adjustable t m) => (forall a. r

202205subRoute_ f = factorRouted $ strictDynWidget_ $ \(c :=> r') -> do

203206 runRoutedT (f c) r'

204207

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+

205212subRoute :: (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)

206213subRoute f = factorRouted $ strictDynWidget $ \(c :=> r') -> do

207214 runRoutedT (f c) r'

208215

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+

209220maybeRoute_ :: (MonadFix m, MonadHold t m, Adjustable t m) => m () -> RoutedT t r m () -> RoutedT t (Maybe r) m ()

210221maybeRoute_ n j = maybeRouted $ strictDynWidget_ $ \case

211222 Nothing -> n