git.iko.soy/schematic
on master help sign in
move constructor DSL to a separate module & remove useless code
b1b8d40Denis Redozubov
schematic.cabal+2−1
compare with master
unifiedsplit
@@ -14,6 +14,7 @@ cabal-version: >=1.10
14
14
15library
15library
16 exposed-modules: Data.Schematic
16 exposed-modules: Data.Schematic
17+ , Data.Schematic.DSL
17 , Data.Schematic.Instances
18 , Data.Schematic.Instances
18 , Data.Schematic.JsonSchema
19 , Data.Schematic.JsonSchema
19 , Data.Schematic.Helpers
20 , Data.Schematic.Helpers
@@ -22,7 +23,6 @@ library
22 , Data.Schematic.Path
23 , Data.Schematic.Path
23 , Data.Schematic.Schema
24 , Data.Schematic.Schema
24 , Data.Schematic.Validation
25 , Data.Schematic.Validation
25− , Data.Schematic.Utils
26 ghc-options: -Wall
26 ghc-options: -Wall
27 default-extensions: ConstraintKinds
27 default-extensions: ConstraintKinds
28 , DataKinds
28 , DataKinds
@@ -70,6 +70,7 @@ library
70 , singletons >= 2.2
70 , singletons >= 2.2
71 , smallcheck
71 , smallcheck
72 , tagged
72 , tagged
73+ , template-haskell
73 , text
74 , text
74 , union
75 , union
75 , unordered-containers
76 , unordered-containers
src/Data/Schematic.hs+1−63
@@ -7,7 +7,6 @@ module Data.Schematic
7 , module Data.Schematic.Lens
7 , module Data.Schematic.Lens
8 , module Data.Schematic.Migration
8 , module Data.Schematic.Migration
9 , module Data.Schematic.Schema
9 , module Data.Schematic.Schema
10− , module Data.Schematic.Utils
11 , decodeAndValidateJson
10 , decodeAndValidateJson
12 , parseAndValidateJson
11 , parseAndValidateJson
13 , parseAndValidateJsonBy
12 , parseAndValidateJsonBy
@@ -28,23 +27,15 @@ import Data.Aeson as J
28import Data.Aeson.Types as J
27import Data.Aeson.Types as J
29import Data.ByteString.Lazy as BL
28import Data.ByteString.Lazy as BL
30import Data.Functor.Identity as F
29import Data.Functor.Identity as F
31−import Data.Kind
30+import Data.Schematic.DSL
32import Data.Schematic.Helpers
31import Data.Schematic.Helpers
33import Data.Schematic.JsonSchema
32import Data.Schematic.JsonSchema
34import Data.Schematic.Lens
33import Data.Schematic.Lens
35import Data.Schematic.Migration
34import Data.Schematic.Migration
36import Data.Schematic.Schema
35import Data.Schematic.Schema
37−import Data.Schematic.Utils
38import Data.Schematic.Validation
36import Data.Schematic.Validation
39−import Data.Scientific
40import Data.Singletons.Prelude hiding ((:.))
37import Data.Singletons.Prelude hiding ((:.))
41−import Data.Singletons.TypeLits
42−import Data.Tagged
43import Data.Text as T
38import Data.Text as T
44−import Data.Union
45−import qualified Data.Vector as V
46−import Data.Vinyl as V
47−import Data.Vinyl.Functor
48
39
49
40
50parseAndValidateJson
41parseAndValidateJson
@@ -135,56 +126,3 @@ decodeAndValidateVersionedWithPureMList
135 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
126 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
136decodeAndValidateVersionedWithPureMList a b c =
127decodeAndValidateVersionedWithPureMList a b c =
137 runIdentity $ decodeAndValidateVersionedWithMList a b c
128 runIdentity $ decodeAndValidateVersionedWithMList a b c
138−
139−-- convenience helpers
140−
141−type Constructor a
142− = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)
143− => Rec (Tagged (FieldsOf a) :. FieldRepr) b
144− -> JsonRepr ('SchemaObject (FieldsOf a))
145−
146−withRepr :: Constructor a
147−withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
148−
149−class Representable s where
150− type Repr s :: Type
151− construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
152−
153−instance SingI so => Representable ('SchemaObject so) where
154− type Repr ('SchemaObject so) = Rec FieldRepr so
155− construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
156−
157−instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
158− type Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
159− construct sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
160−
161−instance SingI cs => Representable ('SchemaText cs) where
162− type Repr ('SchemaText cs) = Text
163− construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
164−
165−instance SingI cs => Representable ('SchemaNumber cs) where
166− type Repr ('SchemaNumber cs) = Scientific
167− construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
168−
169−instance Representable 'SchemaBoolean where
170− type Repr 'SchemaBoolean = Bool
171− construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
172−
173−instance SingI so => Representable ('SchemaOptional so) where
174− type Repr ('SchemaOptional so) = Maybe (JsonRepr so)
175− construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
176−
177−instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
178− type Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
179− construct sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
180−
181−type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
182− FieldsOf ('SchemaObject fs) = fs
183−
184−type FieldConstructor fn =
185− forall fs. (Representable (ByField fn fs (FIndex fn fs)))
186− => Repr (ByField fn fs (FIndex fn fs))
187− -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))
188−
189−field :: forall fn. KnownSymbol fn => FieldConstructor fn
190−field = Compose . Tagged . construct (sing :: Sing fn) Proxy
src/Data/Schematic/DSL.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+
3+module Data.Schematic.DSL where
4+
5+import Data.Kind
6+import Data.Schematic.Lens
7+import Data.Schematic.Migration
8+import Data.Schematic.Schema
9+import Data.Scientific
10+import Data.Singletons
11+import Data.Singletons.Prelude hiding ((:.))
12+import Data.Singletons.TypeLits
13+import Data.Tagged
14+import Data.Text as T
15+import Data.Union
16+import qualified Data.Vector as V
17+import Data.Vinyl
18+import Data.Vinyl.Functor
19+
20+
21+
22+type Constructor a
23+ = forall b. FSubset (FieldsOf a) b (FImage (FieldsOf a) b)
24+ => Rec (Tagged (FieldsOf a) :. FieldRepr) b
25+ -> JsonRepr ('SchemaObject (FieldsOf a))
26+
27+withRepr :: Constructor a
28+withRepr = ReprObject . rmap (unTagged . getCompose) . fcast
29+
30+class Representable s where
31+ type Repr s :: Type
32+ construct :: Sing fn -> Proxy s -> Repr s -> FieldRepr '(fn, s)
33+
34+instance SingI so => Representable ('SchemaObject so) where
35+ type Repr ('SchemaObject so) = Rec FieldRepr so
36+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprObject o
37+
38+instance (SingI cs, SingI sa) => Representable ('SchemaArray cs sa) where
39+ type Repr ('SchemaArray cs sa) = V.Vector (JsonRepr sa)
40+ construct sfn _ a = withKnownSymbol sfn $ FieldRepr $ ReprArray a
41+
42+instance SingI cs => Representable ('SchemaText cs) where
43+ type Repr ('SchemaText cs) = Text
44+ construct sfn _ t = withKnownSymbol sfn $ FieldRepr $ ReprText t
45+
46+instance SingI cs => Representable ('SchemaNumber cs) where
47+ type Repr ('SchemaNumber cs) = Scientific
48+ construct sfn _ n = withKnownSymbol sfn $ FieldRepr $ ReprNumber n
49+
50+instance Representable 'SchemaBoolean where
51+ type Repr 'SchemaBoolean = Bool
52+ construct sfn _ b = withKnownSymbol sfn $ FieldRepr $ ReprBoolean b
53+
54+instance SingI so => Representable ('SchemaOptional so) where
55+ type Repr ('SchemaOptional so) = Maybe (JsonRepr so)
56+ construct sfn _ o = withKnownSymbol sfn $ FieldRepr $ ReprOptional o
57+
58+instance SingI (h ': tl) => Representable ('SchemaUnion (h ': tl)) where
59+ type Repr ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
60+ construct sfn _ u = withKnownSymbol sfn $ FieldRepr $ ReprUnion u
61+
62+type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
63+ FieldsOf ('SchemaObject fs) = fs
64+
65+type FieldConstructor fn =
66+ forall fs. (Representable (ByField fn fs (FIndex fn fs)))
67+ => Repr (ByField fn fs (FIndex fn fs))
68+ -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))
69+
70+field :: forall fn. KnownSymbol fn => FieldConstructor fn
71+field = Compose . Tagged . construct (sing :: Sing fn) Proxy
src/Data/Schematic/Path.hs+4−13
@@ -2,7 +2,6 @@ module Data.Schematic.Path where
2
2
3import Data.Foldable as F
3import Data.Foldable as F
4import Data.Monoid
4import Data.Monoid
5−import Data.Schematic.Utils
6import Data.Singletons
5import Data.Singletons
7import Data.Singletons.Prelude
6import Data.Singletons.Prelude
8import Data.Singletons.TypeLits
7import Data.Singletons.TypeLits
@@ -12,16 +11,8 @@ import Data.Text as T
12data PathSegment = Key Symbol | Ix Nat
11data PathSegment = Key Symbol | Ix Nat
13
12
14data instance Sing (jp :: PathSegment) where
13data instance Sing (jp :: PathSegment) where
15− SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)
14+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)
16− SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)
15+ SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)
17−
18−instance (KnownSymbol k, Known (Sing k))
19− => Known (Sing ('Key k)) where
20− known = SKey known
21−
22−instance (KnownNat n, Known (Sing n))
23− => Known (Sing ('Ix n)) where
24− known = SIx known
25
16
26data DemotedPathSegment = DKey Text | DIx Integer
17data DemotedPathSegment = DKey Text | DIx Integer
27 deriving (Show)
18 deriving (Show)
@@ -37,8 +28,8 @@ demotePath = go []
37 go acc SNil = acc
28 go acc SNil = acc
38 go acc (SCons p ps) = go (acc ++ [demote p]) ps
29 go acc (SCons p ps) = go (acc ++ [demote p]) ps
39 demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
30 demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
40− demote (SKey s) = DKey $ T.pack $ symbolVal s
31+ demote (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s
41− demote (SIx n) = DIx $ natVal n
32+ demote (SIx n) = DIx $ withKnownNat n $ natVal n
42
33
43demotedPathToText :: [DemotedPathSegment] -> JSONPath
34demotedPathToText :: [DemotedPathSegment] -> JSONPath
44demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
35demotedPathToText = JSONPath . F.foldl' renderPathSegment ""
src/Data/Schematic/Utils.hsdeleted−42
@@ -1,42 +0,0 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−
3−module Data.Schematic.Utils where
4−
5−import Data.Proxy
6−import Data.Singletons
7−import Data.Singletons.Prelude
8−import Data.Singletons.TypeLits
9−import Data.Vinyl hiding (Dict)
10−
11−
12−class Known a where
13− known :: a
14−
15−instance Known (Proxy a) where
16− known = Proxy
17−
18−instance KnownNat n => Known (Sing n) where
19− known = SNat
20−
21−instance KnownSymbol s => Known (Sing s) where
22− known = SSym
23−
24−instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where
25− known = STuple2 known known
26−
27−instance Known (Sing '[]) where known = SNil
28−
29−instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where
30− known = SCons known known
31−
32−instance Known (Rec Sing '[]) where
33− known = RNil
34−
35−instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where
36− known = known :& known
37−
38−data Dict c where
39− Dict :: c => Dict c
40−
41−instance c => Known (Dict c) where
42− known = Dict
src/Data/Schematic/Validation.hs−1
@@ -7,7 +7,6 @@ import Data.Functor.Identity
7import Data.Monoid
7import Data.Monoid
8import Data.Schematic.Path
8import Data.Schematic.Path
9import Data.Schematic.Schema
9import Data.Schematic.Schema
10−import Data.Schematic.Utils ()
11import Data.Scientific
10import Data.Scientific
12import Data.Singletons.Prelude
11import Data.Singletons.Prelude
13import Data.Singletons.TypeLits
12import Data.Singletons.TypeLits