diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/aeson-schema.cabal b/aeson-schema.cabal --- a/aeson-schema.cabal +++ b/aeson-schema.cabal @@ -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 -maintainer: Tim Baumann +author: Tim Baumann, Mateusz Kowalczyk +maintainer: Mateusz Kowalczyk +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 diff --git a/src/Data/Aeson/Schema/CodeGen.hs b/src/Data/Aeson/Schema/CodeGen.hs --- a/src/Data/Aeson/Schema/CodeGen.hs +++ b/src/Data/Aeson/Schema/CodeGen.hs @@ -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 diff --git a/src/Data/Aeson/Schema/CodeGenM.hs b/src/Data/Aeson/Schema/CodeGenM.hs --- a/src/Data/Aeson/Schema/CodeGenM.hs +++ b/src/Data/Aeson/Schema/CodeGenM.hs @@ -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 diff --git a/src/Data/Aeson/Schema/Helpers.hs b/src/Data/Aeson/Schema/Helpers.hs --- a/src/Data/Aeson/Schema/Helpers.hs +++ b/src/Data/Aeson/Schema/Helpers.hs @@ -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 diff --git a/test/Data/Aeson/Schema/CodeGen/Tests.hs b/test/Data/Aeson/Schema/CodeGen/Tests.hs --- a/test/Data/Aeson/Schema/CodeGen/Tests.hs +++ b/test/Data/Aeson/Schema/CodeGen/Tests.hs @@ -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"