diff --git a/aeson-schema.cabal b/aeson-schema.cabal --- a/aeson-schema.cabal +++ b/aeson-schema.cabal @@ -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, 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 @@ -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) |] + ]) diff --git a/src/Data/Aeson/Schema/CodeGenM.hs b/src/Data/Aeson/Schema/CodeGenM.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Schema/CodeGenM.hs @@ -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