{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-}-- Shamelessly copied from Bryan O'Sullivan, 2011-- EVENTUALLY MAKE THIS WORK BY GETTING THE CONSTRUCTOR BEFOREHAND.-- moduleData.Aeson.TH.Smart(deriveJSON,deriveToJSON,deriveFromJSON,mkToJSON,mkParseJSON)where---------------------------------------------------------------------------------- Imports---------------------------------------------------------------------------------- from aeson:importData.Aeson(toJSON,Object,object,(.=),(.:?),ToJSON,toJSON,FromJSON,parseJSON)importData.Aeson.Types(Value(..),Parser)-- from base:importControl.Applicative(pure,(<$>),(<*>))importControl.Monad(return,mapM,liftM2,fail)importData.Bool(otherwise)importData.Default(def,Default)importData.Eq((==))importData.Function(($),(.),id)importData.Functor(fmap)importData.List((++),foldl,foldl',intercalate,length,map,zip,genericLength)importData.Maybe(Maybe(Nothing,Just))importPrelude(String,(-),Integer,fromIntegral,not,error,filter,fst,snd,Bool(..),flip,maybe)importText.Printf(printf)importText.Show(show)#if __GLASGOW_HASKELL__ < 700importControl.Monad((>>=))importPrelude(fromInteger)#endif-- from unordered-containers:importqualifiedData.HashMap.StrictasH(lookup,toList,size)-- from template-haskell:importLanguage.Haskell.THimportLanguage.Haskell.TH.Syntax-- from text:importqualifiedData.TextasT(Text,pack,unpack)-- from vector:importqualifiedData.VectorasV(unsafeIndex,null,length,create,filter)importqualifiedData.Vector.MutableasVM(unsafeNew,unsafeWrite)---------------------------------------------------------------------------------- Convenience---------------------------------------------------------------------------------- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given-- data type.---- This is a convienience function which is equivalent to calling both-- 'deriveToJSON' and 'deriveFromJSON'.deriveJSON::(String->String)-- ^ Function to change field names.->Name-- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'-- instances.->Q[Dec]deriveJSONwithFieldname=liftM2(++)(deriveToJSONwithFieldname)(deriveFromJSONwithFieldname)---------------------------------------------------------------------------------- ToJSON--------------------------------------------------------------------------------{-
TODO: Don't constrain phantom type variables.
data Foo a = Foo Int
instance (ToJSON a) ⇒ ToJSON Foo where ...
The above (ToJSON a) constraint is not necessary and perhaps undesirable.
-}-- | Generates a 'ToJSON' instance declaration for the given data type.---- Example:---- @-- data Foo = Foo 'Char' 'Int'-- $('deriveToJSON' 'id' ''Foo)-- @---- This will splice in the following code:---- @-- instance 'ToJSON' Foo where-- 'toJSON' =-- \value -> case value of-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do-- mv <- 'VM.unsafeNew' 2-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1)-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2)-- return mv-- @deriveToJSON::(String->String)-- ^ Function to change field names.->Name-- ^ Name of the type for which to generate a 'ToJSON' instance-- declaration.->Q[Dec]deriveToJSONwithFieldname=withTypename$\tvbscons->fmap(:[])$fromConstvbsconswherefromCons::[TyVarBndr]->[Con]->QDecfromConstvbscons=instanceD(return$map(\t->ClassP''ToJSON[VarTt])typeNames)(classType`appT`instanceType)[funD'toJSON[clause[](normalB$consToJSONwithFieldcons)[]]]whereclassType=conT''ToJSONtypeNames=maptvbNametvbsinstanceType=foldl'appT(conTname)$mapvarTtypeNames-- | Generates a lambda expression which encodes the given data type as JSON.---- Example:---- @-- data Foo = Foo Int-- @---- @-- encodeFoo :: Foo -> 'Value'-- encodeFoo = $('mkToJSON' id ''Foo)-- @---- This will splice in the following code:---- @-- \value -> case value of Foo arg1 -> 'toJSON' arg1-- @mkToJSON::(String->String)-- ^ Function to change field names.->Name-- ^ Name of the type to encode.->QExpmkToJSONwithFieldname=withTypename(\_cons->consToJSONwithFieldcons)-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code-- to generate the JSON encoding of a number of constructors. All constructors-- must be from the same type.consToJSON::(String->String)-- ^ Function to change field names.->[Con]-- ^ Constructors for which to generate JSON generating code.->QExpconsToJSON_[]=error$"Data.Aeson.TH.consToJSON: "++"Not a single constructor given!"-- A single constructor is directly encoded. The constructor itself may be-- forgotten.consToJSONwithField[con]=dovalue<-newName"value"lam1E(varPvalue)$caseE(varEvalue)[encodeArgsNothingwithFieldcon]consToJSONwithFieldcons=dovalue<-newName"value"lam1E(varPvalue)$caseE(varEvalue)[encodeArgs(Just$wrap$[|String.T.pack|]`appE`conNameExpcon)withFieldcon|con<-cons]wherewrap::QExp->[QExp]->QExpwrapnameexps=[e|object|]`appE`([e|filter(not.(==Null).snd)|]`appE`listE(infixApp(litE$stringL"constructor")[e|(.=)|]name:exps))-- | Generates code to generate the JSON encoding of a single constructor.encodeArgs::Maybe([QExp]->QExp)->(String->String)->Con->QMatchencodeArgs__c@(NormalCconName[])=match(conPconName[])(normalB$[e|toJSON|]`appE`([|T.pack|]`appE`conNameExpc))[]encodeArgswrapper_(NormalCconNamets)=doletlen=lengthtsargs<-mapMnewName["arg"++shown|n<-[1..len]]letjs=case[[e|toJSON|]`appE`varEarg|arg<-args]of-- Single argument is directly converted.[e]->e-- Multiple arguments are converted to a JSON array.es->domv<-newName"mv"letnewMV=bindS(varPmv)([e|VM.unsafeNew|]`appE`litE(integerL$fromIntegrallen))stmts=[noBindS$[e|VM.unsafeWrite|]`appE`(varEmv)`appE`litE(integerLix)`appE`e|(ix,e)<-zip[(0::Integer)..]es]ret=noBindS$[e|return|]`appE`varEmvfltr=[e|V.filter(not.(==Null))|][e|Array|]`appE`(fltr`appE`(varE'V.create`appE`doE(newMV:stmts++[ret])))letb=casewrapperofNothing->js(Justwrapper')->wrapper'[infixApp(litE(stringL"value"))[e|(.=)|]js]match(conPconName$mapvarPargs)(normalBb)[]-- Records.encodeArgswithExpwithField(RecCconNamets)=doargs<-mapMnewName["arg"++shown|(_,n)<-zipts[1::Integer..]]letargs'=map(([e|toJSON|]`appE`).varE)argsletjs=[infixApp([e|T.pack|]`appE`fieldNameExpwithFieldfield)[e|(.=)|]arg|(arg,(field,_,_))<-zipargs'ts]letb=casewithExpofNothing->[e|object|]`appE`([e|filter(not.(==Null).snd)|]`appE`listEjs)(Justwrapper)->wrapperjsmatch(conPconName$mapvarPargs)(normalBb)[]-- Infix constructors.encodeArgswithExp_(InfixC_conName_)=doal<-newName"argL"ar<-newName"argR"letl=listE[[e|toJSON|]`appE`varEa|a<-[al,ar]]letb=casewithExpofNothing->[e|toJSON|]`appE`l(Justwrapper)->wrapper[infixApp(litE$stringL"value")[e|(.=)|]l]match(infixP(varPal)conName(varPar))(normalBb)[]-- Existentially quantified constructors.encodeArgswithExpwithField(ForallC__con)=encodeArgswithExpwithFieldcon---------------------------------------------------------------------------------- FromJSON---------------------------------------------------------------------------------- | Generates a 'FromJSON' instance declaration for the given data type.---- Example:---- @-- data Foo = Foo Char Int-- $('deriveFromJSON' id ''Foo)-- @---- This will splice in the following code:---- @-- instance 'FromJSON' Foo where-- 'parseJSON' =-- \value -> case value of-- 'Array' arr ->-- if (V.length arr == 2)-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)-- else fail \"\<error message\>\"-- other -> fail \"\<error message\>\"-- @deriveFromJSON::(String->String)-- ^ Function to change field names.->Name-- ^ Name of the type for which to generate a 'FromJSON' instance-- declaration.->Q[Dec]deriveFromJSONwithFieldname=withTypename$\tvbscons->fmap(:[])$fromConstvbsconswherefromCons::[TyVarBndr]->[Con]->QDecfromConstvbscons=instanceD(return$map(\t->ClassP''FromJSON[VarTt])typeNames)(classType`appT`instanceType)[funD'parseJSON[clause[](normalB$consFromJSONnamewithFieldcons)[]]]whereclassType=conT''FromJSONtypeNames=maptvbNametvbsinstanceType=foldl'appT(conTname)$mapvarTtypeNames-- | Generates a lambda expression which parses the JSON encoding of the given-- data type.---- Example:---- @-- data Foo = Foo 'Int'-- @---- @-- parseFoo :: 'Value' -> 'Parser' Foo-- parseFoo = $('mkParseJSON' id ''Foo)-- @---- This will splice in the following code:---- @-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg-- @mkParseJSON::(String->String)-- ^ Function to change field names.->Name-- ^ Name of the encoded type.->QExpmkParseJSONwithFieldname=withTypename(\_cons->consFromJSONnamewithFieldcons)-- if it's 1ary flat constrcutor, it's just the constructor name, no matter how many-- if there's many nary constructors, we make an object with value and constructor records-- if there's many record constructors, we add a record with the constructor value-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates-- code to parse the JSON encoding of a number of constructors. All constructors-- must be from the same type.consFromJSON::Name-- ^ Name of the type to which the constructors belong.->(String->String)-- ^ Function to change field names.->[Con]-- ^ Constructors for which to generate JSON parsing code.->QExpconsFromJSON__[]=error$"Data.Aeson.TH.consFromJSON: "++"Not a single constructor given!"consFromJSONtNamewithFieldcons=doobj<-newName"obj"strcon<-newName"strcon"val<-newName"val"matcher<-newName"matcher"mcon<-newName"mcon"arg<-newName"arg"lam1E(varParg)$doE[bindS(tupP[varPmcon,varPmatcher])$caseE(varEarg)[flip(match(conP'Object[varPobj]))[]$normalB$doE[bindS(varPstrcon)(sigE([e|(.:?"constructor")|]`appE`(varEobj))[t|Parser(MaybeT.Text)|]),bindS(varPval)([e|(.:?"value")|]`appE`(varEobj)),noBindS([|return|]`appE`tupE[varEstrcon,[|flipmaybeid|]`appE`varEarg`appE`varEval])],matchwildP(normalB$[|return|]`appE`tupE[conE'Nothing,varEarg])[]],noBindS$caseE(varEmatcher)([parseContNamewithFieldc(varEmcon)|c<-cons]++[noMatchtName])]conEq::ExpQ->Name->ExpQconEqstrconName=infixAppstr[|(==)|]([|T.pack|]`appE`(litE$stringL$nameBaseconName))tupSeq::(Qa,Qb)->Q(a,b)tupSeq(a,b)=doa'<-ab'<-breturn(a',b')conGuard::ExpQ->Name->QGuardconGuardmconconName=doa<-newName"a"normalG$caseEmcon[match(conP'Just[varPa])(normalB$conEq(varEa)conName)[],matchwildP(normalB[|True|])[]]parseCon::Name->(String->String)->Con->ExpQ->QMatchparseCon__(NormalCconName[])_=dostr<-newName"str"grd<-normalG$conEq(varEstr)conNameexpr<-conEconNamematch(conP'String[varPstr])(guardedB$[tupSeq(normalG$conEq(varEstr)conName,[|return|]`appE`conEconName)])[]parseCon__(NormalCconName[_])mcon=doarg<-newName"arg"match(varParg)(guardedB[tupSeq(conGuardmconconName,infixApp(conEconName)[e|(<$>)|]([e|parseJSON|]`appE`varEarg))])[]parseContName_(NormalCconNamets)mcon=parseProducttNameconName(genericLengthts)mconparseContNamewithField(RecCconNamets)mcon=doobj<-newName"recObj"let(x:xs)=[dob<-isInstance''Default[ty][|lookupField|]`appE`(ifbthen[|Justdef|]else[|Nothing|])`appE`(litE$stringL$showtName)`appE`(litE$stringL$nameBaseconName)`appE`(varEobj)`appE`([e|T.pack|]`appE`fieldNameExpwithFieldfield)|(field,_,ty)<-ts]match(conP'Object[varPobj])(guardedB[tupSeq(conGuardmconconName,foldl'(\ab->infixAppa[|(<*>)|]b)(infixApp(conEconName)[|(<$>)|]x)xs)])[]parseArgstName_(InfixC_conName_)mcon=parseProducttNameconName2mconparseArgstNamewithField(ForallC__con)mcon=parseArgstNamewithFieldconmcon-- | Generates code to parse the JSON encoding of an n-ary-- constructor.parseProduct::Name-- ^ Name of the type to which the constructor belongs.->Name-- ^ 'Con'structor name.->Integer-- ^ 'Con'structor arity.->ExpQ-- ^ Possible requirement of the constructor->QMatchparseProducttNameconNamenumArgsmcon=doarr<-newName"arr"letx:xs=[[|parseJSON|]`appE`infixApp(varEarr)[|V.unsafeIndex|](litE$integerLix)|ix<-[0..numArgs-1]]flip(match(conP'Array[varParr]))[]$guardedB[tupSeq(conGuardmconconName,condE(infixApp([|V.length|]`appE`varEarr)[|(==)|](litE$integerLnumArgs))(foldl'(\ab->infixAppa[|(<*>)|]b)(infixApp(conEconName)[|(<$>)|]x)xs)(parseTypeMismatchtNameconName(litE$stringL$"Array of length "++shownumArgs)(infixApp(litE$stringL$"Array of length ")[|(++)|]([|show.V.length|]`appE`varEarr))))]lookupField::(FromJSONa)=>Maybea->String->String->Object->T.Text->ParseralookupFielddtNamerecobjkey=caseH.lookupkeyobjofNothing->casedofNothing->unknownFieldFailtNamerec(T.unpackkey)Justx->returnxJustv->parseJSONv---------------------------------------------------------------------------------- Parsing errors--------------------------------------------------------------------------------noMatch::Name->MatchQnoMatchtName=doother<-newName"other"flip(match(varPother))[](normalB$[|fail$printf"No constructors for type %s were present."|]`appE`(litE$stringL$nameBasetName))parseTypeMismatch::Name->Name->ExpQ->ExpQ->ExpQparseTypeMismatchtNameconNameexpectedactual=foldlappE[|parseTypeMismatch'|][litE$stringL$nameBaseconName,litE$stringL$showtName,expected,actual]unknownFieldFail::String->String->String->ParserfailunknownFieldFailtNamereckey=fail$printf"When parsing the record %s of type %s the key %s was not present."rectNamekeyparseTypeMismatch'::String->String->String->String->ParserfailparseTypeMismatch'tNameconNameexpectedactual=fail$printf"When parsing the constructor %s of type %s expected %s but got %s."conNametNameexpectedactual---------------------------------------------------------------------------------- Utility functions---------------------------------------------------------------------------------- | Boilerplate for top level splices.---- The given 'Name' must be from a type constructor. Furthermore, the-- type constructor must be either a data type or a newtype. Any other-- value will result in an exception.withType::Name->([TyVarBndr]->[Con]->Qa)-- ^ Function that generates the actual code. Will be applied-- to the type variable binders and constructors extracted-- from the given 'Name'.->Qa-- ^ Resulting value in the 'Q'uasi monad.withTypenamef=doinfo<-reifynamecaseinfoofTyConIdec->casedecofDataD__tvbscons_->ftvbsconsNewtypeD__tvbscon_->ftvbs[con]other->error$"Data.Aeson.TH.withType: Unsupported type: "++showother_->error"Data.Aeson.TH.withType: I need the name of a type."-- | Extracts the name from a constructor.getConName::Con->NamegetConName(NormalCname_)=namegetConName(RecCname_)=namegetConName(InfixC_name_)=namegetConName(ForallC__con)=getConNameconguardConName::Name->Name->QStmtguardConNameconNamevarName=noBindS(infixApp(litE$stringL$nameBaseconName)[e|(==)|](varEvarName))-- | Extracts the name from a type variable binder.tvbName::TyVarBndr->NametvbName(PlainTVname)=nametvbName(KindedTVname_)=name-- | Makes a string literal expression from a constructor's name.conNameExp::Con->QExpconNameExp=litE.stringL.nameBase.getConName-- | Creates a string literal expression from a record field name.fieldNameExp::(String->String)-- ^ Function to change the field name.->Name->QExpfieldNameExpf=litE.stringL.f.nameBase-- | The name of the outermost 'Value' constructor.valueConName::Value->StringvalueConName(Object_)="Object"valueConName(Array_)="Array"valueConName(String_)="String"valueConName(Number_)="Number"valueConName(Bool_)="Boolean"valueConNameNull="Null"