jsonschema-gen (empty) → 0.1.0.0
raw patch · 10 files changed
+1522/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, jsonschema-gen, process, scientific, tagged, text, time, transformers, unordered-containers, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- jsonschema-gen.cabal +68/−0
- src/Data/JSON/Schema/Generator.hs +109/−0
- src/Data/JSON/Schema/Generator/Class.hs +75/−0
- src/Data/JSON/Schema/Generator/Convert.hs +266/−0
- src/Data/JSON/Schema/Generator/Generic.hs +457/−0
- src/Data/JSON/Schema/Generator/Types.hs +144/−0
- tests/Main.hs +313/−0
- tests/Types.hs +58/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Shohei Murayama++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Shohei Murayama nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jsonschema-gen.cabal view
@@ -0,0 +1,68 @@+name: jsonschema-gen+version: 0.1.0.0+synopsis: JSON Schema generator from Algebraic data type+description: This library contains a JSON Scheam generator.+homepage: https://github.com/yuga/jsonschema-gen+license: BSD3+license-file: LICENSE+author: Shohei Murayama+maintainer: shohei.murayama@gmail.com+copyright: (c) 2015 Shohei Murayama <shohei.murayama@gmail.com>+category: Text, Data, JSON+build-type: Simple+cabal-version: >=1.10+-- extra-source-files: ++flag safe-aeson+ description: To avoid the issue of prior to aeson-0.7.0.6, set this flag True.+ default: False++library+ exposed-modules: Data.JSON.Schema.Generator+ Data.JSON.Schema.Generator.Class+ Data.JSON.Schema.Generator.Convert+ Data.JSON.Schema.Generator.Generic+ Data.JSON.Schema.Generator.Types++ build-depends: base >=4.6 && <4.9+ , bytestring+ , containers+ , tagged+ , text+ , time+ , unordered-containers+ , vector++ if flag(safe-aeson)+ build-depends:+ aeson >=0.7.0.6+ , scientific >=0.3.2.0+ else+ build-depends:+ aeson+ , scientific++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/yuga/jsonschema-gen++test-suite test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Types+ build-depends: base >=4.6 && <4.9+ , aeson+ , bytestring+ , containers+ , jsonschema-gen+ , process+ , tagged+ , text+ , transformers+ hs-source-dirs: tests+ default-language: Haskell2010+
+ src/Data/JSON/Schema/Generator.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module: Data.JSON.Schema.Generator+-- Copyright: (c) 2015 Shohei Murayama+-- License: BSD3+-- Maintainer: Shohei Murayama <shohei.murayama@gmail.com>+-- Stability: experimental+--+-- A generator for JSON Schemas from ADT.+--+module Data.JSON.Schema.Generator+ (+ -- * How to use this library+ -- $use++ -- * Genenerating JSON Schema+ Options(..), PropType(..), defaultOptions+ , generate, generate'++ -- * Type conversion+ , JSONSchemaGen(toSchema)+ , JSONSchemaPrim(toSchemaPrim)+ , convert++ -- * Generic Schema class+ , GJSONSchemaGen(gToSchema)+ , genericToSchema+ ) where++import Data.ByteString.Lazy.Char8 (ByteString)+import Data.JSON.Schema.Generator.Class (JSONSchemaGen(toSchema), JSONSchemaPrim(toSchemaPrim)+ , GJSONSchemaGen(gToSchema), Options(..), PropType(..), defaultOptions, genericToSchema)+import Data.JSON.Schema.Generator.Convert (convert)+import Data.JSON.Schema.Generator.Generic ()+import Data.Proxy (Proxy)++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A++-- | Generate a JSON Schema from a proxy value of a type.+-- This uses the default options to generate schema in json format.+--+generate :: JSONSchemaGen a+ => Proxy a -- ^ A proxy value of the type from which a schema will be generated.+ -> ByteString+generate = A.encode . convert A.defaultOptions . toSchema defaultOptions++-- | Generate a JSON Schema from a proxy vaulue of a type.+-- This uses the specified options to generate schema in json format.+--+generate' :: JSONSchemaGen a+ => Options -- ^ Schema generation 'Options'.+ -> A.Options -- ^ Encoding 'A.Options' of aeson.+ -> Proxy a -- ^ A proxy value of the type from which a schema will be generated.+ -> ByteString+generate' opts aopts = A.encode . convert aopts . toSchema opts++-- $use+-- Example:+--+-- > {-# LANGUAGE DeriveGeneric #-}+-- >+-- > import qualified Data.ByteString.Lazy.Char8 as BL+-- > import Data.JSON.Schema.Generator+-- > import Data.Proxy+-- > import GHC.Generics+-- >+-- > data User = User+-- > { name :: String+-- > , age :: Int+-- > , email :: Maybe String+-- > } deriving Generic+-- >+-- > instance JSONSchemaGen User+-- >+-- > main :: IO ()+-- > main = BL.putStrLn $ generate (Proxy :: Proxy User)+--+-- Let's run the above script, we can get on stdout (the following json is formatted with jq):+--+-- @+-- {+-- \"required\": [+-- \"name\",+-- \"age\",+-- \"email\"+-- ],+-- \"$schema\": \"http://json-schema.org\/draft-04\/schema#\",+-- \"id\": \"Main.User\",+-- \"title\": \"Main.User\",+-- \"type\": \"object\",+-- \"properties\": {+-- \"email\": {+-- \"type\": [+-- \"string\",+-- \"null\"+-- ]+-- },+-- \"age\": {+-- \"type\": \"integer\"+-- },+-- \"name\": {+-- \"type\": \"string\"+-- }+-- }+-- }+-- @+
+ src/Data/JSON/Schema/Generator/Class.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.JSON.Schema.Generator.Class where++import Data.JSON.Schema.Generator.Types (Schema)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy (Proxy)+import Data.Typeable (TypeRep)+import GHC.Generics (Generic(from), Rep)++--------------------------------------------------------------------------------++class JSONSchemaGen a where+ toSchema :: Options -> Proxy a -> Schema+ + default toSchema :: (Generic a, GJSONSchemaGen (Rep a)) => Options -> Proxy a -> Schema+ toSchema = genericToSchema++class JSONSchemaPrim a where+ toSchemaPrim :: Options -> Proxy a -> Schema++--------------------------------------------------------------------------------++class GJSONSchemaGen f where+ gToSchema :: Options -> Proxy (f a) -> Schema++genericToSchema :: (Generic a, GJSONSchemaGen (Rep a)) => Options -> Proxy a -> Schema+genericToSchema opts = gToSchema opts . fmap from++--------------------------------------------------------------------------------++-- | Options that specify how to generate schema definition automatically+-- from your datatype.+--+data Options = Options+ { baseUri :: String -- ^ shcema id prefix.+ , schemaIdSuffix :: String -- ^ schema id suffix. File extension for example.+ , typeRefMap :: Map TypeRep String -- ^ a mapping from datatypes to referenced schema ids.+ , fieldTypeMap :: Map String PropType -- ^ a mapping to assign a preffered type to a field.+ }++data PropType = forall a. (JSONSchemaPrim a) => PropType (Proxy a)++instance Show Options where+ showsPrec p opts =+ showParen (p > 10)+ $ showString "Options { baseUri = "+ . showsPrec 11 (baseUri opts)+ . showString ", schemaIdSuffix = "+ . showsPrec 11 (schemaIdSuffix opts)+ . showString ", typeRefMap = "+ . showsPrec 11 (typeRefMap opts)+ . showString ", fieldTypeMap = {..} }"++-- | Default geerating 'Options':+--+-- @+-- 'Options'+-- { 'baseUri' = ""+-- , 'schemaIdSuffix' = ""+-- , 'refSchemaMap' = Map.empty+-- }+-- @+--+defaultOptions :: Options+defaultOptions = Options+ { baseUri = ""+ , schemaIdSuffix = ""+ , typeRefMap = Map.empty+ , fieldTypeMap = Map.empty+ }+
+ src/Data/JSON/Schema/Generator/Convert.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Data.JSON.Schema.Generator.Convert+ ( convert+ ) where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative ((<*>))+import Data.Monoid (mappend)+#endif++import Data.JSON.Schema.Generator.Types (Schema(..), SchemaChoice(..))+import Data.Text (Text, pack)++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Vector as Vector++--------------------------------------------------------------------------------++convert :: A.Options -> Schema -> A.Value+convert = convert' False++convert' :: Bool -> A.Options -> Schema -> A.Value+convert' = (((A.Object . HashMap.fromList) .) .) . convertToList++convertToList :: Bool -> A.Options -> Schema -> [(Text,A.Value)]+convertToList inArray opts s = foldr1 (++) $+ [ jsId+ , jsSchema+ , jsSchemaType opts+ , jsTitle+ , jsDescription+ , jsReference+ , jsType inArray opts+ , jsFormat+ , jsLowerBound+ , jsUpperBound+ , jsValue+ , jsItems opts+ , jsProperties opts+ , jsPatternProps opts+ , jsOneOf opts+ , jsRequired opts+ , jsDefinitions opts+ ] <*> [s]++--------------------------------------------------------------------------------++jsId :: Schema -> [(Text,A.Value)]+jsId (SCSchema {scId = i}) = [("id", string i)]+jsId _ = []++jsSchema :: Schema -> [(Text,A.Value)]+jsSchema SCSchema {scUsedSchema = s} = [("$schema", string s)]+jsSchema _ = []++jsSchemaType :: A.Options -> Schema -> [(Text,A.Value)]+jsSchemaType opts SCSchema {scSchemaType = s} = convertToList False opts s+jsSchemaType _ _ = []++jsTitle :: Schema -> [(Text,A.Value)]+jsTitle SCConst {scTitle = "" } = []+jsTitle SCConst {scTitle = t } = [("title", string t)]+jsTitle SCObject {scTitle = "" } = []+jsTitle SCObject {scTitle = t } = [("title", string t)]+jsTitle SCArray {scTitle = "" } = []+jsTitle SCArray {scTitle = t } = [("title", string t)]+jsTitle SCOneOf {scTitle = "" } = []+jsTitle SCOneOf {scTitle = t } = [("title", string t)]+jsTitle _ = []++jsDescription :: Schema -> [(Text,A.Value)]+jsDescription SCString {scDescription = (Just d) } = [("description", string d)]+jsDescription SCInteger {scDescription = (Just d) } = [("description", string d)]+jsDescription SCNumber {scDescription = (Just d) } = [("description", string d)]+jsDescription SCBoolean {scDescription = (Just d) } = [("description", string d)]+jsDescription SCConst {scDescription = (Just d) } = [("description", string d)]+jsDescription SCObject {scDescription = (Just d) } = [("description", string d)]+jsDescription SCArray {scDescription = (Just d) } = [("description", string d)]+jsDescription SCOneOf {scDescription = (Just d) } = [("description", string d)]+jsDescription _ = []++jsReference :: Schema -> [(Text,A.Value)]+jsReference SCRef {scReference = r} = [("$ref", string r)]+jsReference _ = []++jsType :: Bool -> A.Options -> Schema -> [(Text,A.Value)]+jsType (needsNull -> f) (f -> True) SCString {scNullable = True } = [("type", array ["string", "null" :: Text])]+jsType (needsNull -> f) (f -> _ ) SCString {scNullable = _ } = [("type", string "string")]+jsType (needsNull -> f) (f -> True) SCInteger {scNullable = True } = [("type", array ["integer", "null" :: Text])]+jsType (needsNull -> f) (f -> _ ) SCInteger {scNullable = _ } = [("type", string "integer")]+jsType (needsNull -> f) (f -> True) SCNumber {scNullable = True } = [("type", array ["number", "null" :: Text])]+jsType (needsNull -> f) (f -> _ ) SCNumber {scNullable = _ } = [("type", string "number")]+jsType (needsNull -> f) (f -> True) SCBoolean {scNullable = True } = [("type", array ["boolean", "null" :: Text])]+jsType (needsNull -> f) (f -> _ ) SCBoolean {scNullable = _ } = [("type", string "boolean")]+jsType (needsNull -> f) (f -> True) SCObject {scNullable = True } = [("type", array ["object", "null" :: Text])]+jsType (needsNull -> f) (f -> _ ) SCObject {scNullable = _ } = [("type", string "object")]+jsType (needsNull -> f) (f -> True) SCArray {scNullable = True } = [("type", array ["array", "null" :: Text])]+jsType (needsNull -> f) (f -> _ ) SCArray {scNullable = _ } = [("type", string "array")]+jsType _ _ _ = []++needsNull :: Bool -> A.Options -> Bool+needsNull True _ = True+needsNull False opts = not (A.omitNothingFields opts)++jsFormat :: Schema -> [(Text,A.Value)]+jsFormat SCString {scFormat = Just f} = [("format", string f)]+jsFormat _ = []++jsLowerBound :: Schema -> [(Text,A.Value)]+jsLowerBound SCString {scLowerBound = (Just n)} = [("minLength", number n)]+jsLowerBound SCNumber {scLowerBound = (Just n)} = [("mininum", number n)]+jsLowerBound SCArray {scLowerBound = (Just n)} = [("minItems", number n)]+jsLowerBound _ = []++jsUpperBound :: Schema -> [(Text,A.Value)]+jsUpperBound SCString {scUpperBound = (Just n)} = [("maxLength", number n)]+jsUpperBound SCNumber {scUpperBound = (Just n)} = [("maximum", number n)]+jsUpperBound SCArray {scUpperBound = (Just n)} = [("maxItems", number n)]+jsUpperBound _ = []++jsValue :: Schema -> [(Text,A.Value)]+jsValue SCConst {scValue = v} = [("enum", array [v])]+jsValue _ = []++jsItems :: A.Options -> Schema -> [(Text,A.Value)]+jsItems opts SCArray {scItems = items} = [("items", array . map (convert' True opts) $ items)]+jsItems _ _ = []++jsProperties :: A.Options -> Schema -> [(Text,A.Value)]+jsProperties opts SCObject {scProperties = p} = [("properties", object $ toMap opts p)]+jsProperties _ _ = []++jsPatternProps :: A.Options -> Schema -> [(Text,A.Value)]+jsPatternProps _ SCObject {scPatternProps = []} = []+jsPatternProps opts SCObject {scPatternProps = p } = [("patternProperties", object $ toMap opts p)]+jsPatternProps _ _ = []++jsOneOf :: A.Options -> Schema -> [(Text,A.Value)]+jsOneOf opts SCOneOf {scChoices = cs, scNullable = nullable} = choices opts nullable cs+jsOneOf _ _ = []++jsRequired :: A.Options -> Schema -> [(Text,A.Value)]+jsRequired A.Options {A.omitNothingFields = True} SCObject {scRequired = r } = [("required", array r)]+jsRequired opts@(A.Options {A.omitNothingFields = _ }) SCObject {scProperties = p} = [("required", array . map fst $ toMap opts p)]+jsRequired _ _ = []++jsDefinitions :: A.Options -> Schema -> [(Text,A.Value)]+jsDefinitions _ SCSchema {scDefinitions = []} = []+jsDefinitions opts SCSchema {scDefinitions = d } = [("definitions", object $ toMap opts d)]+jsDefinitions _ _ = []++--------------------------------------------------------------------------------++array :: A.ToJSON a => [a] -> A.Value+array = A.Array . Vector.fromList . map A.toJSON++string :: Text -> A.Value+string = A.String++number :: Integer -> A.Value+number = A.Number . fromInteger++object :: [A.Pair] -> A.Value+object = A.object++false :: A.Value+false = A.Bool False++--------------------------------------------------------------------------------++choices :: A.Options -> Bool -> [SchemaChoice] -> [(Text,A.Value)]+choices opts nullable cs+ | isEnum && nullable = [ ("oneOf", array $ [object [("enum", array $ map consAsEnum cs)], object [("type", string "null")]]) ]+ | isEnum = [ ("enum", array $ map consAsEnum cs) ]+ | isUnit && nullable = [ ("type", array $ map string ["object", "null"])+ , ("properties", head $ map (conAsObject opts) cs)+ ]+ | isUnit = [ ("type", array $ map string ["object"])+ , ("properties", head $ map (conAsObject opts) cs)+ ]+ | nullable = [ ("oneOf", array $ object [("type", string "null")] : map (conAsObject opts) cs) ]+ | otherwise = [ ("oneOf", array $ map (conAsObject opts) cs) ]+ where+ isEnum = A.allNullaryToStringTag opts && all enumerable cs+ isUnit = length cs == 1++enumerable :: SchemaChoice -> Bool+enumerable (SCChoiceEnum _ _) = True+enumerable _ = False++consAsEnum :: SchemaChoice -> Text+consAsEnum (SCChoiceEnum tag _) = tag+consAsEnum s = error ("conAsEnum could not handle: " ++ show s)++conAsObject :: A.Options -> SchemaChoice -> A.Value+conAsObject opts sc+ | isArray opts = object $+ if sctTitle sc == "" then [] else [ ("title", string $ sctTitle sc) ]+ `mappend`+ [ ("type", "array")+ , ("items" , conAsObject' opts sc)+ , ("minItems", number 2)+ , ("maxItems", number 2)+ , ("additionalItems", false)+ ]+ | otherwise = object $+ if sctTitle sc == "" then [] else [ ("title", string $ sctTitle sc) ]+ `mappend`+ [ ("type", "object")+ , ("properties", conAsObject' opts sc)+ , ("additionalProperties", false)+ ]++isArray :: A.Options -> Bool+isArray (A.sumEncoding -> A.TwoElemArray) = True+isArray _ = False++conAsObject' :: A.Options -> SchemaChoice -> A.Value+conAsObject' opts@(A.Options {A.sumEncoding = A.TaggedObject tFld cFld}) sc = conAsTag opts (pack tFld) (pack cFld) sc+conAsObject' opts@(A.Options {A.sumEncoding = A.TwoElemArray }) sc = conAsArray opts sc+conAsObject' opts@(A.Options {A.sumEncoding = A.ObjectWithSingleField }) sc = conAsMap opts sc++conAsTag :: A.Options -> Text -> Text -> SchemaChoice -> A.Value+conAsTag opts tFld cFld (SCChoiceEnum tag _) = object [(tFld, object [("enum", array [tag])]), (cFld, conToArray opts [])]+conAsTag opts tFld cFld (SCChoiceArray tag _ ar) = object [(tFld, object [("enum", array [tag])]), (cFld, conToArray opts ar)]+conAsTag opts tFld _ (SCChoiceMap tag _ mp _) = object ((tFld, object [("enum", array [tag])]) : toMap opts mp)++conAsArray :: A.Options -> SchemaChoice -> A.Value+conAsArray opts (SCChoiceEnum tag _) = array [object [("enum", array [tag])], conToArray opts []]+conAsArray opts (SCChoiceArray tag _ ar) = array [object [("enum", array [tag])], conToArray opts ar]+conAsArray opts (SCChoiceMap tag _ mp rq) = array [object [("enum", array [tag])], conToObject opts mp rq]++conAsMap :: A.Options -> SchemaChoice -> A.Value+conAsMap opts (SCChoiceEnum tag _) = object [(tag, conToArray opts [])]+conAsMap opts (SCChoiceArray tag _ ar) = object [(tag, conToArray opts ar)]+conAsMap opts (SCChoiceMap tag _ mp rq) = object [(tag, conToObject opts mp rq)]++conToArray :: A.Options -> [Schema] -> A.Value+conToArray opts ar = object+ [ ("type", "array")+ , ("items", array . map (convert' True opts) $ ar)+ , ("minItems", A.toJSON $ length ar)+ , ("maxItems", A.toJSON $ length ar)+ , ("additionalItems", false)+ ]++conToObject :: A.Options -> [(Text,Schema)] -> [Text] -> A.Value+conToObject opts mp rq = object+ [ ("type", "object")+ , ("properties", object $ toMap opts mp)+ , ("required", required opts)+ , ("additionalProperties", false)+ ]+ where+ required A.Options {A.omitNothingFields = True} = array rq+ required A.Options {A.omitNothingFields = _ } = array . map fst $ toMap opts mp++toMap :: A.Options -> [(Text,Schema)] -> [(Text,A.Value)]+toMap opts mp = map (\(n,v) -> (n,convert' False opts v)) mp -- ++ [("additionalProperties", false)]+
+ src/Data/JSON/Schema/Generator/Generic.hs view
@@ -0,0 +1,457 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.JSON.Schema.Generator.Generic () where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative (pure)+import Data.Monoid (mappend, mempty)+#endif++import Data.JSON.Schema.Generator.Class (JSONSchemaGen(..), JSONSchemaPrim(..)+ , GJSONSchemaGen(..), Options(..), PropType(..))+import Data.JSON.Schema.Generator.Types (Schema(..), SchemaChoice(..)+ , scBoolean, scInteger, scNumber, scString)+import Data.HashMap.Strict (HashMap)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy (Proxy(Proxy))+import Data.Tagged (Tagged(Tagged, unTagged))+import qualified Data.Text as Text+import Data.Typeable (Typeable, typeOf)+import Data.Text (Text)+import Data.Time (UTCTime)+import GHC.Generics (+ Datatype(datatypeName, moduleName), Constructor(conName), Selector(selName)+ , NoSelector+ , C1, D1, K1, M1(unM1), S1, U1, (:+:), (:*:)+ , S)++--------------------------------------------------------------------------------++data Env = Env+ { envModuleName :: !String+ , envDatatypeName :: !String+ , envConName :: !String+ , envSelname :: !(Maybe String)+ }++initEnv :: Env+initEnv = Env "" "" "" Nothing++instance (Datatype d, SchemaType f) => GJSONSchemaGen (D1 d f) where+ gToSchema opts pd = SCSchema+ { scId = Text.pack $ baseUri opts ++ modName ++ "." ++ typName ++ schemaIdSuffix opts+ , scUsedSchema = "http://json-schema.org/draft-04/schema#"+ , scSchemaType = (simpleType opts env . fmap unM1 $ pd)+ { scTitle = Text.pack $ modName ++ "." ++ typName+ }+ , scDefinitions = mempty+ }+ where+ modName = moduleName (undefined :: D1 d f p)+ typName = datatypeName (undefined :: D1 d f p)+ env = initEnv { envModuleName = modName+ , envDatatypeName = typName+ }++--------------------------------------------------------------------------------++class SchemaType f where+ simpleType :: Options -> Env -> Proxy (f a) -> Schema++instance (Constructor c) => SchemaType (C1 c U1) where+ simpleType _ env _ = SCConst+ { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ conname+ , scDescription = Nothing+ , scValue = Text.pack conname+ }+ where+ conname = conName (undefined :: C1 c U1 p)++instance (IsRecord f isRecord, SchemaTypeS f isRecord, Constructor c) => SchemaType (C1 c f) where+ simpleType opts env _ = (unTagged :: Tagged isRecord Schema -> Schema) . simpleTypeS opts env' $ (Proxy :: Proxy (f p))+ where+ env' = env { envConName = conName (undefined :: C1 c f p) }++-- there are multiple constructors+#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPABLE #-} (AllNullary f allNullary, SchemaTypeM f allNullary) => SchemaType f where+ simpleType opts env _ = (unTagged :: Tagged allNullary Schema -> Schema) . simpleTypeM opts env $ (Proxy :: Proxy (f p))+#else+instance (AllNullary f allNullary, SchemaTypeM f allNullary) => SchemaType f where+ simpleType opts env _ = (unTagged :: Tagged allNullary Schema -> Schema) . simpleTypeM opts env $ (Proxy :: Proxy (f p))+#endif++class SchemaTypeS f isRecord where+ simpleTypeS :: Options -> Env -> Proxy (f a) -> Tagged isRecord Schema++-- Record+instance (RecordToPairs f) => SchemaTypeS f True where+ simpleTypeS opts env _ = Tagged SCObject+ { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env+ , scDescription = Nothing+ , scNullable = False+ , scProperties = recordToPairs opts env False (Proxy :: Proxy (f p))+ , scPatternProps = []+ , scRequired = map fst $ recordToPairs opts env True (Proxy :: Proxy (f p))+ }++-- Product+instance (ProductToList f) => SchemaTypeS f False where+ simpleTypeS opts env _ = Tagged SCArray+ { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env+ , scDescription = Nothing+ , scNullable = False+ , scItems = productToList opts env (Proxy :: Proxy (f p))+ , scLowerBound = Nothing+ , scUpperBound = Nothing+ }++class SchemaTypeM f allNullary where+ simpleTypeM :: Options -> Env -> Proxy (f a) -> Tagged allNullary Schema++-- allNullary+instance (SumToEnum f) => SchemaTypeM f True where+ simpleTypeM _ env _ = Tagged SCOneOf+ { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env+ , scDescription = Nothing+ , scNullable = False+ , scChoices = sumToEnum env (Proxy :: Proxy (f p))+ }++-- not allNullary+instance (SumToArrayOrMap f) => SchemaTypeM f False where+ simpleTypeM opts env _ = Tagged SCOneOf+ { scTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env+ , scDescription = Nothing+ , scNullable = False+ , scChoices = sumToArrayOrMap opts env (Proxy :: Proxy (f p))+ }++--------------------------------------------------------------------------------++class SumToEnum f where+ sumToEnum :: Env -> Proxy (f a) -> [SchemaChoice]++instance (Constructor c) => SumToEnum (C1 c U1) where+ sumToEnum env _ = pure SCChoiceEnum+ { sctName = Text.pack $ conName (undefined :: C1 c U1 p)+ , sctTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "."+ ++ conName (undefined :: C1 c U1 p)+ }++instance (SumToEnum a, SumToEnum b) => SumToEnum (a :+: b) where+ sumToEnum env _ = sumToEnum env a `mappend` sumToEnum env b+ where+ a = Proxy :: Proxy (a p)+ b = Proxy :: Proxy (b p)++class SumToArrayOrMap f where+ sumToArrayOrMap :: Options -> Env -> Proxy (f a) -> [SchemaChoice]++instance (Constructor c, IsRecord f isRecord, ConToArrayOrMap f isRecord)+ => SumToArrayOrMap (C1 c f) where+ sumToArrayOrMap opts env _ =+ pure . (unTagged :: Tagged isRecord SchemaChoice -> SchemaChoice) . conToArrayOrMap opts env' $ (Proxy :: Proxy (f p))+ where+ env' = env { envConName = conName (undefined :: C1 c f p) }++instance (SumToArrayOrMap a, SumToArrayOrMap b) => SumToArrayOrMap (a :+: b) where+ sumToArrayOrMap opts env _ = sumToArrayOrMap opts env a `mappend` sumToArrayOrMap opts env b+ where+ a = Proxy :: Proxy (a p)+ b = Proxy :: Proxy (b p)++class ConToArrayOrMap f isRecord where+ conToArrayOrMap :: Options -> Env -> Proxy (f a) -> Tagged isRecord SchemaChoice++instance (RecordToPairs f) => ConToArrayOrMap f True where+ conToArrayOrMap opts env _ = Tagged SCChoiceMap+ { sctName = Text.pack $ envConName env+ , sctTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env+ , sctMap = recordToPairs opts env False (Proxy :: Proxy (f p))+ , sctRequired = map fst $ recordToPairs opts env True (Proxy :: Proxy (f p))+ }++instance (RecordToPairs f) => ConToArrayOrMap f False where+ conToArrayOrMap opts env _ = Tagged SCChoiceArray+ { sctName = Text.pack $ envConName env+ , sctTitle = Text.pack $ envModuleName env ++ "." ++ envDatatypeName env ++ "." ++ envConName env+ , sctArray = map snd $ recordToPairs opts env False (Proxy :: Proxy (f p))+ }++--------------------------------------------------------------------------------++class RecordToPairs f where+ recordToPairs :: Options -> Env -> Bool -> Proxy (f a) -> [(Text, Schema)]++instance RecordToPairs U1 where+ recordToPairs _ _ _ _ = mempty++instance (Selector s, IsNullable a, ToJSONSchemaDef a) => RecordToPairs (S1 s a) where+ recordToPairs opts env notMaybe _ + | isEmpty = mempty+ | otherwise = pure ( Text.pack selname+ , (toJSONSchemaDef opts env' field) { scNullable = isNullable field })+ where+ isEmpty = notMaybe && isNullable field+ field = Proxy :: Proxy (a p)+ selector = undefined :: S1 s a p+ selname = selName selector+ env' = env { envSelname = Just selname }++instance (RecordToPairs a, RecordToPairs b) => RecordToPairs (a :*: b) where+ recordToPairs opts env notMaybe _ =+ recordToPairs opts env notMaybe a `mappend` recordToPairs opts env notMaybe b+ where+ a = Proxy :: Proxy (a p)+ b = Proxy :: Proxy (b p)++class ProductToList f where+ productToList :: Options -> Env -> Proxy (f a) -> [Schema]++instance (IsNullable a, ToJSONSchemaDef a) => ProductToList (S1 s a) where+ productToList opts env _ = pure (toJSONSchemaDef opts env prod) {scNullable = isNullable prod}+ where+ prod = Proxy :: Proxy (a p)++instance (ProductToList a, ProductToList b) => ProductToList (a :*: b) where+ productToList opts env _ = productToList opts env a `mappend` productToList opts env b+ where+ a = Proxy :: Proxy (a p)+ b = Proxy :: Proxy (b p)++--------------------------------------------------------------------------------++class ToJSONSchemaDef f where+ toJSONSchemaDef :: Options -> Env -> Proxy (f a) -> Schema++#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-} (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i (Maybe a)) where+ toJSONSchemaDef opts env _ = case propType opts env of+ Just (PropType p) -> toSchemaPrim opts p+ Nothing -> toSchemaPrim opts (Proxy :: Proxy a)++instance {-# OVERLAPPABLE #-} (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i a) where+ toJSONSchemaDef opts env _ = case propType opts env of+ Just (PropType p) -> toSchemaPrim opts p+ Nothing -> toSchemaPrim opts (Proxy :: Proxy a)+#else+instance (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i (Maybe a)) where+ toJSONSchemaDef opts env _ = case propType opts env of+ Just (PropType p) -> toSchemaPrim opts p+ Nothing -> toSchemaPrim opts (Proxy :: Proxy a)++instance (JSONSchemaPrim a) => ToJSONSchemaDef (K1 i a) where+ toJSONSchemaDef opts env _ = case propType opts env of+ Just (PropType p) -> toSchemaPrim opts p+ Nothing -> toSchemaPrim opts (Proxy :: Proxy a)+#endif++propType :: Options -> Env -> Maybe PropType+propType opts env = do+ selname <- envSelname env+ Map.lookup selname $ fieldTypeMap opts++--------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-} JSONSchemaPrim String where+ toSchemaPrim _ _ = scString++instance {-# OVERLAPPING #-} JSONSchemaPrim Text where+ toSchemaPrim _ _ = scString++instance {-# OVERLAPPING #-} JSONSchemaPrim UTCTime where+ toSchemaPrim _ _ = scString { scFormat = Just "date-time" }++instance {-# OVERLAPPING #-} JSONSchemaPrim Int where+ toSchemaPrim _ _ = scInteger++instance {-# OVERLAPPING #-} JSONSchemaPrim Integer where+ toSchemaPrim _ _ = scInteger++instance {-# OVERLAPPING #-} JSONSchemaPrim Float where+ toSchemaPrim _ _ = scNumber++instance {-# OVERLAPPING #-} JSONSchemaPrim Double where+ toSchemaPrim _ _ = scNumber++instance {-# OVERLAPPING #-} JSONSchemaPrim Bool where+ toSchemaPrim _ _ = scBoolean++instance {-# OVERLAPS #-} (JSONSchemaPrim a) => JSONSchemaPrim [a] where+ toSchemaPrim opts _ = SCArray+ { scTitle = ""+ , scDescription = Nothing+ , scNullable = False+ , scItems = [toSchemaPrim opts (Proxy :: Proxy a)]+ , scLowerBound = Nothing+ , scUpperBound = Nothing+ }++instance {-# OVERLAPS #-} (JSONSchemaPrim a) => JSONSchemaPrim (Map String a) where+ toSchemaPrim opts _ = SCObject+ { scTitle = ""+ , scDescription = Nothing+ , scNullable = False+ , scProperties = []+ , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))]+ , scRequired = []+ }++instance {-# OVERLAPS #-} (JSONSchemaPrim a) => JSONSchemaPrim (HashMap String a) where+ toSchemaPrim opts _ = SCObject+ { scTitle = ""+ , scDescription = Nothing+ , scNullable = False+ , scProperties = []+ , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))]+ , scRequired = []+ }++instance {-# OVERLAPPABLE #-} (Typeable a, JSONSchemaGen a) => JSONSchemaPrim a where+ toSchemaPrim opts a = SCRef+ { scReference = maybe (scId $ toSchema opts a) Text.pack $ Map.lookup (typeOf (undefined :: a)) (typeRefMap opts)+ , scNullable = False+ }+#else+instance JSONSchemaPrim String where+ toSchemaPrim _ _ = scString++instance JSONSchemaPrim Text where+ toSchemaPrim _ _ = scString++instance JSONSchemaPrim UTCTime where+ toSchemaPrim _ _ = scString { scFormat = Just "date-time" }++instance JSONSchemaPrim Int where+ toSchemaPrim _ _ = scInteger++instance JSONSchemaPrim Integer where+ toSchemaPrim _ _ = scInteger++instance JSONSchemaPrim Float where+ toSchemaPrim _ _ = scNumber++instance JSONSchemaPrim Double where+ toSchemaPrim _ _ = scNumber++instance JSONSchemaPrim Bool where+ toSchemaPrim _ _ = scBoolean++instance (JSONSchemaPrim a) => JSONSchemaPrim [a] where+ toSchemaPrim opts _ = SCArray+ { scTitle = ""+ , scDescription = Nothing+ , scNullable = False+ , scItems = [toSchemaPrim opts (Proxy :: Proxy a)]+ , scLowerBound = Nothing+ , scUpperBound = Nothing+ }++instance (JSONSchemaPrim a) => JSONSchemaPrim (Map String a) where+ toSchemaPrim opts _ = SCObject+ { scTitle = ""+ , scDescription = Nothing+ , scNullable = False+ , scProperties = []+ , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))]+ , scRequired = []+ }++instance (JSONSchemaPrim a) => JSONSchemaPrim (HashMap String a) where+ toSchemaPrim opts _ = SCObject+ { scTitle = ""+ , scDescription = Nothing+ , scNullable = False+ , scProperties = []+ , scPatternProps = [(".*", toSchemaPrim opts (Proxy :: Proxy a))]+ , scRequired = []+ }++instance (Typeable a, JSONSchemaGen a) => JSONSchemaPrim a where+ toSchemaPrim opts a = SCRef+ { scReference = maybe (scId $ toSchema opts a) Text.pack $ Map.lookup (typeOf (undefined :: a)) (typeRefMap opts)+ , scNullable = False+ }+#endif++--------------------------------------------------------------------------------++class IsNullable f where+ isNullable :: Proxy (f a) -> Bool++#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-} IsNullable (K1 i (Maybe a)) where+ isNullable _ = True++instance {-# OVERLAPPABLE #-} IsNullable (K1 i a) where+ isNullable _ = False+#else+instance IsNullable (K1 i (Maybe a)) where+ isNullable _ = True++instance IsNullable (K1 i a) where+ isNullable _ = False+#endif++--------------------------------------------------------------------------------++class IsRecord (f :: * -> *) isRecord | f -> isRecord++#if __GLASGOW_HASKELL__ >= 710+instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord+instance {-# OVERLAPPING #-} IsRecord (M1 S NoSelector f) False+instance {-# OVERLAPPABLE #-} (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord+instance IsRecord (K1 i c) True+instance IsRecord U1 False+#else+instance (IsRecord f isRecord) => IsRecord (f :*: g) isRecord+instance IsRecord (M1 S NoSelector f) False+instance (IsRecord f isRecord) => IsRecord (M1 S c f) isRecord+instance IsRecord (K1 i c) True+instance IsRecord U1 False+#endif++--------------------------------------------------------------------------------++class AllNullary (f :: * -> *) allNullary | f -> allNullary++instance ( AllNullary a allNullaryL+ , AllNullary b allNullaryR+ , And allNullaryL allNullaryR allNullary+ ) => AllNullary (a :+: b) allNullary+instance AllNullary a allNullary => AllNullary (M1 i c a) allNullary+instance AllNullary (a :*: b) False+instance AllNullary (K1 i c) False+instance AllNullary U1 True++--------------------------------------------------------------------------------++data True+data False++class And bool1 bool2 bool3 | bool1 bool2 -> bool3++instance And True True True+instance And False False False+instance And False True False+instance And True False False++--------------------------------------------------------------------------------+
+ src/Data/JSON/Schema/Generator/Types.hs view
@@ -0,0 +1,144 @@+module Data.JSON.Schema.Generator.Types+ ( Schema (..)+ , SchemaChoice (..)+ , scString+ , scInteger+ , scNumber+ , scBoolean+ ) where++import Data.Text (Text)++--------------------------------------------------------------------------------++-- | A schema for a JSON value.+--+data Schema =+ SCSchema+ { scId :: !Text+ , scUsedSchema :: !Text+ , scSchemaType :: !Schema+ , scDefinitions :: ![(Text, Schema)]+ }+ | SCString+ { scDescription :: !(Maybe Text)+ , scNullable :: !Bool+ , scFormat :: !(Maybe Text)+ , scLowerBound :: !(Maybe Integer)+ , scUpperBound :: !(Maybe Integer)+ }+ | SCInteger+ { scDescription :: !(Maybe Text)+ , scNullable :: !Bool+ , scLowerBound :: !(Maybe Integer)+ , scUpperBound :: !(Maybe Integer)+ }+ | SCNumber+ { scDescription :: !(Maybe Text)+ , scNullable :: !Bool+ , scLowerBound :: !(Maybe Integer)+ , scUpperBound :: !(Maybe Integer)+ }+ | SCBoolean+ { scDescription :: !(Maybe Text)+ , scNullable :: !Bool+ }+ | SCConst+ { scTitle :: !Text+ , scDescription :: !(Maybe Text)+ , scValue :: !Text+ }+ | SCObject+ { scTitle :: !Text+ , scDescription :: !(Maybe Text)+ , scNullable :: !Bool+ , scProperties :: ![(Text, Schema)]+ , scPatternProps :: ![(Text, Schema)]+ , scRequired :: ![Text]+ }+ | SCArray+ { scTitle :: !Text+ , scDescription :: !(Maybe Text)+ , scNullable :: !Bool+ , scItems :: ![Schema]+ , scLowerBound :: !(Maybe Integer)+ , scUpperBound :: !(Maybe Integer)+ }+ | SCOneOf+ { scTitle :: !Text+ , scDescription :: !(Maybe Text)+ , scNullable :: !Bool+ , scChoices :: ![SchemaChoice]+ }+ | SCRef+ { scReference :: !Text+ , scNullable :: !Bool+ }+ | SCNull+ deriving (Show)++-- | A sum encoding for ADT.+--+data SchemaChoice =+ SCChoiceEnum+ { sctName :: !Text -- constructor name.+ , sctTitle :: !Text -- an arbitrary text. e.g. Types.UnitType1.UnitData11.+ }+ -- ^ Encoding for constructors that are all unit type.+ -- e.g. "test": {"enum": ["xxx", "yyy", "zzz"]}+ | SCChoiceArray+ { sctName :: !Text -- constructor name.+ , sctTitle :: !Text -- an arbitrary text. e.g. Types.ProductType1.ProductData11.+ , sctArray :: ![Schema] -- parametes of constructor.+ }+ -- ^ Encoding for constructors that are non record type.+ -- e.g. "test": [{"tag": "xxx", "contents": []},...] or "test": [{"xxx": [],},...]+ | SCChoiceMap+ { sctName :: !Text -- constructor name.+ , sctTitle :: !Text -- an arbitrary text. e.g. Types.RecordType1.RecordData11.+ , sctMap :: ![(Text, Schema)] -- list of record field name and schema in this constructor.+ , sctRequired :: ![Text] -- required field names.+ }+ -- ^ Encoding for constructos that are record type.+ -- e.g. "test": [{"tag": "xxx", "contents": {"aaa": "yyy",...}},...] or "test": [{"xxx": []},...]+ deriving (Show)++-- ^ A smart consturctor for String.+--+scString :: Schema+scString = SCString+ { scDescription = Nothing+ , scNullable = False+ , scFormat = Nothing+ , scLowerBound = Nothing+ , scUpperBound = Nothing+ }++-- ^ A smart consturctor for Integer.+--+scInteger :: Schema+scInteger = SCInteger+ { scDescription = Nothing+ , scNullable = False+ , scLowerBound = Nothing+ , scUpperBound = Nothing+ }++-- ^ A smart consturctor for Number.+--+scNumber :: Schema+scNumber = SCNumber+ { scDescription = Nothing+ , scNullable = False+ , scLowerBound = Nothing+ , scUpperBound = Nothing+ }++-- ^ A smart consturctor for Boolean.+--+scBoolean :: Schema+scBoolean = SCBoolean+ { scDescription = Nothing+ , scNullable = False+ }+
+ tests/Main.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Control.Applicative ((<*>), pure)+import Control.Arrow ((&&&))+import Control.Monad (forM, forM_)+import Control.Monad.Trans.State+import qualified Data.Aeson as A+import qualified Data.Aeson.TH as A+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.JSON.Schema.Generator as G+import qualified Data.List as List+import Data.Map (fromList)+import Data.Monoid ((<>))+import Data.Proxy (Proxy(Proxy))+import Data.Typeable (typeOf)+import GHC.Generics+import System.Exit (ExitCode(ExitSuccess), exitWith)+import System.IO (Handle, IOMode(WriteMode), hClose, hPutStr, hPutStrLn, withFile)+import System.Process (CreateProcess(..), CmdSpec(RawCommand), StdStream(CreatePipe, Inherit)+ , createProcess, system, waitForProcess)++import Types+import Values++--+-- Instances+--++instance G.JSONSchemaGen RecordType1+instance G.JSONSchemaGen RecordType2+instance G.JSONSchemaGen ProductType1+instance G.JSONSchemaGen ProductType2+instance G.JSONSchemaGen UnitType1+instance G.JSONSchemaGen UnitType2+instance G.JSONSchemaGen MixType1++--instance G.JSONSchemaPrim UnitType2 where+-- toSchemaPrim opts _ = G.scSchemaType . G.toSchema opts $ (Proxy :: Proxy UnitType2)++--+-- TestData+--++data TestDatum =+ forall a. (Generic a, A.GToJSON (Rep a), SchemaName (Rep a))+ => TestDatum { tdName :: String+ , tdValue :: a+ }++testDatum :: (Generic a, A.GToJSON (Rep a), SchemaName (Rep a)) => String -> a -> TestDatum+testDatum name p = TestDatum name p++testData :: [TestDatum]+testData =+ [ TestDatum "recordData11" recordType11+ , testDatum "recordData12" recordType22+ , testDatum "productData11" productData11+ , testDatum "productData12" productData12+ , testDatum "unitData1" unitData1+ , testDatum "unitData2" unitData2+ , testDatum "unitData3" unitData3+ , testDatum "mixData11" mixData11+ , testDatum "mixData12" mixData12+ , testDatum "mixData13" mixData13+ ]++--+-- Encoder+--++aesonOptions :: Bool -> Bool -> A.SumEncoding -> A.Options+aesonOptions allNullary omitNothing sumEncoding = A.defaultOptions+ { A.allNullaryToStringTag = allNullary+ , A.omitNothingFields = omitNothing+ , A.sumEncoding = sumEncoding+ }++optPatterns :: [A.Options]+optPatterns =+ [ aesonOptions True True+ , aesonOptions True False+ , aesonOptions False True+ , aesonOptions False False+ ]+ <*>+ [ A.defaultTaggedObject+ , A.ObjectWithSingleField+ , A.TwoElemArray+ ]++encode :: (Generic a, A.GToJSON (Rep a)) => A.Options -> a -> BL.ByteString+encode opt a = A.encode (A.genericToJSON opt a)++--+-- Print values as json in python+--++optToStr :: String -> A.Options -> String+optToStr symbol A.Options { A.allNullaryToStringTag = a, A.omitNothingFields = b, A.sumEncoding = c } =+ "# " ++ symbol ++ " (allNullaryToStringTag: " ++ show a+ ++ ", omitNothingFields: " ++ show b+ ++ ", sumEncoding: " ++ showC c ++ ")"++showC :: A.SumEncoding -> String+showC A.TwoElemArray = "array"+showC A.ObjectWithSingleField = "object"+showC _ = "tag"++pairsOptSymbol :: [A.Options] -> String -> [(A.Options, String)]+pairsOptSymbol opts name =+ fst . flip runState (0 :: Int) $ forM opts $ \opt -> do+ n <- fmap (+ 1) get+ put $! n+ return (opt, name ++ "_" ++ show n)++printValueAsJson :: (Generic a, A.GToJSON (Rep a)) => Handle -> [A.Options] -> String -> a -> IO ()+printValueAsJson h opts name value =+ forM_ (pairsOptSymbol opts name) . uncurry $ \opt symbol -> do+ hPutStrLn h $ optToStr symbol opt+ hPutStr h $ symbol ++ " = json.loads('"+ BL.hPutStr h $ Main.encode opt value+ hPutStrLn h "')"+ hPutStrLn h ""++printValueAsJsonInPython :: FilePath -> IO ()+printValueAsJsonInPython path = do+ withFile path WriteMode $ \h -> do+ hPutStrLn h "# -*- coding: utf-8 -*-"+ hPutStrLn h "import json"+ hPutStrLn h ""+ forM_ testData $ \(TestDatum name value) ->+ printValueAsJson h optPatterns name value++--+-- Print type definitions as schema in individualy json files+--++printTypeAsSchema :: (Generic a, G.JSONSchemaGen a, SchemaName (Rep a))+ => FilePath -> G.Options -> [A.Options] -> Proxy a -> IO ()+printTypeAsSchema dir opts aoptss a = do+ forM_ aoptss $ \aopts -> do+ let fa = fmap from a+ let filename = schemaName opts aopts fa+ let suffix = "." ++ schemaSuffix opts aopts fa+ let path = dir ++ "/" ++ filename+ let opts' = opts { G.schemaIdSuffix = suffix }+ withFile path WriteMode $ \h -> do+ BL.hPutStrLn h $ G.generate' opts' aopts a++class SchemaName f where+ schemaName :: G.Options -> A.Options -> Proxy (f a) -> FilePath+ schemaSuffix :: G.Options -> A.Options -> Proxy (f a) -> String++instance (Datatype d) => SchemaName (D1 d f) where+ schemaName opts aopts p = modName ++ "." ++ typName ++ "." ++ schemaSuffix opts aopts p+ where+ modName = moduleName (undefined :: D1 d f p)+ typName = datatypeName (undefined :: D1 d f p)+ schemaSuffix opts A.Options { A.allNullaryToStringTag = a, A.omitNothingFields = b, A.sumEncoding = c } _ =+ show a ++ "." ++ show b ++ "." ++ showC c ++ G.schemaIdSuffix opts++schemaOptions :: G.Options+schemaOptions = G.defaultOptions+ { G.baseUri = "https://github.com/yuga/jsonschema-gen/tests/"+ , G.schemaIdSuffix = ".json"+ , G.typeRefMap = fromList+ [ (typeOf (undefined :: RecordType2), "https://github.com/yuga/jsonschema-gen/tests/Types.RecordType2.True.False.tag.json")+ , (typeOf (undefined :: ProductType2), "https://github.com/yuga/jsonschema-gen/tests/Types.ProductType2.True.False.tag.json")+ ]+ }++schemaOptions' :: G.Options+schemaOptions'= schemaOptions+ { G.typeRefMap = fromList+ [ (typeOf (undefined :: RecordType2), "https://github.com/yuga/jsonschema-gen/tests/Types.RecordType2.True.False.tag.json")+ , (typeOf (undefined :: ProductType2), "https://github.com/yuga/jsonschema-gen/tests/Types.ProductType2.True.False.tag.json")+ , (typeOf (undefined :: UnitType2), "https://github.com/yuga/jsonschema-gen/tests/Types.UnitType2.True.False.tag.json")+ ]+ , G.fieldTypeMap = fromList [("recordField1A", G.PropType (Proxy :: Proxy UnitType2))]+ }++printTypeAsSchemaInJson :: FilePath -> IO ()+printTypeAsSchemaInJson dir = do+ printTypeAsSchema dir schemaOptions' optPatterns (Proxy :: Proxy RecordType1)+ printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy RecordType2)+ printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy ProductType1)+ printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy ProductType2)+ printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy UnitType1)+ printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy UnitType2)+ printTypeAsSchema dir schemaOptions optPatterns (Proxy :: Proxy MixType1)++--+-- Print jsonschema validator in python+--++convertToPythonLoadingSchema :: (Generic a, SchemaName (Rep a)) => G.Options -> [A.Options] -> Proxy a -> ([String], [String])+convertToPythonLoadingSchema opts aoptss a =+ let fa = fmap from a+ toLoader aopts =+ let filename = schemaName opts aopts fa+ symbol = "schema_" ++ map dotToLowline filename+ in (symbol ++ " = json.load(codecs.open(schemaPath + '" ++ filename ++ "', 'r', 'utf-8'))")+ toStore aopts =+ let filename = schemaName opts aopts fa+ symbol = "schema_" ++ map dotToLowline filename+ in ("'" ++ G.baseUri opts ++ filename ++ "' : " ++ symbol)+ in (map toLoader &&& map toStore) aoptss++dotToLowline :: Char -> Char+dotToLowline '.' = '_'+dotToLowline c = c++printLoadSchemas :: Handle -> IO ()+printLoadSchemas h = do+ let (loader, store) = convertToPythonLoadingSchema schemaOptions' optPatterns (Proxy :: Proxy RecordType1)+ <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy RecordType2)+ <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy ProductType1)+ <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy ProductType2)+ <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy UnitType1)+ <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy UnitType2)+ <> convertToPythonLoadingSchema schemaOptions optPatterns (Proxy :: Proxy MixType1)+ hPutStrLn h "schemaPath = os.path.dirname(os.path.realpath(__file__)) + '/'"+ mapM_ (hPutStrLn h) loader+ hPutStrLn h ""+ mapM_ (hPutStrLn h . concat) . chunk 2 $ beginmap : (List.intersperse comma store) ++ [endofmap]+ where+ chunk n = takeWhile (not . null) . map (take n) . iterate (drop n)+ beginmap = "selfStore = { "+ comma = " , "+ endofmap = " }"++printValidate :: Handle -> [A.Options] -> IO ()+printValidate h aoptss = do+ hPutStrLn h "def mkValidator(schema):"+ hPutStrLn h " resolver = jsonschema.RefResolver(schema[u'id'], schema, store=selfStore)"+ hPutStrLn h " validator = jsonschema.Draft4Validator(schema, resolver=resolver)"+ hPutStrLn h " return validator"+ hPutStrLn h ""+ forM_ testData $ \(TestDatum name value) ->+ forM_ (pairsOptSymbol aoptss name) . uncurry $ \aopts dataSymbol -> do+ let schemaFilename = schemaName schemaOptions aopts (fmap from . pure $ value)+ let schemaSymbol = map dotToLowline schemaFilename+ hPutStrLn h $ "mkValidator(" ++ "schema_" ++ schemaSymbol ++ ").validate(jsondata." ++ dataSymbol ++ ")"++printValidatorInPython :: FilePath -> IO ()+printValidatorInPython path = do+ withFile path WriteMode $ \h -> do+ hPutStrLn h "# -*- coding: utf-8 -*-"+ hPutStrLn h "import codecs"+ hPutStrLn h "import json"+ hPutStrLn h "import jsondata"+ hPutStrLn h "import jsonschema"+ hPutStrLn h "import os"+ hPutStrLn h ""+ printLoadSchemas h+ hPutStrLn h ""+ printValidate h optPatterns++--+-- Run Test+--++pythonProcess :: FilePath -> CreateProcess+pythonProcess dir =+ CreateProcess+ { cmdspec = RawCommand "python" [dir ++ "/jsonvalidator.py"]+ , cwd = Nothing+ , env = Nothing+ , std_in = CreatePipe+ , std_out = Inherit+ , std_err = Inherit+ , close_fds = False+ , create_group = False+#if MIN_VERSION_process(1,2,0)+ , delegate_ctlc = True+#endif+ }++runTest :: FilePath -> IO ()+runTest dir = do+ handles <- createProcess $ pythonProcess dir+ case handles of+ (Just hIn, _, _, hP) -> do+ hClose hIn+ ec <- waitForProcess hP+ exitWith ec+ _ -> fail $ "Failed to launch python"++--+-- Main+--++main :: IO ()+main = do+ let dir = "tests"+ printValueAsJsonInPython (dir ++ "/jsondata.py")+ printTypeAsSchemaInJson (dir)+ printValidatorInPython (dir ++ "/jsonvalidator.py")+ ec <- system "python --version"+ case ec of+ ExitSuccess -> runTest dir+ _ -> putStrLn "If you have 'python' in your PATH, this test runs jsonvalidator.py"+
+ tests/Types.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Types where++import Data.Typeable+import GHC.Generics++data RecordType1 =+ RecordData11+ { recordField11 :: String+ , recordField12 :: Int+ , recordField13 :: Double+ , recordField14 :: Maybe String+ , recordField15 :: RecordType2+ , recordField16 :: [String]+ , recordField17 :: [Int]+ , recordField18 :: [Int]+ , recordField19 :: Maybe Int+ , recordField1A :: String+ }+ deriving (Show, Generic)++data RecordType2 =+ RecordData21+ { recordField21 :: String+ , recordField22 :: Maybe String+ }+ | RecordData22+ { recordField21 :: String+ , recordField22 :: Maybe String+ , recordField23 :: Int+ }+ deriving (Show, Generic, Typeable)++data ProductType1 = ProductData11 String Int Double (Maybe String) ProductType2+ deriving (Show, Generic)++data ProductType2 = ProductData21 String (Maybe String)+ | ProductData22 String (Maybe String) Int+ deriving (Show, Generic, Typeable)++data UnitType1 = UnitData1 | UnitData2 | UnitData3+ deriving (Show, Generic, Typeable)++data UnitType2 = UnitData21 | UnitData22 | UnitData23+ deriving (Show, Generic, Typeable)++data MixType1 =+ MixData11+ | MixData12 String (Maybe String)+ | MixData13+ { recordField31 :: String+ , recordField32 :: Maybe String+ , recordField33 :: Int+ }+ deriving (Show, Generic)+