{-# OPTIONS -Wall -fno-warn-unused-binds #-}{-# LANGUAGE CPP #-}{-# LANGUAGE NoMonomorphismRestriction #-}moduleLanguage.Haskell.TH.ExpandSyns(-- * Expand synonymsexpandSyns-- * Misc utilities,substInType,substInCon,evades,evade)whereimportLanguage.Haskell.THhiding(cxt)importqualifiedData.SetasSetimportData.GenericsimportControl.Monad-- For ghci#ifndef MIN_VERSION_template_haskell#define MIN_VERSION_template_haskell(X,Y,Z) 1#endifpackagename::Stringpackagename="th-expand-syns"-- Compatibility layer for TH >=2.4 vs. 2.3tyVarBndrGetName::TyVarBndr->NamemapPred::(Type->Type)->Pred->PredbindPred::(Type->QType)->Pred->QPredtyVarBndrSetName::Name->TyVarBndr->TyVarBndr#if MIN_VERSION_template_haskell(2,4,0)tyVarBndrGetName(PlainTVn)=ntyVarBndrGetName(KindedTVn_)=nmapPredf(ClassPnts)=ClassPn(f<$>ts)mapPredf(EqualPt1t2)=EqualP(ft1)(ft2)bindPredf(ClassPnts)=ClassPn<$>mapMftsbindPredf(EqualPt1t2)=EqualP<$>ft1<*>ft2tyVarBndrSetNamen(PlainTV_)=PlainTVntyVarBndrSetNamen(KindedTV_k)=KindedTVnk#elsetypeTyVarBndr=NametypePred=TypetyVarBndrGetName=idmapPred=idbindPred=idtyVarBndrSetNamen_=n#endif(<$>)::(Functorf)=>(a->b)->fa->fb(<$>)=fmap(<*>)::(Monadm)=>m(a->b)->ma->mb(<*>)=aptypeSynInfo=([Name],Type)nameIsSyn::Name->Q(MaybeSynInfo)nameIsSynn=doi<-reifyncaseiofTyConId->decIsSyndClassI{}->returnNothingPrimTyConI{}->returnNothing_->dowarn("Don't know how to interpret the result of reify "++shown++" (= "++showi++"). I will assume that "++shown++" is not a type synonym.")returnNothingwarn::String->Q()warnmsg=reportFalse(packagename++": "++"WARNING: "++msg)-- | Handles only declaration constructs that can be returned by 'reify'ing a type name.decIsSyn::Dec->Q(MaybeSynInfo)decIsSyn(ClassD{})=returnNothingdecIsSyn(DataD{})=returnNothingdecIsSyn(NewtypeD{})=returnNothingdecIsSyn(TySynD_varst)=return(Just(tyVarBndrGetName<$>vars,t))#if MIN_VERSION_template_haskell(2,4,0)decIsSyn(FamilyD_name__)=dowarn("Type families (data families, newtype families, associated types and type synonym families) are currently not supported (they won't be expanded). Name of unsupported family: "++showname)returnNothing#endifdecIsSynx=dowarn("Unrecognized declaration construct: "++showx++". I will assume that it's not a type synonym declaration.")returnNothing-- | Expands all type synonyms in the given type. Type families currently won't be expanded (but will be passed through).expandSyns::Type->QTypeexpandSyns=(\t->do(acc,t')<-go[]treturn(foldlAppTt'acc))wheregoaccListT=return(acc,ListT)goaccArrowT=return(acc,ArrowT)goaccx@(TupleT_)=return(acc,x)goaccx@(VarT_)=return(acc,x)go[](ForallTnscxtt)=docxt'<-mapM(bindPredexpandSyns)cxtt'<-expandSynstreturn([],ForallTnscxt't')goaccx@(ForallT___)=fail(packagename++": Unexpected application of the local quantification: "++showx++"\n (to the arguments "++showacc++")")goacc(AppTt1t2)=dor<-expandSynst2go(r:acc)t1goaccx@(ConTn)=doi<-nameIsSynncaseiofNothing->return(acc,x)Just(vars,body)->iflengthacc<lengthvarsthenfail(packagename++": expandSyns: Underapplied type synonym:"++show(n,acc))elseletsubsts=zipvarsaccexpanded=foldrsubstbodysubstsingo(drop(lengthvars)acc)expanded#if MIN_VERSION_template_haskell(2,4,0)goacc(SigTtkind)=do(acc',t')<-goacctreturn(acc',SigTt'kind)#endif#if MIN_VERSION_template_haskell(2,6,0)goaccx@(UnboxedTupleT_)=return(acc,x)#endifclassSubstTypeVariableawhere-- | Capture-free substitutionsubst::(Name,Type)->a->ainstanceSubstTypeVariableTypewheresubst(v,t)=gowherego(AppTxy)=AppT(gox)(goy)gos@(ConT_)=sgos@(VarTw)|v==w=t|otherwise=sgoArrowT=ArrowTgoListT=ListTgo(ForallTvarscxtbody)=commonForallCase(v,t)(vars,cxt,body)gos@(TupleT_)=s#if MIN_VERSION_template_haskell(2,4,0)go(SigTt1kind)=SigT(got1)kind#endif#if MIN_VERSION_template_haskell(2,6,0)gos@(UnboxedTupleT_)=s#endif-- testCapture :: Type-- testCapture = -- let -- n = mkName-- v = VarT . mkName-- in-- substInType (n "x", v "y" `AppT` v "z")-- (ForallT -- [n "y",n "z"] -- [ConT (mkName "Show") `AppT` v "x" `AppT` v "z"]-- (v "x" `AppT` v "y"))#if MIN_VERSION_template_haskell(2,4,0)instanceSubstTypeVariablePredwheresubsts=mapPred(substs)#endif-- | Make a name (based on the first arg) that's distinct from every name in the second arg---- Example why this is necessary:---- > type E x = forall y. Either x y-- >-- > ... expandSyns [t| forall y. y -> E y |]---- The example as given may actually work correctly without any special capture-avoidance depending-- on how GHC handles the @y@s, but in any case, the input type to expandSyns may be an explicit-- AST using 'mkName' to ensure a collision.--evade::Datad=>Name->d->Nameevadent=letvars::Set.SetNamevars=everythingSet.union(mkQSet.emptySet.singleton)tgon1=ifn1`Set.member`varsthengo(bumpn1)elsen1bump=mkName.('f':).nameBaseingon-- | Make a list of names (based on the first arg) such that every name in the result-- is distinct from every name in the second arg, and from the other resultsevades::(Datat)=>[Name]->t->[Name]evadesnst=foldrc[]nswherecnrec=evaden(rec,t):rec-- evadeTest = let v = mkName "x"-- in-- evade v (AppT (VarT v) (VarT (mkName "fx")))instanceSubstTypeVariableConwheresubst(v,t)=gowherest=subst(v,t)go(NormalCnts)=NormalCn[(x,sty)|(x,y)<-ts]go(RecCnts)=RecCn[(x,y,stz)|(x,y,z)<-ts]go(InfixC(y1,t1)op(y2,t2))=InfixC(y1,stt1)op(y2,stt2)go(ForallCvarscxtbody)=commonForallCase(v,t)(vars,cxt,body)classHasForallConstructawheremkForall::[TyVarBndr]->Cxt->a->ainstanceHasForallConstructTypewheremkForall=ForallTinstanceHasForallConstructConwheremkForall=ForallCcommonForallCase::(SubstTypeVariablea,HasForallConstructa)=>(Name,Type)->([TyVarBndr],Cxt,a)->acommonForallCasevt@(v,t)(bndrs,cxt,body)-- If a variable with the same name as the one to be replaced is bound by the forall, -- the variable to be replaced is shadowed in the body, so we leave the whole thing alone (no recursion)|v`elem`(tyVarBndrGetName<$>bndrs)=mkForallbndrscxtbody|otherwise=let-- prevent capturevars=tyVarBndrGetName<$>bndrsfreshes=evadesvarstfreshTyVarBndrs=zipWithtyVarBndrSetNamefreshesbndrssubsts=zipvars(VarT<$>freshes)doSubsts::SubstTypeVariableb=>b->bdoSubstsx=foldrsubstxsubstsinmkForallfreshTyVarBndrs(fmap(substvt.doSubsts)cxt)((substvt.doSubsts)body)-- | Capture-free substitutionsubstInType::(Name,Type)->Type->TypesubstInType=subst-- | Capture-free substitutionsubstInCon::(Name,Type)->Con->ConsubstInCon=subst