Permalink
Browse files

Implement code generator

and tons of other changes
  • Loading branch information...
1 parent b037f6a commit 2e50321a2f843d6a96b3b7c43af42c9f306b2d93 @timjb committed Aug 23, 2012
View
@@ -18,7 +18,7 @@ cabal-version: >=1.8
library
ghc-options: -Wall
hs-source-dirs: src
- exposed-modules: Data.Aeson.Schema, Data.Aeson.Schema.Validator, Data.Aeson.Schema.Choice
+ exposed-modules: Data.Aeson.Schema, Data.Aeson.Schema.Validator, Data.Aeson.Schema.CodeGen, Data.Aeson.Schema.Choice, Data.Aeson.Schema.Helpers
other-modules: Data.Aeson.Schema.Choice.TH
extensions: OverloadedStrings
build-depends: base == 4.5.*,
@@ -29,7 +29,11 @@ library
unordered-containers >= 0.1.3.0,
containers,
attoparsec >= 0.8.6.1,
- template-haskell
+ template-haskell,
+ mtl >= 2.1.1 && < 3,
+ transformers >= 0.3.0.0,
+ QuickCheck >= 2.4.2 && < 2.5,
+ syb >= 0.3.6.1
test-suite tests
ghc-options: -Wall
@@ -42,6 +46,7 @@ test-suite tests
text,
vector,
containers,
+ hashable,
unordered-containers,
aeson-schema,
aeson-qq,
@@ -52,4 +57,7 @@ test-suite tests
HUnit >= 1.2.4.3,
test-framework-quickcheck2 >= 0.2.12.2 && < 0.3,
QuickCheck >= 2.4.2 && < 2.5,
- bytestring
+ bytestring,
+ ghc,
+ ghc-paths,
+ temporary
View
@@ -7,21 +7,21 @@
"type" : {
"type" : ["string", "array"],
"items" : {
- "type" : ["string", "#"]
+ "type" : ["string", { "$ref" : "#" }]
},
"uniqueItems" : true,
"default" : "any"
},
"properties" : {
"type" : "object",
- "additionalProperties" : "#",
+ "additionalProperties" : { "$ref" : "#" },
"default" : {}
},
"items" : {
- "type" : ["#", "array"],
- "items" : "#",
+ "type" : [{ "$ref" : "#" }, "array"],
+ "items" : { "$ref" : "#" },
"default" : {}
},
@@ -31,16 +31,16 @@
},
"additionalProperties" : {
- "type" : ["#", "boolean"],
+ "type" : [{ "$ref" : "#" }, "boolean"],
"default" : {}
},
"additionalItems" : {
- "type" : ["#", "boolean"],
+ "type" : [{ "$ref" : "#" }, "boolean"],
"default" : {}
},
"requires" : {
- "type" : ["string", "#"]
+ "type" : ["string", { "$ref" : "#" }]
},
"minimum" : {
@@ -113,16 +113,16 @@
},
"disallow" : {
- "type" : ["string", "array", "#"],
+ "type" : ["string", "array", { "$ref" : "#" }],
"items" : {
- "type" : ["string", "#"]
+ "type" : ["string", { "$ref" : "#" }]
},
"uniqueItems" : true
},
"extends" : {
- "type" : ["#", "array"],
- "items" : "#",
+ "type" : [{ "$ref" : "#" }, "array"],
+ "items" : { "$ref" : "#" },
"default" : {}
}
},
View
@@ -1,7 +1,8 @@
{-# LANGUAGE FlexibleInstances, TupleSections, EmptyDataDecls #-}
module Data.Aeson.Schema
- ( Schema (..)
+ ( SchemaType (..)
+ , Schema (..)
, V3
, Pattern (..)
, mkPattern
@@ -47,13 +48,36 @@ instance FromJSON Pattern where
mkPattern :: (Monad m) => Text -> m Pattern
mkPattern t = liftM (Pattern t) $ makeRegexM (unpack t)
+data SchemaType = StringType
+ | NumberType
+ | IntegerType
+ | BooleanType
+ | ObjectType
+ | ArrayType
+ | NullType
+ | AnyType
+ deriving (Eq, Show, Read)
+
+instance FromJSON SchemaType where
+ parseJSON (String t) = case t of
+ "string" -> return StringType
+ "number" -> return NumberType
+ "integer" -> return IntegerType
+ "boolean" -> return BooleanType
+ "object" -> return ObjectType
+ "array" -> return ArrayType
+ "null" -> return NullType
+ "any" -> return AnyType
+ _ -> fail $ "not a valid type: " ++ unpack t
+ parseJSON _ = fail "not a string"
+
data Schema version ref = Schema
- { schemaType :: [Choice2 Text (Schema version ref)]
+ { schemaType :: [Choice2 SchemaType (Schema version ref)]
, schemaProperties :: Map (Schema version ref)
, schemaPatternProperties :: [(Pattern, Schema version ref)]
- , schemaAdditionalProperties :: Choice3 Text Bool (Schema version ref)
- , schemaItems :: Maybe (Choice3 Text (Schema version ref) [Schema version ref])
- , schemaAdditionalItems :: Choice3 Text Bool (Schema version ref)
+ , schemaAdditionalProperties :: Choice2 Bool (Schema version ref)
+ , schemaItems :: Maybe (Choice2 (Schema version ref) [Schema version ref])
+ , schemaAdditionalItems :: Choice2 Bool (Schema version ref)
, schemaRequired :: Bool
, schemaDependencies :: Map (Choice2 [Text] (Schema version ref))
, schemaMinimum :: Maybe Number
@@ -73,7 +97,7 @@ data Schema version ref = Schema
, schemaDescription :: Maybe Text
, schemaFormat :: Maybe Text
, schemaDivisibleBy :: Maybe Number
- , schemaDisallow :: [Choice2 Text (Schema version ref)]
+ , schemaDisallow :: [Choice2 SchemaType (Schema version ref)]
, schemaExtends :: [Schema version ref]
, schemaId :: Maybe Text
, schemaDRef :: Maybe ref -- ^ $ref
@@ -87,9 +111,9 @@ instance Functor (Schema version) where
{ schemaType = mapChoice2 id (fmap f) <$> schemaType s
, schemaProperties = fmap f <$> schemaProperties s
, schemaPatternProperties = second (fmap f) <$> schemaPatternProperties s
- , schemaAdditionalProperties = mapChoice3 id id (fmap f) (schemaAdditionalProperties s)
- , schemaItems = mapChoice3 id (fmap f) (fmap $ fmap f) <$> schemaItems s
- , schemaAdditionalItems = mapChoice3 id id (fmap f) (schemaAdditionalItems s)
+ , schemaAdditionalProperties = mapChoice2 id (fmap f) (schemaAdditionalProperties s)
+ , schemaItems = mapChoice2 (fmap f) (fmap $ fmap f) <$> schemaItems s
+ , schemaAdditionalItems = mapChoice2 id (fmap f) (schemaAdditionalItems s)
, schemaDependencies = mapChoice2 id (fmap f) <$> schemaDependencies s
, schemaDisallow = mapChoice2 id (fmap f) <$> schemaDisallow s
, schemaExtends = fmap f <$> schemaExtends s
@@ -100,9 +124,9 @@ instance Foldable (Schema version) where
foldr f start s = ffoldr (ffoldr f) (choice2of2s $ schemaType s)
. ffoldr (ffoldr f) (schemaProperties s)
. ffoldr (ffoldr f) (map snd $ schemaPatternProperties s)
- . foldChoice3of3 (ffoldr f) (schemaAdditionalProperties s)
- . ffoldr (\items -> foldChoice2of3 (ffoldr f) items . foldChoice3of3 (ffoldr $ ffoldr f) items) (schemaItems s)
- . foldChoice3of3 (ffoldr f) (schemaAdditionalItems s)
+ . foldChoice2of2 (ffoldr f) (schemaAdditionalProperties s)
+ . ffoldr (\items -> foldChoice1of2 (ffoldr f) items . foldChoice2of2 (ffoldr $ ffoldr f) items) (schemaItems s)
+ . foldChoice2of2 (ffoldr f) (schemaAdditionalItems s)
. ffoldr (ffoldr f) (choice2of2s $ toList $ schemaDependencies s)
. ffoldr (ffoldr f) (choice2of2s $ schemaDisallow s)
. ffoldr (ffoldr f) (schemaExtends s)
@@ -111,21 +135,21 @@ instance Foldable (Schema version) where
where
ffoldr :: (Foldable t) => (a -> b -> b) -> t a -> b -> b
ffoldr g = flip $ foldr g
- foldChoice2of3 :: (a -> b -> b) -> Choice3 x a y -> b -> b
- foldChoice2of3 g (Choice2of3 c) = g c
- foldChoice2of3 _ _ = id
- foldChoice3of3 :: (a -> b -> b) -> Choice3 x y a -> b -> b
- foldChoice3of3 g (Choice3of3 c) = g c
- foldChoice3of3 _ _ = id
+ foldChoice1of2 :: (a -> b -> b) -> Choice2 a x -> b -> b
+ foldChoice1of2 g (Choice1of2 c) = g c
+ foldChoice1of2 _ _ = id
+ foldChoice2of2 :: (a -> b -> b) -> Choice2 x a -> b -> b
+ foldChoice2of2 g (Choice2of2 c) = g c
+ foldChoice2of2 _ _ = id
empty :: Schema version ref
empty = Schema
- { schemaType = []
+ { schemaType = [Choice1of2 AnyType]
, schemaProperties = H.empty
, schemaPatternProperties = []
- , schemaAdditionalProperties = Choice2of3 True
+ , schemaAdditionalProperties = Choice1of2 True
, schemaItems = Nothing
- , schemaAdditionalItems = Choice2of3 True
+ , schemaAdditionalItems = Choice1of2 True
, schemaRequired = False
, schemaDependencies = H.empty
, schemaMinimum = Nothing
@@ -159,9 +183,9 @@ instance (FromJSON ref) => FromJSON (Schema V3 ref) where
Schema <$> (parseSingleOrArray =<< parseFieldDefault "type" "any")
<*> parseFieldDefault "properties" emptyObject
<*> (parseFieldDefault "patternProperties" emptyObject >>= mapM (\(k, v) -> fmap (,v) (mkPattern k)) . H.toList)
- <*> (parseField "additionalProperties" .!= Choice2of3 True)
+ <*> (parseField "additionalProperties" .!= Choice1of2 True)
<*> parseField "items"
- <*> (parseField "additionalItems" .!= Choice2of3 True)
+ <*> (parseField "additionalItems" .!= Choice1of2 True)
<*> parseFieldDefault "required" (Bool False)
<*> (traverse parseDependency =<< parseFieldDefault "dependencies" emptyObject)
<*> parseField "minimum"
@@ -5,8 +5,10 @@ module Data.Aeson.Schema.Choice.TH
) where
import Control.Monad (forM)
+import Control.Applicative ((<$>))
import Language.Haskell.TH
import Data.Aeson (ToJSON (..), FromJSON (..))
+import Test.QuickCheck (Arbitrary (..), oneof)
import Control.Applicative (Alternative (..))
generateChoice :: Int -> Q [Dec]
@@ -21,17 +23,23 @@ generateChoice n = do
let tyCon = appConT tyName tyParams
let genClassConstraints c = cxt $ map (classP c . singleton) tyParams
instToJSON <- instanceD (genClassConstraints ''ToJSON)
- (appT (conT ''ToJSON) tyCon)
+ (conT ''ToJSON `appT` tyCon)
[ funD 'toJSON $ zipWith genToJSONClause conNames tyParamNames ]
instFromJSON <- instanceD (genClassConstraints ''FromJSON)
- (appT (conT ''FromJSON) tyCon)
+ (conT ''FromJSON `appT` tyCon)
[ let v = mkName "v" in
funD 'parseJSON [clause [varP v]
- (normalB $ foldl (\a b -> [e|(<|>)|] `appE` a `appE` b) (varE 'empty)
- $ map (\con -> varE 'fmap `appE` conE con `appE` (varE 'parseJSON `appE` (varE v))) conNames)
+ (normalB $ foldl (\a b -> [| $a <|> $b |]) [| empty |]
+ $ map (\con -> [| $(conE con) <$> parseJSON $(varE v) |]) conNames)
[]
]
]
+ instArbitrary <- instanceD (genClassConstraints ''Arbitrary)
+ (conT ''Arbitrary `appT` tyCon)
+ [ valD (varP 'arbitrary)
+ (normalB $ varE 'oneof `appE` listE (map (\con -> [| $(conE con) <$> arbitrary |]) conNames))
+ []
+ ]
let choiceN = mkName $ "choice" ++ show n
let resultT = mkName "res"
choiceFunDec <- sigD choiceN
@@ -73,7 +81,7 @@ generateChoice n = do
, noBindS (varE c)
]) []]
return [typeDec, funDef]
- return $ [dataDec, instToJSON, instFromJSON, choiceFunDec, choiceFun, mapChoiceFunDec, mapChoiceFun] ++ choiceIofNFuns
+ return $ [dataDec, instToJSON, instFromJSON, instArbitrary, choiceFunDec, choiceFun, mapChoiceFunDec, mapChoiceFun] ++ choiceIofNFuns
where
singleton :: a -> [a]
singleton = (:[])
Oops, something went wrong.

0 comments on commit 2e50321

Please sign in to comment.