git.iko.soy/typeable/schematic
on master help sign in
fix warnings
26cc050Denis Redozubov
src/Data/Schematic/Instances.hs+1
compare with master
unifiedsplit
@@ -1,4 +1,5 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
2
3
3module Data.Schematic.Instances where
4module Data.Schematic.Instances where
4
5
src/Data/Schematic/Path.hs+4−4
@@ -10,15 +10,15 @@ import Data.Text as T
10data PathSegment = Key Symbol | Ix Nat
10data PathSegment = Key Symbol | Ix Nat
11
11
12data instance Sing (jp :: PathSegment) where
12data instance Sing (jp :: PathSegment) where
13− SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing (Key k)
13+ SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k)
14− SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing (Ix n)
14+ SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n)
15
15
16instance (KnownSymbol k, Known (Sing k))
16instance (KnownSymbol k, Known (Sing k))
17− => Known (Sing (Key k)) where
17+ => Known (Sing ('Key k)) where
18 known = SKey known
18 known = SKey known
19
19
20instance (KnownNat n, Known (Sing n))
20instance (KnownNat n, Known (Sing n))
21− => Known (Sing (Ix n)) where
21+ => Known (Sing ('Ix n)) where
22 known = SIx known
22 known = SIx known
23
23
24pathToText :: Sing (ps :: [PathSegment]) -> Text
24pathToText :: Sing (ps :: [PathSegment]) -> Text
src/Data/Schematic/Schema.hs+79−87
@@ -6,40 +6,32 @@
6module Data.Schematic.Schema where
6module Data.Schematic.Schema where
7
7
8import Control.Applicative
8import Control.Applicative
9−import Control.Category ((<<<), (>>>))
10import Control.Monad
9import Control.Monad
11−import Control.Monad.Validation
12import Data.Aeson as J
10import Data.Aeson as J
13import Data.Aeson.Types as J
11import Data.Aeson.Types as J
14−import Data.Eq.Deriving (deriveEq1)
15−import Data.Foldable as F
16−import Data.Functor.Classes
17import Data.HashMap.Strict as H
12import Data.HashMap.Strict as H
18import Data.Kind
13import Data.Kind
19import Data.Maybe
14import Data.Maybe
20−import Data.Schematic.Instances
15+import Data.Schematic.Instances ()
21import Data.Schematic.Utils
16import Data.Schematic.Utils
22import Data.Scientific
17import Data.Scientific
23−import Data.Singletons.Decide
24import Data.Singletons.Prelude.List
18import Data.Singletons.Prelude.List
25import Data.Singletons.TH
19import Data.Singletons.TH
26import Data.Singletons.TypeLits
20import Data.Singletons.TypeLits
27import Data.Text as T
21import Data.Text as T
28import Data.Vector as V
22import Data.Vector as V
29import Data.Vinyl hiding (Dict)
23import Data.Vinyl hiding (Dict)
30−import Data.Vinyl.Functor
31import Data.Vinyl.TypeLevel hiding (Nat)
24import Data.Vinyl.TypeLevel hiding (Nat)
32import GHC.Generics (Generic)
25import GHC.Generics (Generic)
33import Prelude as P
26import Prelude as P
34import Test.SmallCheck.Series
27import Test.SmallCheck.Series
35−import Text.Show.Deriving (deriveShow1)
36
28
37
29
38type family CRepr (s :: Schema) :: Type where
30type family CRepr (s :: Schema) :: Type where
39− CRepr (SchemaText cs) = TextConstraint
31+ CRepr ('SchemaText cs) = TextConstraint
40− CRepr (SchemaNumber cs) = NumberConstraint
32+ CRepr ('SchemaNumber cs) = NumberConstraint
41− CRepr (SchemaObject fs) = (String, Schema)
33+ CRepr ('SchemaObject fs) = (String, Schema)
42− CRepr (SchemaArray ar s) = ArrayConstraint
34+ CRepr ('SchemaArray ar s) = ArrayConstraint
43
35
44data TextConstraint
36data TextConstraint
45 = TEq Nat
37 = TEq Nat
@@ -49,19 +41,19 @@ data TextConstraint
49 deriving (Generic)
41 deriving (Generic)
50
42
51data instance Sing (tc :: TextConstraint) where
43data instance Sing (tc :: TextConstraint) where
52− STEq :: Sing n -> Sing (TEq n)
44+ STEq :: Sing n -> Sing ('TEq n)
53− STLe :: Sing n -> Sing (TLe n)
45+ STLe :: Sing n -> Sing ('TLe n)
54− STGt :: Sing n -> Sing (TGt n)
46+ STGt :: Sing n -> Sing ('TGt n)
55− STRegex :: Sing s -> Sing (TRegex s)
47+ STRegex :: Sing s -> Sing ('TRegex s)
56
48
57−instance Known (Sing n) => Known (Sing (TEq n)) where known = STEq known
49+instance Known (Sing n) => Known (Sing ('TEq n)) where known = STEq known
58−instance Known (Sing n) => Known (Sing (TGt n)) where known = STGt known
50+instance Known (Sing n) => Known (Sing ('TGt n)) where known = STGt known
59−instance Known (Sing n) => Known (Sing (TLe n)) where known = STLe known
51+instance Known (Sing n) => Known (Sing ('TLe n)) where known = STLe known
60−instance Known (Sing s) => Known (Sing (TRegex s)) where known = STRegex known
52+instance Known (Sing s) => Known (Sing ('TRegex s)) where known = STRegex known
61
53
62−instance Eq (Sing (TEq n)) where a == b = True
54+instance Eq (Sing ('TEq n)) where _ == _ = True
63−instance Eq (Sing (TLe n)) where a == b = True
55+instance Eq (Sing ('TLe n)) where _ == _ = True
64−instance Eq (Sing (TGt n)) where a == b = True
56+instance Eq (Sing ('TGt n)) where _ == _ = True
65
57
66data NumberConstraint
58data NumberConstraint
67 = NLe Nat
59 = NLe Nat
@@ -70,28 +62,28 @@ data NumberConstraint
70 deriving (Generic)
62 deriving (Generic)
71
63
72data instance Sing (nc :: NumberConstraint) where
64data instance Sing (nc :: NumberConstraint) where
73− SNEq :: Sing n -> Sing (NEq n)
65+ SNEq :: Sing n -> Sing ('NEq n)
74− SNGt :: Sing n -> Sing (NGt n)
66+ SNGt :: Sing n -> Sing ('NGt n)
75− SNLe :: Sing n -> Sing (NLe n)
67+ SNLe :: Sing n -> Sing ('NLe n)
76
68
77−instance Known (Sing n) => Known (Sing (NEq n)) where known = SNEq known
69+instance Known (Sing n) => Known (Sing ('NEq n)) where known = SNEq known
78−instance Known (Sing n) => Known (Sing (NGt n)) where known = SNGt known
70+instance Known (Sing n) => Known (Sing ('NGt n)) where known = SNGt known
79−instance Known (Sing n) => Known (Sing (NLe n)) where known = SNLe known
71+instance Known (Sing n) => Known (Sing ('NLe n)) where known = SNLe known
80
72
81−instance Eq (Sing (NEq n)) where a == b = True
73+instance Eq (Sing ('NEq n)) where _ == _ = True
82−instance Eq (Sing (NLe n)) where a == b = True
74+instance Eq (Sing ('NLe n)) where _ == _ = True
83−instance Eq (Sing (NGt n)) where a == b = True
75+instance Eq (Sing ('NGt n)) where _ == _ = True
84
76
85data ArrayConstraint
77data ArrayConstraint
86 = AEq Nat
78 = AEq Nat
87 deriving (Generic)
79 deriving (Generic)
88
80
89data instance Sing (ac :: ArrayConstraint) where
81data instance Sing (ac :: ArrayConstraint) where
90− SAEq :: Sing n -> Sing (AEq n)
82+ SAEq :: Sing n -> Sing ('AEq n)
91
83
92−instance Known (Sing n) => Known (Sing (AEq n)) where known = SAEq known
84+instance Known (Sing n) => Known (Sing ('AEq n)) where known = SAEq known
93
85
94−instance Eq (Sing (AEq n)) where a == b = True
86+instance Eq (Sing ('AEq n)) where _ == _ = True
95
87
96data Schema
88data Schema
97 = SchemaText [TextConstraint]
89 = SchemaText [TextConstraint]
@@ -103,32 +95,32 @@ data Schema
103 deriving (Generic)
95 deriving (Generic)
104
96
105data instance Sing (schema :: Schema) where
97data instance Sing (schema :: Schema) where
106− SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing (SchemaText tcs)
98+ SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing ('SchemaText tcs)
107− SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing (SchemaNumber ncs)
99+ SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing ('SchemaNumber ncs)
108− SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
100+ SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
109− SSchemaObject :: Known (Sing fields) => Sing fields -> Sing (SchemaObject fields)
101+ SSchemaObject :: Known (Sing fields) => Sing fields -> Sing ('SchemaObject fields)
110− SSchemaOptional :: Known (Sing s) => Sing s -> Sing (SchemaOptional s)
102+ SSchemaOptional :: Known (Sing s) => Sing s -> Sing ('SchemaOptional s)
111− SSchemaNull :: Sing SchemaNull
103+ SSchemaNull :: Sing 'SchemaNull
112−
104+
113−instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
105+instance Known (Sing sl) => Known (Sing ('SchemaText sl)) where
114 known = SSchemaText known
106 known = SSchemaText known
115−instance Known (Sing sl) => Known (Sing (SchemaNumber sl)) where
107+instance Known (Sing sl) => Known (Sing ('SchemaNumber sl)) where
116 known = SSchemaNumber known
108 known = SSchemaNumber known
117−instance Known (Sing SchemaNull) where
109+instance Known (Sing 'SchemaNull) where
118 known = SSchemaNull
110 known = SSchemaNull
119−instance (Known (Sing ac), Known (Sing s)) => Known (Sing (SchemaArray ac s)) where
111+instance (Known (Sing ac), Known (Sing s)) => Known (Sing ('SchemaArray ac s)) where
120 known = SSchemaArray known known
112 known = SSchemaArray known known
121−instance Known (Sing stl) => Known (Sing (SchemaObject stl)) where
113+instance Known (Sing stl) => Known (Sing ('SchemaObject stl)) where
122 known = SSchemaObject known
114 known = SSchemaObject known
123−instance Known (Sing s) => Known (Sing (SchemaOptional s)) where
115+instance Known (Sing s) => Known (Sing ('SchemaOptional s)) where
124 known = SSchemaOptional known
116 known = SSchemaOptional known
125
117
126−instance Eq (Sing (SchemaText cs)) where a == b = True
118+instance Eq (Sing ('SchemaText cs)) where _ == _ = True
127−instance Eq (Sing (SchemaNumber cs)) where a == b = True
119+instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
128−instance Eq (Sing SchemaNull) where a == b = True
120+instance Eq (Sing 'SchemaNull) where _ == _ = True
129−instance Eq (Sing (SchemaArray as s)) where a == b = True
121+instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
130−instance Eq (Sing (SchemaObject cs)) where a == b = True
122+instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
131−instance Eq (Sing (SchemaOptional s)) where a == b = True
123+instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
132
124
133data FieldRepr :: (Symbol, Schema) -> Type where
125data FieldRepr :: (Symbol, Schema) -> Type where
134 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
126 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
@@ -149,74 +141,74 @@ instance
149 series = FieldRepr <$> series
141 series = FieldRepr <$> series
150
142
151data JsonRepr :: Schema -> Type where
143data JsonRepr :: Schema -> Type where
152− ReprText :: Text -> JsonRepr (SchemaText cs)
144+ ReprText :: Text -> JsonRepr ('SchemaText cs)
153− ReprNumber :: Scientific -> JsonRepr (SchemaNumber cs)
145+ ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
154− ReprNull :: JsonRepr SchemaNull
146+ ReprNull :: JsonRepr 'SchemaNull
155− ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
147+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
156− ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
148+ ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
157− ReprOptional :: Maybe (JsonRepr s) -> JsonRepr (SchemaOptional s)
149+ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
158−
150+
159−instance Show (JsonRepr (SchemaText cs)) where
151+instance Show (JsonRepr ('SchemaText cs)) where
160 show (ReprText t) = "ReprText " P.++ show t
152 show (ReprText t) = "ReprText " P.++ show t
161
153
162−instance Show (JsonRepr (SchemaNumber cs)) where
154+instance Show (JsonRepr ('SchemaNumber cs)) where
163 show (ReprNumber n) = "ReprNumber " P.++ show n
155 show (ReprNumber n) = "ReprNumber " P.++ show n
164
156
165−instance Show (JsonRepr SchemaNull) where show _ = "ReprNull"
157+instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
166
158
167−instance Show (JsonRepr s) => Show (JsonRepr (SchemaArray acs s)) where
159+instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
168 show (ReprArray v) = "ReprArray " P.++ show v
160 show (ReprArray v) = "ReprArray " P.++ show v
169
161
170−instance RecAll FieldRepr fs Show => Show (JsonRepr (SchemaObject fs)) where
162+instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
171 show (ReprObject fs) = "ReprObject " P.++ show fs
163 show (ReprObject fs) = "ReprObject " P.++ show fs
172
164
173−instance Show (JsonRepr s) => Show (JsonRepr (SchemaOptional s)) where
165+instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
174 show (ReprOptional s) = "ReprOptional " P.++ show s
166 show (ReprOptional s) = "ReprOptional " P.++ show s
175
167
176instance (Monad m, Serial m Text)
168instance (Monad m, Serial m Text)
177− => Serial m (JsonRepr (SchemaText cs)) where
169+ => Serial m (JsonRepr ('SchemaText cs)) where
178 series = cons1 ReprText
170 series = cons1 ReprText
179
171
180instance (Monad m, Serial m Scientific)
172instance (Monad m, Serial m Scientific)
181− => Serial m (JsonRepr (SchemaNumber cs)) where
173+ => Serial m (JsonRepr ('SchemaNumber cs)) where
182 series = cons1 ReprNumber
174 series = cons1 ReprNumber
183
175
184−instance Monad m => Serial m (JsonRepr SchemaNull) where
176+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
185 series = cons0 ReprNull
177 series = cons0 ReprNull
186
178
187instance (Serial m (V.Vector (JsonRepr s)))
179instance (Serial m (V.Vector (JsonRepr s)))
188− => Serial m (JsonRepr (SchemaArray cs s)) where
180+ => Serial m (JsonRepr ('SchemaArray cs s)) where
189 series = cons1 ReprArray
181 series = cons1 ReprArray
190
182
191instance (Serial m (JsonRepr s))
183instance (Serial m (JsonRepr s))
192− => Serial m (JsonRepr (SchemaOptional s)) where
184+ => Serial m (JsonRepr ('SchemaOptional s)) where
193 series = cons1 ReprOptional
185 series = cons1 ReprOptional
194
186
195instance (Monad m, Serial m (Rec FieldRepr fs))
187instance (Monad m, Serial m (Rec FieldRepr fs))
196− => Serial m (JsonRepr (SchemaObject fs)) where
188+ => Serial m (JsonRepr ('SchemaObject fs)) where
197 series = cons1 ReprObject
189 series = cons1 ReprObject
198
190
199−instance Eq (Rec FieldRepr fs) => Eq (JsonRepr (SchemaObject fs)) where
191+instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
200 ReprObject a == ReprObject b = a == b
192 ReprObject a == ReprObject b = a == b
201
193
202−instance Eq (JsonRepr (SchemaText cs)) where
194+instance Eq (JsonRepr ('SchemaText cs)) where
203 ReprText a == ReprText b = a == b
195 ReprText a == ReprText b = a == b
204
196
205−instance Eq (JsonRepr (SchemaNumber cs)) where
197+instance Eq (JsonRepr ('SchemaNumber cs)) where
206 ReprNumber a == ReprNumber b = a == b
198 ReprNumber a == ReprNumber b = a == b
207
199
208−instance Eq (JsonRepr SchemaNull) where
200+instance Eq (JsonRepr 'SchemaNull) where
209 ReprNull == ReprNull = True
201 ReprNull == ReprNull = True
210
202
211−instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
203+instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
212 ReprArray a == ReprArray b = a == b
204 ReprArray a == ReprArray b = a == b
213
205
214−instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaOptional s)) where
206+instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
215 ReprOptional a == ReprOptional b = a == b
207 ReprOptional a == ReprOptional b = a == b
216
208
217fromOptional
209fromOptional
218 :: (Known (Sing s))
210 :: (Known (Sing s))
219− => Sing (SchemaOptional s)
211+ => Sing ('SchemaOptional s)
220 -> J.Value
212 -> J.Value
221 -> Parser (Maybe (JsonRepr s))
213 -> Parser (Maybe (JsonRepr s))
222fromOptional _ = parseJSON
214fromOptional _ = parseJSON
@@ -229,11 +221,11 @@ instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
229 J.Null -> pure ReprNull
221 J.Null -> pure ReprNull
230 _ -> typeMismatch "Null" value
222 _ -> typeMismatch "Null" value
231 so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value
223 so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value
232− SSchemaArray c s -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
224+ SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value
233 SSchemaObject fs -> do
225 SSchemaObject fs -> do
234 let
226 let
235 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
227 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
236− demoteFields SNil h = pure RNil
228+ demoteFields SNil _ = pure RNil
237 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
229 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
238 let fieldName = T.pack $ symbolVal (Proxy @fn)
230 let fieldName = T.pack $ symbolVal (Proxy @fn)
239 fieldRepr <- case s of
231 fieldRepr <- case s of
@@ -252,7 +244,7 @@ instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
252 SSchemaObject _ -> case H.lookup fieldName h of
244 SSchemaObject _ -> case H.lookup fieldName h of
253 Just v -> FieldRepr <$> parseJSON v
245 Just v -> FieldRepr <$> parseJSON v
254 Nothing -> fail "schemaobject"
246 Nothing -> fail "schemaobject"
255− SSchemaOptional s -> case H.lookup fieldName h of
247+ SSchemaOptional _ -> case H.lookup fieldName h of
256 Just v -> FieldRepr <$> parseJSON v
248 Just v -> FieldRepr <$> parseJSON v
257 Nothing -> fail "schemaoptional"
249 Nothing -> fail "schemaoptional"
258 (fieldRepr :&) <$> demoteFields tl h
250 (fieldRepr :&) <$> demoteFields tl h
@@ -275,11 +267,11 @@ instance J.ToJSON (JsonRepr a) where
275 fold :: Rec FieldRepr fs -> [(Text, J.Value)]
267 fold :: Rec FieldRepr fs -> [(Text, J.Value)]
276 fold = \case
268 fold = \case
277 RNil -> []
269 RNil -> []
278− fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
270+ fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
279
271
280class FalseConstraint
272class FalseConstraint
281
273
282type family TopLevel (spec :: Schema) :: Constraint where
274type family TopLevel (spec :: Schema) :: Constraint where
283− TopLevel (SchemaArray a e) = ()
275+ TopLevel ('SchemaArray a e) = ()
284− TopLevel (SchemaObject o) = ()
276+ TopLevel ('SchemaObject o) = ()
285 TopLevel spec = FalseConstraint
277 TopLevel spec = FalseConstraint
src/Data/Schematic/Utils.hs+3−1
@@ -2,7 +2,6 @@
2
2
3module Data.Schematic.Utils where
3module Data.Schematic.Utils where
4
4
5−import Data.Kind
6import Data.Proxy
5import Data.Proxy
7import Data.Singletons
6import Data.Singletons
8import Data.Singletons.Prelude
7import Data.Singletons.Prelude
@@ -13,6 +12,9 @@ import Data.Vinyl hiding (Dict)
13class Known a where
12class Known a where
14 known :: a
13 known :: a
15
14
15+instance Known (Proxy a) where
16+ known = Proxy
17+
16instance KnownNat n => Known (Sing n) where
18instance KnownNat n => Known (Sing n) where
17 known = SNat
19 known = SNat
18
20