%%(c)TheUniversityofGlasgow2006%(c)TheGRASP/AQUAProject,GlasgowUniversity,1992-1998%\begin{code}-- |-- #name_types#-- GHC uses several kinds of name internally:---- * 'OccName.OccName' represents names as strings with just a little more information:-- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or-- data constructors---- * 'RdrName.RdrName': see "RdrName#name_types"---- * 'Name.Name': see "Name#name_types"---- * 'Id.Id': see "Id#name_types"---- * 'Var.Var': see "Var#name_types"moduleOccName(-- * The 'NameSpace' typeNameSpace,-- Abstract-- ** Construction-- $real_vs_source_data_constructorstcName,clsName,tcClsName,dataName,varName,tvName,srcDataName,-- ** Pretty PrintingpprNameSpace,pprNonVarNameSpace,pprNameSpaceBrief,-- * The 'OccName' typeOccName,-- Abstract, instance of OutputablepprOccName,-- ** Construction mkOccName,mkOccNameFS,mkVarOcc,mkVarOccFS,mkDataOcc,mkDataOccFS,mkTyVarOcc,mkTyVarOccFS,mkTcOcc,mkTcOccFS,mkClsOcc,mkClsOccFS,mkDFunOcc,mkTupleOcc,setOccNameSpace,-- ** Derived 'OccName'sisDerivedOccName,mkDataConWrapperOcc,mkWorkerOcc,mkDefaultMethodOcc,mkDerivedTyConOcc,mkNewTyCoOcc,mkCon2TagOcc,mkTag2ConOcc,mkMaxTagOcc,mkClassTyConOcc,mkClassDataConOcc,mkDictOcc,mkIPOcc,mkSpecOcc,mkForeignExportOcc,mkGenOcc1,mkGenOcc2,mkDataTOcc,mkDataCOcc,mkDataConWorkerOcc,mkSuperDictSelOcc,mkLocalOcc,mkMethodOcc,mkInstTyTcOcc,mkInstTyCoOcc,mkEqPredCoOcc,mkVectOcc,mkVectTyConOcc,mkVectDataConOcc,mkVectIsoOcc,mkPDataTyConOcc,mkPDataDataConOcc,mkPReprTyConOcc,mkPADFunOcc,-- ** DeconstructionoccNameFS,occNameString,occNameSpace,isVarOcc,isTvOcc,isTcOcc,isDataOcc,isDataSymOcc,isSymOcc,isValOcc,parenSymOcc,startsWithUnderscore,isTcClsNameSpace,isTvNameSpace,isDataConNameSpace,isVarNameSpace,isValNameSpace,isTupleOcc_maybe,-- * The 'OccEnv' typeOccEnv,emptyOccEnv,unitOccEnv,extendOccEnv,mapOccEnv,lookupOccEnv,mkOccEnv,mkOccEnv_C,extendOccEnvList,elemOccEnv,occEnvElts,foldOccEnv,plusOccEnv,plusOccEnv_C,extendOccEnv_C,filterOccEnv,delListFromOccEnv,delFromOccEnv,-- * The 'OccSet' typeOccSet,emptyOccSet,unitOccSet,mkOccSet,extendOccSet,extendOccSetList,unionOccSets,unionManyOccSets,minusOccSet,elemOccSet,occSetElts,foldOccSet,isEmptyOccSet,intersectOccSet,intersectsOccSet,-- * Tidying upTidyOccEnv,emptyTidyOccEnv,tidyOccName,initTidyOccEnv,-- * Lexical characteristics of Haskell namesisLexCon,isLexVar,isLexId,isLexSym,isLexConId,isLexConSym,isLexVarId,isLexVarSym,startsVarSym,startsVarId,startsConSym,startsConId)whereimportUtilimportUniqueimportBasicTypesimportUniqFMimportUniqSetimportFastStringimportFastTypesimportOutputableimportBinaryimportStaticFlags(opt_SuppressUniques)importData.Char\end{code}\begin{code}-- Unicode TODO: put isSymbol in libcompat#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604#elseisSymbol::a->BoolisSymbol=constFalse#endif\end{code}%************************************************************************%**\subsection{Namespace}%**%************************************************************************\begin{code}dataNameSpace=VarName-- Variables, including "real" data constructors|DataName-- "Source" data constructors |TvName-- Type variables|TcClsName-- Type constructors and classes; Haskell has them-- in the same name space for now.deriving(Eq,Ord){-! derive: Binary !-}-- Note [Data Constructors] -- see also: Note [Data Constructor Naming] in DataCon.lhs---- $real_vs_source_data_constructors-- There are two forms of data constructor:---- [Source data constructors] The data constructors mentioned in Haskell source code---- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type---- For example:---- > data T = T !(Int, Int)---- The source datacon has type @(Int, Int) -> T@-- The real datacon has type @Int -> Int -> T@---- GHC chooses a representation based on the strictness etc.tcName,clsName,tcClsName::NameSpacedataName,srcDataName::NameSpacetvName,varName::NameSpace-- Though type constructors and classes are in the same name space now,-- the NameSpace type is abstract, so we can easily separate them latertcName=TcClsName-- Type constructorsclsName=TcClsName-- ClassestcClsName=TcClsName-- Not sure which!dataName=DataNamesrcDataName=DataName-- Haskell-source data constructors should be-- in the Data name spacetvName=TvNamevarName=VarNameisDataConNameSpace::NameSpace->BoolisDataConNameSpaceDataName=TrueisDataConNameSpace_=FalseisTcClsNameSpace::NameSpace->BoolisTcClsNameSpaceTcClsName=TrueisTcClsNameSpace_=FalseisTvNameSpace::NameSpace->BoolisTvNameSpaceTvName=TrueisTvNameSpace_=FalseisVarNameSpace::NameSpace->Bool-- Variables or type variables, but not constructorsisVarNameSpaceTvName=TrueisVarNameSpaceVarName=TrueisVarNameSpace_=FalseisValNameSpace::NameSpace->BoolisValNameSpaceDataName=TrueisValNameSpaceVarName=TrueisValNameSpace_=FalsepprNameSpace::NameSpace->SDocpprNameSpaceDataName=ptext(sLit"data constructor")pprNameSpaceVarName=ptext(sLit"variable")pprNameSpaceTvName=ptext(sLit"type variable")pprNameSpaceTcClsName=ptext(sLit"type constructor or class")pprNonVarNameSpace::NameSpace->SDocpprNonVarNameSpaceVarName=emptypprNonVarNameSpacens=pprNameSpacenspprNameSpaceBrief::NameSpace->SDocpprNameSpaceBriefDataName=char'd'pprNameSpaceBriefVarName=char'v'pprNameSpaceBriefTvName=ptext(sLit"tv")pprNameSpaceBriefTcClsName=ptext(sLit"tc")\end{code}%************************************************************************%**\subsection[Name-pieces-datatypes]{The@OccName@datatypes}%**%************************************************************************\begin{code}dataOccName=OccName{occNameSpace::!NameSpace,occNameFS::!FastString}\end{code}\begin{code}instanceEqOccNamewhere(OccNamesp1s1)==(OccNamesp2s2)=s1==s2&&sp1==sp2instanceOrdOccNamewhere-- Compares lexicographically, *not* by Unique of the stringcompare(OccNamesp1s1)(OccNamesp2s2)=(s1`compare`s2)`thenCmp`(sp1`compare`sp2)\end{code}%************************************************************************%**\subsection{Printing}%**%************************************************************************\begin{code}instanceOutputableOccNamewhereppr=pprOccNamepprOccName::OccName->SDocpprOccName(OccNamespocc)=getPprStyle$\sty->ifcodeStylestythenftext(zEncodeFSocc)elsepp_occ<>pp_debugstywherepp_debugsty|debugStylesty=braces(pprNameSpaceBriefsp)|otherwise=emptypp_occ|opt_SuppressUniques=text(strip_th_unique(unpackFSocc))|otherwise=ftextocc-- See Note [Suppressing uniques in OccNames]strip_th_unique('[':c:_)|isAlphaNumc=[]strip_th_unique(c:cs)=c:strip_th_uniquecsstrip_th_unique[]=[]\end{code}Note[SuppressinguniquesinOccNames]~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~Thisisahacktode-wobblifytheOccNamesthatcontainuniquesfromTemplateHaskellthathavebeenturnedintoastringintheOccName.SeeNote[UniqueOccNamesfromTemplateHaskell]inConvert.hs%************************************************************************%**\subsection{Construction}%**%************************************************************************\begin{code}mkOccName::NameSpace->String->OccNamemkOccNameocc_spstr=OccNameocc_sp(mkFastStringstr)mkOccNameFS::NameSpace->FastString->OccNamemkOccNameFSocc_spfs=OccNameocc_spfsmkVarOcc::String->OccNamemkVarOccs=mkOccNamevarNamesmkVarOccFS::FastString->OccNamemkVarOccFSfs=mkOccNameFSvarNamefsmkDataOcc::String->OccNamemkDataOcc=mkOccNamedataNamemkDataOccFS::FastString->OccNamemkDataOccFS=mkOccNameFSdataNamemkTyVarOcc::String->OccNamemkTyVarOcc=mkOccNametvNamemkTyVarOccFS::FastString->OccNamemkTyVarOccFSfs=mkOccNameFStvNamefsmkTcOcc::String->OccNamemkTcOcc=mkOccNametcNamemkTcOccFS::FastString->OccNamemkTcOccFS=mkOccNameFStcNamemkClsOcc::String->OccNamemkClsOcc=mkOccNameclsNamemkClsOccFS::FastString->OccNamemkClsOccFS=mkOccNameFSclsName\end{code}%************************************************************************%**Environments%**%************************************************************************OccEnvsareusedmainlyfortheenvtsinModIfaces.Theyareefficient,becauseFastStringshaveuniqueInt#keys.Weassumethiskeyislessthan2^24,sowecanmakeaUniqueusingmkUniquenskey::Uniquewhere'ns'isaCharreprsentingthenamespace.ThisinturnmakesiteasytobuildanOccEnv.\begin{code}instanceUniquableOccNamewheregetUnique(OccNamensfs)=mkUniquechar(iBox(uniqueOfFSfs))where-- See notes above about this getUnique functionchar=casensofVarName->'i'DataName->'d'TvName->'v'TcClsName->'t'newtypeOccEnva=A(UniqFMa)emptyOccEnv::OccEnvaunitOccEnv::OccName->a->OccEnvaextendOccEnv::OccEnva->OccName->a->OccEnvaextendOccEnvList::OccEnva->[(OccName,a)]->OccEnvalookupOccEnv::OccEnva->OccName->MaybeamkOccEnv::[(OccName,a)]->OccEnvamkOccEnv_C::(a->a->a)->[(OccName,a)]->OccEnvaelemOccEnv::OccName->OccEnva->BoolfoldOccEnv::(a->b->b)->b->OccEnva->boccEnvElts::OccEnva->[a]extendOccEnv_C::(a->a->a)->OccEnva->OccName->a->OccEnvaplusOccEnv::OccEnva->OccEnva->OccEnvaplusOccEnv_C::(a->a->a)->OccEnva->OccEnva->OccEnvamapOccEnv::(a->b)->OccEnva->OccEnvbdelFromOccEnv::OccEnva->OccName->OccEnvadelListFromOccEnv::OccEnva->[OccName]->OccEnvafilterOccEnv::(elt->Bool)->OccEnvelt->OccEnveltemptyOccEnv=AemptyUFMunitOccEnvxy=A$unitUFMxyextendOccEnv(Ax)yz=A$addToUFMxyzextendOccEnvList(Ax)l=A$addListToUFMxllookupOccEnv(Ax)y=lookupUFMxymkOccEnvl=A$listToUFMlelemOccEnvx(Ay)=elemUFMxyfoldOccEnvab(Ac)=foldUFMabcoccEnvElts(Ax)=eltsUFMxplusOccEnv(Ax)(Ay)=A$plusUFMxyplusOccEnv_Cf(Ax)(Ay)=A$plusUFM_CfxyextendOccEnv_Cf(Ax)yz=A$addToUFM_CfxyzmapOccEnvf(Ax)=A$mapUFMfxmkOccEnv_Ccombl=A$addListToUFM_CcombemptyUFMldelFromOccEnv(Ax)y=A$delFromUFMxydelListFromOccEnv(Ax)y=A$delListFromUFMxyfilterOccEnvx(Ay)=A$filterUFMxyinstanceOutputablea=>Outputable(OccEnva)whereppr(Ax)=pprxtypeOccSet=UniqSetOccNameemptyOccSet::OccSetunitOccSet::OccName->OccSetmkOccSet::[OccName]->OccSetextendOccSet::OccSet->OccName->OccSetextendOccSetList::OccSet->[OccName]->OccSetunionOccSets::OccSet->OccSet->OccSetunionManyOccSets::[OccSet]->OccSetminusOccSet::OccSet->OccSet->OccSetelemOccSet::OccName->OccSet->BooloccSetElts::OccSet->[OccName]foldOccSet::(OccName->b->b)->b->OccSet->bisEmptyOccSet::OccSet->BoolintersectOccSet::OccSet->OccSet->OccSetintersectsOccSet::OccSet->OccSet->BoolemptyOccSet=emptyUniqSetunitOccSet=unitUniqSetmkOccSet=mkUniqSetextendOccSet=addOneToUniqSetextendOccSetList=addListToUniqSetunionOccSets=unionUniqSetsunionManyOccSets=unionManyUniqSetsminusOccSet=minusUniqSetelemOccSet=elementOfUniqSetoccSetElts=uniqSetToListfoldOccSet=foldUniqSetisEmptyOccSet=isEmptyUniqSetintersectOccSet=intersectUniqSetsintersectsOccSets1s2=not(isEmptyOccSet(s1`intersectOccSet`s2))\end{code}%************************************************************************%**\subsection{Predicatesandtakingthemapart}%**%************************************************************************\begin{code}occNameString::OccName->StringoccNameString(OccName_s)=unpackFSssetOccNameSpace::NameSpace->OccName->OccNamesetOccNameSpacesp(OccName_occ)=OccNamespoccisVarOcc,isTvOcc,isTcOcc,isDataOcc::OccName->BoolisVarOcc(OccNameVarName_)=TrueisVarOcc_=FalseisTvOcc(OccNameTvName_)=TrueisTvOcc_=FalseisTcOcc(OccNameTcClsName_)=TrueisTcOcc_=False-- | /Value/ 'OccNames's are those that are either in -- the variable or data constructor namespacesisValOcc::OccName->BoolisValOcc(OccNameVarName_)=TrueisValOcc(OccNameDataName_)=TrueisValOcc_=FalseisDataOcc(OccNameDataName_)=TrueisDataOcc(OccNameVarNames)|isLexCons=pprPanic"isDataOcc: check me"(pprs)-- Jan06: I don't think this should happenisDataOcc_=False-- | Test if the 'OccName' is a data constructor that starts with-- a symbol (e.g. @:@, or @[]@)isDataSymOcc::OccName->BoolisDataSymOcc(OccNameDataNames)=isLexConSymsisDataSymOcc(OccNameVarNames)|isLexConSyms=pprPanic"isDataSymOcc: check me"(pprs)-- Jan06: I don't think this should happenisDataSymOcc_=False-- Pretty inefficient!-- | Test if the 'OccName' is that for any operator (whether -- it is a data constructor or variable or whatever)isSymOcc::OccName->BoolisSymOcc(OccNameDataNames)=isLexConSymsisSymOcc(OccNameTcClsNames)=isLexConSymsisSymOcc(OccNameVarNames)=isLexSymsisSymOcc(OccNameTvNames)=isLexSyms-- Pretty inefficient!parenSymOcc::OccName->SDoc->SDoc-- ^ Wrap parens around an operatorparenSymOccoccdoc|isSymOccocc=parensdoc|otherwise=doc\end{code}\begin{code}startsWithUnderscore::OccName->Bool-- ^ Haskell 98 encourages compilers to suppress warnings about unsed-- names in a pattern if they start with @_@: this implements that teststartsWithUnderscoreocc=caseoccNameStringoccof('_':_)->True_other->False\end{code}%************************************************************************%**\subsection{Makingsystemnames}%**%************************************************************************Here'sourconventionforsplittinguptheinterfacefilenamespace:d...dictionaryidentifiers(localvariables,sononame-clashworries)AlloftheseotherOccNamescontainamixtureofalphabeticandsymboliccharacters,andhencecannotpossiblyclashwithauser-writtentypeorfunctionname$f...Dict-funidentifiers(frominstdecls)$dmopDefaultmethodfor'op'$pnCn'thsuperclassselectorforclassC$wfWorkerforfuncttoin'f'$sf..SpecialisedversionoffT:CTyconfordictionaryforclassCD:CDataconstructorfordictionaryforclassCNTCo:TCoercionconnectingnewtypeTwithitsrepresentationtypeTFCo:RCoercionconnectingadatafamilytoitsrespresentationtypeRInencodedformtheseappearasZdfxxxetc:...keywords(export:,letrec:etc.)--- I THINK THIS IS WRONG!Thisknowledgeisencodedinthefollowingfunctions.@mk_deriv@generatesan@OccName@fromtheprefixandastring.NB:Thestringmustalreadybeencoded!\begin{code}mk_deriv::NameSpace->String-- Distinguishes one sort of derived name from another->String->OccNamemk_derivocc_spsys_prefixstr=mkOccNameocc_sp(sys_prefix++str)isDerivedOccName::OccName->BoolisDerivedOccNameocc=caseoccNameStringoccof'$':c:_|isAlphaNumc->True':':c:_|isAlphaNumc->True_other->False\end{code}\begin{code}mkDataConWrapperOcc,mkWorkerOcc,mkDefaultMethodOcc,mkDerivedTyConOcc,mkClassTyConOcc,mkClassDataConOcc,mkDictOcc,mkIPOcc,mkSpecOcc,mkForeignExportOcc,mkGenOcc1,mkGenOcc2,mkDataTOcc,mkDataCOcc,mkDataConWorkerOcc,mkNewTyCoOcc,mkInstTyCoOcc,mkEqPredCoOcc,mkCon2TagOcc,mkTag2ConOcc,mkMaxTagOcc,mkVectOcc,mkVectTyConOcc,mkVectDataConOcc,mkVectIsoOcc,mkPDataTyConOcc,mkPDataDataConOcc,mkPReprTyConOcc,mkPADFunOcc::OccName->OccName-- These derived variables have a prefix that no Haskell value could havemkDataConWrapperOcc=mk_simple_derivvarName"$W"mkWorkerOcc=mk_simple_derivvarName"$w"mkDefaultMethodOcc=mk_simple_derivvarName"$dm"mkDerivedTyConOcc=mk_simple_derivtcName":"-- The : prefix makes sure it classifiesmkClassTyConOcc=mk_simple_derivtcName"T:"-- as a tycon/dataconmkClassDataConOcc=mk_simple_derivdataName"D:"-- We go straight to the "real" data con-- for datacons from classesmkDictOcc=mk_simple_derivvarName"$d"mkIPOcc=mk_simple_derivvarName"$i"mkSpecOcc=mk_simple_derivvarName"$s"mkForeignExportOcc=mk_simple_derivvarName"$f"mkNewTyCoOcc=mk_simple_derivtcName"NTCo:"-- Coercion for newtypesmkInstTyCoOcc=mk_simple_derivtcName"TFCo:"-- Coercion for type functionsmkEqPredCoOcc=mk_simple_derivtcName"$co"-- used in derived instancesmkCon2TagOcc=mk_simple_derivvarName"$con2tag_"mkTag2ConOcc=mk_simple_derivvarName"$tag2con_"mkMaxTagOcc=mk_simple_derivvarName"$maxtag_"-- Generic derivable classesmkGenOcc1=mk_simple_derivvarName"$gfrom"mkGenOcc2=mk_simple_derivvarName"$gto"-- data T = MkT ... deriving( Data ) needs defintions for -- $tT :: Data.Generics.Basics.DataType-- $cMkT :: Data.Generics.Basics.ConstrmkDataTOcc=mk_simple_derivvarName"$t"mkDataCOcc=mk_simple_derivvarName"$c"-- VectorisationmkVectOcc=mk_simple_derivvarName"$v_"mkVectTyConOcc=mk_simple_derivtcName":V_"mkVectDataConOcc=mk_simple_derivdataName":VD_"mkVectIsoOcc=mk_simple_derivvarName"$VI_"mkPDataTyConOcc=mk_simple_derivtcName":VP_"mkPDataDataConOcc=mk_simple_derivdataName":VPD_"mkPReprTyConOcc=mk_simple_derivtcName":VR_"mkPADFunOcc=mk_simple_derivvarName"$PA_"mk_simple_deriv::NameSpace->String->OccName->OccNamemk_simple_derivsppxocc=mk_derivsppx(occNameStringocc)-- Data constructor workers are made by setting the name space-- of the data constructor OccName (which should be a DataName)-- to VarNamemkDataConWorkerOccdatacon_occ=setOccNameSpacevarNamedatacon_occ\end{code}\begin{code}mkSuperDictSelOcc::Int-- ^ Index of superclass, e.g. 3->OccName-- ^ Class, e.g. @Ord@->OccName-- ^ Derived 'Occname', e.g. @$p3Ord@mkSuperDictSelOccindexcls_occ=mk_derivvarName"$p"(showindex++occNameStringcls_occ)mkLocalOcc::Unique-- ^ Unique to combine with the 'OccName'->OccName-- ^ Local name, e.g. @sat@->OccName-- ^ Nice unique version, e.g. @$L23sat@mkLocalOccuniqocc=mk_derivvarName("$L"++showuniq)(occNameStringocc)-- The Unique might print with characters -- that need encoding (e.g. 'z'!)\end{code}\begin{code}-- | Derive a name for the representation type constructor of a-- @data@\/@newtype@ instance.mkInstTyTcOcc::String-- ^ Family name, e.g. @Map@->OccSet-- ^ avoid these Occs->OccName-- ^ @R:Map@mkInstTyTcOccstrset=chooseUniqueOcctcName('R':':':str)set\end{code}\begin{code}mkDFunOcc::String-- ^ Typically the class and type glommed together e.g. @OrdMaybe@.-- Only used in debug mode, for extra clarity->Bool-- ^ Is this a hs-boot instance DFun?->OccSet-- ^ avoid these Occs->OccName-- ^ E.g. @$f3OrdMaybe@-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real-- thing when we compile the mother module. Reason: we don't know exactly-- what the mother module will call it.mkDFunOccinfo_stris_bootset=chooseUniqueOccVarName(prefix++info_str)setwhereprefix|is_boot="$fx"|otherwise="$f"\end{code}SometimesweneedtopickanOccNamethathasnotalreadybeenused,givenasetofin-useOccNames.\begin{code}chooseUniqueOcc::NameSpace->String->OccSet->OccNamechooseUniqueOccnsstrset=loop(mkOccNamensstr)(0::Int)whereloopoccn|occ`elemOccSet`set=loop(mkOccNamens(str++shown))(n+1)|otherwise=occ\end{code}Weusedtoadda'$m'toindicateamethod,butthatgivesrisetobaderrormessagesfromthetypecheckerwhenweprintthefunctionnameorpatternofaninstance-declbinding.Why?Becausethebindingiszappedtousethemethodnameinplaceoftheselectorname.(SeeTcClassDcl.tcMethodBind)Thewayitisnow,-ddump-xxoutputmaylookconfusing,butyoucanalwayssay-dppr-debugtogettheuniques.However,we*do*havetozapthefirstcharactertobelowercase,becauseoverloadedconstructors(blarg)generatemethodstoo.AndconverttoVarNamespacee.g.acalltoconstructorMkFoowheredata(Orda)=>Fooa=MkFooaIfthisisnecessary,wedoitbyprefixing'$m'.Theseguysnevershowupinerrormessages.Whatahack.\begin{code}mkMethodOcc::OccName->OccNamemkMethodOccocc@(OccNameVarName_)=occmkMethodOccocc=mk_simple_derivvarName"$m"occ\end{code}%************************************************************************%**\subsection{Tidyingthemup}%**%************************************************************************Beforeweprintchunksofcodeweliketorenameitsothatwedon'thavetoprintlotsofsillyuniquesinit.Butwemustn'taccidentallyintroducenameclashes!SotheideaisthatweleavetheOccNamealoneunlessitaccidentallyclasheswithonethatisalreadyinscope;ifso,wetackon'1'attheendandtryagain,then'2',andsoontillwefindauniqueone.There'sawrinkleforoperators.Consider'>>='.Wecan'tuse'>>=1'becausethatisn'tasinglelexeme.Soweencodeitto'lle'and*then*tackonthe'1',ifnecessary.\begin{code}typeTidyOccEnv=OccEnvInt-- The in-scope OccNames-- Range gives a plausible starting point for new guessesemptyTidyOccEnv::TidyOccEnvemptyTidyOccEnv=emptyOccEnvinitTidyOccEnv::[OccName]->TidyOccEnv-- Initialise with names to avoid!initTidyOccEnv=foldl(\envocc->extendOccEnvenvocc1)emptyTidyOccEnvtidyOccName::TidyOccEnv->OccName->(TidyOccEnv,OccName)tidyOccNamein_scopeocc@(OccNameocc_spfs)=caselookupOccEnvin_scopeoccofNothing->-- Not already used: make it used(extendOccEnvin_scopeocc1,occ)Justn->-- Already used: make a new guess, -- change the guess base, and try againtidyOccName(extendOccEnvin_scopeocc(n+1))(mkOccNameocc_sp(unpackFSfs++shown))\end{code}%************************************************************************%**Stufffordealingwithtuples%**%************************************************************************\begin{code}mkTupleOcc::NameSpace->Boxity->Arity->OccNamemkTupleOccnsbxar=OccNamens(mkFastStringstr)where-- no need to cache these, the caching is done in the caller-- (TysWiredIn.mk_tuple)str=casebxofBoxed->'(':commas++")"Unboxed->'(':'#':commas++"#)"commas=take(ar-1)(repeat',')isTupleOcc_maybe::OccName->Maybe(NameSpace,Boxity,Arity)-- Tuples are special, because there are so many of them!isTupleOcc_maybe(OccNamensfs)=caseunpackFSfsof'(':'#':',':rest->Just(ns,Unboxed,2+count_commasrest)'(':',':rest->Just(ns,Boxed,2+count_commasrest)_other->Nothingwherecount_commas(',':rest)=1+count_commasrestcount_commas_=0\end{code}%************************************************************************%**\subsection{Lexicalcategories}%**%************************************************************************ThesefunctionsteststringstoseeiftheyfitthelexicalcategoriesdefinedintheHaskellreport.\begin{code}isLexCon,isLexVar,isLexId,isLexSym::FastString->BoolisLexConId,isLexConSym,isLexVarId,isLexVarSym::FastString->BoolisLexConcs=isLexConIdcs||isLexConSymcsisLexVarcs=isLexVarIdcs||isLexVarSymcsisLexIdcs=isLexConIdcs||isLexVarIdcsisLexSymcs=isLexConSymcs||isLexVarSymcs-------------isLexConIdcs-- Prefix type or data constructors|nullFScs=False-- e.g. "Foo", "[]", "(,)" |cs==(fsLit"[]")=True|otherwise=startsConId(headFScs)isLexVarIdcs-- Ordinary prefix identifiers|nullFScs=False-- e.g. "x", "_x"|otherwise=startsVarId(headFScs)isLexConSymcs-- Infix type or data constructors|nullFScs=False-- e.g. ":-:", ":", "->"|cs==(fsLit"->")=True|otherwise=startsConSym(headFScs)isLexVarSymcs-- Infix identifiers|nullFScs=False-- e.g. "+"|otherwise=startsVarSym(headFScs)-------------startsVarSym,startsVarId,startsConSym,startsConId::Char->BoolstartsVarSymc=isSymbolASCIIc||(ordc>0x7f&&isSymbolc)-- Infix IdsstartsConSymc=c==':'-- Infix data constructorsstartsVarIdc=isLowerc||c=='_'-- Ordinary IdsstartsConIdc=isUpperc||c=='('-- Ordinary type constructors and data constructorsisSymbolASCII::Char->BoolisSymbolASCIIc=c`elem`"!#$%&*+./<=>?@\\^|~-"\end{code}%************************************************************************%**BinaryinstanceHereratherthanBinIfacebecauseOccNameisabstract%**%************************************************************************\begin{code}instanceBinaryNameSpacewhereput_bhVarName=doputBytebh0put_bhDataName=doputBytebh1put_bhTvName=doputBytebh2put_bhTcClsName=doputBytebh3getbh=doh<-getBytebhcasehof0->doreturnVarName1->doreturnDataName2->doreturnTvName_->doreturnTcClsNameinstanceBinaryOccNamewhereput_bh(OccNameaaab)=doput_bhaaput_bhabgetbh=doaa<-getbhab<-getbhreturn(OccNameaaab)\end{code}