git.iko.soy/obelisk
on master help sign in
Add a few combinators to routes
d52e32bDan Bornside
lib/route/src/Obelisk/Route.hs+86−9
compare with master
unifiedsplit
@@ -90,6 +90,7 @@ module Obelisk.Route
90 , Decoder(..)
90 , Decoder(..)
91 , dmapEncoder
91 , dmapEncoder
92 , fieldMapEncoder
92 , fieldMapEncoder
93+ , pathFieldEncoder
93 , jsonEncoder
94 , jsonEncoder
94 ) where
95 ) where
95
96
@@ -101,8 +102,31 @@ import qualified Control.Categorical.Functor as Cat
101import Control.Categorical.Bifunctor
102import Control.Categorical.Bifunctor
102import Control.Category.Associative
103import Control.Category.Associative
103import Control.Category.Monoidal
104import Control.Category.Monoidal
104−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
105+import Control.Category.Braided
106+import Control.Lens
107+ ( Identity (..)
108+ , (^.)
109+ , (^?)
110+ , Iso'
111+ , Prism'
112+ , Wrapped (..)
113+ , _Just
114+ , _Nothing
115+ , from
116+ , imap
117+ , iso
118+ , itraverse
119+ , makePrisms
120+ , matching
121+ , prism
122+ , re
123+ , view
124+ , Cons(..)
125+ )
105import Control.Monad.Except
126import Control.Monad.Except
127+import Control.Monad.Writer (execWriter, tell)
128+import qualified Control.Monad.State.Strict as State
129+import Control.Monad.Trans (lift)
106import qualified Data.ByteString.Lazy as BSL
130import qualified Data.ByteString.Lazy as BSL
107import Data.Dependent.Sum (DSum (..))
131import Data.Dependent.Sum (DSum (..))
108import Data.Dependent.Map (DMap)
132import Data.Dependent.Map (DMap)
@@ -252,6 +276,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E
252 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
276 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
253 }
277 }
254
278
279+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
280+ braid = isoEncoder (iso swap swap)
281+
282+
255instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
283instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
256 first f = bimap f id
284 first f = bimap f id
257instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
285instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
@@ -265,6 +293,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco
265 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
293 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve
266 }
294 }
267
295
296+instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
297+ first f = bimap f id
298+instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
299+ second g = bimap id g
300+instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
301+ bimap f g = EncoderImpl
302+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
303+ , _encoderImpl_decode = \case
304+ Left a -> Left <$> _encoderImpl_decode f a
305+ Right b -> Right <$> _encoderImpl_decode g b
306+ }
307+
308+instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where
309+ second g = bimap id g
310+instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where
311+ first f = bimap f id
312+instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where
313+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)
314+
315+instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
316+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)
317+ disassociate = isoEncoder (iso disassociate associate)
318+
319+instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
320+ braid = isoEncoder (iso swap swap)
321+
322+
323+
268instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
324instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
269 fmap e = Encoder $ do
325 fmap e = Encoder $ do
270 ve <- unEncoder e
326 ve <- unEncoder e
@@ -877,14 +933,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
877integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
933integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
878integralEncoder = prismEncoder (Numeric.Lens.integral)
934integralEncoder = prismEncoder (Numeric.Lens.integral)
879
935
880−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>
936+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>
881− Encoder check parse (Text, PageName) PageName
937+ Encoder check parse (a, (as, b)) (as, b)
882−pathSegmentEncoder = unsafeMkEncoder EncoderImpl
938+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate
883− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)
884− , _encoderImpl_decode = \(xss, y) -> case xss of
885− [] -> throwError "not enough path segments"
886− (x:xs) -> pure (x, (xs, y))
887− }
888
939
889newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
940newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
890
941
@@ -938,6 +989,32 @@ fieldMapEncoder = unsafeEncoder $ do
938 Just (Identity v) -> return v
989 Just (Identity v) -> return v
939 }
990 }
940
991
992+-- this is in base 4.12 (GHC 8.6);
993+newtype Ap f a = Ap {getAp :: f a}
994+
995+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where
996+ Ap x <> Ap y = Ap (liftA2 (<>) x y)
997+
998+instance (Applicative f, Monoid a) => Monoid (Ap f a) where
999+ mappend = (<>)
1000+ mempty = Ap (pure mempty)
1001+
1002+pathFieldEncoder :: forall a p check parse . (HasFields a, Monad check, MonadError Text parse, GCompare (Field a)) => (forall x. Field a x -> Encoder check parse x p) -> Encoder check parse (a, [p]) [p]
1003+pathFieldEncoder fieldEncoder = unsafeEncoder $ do
1004+ fieldEncoderPureMap :: DMap.DMap (Field a) (Decoder Identity parse p) <- getAp $ getConst $ tabulateFieldsA @a $ \f -> Const (Ap $ fmap (DMap.singleton f . Decoder) $ (checkEncoder @Identity) $ fieldEncoder f)
1005+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p
1006+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)
1007+ pure $ EncoderImpl
1008+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do
1009+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x
1010+ tell rest
1011+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case
1012+ [] -> throwError $ T.pack "not enough path components"
1013+ p:ps -> do
1014+ State.put ps
1015+ lift $ tryDecode (fieldEncoderPure f) p
1016+ }
1017+
941-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
1018-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
942jsonEncoder :: forall check parse r.
1019jsonEncoder :: forall check parse r.
943 ( ToJSON r
1020 ( ToJSON r