aeson-schema 0.2.0.0 → 0.2.0.1
raw patch · 4 files changed
+63/−18 lines, 4 filesdep +directorydep +filepathdep ~QuickCheck
Dependencies added: directory, filepath
Dependency ranges changed: QuickCheck
Files
- aeson-schema.cabal +6/−4
- src/Data/Aeson/Schema/CodeGen.hs +7/−4
- src/Data/Aeson/Schema/CodeGenM.hs +38/−4
- test/TestSuite.hs +12/−6
aeson-schema.cabal view
@@ -1,5 +1,5 @@ name: aeson-schema-version: 0.2.0.0+version: 0.2.0.1 synopsis: Haskell JSON schema validator and parser generator -- description: homepage: https://github.com/timjb/aeson-schema@@ -13,7 +13,7 @@ source-repository head type: git- location: git://github.com/timjb/haskell-aeson-schema.git+ location: git://github.com/timjb/aeson-schema.git library ghc-options: -Wall@@ -39,7 +39,7 @@ th-lift >= 0.5.5 && < 0.6, mtl >= 2 && < 3, transformers >= 0.3.0.0,- QuickCheck >= 2.4.2 && < 2.5,+ QuickCheck >= 2.4.2 && < 2.7, syb >= 0.3.6.1, bytestring @@ -67,4 +67,6 @@ bytestring, hint, temporary,- mtl+ mtl,+ filepath,+ directory
src/Data/Aeson/Schema/CodeGen.hs view
@@ -308,7 +308,7 @@ (doE $ checkers ++ [noBindS parseAdditional]) [| fail "not an object" |] let typ = [t| M.Map Text $(additionalType) |]- let to = [| Object . HM.fromList . map $(additionalTo) . M.toList |]+ let to = [| Object . HM.fromList . map (second $(additionalTo)) . M.toList |] return ((typ, parser, to), True) _ -> do let validatesStmt = assertValidates (lift schema) [| Object $(varE obj) |]@@ -347,9 +347,12 @@ , Nothing ) conName <- maybe (qNewName $ firstUpper $ unpack name) return decName+ recordDeclaration <- runQ $ genRecord conName+ (zip3 propertyNames+ (map (fmap replaceHiddenModules) propertyTypes)+ (map (schemaDescription . snd) propertiesList))+ derivingTypeclasses let typ = conT conName- let dataCon = recC conName $ zipWith (\pname ptyp -> (pname,NotStrict,) <$> ptyp) propertyNames propertyTypes- dataDec <- runQ $ dataD (cxt []) conName [] [dataCon] derivingTypeclasses let parser = foldl (\oparser propertyParser -> [| $oparser <*> $propertyParser |]) [| pure $(conE conName) |] propertyParsers fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` typ) [ funD (mkName "parseJSON") -- cannot use a qualified name here@@ -364,7 +367,7 @@ ] ] tell- [ Declaration dataDec Nothing+ [ recordDeclaration , Declaration fromJSONInst Nothing , Declaration toJSONInst Nothing ]
src/Data/Aeson/Schema/CodeGenM.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-} module Data.Aeson.Schema.CodeGenM ( Declaration (..)@@ -7,9 +8,10 @@ , CodeGenM (..) , renderDeclaration , codeGenNewName+ , genRecord ) where -import Control.Applicative (Applicative (..))+import Control.Applicative (Applicative (..), (<$>)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.RWS.Lazy (MonadReader (..), MonadState (..), MonadWriter (..), RWST (..))@@ -17,10 +19,10 @@ import Data.Data (Data, Typeable) import Data.Function (on) import qualified Data.HashSet as HS-import Data.Monoid ((<>))-import Data.Text (Text)+import Data.Monoid ((<>), mconcat)+import Data.Text (Text, pack) import qualified Data.Text as T-import Language.Haskell.TH.Ppr (pprint)+import Language.Haskell.TH import Language.Haskell.TH.Syntax -- | A top-level declaration.@@ -80,3 +82,35 @@ instance MonadIO (CodeGenM s) where liftIO = qRunIO++-- ^ Generates a record data declaration where the fields may have descriptions for Haddock+genRecord :: Name -- ^ Type and constructor name+ -> [(Name, TypeQ, Maybe Text)] -- ^ Fields+ -> [Name] -- ^ Deriving typeclasses+ -> Q Declaration+genRecord name fields classes = Declaration <$> dataDec+ <*> (Just . recordBlock . map fieldLine <$> fields')+ where+ fields' :: Q [(Name, Type, Maybe Text)]+ fields' = mapM (\(fieldName, fieldType, fieldDesc) -> (fieldName,,fieldDesc) <$> fieldType) fields+ dataLine, derivingClause :: Text+ dataLine = "data " <> pack (nameBase name) <> " = " <> pack (nameBase name)+ derivingClause = "deriving (" <> T.intercalate ", " (map (\n -> maybe "" ((<> ".") . pack) (nameModule n) <> pack (nameBase n)) classes) <> ")"+ fieldLine :: (Name, Type, Maybe Text) -> Text+ fieldLine (fieldName, fieldType, fieldDesc) = mconcat+ [ pack (nameBase fieldName)+ , " :: "+ , pack (pprint fieldType)+ , maybe "" ((" " <>) . renderComment . ("^ " <>)) fieldDesc+ ]+ renderComment :: Text -> Text+ renderComment = T.intercalate "\n" . map ("-- " <>) . T.lines+ recordBlock :: [Text] -> Text+ recordBlock [] = dataLine <> " " <> derivingClause+ recordBlock (l:ls) = T.unlines $ [dataLine] ++ map indent (["{ " <> l] ++ map (", " <>) ls ++ ["} " <> derivingClause])+ indent :: Text -> Text+ indent = (" " <>)++ -- Template Haskell+ constructor = recC name $ map (\(fieldName, fieldType, _) -> (fieldName,NotStrict,) <$> fieldType) fields+ dataDec = dataD (cxt []) name [] [constructor] classes
test/TestSuite.hs view
@@ -1,14 +1,20 @@+import Control.Applicative ((<$>)) import Test.Framework import qualified Data.Aeson.Schema.Choice.Tests import qualified Data.Aeson.Schema.CodeGen.Tests import qualified Data.Aeson.Schema.Types.Tests import qualified Data.Aeson.Schema.Validator.Tests+import TestSuite.Types (readSchemaTests) main :: IO ()-main = defaultMain- [ testGroup "Data.Aeson.Schema.Types" Data.Aeson.Schema.Types.Tests.tests- , testGroup "Data.Aeson.Schema.Validator" Data.Aeson.Schema.Validator.Tests.tests- , buildTest $ fmap (testGroup "Data.Aeson.Schema.CodeGen") Data.Aeson.Schema.CodeGen.Tests.tests- , testGroup "Data.Aeson.Schema.Choice" Data.Aeson.Schema.Choice.Tests.tests- ]+main = do+ requiredTests <- readSchemaTests "test/test-suite/tests/draft3"+ optionalTests <- readSchemaTests "test/test-suite/tests/draft3/optional"+ let schemaTests = requiredTests ++ optionalTests+ defaultMain+ [ testGroup "Data.Aeson.Schema.Types" Data.Aeson.Schema.Types.Tests.tests+ , testGroup "Data.Aeson.Schema.Validator" $ Data.Aeson.Schema.Validator.Tests.tests schemaTests+ , buildTest $ testGroup "Data.Aeson.Schema.CodeGen" <$> Data.Aeson.Schema.CodeGen.Tests.tests schemaTests+ , testGroup "Data.Aeson.Schema.Choice" Data.Aeson.Schema.Choice.Tests.tests+ ]