{-# LANGUAGE FlexibleContexts, PatternGuards #-}moduleCurry.ExtendedFlat.TypeInference(dispType,adjustTypeInfo,labelVarsWithTypes,uniqueTypeIndices,genEquations,elimFreeTypes)whereimportDebug.TraceimportText.PrettyPrint.HughesPJimportControl.Monad.StateimportControl.Monad.ReaderimportData.MaybeimportqualifiedData.IntMapasIntMapimportCurry.ExtendedFlat.TypeimportCurry.ExtendedFlat.Goodiestrace'msgx=x-- trace msg x -- | For every identifier that occurs in the right hand side-- of a declaration, the polymorphic type variables in its-- type label are replaced by concrete types.adjustTypeInfo::Prog->ProgadjustTypeInfo=-- elimFreeTypes .genEquations.uniqueTypeIndices.labelVarsWithTypes-- | Displays a TypeExpr as a stringdispType::TypeExpr->StringdispType=render.prettyTypeprettyType::TypeExpr->DocprettyType(TVari)=text('t':showi)prettyType(FuncTypefx)=parens(prettyTypef)<+>text"->"<+>prettyTypexprettyType(TConsqnts)=letn=let(m,l)=qnOfqninm++'.':lintextn<+>hsep(map(parens.prettyType)ts)prettyAllEqns=render.prettyEqnswhereprettyEqn::(TVarIndex,TypeExpr)->DocprettyEqn(l,r)=(char't'<>intl<+>text"->"<+>prettyTyper)prettyEqns((m,l),t,eqns)=textm<>char'.'<>textl<+>text"::"<+>prettyTypet<>char':'$$(nest5(vcat(mapprettyEqneqns)))postOrderExpr::Monadm=>(Expr->mExpr)->Expr->mExprpostOrderExprf=powherepoe@(Var_)=fepoe@(Lit_)=fepo(Combtnes)=does'<-mapMpoesf(Combtnes')po(Freevse)=doe'<-poef(Freevse')po(Letbse)=dobs'<-mapMpoBindbse'<-poef(Letbs'e')po(Orlr)=liftM2Or(pol)(por)>>=fpo(Caseptebs)=doe'<-poebs'<-mapMpoBranchbsf(Casepte'bs')poBind(v,rhs)=dorhs'<-porhsreturn(v,rhs')poBranch(Branchprhs)=dorhs'<-porhsreturn(Branchprhs')postOrderType::Monadm=>(TypeExpr->mTypeExpr)->TypeExpr->mTypeExprpostOrderTypef=powherepoe@(TVar_)=fepo(FuncTypet1t2)=dot1'<-pot1t2'<-pot2f(FuncTypet1't2')po(TConsqnts)=dots'<-mapMpotsf(TConsqnts')visitTVars::Monadm=>(TVarIndex->mTypeExpr)->TypeExpr->mTypeExprvisitTVarsf=postOrderTypef'wheref'(TVari)=fif't=returnt-- ------------------------------------------------------------------------ ------------------------------------------------------------------------ | All identifiers that do not have type annotations are-- labelled with new type variableslabelVarsWithTypes::Prog->ProglabelVarsWithTypes=updProgFuncsupdateFuncwhereupdateFunc=map(\func->letmaxtvi=maxFuncTVfunc+1intrFunc(foomaxtvi)func)foomaxtvqnarityvistyter@(External_)=Funcqnarityvistyterfoomaxtvqnarityvistyter@(Rulevsexpr)=letexpr'=evalState(runReaderT(withVSvs(poexpr))typeMap)maxtvtypeMap=trace'(showargTypes)$IntMap.fromListargTypesargTypes=[(vi,t)|VarIndex(Justt)vi<-vs]inFuncqnarityvistyte(Rulevsexpr')po::Expr->ReaderTTypeMap(StateInt)Expr-- type information from vi is superseded by type information-- from the map. This is okay in the current context, but for-- general type inference this would result in loss of information.-- (Fix by unifying both types in a later version)poe@(Varvi)=dovt<-asks(IntMap.lookup$idxOfvi)casevtofJustt->return(Varvi{typeofVar=Justt})Nothing->casetypeofVarviofNothing->error$"no type for var "++showe_->liftMVar(poVarIndexvi)poe@(Lit_)=returnepo(Combtnes)=does'<-mapMpoesn'<-poQNamenreturn(Combtn'es')po(Freevse)=dovs'<-mapMpoVarIndexvse'<-poereturn(Freevs'e')po(Letbse)=dolet(vs,es)=unzipbsvs'<-mapMpoVarIndexvswithVSvs'(does'<-mapMpoese'<-poereturn(Let(zipvs'es')e'))po(Orlr)=liftM2Or(pol)(por)po(Caseptebs)=doe'<-poebs'<-mapMpoBranchbsreturn(Casepte'bs')poBranch(Branch(Patternqnvs)rhs)=doqn'<-poQNameqnvs'<-mapMpoVarIndexvswithVSvs'(dorhs'<-porhsreturn(Branch(Patternqn'vs')rhs'))poBranch(Branch(LPatternl)e)=dorhs'<-poereturn(Branch(LPatternl)e)poVarIndexvi=dot<-maybe(lift$freshTVar)return.typeofVar$vireturnvi{typeofVar=Justt}poQNameqn=dot<-maybe(lift$freshTVar)return.typeofQName$qnreturnqn{typeofQName=Justt}withVS::MonadReaderTypeMapm=>[VarIndex]->ma->mawithVSvsaction=local(\m->foldr(\v->IntMap.insert(idxOfv)(fromJust$typeofVarv))mvs)action-- ------------------------------------------------------------------------ ------------------------------------------------------------------------ | Type variables that occur in the type annotations of QNames-- are replaced by newly introduced type variables, so that further-- unification steps will not interfere with parametric polymorphismuniqueTypeIndices::Prog->ProguniqueTypeIndices=updProgFuncs(mapupdateFunc)whereupdateFuncfunc=letfirstfree=maxFuncTVfunc+1in(updFuncRule(trRule(ruleFoofirstfree)External))funcruleFoofirstfreeargsexpr=letexpr'=evalState(postOrderExprrelabelTypesexpr)firstfreeinRuleargsexpr'relabelTypes::Expr->StateTVarIndexExprrelabelTypes(Combctqnameargs)=dot'<-casetypeofQNameqnameofJustlt->relabelTypeltNothing->freshTVarreturn(Combctqname{typeofQName=Justt'}args)relabelTypes(Varv)|typeofVarv==Nothing=dot<-freshTVarreturn(Varv{typeofVar=Justt})relabelTypes(Caseptebs)=dobs'<-mapMrelabelPatTypebsreturn(Caseptebs')whererelabelPatType(Branch(Patternqnvis)e)=dot'<-casetypeofQNameqnofJustlt->relabelTypeltNothing->freshTVarreturn(Branch(Patternqn{typeofQName=Justt'}vis)e)relabelPatTypebe=returnberelabelTypest=returntrelabelType::TypeExpr->StateTVarIndexTypeExprrelabelTypet=evalStateT(visitTVarstypeFoot)IntMap.emptywheretypeFooi=dom<-getcaseIntMap.lookupimofJustv->returnvNothing->dov<-liftfreshTVarmodify(IntMap.insertiv)returnv-- ------------------------------------------------------------------------ ---------------------------------------------------------------------- typeTypeMap=IntMap.IntMapTypeExprtypeEqnMonad=StateTTypeMap(StateTVarIndex)-- | Specialises all type variables (part of adjustTypeInfo)genEquations::Prog->ProggenEquations=updProgFuncsupdateFuncwhereupdateFunc=map(\func->letmaxtvi=maxFuncTVfunc+1intrFunc(foomaxtvi)func)foomaxtvqnarityvistyter@(External_)=Funcqnarityvistyterfoomaxtvqnarityvistyter@(Rulevsexpr)=leth=evalState(execStateT(doargTypes<-mapMvarIndexTypevsetype<-equationsexprqnt<-qnTypeqnqnt=:=foldrFuncTypeetypeargTypesreturn())IntMap.empty)maxtvintrace'(prettyAllEqns(qnOfqn,te,IntMap.toListh))Funcqnarityvisty(specialiseTypehte)(specInRuleh(Rulevsexpr))equations::Expr->EqnMonadTypeExprequations=trExprvarIndexType(return.typeofLiteral)combEqnletEqnfrEqnorEqncasEqnbranchEqnwherecombEqn::(CombType->QName->[EqnMonadTypeExpr]->EqnMonadTypeExpr)combEqn_qnargs=doresultType<-lift$freshTVarargTypes<-sequenceargstqn<-qnTypeqntqn=:=foldrFuncTyperesultTypeargTypesreturnresultTypeletEqn_e=efrEqn_e=eorEqnlr=dol'<-lr'<-rl'=:=r'casEqn::SrcRef->CaseType->EqnMonadTypeExpr->[(Pattern,EqnMonadTypeExpr)]->EqnMonadTypeExprcasEqn__scr[]=scr>>(lift$freshTVar)casEqn__scrps=doscrt<-scr-- unify patterns with scrutineemapM_(unifLhsscrt)ps-- unify right hand sides(p:ps')<-sequence$mapsndpsfoldM(=:=)pps'unifLhsscrt(LPatternlit,_)=typeofLiterallit=:=scrtunifLhsscrt(Patternqnvs,_)=doqnt<-qnTypeqnargTypes<-mapMvarIndexTypevsqnt=:=foldrFuncTypescrtargTypesbranchEqn::Pattern->EqnMonadTypeExpr->(Pattern,EqnMonadTypeExpr)branchEqnpe=(p,e)unify::TypeExpr->TypeExpr->TypeMap->TypeMap-- t =:= u = return tunify(TVari)ttm|Justs<-IntMap.lookupitm=unifysttmunifys(TVarj)tm|Justt<-IntMap.lookupjtm=unifysttmunifys@(TVari)t@(TVarj)tm|i==j=tm|i<j=IntMap.insertjstm|i>j=IntMap.insertittmunify(TVari)ttm=IntMap.insertittmunifys(TVarj)tm=IntMap.insertjstmunify(FuncTypefx)(FuncTypegy)tm=unifyxy(unifyfgtm)unify(TConsmas)(TConsnbs)tm|m==n=foldr($)tm(zipWithunifyasbs)unifyst_=error.render$text"Types differ: "<+>prettyTypes<+>text"/="<+>prettyTypet(=:=)::TypeExpr->TypeExpr->EqnMonadTypeExpra=:=b=modify(unifyab)>>returnavarIndexType::VarIndex->EqnMonadTypeExprvarIndexType=maybe(lift$freshTVar)return.typeofVarqnType::QName->EqnMonadTypeExprqnType=maybe(lift$freshTVar)return.typeofQNamefreshTVar::MonadStateIntm=>mTypeExprfreshTVar=donextIdx<-getmodifysuccreturn(TVarnextIdx)----------------------------------------------------------------------- | Type variables that occur in the right hand side of a declaration-- but not in its type signature are replaced by the unit type ().-- This function requires that proper type information has been made-- available by function @adjustTypeInfo@elimFreeTypes::Prog->ProgelimFreeTypes=updProgFuncsupdateFuncwhereupdateFunc=map(trFuncfoo)fooqnarityvistyter@(External_)=Funcqnarityvistyterfooqnarityvistyter@(Rulevsexpr)=lettvs=tvarstetvars(TVarvi)=[vi]tvars(FuncTypet1t2)=tvarst1++tvarst2tvars(TCons_ts)=concatMaptvarststfoot@(TVarvi)|vi`elem`tvs=t|otherwise=TCons(mkQName("Prelude","()"))[]tfoo(FuncTypet1t2)=FuncType(tfoot1)(tfoot2)tfoo(TConsqnts)=TConsqn(maptfoots)inFuncqnarityvistyte(modifyTypetfoo(Rulevsexpr))---------------------------------------------------------------------maxFuncTV=trFunc(\qn__ter->max(maxQNameTVqn)(max(maxTypeTVte)(maxRuleTVr)))wheremaxRuleTV=trRule(\vise->maximum(maxExprTVe:mapmaxVarIndexTVvis))(const(-1))maxExprTV::Expr->IntmaxExprTV=trExprvarlitcombltfrmaxcasbranchwherevar=maxVarIndexTVlit=const(-1)comb_qnms=maximum(maxQNameTVqn:ms)ltbse=maximum(e:mapmaxBindTVbs)frvse=maximum(e:mapmaxVarIndexTVvs)cas__eps=maximum(e:ps)branchpe=maxe(maxPatternTVp)maxQNameTV=maybe(-1)maxTypeTV.typeofQNamemaxVarIndexTV=maybe(-1)maxTypeTV.typeofVarmaxBindTV(vi,e)=maxe(maxVarIndexTVvi)maxPatternTV(Patternqnvis)=maximum(maxQNameTVqn:mapmaxVarIndexTVvis)maxPatternTV(LPattern_)=-1maxTypeTV=trTypeExpridtappmaxwheretapp_args=maximum(-1:args)--------------------specialiseType::TypeMap->TypeExpr->TypeExprspecialiseTypemt=trTypeExpr(foom)TConsFuncTypetwherefoomi=maybe(TVari)(specialiseTypem)(IntMap.lookupim)-- boilerplatespecInRule::TypeMap->Rule->RulespecInRuletm=modifyType(specialiseTypetm)-- boilerplatemodifyType::(TypeExpr->TypeExpr)->Rule->RulemodifyTypef=updRule(mapspecInVarIndex)specInExpridwherespecInExpr=trExprvarLitcombletexpfreeOrCasealtvarvi=Var(specInVarIndexvi)combctqnas=Combct(specInQNameqn)asletexpbse=Let(mapspecInBindbs)efreevise=Free(mapspecInVarIndexvis)ealtpe=Branch(specInPatternp)especInBind(vi,e)=(specInVarIndexvi,e)specInPattern(Patternqnvis)=Pattern(specInQNameqn)(mapspecInVarIndexvis)specInPatternp=pspecInVarIndexvi=vi{typeofVar=fmapf(typeofVarvi)}specInQNameqn=qn{typeofQName=fmapf(typeofQNameqn)}