661b7e0 · schematic · git.iko.soy

git.iko.soy/schematic

Simplify constructor DSL

commit661b7e0e7b8128cb7d1980b1f0575f77c9688a46 authorDenis Redozubov <denis.redozubov@gmail.com> dateThu 12 Oct 2017, 15:42 (9 years ago) parentb8797b8

4 files changed+34−43

compare with master

unifiedsplit

src/Data/Schematic.hs+9−19 src/Data/Schematic/Lens.hs+17−17 test/JsonSchemaSpec.hs+3−3 test/SchemaSpec.hs+5−4

src/Data/Schematic.hs+9−19

@@ -21,15 +21,13 @@ module Data.Schematic

2121 , ParseResult(..)

2222 , withRepr

2323 , field

24− , (<:&>)

2524 ) where

2625

27−import Control.Applicative

2826import Control.Monad.Validation

2927import Data.Aeson as J

3028import Data.Aeson.Types as J

3129import Data.ByteString.Lazy as BL

32−import Data.Functor.Identity

30+import Data.Functor.Identity as F

3331import Data.Kind

3432import Data.Schematic.Helpers

3533import Data.Schematic.JsonSchema

@@ -39,13 +37,14 @@ import Data.Schematic.Schema

3937import Data.Schematic.Utils

4038import Data.Schematic.Validation

4139import Data.Scientific

42−import Data.Singletons.Prelude

40+import Data.Singletons.Prelude hiding ((:.))

4341import Data.Singletons.TypeLits

4442import Data.Tagged

4543import Data.Text as T

4644import Data.Union

4745import qualified Data.Vector as V

48−import Data.Vinyl

46+import Data.Vinyl as V

47+import Data.Vinyl.Functor

4948

5049

5150parseAndValidateJson

@@ -131,7 +130,7 @@ decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of

131130

132131decodeAndValidateVersionedWithPureMList

133132 :: proxy versioned

134− -> MList Identity (MapSnd (AllVersions versioned))

133+ -> MList F.Identity (MapSnd (AllVersions versioned))

135134 -> BL.ByteString

136135 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))

137136decodeAndValidateVersionedWithPureMList a b c =

@@ -141,20 +140,11 @@ decodeAndValidateVersionedWithPureMList a b c =

141140

142141type Constructor a

143142 = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)

144− => Tagged (FieldsOf a) (Rec FieldRepr b)

143+ => Rec (Tagged (FieldsOf a) :. FieldRepr) b

145144 -> JsonRepr ('SchemaObject (FieldsOf a))

146145

147146withRepr :: Constructor a

148−withRepr = ReprObject . unTagged . fmap fcast

149−

150−(<:&>)

151− :: Applicative m

152− => m (FieldRepr fns)

153− -> m (Rec FieldRepr b)

154− -> m (Rec FieldRepr (fns ': b))

155−(<:&>) = liftA2 (:&)

156−

157−infixr 7 <:&>

147+withRepr = ReprObject . rmap (unTagged . getCompose) . fcast

158148

159149class Representable s where

160150 type Repr s :: Type

@@ -194,7 +184,7 @@ type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where

194184type FieldConstructor fn =

195185 forall fs. (Representable (ByField fn fs (FIndex fn fs)))

196186 => Repr (ByField fn fs (FIndex fn fs))

197− -> Tagged fs (FieldRepr '(fn, (ByField fn fs (FIndex fn fs))))

187+ -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))

198188

199189field :: forall fn. KnownSymbol fn => FieldConstructor fn

200−field = Tagged . construct (sing :: Sing fn) Proxy

190+field = Compose . Tagged . construct (sing :: Sing fn) Proxy

src/Data/Schematic/Lens.hs+17−17

@@ -40,23 +40,23 @@ class i ~ FIndex fn rs => FElem (fn :: Symbol) (rs :: [(Symbol, Schema)]) (i ::

4040 flens

4141 :: Functor g

4242 => proxy fn

43− -> (FieldRepr '(fn, (ByField fn rs i)) -> g (FieldRepr '(fn, (ByField fn rs i))))

44− -> Rec FieldRepr rs

45− -> g (Rec FieldRepr rs)

43+ -> (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))

44+ -> Rec f rs

45+ -> g (Rec f rs)

4646

4747 -- | For Vinyl users who are not using the @lens@ package, we provide a getter.

4848 fget

4949 :: proxy fn

50− -> Rec FieldRepr rs

51− -> FieldRepr '(fn, (ByField fn rs i))

50+ -> Rec f rs

51+ -> f '(fn, (ByField fn rs i))

5252

5353 -- | For Vinyl users who are not using the @lens@ package, we also provide a

5454 -- setter. In general, it will be unambiguous what field is being written to,

5555 -- and so we do not take a proxy argument here.

5656 fput

57− :: FieldRepr '(fn, ByField fn rs i)

58− -> Rec FieldRepr rs

59− -> Rec FieldRepr rs

57+ :: f '(fn, ByField fn rs i)

58+ -> Rec f rs

59+ -> Rec f rs

6060

6161instance FElem fn ('(fn, r) ': rs) 'Z where

6262 type ByField fn ('(fn, r) ': rs) 'Z = r

@@ -115,24 +115,24 @@ class is ~ FImage rs ss

115115 -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)

