>-- | Converts an 'HsModule' into the abstract syntax tree used by HFusion.>-- The HsModule can be obtained by parsing a Haskell program with >-- 'Language.Haskell.Parser.parseModule'>hsModule2HsSyn::HsModule->FusionState[Def]>hsModule2HsSynm=dop<-lift(hsModule2HsSyn_m)>casepof>([],dfs)->returndfs>(e:_,_)->throwErrore

>convertDecl2Def::HsDecl->FusionStateDef>convertDecl2DefhsDecl=>casehsDeclof>HsFunBindhsMatches->fhsMatches>HsPatBindloc(HsPVarhsName)hsRhshsDecls->f[HsMatchlochsName[]hsRhshsDecls]>HsForeignExport_____->fail"foreign exports are not supported">HsForeignImport______->fail"foreign imports are not supported">HsTypeSig___->fail"type signatures are not supported">HsDefaultDecl__->fail"Default declarations are not supported">HsInstDecl_____->fail"Instance declarations are not supported">HsClassDecl_____->fail"Class declarations are not supported">HsNewTypeDecl______->fail"New type declarations are not supported">HsInfixDecl____->fail"Infix declarations are not supported">HsTypeDecl____->fail"Type declarations are not supported">HsDataDecl______->fail"Data declarations are not supported">HsPatBind____->fail"non variable pattern bindings are not supported">wherefhsMatches=>dor<-mapMconvertHsMatchhsMatches>let(ns,args,ts)=unzip3r>ifnullnsthenfail"convertDecl2Term: we got an empty declaration">elselift(updateVariableGeneratorState(nub(vars(headns)++varsargs++varsBts))>>>joinEquationsargsts>>=return.Defvalue(headns))>updateVariableGeneratorStatevs=dogi<-get;put(foldrupdateStgivs)>updateSt(Vgenpi)gi=M.insertWithmaxp(i+1)gi>updateSt(Vuserdefs)gi=casestr2varsof>v@(Vgen__)->updateStvgi>_->gi

>joinEquations::[[EitherPatternVariable]]->[Term]->VarGenStateTerm>joinEquationsargsts=do(vs,t)<-renameVars(unifyPatternsargs)ts>return(foldr(Tlamb.Bvar)tvs)>whererenameVarsargsts=doletargs'=transposeargs>vs'<-mapMgenVarargs'>(vs'',ts')<-sustsvs'args'argsts>letvps=leftPosvs''>t|nullvps=headts'>|null(tailvps)=Tcase(Tvar(headvps))(maphead$mapleftPosargs)ts'>|otherwise=Tcase(TtupleFalse$mapTvarvps)(mapPtuple$mapleftPosargs)ts'>return(map(eitheridid)vs'',t)>leftPos=map(eitherid(error"joinEquations")).filter(either(constTrue)(constFalse))>genVarls@(Left_:_)=getFreshVar"v">>=return.Left>genVarls@(Rightv:_)=return(Rightv)>genVar_=error"joinEquations: This should never had hapenned.">susts::[EitherVariableVariable]->[[EitherPatternVariable]]->>[[EitherPatternVariable]]->[Term]->VarGenState([EitherVariableVariable],[Term])>sustsvs'args'argsts=letinds=catMaybes$zipWith(\ib->ifbthen(Justi)elseNothing)[0..]$>zipWithcheckEqvs'args'>indous<-mapM(const(getFreshVar"v"))inds>letinds'=zipindsus>return(map(toVarinds')(zip[0..]vs'),zipWith(susts'vs'inds')argsts)>susts'::[EitherVariableVariable]->[(Int,Variable)]->[EitherPatternVariable]->Term->Term>susts'vs'inds'argt=substitution(map(toPairarg)inds')t>checkEq(Righta)ls=any(either(constFalse)(a/=))ls>checkEq__=False>toPairl(i,u)=either(error"joinEquations")(\v->(v,Tvaru))(l!!i)>toVarinds'(i,e)=eitherLeft(\v->Right$maybevid$lookupiinds')e

>convertHsMatch::HsMatch->FusionState(Variable,[EitherPatternVariable],Term)>convertHsMatch(HsMatchlochnamehpatrhs[])=dot<-convertRhs2Termlocrhs>ps<-mapM(convertPat2MyPatloc)hpat>return(str2var(convertHsName2Stringhname),mapanalisePatps,t)>convertHsMatch(HsMatchloc____)=throwError(ParserErrorloc"\"where\" clauses are not supported.")

>convertRhs2Term::SrcLoc->HsRhs->FusionStateTerm>convertRhs2TermlochsRhs=>casehsRhsof>HsUnGuardedRhshsExp->convertHsExp2TermlochsExp[]>>=(return.fixInfixAssoc)>HsGuardedRhsshsGuardedRhss->throwError(ParserErrorloc"Guarded definitions are not supported.")

