aeson-schema 0.1.0.0 → 0.1.1.0
raw patch · 3 files changed
+162/−125 lines, 3 files
Files
- aeson-schema.cabal +9/−3
- src/Data/Aeson/Schema/CodeGen.hs +85/−122
- src/Data/Aeson/Schema/CodeGenM.hs +68/−0
aeson-schema.cabal view
@@ -1,5 +1,5 @@ name: aeson-schema-version: 0.1.0.0+version: 0.1.1.0 synopsis: Haskell JSON schema validator and parser generator -- description: homepage: https://github.com/timjb/aeson-schema@@ -18,8 +18,14 @@ library ghc-options: -Wall hs-source-dirs: src- exposed-modules: Data.Aeson.Schema, Data.Aeson.Schema.Validator, Data.Aeson.Schema.CodeGen, Data.Aeson.Schema.Choice, Data.Aeson.Schema.Helpers, Data.Aeson.Schema.Types- other-modules: Data.Aeson.Schema.Choice.TH, Data.Aeson.TH.Lift+ exposed-modules: Data.Aeson.Schema, Data.Aeson.Schema.Validator,+ Data.Aeson.Schema.CodeGenM,+ Data.Aeson.Schema.CodeGen,+ Data.Aeson.Schema.Choice,+ Data.Aeson.Schema.Helpers,+ Data.Aeson.Schema.Types+ other-modules: Data.Aeson.Schema.Choice.TH,+ Data.Aeson.TH.Lift extensions: OverloadedStrings build-depends: base == 4.5.*, aeson >= 0.6.0.2,
src/Data/Aeson/Schema/CodeGen.hs view
@@ -1,7 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -17,17 +15,13 @@ (<|>)) import Control.Arrow (first, second) import Control.Monad (forM_, unless, when, zipWithM)-import Control.Monad.RWS.Lazy (MonadReader (..), MonadState (..),- MonadWriter (..), RWST (..),- evalRWST)-import qualified Control.Monad.Trans.Class as MT+import Control.Monad.RWS.Lazy (MonadReader (..), + MonadWriter (..), evalRWST) import Data.Aeson import Data.Aeson.Types (parse) import Data.Attoparsec.Number (Number (..)) import Data.Char (isAlphaNum, isLetter, toLower, toUpper)-import Data.Data (Data, Typeable)-import Data.Function (on) import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as HS import Data.List (mapAccumL, sort, unzip4)@@ -45,61 +39,14 @@ import Text.Regex.PCRE.String (Regex) import Data.Aeson.Schema.Choice+import Data.Aeson.Schema.CodeGenM import Data.Aeson.Schema.Helpers import Data.Aeson.Schema.Types import Data.Aeson.Schema.Validator import Data.Aeson.TH.Lift () --- | A top-level declaration.-data Declaration = Declaration Dec (Maybe Text) -- ^ Optional textual declaration. This can be used for information (e.g. inline comments) that are not representable in TH.- | Comment Text -- ^ Comment text- deriving (Show, Eq, Typeable, Data)---- | Haskell code (without module declaration and imports)-type Code = [Declaration]--type StringSet = HS.HashSet String type SchemaTypes = M.Map Text Name --- Code generation monad: Keeps a set of used names, writes out the code and--- has a readonly map from schema identifiers to the names of the corresponding--- types in the generated code.-newtype CodeGenM a = CodeGenM- { unCodeGenM :: RWST SchemaTypes Code StringSet Q a- } deriving (Monad, Applicative, Functor, MonadReader SchemaTypes, MonadWriter Code, MonadState StringSet)---- | Generates a fresh name-codeGenNewName :: String -> StringSet -> (Name, StringSet)-codeGenNewName s used = (Name (mkOccName free) NameS, HS.insert free used)- where- free = head $ dropWhile (`HS.member` used) $ (if validName s then (s:) else id) $ map (\i -> s ++ "_" ++ show i) ([1..] :: [Int])- -- taken from http://www.haskell.org/haskellwiki/Keywords- haskellKeywords = HS.fromList- [ "as", "case", "of", "class", "data", "data family", "data instance"- , "default", "deriving", "deriving instance", "do", "forall", "foreign"- , "hiding", "if", "then", "else", "import", "infix", "infixl", "infixr"- , "instance", "let", "in", "mdo", "module", "newtype", "proc"- , "qualified", "rec", "type", "type family", "type instance", "where"- ]- validName n = not (n `elem` ["", "_"] || n `HS.member` haskellKeywords)--instance Quasi CodeGenM where- qNewName = state . codeGenNewName- qReport b = CodeGenM . MT.lift . report b- qRecover (CodeGenM handler) (CodeGenM action) = do- graph <- ask- currState <- get- (a, s, w) <- CodeGenM $ MT.lift $ (recover `on` \m -> runRWST m graph currState) handler action- put s- tell w- return a- qLookupName b = CodeGenM . MT.lift . (if b then lookupTypeName else lookupValueName)- qReify = CodeGenM . MT.lift . reify- qReifyInstances name = CodeGenM . MT.lift . reifyInstances name- qLocation = CodeGenM . MT.lift $ location- qRunIO = CodeGenM . MT.lift . runIO- qAddDependentFile = CodeGenM . MT.lift . addDependentFile- instance (Lift k, Lift v) => Lift (M.Map k v) where lift m = [| M.fromList $(lift $ M.toList m) |] @@ -129,7 +76,7 @@ generateModule modName = fmap (first $ renderCode . map rewrite) . generate where renderCode :: Code -> Text- renderCode code = T.unlines $ [modDec] ++ imprts ++ map renderDeclaration code+ renderCode code = T.intercalate "\n\n" $ [modDec, T.intercalate "\n" imprts] ++ map renderDeclaration code where mods = sort $ extraModules ++ getUsedModules (getDecs code) imprts = map (\m -> "import " <> pack m) mods@@ -149,7 +96,7 @@ (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 ()+generateTopLevel :: Graph Schema Text -> CodeGenM SchemaTypes () generateTopLevel graph = do typeMap <- ask graphN <- qNewName "graph"@@ -162,7 +109,7 @@ ((typeQ, exprQ), defNewtype) <- generateSchema (Just typeName) name schema when defNewtype $ do let newtypeCon = normalC typeName [strictType notStrict typeQ]- newtypeDec <- runQ $ newtypeD (cxt []) typeName [] newtypeCon []+ newtypeDec <- runQ $ newtypeD (cxt []) typeName [] newtypeCon derivingTypeclasses fromJSONInst <- runQ $ instanceD (cxt []) (conT ''FromJSON `appT` conT typeName) [ valD (varP $ mkName "parseJSON") (normalB [| fmap $(conE typeName) . $exprQ |]) [] ]@@ -171,7 +118,7 @@ generateSchema :: Maybe Name -- ^ Name to be used by type declarations -> Text -- ^ Describes the position in the schema -> Schema Text- -> CodeGenM ((TypeQ, ExpQ), Bool) -- ^ ((type of the generated representation (a), function :: Value -> Parser a), whether a newtype wrapper is necessary)+ -> CodeGenM SchemaTypes ((TypeQ, 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 Nothing -> fail "couldn't find referenced schema"@@ -186,19 +133,19 @@ subs <- fmap (map fst) $ zipWithM (choice2 (flip $ generateSimpleType Nothing) (flip $ generateSchema Nothing)) unionType names (,True) <$> generateUnionType subs where- generateSimpleType :: Maybe Name -> Text -> SchemaType -> CodeGenM ((TypeQ, ExpQ), Bool)+ generateSimpleType :: Maybe Name -> Text -> SchemaType -> CodeGenM SchemaTypes ((TypeQ, ExpQ), Bool) generateSimpleType decName' name' typ = case typ of StringType -> (,True) <$> generateString schema NumberType -> (,True) <$> generateNumber schema IntegerType -> (,True) <$> generateInteger schema BooleanType -> (,True) <$> generateBoolean ObjectType -> case checkers of- [] -> (,False) <$> generateObject decName' name' schema- _ -> (,True) <$> generateObject Nothing name' schema+ [] -> generateObject decName' name' schema+ _ -> (,True) . fst <$> generateObject Nothing name' schema ArrayType -> (,True) <$> generateArray name' schema NullType -> (,True) <$> generateNull AnyType -> (,True) <$> generateAny schema- generateUnionType :: [(TypeQ, ExpQ)] -> CodeGenM (TypeQ, ExpQ)+ generateUnionType :: [(TypeQ, ExpQ)] -> CodeGenM SchemaTypes (TypeQ, ExpQ) generateUnionType union = return (typ, lamE [varP val] code) where n = length union@@ -228,11 +175,7 @@ [] -> fail "disallowed" _ -> return () |]- checkExtends exts = noBindS $ doE $ flip map exts $ noBindS . \sch ->- [| case validate $(varE $ mkName "graph") $(lift sch) $(varE val) of- [] -> return ()- es -> fail $ unlines es- |]+ checkExtends exts = noBindS $ doE $ flip map exts $ flip assertValidates (varE val) . lift checkers = catMaybes [ checkEnum <$> schemaEnum schema , if null (schemaDisallow schema) then Nothing else Just (checkDisallow $ schemaDisallow schema)@@ -242,9 +185,19 @@ 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+ [| case validate $(varE $ mkName "graph") $schema $value of+ [] -> return ()+ es -> fail $ unlines es+ |]+ lambdaPattern :: PatQ -> ExpQ -> ExpQ -> ExpQ lambdaPattern pat body err = lamE [varP val] $ caseE (varE val) [ match pat (normalB body) []@@ -252,7 +205,7 @@ ] where val = mkName "val" -generateString :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateString :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ) generateString schema = return (conT ''Text, code) where str = mkName "str"@@ -273,7 +226,7 @@ (doE $ checkers ++ [noBindS [| return $(varE str) |]]) [| fail "not a string" |] -generateNumber :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateNumber :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ) generateNumber schema = return (conT ''Number, code) where num = mkName "num"@@ -281,7 +234,7 @@ (doE $ numberCheckers num schema ++ [noBindS [| return $(varE num) |]]) [| fail "not a number" |] -generateInteger :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateInteger :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ) generateInteger schema = return (conT ''Integer, code) where num = mkName "num"@@ -305,10 +258,10 @@ else assertStmt [| $(varE num) <= m |] $ "number must be less than or equal " ++ show m checkDivisibleBy devisor = assertStmt [| $(varE num) `isDivisibleBy` devisor |] $ "number must be devisible by " ++ show devisor -generateBoolean :: CodeGenM (TypeQ, ExpQ)+generateBoolean :: CodeGenM SchemaTypes (TypeQ, ExpQ) generateBoolean = return (conT ''Bool, varE 'parseJSON) -generateNull :: CodeGenM (TypeQ, ExpQ)+generateNull :: CodeGenM SchemaTypes (TypeQ, ExpQ) generateNull = return (tupleT 0, code) where code = lambdaPattern (conP 'Null [])@@ -332,58 +285,68 @@ generateObject :: Maybe Name -- ^ Name to be used by data declaration -> Text -> Schema Text- -> CodeGenM (TypeQ, ExpQ)-generateObject decName name schema = do- let propertiesList = HM.toList $ schemaProperties schema- (propertyNames, propertyTypes, propertyParsers, defaultParsers) <- fmap unzip4 $ forM propertiesList $ \(fieldName, propertySchema) -> do- let cleanedFieldName = cleanName $ unpack fieldName- propertyName <- qNewName $ firstLower cleanedFieldName- ((typ, expr), _) <- generateSchema Nothing (name <> pack (firstUpper cleanedFieldName)) propertySchema- let lookupProperty = [| HM.lookup $(lift fieldName) $(varE obj) |]- case schemaDefault propertySchema of- Just defaultValue -> do- defaultName <- qNewName $ "default" <> firstUpper cleanedFieldName- return (propertyName, typ, [| maybe (return $(varE defaultName)) $expr $lookupProperty |], Just $ valD (conP 'Success [varP defaultName]) (normalB [| parse $expr $(lift defaultValue) |]) [])- Nothing -> return $ if schemaRequired propertySchema- then (propertyName, typ, [| maybe (fail $(lift $ "required property " ++ unpack fieldName ++ " missing")) $expr $lookupProperty |], Nothing)- else (propertyName, conT ''Maybe `appT` typ, [| traverse $expr $lookupProperty |], Nothing)- conName <- maybe (qNewName $ firstUpper $ unpack name) return decName- let typ = conT conName- let dataCon = recC conName $ zipWith (\pname ptyp -> (pname,NotStrict,) <$> ptyp) propertyNames propertyTypes- dataDec <- runQ $ dataD (cxt []) conName [] [dataCon] []- 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- [ clause [conP 'Object [varP obj]] (normalB $ doE $ checkers ++ [noBindS parser]) (catMaybes defaultParsers)- , clause [wildP] (normalB [| fail "not an object" |]) []- ]- ]- tell [Declaration dataDec Nothing, Declaration fromJSONInst Nothing]- return (typ, [| parseJSON |])+ -> CodeGenM SchemaTypes ((TypeQ, ExpQ), Bool)+generateObject decName name schema = case (propertiesList, schemaAdditionalProperties schema) of+ ([], Choice2of2 additionalSchema) -> generateMap additionalSchema+ _ -> generateDataDecl where+ propertiesList = HM.toList $ schemaProperties schema+ generateMap additionalSchema = case schemaPatternProperties schema of+ [] -> do+ ((additionalType, additionalParser), _) <- generateSchema Nothing (name <> "Item") additionalSchema+ let parseAdditional = [| fmap M.fromList $ mapM (\(k,v) -> (,) k <$> $(additionalParser) v) $ HM.toList $(varE obj) |]+ let parser = lambdaPattern (conP 'Object [varP obj])+ (doE $ checkers ++ [noBindS parseAdditional])+ [| fail "not an object" |]+ let typ = [t| M.Map Text $(additionalType) |]+ return ((typ, parser), True)+ _ -> do+ let validatesStmt = assertValidates (lift schema) [| Object $(varE obj) |]+ let parser = lambdaPattern (conP 'Object [varP obj])+ (doE $ validatesStmt : [noBindS [| return $ M.fromList $ HM.toList $(varE obj) |]])+ [| fail "not an object" |]+ return (([t| M.Map Text Value |], parser), True)+ generateDataDecl = do+ (propertyNames, propertyTypes, propertyParsers, defaultParsers) <- fmap unzip4 $ forM propertiesList $ \(fieldName, propertySchema) -> do+ let cleanedFieldName = cleanName $ unpack name ++ firstUpper (unpack fieldName)+ propertyName <- qNewName $ firstLower cleanedFieldName+ ((typ, expr), _) <- generateSchema Nothing (pack (firstUpper cleanedFieldName)) propertySchema+ let lookupProperty = [| HM.lookup $(lift fieldName) $(varE obj) |]+ case schemaDefault propertySchema of+ Just defaultValue -> do+ defaultName <- qNewName $ "default" <> firstUpper cleanedFieldName+ return (propertyName, typ, [| maybe (return $(varE defaultName)) $expr $lookupProperty |], Just $ valD (conP 'Success [varP defaultName]) (normalB [| parse $expr $(lift defaultValue) |]) [])+ Nothing -> return $ if schemaRequired propertySchema+ then (propertyName, typ, [| maybe (fail $(lift $ "required property " ++ unpack fieldName ++ " missing")) $expr $lookupProperty |], Nothing)+ else (propertyName, conT ''Maybe `appT` typ, [| traverse $expr $lookupProperty |], Nothing)+ conName <- maybe (qNewName $ firstUpper $ unpack name) return decName+ 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+ [ clause [conP 'Object [varP obj]] (normalB $ doE $ checkers ++ [noBindS parser]) (catMaybes defaultParsers)+ , clause [wildP] (normalB [| fail "not an object" |]) []+ ]+ ]+ tell [Declaration dataDec Nothing, Declaration fromJSONInst Nothing]+ return ((typ, [| parseJSON |]), False) obj = mkName "obj" checkDependencies deps = noBindS [| let items = HM.toList $(varE obj) in forM_ items $ \(pname, _) -> case HM.lookup pname $(lift deps) of Nothing -> return () Just (Choice1of2 props) -> forM_ props $ \prop -> when (isNothing (HM.lookup prop $(varE obj))) $ fail $ unpack pname ++ " requires property " ++ unpack prop- Just (Choice2of2 depSchema) -> case validate $(varE $ mkName "graph") depSchema (Object $(varE obj)) of- [] -> return ()- es -> fail $ unlines es+ Just (Choice2of2 depSchema) -> $(doE [assertValidates [| depSchema |] [| Object $(varE obj) |]]) |] checkAdditionalProperties _ (Choice1of2 True) = [| return () |] checkAdditionalProperties _ (Choice1of2 False) = [| fail "additional properties are not allowed" |]- checkAdditionalProperties value (Choice2of2 sch) =- [| case validate $(varE $ mkName "graph") $(lift sch) $(value) of- [] -> return ()- es -> fail $ unlines es- |]+ checkAdditionalProperties value (Choice2of2 sch) = doE [assertValidates (lift sch) value] 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)- forM_ matchingPatterns $ \(_, sch) -> case validate $(varE $ mkName "graph") sch value of- [] -> return ()- es -> fail $ unlines es+ forM_ matchingPatterns $ \(_, sch) -> $(doE [assertValidates [| sch |] [| value |]]) let isAdditionalProperty = null matchingPatterns && pname `notElem` $(lift $ map fst $ HM.toList $ schemaProperties schema) when isAdditionalProperty $(checkAdditionalProperties [| value |] additional) |]@@ -396,7 +359,7 @@ else Just (checkPatternAndAdditionalProperties (schemaPatternProperties schema) (schemaAdditionalProperties schema)) ] -generateArray :: Text -> Schema Text -> CodeGenM (TypeQ, ExpQ)+generateArray :: Text -> Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ) generateArray name schema = case schemaItems schema of Nothing -> monomorphicArray (conT ''Value) (varE 'parseJSON) Just (Choice1of2 itemsSchema) -> do@@ -410,7 +373,7 @@ Choice2of2 sch -> Choice2of2 . fst <$> generateSchema Nothing (name <> "AdditionalItems") sch tupleArray items additionalItems where- tupleArray :: [(TypeQ, ExpQ)] -> Choice2 Bool (TypeQ, ExpQ) -> CodeGenM (TypeQ, ExpQ)+ tupleArray :: [(TypeQ, ExpQ)] -> Choice2 Bool (TypeQ, ExpQ) -> CodeGenM SchemaTypes (TypeQ, ExpQ) tupleArray items additionalItems = return (tupleType, code $ additionalCheckers ++ [noBindS tupleParser]) where items' = flip map (zip [0..] items) $ \(i, (itemType, itemParser)) ->@@ -434,7 +397,7 @@ (tupleT $ length items'', [| pure $(conE $ tupleDataName $ length items'') |]) items'' - monomorphicArray :: TypeQ -> ExpQ -> CodeGenM (TypeQ, ExpQ)+ monomorphicArray :: TypeQ -> ExpQ -> CodeGenM SchemaTypes (TypeQ, ExpQ) monomorphicArray itemType itemCode = return (listT `appT` itemType, code [noBindS [| mapM $(itemCode) (V.toList $(varE arr)) |]]) arr = mkName "arr"@@ -450,11 +413,11 @@ , if schemaUniqueItems schema then Just checkUnique else Nothing ] -generateAny :: Schema Text -> CodeGenM (TypeQ, ExpQ)+generateAny :: Schema Text -> CodeGenM SchemaTypes (TypeQ, ExpQ) generateAny schema = return (conT ''Value, code) where- code =- [| \val -> case validate $(varE $ mkName "graph") $(lift schema) val of- [] -> return val- es -> fail $ unlines es- |]+ val = mkName "val"+ code = lamE [varP val]+ (doE [ assertValidates (lift schema) (varE val)+ , noBindS [| return $(varE val) |]+ ])
+ src/Data/Aeson/Schema/CodeGenM.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Data.Aeson.Schema.CodeGenM+ ( Declaration (..)+ , Code+ , CodeGenM (..)+ , codeGenNewName+ ) where++import Control.Applicative (Applicative (..))+import Control.Monad.RWS.Lazy (MonadReader (..), MonadState (..),+ MonadWriter (..), RWST (..))+import qualified Control.Monad.Trans.Class as MT+import Data.Data (Data, Typeable)+import Data.Function (on)+import qualified Data.HashSet as HS+import Data.Text (Text)+import Language.Haskell.TH.Syntax++-- | A top-level declaration.+data Declaration = Declaration Dec (Maybe Text) -- ^ Optional textual declaration. This can be used for information (e.g. inline comments) that are not representable in TH.+ | Comment Text -- ^ Comment text+ deriving (Show, Eq, Typeable, Data)++-- | Haskell code (without module declaration and imports)+type Code = [Declaration]++type StringSet = HS.HashSet String++-- | Generates a fresh name+codeGenNewName :: String -> StringSet -> (Name, StringSet)+codeGenNewName s used = (Name (mkOccName free) NameS, HS.insert free used)+ where+ free = head $ dropWhile (`HS.member` used) $ (if validName s then (s:) else id) $ map (\i -> s ++ "_" ++ show i) ([1..] :: [Int])+ -- taken from http://www.haskell.org/haskellwiki/Keywords+ haskellKeywords = HS.fromList+ [ "as", "case", "of", "class", "data", "data family", "data instance"+ , "default", "deriving", "deriving instance", "do", "forall", "foreign"+ , "hiding", "if", "then", "else", "import", "infix", "infixl", "infixr"+ , "instance", "let", "in", "mdo", "module", "newtype", "proc"+ , "qualified", "rec", "type", "type family", "type instance", "where"+ ]+ validName n = not (n `elem` ["", "_"] || n `HS.member` haskellKeywords)++-- Code generation monad: Keeps a set of used names, writes out the code and+-- 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)++instance Quasi (CodeGenM s) where+ qNewName = state . codeGenNewName+ qReport b = CodeGenM . MT.lift . report b+ qRecover (CodeGenM handler) (CodeGenM action) = do+ graph <- ask+ currState <- get+ (a, s, w) <- CodeGenM $ MT.lift $ (recover `on` \m -> runRWST m graph currState) handler action+ put s+ tell w+ return a+ qLookupName b = CodeGenM . MT.lift . (if b then lookupTypeName else lookupValueName)+ qReify = CodeGenM . MT.lift . reify+ qReifyInstances name = CodeGenM . MT.lift . reifyInstances name+ qLocation = CodeGenM . MT.lift $ location+ qRunIO = CodeGenM . MT.lift . runIO+ qAddDependentFile = CodeGenM . MT.lift . addDependentFile