116116 fsubset

117117 :: Functor g

118− => (Rec FieldRepr rs -> g (Rec FieldRepr rs))

119− -> Rec FieldRepr ss

120− -> g (Rec FieldRepr ss)

118+ => (Rec f rs -> g (Rec f rs))

119+ -> Rec f ss

120+ -> g (Rec f ss)

121121

122122 -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record

123123 -- to a smaller one by forgetting fields.

124124 fcast

125− :: Rec FieldRepr ss

126− -> Rec FieldRepr rs

125+ :: Rec f ss

126+ -> Rec f rs

127127 fcast = getConst . fsubset Const

128128 {-# INLINE fcast #-}

129129

130130 -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of

131131 -- a record to be replaced with different values.

132132 freplace

133− :: Rec FieldRepr rs

134− -> Rec FieldRepr ss

135− -> Rec FieldRepr ss

133+ :: Rec f rs

134+ -> Rec f ss

135+ -> Rec f ss

136136 freplace rs = getIdentity . fsubset (\_ -> Identity rs)

137137 {-# INLINE freplace #-}

138138

@@ -145,7 +145,7 @@ instance

145145 , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where

146146 fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set

147147 where

148− set :: Rec FieldRepr ss -> Rec FieldRepr ( '(fn,s) ': rs) -> Rec FieldRepr ss

148+ set :: Rec f ss -> Rec f ( '(fn,s) ': rs) -> Rec f ss

149149 set ss (r :& rs) = fput r $ freplace rs ss

150150

151151-- A bunch of @Iso@morphisms

test/JsonSchemaSpec.hs+3−3

@@ -20,9 +20,9 @@ type SchemaExample = 'SchemaObject FieldsSchema

2020

2121exampleData :: JsonRepr SchemaExample

2222exampleData = withRepr @SchemaExample $

23− field @"foo" [ReprNumber 13]

24− <:&> field @"bar" (pure (ReprText "foo"))

25− <:&> pure RNil

23+ field @"foo" [ReprNumber 13]

24+ :& field @"bar" (pure (ReprText "foo"))

25+ :& RNil

2626

2727spec :: Spec

2828spec = do

test/SchemaSpec.hs+5−4

@@ -10,15 +10,16 @@ import Data.Schematic

1010import Data.Vinyl

1111import Test.Hspec

1212

13+

1314type SchemaExample = 'SchemaObject

1415 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))

1516 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]

1617

1718jsonExample :: JsonRepr SchemaExample

18−jsonExample = withRepr @SchemaExample $

19− field @"bar" (Just $ ReprText "bar")

20− <:&> field @"foo" [ReprNumber 12]

21− <:&> pure RNil

19+jsonExample = withRepr @SchemaExample

20+ $ field @"bar" (Just "bar")

21+ :& field @"foo" [12]

22+ :& RNil

2223

2324type TestMigration =

2425 'Migration "test_revision"