module Data.Schematic.JsonSchema
( toJsonSchema
, toJsonSchema'
) where
import Control.Monad.State.Strict
import Data.Foldable
import Data.HashMap.Strict as H
import Data.List.NonEmpty
import Data.Schematic.Schema as S
import Data.Singletons
import Data.Text
import JSONSchema.Draft4.Schema as D4
import JSONSchema.Validator.Draft4 as D4
draft4 :: Text
draft4 = "http://Jason-schema.org/draft-04/schema#"
textConstraint :: DemotedTextConstraint -> State D4.Schema ()
textConstraint (DTEq _) = pure ()
textConstraint (DTLt _) = pure ()
textConstraint (DTLe _) = pure ()
textConstraint (DTGt _) = pure ()
textConstraint (DTGe _) = pure ()
textConstraint (DTRegex _) = pure ()
textConstraint (DTEnum _) = pure ()
numberConstraint :: DemotedNumberConstraint -> State D4.Schema ()
numberConstraint (DNLe _) = pure ()
numberConstraint (DNLt _) = pure ()
numberConstraint (DNGt _) = pure ()
numberConstraint (DNGe _) = pure ()
numberConstraint (DNEq _) = pure ()
arrayConstraint :: DemotedArrayConstraint -> State D4.Schema ()
arrayConstraint (DAEq _) = pure ()
toJsonSchema
:: forall proxy schema
. SingI schema
=> proxy (schema :: S.Schema)
-> D4.Schema
toJsonSchema _ = (toJsonSchema' $ fromSing (sing :: Sing schema))
{ _schemaVersion = pure draft4 }
toJsonSchema'
:: DemotedSchema
-> D4.Schema
toJsonSchema' = \case
DSchemaText tcs ->
execState (traverse_ textConstraint tcs) $ emptySchema
{ _schemaType = pure $ TypeValidatorString D4.SchemaString }
DSchemaNumber ncs ->
execState (traverse_ numberConstraint ncs) $ emptySchema
{ _schemaType = pure $ TypeValidatorString D4.SchemaNumber }
DSchemaBoolean -> emptySchema
{ _schemaType = pure $ TypeValidatorString D4.SchemaBoolean }
DSchemaObject objs -> emptySchema
{ _schemaType = pure $ TypeValidatorString D4.SchemaObject
, _schemaProperties = pure $ H.fromList $ (\(n,s) -> (n, toJsonSchema' s))
<$> objs }
DSchemaArray acs sch ->
execState (traverse_ arrayConstraint acs) $ emptySchema
{ _schemaType = pure $ TypeValidatorString D4.SchemaArray
, _schemaItems = pure $ ItemsArray [toJsonSchema' sch] }
DSchemaNull -> emptySchema
{ _schemaType = pure $ TypeValidatorString D4.SchemaNull }
DSchemaOptional sch -> emptySchema
{ _schemaOneOf = pure $ toJsonSchema' DSchemaNull :| [toJsonSchema' sch] }