aeson-schema 0.3.0.7 → 0.4.0.0

raw patch · 6 files changed

+142/−60 lines, 6 filesdep ~sybnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: syb

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• aeson-schema.cabal +7/−5
• src/Data/Aeson/Schema/CodeGen.hs +34/−31
• src/Data/Aeson/Schema/CodeGenM.hs +79/−2
• src/Data/Aeson/Schema/Helpers.hs +5/−12
• test/Data/Aeson/Schema/CodeGen/Tests.hs +12/−10

@@ -1,3 +1,8 @@+# 0.4.0.0++- Add Data.Aeson.Schema.CodeGenM.Options type which allows+  customisation of codegen output+ # 0.3.0.7 - 2015-07-15  - Bump upper bounds: Allow vector-0.11

@@ -1,12 +1,14 @@ name:                aeson-schema-version:             0.3.0.7+version:             0.4.0.0 synopsis:            Haskell JSON schema validator and parser generator description:         This library provides validation of JSON values against schemata. Given a schema, it can also produce data types corresponding to the schema and a parser.-homepage:            https://github.com/timjb/aeson-schema+homepage:            https://github.com/Fuuzetsu/aeson-schema license:             MIT license-file:        LICENSE-author:              Tim Baumann <tim@timbaumann.info>-maintainer:          Tim Baumann <tim@timbaumann.info>+author:              Tim Baumann, Mateusz Kowalczyk+maintainer:          Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>+copyright:           (c) 2012-2015 Tim Baumann+                     (c) 2015 Mateusz Kowalczyk category:            Data build-type:          Simple cabal-version:       >= 1.8@@ -17,7 +19,7 @@  source-repository head   type:                git-  location:            git://github.com/timjb/aeson-schema.git+  location:            git://github.com/Fuuzetsu/aeson-schema.git  library   ghc-options:         -Wall

