7765c15 · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge pull request #767 from obsidiansystems/eac@route-fixes

Route improvements

commit7765c15b9d766cb5db26761e70522ddc082f9c68 authorElliot Cameron <3noch@users.noreply.github.com> dateThu 18 Jun 2020, 15:58 (6 years ago) parent86545e2 d178241

2 files changed+39−47

compare with master

unifiedsplit

lib/route/src/Obelisk/Route.hs+20−20 lib/route/src/Obelisk/Route/Frontend.hs+19−27

lib/route/src/Obelisk/Route.hs+20−20

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

66{-# LANGUAGE FlexibleContexts #-}

77{-# LANGUAGE FlexibleInstances #-}

88{-# LANGUAGE GADTs #-}

9−{-# LANGUAGE KindSignatures #-}

109{-# LANGUAGE LambdaCase #-}

1110{-# LANGUAGE MultiParamTypeClasses #-}

1211{-# LANGUAGE OverloadedStrings #-}

@@ -141,16 +140,19 @@ import Control.Lens

141140 , Wrapped (..)

142141 )

143142import Control.Monad.Except

144−import Control.Monad.Writer (execWriter, tell)

145143import qualified Control.Monad.State.Strict as State

146144import Control.Monad.Trans (lift)

145+import Control.Monad.Writer (execWriter, tell)

146+import Data.Aeson (FromJSON, ToJSON)

147+import qualified Data.Aeson as Aeson

147148import qualified Data.ByteString as BS

148149import qualified Data.ByteString.Lazy as BSL

149−import Data.Dependent.Sum (DSum (..))

150150import Data.Dependent.Map (DMap)

151151import qualified Data.Dependent.Map as DMap

152+import Data.Dependent.Sum (DSum (..))

152153import Data.Either.Validation (Validation (..))

153154import Data.Foldable

155+import Data.Functor (($>))

154156import Data.Functor.Sum

155157import Data.GADT.Compare

156158import Data.GADT.Compare.TH

@@ -163,19 +165,17 @@ import Data.Monoid ((<>))

163165import Data.Set (Set)

164166import qualified Data.Set as Set

165167import Data.Some (Some(Some))

168+import Data.Tabulation

166169import Data.Text (Text)

167−import Data.Text.Lens (IsText, packed, unpacked)

168170import qualified Data.Text as T

169171import qualified Data.Text.Encoding as T

172+import Data.Text.Lens (IsText, packed, unpacked)

170173import Data.Universe

171174import Data.Universe.Some

172175import Network.HTTP.Types.URI

173176import qualified Numeric.Lens

174177import Obelisk.Route.TH

175178import Text.Read (readMaybe)

176−import Data.Tabulation

177−import qualified Data.Aeson as Aeson

178−import Data.Aeson (FromJSON, ToJSON)

179179

180180-- Design goals:

181181-- No start-up time on the frontend (not yet met)

@@ -303,13 +303,13 @@ decode e x = runIdentity (tryDecode e x)

303303-- | Once an 'Encoder' has been checked, so that its check monad has become 'Identity', even if the same is not true of the

304304-- parse monad, we may still attempt to decode with it in its parse monad.

305305tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded

306−tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x

306+tryDecode (Encoder (Identity impl)) = _encoderImpl_decode impl

307307

308308-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it

309309-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,

310310-- one should usually be applying decode and encode to the same 'Encoder'

311311encode :: Encoder Identity parse decoded encoded -> decoded -> encoded

312−encode (Encoder (Identity impl)) x = _encoderImpl_encode impl x

312+encode (Encoder (Identity impl)) = _encoderImpl_encode impl

313313

314314-- | This is a primitive used to build encoders which can't fail to check. It should not be used unless one is

315315-- reasonably certain that the law given for 'EncoderImpl' above holds.

@@ -554,11 +554,11 @@ pathComponentEncoder f = Encoder $ do

554554 unEncoder (pathComponentEncoderImpl (enum1Encoder (extractPathSegment . f)) f')

555555

556556pathComponentEncoderImpl :: forall check parse p. (Monad check, Monad parse)

557− => (Encoder check parse (Some p) (Maybe Text))

557+ => Encoder check parse (Some p) (Maybe Text)

558558 -> (forall a. p a -> Encoder Identity parse a PageName)

559559 -> Encoder check parse (R p) PageName

560−pathComponentEncoderImpl this rest =

561− chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder) this rest

560+pathComponentEncoderImpl =

561+ chainEncoder (lensEncoder (\(_, b) a -> (a, b)) Prelude.fst consEncoder)

562562

563563--NOTE: Naming convention in this module is to always talk about things in the *encoding* direction, never in the *decoding* direction

564564

@@ -814,7 +814,7 @@ rPrism

814814 :: forall f f'

815815 . (forall a. Prism' (f a) (f' a))

816816 -> Prism' (R f) (R f')

817−rPrism p = dSumPrism p

817+rPrism = dSumPrism

818818

819819dSumPrism'

820820 :: forall f g a

@@ -826,7 +826,7 @@ dSumGEqPrism

826826 :: GEq f

827827 => f a

828828 -> Prism' (DSum f g) (g a)

829−dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)

829+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (geq variant)

830830

831831-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual

832832-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'

@@ -993,9 +993,9 @@ obeliskRouteSegment r appRouteSegment = case r of

993993-- be combined with other such segment encoders before 'pathComponentEncoder' turns it into a proper 'Encoder'.

994994resourceRouteSegment :: (MonadError Text check, MonadError Text parse) => ResourceRoute a -> SegmentResult check parse a

995995resourceRouteSegment = \case

996− ResourceRoute_Static -> PathSegment "static" $ pathOnlyEncoderIgnoringQuery

997− ResourceRoute_Ghcjs -> PathSegment "ghcjs" $ pathOnlyEncoder

998− ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" $ jsaddleWarpRouteEncoder

996+ ResourceRoute_Static -> PathSegment "static" pathOnlyEncoderIgnoringQuery

997+ ResourceRoute_Ghcjs -> PathSegment "ghcjs" pathOnlyEncoder

998+ ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" jsaddleWarpRouteEncoder

999999 ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty

10001000

10011001data JSaddleWarpRoute :: * -> * where

@@ -1007,7 +1007,7 @@ jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Enc

10071007jsaddleWarpRouteEncoder = pathComponentEncoder $ \case

10081008 JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty

10091009 JSaddleWarpRoute_WebSocket -> PathEnd $ unitEncoder mempty

1010− JSaddleWarpRoute_Sync -> PathSegment "sync" $ pathOnlyEncoder

1010+ JSaddleWarpRoute_Sync -> PathSegment "sync" pathOnlyEncoder

10111011

10121012instance GShow appRoute => GShow (ObeliskRoute appRoute) where

10131013 gshowsPrec prec = \case

@@ -1083,7 +1083,7 @@ readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) =>

10831083readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder

10841084

10851085integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer

1086−integralEncoder = reviewEncoder (Numeric.Lens.integral)

1086+integralEncoder = reviewEncoder Numeric.Lens.integral

10871087

10881088pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>

10891089 Encoder check parse (a, (as, b)) (as, b)

@@ -1158,7 +1158,7 @@ pathFieldEncoder fieldEncoder = unsafeEncoder $ do

11581158 fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)

11591159 pure $ EncoderImpl

11601160 { _encoderImpl_encode = \(x, rest) -> execWriter $ do

1161− _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x

1161+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) $> x_i) x

