git.iko.soy/typeable/schematic
on master help sign in
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"