d5ee34d · obelisk · git.iko.soy

git.iko.soy/obelisk

lib/route: add deriveRouteComponent

commitd5ee34d55665e51d3293a3f8af7183d657a7c8fd authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 27 Jul 2018, 14:16 (8 years ago) parent887da01

4 files changed+48−64

compare with master

unifiedsplit

default.nix+17−7 lib/route/obelisk-route.cabal+4−1 lib/route/src/Obelisk/Route.hs+9−56 lib/route/src/Obelisk/Route/TH.hs+18

default.nix+17−7

@@ -77,6 +77,23 @@ let

7777 sha256 = "11v20ing8lrb5ccf6g9iihwcw5d22yj2ifw15v04ypn19y8kariw";

7878 };

7979 in pkgs.haskell.lib.dontCheck (self.callCabal2nix "monoidal-containers" src {});

80+

81+ # Need deriveSomeUniverse

82+ # PR: https://github.com/dmwit/universe/pull/32

83+ universe-template = self.callCabal2nix "universe-template" (pkgs.fetchFromGitHub {

84+ owner = "obsidiansystems";

85+ repo = "universe";

86+ rev = "5a2fc823caa4163411d7e41aa80e67cefb15944a";

87+ sha256 = "0ll2z0fh18z6x8jl8kbp7ldagwccz3wjmvrw1gw752z058n82yfa";

88+ } + /template) {};

89+

90+ # Need ShowTag, EqTag, and OrdTag instances

91+ dependent-sum-template = self.callCabal2nix "dependent-sum-template" (pkgs.fetchFromGitHub {

92+ owner = "mokus0";

93+ repo = "dependent-sum-template";

94+ rev = "bfe9c37f4eaffd8b17c03f216c06a0bfb66f7df7";

95+ sha256 = "1w3s7nvw0iw5li3ry7s8r4651qwgd22hmgz6by0iw3rm64fy8x0y";

96+ }) {};

8097 };

8198

8299 cleanSource = builtins.filterSource (name: _: let baseName = builtins.baseNameOf name; in !(

@@ -101,13 +118,6 @@ let

101118 obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

102119 obelisk-snap = self.callCabal2nix "obelisk-snap" (cleanSource ./lib/snap) {};

103120 obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" (cleanSource ./lib/snap-extras) {};

104−

105− dependent-sum-template = self.callCabal2nix "dependent-sum-template" (pkgs.fetchFromGitHub {

106− owner = "mokus0";

107− repo = "dependent-sum-template";

108− rev = "877aea7817f8b9a7ca90374692402cc505bbab25";

109− sha256 = "0x065vdvjnbn2fiw27kk1zbjgknfnbli9bjvn4pmdbdf8m9picpg";

110− }) {};

111121 };

112122

113123 inherit (import ./lib/asset/assets.nix { inherit nixpkgs; }) mkAssets;

lib/route/obelisk-route.cabal+4−1

@@ -24,9 +24,12 @@ library

2424 ref-tf,

2525 reflex,

2626 reflex-dom,

27+ template-haskell,

2728 text,

2829 transformers,

29− universe

30+ universe,

31+ universe-template

3032 exposed-modules: Obelisk.Route

33+ Obelisk.Route.TH

3134 Obelisk.Route.Frontend

3235 ghc-options: -Wall -fwarn-redundant-constraints

lib/route/src/Obelisk/Route.hs+9−56

@@ -67,7 +67,7 @@ import qualified Control.Categorical.Functor as Cat

6767import Control.Categorical.Bifunctor

6868import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?))

6969import Control.Monad.Except

70−import Data.Dependent.Sum (DSum (..), ShowTag (..))

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

7171import Data.Dependent.Map (DMap)

7272import qualified Data.Dependent.Map as DMap

7373import Data.Either.Validation (Validation (..))

@@ -76,7 +76,6 @@ import Data.Functor.Sum

7676import Data.GADT.Compare

7777import Data.GADT.Compare.TH

7878import Data.GADT.Show

79−import Data.GADT.Show.TH

8079import Data.List.NonEmpty (NonEmpty (..))

8180import Data.Map (Map)

8281import qualified Data.Map as Map

@@ -90,6 +89,7 @@ import qualified Data.Text as T

9089import Data.Text.Encoding

9190import Data.Universe

9291import Network.HTTP.Types.URI

92+import Obelisk.Route.TH

9393

9494-- Design goals:

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

@@ -462,14 +462,6 @@ data ResourceRoute :: * -> * where

462462 ResourceRoute_Ghcjs :: ResourceRoute [Text]

463463 ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)

464464

465−--TODO: Generate this

466−instance Universe (Some ResourceRoute) where

467− universe =

468− [ Some.This ResourceRoute_Static

469− , Some.This ResourceRoute_Ghcjs

470− , Some.This ResourceRoute_JSaddleWarp

471− ]

472−

473465--TODO: Figure out a way to check this

474466obeliskComponentEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (ObeliskRoute f)) (Either (Some ResourceRoute) (Some f))

475467obeliskComponentEncoder = Encoder $ pure $ ValidEncoder

@@ -551,13 +543,6 @@ data JSaddleWarpRoute :: * -> * where