11621162 tell rest

11631163 , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case

11641164 [] -> throwError $ T.pack "not enough path components"

lib/route/src/Obelisk/Route/Frontend.hs+19−27

@@ -1,24 +1,24 @@

1−{-# LANGUAGE ApplicativeDo #-}

21{-# LANGUAGE CPP #-}

3−{-# LANGUAGE RecursiveDo #-}

4−{-# LANGUAGE StandaloneDeriving #-}

2+{-# LANGUAGE ApplicativeDo #-}

53{-# LANGUAGE ConstraintKinds #-}

4+{-# LANGUAGE DataKinds #-}

65{-# LANGUAGE DefaultSignatures #-}

76{-# LANGUAGE FlexibleContexts #-}

87{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE FunctionalDependencies #-}

99{-# LANGUAGE GADTs #-}

10+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1011{-# LANGUAGE LambdaCase #-}

1112{-# LANGUAGE OverloadedStrings #-}

1213{-# LANGUAGE PatternSynonyms #-}

1314{-# LANGUAGE RankNTypes #-}

15+{-# LANGUAGE RecursiveDo #-}

1416{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE StandaloneDeriving #-}

1518{-# LANGUAGE TypeFamilies #-}

1619{-# LANGUAGE TypeOperators #-}

17−{-# LANGUAGE ViewPatterns #-}

18−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1920{-# LANGUAGE UndecidableInstances #-}

20−{-# LANGUAGE DataKinds #-}

21−{-# LANGUAGE FunctionalDependencies #-}

21+{-# LANGUAGE ViewPatterns #-}

2222

2323module Obelisk.Route.Frontend

2424 ( module Obelisk.Route

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

5757

5858import Prelude hiding ((.), id)

5959

60−import Obelisk.Route

61−

6260import Control.Category (Category (..), (.))

6361import Control.Category.Cartesian ((&&&))

6462import Control.Lens hiding (Bifunctor, bimap, universe, element)

@@ -70,36 +68,30 @@ import Control.Monad.Ref

7068import Control.Monad.Trans.Control

7169import Data.Coerce

7270import Data.Dependent.Sum (DSum (..))

71+import Data.Functor.Compose

72+import Data.Functor.Misc

7373import Data.GADT.Compare

74+import qualified Data.List as L

7475import Data.Map (Map)

76+import Data.Maybe (fromMaybe)

7577import Data.Monoid

7678import Data.Proxy

7779import Data.Text (Text)

7880import qualified Data.Text as T

79−import Data.Functor.Compose

80−import Data.Functor.Misc

81−import Reflex.Class

82−import Reflex.Host.Class

83−import Reflex.PostBuild.Class

84−import Reflex.TriggerEvent.Class

85−import Reflex.PerformEvent.Class

86−import Reflex.EventWriter.Class

87−import Reflex.EventWriter.Base

88−import Reflex.Dynamic

89−import Reflex.Dom.Builder.Class

9081import Data.Type.Coercion

91−import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can also be routed

92−import Reflex.Dom.Core

9382import qualified GHCJS.DOM as DOM

9483import qualified GHCJS.DOM.Types as DOM

9584import qualified GHCJS.DOM.Window as Window

85+import Language.Javascript.JSaddle (MonadJSM, jsNull, liftJSM) --TODO: Get rid of this - other platforms can also be routed

9686import Network.URI

97−import Data.Maybe (fromMaybe)

98−import qualified Data.List as L

99−

87+import Reflex.Class

88+import Reflex.Dom.Builder.Class

89+import Reflex.Dom.Core

90+import Reflex.Host.Class

10091import Unsafe.Coerce

10192

10293import Obelisk.Configs

94+import Obelisk.Route

10395

10496infixr 5 :~

10597pattern (:~) :: Reflex t => f a -> Dynamic t a -> DSum f (Compose (Dynamic t) Identity)

@@ -256,7 +248,7 @@ dynamicIdentityCoercion = unsafeCoerce (Coercion :: Coercion (Identity ()) ()) -

256248factorRouted :: (Reflex t, MonadFix m, MonadHold t m, GEq f) => RoutedT t (DSum f (Dynamic t)) m a -> RoutedT t (DSum f Identity) m a

257249factorRouted r = RoutedT $ ReaderT $ \d -> do

258250 d' <- factorDyn d

259− runRoutedT r $ (coerceWith (dynamicCoercion $ dsumValueCoercion dynamicIdentityCoercion) d')

251+ runRoutedT r $ coerceWith (dynamicCoercion $ dsumValueCoercion dynamicIdentityCoercion) d'

260252

261253maybeRouted :: (Reflex t, MonadFix m, MonadHold t m) => RoutedT t (Maybe (Dynamic t a)) m b -> RoutedT t (Maybe a) m b

262254maybeRouted r = RoutedT $ ReaderT $ \d -> do

@@ -464,7 +456,7 @@ runRouteViewT

464456 , MonadJSM (Performable m)

465457 , MonadFix m

466458 )

467− => (Encoder Identity Identity r PageName)

459+ => Encoder Identity Identity r PageName

468460 --TODO: Get rid of the switchover and useHash arguments

469461 -- useHash can probably be baked into the encoder

470462 -> Event t () -- ^ Switchover event, nothing is done until this event fires. Used to prevent incorrect DOM expectations at hydration switchover time