60111f8 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Add tabulation library, add dmapEncoder and fieldMapEncoder, add queryOnlyEncoder.

60111f8Cale Gibbard7 years ago

default.nix+1

compare with master

unifiedsplit

@@ -67,6 +67,7 @@ let

67 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

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

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

70+ tabulation = self.callCabal2nix "tabulation" (cleanSource ./lib/tabulation) {};

70 })

71 })

72 (self: super: let

73 (self: super: let

lib/route/obelisk-route.cabal+2

@@ -8,6 +8,7 @@ library

8 build-depends: base,

9 categories,

10 constraints,

11+ constraints-extras,

11 containers,

12 containers,

12 dependent-map,

13 dependent-map,

13 dependent-sum,

14 dependent-sum,

@@ -26,6 +27,7 @@ library

26 reflex,

27 reflex,

27 reflex-dom-core,

28 reflex-dom-core,

28 template-haskell,

29 template-haskell,

30+ tabulation,

29 text,

31 text,

30 transformers,

32 transformers,

31 universe,

33 universe,

lib/route/src/Obelisk/Route.hs+62−8

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

13{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE ScopedTypeVariables #-}

15{-# LANGUAGE TemplateHaskell #-}

16+{-# LANGUAGE TypeApplications #-}

16{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE ViewPatterns #-}

19{-# LANGUAGE ViewPatterns #-}

@@ -85,6 +86,10 @@ module Obelisk.Route

85 , readShowEncoder

86 , readShowEncoder

86 , integralEncoder

87 , integralEncoder

87 , pathSegmentEncoder

88 , pathSegmentEncoder

89+ , queryOnlyEncoder

90+ , Decoder(..)

91+ , dmapEncoder

92+ , fieldMapEncoder

88 ) where

93 ) where

90import Prelude hiding ((.), id)

95import Prelude hiding ((.), id)

@@ -124,6 +129,7 @@ import Network.HTTP.Types.URI

124import qualified Numeric.Lens

129import qualified Numeric.Lens

125import Obelisk.Route.TH

130import Obelisk.Route.TH

126import Text.Read (readMaybe)

131import Text.Read (readMaybe)

132+import Data.Tabulation

127

133

128-- Design goals:

134-- Design goals:

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

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

@@ -547,13 +553,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl

547 }

553 }

548

554

549pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName

555pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName

550−pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl

556+pathOnlyEncoder = second (unitEncoder mempty) . coidr

551− { _encoderImpl_decode = \(path, query) ->

557+

552− if query == mempty

558+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName

553− then pure path

559+queryOnlyEncoder = first (unitEncoder []) . coidl

554− else throwError "pathOnlyEncoderImpl: query was provided"

555− , _encoderImpl_encode = \path -> (path, mempty)

556− }

557

560

558singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]

561singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]

559singletonListEncoder = unsafeMkEncoder $ EncoderImpl

562singletonListEncoder = unsafeMkEncoder $ EncoderImpl

@@ -866,7 +869,6 @@ renderObeliskRoute e r =

866readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName

869readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName

867readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder

870readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder

868

871

869−

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

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

871integralEncoder = prismEncoder (Numeric.Lens.integral)

873integralEncoder = prismEncoder (Numeric.Lens.integral)

872

874

@@ -879,4 +881,56 @@ pathSegmentEncoder = unsafeMkEncoder EncoderImpl

879 (x:xs) -> pure (x, (xs, y))

881 (x:xs) -> pure (x, (xs, y))

880 }

882 }

881

883

884+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }

885+

886+dmapEncoder :: forall check parse k k' v.

