{-# LANGUAGE CPP #-}{-# LANGUAGE TemplateHaskell #-}#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704{-# LANGUAGE Trustworthy #-}#endif-- in case we're being loaded from ghci#ifndef MIN_VERSION_template_haskell#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)#endif------------------------------------------------------------------------------- |-- Module : Control.Lens.TH-- Copyright : (C) 2012 Edward Kmett, Michael Sloan-- License : BSD-style (see the file LICENSE)-- Maintainer : Edward Kmett <ekmett@gmail.com>-- Stability : experimental-- Portability : TemplateHaskell-------------------------------------------------------------------------------moduleControl.Lens.TH(-- * Constructing Lenses AutomaticallymakeLenses,makeLensesFor,makeClassy,makeClassyFor,makeIso-- * Configuring Lenses,makeLensesWith,defaultRules,LensRules(LensRules),lensRules,classyRules,isoRules,lensIso,lensField,lensClass,lensFlags,LensFlag(..),simpleLenses,partialLenses,buildTraversals,handleSingletons,singletonIso,singletonRequired,createClass,createInstance,classRequired,singletonAndField)whereimportControl.ApplicativeimportControl.Lens.FoldimportControl.Lens.GetterimportControl.Lens.IsoimportControl.Lens.SetterimportControl.Lens.TupleimportControl.Lens.TraversalimportControl.Lens.TypeimportControl.Lens.IndexedLensimportControl.MonadimportData.Char(toLower)importData.Either(lefts)importData.Foldablehiding(concat)importData.Function(on)importData.ListasListimportData.MapasMaphiding(toList,map,filter)importData.Maybe(isNothing,isJust,catMaybes,fromJust)importData.Ord(comparing)importData.SetasSethiding(toList,map,filter)importData.Set.LensimportData.Traversablehiding(mapM)importLanguage.Haskell.THimportLanguage.Haskell.TH.Lens-- | Flags for lens constructiondataLensFlag=SimpleLenses|PartialLenses|BuildTraversals|SingletonAndField|SingletonIso|HandleSingletons|SingletonRequired|CreateClass|CreateInstance|ClassRequiredderiving(Eq,Ord,Show,Read)-- | Only Generate valid 'Simple' 'Lens' lenses.simpleLenses::SimpleLensLensRulesBoolsimpleLenses=lensFlags.containsSimpleLenses-- | Enables the generation of partial lenses, generating runtime errors for-- every constructor that does not have a valid definition for the lens. This-- occurs when the constructor lacks the field, or has multiple fields mapped-- to the same lens.partialLenses::SimpleLensLensRulesBoolpartialLenses=lensFlags.containsPartialLenses-- | In the situations that a lens would be partial, when 'partialLenses' is-- used, this flag instead causes traversals to be generated. Only one can be-- used, and if neither are, then compile-time errors are generated.buildTraversals::SimpleLensLensRulesBoolbuildTraversals=lensFlags.containsBuildTraversals-- | Handle singleton constructors specially.handleSingletons::SimpleLensLensRulesBoolhandleSingletons=lensFlags.containsHandleSingletons-- | When building a singleton 'Iso' (or 'Lens') for a record constructor, build both-- the 'Iso' (or 'Lens') for the record and the one for the field.singletonAndField::SimpleLensLensRulesBoolsingletonAndField=lensFlags.containsSingletonAndField-- | Use 'Iso' for singleton constructors.singletonIso::SimpleLensLensRulesBoolsingletonIso=lensFlags.containsSingletonIso-- | Expect a single constructor, single field newtype or data type.singletonRequired::SimpleLensLensRulesBoolsingletonRequired=lensFlags.containsSingletonRequired-- | Create the class if the constructor is simple and the 'lensClass' rule matches.createClass::SimpleLensLensRulesBoolcreateClass=lensFlags.containsCreateClass-- | Create the instance if the constructor is simple and the 'lensClass' rule matches.createInstance::SimpleLensLensRulesBoolcreateInstance=lensFlags.containsCreateInstance-- | Die if the 'lensClass' fails to match.classRequired::SimpleLensLensRulesBoolclassRequired=lensFlags.containsClassRequired-- | This configuration describes the options we'll be using to make isomorphisms or lenses.dataLensRules=LensRules{_lensIso::String->MaybeString,_lensField::String->MaybeString,_lensClass::String->Maybe(String,String),_lensFlags::SetLensFlag}-- | Lens to access the convention for naming top level isomorphisms in our lens rules.---- Defaults to lowercasing the first letter of the constructor.lensIso::SimpleLensLensRules(String->MaybeString)lensIsof(LensRulesinco)=(\i'->LensRulesi'nco)<$>fi-- | Lens to access the convention for naming fields in our lens rules.---- Defaults to stripping the _ off of the field name, lowercasing the name, and-- rejecting the field if it doesn't start with an '_'.lensField::SimpleLensLensRules(String->MaybeString)lensFieldf(LensRulesinco)=(\n'->LensRulesin'co)<$>fn-- | Retrieve options such as the name of the class and method to put in it to-- build a class around monomorphic data types.lensClass::SimpleLensLensRules(String->Maybe(String,String))lensClassf(LensRulesinco)=(\c'->LensRulesinc'o)<$>fc-- | Retrieve options such as the name of the class and method to put in it to-- build a class around monomorphic data types.lensFlags::SimpleLensLensRules(SetLensFlag)lensFlagsf(LensRulesinco)=LensRulesinc<$>fo-- | Default lens rulesdefaultRules::LensRulesdefaultRules=LensRulestopfield(constNothing)$Set.fromList[SingletonIso,SingletonAndField,CreateClass,CreateInstance,BuildTraversals]wheretop(c:cs)=Just(toLowerc:cs)top_=Nothingfield('_':c:cs)=Just(toLowerc:cs)field_=Nothing-- | Rules for making fairly simple partial lenses, ignoring the special cases-- for isomorphisms and traversals, and not making any classes.lensRules::LensRuleslensRules=defaultRules%lensIso.~constNothing%lensClass.~constNothing%handleSingletons.~True%partialLenses.~False%buildTraversals.~True-- | Rules for making lenses and traversals that precompose another lens.classyRules::LensRulesclassyRules=defaultRules%lensIso.~constNothing%handleSingletons.~False%lensClass.~classy%classRequired.~True%partialLenses.~False%buildTraversals.~Truewhereclassy::String->Maybe(String,String)classyn@(a:as)=Just("Has"++n,toLowera:as)classy_=Nothing-- | Rules for making an isomorphism from a data typeisoRules::LensRulesisoRules=defaultRules%singletonRequired.~True%singletonAndField.~True-- | Build lenses (and traversals) with a sensible default configuration.---- > makeLenses = makeLensesWith lensRulesmakeLenses::Name->Q[Dec]makeLenses=makeLensesWithlensRules-- | Make lenses and traversals for a type, and create a class when the type has no arguments.---- /e.g./---- @-- data Foo = Foo { _fooX, _fooY :: 'Int' }-- 'makeClassy' ''Foo-- @---- will create---- @-- class HasFoo t where-- foo :: 'Simple' 'Lens' t Foo-- instance HasFoo Foo where foo = 'id'-- fooX, fooY :: HasFoo t => 'Simple' 'Lens' t 'Int'-- @---- > makeClassy = makeLensesWith classyRulesmakeClassy::Name->Q[Dec]makeClassy=makeLensesWithclassyRules-- | Make a top level isomorphism injecting /into/ the type.---- The supplied name is required to be for a type with a single constructor that has a single argument---- /e.g./---- @-- newtype List a = List [a]-- makeIso ''List-- @---- will create---- @-- list :: Iso [a] [b] ('List' a) ('List' b)-- @---- > makeIso = makeLensesWith isoRulesmakeIso::Name->Q[Dec]makeIso=makeLensesWithisoRules-- | Derive lenses and traversals, specifying explicit pairings of @(fieldName, lensName)@.---- If you map multiple names to the same label, and it is present in the same constructor then this will generate a 'Traversal'.---- /e.g./---- > makeLensesFor [("_foo", "fooLens"), ("baz", "lbaz")] ''Foo-- > makeLensesFor [("_barX", "bar"), ("_barY", "bar)] ''BarmakeLensesFor::[(String,String)]->Name->Q[Dec]makeLensesForfields=makeLensesWith$lensRules%lensField.~(`Prelude.lookup`fields)-- | Derive lenses and traversals, using a named wrapper class, and specifying-- explicit pairings of @(fieldName, traversalName)@.---- Example usage:---- > makeClassyFor "HasFoo" "foo" [("_foo", "fooLens"), ("bar", "lbar")] ''FoomakeClassyFor::String->String->[(String,String)]->Name->Q[Dec]makeClassyForclsNamefunNamefields=makeLensesWith$classyRules%lensClass.~const(Just(clsName,funName))%lensField.~(`Prelude.lookup`fields)-- | Build lenses with a custom configuration.makeLensesWith::LensRules->Name->Q[Dec]makeLensesWithcfgnm=doinf<-reifynmcaseinfof(TyConIdecl)->casedeNewtypedeclof(DataDctxtyConNameargscons_)->caseconsof[NormalCdataConName[(_,ty)]]|cfg^.handleSingletons->makeIsoLensescfgctxtyConNameargsdataConNameNothingty[RecCdataConName[(fld,_,ty)]]|cfg^.handleSingletons->makeIsoLensescfgctxtyConNameargsdataConName(Justfld)ty_|cfg^.singletonRequired->fail"makeLensesWith: A single-constructor single-argument data type is required"|otherwise->makeFieldLensescfgctxtyConNameargscons_->fail"makeLensesWith: Unsupported data type"_->fail"makeLensesWith: Expected the name of a data type or newtype"wheredeNewtype(NewtypeDctxtyConNameargscd)=DataDctxtyConNameargs[c]ddeNewtyped=d------------------------------------------------------------------------------- Internal TH Implementation------------------------------------------------------------------------------- | Given a set of names, build a map from those names to a set of fresh names based on them.freshMap::SetName->Q(MapNameName)freshMapns=Map.fromList<$>for(toListns)(\n->(,)n<$>newName(nameBasen))makeIsoTo::Name->ExpQmakeIsoToconName=dof<-newName"f"a<-newName"a"lamE[varPf,conPconName[varPa]]$appsE[return(VarE'fmap),conEconName,varEf`appE`varEa]makeIsoFrom::Name->ExpQmakeIsoFromconName=dof<-newName"f"a<-newName"a"b<-newName"b"lamE[varPf,varPa]$appsE[return(VarE'fmap),lamE[conPconName[varPb]]$varEb,varEf`appE`(conEconName`appE`varEa)]makeIsoBody::Name->Name->(Name->ExpQ)->(Name->ExpQ)->DecQmakeIsoBodylensNameconNamefg=funDlensName[clause[](normalBbody)[]]wherebody=appsE[return(VarE'isomorphic),fconName,gconName]makeLensBody::Name->Name->(Name->ExpQ)->(Name->ExpQ)->DecQmakeLensBodylensNameconNamef_=funDlensName[clause[](normalB(fconName))[]]plain::TyVarBndr->TyVarBndrplain(KindedTVt_)=PlainTVtplain(PlainTVt)=PlainTVtappArgs::Type->[TyVarBndr]->TypeappArgst[]=tappArgst(x:xs)=appArgs(AppTt(VarT(x^.name)))xsapps::Type->[Type]->Typeapps=Prelude.foldlAppTappsT::TypeQ->[TypeQ]->TypeQappsT=Prelude.foldlappT-- | Given---- > newtype Cxt b => Foo a b c d = Foo { _baz :: Bar a b }---- This will generate:---- > foo :: (Cxt b, Cxt f) => Iso (Foo a b c d) (Foo e f g h) (Bar a b) (Bar e f)-- > foo = isomorphic (\f a -> (\(Foo b) -> b) <$> f (Foo a))-- > (\f (Foo a) -> fmap Foo (f a))-- > {-# INLINE foo #-}-- > baz :: (Cxt b, Cxt f) => Iso (Bar a b) (Bar e f) (Foo a b c d) (Foo e f g h)-- > baz = isomorphic (\f (Foo a) -> fmap Foo (f a))-- > (\f a -> fmap (\(Foo b) -> b) (f (Foo a)))-- > {-# INLINE baz #-}makeIsoLenses::LensRules->Cxt->Name->[TyVarBndr]->Name->MaybeName->Type->Q[Dec]makeIsoLensescfgctxtyConNametyArgs0dataConNamemaybeFieldNamepartTy=dolettyArgs=mapplaintyArgs0m<-freshMap$setOftypeVarstyArgsletaty=partTybty=substTypeVarsmatycty=appArgs(ConTtyConName)tyArgsdty=substTypeVarsmctyquantified=ForallT(tyArgs++substTypeVarsmtyArgs)(ctx++substTypeVarsmctx)maybeIsoName=mkName<$>viewlensIsocfg(nameBasedataConName)lensOnly=not$cfg^.singletonIsoisoCon|lensOnly=ConT''Lens|otherwise=ConT''IsomakeBody|lensOnly=makeLensBody|otherwise=makeIsoBodyisoDecls<-flip(maybe(return[]))maybeIsoName$\isoName->doletdecl=SigDisoName$quantified$isoCon`apps`ifcfg^.simpleLensesthen[aty,aty,cty,cty]else[aty,bty,cty,dty]body<-makeBodyisoNamedataConNamemakeIsoFrommakeIsoTo#ifndef INLININGreturn[decl,body]#elseinlining<-inlinePragmaisoNamereturn[decl,body,inlining]#endifaccessorDecls<-casemkName<$>(maybeFieldName>>=viewlensFieldcfg.nameBase)ofjfn@(JustlensName)|(jfn/=maybeIsoName)&&(isNothingmaybeIsoName||cfg^.singletonAndField)->doletdecl=SigDlensName$quantified$isoCon`apps`ifcfg^.simpleLensesthen[cty,cty,aty,aty]else[cty,dty,aty,bty]body<-makeBodylensNamedataConNamemakeIsoTomakeIsoFrom#ifndef INLININGreturn[decl,body]#elseinlining<-inlinePragmalensNamereturn[decl,body,inlining]#endif_->return[]return$isoDecls++accessorDeclsmakeFieldLensBody::Bool->Name->[(Con,[Name])]->MaybeName->QDecmakeFieldLensBodyisTraversallensNameconListmaybeMethodName=casemaybeMethodNameofJustmethodName->dogo<-newName"go"letexpr=infixApp(varEmethodName)(varE'(Prelude..))(varEgo)funDlensName[clause[](normalBexpr)[funDgoclauses]]Nothing->funDlensNameclauseswhereclauses=mapbuildClauseconListbuildClause(con,fields)=dof<-newName"_f"vars<-for(con^..conNamedFields._1)$\field->iffield`List.elem`fieldsthenLeft<$>((,)<$>newName('_':(nameBasefield++"'"))<*>newName('_':nameBasefield))elseRight<$>newName('_':nameBasefield)letcpats=map(varP.eitherfstid)vars-- Deconstructioncvals=map(varE.eithersndid)vars-- Reconstructionfpats=map(varP.snd)$leftsvars-- Lambda patternsfvals=map(appE(varEf).varE.fst)$leftsvars-- Functor applicationsconName=con^.namerecon=appsE$conEconName:cvalsexpr|notisTraversal&&lengthfields/=1=appE(varE'error).litE.stringL$showlensName++": expected a single matching field in "++showconName++", found "++show(lengthfields)|List.nullfields=appE(varE'pure)recon|otherwise=letstepNothingr=Just$infixE(Just$lamEfpatsrecon)(varE'(<$>))(Justr)step(Justl)r=Just$infixE(Justl)(varE'(<*>))(Justr)infromJust$List.foldlstepNothingfvals-- = infixE (Just $ lamE fpats recon) (varE '(<$>)) $ Just $ List.foldl1 (\l r -> infixE (Just l) (varE '(<*>)) (Just r)) fvalsclause[varPf,conPconNamecpats](normalBexpr)[]makeFieldLenses::LensRules->Cxt-- ^ surrounding cxt driven by the data type context->Name-- ^ data/newtype constructor name->[TyVarBndr]-- ^ args->[Con]->Q[Dec]makeFieldLensescfgctxtyConNametyArgs0cons=dolettyArgs=mapplaintyArgs0maybeLensClass=doguard$tyArgs==[]viewlensClasscfg$nameBasetyConNamemaybeClassName=fmap(^._1.tomkName)maybeLensClasst<-newName"t"a<-newName"a"--TODO: there's probably a more efficient way to do this.lensFields<-map(\xs->(fst$headxs,mapsndxs)).groupBy((==)`on`fst).sortBy(comparingfst).concat<$>mapM(getLensFields$viewlensFieldcfg)cons-- varMultiSet knows how many usages of the type variables there are.letvarMultiSet=List.concatMap(toListOf(conFields._2.typeVars))consvarSet=Set.fromList$map(viewname)tyArgsbodies<-forlensFields$\(lensName,fields)->doletfieldTypes=map(view_3)fields-- All of the polymorphic variables not involved in these fieldsotherVars=varMultiSetList.\\fieldTypes^..typeVars-- New type variable binders, and the type to represent the selected fields(tyArgs',cty)<-unifyTypestyArgsfieldTypes-- Map for the polymorphic variables that are only involved in these fields, to new names for them.m<-freshMap.Set.differencevarSet$Set.fromListotherVarsletaty|isJustmaybeClassName=VarTt|otherwise=appArgs(ConTtyConName)tyArgs'bty=substTypeVarsmatydty=substTypeVarsmctys=setOffoldedmrelevantBndrb=s^.contains(b^.name)relevantCtx=not.Set.null.Set.intersections.setOftypeVarstvs=tyArgs'++filterrelevantBndr(substTypeVarsmtyArgs')ps=ctx++filterrelevantCtx(substTypeVarsmctx)qs=casemaybeClassNameofJustn|not(cfg^.createClass)->ClassPn[VarTt]:ps_->pstvs'|isJustmaybeClassName&&not(cfg^.createClass)=PlainTVt:tvs|otherwise=tvs--TODO: Better way to write this?fieldMap=fromListWith(++)$map(\(cn,fn,_)->(cn,[fn]))fieldsconList=map(\c->(c,Map.findWithDefault[](viewnamec)fieldMap))consmaybeMethodName=fmap(mkName.view_2)maybeLensClassisTraversal<-doletnotSingular=filter((/=1).length.snd)conListshowCon(c,fs)=pprint(viewnamec)++" { "++concat(intersperse", "$mappprintfs)++" }"case(cfg^.buildTraversals,cfg^.partialLenses)of(True,True)->fail"Cannot makeLensesWith both of the flags buildTraversals and partialLenses."(False,True)->returnFalse(True,False)|List.nullnotSingular->returnFalse|otherwise->returnTrue(False,False)|List.nullnotSingular->returnFalse|otherwise->fail.unlines$["Cannot use 'makeLensesWith' with constructors that don't map just one field","to a lens, without using either the buildTraversals or partialLenses flags.",iflengthconList==1then"The following constructor failed this criterion for the "++pprintlensName++" lens:"else"The following constructors failed this criterion for the "++pprintlensName++" lens:"]++mapshowConconList--TODO: consider detecting simpleLenses, and generating signatures involving "Simple"?letdecl=SigDlensName.ForallTtvs'qs.apps(ifisTraversalthenConT''TraversalelseConT''Lens)$ifcfg^.simpleLensesthen[aty,aty,cty,cty]else[aty,bty,cty,dty]body<-makeFieldLensBodyisTraversallensNameconListmaybeMethodName#ifndef INLININGreturn[decl,body]#elseinlining<-inlinePragmalensNamereturn[decl,body,inlining]#endifletdefs=Prelude.concatbodiescasemaybeLensClassofNothing->returndefsJust(clsNameString,methodNameString)->doletclsName=mkNameclsNameStringmethodName=mkNamemethodNameStringPrelude.sequence$filter(\_->cfg^.createClass)[classD(return[])clsName[PlainTVt][](sigDmethodName(appsT(conT''Lens)[varTt,varTt,conTtyConName,conTtyConName]):mapreturndefs)]++filter(\_->cfg^.createInstance)[instanceD(return[])(conTclsName`appT`conTtyConName)[funDmethodName[clause[varPa](normalB(varEa))[]]#ifdef INLINING,inlinePragmamethodName#endif]]++filter(\_->not$cfg^.createClass)(mapreturndefs)-- | Gets @[(lens name, (constructor name, field name, type))]@ from a record constructorgetLensFields::(String->MaybeString)->Con->Q[(Name,(Name,Name,Type))]getLensFieldsf(RecCcnfs)=return.catMaybes$map(\(fn,_,t)->(\ln->(mkNameln,(cn,fn,t)))<$>f(nameBasefn))fsgetLensFields__=return[]-- TODO: properly fill this out---- Ideally this would unify the different field types, and figure out which polymorphic variables-- need to be the same. For now it just leaves them the same and yields the first type.-- (This leaves us open to inscrutable compile errors in the generated code)unifyTypes::[TyVarBndr]->[Type]->Q([TyVarBndr],Type)unifyTypestvstys=return(tvs,headtys)#if !(MIN_VERSION_template_haskell(2,7,0))-- | The orphan instance for old versions is bad, but programing without 'Applicative' is worse.instanceApplicativeQwherepure=return(<*>)=ap#endif#ifdef INLININGinlinePragma::Name->QDec#if MIN_VERSION_template_haskell(2,8,0)# ifdef OLD_INLINE_PRAGMAS-- 7.6rc1?inlinePragmamethodName=pragInlDmethodName$inlineSpecNoPhaseInlineFalse# else-- 7.7.20120830inlinePragmamethodName=pragInlDmethodNameInlineFunLikeAllPhases# endif#else-- GHC <7.6, TH <2.8.0inlinePragmamethodName=pragInlDmethodName$inlineSpecNoPhaseTrueFalse#endif#endif