@@ -15,7 +15,7 @@                                               (<|>)) import           Control.Arrow               (first, second) import           Control.Monad               (forM_, unless, when, zipWithM)-import           Control.Monad.RWS.Lazy      (MonadReader (..), +import           Control.Monad.RWS.Lazy      (MonadReader (..),                                               MonadWriter (..), evalRWST) import           Data.Aeson import           Data.Aeson.Types            (parse)@@ -51,51 +51,48 @@ instance (Lift k, Lift v) => Lift (M.Map k v) where   lift m = [| M.fromList $(lift $ M.toList m) |] --- | Needed modules that are not found by "getUsedModules".-extraModules :: [String]-extraModules =-  [ "Text.Regex" -- provides RegexMaker instances-  , "Text.Regex.PCRE.String" -- provides RegexLike instances, Regex type-  , "Data.Aeson.Types" -- Parser type-  , "Data.Ratio"-  ]- -- | Extracts all TH declarations getDecs :: Code -> [Dec] getDecs code = [ dec | Declaration dec _ <- code ]  -- | Generate data-types and FromJSON instances for all schemas generateTH :: Graph Schema Text -- ^ Set of schemas+           -> Options            -> Q ([Dec], M.Map Text Name) -- ^ Generated code and mapping from schema identifiers to type names-generateTH = fmap (first getDecs) . generate+generateTH g = fmap (first getDecs) . generate g  -- | Generated a self-contained module that parses and validates values of -- a set of given schemas. generateModule :: Text -- ^ Name of the generated module                -> Graph Schema Text -- ^ Set of schemas+               -> Options                -> Q (Text, M.Map Text Name) -- ^ Module code and mapping from schema identifiers to type names-generateModule modName = fmap (first $ renderCode . map rewrite) . generate+generateModule modName g opts = fmap (first $ renderCode . map rewrite) $ generate g opts   where     renderCode :: Code -> Text-    renderCode code = T.intercalate "\n\n" $ [modDec, T.intercalate "\n" imprts] ++ map renderDeclaration code+    renderCode code = T.intercalate "\n\n" $ [langExts <> ghcOpts, modDec, T.intercalate "\n" imprts] ++ map renderDeclaration code       where-        mods = sort $ extraModules ++ getUsedModules (getDecs code)+        mods = sort $ _extraModules opts ++ getUsedModules (getDecs code)         imprts = map (\m -> "import " <> pack m) mods         modDec = "module " <> modName <> " where"+        -- TH has no support for file-header pragmas so we splice the text in here+        mkHeaderPragmas t = T.intercalate "\n" . map (\s -> T.unwords ["{-#", t, s, "#-}"])+        langExts = mkHeaderPragmas "LANGUAGE" $ _languageExtensions opts+        ghcOpts = mkHeaderPragmas "OPTIONS_GHC" $ _ghcOptsPragmas opts     rewrite :: Declaration -> Declaration-    rewrite (Declaration dec text) = Declaration (replaceHiddenModules $ cleanPatterns dec) text+    rewrite (Declaration dec text) = Declaration (replaceHiddenModules (cleanPatterns dec) (_replaceModules opts)) text     rewrite a = a  -- | Generate a generalized representation of the code in a Haskell module-generate :: Graph Schema Text -> Q (Code, M.Map Text Name)-generate graph = swap <$> evalRWST (unCodeGenM $ generateTopLevel graph >> return typeMap) typeMap used+generate :: Graph Schema Text -> Options -> Q (Code, M.Map Text Name)+generate graph opts = swap <$> evalRWST (unCodeGenM $ generateTopLevel graph >> return typeMap) (opts, typeMap) used   where     (used, typeMap) = second M.fromList $ mapAccumL nameAccum HS.empty (M.keys graph)     nameAccum usedNames schemaName = second (schemaName,) $ swap $ codeGenNewName (firstUpper $ unpack schemaName) usedNames  generateTopLevel :: Graph Schema Text -> CodeGenM SchemaTypes () generateTopLevel graph = do-  typeMap <- ask+  (opts, typeMap) <- ask   graphN <- qNewName "graph"   when (nameBase graphN /= "graph") $ fail "name graph is already taken"   graphDecType <- runQ $ sigD graphN [t| Graph Schema Text |]@@ -106,7 +103,7 @@     ((typeQ, fromJsonQ, toJsonQ), defNewtype) <- generateSchema (Just typeName) name schema     when defNewtype $ do       let newtypeCon = normalC typeName [strictType notStrict typeQ]-      newtypeDec <- runQ $ newtypeD (cxt []) typeName [] newtypeCon derivingTypeclasses+      newtypeDec <- runQ $ newtypeD (cxt []) typeName [] newtypeCon (_derivingTypeclasses opts)       fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` conT typeName)         [ valD (varP $ mkName "parseJSON") (normalB [| fmap $(conE typeName) . $fromJsonQ |]) []         ]@@ -126,7 +123,7 @@                -> Schema Text                -> CodeGenM SchemaTypes ((TypeQ, ExpQ, ExpQ), Bool) -- ^ ((type of the generated representation (a), function :: Value -> Parser a), whether a newtype wrapper is necessary) generateSchema decName name schema = case schemaDRef schema of-  Just ref -> ask >>= \typesMap -> case M.lookup ref typesMap of+  Just ref -> askEnv >>= \typesMap -> case M.lookup ref typesMap of     Nothing -> fail "couldn't find referenced schema"     Just referencedSchema -> return ((conT referencedSchema, [| parseJSON |], [| toJSON |]), True)   Nothing -> first (\(typ,from,to) -> (typ,wrap from,to)) <$> case schemaType schema of@@ -198,14 +195,11 @@       then parser       else lamE [varP val] $ doE $ checkers ++ [noBindS $ parser `appE` varE val] -derivingTypeclasses :: [Name]-derivingTypeclasses = [''Eq, ''Show]- assertStmt :: ExpQ -> String -> StmtQ assertStmt expr err = noBindS [| unless $(expr) (fail err) |]  assertValidates :: ExpQ -> ExpQ -> StmtQ-assertValidates schema value = noBindS+assertValidates schema value = noBindS $ parensE   [| case validate $(varE $ mkName "graph") $schema $value of        [] -> return ()        es -> fail $ unlines es@@ -357,11 +351,14 @@                  , Nothing                  )       conName <- maybe (qNewName $ firstUpper $ unpack name) return decName+      tcs <- _derivingTypeclasses <$> askOpts+      rMods <- _replaceModules <$> askOpts+      userInstanceGen <- _extraInstances <$> askOpts       recordDeclaration <- runQ $ genRecord conName                                             (zip3 propertyNames-                                                  (map (fmap replaceHiddenModules) propertyTypes)+                                                  (map (fmap (`replaceHiddenModules` rMods)) propertyTypes)                                                   (map (schemaDescription . snd) propertiesList))-                                            derivingTypeclasses+                                            (map (`replaceHiddenModules` rMods) tcs)       let typ = conT conName       let parser = foldl (\oparser propertyParser -> [| $oparser <*> $propertyParser |]) [| pure $(conE conName) |] propertyParsers       fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` typ)@@ -371,14 +368,17 @@             ]         ]       let paramNames = map (mkName . ("a" ++) . show) $ take (length propertyTos) ([1..] :: [Int])++      userInstances <- runQ . sequence $ userInstanceGen conName       toJSONInst <- runQ $ instanceD (cxt []) (conT ''ToJSON `appT` typ)         [ funD (mkName "toJSON") -- cannot use a qualified name here           [ clause [conP conName $ map varP paramNames] (normalB [| Object $ HM.fromList $ catMaybes $(listE $ zipWith3 (\fieldName to param -> [| (,) $(lift fieldName) <$> $to $(varE param) |]) (map fst propertiesList) propertyTos paramNames) |]) []           ]         ]-      tell-        [ recordDeclaration-        , Declaration fromJSONInst Nothing+      tell $+        [ recordDeclaration ]+        ++ map (flip Declaration Nothing) userInstances +++        [ Declaration fromJSONInst Nothing         , Declaration toJSONInst Nothing         ]       return ((typ, [| parseJSON |], [| toJSON |]), False)@@ -393,11 +393,14 @@     checkAdditionalProperties _ (Choice1of2 True) = [| return () |]     checkAdditionalProperties _ (Choice1of2 False) = [| fail "additional properties are not allowed" |]     checkAdditionalProperties value (Choice2of2 sch) = doE [assertValidates (lift sch) value]+    -- TODO Once https://ghc.haskell.org/trac/ghc/ticket/10734 is+    -- fixed, use a ‘let’ again for matchingPatterns and+    -- isAdditionalProperty     checkPatternAndAdditionalProperties patterns additional = noBindS       [| let items = HM.toList $(varE obj) in forM_ items $ \(pname, value) -> do-           let matchingPatterns = filter (flip PCRE.match (unpack pname) . patternCompiled . fst) $(lift patterns)+           matchingPatterns <- return (filter (flip PCRE.match (unpack pname) . patternCompiled . fst) $(lift patterns))            forM_ matchingPatterns $ \(_, sch) -> $(doE [assertValidates [| sch |] [| value |]])-           let isAdditionalProperty = null matchingPatterns && pname `notElem` $(lift $ map fst $ HM.toList $ schemaProperties schema)+           isAdditionalProperty <- return (null matchingPatterns && pname `notElem` $(lift $ map fst $ HM.toList $ schemaProperties schema))            when isAdditionalProperty $(checkAdditionalProperties [| value |] additional)       |]     additionalPropertiesAllowed (Choice1of2 True) = True

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}  module Data.Aeson.Schema.CodeGenM   ( Declaration (..)@@ -9,6 +10,11 @@   , renderDeclaration   , codeGenNewName   , genRecord+  -- * Customising the codegen+  , Options(..)+  , defaultOptions+  , askOpts+  , askEnv   ) where  import           Control.Applicative        (Applicative (..), (<$>))@@ -19,6 +25,7 @@ import           Data.Data                  (Data, Typeable) import           Data.Function              (on) import qualified Data.HashSet               as HS+import qualified Data.Map                   as M import           Data.Monoid                ((<>), mconcat) import           Data.Text                  (Text, pack) import qualified Data.Text                  as T@@ -60,8 +67,78 @@ -- has a readonly map from schema identifiers to the names of the corresponding -- types in the generated code. newtype CodeGenM s a = CodeGenM-  { unCodeGenM :: RWST s Code StringSet Q a-  } deriving (Monad, Applicative, Functor, MonadReader s, MonadWriter Code, MonadState StringSet)+  { unCodeGenM :: RWST (Options, s) Code StringSet Q a+  } deriving (Monad, Applicative, Functor, MonadReader (Options, s), MonadWriter Code, MonadState StringSet)++-- | Extra options used for the codegen+data Options = Options+ { _extraModules :: [String]+  -- ^ Needed modules that are not found by 'getUsedModules'.+ , _derivingTypeclasses :: [Name]+  -- ^ Classes to put in the @deriving@ clause+ , _replaceModules :: M.Map String String+  -- ^ A 'M.Map' of modules which we should replace with other ones+  -- when references to them are found. Useful for example when the+  -- codegen is hitting a hidden module that's not already gotten rid+  -- of in 'Data.Aeson.Schema.Helpers.replaceHiddenModules'.+ , _languageExtensions :: [Text]+  -- ^ List of @LANGUAGE@ extensions to enable in the module. Note that+  -- these aren't checked for validity.+  --+  -- @'_languageExtensions' = [ "LambdaCase" ]@+ , _ghcOptsPragmas :: [Text]+  -- ^ List of @OPTIONS_GHC@ to turn on in the module. Note that these+  -- aren't checked for validity.+  --+  -- @'_ghcOptsPragmas' = [ "-fno-warn-name-shadowing" ]@+ , _extraInstances :: Name -> [DecQ]+  -- ^ Supplied a 'Name' of the type in question (after mangling),+  -- potentially generate an instance for the type. For example, to+  -- generate an empty 'Enum' instance for every data type we make,+  -- the user can supply something like+  --+  -- @+  -- _extraInstances = \n -> return $+  --   instanceD (cxt []) (conT ''Enum `appT` conT n) []+  -- @+  --+  -- and to generate no instances, simply use @'const' []@.+ }++defaultOptions :: Options+defaultOptions = Options+  { _extraModules = [ "Text.Regex" -- provides RegexMaker instances+                    , "Text.Regex.PCRE.String" -- provides RegexLike instances, Regex type+                    , "Data.Aeson.Types" -- Parser type+                    , "Data.Ratio"+                    ]+  , _derivingTypeclasses = [''Eq, ''Show]+  , _replaceModules = M.fromList+       [ ("Data.HashMap.Base", "Data.HashMap.Lazy")+       , ("Data.Aeson.Types.Class", "Data.Aeson")+       , ("Data.Aeson.Types.Internal", "Data.Aeson.Types")+         -- "Could not find module `GHC.Integer.Type'; it is a hidden+         -- module in the package `integer-gmp'"+       , ("GHC.Integer.Type", "Prelude")+       , ("GHC.Types", "Prelude")+       , ("GHC.Real", "Prelude")+       , ("Data.Text.Internal", "Data.Text")+       , ("Data.Map.Base", "Data.Map")+         -- Due to mistake in base 4.8.{0,1} releases+       , ("Data.OldList", "Prelude")+       , ("Data.Typeable.Internal", "Data.Typeable")+       , ("Data.Binary.Class", "Data.Binary")+       ]+  , _languageExtensions = []+  , _ghcOptsPragmas = []+  , _extraInstances = const []+  }++askOpts :: CodeGenM s Options+askOpts = fst <$> ask++askEnv :: CodeGenM s s+askEnv = snd <$> ask  instance Quasi (CodeGenM s) where   qNewName = state . codeGenNewName

@@ -11,6 +11,7 @@ import           Control.Monad          (join) import           Data.Generics          (Data, everything, everywhere, mkQ, mkT) import           Data.List              (nub)+import qualified Data.Map               as M import           Data.Maybe             (maybeToList) import           Data.Scientific        (Scientific, coefficient, base10Exponent) import           Data.Text              (Text, unpack)@@ -76,25 +77,17 @@ -- some code in a module but not when we use the TH code for pretty-printing. replaceHiddenModules :: Data a                      => a -- ^ Dec or Exp+                     -> M.Map String String+                     -- ^ Extra replacements, supplied by 'CodeGenM'                      -> a-replaceHiddenModules = everywhere $ mkT replaceModule+replaceHiddenModules d replaceMap = everywhere (mkT replaceModule) d   where-    replacements =-      [ ("Data.HashMap.Base", "Data.HashMap.Lazy")-      , ("Data.Aeson.Types.Class", "Data.Aeson")-      , ("Data.Aeson.Types.Internal", "Data.Aeson.Types")-      , ("GHC.Integer.Type", "Prelude") -- "Could not find module `GHC.Integer.Type'; it is a hidden module in the package `integer-gmp'"-      , ("GHC.Types", "Prelude")-      , ("GHC.Real", "Prelude")-      , ("Data.Text.Internal", "Data.Text")-      , ("Data.Map.Base", "Data.Map")-      ]     replaceModule :: Name -> Name     replaceModule n = case nameModule n of       Just "Data.Aeson.Types.Internal" | nameBase n `elem` ["I", "D"] ->         mkName $ "Data.Attoparsec.Number." ++ nameBase n       Just "GHC.Tuple" -> mkName $ nameBase n-      Just m -> case lookup m replacements of+      Just m -> case M.lookup m replaceMap of         Just r -> mkName $ r ++ ('.' : nameBase n)         Nothing -> n       _ -> n

@@ -50,6 +50,7 @@ import           Data.Aeson.Schema import           Data.Aeson.Schema.Choice import           Data.Aeson.Schema.CodeGen            (generateModule)+import           Data.Aeson.Schema.CodeGenM           (Options(..), defaultOptions) import           Data.Aeson.Schema.Helpers            (formatValidators,                                                        getUsedModules,                                                        replaceHiddenModules)@@ -196,7 +197,7 @@  data ForkLift = ForkLift (Chan (Hint.Interpreter (), Hint.InterpreterError -> IO ())) -getSandboxPackageDB :: IO (Maybe FilePath) +getSandboxPackageDB :: IO (Maybe FilePath) getSandboxPackageDB = do     cwd <- DIR.getCurrentDirectory     contents <- readFile $ cwd <> [FP.pathSeparator] <> "cabal.sandbox.config"@@ -204,7 +205,7 @@     where         packagedb = "package-db: "         maybePackageDB :: [FilePath] -> Maybe FilePath-        maybePackageDB list = case list of +        maybePackageDB list = case list of                                    [path] -> Just $ T.unpack $ T.replace packagedb "" (T.pack path)                                    _ -> Nothing         findPackageDB contents = maybePackageDB $ filter (\l -> T.isPrefixOf packagedb (T.pack l)) (lines contents)@@ -213,7 +214,7 @@ getInterpreterArgs = do     mdb <- getSandboxPackageDB     return $ case mdb of-                Just path -> ["-no-user-package-db", "-package-db " <> path]  +                Just path -> ["-no-user-package-db", "-package-db " <> path]                 Nothing -> []  -- | uses the Forklift pattern (http://apfelmus.nfshost.com/blog/2012/06/07-forklift.html)@@ -223,7 +224,7 @@   cmdChan <- newChan   _ <- forkIO $ do     errorHandler <- newEmptyMVar-    args <- getInterpreterArgs +    args <- getInterpreterArgs      forever $ do       Left err <- Hint.unsafeRunInterpreterWithArgs args $ do@@ -258,7 +259,7 @@             , schemaItems = Just $ Choice2of2 [empty { schemaType = [Choice1of2 NumberType] }]             }           graph = M.singleton "A" schema-        (code, _) <- runQ $ generateModule "TestOneTuple" graph+        (code, _) <- runQ $ generateModule "TestOneTuple" graph defaultOptions         result <- typecheck code forkLift         case result of           Left err -> HU.assertFailure $ show err@@ -270,7 +271,7 @@               "additionalProperties": { "type": "number" }             } |]           graph = M.singleton "A" schema-        (code, _) <- runQ $ generateModule "SimpleMap" graph+        (code, _) <- runQ $ generateModule "SimpleMap" graph defaultOptions         result <- typecheck code forkLift         case result of           Left err -> HU.assertFailure $ show err@@ -280,7 +281,7 @@ typecheckGenerate :: ForkLift -> Schema Text -> Property typecheckGenerate forkLift schema = ioProperty $ do   let graph = M.singleton "A" schema-  (code, _) <- runQ $ generateModule "CustomSchema" graph+  (code, _) <- runQ $ generateModule "CustomSchema" graph defaultOptions   eitherToResult <$> typecheck code forkLift  withCodeTempFile :: Text -> (FilePath -> IO a) -> IO a@@ -328,9 +329,10 @@ assertValidates :: Bool -> ForkLift -> Graph Schema Text -> Schema Text -> Value -> HU.Assertion assertValidates shouldBeValid forkLift graph schema value = do   let graph' = if M.null graph then M.singleton "a" schema else graph-  (code, typeMap) <- runQ $ generateModule "TestSchema" graph'-  valueExpr <- replaceHiddenModules <$> runQ (THS.lift value)-  let typ = replaceHiddenModules $ typeMap M.! "a"+      repMap = _replaceModules defaultOptions+  (code, typeMap) <- runQ $ generateModule "TestSchema" graph' defaultOptions+  valueExpr <- flip replaceHiddenModules repMap <$> runQ (THS.lift value)+  let typ = flip replaceHiddenModules repMap $ typeMap M.! "a"   let validatesExpr = unlines         [ "case DAT.parseEither parseJSON (" ++ pprint valueExpr ++ ") :: Either String (" ++ pprint typ ++ ") of"         , "  Prelude.Left e  -> Just e"