------------------------------------------------------------------------------- | License : GPL-- -- Maintainer : helium@cs.uu.nl-- Stability : provisional-- Portability : portable---- This module contains type synonyms to represent type synonyms. A collection-- of type synonyms can always be ordered, since (mutually) recursive type-- synonyms are not permitted. The ordering of type synonyms must be determined-- to find a minimal number of unfold steps to make two types syntactically -- equivalent.-------------------------------------------------------------------------------moduleTop.Types.SynonymwhereimportTop.Types.PrimitiveimportTop.Types.Substitutionhiding(lookupInt)importUtils(internalError)importData.MaybeimportData.Graph(scc,buildG)importData.Tree(flatten)importqualifiedData.MapasM------------------------------------------------------------------------ * Type synonyms-- |A (unordered) collection of type synonyms is represented by a finite map of-- strings (the name of the type synonym) to pairs that have an int-- (the number of arguments of the type synonym) and a function.typeTypeSynonyms=M.MapString(Int,Tps->Tp)-- |An ordering of type synonyms maps a name of a type synonym to -- a position in the ordering.typeTypeSynonymOrdering=M.MapStringInt-- |An (unordered) collection of type synonyms, together with an ordering.typeOrderedTypeSynonyms=(TypeSynonymOrdering,TypeSynonyms)------------------------------------------------------------------------ * Utility functions-- |An empty collection of ordered type synonyms.noOrderedTypeSynonyms::OrderedTypeSynonymsnoOrderedTypeSynonyms=(M.empty,M.empty)-- |A string is a list of charactersstringAsTypeSynonym::OrderedTypeSynonymsstringAsTypeSynonym=(M.singleton"String"0,M.singleton"String"(0,\_->listTypecharType))-- |Order a collection of type synonyms, and return this ordering paired with-- sets of mutually recursive type synonyms that are detected.getTypeSynonymOrdering::TypeSynonyms->(TypeSynonymOrdering,[[String]])getTypeSynonymOrderingsynonyms=let(nameTable,intTable)=letkeys=M.keyssynonymsin(M.fromList(zipkeys[0..]),M.fromList(zip[0..]keys))err=internalError"Top.Types.Synonyms""getTypeSynonymOrdering""error in lookup table"lookupNamen=fromMaybeerr(M.lookupnnameTable)lookupInti=fromMaybeerr(M.lookupiintTable)edges=letops1(arity,function)es=leti1=lookupNames1cs=constantsInType(function(mapTVar[0..arity-1]))adds2=caseM.lookups2nameTableofJusti2->(:)(i2,i1)Nothing->idinfoldraddescsinM.foldrWithKeyop[]synonymsgraph=buildG(0,M.sizesynonyms-1)edgeslist=mapflatten(sccgraph)(ordering,recursive,_)=letopints(os,rs,counter)=caseintsof[int]|(int,int)`notElem`edges-- correct type synonym->(M.insert(lookupIntint)counteros,rs,counter+1)_->(os,maplookupIntints:rs,counter)infoldrop(M.empty,[],0)listin(ordering,recursive)isPhantomTypeSynonym::OrderedTypeSynonyms->String->BoolisPhantomTypeSynonym(_,xs)s=caseM.lookupsxsofNothing->FalseJust(i,f)->letis=takei[0..]tp=f(mapTVaris)free=ftvtpinany(`notElem`free)is------------------------------------------------------------------------ * Expansion of a type-- |Fully expand a type in a recursive way.expandType::TypeSynonyms->Tp->TpexpandTypesynonymstp=let(x,xs)=leftSpine(expandTypeConstructorsynonymstp)infoldlTAppx(map(expandTypesynonyms)xs)-- |Fully expand the top-level type constructor.expandTypeConstructor::TypeSynonyms->Tp->TpexpandTypeConstructorsynonymstp=maybetp(expandTypeConstructorsynonyms)(expandTypeConstructorOneStepsynonymstp)-- |Fully expand the top-level type constructor.expandToplevelTC::OrderedTypeSynonyms->Tp->MaybeTpexpandToplevelTC(_,synonyms)=fmap(expandTypeConstructorsynonyms).expandTypeConstructorOneStepsynonyms-- |Try to expand the top-level type constructor one step.expandTypeConstructorOneStep::TypeSynonyms->Tp->MaybeTpexpandTypeConstructorOneStepsynonymstp=caseleftSpinetpof(TCons,tps)->caseM.lookupssynonymsofJust(i,f)|i==lengthtps->Just(ftps)|otherwise->internalError"Top.Types.Synonyms""expandTypeConstructorOneStep""invalid arity of type synonym"Nothing->Nothing_->Nothing-- |Try to expand the top-level type constructor of one of the two paired Top.Types. If both-- top-level type constructors can be expanded, then the type synonym thast appears first-- in the ordering is expanded.expandOneStepOrdered::OrderedTypeSynonyms->(Tp,Tp)->Maybe(Tp,Tp)expandOneStepOrdered(ordering,synonyms)(t1,t2)=letftp=casefst(leftSpinetp)ofTCons->M.lookupsordering_->Nothingexpandtp=fromMaybeerr(expandTypeConstructorOneStepsynonymstp)err=internalError"Top.Types.Synonyms""expandOneStep""invalid set of OrderedTypeSynonyms"incase(ft1,ft2)of(Justi1,Justi2)|i1<=i2->Just(expandt1,t2)|otherwise->Just(t1,expandt2)(Just_,Nothing)->Just(expandt1,t2)(Nothing,Just_)->Just(t1,expandt2)_->Nothing