@@ -1,151 +1,179 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE InstanceSigs #-}
4−{-# LANGUAGE UndecidableInstances #-}
2+{-# LANGUAGE OverloadedLists #-}
3+{-# LANGUAGE OverloadedStrings #-}
54{-# OPTIONS_GHC -fprint-explicit-kinds #-}
65
76module Data.Schematic.Schema where
87
9−import Data.Functor.Foldable
10−import Data.Kind hiding (Type)
11−import Data.Proxy
12−import Data.Schematic.Validation
13−import Data.Text (Text)
14−import GHC.Generics
15−import GHC.TypeLits (KnownNat, natVal, KnownSymbol, symbolVal, Symbol, Nat)
16−
17−
18−type family JT (s :: k) :: JType where
19− JT (SNumber cs) = 'JNumber
20− JT (SText cs) = 'JText
21− JT (SObject els) = 'JObject
22− JT (SArray cs s) = 'JArray
23− JT (Field field ty cs) = JT ty
24−
25−class Constrained (ty :: JType) c where
26− cRep :: Proxy ty -> Proxy c -> CRepr ty
27−
28−-- Validators
29−
30−data LengthEqNat nat
31−
32−instance KnownNat nat => Constrained 'JText (LengthEqNat nat) where
33− cRep _ _ = LengthEq $ natVal (Proxy @nat)
34−
35−data Gt nat
36−
37−instance KnownNat nat => Constrained 'JNumber (Gt nat) where
38− cRep _ _ = Gt $ natVal (Proxy @nat)
39−
40−instance KnownNat nat => Constrained 'JArray (LengthEqNat nat) where
41− cRep _ _ = LengthArrEq $ natVal (Proxy @nat)
42−
43−-- /Validators
44−
45−data Field field ty schema
46−
47−data Empty
48−
49−class Verifiable ty cs where
50− schema :: Proxy ty -> Proxy cs -> [CRepr ty]
51−
52−instance
53− ( Constrained 'JText c
54− , Verifiable 'JText cs )
55− => Verifiable 'JText (c ': cs) where
56− schema _ _ = cRep (Proxy @'JText) (Proxy @c)
57− : schema (Proxy @'JText) (Proxy @cs)
8+import Control.Applicative
9+import Control.Category ((<<<), (>>>))
10+import Control.Monad
11+import Data.Aeson as J
12+import Data.Aeson.Types as J
13+import Data.Eq.Deriving (deriveEq1)
14+import Data.Foldable as F
15+import Data.Functor.Classes
16+import Data.HashMap.Strict as H
17+import Data.Kind
18+import Data.Maybe
19+import Data.Scientific
20+import Data.Singletons.Decide
21+import Data.Singletons.Prelude.List
22+import Data.Singletons.TH
23+import Data.Singletons.TypeLits
24+import Data.Text as T
25+import Data.Vector as V
26+import Data.Vinyl hiding (Dict)
27+import Data.Vinyl.Functor
28+import GHC.Generics (Generic)
29+import Test.SmallCheck.Series
30+import Text.Show.Deriving (deriveShow1)
31+
32+
33+type family CRepr (s :: Schema) :: Type where
34+ CRepr (SchemaText cs) = TextConstraint
35+ CRepr (SchemaNumber cs) = NumberConstraint
36+ CRepr (SchemaObject fs) = (String, Schema)
37+ CRepr (SchemaArray ar s) = ArrayConstraint
38+
39+data TextConstraint
40+ = TEq Nat
41+ | TLe Nat
42+ | TGt Nat
43+ | Regex Symbol
44+ deriving (Generic)
45+
46+data instance Sing (tc :: TextConstraint) where
47+ STextLengthEq :: Sing n -> Sing (TEq n)
48+ STextLengthLe :: Sing n -> Sing (TLe n)
49+ STextLengthGt :: Sing n -> Sing (TGt n)
50+
51+instance Eq (Sing (TEq n)) where a == b = True
52+instance Eq (Sing (TLe n)) where a == b = True
53+instance Eq (Sing (TGt n)) where a == b = True
54+
55+data NumberConstraint
56+ = NLe Nat
57+ | NGt Nat
58+ | NEq Nat
59+ deriving (Generic)
60+
61+data instance Sing (nc :: NumberConstraint) where
62+ SNumberEq :: Sing n -> Sing (NEq n)
63+ SNumberGt :: Sing n -> Sing (NGt n)
64+ SNumberLe :: Sing n -> Sing (NLe n)
65+
66+instance Eq (Sing (NEq n)) where a == b = True
67+instance Eq (Sing (NLe n)) where a == b = True
68+instance Eq (Sing (NGt n)) where a == b = True
69+
70+data ArrayConstraint
71+ = AEq Nat
72+ deriving (Generic)
73+
74+data instance Sing (ac :: ArrayConstraint) where
75+ SArrayEq :: Sing n -> Sing (AEq n)
76+
77+instance Eq (Sing (AEq n)) where a == b = True
78+
79+data Schema
80+ = SchemaText [TextConstraint]
81+ | SchemaNumber [NumberConstraint]
82+ | SchemaObject [(Symbol, Schema)]
83+ | SchemaArray [ArrayConstraint] Schema
84+ | SchemaNull
85+ deriving (Generic)
86+
87+data instance Sing (schema :: Schema) where
88+ SSchemaText :: Sing tcs -> Sing (SchemaText tcs)
89+ SSchemaNumber :: Sing ncs -> Sing (SchemaNumber ncs)
90+ SSchemaArray :: Sing acs -> Sing schema -> Sing (SchemaArray acs schema)
91+ SSchemaObject :: Sing fields -> Sing (SchemaObject fields)
92+ SSchemaNull :: Sing SchemaNull
93+
94+instance Eq (Sing (SchemaText cs)) where a == b = True
95+instance Eq (Sing (SchemaNumber cs)) where a == b = True
96+instance Eq (Sing SchemaNull) where a == b = True
97+instance Eq (Sing (SchemaArray as s)) where a == b = True
98+instance Eq (Sing (SchemaObject cs)) where a == b = True
99+
100+data FieldRepr :: (Symbol, Schema) -> Type where
101+ FieldRepr :: KnownSymbol name => JsonRepr schema -> FieldRepr '(name, schema)
102+
103+instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where
104+ FieldRepr a == FieldRepr b = a == b
58105
59106instance
60− ( Constrained 'JNumber c
61− , Verifiable 'JNumber cs )
62− => Verifiable 'JNumber (c ': cs) where
63− schema _ _ = cRep (Proxy @'JNumber) (Proxy @c)
64− : schema (Proxy @'JNumber) (Proxy @cs)
65−
66−instance Verifiable jty '[] where
67− schema _ _ = []
68−
69−instance
70− ( Constrained 'JArray c
71− , Verifiable 'JArray cs )
72− => Verifiable 'JArray (c ': cs) where
73− schema _ _ = cRep (Proxy @'JArray) (Proxy @c)
74− : schema (Proxy @'JArray) (Proxy @cs)
75−
76−instance
77− ( SchemaConstructor jty
78− , Verifiable 'JObject fs
79− , KnownSymbol field
80− , Verifiable jty cs )
81− => Verifiable 'JObject ((Field field jty cs) ': fs) where
82− schema _ _ = (fieldName, fieldSchema) : schema (Proxy @'JObject) (Proxy @fs)
107+ ( KnownSymbol name
108+ , Serial m (JsonRepr schema) )
109+ => Serial m (FieldRepr '(name, schema)) where
110+ series = FieldRepr <$> series
111+
112+data JsonRepr :: Schema -> Type where
113+ ReprText :: Text -> JsonRepr (SchemaText cs)
114+ ReprNumber :: Scientific -> JsonRepr (SchemaNumber cs)
115+ ReprNull :: JsonRepr SchemaNull
116+ ReprArray :: V.Vector (JsonRepr s) -> JsonRepr (SchemaArray cs s)
117+ ReprObject :: Rec FieldRepr fs -> JsonRepr (SchemaObject fs)
118+
119+instance Eq (Rec FieldRepr fs) => Eq (JsonRepr (SchemaObject fs)) where
120+ ReprObject a == ReprObject b = a == b
121+
122+instance Eq (JsonRepr (SchemaText cs)) where
123+ ReprText a == ReprText b = a == b
124+
125+instance Eq (JsonRepr (SchemaNumber cs)) where
126+ ReprNumber a == ReprNumber b = a == b
127+
128+instance Eq (JsonRepr SchemaNull) where
129+ ReprNull == ReprNull = True
130+
131+instance Eq (JsonRepr s) => Eq (JsonRepr (SchemaArray as s)) where
132+ ReprArray a == ReprArray b = a == b
133+
134+instance (SingI schema) => J.FromJSON (JsonRepr schema) where
135+ parseJSON value = case sing :: Sing schema of
136+ SSchemaText _ -> withText "String" (pure . ReprText) value
137+ SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value
138+ SSchemaNull -> pure ReprNull
139+ SSchemaArray c s -> withArray "Array" f value
140+ where
141+ f = fmap ReprArray . (withSingI s $ traverse parseJSON)
142+ SSchemaObject fs -> ReprObject <$> withObject "Object" (demoteFields fs) value
143+
144+demoteFields
145+ :: SList s
146+ -> H.HashMap Text J.Value
147+ -> Parser (Rec FieldRepr s)
148+demoteFields SNil h
149+ | H.null h = pure RNil
150+ | otherwise = mzero
151+demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do
152+ let fieldName = T.pack $ symbolVal (Proxy @fn)
153+ fieldRepr <- case H.lookup fieldName h of
154+ Just v -> FieldRepr <$> (withSingI s $ parseJSON v)
155+ Nothing -> mzero
156+ (fieldRepr :&) <$> demoteFields tl h
157+
158+instance J.ToJSON (JsonRepr a) where
159+ toJSON ReprNull = J.Null
160+ toJSON (ReprText t) = J.String t
161+ toJSON (ReprNumber n) = J.Number n
162+ toJSON (ReprArray v) = J.Array $ toJSON <$> v
163+ toJSON (ReprObject r) = J.Object . H.fromList . fold $ r
83164 where
84− fieldName = symbolVal (Proxy @field)
85− fieldSchema = constructor (Proxy @jty) $ schema (Proxy @jty) (Proxy @cs)
86−
87−class SchemaConstructor jty where
88− constructor :: Proxy jty -> [CRepr jty] -> Schema
89−
90−instance SchemaConstructor 'JText where
91− constructor _ = Fix . SchemaText
92−
93−instance SchemaConstructor 'JNumber where
94− constructor _ = Fix . SchemaNumber
95−
96−instance SchemaConstructor 'JObject where
97− constructor _ = Fix . SchemaObject
98−
99−class Schematic ty where
100− build :: Proxy ty -> Schema
101−
102−data SText cs
103−
104−instance (Verifiable 'JText cs) => Schematic (SText cs) where
105− build _ = constructor (Proxy @(JT (SText cs))) $ schema (Proxy @JText) (Proxy @cs)
106−
107−data SNumber cs
108−
109−instance (Verifiable 'JNumber cs) => Schematic (SNumber cs) where
110− build _ = constructor (Proxy @(JT (SNumber cs)))
111− $ schema (Proxy @'JNumber) (Proxy @cs)
112−
113−instance
114− ( Verifiable (JT ty) cs
115− , SchemaConstructor (JT ty))
116− => Schematic (Field field ty cs) where
117− build _ = constructor (Proxy @(JT (Field field ty cs)))
118− $ schema (Proxy @(JT (Field field ty cs))) (Proxy @cs)
119−
120−data SObject els
121−
122−instance
123− ( Verifiable 'JObject els )
124− => Schematic (SObject els) where
125− build _ =
126− constructor (Proxy @'JObject) $ schema (Proxy @(JT (SObject els))) (Proxy @els)
127−
128−data SArray cs s
129−
130−instance
131− ( Schematic s
132− , Verifiable 'JArray cs )
133− => Schematic (SArray cs s) where
134− build _ =
135− Fix $ SchemaArray
136− (schema (Proxy @'JArray) (Proxy @cs))
137− (build (Proxy @s))
138−
139−-- | Shows it's top-level definition according to the json-schema
140−class Schematic spec => TopLevel spec
141−
142−instance (Schematic (SObject els)) => TopLevel (SObject els)
143−
144−instance Schematic (SArray cs s) => TopLevel (SArray cs s)
145−
146−-- | TODO: abstract over objects and arrays
147−toSchema
148− :: forall spec. TopLevel spec
149− => Proxy spec
150− -> Schema
151−toSchema = build
165+ extract :: forall name s . (KnownSymbol name)
166+ => FieldRepr '(name, s)
167+ -> (Text, Value)
168+ extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s)
169+ fold :: Rec FieldRepr fs -> [(Text, J.Value)]
170+ fold = \case
171+ RNil -> []
172+ fr@(FieldRepr s) :& tl -> (extract fr) : fold tl
173+
174+class FalseConstraint
175+
176+type family TopLevel (spec :: Schema) :: Constraint where
177+ TopLevel (SchemaArray a e) = ()
178+ TopLevel (SchemaObject o) = ()
179+ TopLevel spec = FalseConstraint