git.iko.soy/schematic
on master help sign in
Simplify constructor DSL
661b7e0Denis Redozubov
src/Data/Schematic.hs+9−19
compare with master
unifiedsplit
@@ -21,15 +21,13 @@ module Data.Schematic
21 , ParseResult(..)
21 , ParseResult(..)
22 , withRepr
22 , withRepr
23 , field
23 , field
24− , (<:&>)
25 ) where
24 ) where
26
25
27−import Control.Applicative
28import Control.Monad.Validation
26import Control.Monad.Validation
29import Data.Aeson as J
27import Data.Aeson as J
30import Data.Aeson.Types as J
28import Data.Aeson.Types as J
31import Data.ByteString.Lazy as BL
29import Data.ByteString.Lazy as BL
32−import Data.Functor.Identity
30+import Data.Functor.Identity as F
33import Data.Kind
31import Data.Kind
34import Data.Schematic.Helpers
32import Data.Schematic.Helpers
35import Data.Schematic.JsonSchema
33import Data.Schematic.JsonSchema
@@ -39,13 +37,14 @@ import Data.Schematic.Schema
39import Data.Schematic.Utils
37import Data.Schematic.Utils
40import Data.Schematic.Validation
38import Data.Schematic.Validation
41import Data.Scientific
39import Data.Scientific
42−import Data.Singletons.Prelude
40+import Data.Singletons.Prelude hiding ((:.))
43import Data.Singletons.TypeLits
41import Data.Singletons.TypeLits
44import Data.Tagged
42import Data.Tagged
45import Data.Text as T
43import Data.Text as T
46import Data.Union
44import Data.Union
47import qualified Data.Vector as V
45import qualified Data.Vector as V
48−import Data.Vinyl
46+import Data.Vinyl as V
47+import Data.Vinyl.Functor
49
48
50
49
51parseAndValidateJson
50parseAndValidateJson
@@ -131,7 +130,7 @@ decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of
131
130
132decodeAndValidateVersionedWithPureMList
131decodeAndValidateVersionedWithPureMList
133 :: proxy versioned
132 :: proxy versioned
134− -> MList Identity (MapSnd (AllVersions versioned))
133+ -> MList F.Identity (MapSnd (AllVersions versioned))
135 -> BL.ByteString
134 -> BL.ByteString
136 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
135 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
137decodeAndValidateVersionedWithPureMList a b c =
136decodeAndValidateVersionedWithPureMList a b c =
@@ -141,20 +140,11 @@ decodeAndValidateVersionedWithPureMList a b c =
141
140
142type Constructor a
141type Constructor a
143 = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)
142 = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)
144− => Tagged (FieldsOf a) (Rec FieldRepr b)
143+ => Rec (Tagged (FieldsOf a) :. FieldRepr) b
145 -> JsonRepr ('SchemaObject (FieldsOf a))
144 -> JsonRepr ('SchemaObject (FieldsOf a))
146
145
147withRepr :: Constructor a
146withRepr :: Constructor a
148−withRepr = ReprObject . unTagged . fmap fcast
147+withRepr = ReprObject . rmap (unTagged . getCompose) . 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 <:&>
158
148
159class Representable s where
149class Representable s where
160 type Repr s :: Type
150 type Repr s :: Type
@@ -194,7 +184,7 @@ type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
194type FieldConstructor fn =
184type FieldConstructor fn =
195 forall fs. (Representable (ByField fn fs (FIndex fn fs)))
185 forall fs. (Representable (ByField fn fs (FIndex fn fs)))
196 => Repr (ByField fn fs (FIndex fn fs))
186 => 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)))
198
188
199field :: forall fn. KnownSymbol fn => FieldConstructor fn
189field :: 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 ::
40 flens
40 flens
41 :: Functor g
41 :: Functor g
42 => proxy fn
42 => proxy fn
43− -> (FieldRepr '(fn, (ByField fn rs i)) -> g (FieldRepr '(fn, (ByField fn rs i))))
43+ -> (f '(fn, (ByField fn rs i)) -> g (f '(fn, (ByField fn rs i))))
44− -> Rec FieldRepr rs
44+ -> Rec f rs
45− -> g (Rec FieldRepr rs)
45+ -> g (Rec f rs)
46
46
47 -- | For Vinyl users who are not using the @lens@ package, we provide a getter.
47 -- | For Vinyl users who are not using the @lens@ package, we provide a getter.
48 fget
48 fget
49 :: proxy fn
49 :: proxy fn
50− -> Rec FieldRepr rs
50+ -> Rec f rs
51− -> FieldRepr '(fn, (ByField fn rs i))
51+ -> f '(fn, (ByField fn rs i))
52
52
53 -- | For Vinyl users who are not using the @lens@ package, we also provide a
53 -- | For Vinyl users who are not using the @lens@ package, we also provide a
54 -- setter. In general, it will be unambiguous what field is being written to,
54 -- setter. In general, it will be unambiguous what field is being written to,
55 -- and so we do not take a proxy argument here.
55 -- and so we do not take a proxy argument here.
56 fput
56 fput
57− :: FieldRepr '(fn, ByField fn rs i)
57+ :: f '(fn, ByField fn rs i)
58− -> Rec FieldRepr rs
58+ -> Rec f rs
59− -> Rec FieldRepr rs
59+ -> Rec f rs
60
60
61instance FElem fn ('(fn, r) ': rs) 'Z where
61instance FElem fn ('(fn, r) ': rs) 'Z where
62 type ByField fn ('(fn, r) ': rs) 'Z = r
62 type ByField fn ('(fn, r) ': rs) 'Z = r
@@ -115,24 +115,24 @@ class is ~ FImage rs ss
115 -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)
115 -- > fsubset :: Lens' (Rec FieldRepr ss) (Rec FieldRepr rs)
116 fsubset
116 fsubset
117 :: Functor g
117 :: Functor g
118− => (Rec FieldRepr rs -> g (Rec FieldRepr rs))
118+ => (Rec f rs -> g (Rec f rs))
119− -> Rec FieldRepr ss
119+ -> Rec f ss
120− -> g (Rec FieldRepr ss)
120+ -> g (Rec f ss)
121
121
122 -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record
122 -- | The getter of the 'fsubset' lens is 'fcast', which takes a larger record
123 -- to a smaller one by forgetting fields.
123 -- to a smaller one by forgetting fields.
124 fcast
124 fcast
125− :: Rec FieldRepr ss
125+ :: Rec f ss
126− -> Rec FieldRepr rs
126+ -> Rec f rs
127 fcast = getConst . fsubset Const
127 fcast = getConst . fsubset Const
128 {-# INLINE fcast #-}
128 {-# INLINE fcast #-}
129
129
130 -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of
130 -- | The setter of the 'fsubset' lens is 'freplace', which allows a slice of
131 -- a record to be replaced with different values.
131 -- a record to be replaced with different values.
132 freplace
132 freplace
133− :: Rec FieldRepr rs
133+ :: Rec f rs
134− -> Rec FieldRepr ss
134+ -> Rec f ss
135− -> Rec FieldRepr ss
135+ -> Rec f ss
136 freplace rs = getIdentity . fsubset (\_ -> Identity rs)
136 freplace rs = getIdentity . fsubset (\_ -> Identity rs)
137 {-# INLINE freplace #-}
137 {-# INLINE freplace #-}
138
138
@@ -145,7 +145,7 @@ instance
145 , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where
145 , FSubset rs ss is) => FSubset ( '(fn,s) ': rs) ss (i ': is) where
146 fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set
146 fsubset = lens (\ss -> fget Proxy ss :& fcast ss) set
147 where
147 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
149 set ss (r :& rs) = fput r $ freplace rs ss
149 set ss (r :& rs) = fput r $ freplace rs ss
150
150
151-- A bunch of @Iso@morphisms
151-- A bunch of @Iso@morphisms
test/JsonSchemaSpec.hs+3−3
@@ -20,9 +20,9 @@ type SchemaExample = 'SchemaObject FieldsSchema
20
20
21exampleData :: JsonRepr SchemaExample
21exampleData :: JsonRepr SchemaExample
22exampleData = withRepr @SchemaExample $
22exampleData = withRepr @SchemaExample $
23− field @"foo" [ReprNumber 13]
23+ field @"foo" [ReprNumber 13]
24− <:&> field @"bar" (pure (ReprText "foo"))
24+ :& field @"bar" (pure (ReprText "foo"))
25− <:&> pure RNil
25+ :& RNil
26
26
27spec :: Spec
27spec :: Spec
28spec = do
28spec = do
test/SchemaSpec.hs+5−4
@@ -10,15 +10,16 @@ import Data.Schematic
10import Data.Vinyl
10import Data.Vinyl
11import Test.Hspec
11import Test.Hspec
12
12
13+
13type SchemaExample = 'SchemaObject
14type SchemaExample = 'SchemaObject
14 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
15 '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]))
15 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
16 , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))]
16
17
17jsonExample :: JsonRepr SchemaExample
18jsonExample :: JsonRepr SchemaExample
18−jsonExample = withRepr @SchemaExample $
19+jsonExample = withRepr @SchemaExample
19− field @"bar" (Just $ ReprText "bar")
20+ $ field @"bar" (Just "bar")
20− <:&> field @"foo" [ReprNumber 12]
21+ :& field @"foo" [12]
21− <:&> pure RNil
22+ :& RNil
22
23
23type TestMigration =
24type TestMigration =
24 'Migration "test_revision"
25 'Migration "test_revision"