git.iko.soy/schematic
on master help sign in
WIP
afb03edDenis Redozubov
src/Data/Schematic/DSL.hs+7−3
compare with master
unifiedsplit
@@ -2,6 +2,7 @@
2
2
3module Data.Schematic.DSL where
3module Data.Schematic.DSL where
4
4
5+import Data.Coerce
5import Data.Kind
6import Data.Kind
6import Data.Schematic.Lens
7import Data.Schematic.Lens
7import Data.Schematic.Schema
8import Data.Schematic.Schema
@@ -66,12 +67,15 @@ type family FieldsOf (s :: Schema) :: [(Symbol, Schema)] where
66 FieldsOf ('SchemaObject fs) = fs
67 FieldsOf ('SchemaObject fs) = fs
67
68
68type FieldConstructor fn =
69type FieldConstructor fn =
70+ forall fs rty ty
71+ . ( Coercible rty ty
72+ , rty ~ Repr (ByField fn fs (FIndex fn fs))
69− forall fs. (Representable (ByField fn fs (FIndex fn fs)))
73+ , Representable (ByField fn fs (FIndex fn fs)) )
70− => Repr (ByField fn fs (FIndex fn fs))
74+ => ty
71 -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))
75 -> (Tagged fs :. FieldRepr) '(fn, (ByField fn fs (FIndex fn fs)))
72
76
73field :: forall fn. KnownSymbol fn => FieldConstructor fn
77field :: forall fn. KnownSymbol fn => FieldConstructor fn
74−field = Compose . Tagged . constructField (sing :: Sing fn) Proxy
78+field = Compose . Tagged . constructField (sing :: Sing fn) Proxy . coerce
75
79
76type family Repr (s :: Schema) = (ty :: Type) where
80type family Repr (s :: Schema) = (ty :: Type) where
77 Repr ('SchemaObject so) = Rec FieldRepr so
81 Repr ('SchemaObject so) = Rec FieldRepr so
src/Data/Schematic/Schema.hs+99−55
@@ -9,6 +9,7 @@ import Control.Applicative ((<|>))
9import Control.Monad
9import Control.Monad
10import Data.Aeson as J
10import Data.Aeson as J
11import Data.Aeson.Types as J
11import Data.Aeson.Types as J
12+import Data.Coerce
12import Data.HashMap.Strict as H
13import Data.HashMap.Strict as H
13import Data.Kind
14import Data.Kind
14import Data.Maybe
15import Data.Maybe
@@ -324,79 +325,122 @@ type family USubsets (u :: [k]) :: Constraint where
324 USubsets '[] = ()
325 USubsets '[] = ()
325 USubsets (h ': tl) = (USubset tl (h ': tl) (V.RImage tl (h ': tl)), USubsets tl)
326 USubsets (h ': tl) = (USubset tl (h ': tl) (V.RImage tl (h ': tl)), USubsets tl)
326
327
328+class JsonRepresentable (schema :: Schema) where
329+ type ReprType schema :: *
330+ data JsonRepr schema :: *
331+ wrap :: ReprType schema -> JsonRepr schema
332+
333+instance JsonRepresentable ('SchemaText cs) where
334+ type ReprType ('SchemaText cs) = Text
335+ newtype JsonRepr ('SchemaText cs) = ReprText (ReprType ('SchemaText cs))
336+ wrap = ReprText
337+
338+instance JsonRepresentable ('SchemaNumber cs) where
339+ type ReprType ('SchemaNumber cs) = Scientific
340+ newtype JsonRepr ('SchemaNumber cs) = ReprNumber (ReprType ('SchemaNumber cs))
341+ wrap = ReprNumber
342+
343+instance JsonRepresentable 'SchemaBoolean where
344+ type ReprType 'SchemaBoolean = Bool
345+ newtype JsonRepr 'SchemaBoolean = ReprBoolean (ReprType 'SchemaBoolean)
346+ wrap = ReprBoolean
347+
348+instance JsonRepresentable 'SchemaNull where
349+ type ReprType 'SchemaNull = ()
350+ newtype JsonRepr 'SchemaNull = ReprNull (ReprType 'SchemaNull)
351+ wrap = ReprNull
352+
353+instance JsonRepresentable s => JsonRepresentable ('SchemaArray cs s) where
354+ type ReprType ('SchemaArray cs s) = V.Vector (JsonRepr s)
355+ newtype JsonRepr ('SchemaArray cs s) = ReprArray (ReprType ('SchemaArray cs s))
356+ wrap = ReprArray
357+
358+instance JsonRepresentable ('SchemaObject fs) where
359+ type ReprType ('SchemaObject fs) = Rec FieldRepr fs
360+ newtype JsonRepr ('SchemaObject fs) = ReprObject (ReprType ('SchemaObject fs))
361+ wrap = ReprObject
362+
363+instance JsonRepresentable s => JsonRepresentable ('SchemaOptional s) where
364+ type ReprType ('SchemaOptional s) = Maybe (JsonRepr s)
365+ newtype JsonRepr ('SchemaOptional s) = ReprOptional (ReprType ('SchemaOptional s))
366+ wrap = ReprOptional
367+
368+instance JsonRepresentable ('SchemaUnion (h ': tl)) where
369+ type ReprType ('SchemaUnion (h ': tl)) = Union JsonRepr (h ': tl)
370+ newtype JsonRepr ('SchemaUnion (h ': tl)) = ReprUnion (ReprType ('SchemaUnion (h ': tl)))
371+ wrap = ReprUnion
372+
327−data JsonRepr :: Schema -> Type where
373+-- data JsonRepr :: Schema -> Type where
328− ReprText :: Text -> JsonRepr ('SchemaText cs)
374+-- ReprText :: Text -> JsonRepr ('SchemaText cs)
329− ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
375+-- ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs)
330− ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
376+-- ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean
331− ReprNull :: JsonRepr 'SchemaNull
377+-- ReprNull :: JsonRepr 'SchemaNull
332− ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
378+-- ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s)
333− ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
379+-- ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs)
334− ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
380+-- ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s)
335− ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
381+-- ReprUnion :: Union JsonRepr (h ': tl) -> JsonRepr ('SchemaUnion (h ': tl))
336
382
337-- | Move to the union package
383-- | Move to the union package
338−instance Show (JsonRepr ('SchemaText cs)) where
384+-- instance Show (JsonRepr ('SchemaText cs)) where
339− show (ReprText t) = "ReprText " P.++ show t
385+-- show (ReprText t) = "ReprText " P.++ show t
340
386
341−instance Show (JsonRepr ('SchemaNumber cs)) where
387+-- instance Show (JsonRepr ('SchemaNumber cs)) where
342− show (ReprNumber n) = "ReprNumber " P.++ show n
388+-- show (ReprNumber n) = "ReprNumber " P.++ show n
343
389
344−instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
390+-- instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull"
345
391
346−instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
392+-- instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where
347− show (ReprArray v) = "ReprArray " P.++ show v
393+-- show (ReprArray v) = "ReprArray " P.++ show v
348
394
349−instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
395+-- instance V.RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where
350− show (ReprObject fs) = "ReprObject " P.++ show fs
396+-- show (ReprObject fs) = "ReprObject " P.++ show fs
351
397
352−instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
398+-- instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where
353− show (ReprOptional s) = "ReprOptional " P.++ show s
399+-- show (ReprOptional s) = "ReprOptional " P.++ show s
354
400
355−instance (Monad m, Serial m Text)
401+-- instance (Monad m, Serial m Text)
356− => Serial m (JsonRepr ('SchemaText cs)) where
402+-- => Serial m (JsonRepr ('SchemaText cs)) where
357− series = cons1 ReprText
403+-- series = cons1 ReprText
358
404
359−instance (Monad m, Serial m Scientific)
405+-- instance (Monad m, Serial m Scientific)
360− => Serial m (JsonRepr ('SchemaNumber cs)) where
406+-- => Serial m (JsonRepr ('SchemaNumber cs)) where
361− series = cons1 ReprNumber
407+-- series = cons1 ReprNumber
362
408
363−instance Monad m => Serial m (JsonRepr 'SchemaNull) where
409+-- instance Monad m => Serial m (JsonRepr 'SchemaNull) where
364− series = cons0 ReprNull
410+-- series = cons0 ReprNull
365
411
366−instance (Serial m (V.Vector (JsonRepr s)))
412+-- instance (Serial m (V.Vector (JsonRepr s)))
367− => Serial m (JsonRepr ('SchemaArray cs s)) where
413+-- => Serial m (JsonRepr ('SchemaArray cs s)) where
368− series = cons1 ReprArray
414+-- series = cons1 ReprArray
369
415
370−instance (Serial m (JsonRepr s))
416+-- instance (Serial m (JsonRepr s))
371− => Serial m (JsonRepr ('SchemaOptional s)) where
417+-- => Serial m (JsonRepr ('SchemaOptional s)) where
372− series = cons1 ReprOptional
418+-- series = cons1 ReprOptional
373
419
374−instance (Monad m, Serial m (Rec FieldRepr fs))
420+-- instance (Monad m, Serial m (Rec FieldRepr fs))
375− => Serial m (JsonRepr ('SchemaObject fs)) where
421+-- => Serial m (JsonRepr ('SchemaObject fs)) where
376− series = cons1 ReprObject
422+-- series = cons1 ReprObject
377
423
378−instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
424+-- instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where
379− ReprObject a == ReprObject b = a == b
425+-- ReprObject a == ReprObject b = a == b
380
426
381−instance Eq (JsonRepr ('SchemaText cs)) where
427+-- instance Eq (JsonRepr ('SchemaText cs))
382− ReprText a == ReprText b = a == b
383
428
384−instance Eq (JsonRepr ('SchemaNumber cs)) where
429+-- instance Eq (JsonRepr ('SchemaNumber cs))
385− ReprNumber a == ReprNumber b = a == b
386
430
387−instance Eq (JsonRepr 'SchemaNull) where
431+-- instance Eq (JsonRepr 'SchemaNull) where
388− ReprNull == ReprNull = True
432+-- ReprNull == ReprNull = True
389
433
390−instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
434+-- instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where
391− ReprArray a == ReprArray b = a == b
435+-- ReprArray a == ReprArray b = a == b
392
436
393−instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
437+-- instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where
394− ReprOptional a == ReprOptional b = a == b
438+-- ReprOptional a == ReprOptional b = a == b
395
439
396instance IsList (JsonRepr ('SchemaArray cs s)) where
440instance IsList (JsonRepr ('SchemaArray cs s)) where
397 type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s
441 type Item (JsonRepr ('SchemaArray cs s)) = JsonRepr s
398− fromList = ReprArray . GHC.Exts.fromList
442+ fromList = GHC.Exts.fromList
399− toList (ReprArray v) = GHC.Exts.toList v
443+ toList v = GHC.Exts.toList v
400
444
401instance Num (JsonRepr ('SchemaNumber cs)) where
445instance Num (JsonRepr ('SchemaNumber cs)) where
402 ReprNumber a + ReprNumber b = ReprNumber $ a + b
446 ReprNumber a + ReprNumber b = ReprNumber $ a + b
@@ -407,7 +451,7 @@ instance Num (JsonRepr ('SchemaNumber cs)) where
407 fromInteger = ReprNumber . fromIntegral
451 fromInteger = ReprNumber . fromIntegral
408
452
409instance IsString (JsonRepr ('SchemaText cs)) where
453instance IsString (JsonRepr ('SchemaText cs)) where
410− fromString = ReprText . fromString
454+ fromString = fromString
411
455
412fromOptional
456fromOptional
413 :: SingI s
457 :: SingI s
@@ -440,7 +484,7 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where
440 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
484 SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
441 SSchemaBoolean -> ReprBoolean <$> parseJSON value
485 SSchemaBoolean -> ReprBoolean <$> parseJSON value
442 SSchemaNull -> case value of
486 SSchemaNull -> case value of
443− J.Null -> pure ReprNull
487+ J.Null -> pure (wrap ())
444 _ -> typeMismatch "Null" value
488 _ -> typeMismatch "Null" value
445 so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value
489 so@(SSchemaOptional s) -> withSingI s $ ReprOptional <$> fromOptional so value
446 SSchemaArray sa sb -> withSingI sa $ withSingI sb
490 SSchemaArray sa sb -> withSingI sa $ withSingI sb
@@ -478,8 +522,8 @@ instance SingI schema => J.FromJSON (JsonRepr schema) where
478 ReprObject <$> withObject "Object" (demoteFields fs) value
522 ReprObject <$> withObject "Object" (demoteFields fs) value
479 SSchemaUnion ss -> parseUnion ss value
523 SSchemaUnion ss -> parseUnion ss value
480
524
481−instance J.ToJSON (JsonRepr a) where
525+instance J.ToJSON (JsonRepr schema) where
482− toJSON ReprNull = J.Null
526+ toJSON (ReprNull _) = J.Null
483 toJSON (ReprBoolean b) = J.Bool b
527 toJSON (ReprBoolean b) = J.Bool b
484 toJSON (ReprText t) = J.String t
528 toJSON (ReprText t) = J.String t
485 toJSON (ReprNumber n) = J.Number n
529 toJSON (ReprNumber n) = J.Number n