git.iko.soy/typeable/schematic
on master help sign in
move constructor DSL to a separate module & remove useless code
commitb1b8d40ad185985517ec6e04a06ddc6a7be26c22 authorDenis Redozubov <denis.redozubov@gmail.com> dateThu 12 Oct 2017, 16:00 (9 years ago) parent661b7e0
6 files changed+78−120
compare with master
unifiedsplit
schematic.cabal+2−1 src/Data/Schematic.hs+1−63 src/Data/Schematic/DSL.hs+71 src/Data/Schematic/Path.hs+4−13 src/Data/Schematic/Utils.hs−42 src/Data/Schematic/Validation.hs−1
schematic.cabal+2−1
@@ -14,6 +14,7 @@ cabal-version: >=1.10
1414
1515library
1616 exposed-modules: Data.Schematic
17+ , Data.Schematic.DSL
1718 , Data.Schematic.Instances
1819 , Data.Schematic.JsonSchema
1920 , Data.Schematic.Helpers
@@ -22,7 +23,6 @@ library
2223 , Data.Schematic.Path
2324 , Data.Schematic.Schema
2425 , Data.Schematic.Validation
25− , Data.Schematic.Utils
2626 ghc-options: -Wall
2727 default-extensions: ConstraintKinds
2828 , DataKinds
@@ -70,6 +70,7 @@ library
7070 , singletons >= 2.2
7171 , smallcheck
7272 , tagged
73+ , template-haskell
7374 , text
7475 , union
7576 , unordered-containers
src/Data/Schematic.hs+1−63
@@ -7,7 +7,6 @@ module Data.Schematic
77 , module Data.Schematic.Lens
88 , module Data.Schematic.Migration
99 , module Data.Schematic.Schema
10− , module Data.Schematic.Utils
1110 , decodeAndValidateJson
1211 , parseAndValidateJson
1312 , parseAndValidateJsonBy
@@ -28,23 +27,15 @@ import Data.Aeson as J
2827import Data.Aeson.Types as J
2928import Data.ByteString.Lazy as BL
3029import Data.Functor.Identity as F
31−import Data.Kind
30+import Data.Schematic.DSL
3231import Data.Schematic.Helpers
3332import Data.Schematic.JsonSchema
3433import Data.Schematic.Lens
3534import Data.Schematic.Migration
3635import Data.Schematic.Schema
37−import Data.Schematic.Utils
3836import Data.Schematic.Validation
39−import Data.Scientific
4037import Data.Singletons.Prelude hiding ((:.))
41−import Data.Singletons.TypeLits
42−import Data.Tagged
4338import 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
4839
4940
5041parseAndValidateJson
@@ -135,56 +126,3 @@ decodeAndValidateVersionedWithPureMList
135126 -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))
136127decodeAndValidateVersionedWithPureMList a b c =
137128 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
22
33import Data.Foldable as F
44import Data.Monoid
5−import Data.Schematic.Utils
65import Data.Singletons
76import Data.Singletons.Prelude
87import Data.Singletons.TypeLits
@@ -12,16 +11,8 @@ import Data.Text as T
1211data PathSegment = Key Symbol | Ix Nat
1312
1413data instance Sing (jp :: PathSegment) where
15− SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)
16− SIx :: (KnownNat n, Known (Sing 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
14+ SKey :: (SingI k) => Sing (k :: Symbol) -> Sing ('Key k)
15+ SIx :: (SingI n) => Sing (n :: Nat) -> Sing ('Ix n)
2516
2617data DemotedPathSegment = DKey Text | DIx Integer
2718 deriving (Show)
@@ -37,8 +28,8 @@ demotePath = go []
3728 go acc SNil = acc
3829 go acc (SCons p ps) = go (acc ++ [demote p]) ps
3930 demote :: Sing (ps :: PathSegment) -> DemotedPathSegment
40− demote (SKey s) = DKey $ T.pack $ symbolVal s
41− demote (SIx n) = DIx $ natVal n
31+ demote (SKey s) = DKey $ T.pack $ withKnownSymbol s $ symbolVal s
32+ demote (SIx n) = DIx $ withKnownNat n $ natVal n
4233
4334demotedPathToText :: [DemotedPathSegment] -> JSONPath
4435demotedPathToText = 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
77import Data.Monoid
88import Data.Schematic.Path
99import Data.Schematic.Schema
10−import Data.Schematic.Utils ()
1110import Data.Scientific
1211import Data.Singletons.Prelude
1312import Data.Singletons.TypeLits