887+ ( Monad check

888+ , MonadError Text parse

889+ , Universe (Some k')

890+ , Ord k

891+ , GCompare k'

892+ , GShow k'

893+ )

894+ => Encoder check parse (Some k') k

895+ -> (forall v'. k' v' -> Encoder check parse v' v)

896+ -> Encoder check parse (DMap k' Identity) (Map k v)

897+dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do

898+ keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'

899+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some.This (k' :: k' t)) -> do

900+ ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')

901+ return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)

902+ let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."

903+ return $ EncoderImpl

904+ { _encoderImpl_encode = \dm -> Map.fromList $ do

905+ ((k' :: k' t) :=> Identity v') <- DMap.toList dm

906+ return ( encode keyEncoder (Some.This k')

907+ , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'

908+ )

909+ , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do

910+ Some.This (k' :: k' t) <- tryDecode keyEncoder k

911+ case DMap.lookup k' valueDecoders of

912+ Nothing -> throwError . T.pack . keyError $ gshow k'

913+ Just (Decoder e) -> do

914+ v' <- tryDecode e v

915+ return (k' :=> Identity v')

916+ }

917+

918+fieldMapEncoder :: forall check parse r.

919+ ( Applicative check

920+ , MonadError Text parse

921+ , HasFields r

922+ , Universe (Some (Field r))

923+ , GShow (Field r)

924+ , GCompare (Field r)

925+ )

926+ => Encoder check parse r (DMap (Field r) Identity)

927+fieldMapEncoder = unsafeEncoder $ do

928+ pure $ EncoderImpl

929+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some.This f <- universe ]

930+ , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do

931+ case DMap.lookup f dm of

932+ Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."

933+ Just (Identity v) -> return v

934+ }

935+

882--TODO: decodeURIComponent as appropriate

936--TODO: decodeURIComponent as appropriate

lib/tabulation/CHANGELOG.mdnew file+5

@@ -0,0 +1,5 @@

1+# Revision history for tabulation

3+## 0.1.0.0 -- 2019-05-24

5+* First version. Basically carve out this library as a place for the HasFields class.

lib/tabulation/LICENSEnew file+30

@@ -0,0 +1,30 @@

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Cale Gibbard nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

lib/tabulation/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

lib/tabulation/src/Data/Tabulation.hsnew file+17

@@ -0,0 +1,17 @@

1+{-# LANGUAGE TypeFamilies #-}

2+{-# LANGUAGE RankNTypes #-}

4+module Data.Tabulation where

6+import Control.Lens

8+-- | This is a class for record types whose fields can be enumerated by an associated GADT. It's closely related to the concept of a representable functor, except without the functor part, and the fields are not all the same type.

9+class HasFields a where

10+ type Field a :: * -> *

11+ tabulateFields :: (forall x. Field a x -> x) -> a

12+ tabulateFields f = runIdentity (tabulateFieldsA (Identity . f))

13+ tabulateFieldsA :: Applicative f => (forall x. Field a x -> f x) -> f a

14+ fieldLens :: Field a x -> Lens' a x

15+ traverseWithField :: Applicative m => (forall x. Field a x -> x -> m x) -> a -> m a

16+ indexField :: a -> Field a x -> x

17+ indexField a f = a ^. fieldLens f

lib/tabulation/tabulation.cabalnew file+26

@@ -0,0 +1,26 @@

1+cabal-version: >=1.10

2+-- Initial package description 'tabulation.cabal' generated by 'cabal

3+-- init'. For further documentation, see

4+-- http://haskell.org/cabal/users-guide/

6+name: tabulation

7+version: 0.1.0.0

8+synopsis: A library for types that can be completely reconstructed by fields as specified by a GADT.

9+-- description:

10+-- bug-reports:

11+license: BSD3

12+license-file: LICENSE

13+author: Cale Gibbard

14+maintainer: cale.gibbard@obsidian.systems

15+-- copyright:

16+category: Data

17+build-type: Simple

18+extra-source-files: CHANGELOG.md

19+

20+library

21+ exposed-modules: Data.Tabulation

22+ -- other-modules:

23+ -- other-extensions:

24+ build-depends: base, lens

25+ hs-source-dirs: src

26+ default-language: Haskell2010