>convertHsExp2Term::SrcLoc->HsExp->[Term]->FusionStateTerm>convertHsExp2Termlocexpargs=>letwildTerm=Tvar$Vuserdef"_">appArgstargs=foldlTapptargs>incaseexpof>HsVarhsQName->return$convertHsQName2TermhsQNameargs>HsConhsQName->return$convertHsQName2TermhsQNameargs>HsLithsLiteral->return$Tlit(convertLit2LithsLiteral)>HsInfixApphsExphsQOphsExp1->dot0<-convertHsExp2TermlochsExp[]>t1<-convertHsExp2TermlochsExp1[]>return$convertHsQName2Term(convertHsQOP2VariablehsQOp)(t0:t1:args)>HsApphsExphsExp1->convertHsExp2TermlochsExp1[]>>=convertHsExp2TermlochsExp.(:args)>HsNegApphsExp->convertHsExp2TermlochsExp[]>>=\t->return(appArgs(Tfapp(Vuserdef"-")[t])args)>HsLambdalochsPatshsExp->dops<-mapM(convertPat2MyPatloc)hsPats>ps'<-mapMps2bvps>t<-convertHsExp2TermlochsExpargs>return$foldrTlambtps'>whereps2bv(Pvarv)=return$Bvarv>ps2bv(Ptupleps)=mapMps2bvps>>=return.BvtupleFalse>ps2bv_=throwError(ParserErrorloc"Constructors are not allowed in patterns in lambda abstractions.")>HsLethsDeclshsExp->dot<-convertHsExp2TermlochsExp[]>listaVarsTerms<-mapM(convertHsLetsDect2PatyTermloc)hsDecls>return(appArgs(foldr(\(p,t0)->Tcaset0[p].(:[]))tlistaVarsTerms)args)>HsIfhsExphsExp1hsExp2->dot0<-convertHsExp2TermlochsExp[]>lettrueCase=Pcons"True"[]>falseCase=Pcons"False"[]>termTrue<-convertHsExp2TermlochsExp1[]>termFalse<-convertHsExp2TermlochsExp2[]>return(appArgs(Tcaset0[trueCase,falseCase][termTrue,termFalse])args)>HsCasehsExphsAlts->dot0<-convertHsExp2TermlochsExp[]>alternativas<-mapMconverthsAlt2PatyTermhsAlts>letpats=mapfstalternativas>terms=mapsndalternativas>return(appArgs(Tcaset0patsterms)args)>HsTuplehsExps->dots<-mapM(flip(convertHsExp2Termloc)[])hsExps>return(appArgs(TtupleFalsets)args)>HsListhsExps->dots<-mapM(flip(convertHsExp2Termloc)[])hsExps>return(appArgs(foldr(\t1t2->Tcapp":"[t1,t2])(Tcapp"[]"[])ts)args)>HsParenhsExp->convertHsExp2TermlochsExpargs>>=(return.Tpar)>HsLeftSectionhsExphsQOp->dot<-convertHsExp2TermlochsExp[]>return$convertHsQName2Term(convertHsQOP2VariablehsQOp)(t:args)>HsRightSectionhsQOphsExp->dot1<-convertHsExp2TermlochsExp[]>ifnullargsthenthrowError(ParserErrorloc"Non applied right sections are not supported.")>elsereturn$convertHsQName2Term(convertHsQOP2VariablehsQOp)(headargs:t1:tailargs)>_->throwError(ParserErrorloc"This kind of term is not supported.")

>convertHsGuardedAlts2Term::SrcLoc->HsGuardedAlts->FusionStateTerm>convertHsGuardedAlts2Termlocx=>casexof>HsUnGuardedAlthsExp->convertHsExp2TermlochsExp[]>HsGuardedAltshsGuardedAlt->throwError(ParserErrorloc"Guarded alternatives are not supported.")

>convertPat2MyPat::SrcLoc->HsPat->FusionStatePattern>convertPat2MyPatloc=convertPat2MyPat'loc.changeConsAssoc>convertPat2MyPat'lochsPat=>casehsPatof>HsPVarhsName->return$Pvar(str2var$convertHsName2StringhsName)>HsPLithsLiteral->return$Plit(convertLit2LithsLiteral)>HsPInfixApphsPat1hsQNamehsPat2->>dohsRes1<-convertPat2MyPat'lochsPat1>hsRes2<-convertPat2MyPat'lochsPat2>return$convertHsQName2PatternhsQName[hsRes1,hsRes2]>HsPApphsQNamehsPats->dops<-mapM(convertPat2MyPat'loc)hsPats>return$convertHsQName2PatternhsQNameps>HsPTuplehsPats->dops<-mapM(convertPat2MyPat'loc)hsPats>return$Ptupleps>HsPListhsPats->dops<-mapM(convertPat2MyPat'loc)hsPats>return(foldr(\t1t2->Pcons":"[t1,t2])(Pcons"[]"[])ps)>HsPParenhsPat->(convertPat2MyPat'loc)hsPat>HsPWildCard->returnpany>HsPAsPathsNamehsPat->dop<-convertPat2MyPatlochsPat>return$Pas(str2var$convertHsName2StringhsName)p>_->throwError(ParserErrorloc"This kind of pattern is not supported.")