551543 JSaddleWarpRoute_WebSocket :: JSaddleWarpRoute ()

552544 JSaddleWarpRoute_Sync :: JSaddleWarpRoute [Text]

553545

554−instance Universe (Some JSaddleWarpRoute) where

555− universe =

556− [ Some.This JSaddleWarpRoute_JavaScript

557− , Some.This JSaddleWarpRoute_WebSocket

558− , Some.This JSaddleWarpRoute_Sync

559− ]

560−

561546jsaddleWarpRouteComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some JSaddleWarpRoute) (Maybe Text)

562547jsaddleWarpRouteComponentEncoder = enum1Encoder $ \case

563548 JSaddleWarpRoute_JavaScript -> Just "jsaddle.js"

@@ -570,29 +555,6 @@ jsaddleWarpRouteEncoder = pathComponentEncoder jsaddleWarpRouteComponentEncoder

570555 JSaddleWarpRoute_WebSocket -> endValidEncoder mempty

571556 JSaddleWarpRoute_Sync -> pathOnlyValidEncoder

572557

573−instance ShowTag appRoute Identity => ShowTag (ObeliskRoute appRoute) Identity where

574− showTaggedPrec = \case

575− ObeliskRoute_App a -> showTaggedPrec a

576− ObeliskRoute_Resource r -> showTaggedPrec r

577−

578−instance ShowTag ResourceRoute Identity where

579− showTaggedPrec = \case

580− ResourceRoute_Static -> showsPrec

581− ResourceRoute_Ghcjs -> showsPrec

582− ResourceRoute_JSaddleWarp -> showsPrec

583−

584−instance ShowTag JSaddleWarpRoute Identity where

585− showTaggedPrec = \case

586− JSaddleWarpRoute_JavaScript -> showsPrec

587− JSaddleWarpRoute_WebSocket -> showsPrec

588− JSaddleWarpRoute_Sync -> showsPrec

589−

590−instance Universe (Some appRoute) => Universe (Some (ObeliskRoute appRoute)) where

591− universe = mconcat

592− [ mapSome ObeliskRoute_App <$> universe

593− , mapSome ObeliskRoute_Resource <$> universe

594− ]

595−

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

597559 gshowsPrec prec = \case

598560 ObeliskRoute_App appRoute -> showParen (prec > 10) $

@@ -604,9 +566,6 @@ instance GShow appRoute => GShow (ObeliskRoute appRoute) where

604566data IndexOnlyRoute :: * -> * where

605567 IndexOnlyRoute :: IndexOnlyRoute ()

606568

607−instance Universe (Some IndexOnlyRoute) where

608− universe = [Some.This IndexOnlyRoute]

609−

610569indexOnlyRouteComponentEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (Some IndexOnlyRoute) (Maybe Text)

611570indexOnlyRouteComponentEncoder = enum1Encoder $ \case

612571 IndexOnlyRoute -> Nothing

@@ -623,10 +582,6 @@ constLaxValidEncoder a = ValidEncoder

623582 , _validEncoder_decode = \_ -> pure ()

624583 }

625584

626−instance ShowTag IndexOnlyRoute Identity where

627− showTaggedPrec = \case

628− IndexOnlyRoute -> showsPrec

629−

630585someSumEncoder :: (Applicative check, Applicative parse) => Encoder check parse (Some (Sum a b)) (Either (Some a) (Some b))

631586someSumEncoder = Encoder $ pure $ ValidEncoder

632587 { _validEncoder_encode = \(Some.This t) -> case t of

@@ -653,15 +608,13 @@ instance GShow Void1 where

653608 gshowsPrec _ = \case {}

654609

655610makePrisms ''ObeliskRoute

656−deriveGShow ''ResourceRoute

657−deriveGEq ''ResourceRoute

658−deriveGCompare ''ResourceRoute

659−deriveGShow ''JSaddleWarpRoute

660−deriveGEq ''JSaddleWarpRoute

661−deriveGCompare ''JSaddleWarpRoute

662−deriveGShow ''IndexOnlyRoute

663−deriveGEq ''IndexOnlyRoute

664−deriveGCompare ''IndexOnlyRoute

611+

612+concat <$> mapM deriveRouteComponent

613+ [ ''ResourceRoute

614+ , ''JSaddleWarpRoute

615+ , ''IndexOnlyRoute

616+ ]

617+

665618deriveGEq ''Void1

666619deriveGCompare ''Void1

667620

lib/route/src/Obelisk/Route/TH.hsnew file+18

@@ -0,0 +1,18 @@

1+module Obelisk.Route.TH (deriveRouteComponent) where

3+import Data.GADT.Show.TH

4+import Data.GADT.Compare.TH

5+import Data.Universe.TH

6+import Language.Haskell.TH

8+-- | Derive all the typeclasses needed for a RouteComponent type. The argument should be the name of a type of kind @k -> *@

9+deriveRouteComponent :: Name -> Q [Dec]

10+deriveRouteComponent x = concat <$> traverse ($ x)

11+ [ deriveGShow

12+ , deriveGEq

13+ , deriveGCompare

14+ , deriveShowTagIdentity

15+ , deriveEqTagIdentity

16+ , deriveOrdTagIdentity

17+ , deriveSomeUniverse

18+ ]