{-# OPTIONS_GHC -fno-warn-orphans #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE TupleSections #-}moduleData.Aeson.Schema.CodeGen(Declaration(..),Code,generate,generateTH,generateModule)whereimportControl.Applicative(Applicative(..),(<$>),(<*>),(<|>))importControl.Arrow(first,second)importControl.Monad(forM_,unless,when,zipWithM)importControl.Monad.RWS.Lazy(MonadReader(..),MonadWriter(..),evalRWST)importData.AesonimportData.Aeson.Types(parse)importData.Attoparsec.Number(Number(..))importData.Char(isAlphaNum,isLetter,toLower,toUpper)importqualifiedData.HashMap.LazyasHMimportqualifiedData.HashSetasHSimportData.List(mapAccumL,sort,unzip5)importqualifiedData.MapasMimportData.Maybe(catMaybes,isNothing,maybeToList)importData.Monoid((<>))importData.Text(Text,pack,unpack)importqualifiedData.TextasTimportData.Traversable(forM,traverse)importData.Tuple(swap)importqualifiedData.VectorasVimportLanguage.Haskell.THimportLanguage.Haskell.TH.SyntaximportqualifiedText.Regex.PCREasPCREimportText.Regex.PCRE.String(Regex)importData.Aeson.Schema.ChoiceimportData.Aeson.Schema.CodeGenMimportData.Aeson.Schema.HelpersimportData.Aeson.Schema.TypesimportData.Aeson.Schema.ValidatorimportData.Aeson.TH.Lift()typeSchemaTypes=M.MapTextNameinstance(Liftk,Liftv)=>Lift(M.Mapkv)whereliftm=[|M.fromList$(lift$M.toListm)|]-- | 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 declarationsgetDecs::Code->[Dec]getDecscode=[dec|Declarationdec_<-code]-- | Generate data-types and FromJSON instances for all schemasgenerateTH::GraphSchemaText-- ^ Set of schemas->Q([Dec],M.MapTextName)-- ^ Generated code and mapping from schema identifiers to type namesgenerateTH=fmap(firstgetDecs).generate-- | Generated a self-contained module that parses and validates values of-- a set of given schemas.generateModule::Text-- ^ Name of the generated module->GraphSchemaText-- ^ Set of schemas->Q(Text,M.MapTextName)-- ^ Module code and mapping from schema identifiers to type namesgenerateModulemodName=fmap(first$renderCode.maprewrite).generatewhererenderCode::Code->TextrenderCodecode=T.intercalate"\n\n"$[modDec,T.intercalate"\n"imprts]++maprenderDeclarationcodewheremods=sort$extraModules++getUsedModules(getDecscode)imprts=map(\m->"import "<>packm)modsmodDec="module "<>modName<>" where"rewrite::Declaration->Declarationrewrite(Declarationdectext)=Declaration(replaceHiddenModules$cleanPatternsdec)textrewritea=a-- | Generate a generalized representation of the code in a Haskell modulegenerate::GraphSchemaText->Q(Code,M.MapTextName)generategraph=swap<$>evalRWST(unCodeGenM$generateTopLevelgraph>>returntypeMap)typeMapusedwhere(used,typeMap)=secondM.fromList$mapAccumLnameAccumHS.empty(M.keysgraph)nameAccumusedNamesschemaName=second(schemaName,)$swap$codeGenNewName(firstUpper$unpackschemaName)usedNamesgenerateTopLevel::GraphSchemaText->CodeGenMSchemaTypes()generateTopLevelgraph=dotypeMap<-askgraphN<-qNewName"graph"when(nameBasegraphN/="graph")$fail"name graph is already taken"graphDecType<-runQ$sigDgraphN[t|GraphSchemaText|]graphDec<-runQ$valD(varPgraphN)(normalB$liftgraph)[]tell[DeclarationgraphDecTypeNothing,DeclarationgraphDecNothing]forM_(M.toListgraph)$\(name,schema)->dolettypeName=typeMapM.!name((typeQ,fromJsonQ,toJsonQ),defNewtype)<-generateSchema(JusttypeName)nameschemawhendefNewtype$doletnewtypeCon=normalCtypeName[strictTypenotStricttypeQ]newtypeDec<-runQ$newtypeD(cxt[])typeName[]newtypeConderivingTypeclassesfromJSONInst<-runQ$instanceD(cxt[])(conT''FromJSON`appT`conTtypeName)[valD(varP$mkName"parseJSON")(normalB[|fmap$(conEtypeName).$fromJsonQ|])[]]toJSONInst<-runQ$instanceD(cxt[])(conT''ToJSON`appT`conTtypeName)[funD(mkName"toJSON")[clause[conPtypeName[varP$mkName"val"]](normalB$toJsonQ`appE`varE(mkName"val"))[]]]tell[DeclarationnewtypeDecNothing,DeclarationfromJSONInstNothing,DeclarationtoJSONInstNothing]generateSchema::MaybeName-- ^ Name to be used by type declarations->Text-- ^ Describes the position in the schema->SchemaText->CodeGenMSchemaTypes((TypeQ,ExpQ,ExpQ),Bool)-- ^ ((type of the generated representation (a), function :: Value -> Parser a), whether a newtype wrapper is necessary)generateSchemadecNamenameschema=caseschemaDRefschemaofJustref->ask>>=\typesMap->caseM.lookupreftypesMapofNothing->fail"couldn't find referenced schema"JustreferencedSchema->return((conTreferencedSchema,[|parseJSON|],[|toJSON|]),True)Nothing->first(\(typ,from,to)->(typ,wrapfrom,to))<$>caseschemaTypeschemaof[]->fail"empty type"[Choice1of2typ]->generateSimpleTypedecNamenametyp[Choice2of2sch]->generateSchemadecNamenameschunionType->doletl=pack.show$lengthunionTypeletnames=map(\i->name<>"Choice"<>pack(showi)<>"of"<>l)([1..]::[Int])subs<-fmap(mapfst)$zipWithM(choice2(flip$generateSimpleTypeNothing)(flip$generateSchemaNothing))unionTypenames(,True)<$>generateUnionTypesubswheregenerateSimpleType::MaybeName->Text->SchemaType->CodeGenMSchemaTypes((TypeQ,ExpQ,ExpQ),Bool)generateSimpleTypedecName'name'typ=casetypofStringType->(,True)<$>generateStringschemaNumberType->(,True)<$>generateNumberschemaIntegerType->(,True)<$>generateIntegerschemaBooleanType->(,True)<$>generateBooleanObjectType->casecheckersof[]->generateObjectdecName'name'schema_->(,True).fst<$>generateObjectNothingname'schemaArrayType->(,True)<$>generateArrayname'schemaNullType->(,True)<$>generateNullAnyType->(,True)<$>generateAnyschemagenerateUnionType::[(TypeQ,ExpQ,ExpQ)]->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateUnionTypeunion=return(typ,lamE[varPval]fromQ,toQ)wheren=lengthunion(types,froms,tos)=unzip3unionunionParsers=zipWith(\iparser->[|$(choiceConEin)<$>$parser$(varEval)|])[1..]fromschoiceConE::Int->Int->ExpQchoiceConEij=conE$mkName$"Data.Aeson.Schema.Choice.Choice"++showi++"of"++showjchoiceTi=conT$mkName$"Data.Aeson.Schema.Choice.Choice"++showityp=foldlappT(choiceTn)typesfromQ=foldr(\choiceParserunionParser->[|$choiceParser<|>$unionParser|])[|fail"no type in union"|]unionParserstoQ=foldlappE(varE$mkName$"Data.Aeson.Schema.Choice.choice"++shown)tosval=mkName"val"checkEnumxs=assertStmt[|$(varEval)`elem`xs|]"not one of the values in enum"checkDisallowdis=noBindS$doE$map(noBindS.choice2disallowTypedisallowSchema)disdisallowTypeStringType=disallowPattern(conP'String[wildP])"strings are disallowed"disallowTypeNumberType=disallowPattern(conP'Number[wildP])"numbers are disallowed"disallowTypeIntegerType=disallowPattern(conP'Number[conP'I[wildP]])"integers are disallowed"disallowTypeBooleanType=disallowPattern(conP'Bool[wildP])"booleans are disallowed"disallowTypeObjectType=disallowPattern(conP'Object[wildP])"objects are disallowed"disallowTypeArrayType=disallowPattern(conP'Array[wildP])"arrays are disallowed"disallowTypeNullType=disallowPattern(conP'Null[])"null is disallowed"disallowTypeAnyType=[|fail"Nothing is allowed here. Sorry."|]disallowPatternpaterr=caseE(varEval)[matchpat(normalB[|failerr|])[],matchwildP(normalB[|return()|])[]]disallowSchemasch=[|casevalidate$(varE$mkName"graph")$(liftsch)$(varEval)of[]->fail"disallowed"_->return()|]checkExtendsexts=noBindS$doE$flipmapexts$flipassertValidates(varEval).liftcheckers=catMaybes[checkEnum<$>schemaEnumschema,ifnull(schemaDisallowschema)thenNothingelseJust(checkDisallow$schemaDisallowschema),ifnull(schemaExtendsschema)thenNothingelseJust(checkExtends$schemaExtendsschema)]wrapparser=ifnullcheckersthenparserelselamE[varPval]$doE$checkers++[noBindS$parser`appE`varEval]derivingTypeclasses::[Name]derivingTypeclasses=[''Eq,''Show]assertStmt::ExpQ->String->StmtQassertStmtexprerr=noBindS[|unless$(expr)(failerr)|]assertValidates::ExpQ->ExpQ->StmtQassertValidatesschemavalue=noBindS[|casevalidate$(varE$mkName"graph")$schema$valueof[]->return()es->fail$unlineses|]lambdaPattern::PatQ->ExpQ->ExpQ->ExpQlambdaPatternpatbodyerr=lamE[varPval]$caseE(varEval)[matchpat(normalBbody)[],matchwildP(normalBerr)[]]whereval=mkName"val"generateString::SchemaText->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateStringschema=return(conT''Text,code,[|String|])wherestr=mkName"str"checkMinLengthl=assertStmt[|T.length$(varEstr)>=l|]$"string must have at least "++showl++" characters"checkMaxLengthl=assertStmt[|T.length$(varEstr)<=l|]$"string must have at most "++showl++" characters"checkPattern(Patternp_)=noBindS$doE[bindS(varP$mkName"regex")[|PCRE.makeRegexM$(lift(T.unpackp))|],assertStmt[|PCRE.match($(varE$mkName"regex")::Regex)(unpack$(varEstr))|]$"string must match pattern "++showp]checkFormatformat=noBindS[|maybe(return())fail(validateFormat$(liftformat)$(varEstr))|]checkers=catMaybes[ifschemaMinLengthschema>0thenJust(checkMinLength$schemaMinLengthschema)elseNothing,checkMaxLength<$>schemaMaxLengthschema,checkPattern<$>schemaPatternschema,checkFormat<$>schemaFormatschema]code=lambdaPattern(conP'String[varPstr])(doE$checkers++[noBindS[|return$(varEstr)|]])[|fail"not a string"|]generateNumber::SchemaText->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateNumberschema=return(conT''Number,code,[|Number|])wherenum=mkName"num"code=lambdaPattern(conP'Number[varPnum])(doE$numberCheckersnumschema++[noBindS[|return$(varEnum)|]])[|fail"not a number"|]generateInteger::SchemaText->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateIntegerschema=return(conT''Integer,code,[|Number.I|])wherenum=mkName"num"code=lambdaPattern(conP'Number[asPnum$conP'I[varP$mkName"i"]])(doE$numberCheckersnumschema++[noBindS[|return$(varE$mkName"i")|]])[|fail"not an integer"|]numberCheckers::Name->SchemaText->[StmtQ]numberCheckersnumschema=catMaybes[checkMinimum(schemaExclusiveMinimumschema)<$>schemaMinimumschema,checkMaximum(schemaExclusiveMaximumschema)<$>schemaMaximumschema,checkDivisibleBy<$>schemaDivisibleByschema]wherecheckMinimum,checkMaximum::Bool->Number->StmtQcheckMinimumexclm=ifexclthenassertStmt[|$(varEnum)>m|]$"number must be greater than "++showmelseassertStmt[|$(varEnum)>=m|]$"number must be greater than or equal "++showmcheckMaximumexclm=ifexclthenassertStmt[|$(varEnum)<m|]$"number must be less than "++showmelseassertStmt[|$(varEnum)<=m|]$"number must be less than or equal "++showmcheckDivisibleBydevisor=assertStmt[|$(varEnum)`isDivisibleBy`devisor|]$"number must be devisible by "++showdevisorgenerateBoolean::CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateBoolean=return([t|Bool|],[|parseJSON|],[|Bool|])generateNull::CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateNull=return(tupleT0,code,[|constNull|])wherecode=lambdaPattern(conP'Null[])[|return()|][|fail"not null"|]cleanName::String->StringcleanNamestr=charFirstwhereisAllowedc=isAlphaNumc||c`elem`"'_"cleaned=filterisAllowedstrcharFirst=casecleanedof(chr:_)|not(isLetterchr||chr=='_')->'_':cleaned_->cleanedfirstUpper,firstLower::String->StringfirstUpper""=""firstUpper(c:cs)=toUpperc:csfirstLower""=""firstLower(c:cs)=toLowerc:csgenerateObject::MaybeName-- ^ Name to be used by data declaration->Text->SchemaText->CodeGenMSchemaTypes((TypeQ,ExpQ,ExpQ),Bool)generateObjectdecNamenameschema=case(propertiesList,schemaAdditionalPropertiesschema)of([],Choice2of2additionalSchema)->generateMapadditionalSchema_->generateDataDeclwherepropertiesList=HM.toList$schemaPropertiesschemagenerateMap::SchemaText->CodeGenMSchemaTypes((TypeQ,ExpQ,ExpQ),Bool)generateMapadditionalSchema=caseschemaPatternPropertiesschemaof[]->do((additionalType,additionalParser,additionalTo),_)<-generateSchemaNothing(name<>"Item")additionalSchemaletparseAdditional=[|fmapM.fromList$mapM(\(k,v)->(,)k<$>$(additionalParser)v)$HM.toList$(varEobj)|]letparser=lambdaPattern(conP'Object[varPobj])(doE$checkers++[noBindSparseAdditional])[|fail"not an object"|]lettyp=[t|M.MapText$(additionalType)|]letto=[|Object.HM.fromList.map$(additionalTo).M.toList|]return((typ,parser,to),True)_->doletvalidatesStmt=assertValidates(liftschema)[|Object$(varEobj)|]letparser=lambdaPattern(conP'Object[varPobj])(doE$validatesStmt:[noBindS[|return$M.fromList$HM.toList$(varEobj)|]])[|fail"not an object"|]return(([t|M.MapTextValue|],parser,[|Object.HM.fromList.M.toList|]),True)generateDataDecl::CodeGenMSchemaTypes((TypeQ,ExpQ,ExpQ),Bool)generateDataDecl=do(propertyNames,propertyTypes,propertyParsers,propertyTos,defaultParsers)<-fmapunzip5$forMpropertiesList$\(fieldName,propertySchema)->doletcleanedFieldName=cleanName$unpackname++firstUpper(unpackfieldName)propertyName<-qNewName$firstLowercleanedFieldName((typ,fromExpr,toExpr),_)<-generateSchemaNothing(pack(firstUppercleanedFieldName))propertySchemaletlookupProperty=[|HM.lookup$(liftfieldName)$(varEobj)|]caseschemaDefaultpropertySchemaofJustdefaultValue->dodefaultName<-qNewName$"default"<>firstUppercleanedFieldNamereturn(propertyName,typ,[|maybe(return$(varEdefaultName))$fromExpr$lookupProperty|],[|Just.$toExpr|],Just$valD(conP'Success[varPdefaultName])(normalB[|parse$fromExpr$(liftdefaultValue)|])[])Nothing->return$ifschemaRequiredpropertySchemathen(propertyName,typ,[|maybe(fail$(lift$"required property "++unpackfieldName++" missing"))$fromExpr$lookupProperty|],[|Just.$toExpr|],Nothing)else(propertyName,conT''Maybe`appT`typ,[|traverse$fromExpr$lookupProperty|],[|fmap$toExpr|],Nothing)conName<-maybe(qNewName$firstUpper$unpackname)returndecNamelettyp=conTconNameletdataCon=recCconName$zipWith(\pnameptyp->(pname,NotStrict,)<$>ptyp)propertyNamespropertyTypesdataDec<-runQ$dataD(cxt[])conName[][dataCon]derivingTypeclassesletparser=foldl(\oparserpropertyParser->[|$oparser<*>$propertyParser|])[|pure$(conEconName)|]propertyParsersfromJSONInst<-runQ$instanceD(cxt[])(conT''FromJSON`appT`typ)[funD(mkName"parseJSON")-- cannot use a qualified name here[clause[conP'Object[varPobj]](normalB$doE$checkers++[noBindSparser])(catMaybesdefaultParsers),clause[wildP](normalB[|fail"not an object"|])[]]]letparamNames=map(mkName.("a"++).show)$take(lengthpropertyTos)([1..]::[Int])toJSONInst<-runQ$instanceD(cxt[])(conT''ToJSON`appT`typ)[funD(mkName"toJSON")-- cannot use a qualified name here[clause[conPconName$mapvarPparamNames](normalB[|Object$HM.fromList$catMaybes$(listE$zipWith3(\fieldNametoparam->[|(,)$(liftfieldName)<$>$to$(varEparam)|])(mapfstpropertiesList)propertyTosparamNames)|])[]]]tell[DeclarationdataDecNothing,DeclarationfromJSONInstNothing,DeclarationtoJSONInstNothing]return((typ,[|parseJSON|],[|toJSON|]),False)obj=mkName"obj"checkDependenciesdeps=noBindS[|letitems=HM.toList$(varEobj)inforM_items$\(pname,_)->caseHM.lookuppname$(liftdeps)ofNothing->return()Just(Choice1of2props)->forM_props$\prop->when(isNothing(HM.lookupprop$(varEobj)))$fail$unpackpname++" requires property "++unpackpropJust(Choice2of2depSchema)->$(doE[assertValidates[|depSchema|][|Object$(varEobj)|]])|]checkAdditionalProperties_(Choice1of2True)=[|return()|]checkAdditionalProperties_(Choice1of2False)=[|fail"additional properties are not allowed"|]checkAdditionalPropertiesvalue(Choice2of2sch)=doE[assertValidates(liftsch)value]checkPatternAndAdditionalPropertiespatternsadditional=noBindS[|letitems=HM.toList$(varEobj)inforM_items$\(pname,value)->doletmatchingPatterns=filter(flipPCRE.match(unpackpname).patternCompiled.fst)$(liftpatterns)forM_matchingPatterns$\(_,sch)->$(doE[assertValidates[|sch|][|value|]])letisAdditionalProperty=nullmatchingPatterns&&pname`notElem`$(lift$mapfst$HM.toList$schemaPropertiesschema)whenisAdditionalProperty$(checkAdditionalProperties[|value|]additional)|]additionalPropertiesAllowed(Choice1of2True)=TrueadditionalPropertiesAllowed_=Falsecheckers=catMaybes[ifHM.null(schemaDependenciesschema)thenNothingelseJust(checkDependencies$schemaDependenciesschema),ifnull(schemaPatternPropertiesschema)&&additionalPropertiesAllowed(schemaAdditionalPropertiesschema)thenNothingelseJust(checkPatternAndAdditionalProperties(schemaPatternPropertiesschema)(schemaAdditionalPropertiesschema))]generateArray::Text->SchemaText->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateArraynameschema=caseschemaItemsschemaofNothing->monomorphicArray(conT''Value)[|parseJSON|][|toJSON|]Just(Choice1of2itemsSchema)->do((itemType,itemParse,itemTo),_)<-generateSchemaNothing(name<>"Item")itemsSchemamonomorphicArrayitemTypeitemParseitemToJust(Choice2of2itemSchemas)->doletnames=map(\i->name<>"Item"<>pack(showi))([0..]::[Int])items<-fmap(mapfst)$zipWithM(generateSchemaNothing)namesitemSchemasadditionalItems<-caseschemaAdditionalItemsschemaofChoice1of2b->return$Choice1of2bChoice2of2sch->Choice2of2.fst<$>generateSchemaNothing(name<>"AdditionalItems")schtupleArrayitemsadditionalItemswheretupleArray::[(TypeQ,ExpQ,ExpQ)]->Choice2Bool(TypeQ,ExpQ,ExpQ)->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)tupleArrayitemsadditionalItems=return(tupleType,code$additionalCheckers++[noBindStupleParser],tupleTo)whereitems'=flipmap(zip[0..]items)$\(i,(itemType,itemParser,itemTo))->letsimpleParser=[|$(itemParser)(V.unsafeIndex$(varEarr)i)|]inifi<schemaMinItemsschemathen(itemType,simpleParser,[|return.$itemTo|])else(conT''Maybe`appT`itemType,[|ifV.length$(varEarr)>ithenJust<$>$(simpleParser)elsereturnNothing|],[|maybeToList.fmap$itemTo|])(additionalCheckers,maybeAdditionalTypeAndParser)=caseadditionalItemsofChoice1of2b->ifbthen([],Nothing)else([assertStmt[|V.length$(varEarr)<=$(lift$lengthitems')|]"no additional items allowed"],Nothing)Choice2of2(additionalType,additionalParser,additionalTo)->([],Just(listT`appT`additionalType,[|mapM$(additionalParser)(V.toList$V.drop$(lift$lengthitems')$(varEarr))|],[|map$additionalTo|]))items''=items'++maybeToListmaybeAdditionalTypeAndParser(itemTypes,itemParsers,itemTos)=unzip3items''(tupleType,tupleParser,tupleTo)=caseitems''of[(itemType,itemParser,itemTo)]->(itemType,itemParser,[|Array.V.fromList.$itemTo|])_->lettupleFields=map(mkName.("f"++).show)$take(lengthitems'')([1..]::[Int])(a,b)=foldl(\(typ,parser)(itemType,itemParser,_)->(typ`appT`itemType,[|$(parser)<*>$(itemParser)|]))(tupleT$lengthitems'',[|pure$(conE$tupleDataName$lengthitems'')|])items''to=lamE[tupP$mapvarPtupleFields][|Array$V.fromList$concat$(listE$zipWithappEitemTos(mapvarEtupleFields))|]in(a,b,to)monomorphicArray::TypeQ->ExpQ->ExpQ->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)monomorphicArrayitemTypeitemParseitemTo=return(listT`appT`itemType,code[noBindS[|mapM$(itemParse)(V.toList$(varEarr))|]],[|Array.V.fromList.map$itemTo|])arr=mkName"arr"codeparser=lambdaPattern(conP''Array[varParr])(doE$checkers++parser)[|fail"not an array"|]checkMinItemsm=assertStmt[|V.length$(varEarr)>=m|]$"array must have at least "++showm++" items"checkMaxItemsm=assertStmt[|V.length$(varEarr)<=m|]$"array must have at most "++showm++" items"checkUnique=assertStmt[|vectorUnique$(varEarr)|]"array items must be unique"checkers=catMaybes[ifschemaMinItemsschema>0thenJust(checkMinItems$schemaMinItemsschema)elseNothing,checkMaxItems<$>schemaMaxItemsschema,ifschemaUniqueItemsschemathenJustcheckUniqueelseNothing]generateAny::SchemaText->CodeGenMSchemaTypes(TypeQ,ExpQ,ExpQ)generateAnyschema=return(conT''Value,code,[|id|])whereval=mkName"val"code=lamE[varPval](doE[assertValidates(liftschema)(varEval),noBindS[|return$(varEval)|]])