@@ -6,40 +6,32 @@
66module Data.Schematic.Schema where
77
88import Control.Applicative
9−import Control.Category ((<<<), (>>>))
109import Control.Monad
11−import Control.Monad.Validation
1210import Data.Aeson as J
1311import Data.Aeson.Types as J
14−import Data.Eq.Deriving (deriveEq1)
15−import Data.Foldable as F
16−import Data.Functor.Classes
1712import Data.HashMap.Strict as H
1813import Data.Kind
1914import Data.Maybe
20−import Data.Schematic.Instances
15+import Data.Schematic.Instances ()
2116import Data.Schematic.Utils
2217import Data.Scientific
23−import Data.Singletons.Decide
2418import Data.Singletons.Prelude.List
2519import Data.Singletons.TH
2620import Data.Singletons.TypeLits
2721import Data.Text as T
2822import Data.Vector as V
2923import Data.Vinyl hiding (Dict)
30−import Data.Vinyl.Functor
3124import Data.Vinyl.TypeLevel hiding (Nat)
3225import GHC.Generics (Generic)
3326import Prelude as P
3427import Test.SmallCheck.Series
35−import Text.Show.Deriving (deriveShow1)
3628
3729
3830type family CRepr (s :: Schema) :: Type where
39− CRepr (SchemaText cs) = TextConstraint
40− CRepr (SchemaNumber cs) = NumberConstraint
41− CRepr (SchemaObject fs) = (String, Schema)
42− CRepr (SchemaArray ar s) = ArrayConstraint
31+ CRepr ('SchemaText cs) = TextConstraint
32+ CRepr ('SchemaNumber cs) = NumberConstraint
33+ CRepr ('SchemaObject fs) = (String, Schema)
34+ CRepr ('SchemaArray ar s) = ArrayConstraint
4335
4436data TextConstraint
4537 = TEq Nat
@@ -49,19 +41,19 @@ data TextConstraint
4941 deriving (Generic)
5042
5143data instance Sing (tc :: TextConstraint) where
52− STEq :: Sing n -> Sing (TEq n)
53− STLe :: Sing n -> Sing (TLe n)
54− STGt :: Sing n -> Sing (TGt n)
55− STRegex :: Sing s -> Sing (TRegex s)
44+ STEq :: Sing n -> Sing ('TEq n)
45+ STLe :: Sing n -> Sing ('TLe n)
46+ STGt :: Sing n -> Sing ('TGt n)
47+ STRegex :: Sing s -> Sing ('TRegex s)
5648
57−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
59−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
49+instance Known (Sing n) => Known (Sing ('TEq n)) where known = STEq known
50+instance Known (Sing n) => Known (Sing ('TGt n)) where known = STGt known
51+instance Known (Sing n) => Known (Sing ('TLe n)) where known = STLe known
52+instance Known (Sing s) => Known (Sing ('TRegex s)) where known = STRegex known
6153
62−instance Eq (Sing (TEq n)) where a == b = True
63−instance Eq (Sing (TLe n)) where a == b = True
64−instance Eq (Sing (TGt n)) where a == b = True
54+instance Eq (Sing ('TEq n)) where _ == _ = True
55+instance Eq (Sing ('TLe n)) where _ == _ = True
56+instance Eq (Sing ('TGt n)) where _ == _ = True
6557
6658data NumberConstraint
6759 = NLe Nat
@@ -70,28 +62,28 @@ data NumberConstraint
7062 deriving (Generic)
7163
7264data instance Sing (nc :: NumberConstraint) where
73− SNEq :: Sing n -> Sing (NEq n)
74− SNGt :: Sing n -> Sing (NGt n)
75− SNLe :: Sing n -> Sing (NLe n)
65+ SNEq :: Sing n -> Sing ('NEq n)
66+ SNGt :: Sing n -> Sing ('NGt n)
67+ SNLe :: Sing n -> Sing ('NLe n)
7668
77−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
79−instance Known (Sing n) => Known (Sing (NLe n)) where known = SNLe known
69+instance Known (Sing n) => Known (Sing ('NEq n)) where known = SNEq known
70+instance Known (Sing n) => Known (Sing ('NGt n)) where known = SNGt known
71+instance Known (Sing n) => Known (Sing ('NLe n)) where known = SNLe known
8072
81−instance Eq (Sing (NEq n)) where a == b = True
82−instance Eq (Sing (NLe n)) where a == b = True
83−instance Eq (Sing (NGt n)) where a == b = True
73+instance Eq (Sing ('NEq n)) where _ == _ = True
74+instance Eq (Sing ('NLe n)) where _ == _ = True
75+instance Eq (Sing ('NGt n)) where _ == _ = True
8476
8577data ArrayConstraint
8678 = AEq Nat
8779 deriving (Generic)
8880
8981data instance Sing (ac :: ArrayConstraint) where
90− SAEq :: Sing n -> Sing (AEq n)
82+ SAEq :: Sing n -> Sing ('AEq n)
9183
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
9385
94−instance Eq (Sing (AEq n)) where a == b = True
86+instance Eq (Sing ('AEq n)) where _ == _ = True
9587
9688data Schema
9789 = SchemaText [TextConstraint]
@@ -103,32 +95,32 @@ data Schema
10395 deriving (Generic)
10496
10597data instance Sing (schema :: Schema) where
106− SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing (SchemaText tcs)
107− 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)
109− SSchemaObject :: Known (Sing fields) => Sing fields -> Sing (SchemaObject fields)
110− SSchemaOptional :: Known (Sing s) => Sing s -> Sing (SchemaOptional s)
111− SSchemaNull :: Sing SchemaNull
112−
113−instance Known (Sing sl) => Known (Sing (SchemaText sl)) where
98+ SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing ('SchemaText tcs)
99+ SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing ('SchemaNumber ncs)
100+ SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema)
101+ SSchemaObject :: Known (Sing fields) => Sing fields -> Sing ('SchemaObject fields)
102+ SSchemaOptional :: Known (Sing s) => Sing s -> Sing ('SchemaOptional s)
103+ SSchemaNull :: Sing 'SchemaNull
104+
105+instance Known (Sing sl) => Known (Sing ('SchemaText sl)) where
114106 known = SSchemaText known
115−instance Known (Sing sl) => Known (Sing (SchemaNumber sl)) where
107+instance Known (Sing sl) => Known (Sing ('SchemaNumber sl)) where
116108 known = SSchemaNumber known
117−instance Known (Sing SchemaNull) where
109+instance Known (Sing 'SchemaNull) where
118110 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
120112 known = SSchemaArray known known
121−instance Known (Sing stl) => Known (Sing (SchemaObject stl)) where
113+instance Known (Sing stl) => Known (Sing ('SchemaObject stl)) where
122114 known = SSchemaObject known
123−instance Known (Sing s) => Known (Sing (SchemaOptional s)) where
115+instance Known (Sing s) => Known (Sing ('SchemaOptional s)) where
124116 known = SSchemaOptional known
125117
126−instance Eq (Sing (SchemaText cs)) where a == b = True
127−instance Eq (Sing (SchemaNumber cs)) where a == b = True
128−instance Eq (Sing SchemaNull) where a == b = True
129−instance Eq (Sing (SchemaArray as s)) where a == b = True
130−instance Eq (Sing (SchemaObject cs)) where a == b = True
131−instance Eq (Sing (SchemaOptional s)) where a == b = True
118+instance Eq (Sing ('SchemaText cs)) where _ == _ = True
119+instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True
120+instance Eq (Sing 'SchemaNull) where _ == _ = True
121+instance Eq (Sing ('SchemaArray as s)) where _ == _ = True
122+instance Eq (Sing ('SchemaObject cs)) where _ == _ = True
123+instance Eq (Sing ('SchemaOptional s)) where _ == _ = True
132124
133125data FieldRepr :: (Symbol, Schema) -> Type where
134126 FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
@@ -149,74 +141,74 @@ instance
149141 series = FieldRepr <$> series
150142
151143data JsonRepr :: Schema -> Type where
152− ReprText :: Text -> JsonRepr (SchemaText cs)
153− ReprNumber :: Scientific -> JsonRepr (SchemaNumber cs)
154− ReprNull :: JsonRepr SchemaNull
155− ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
156− ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
157− ReprOptional :: Maybe (JsonRepr s) -> JsonRepr (SchemaOptional s)
158−
159−instance Show (JsonRepr (SchemaText cs)) where
144+ ReprText :: Text -> JsonRepr ('SchemaText cs)
145+ ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
146+ ReprNull :: JsonRepr 'SchemaNull
147+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
148+ ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
149+ ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
150+
151+instance Show (JsonRepr ('SchemaText cs)) where
160152 show (ReprText t) = "ReprText " P.++ show t
161153
162−instance Show (JsonRepr (SchemaNumber cs)) where
154+instance Show (JsonRepr ('SchemaNumber cs)) where
163155 show (ReprNumber n) = "ReprNumber " P.++ show n
164156
165−instance Show (JsonRepr SchemaNull) where show _ = "ReprNull"
157+instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
166158
167−instance Show (JsonRepr s) => Show (JsonRepr (SchemaArray acs s)) where
159+instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
168160 show (ReprArray v) = "ReprArray " P.++ show v
169161
170−instance RecAll FieldRepr fs Show => Show (JsonRepr (SchemaObject fs)) where
162+instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
171163 show (ReprObject fs) = "ReprObject " P.++ show fs
172164
173−instance Show (JsonRepr s) => Show (JsonRepr (SchemaOptional s)) where
165+instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
174166 show (ReprOptional s) = "ReprOptional " P.++ show s
175167
176168instance (Monad m, Serial m Text)
177− => Serial m (JsonRepr (SchemaText cs)) where
169+ => Serial m (JsonRepr ('SchemaText cs)) where
178170 series = cons1 ReprText
179171
180172instance (Monad m, Serial m Scientific)
181− => Serial m (JsonRepr (SchemaNumber cs)) where
173+ => Serial m (JsonRepr ('SchemaNumber cs)) where
182174 series = cons1 ReprNumber
183175
184−instance Monad m => Serial m (JsonRepr SchemaNull) where
176+instance Monad m => Serial m (JsonRepr 'SchemaNull) where
185177 series = cons0 ReprNull
186178
187179instance (Serial m (V.Vector (JsonRepr s)))
188− => Serial m (JsonRepr (SchemaArray cs s)) where
180+ => Serial m (JsonRepr ('SchemaArray cs s)) where
189181 series = cons1 ReprArray
190182
191183instance (Serial m (JsonRepr s))
192− => Serial m (JsonRepr (SchemaOptional s)) where
184+ => Serial m (JsonRepr ('SchemaOptional s)) where
193185 series = cons1 ReprOptional
194186
195187instance (Monad m, Serial m (Rec FieldRepr fs))
196− => Serial m (JsonRepr (SchemaObject fs)) where
188+ => Serial m (JsonRepr ('SchemaObject fs)) where
197189 series = cons1 ReprObject
198190
199−instance Eq (Rec FieldRepr fs) => Eq (JsonRepr (SchemaObject fs)) where
191+instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
200192 ReprObject a == ReprObject b = a == b
201193
202−instance Eq (JsonRepr (SchemaText cs)) where
194+instance Eq (JsonRepr ('SchemaText cs)) where
203195 ReprText a == ReprText b = a == b
204196
205−instance Eq (JsonRepr (SchemaNumber cs)) where
197+instance Eq (JsonRepr ('SchemaNumber cs)) where
206198 ReprNumber a == ReprNumber b = a == b
207199
208−instance Eq (JsonRepr SchemaNull) where
200+instance Eq (JsonRepr 'SchemaNull) where
209201 ReprNull == ReprNull = True
210202
211−instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
203+instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
212204 ReprArray a == ReprArray b = a == b
213205
214−instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaOptional s)) where
206+instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
215207 ReprOptional a == ReprOptional b = a == b
216208
217209fromOptional
218210 :: (Known (Sing s))
219− => Sing (SchemaOptional s)
211+ => Sing ('SchemaOptional s)
220212 -> J.Value
221213 -> Parser (Maybe (JsonRepr s))
222214fromOptional _ = parseJSON
@@ -229,11 +221,11 @@ instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
229221 J.Null -> pure ReprNull
230222 _ -> typeMismatch "Null" value
231223 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
233225 SSchemaObject fs -> do
234226 let
235227 demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s)
236− demoteFields SNil h = pure RNil
228+ demoteFields SNil _ = pure RNil
237229 demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
238230 let fieldName = T.pack $ symbolVal (Proxy @fn)
239231 fieldRepr <- case s of
@@ -252,7 +244,7 @@ instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where
252244 SSchemaObject _ -> case H.lookup fieldName h of
253245 Just v -> FieldRepr <$> parseJSON v
254246 Nothing -> fail "schemaobject"
255− SSchemaOptional s -> case H.lookup fieldName h of
247+ SSchemaOptional _ -> case H.lookup fieldName h of
256248 Just v -> FieldRepr <$> parseJSON v
257249 Nothing -> fail "schemaoptional"
258250 (fieldRepr :&) <$> demoteFields tl h
@@ -275,11 +267,11 @@ instance J.ToJSON (JsonRepr a) where
275267 fold :: Rec FieldRepr fs -> [(Text, J.Value)]
276268 fold = \case
277269 RNil -> []
278− fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
270+ fr@(FieldRepr _) :& tl -> (extract fr) : fold tl
279271
280272class FalseConstraint
281273
282274type family TopLevel (spec :: Schema) :: Constraint where
283− TopLevel (SchemaArray a e) = ()
284− TopLevel (SchemaObject o) = ()
275+ TopLevel ('SchemaArray a e) = ()
276+ TopLevel ('SchemaObject o) = ()
285277 TopLevel spec = FalseConstraint