{-# OPTIONS_GHC -fno-warn-orphans #-}------------------------------------------------------------------------------- |-- Module : Haddock.InterfaceFile-- Copyright : (c) David Waern 2006-2009-- License : BSD-like---- Maintainer : haddock@projects.haskell.org-- Stability : experimental-- Portability : portable---- Reading and writing the .haddock interface file-----------------------------------------------------------------------------moduleHaddock.InterfaceFile(InterfaceFile(..),readInterfaceFile,nameCacheFromGhc,freshNameCache,NameCacheAccessor,writeInterfaceFile)whereimportHaddock.TypesimportHaddock.Utilshiding(out)importData.ListimportData.WordimportData.ArrayimportData.IORefimportqualifiedData.MapasMapimportData.Map(Map)importGHChiding(NoLink)importBinaryimportNameimportUniqSupplyimportUniqFMimportIfaceEnvimportHscTypesimportFastMutIntimportFastStringimportUniquedataInterfaceFile=InterfaceFile{ifLinkEnv::LinkEnv,ifInstalledIfaces::[InstalledInterface]}binaryInterfaceMagic::Word32binaryInterfaceMagic=0xD0Cface-- Since datatypes in the GHC API might change between major versions, and-- because we store GHC datatypes in our interface files, we need to make sure-- we version our interface files accordingly.binaryInterfaceVersion::Word16#if __GLASGOW_HASKELL__ == 610binaryInterfaceVersion=14#elif __GLASGOW_HASKELL__ == 611binaryInterfaceVersion=15#elif __GLASGOW_HASKELL__ == 612binaryInterfaceVersion=15#elif __GLASGOW_HASKELL__ == 613binaryInterfaceVersion=15#else#error Unknown GHC version#endifinitBinMemSize::IntinitBinMemSize=1024*1024writeInterfaceFile::FilePath->InterfaceFile->IO()writeInterfaceFilefilenameiface=dobh0<-openBinMeminitBinMemSizeput_bh0binaryInterfaceMagicput_bh0binaryInterfaceVersion-- remember where the dictionary pointer will godict_p_p<-tellBinbh0put_bh0dict_p_p-- remember where the symbol table pointer will gosymtab_p_p<-tellBinbh0put_bh0symtab_p_p-- Make some intial statesymtab_next<-newFastMutIntwriteFastMutIntsymtab_next0symtab_map<-newIORefemptyUFMletbin_symtab=BinSymbolTable{bin_symtab_next=symtab_next,bin_symtab_map=symtab_map}dict_next_ref<-newFastMutIntwriteFastMutIntdict_next_ref0dict_map_ref<-newIORefemptyUFMletbin_dict=BinDictionary{bin_dict_next=dict_next_ref,bin_dict_map=dict_map_ref}ud<-newWriteState(putNamebin_symtab)(putFastStringbin_dict)-- put the main thingbh<-return$setUserDatabh0udput_bhiface-- write the symtab pointer at the front of the filesymtab_p<-tellBinbhputAtbhsymtab_p_psymtab_pseekBinbhsymtab_p-- write the symbol table itselfsymtab_next'<-readFastMutIntsymtab_nextsymtab_map'<-readIORefsymtab_mapputSymbolTablebhsymtab_next'symtab_map'-- write the dictionary pointer at the fornt of the filedict_p<-tellBinbhputAtbhdict_p_pdict_pseekBinbhdict_p-- write the dictionary itselfdict_next<-readFastMutIntdict_next_refdict_map<-readIORefdict_map_refputDictionarybhdict_nextdict_map-- and send the result to the filewriteBinMembhfilenamereturn()typeNameCacheAccessorm=(mNameCache,NameCache->m())nameCacheFromGhc::NameCacheAccessorGhcnameCacheFromGhc=(read_from_session,write_to_session)whereread_from_session=doref<-withSession(return.hsc_NC)liftIO$readIORefrefwrite_to_sessionnc'=doref<-withSession(return.hsc_NC)liftIO$writeIORefrefnc'freshNameCache::NameCacheAccessorIOfreshNameCache=(create_fresh_nc,\_->return())wherecreate_fresh_nc=dou<-mkSplitUniqSupply'a'-- ??return(initNameCacheu[])-- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message.---- This function can be called in two ways. Within a GHC session it will-- update the use and update the session's name cache. Outside a GHC session-- a new empty name cache is used. The function is therefore generic in the-- monad being used. The exact monad is whichever monad the first-- argument, the getter and setter of the name cache, requires.--readInterfaceFile::MonadIOm=>NameCacheAccessorm->FilePath->m(EitherStringInterfaceFile)readInterfaceFile(get_name_cache,set_name_cache)filename=dobh0<-liftIO$readBinMemfilenamemagic<-liftIO$getbh0version<-liftIO$getbh0case()of_|magic/=binaryInterfaceMagic->return.Left$"Magic number mismatch: couldn't load interface file: "++filename|version/=binaryInterfaceVersion->return.Left$"Interface file is of wrong version: "++filename|otherwise->dodict<-get_dictionarybh0bh1<-init_handle_user_databh0dicttheNC<-get_name_cache(nc',symtab)<-get_symbol_tablebh1theNCset_name_cachenc'-- set the symbol tableletud'=getUserDatabh1bh2<-return$!setUserDatabh1ud'{ud_symtab=symtab}-- load the actual dataiface<-liftIO$getbh2return(Rightiface)whereget_dictionarybin_handle=liftIO$dodict_p<-getbin_handledata_p<-tellBinbin_handleseekBinbin_handledict_pdict<-getDictionarybin_handleseekBinbin_handledata_preturndictinit_handle_user_databin_handledict=liftIO$doud<-newReadStatedictreturn(setUserDatabin_handleud)get_symbol_tablebh1theNC=liftIO$dosymtab_p<-getbh1data_p'<-tellBinbh1seekBinbh1symtab_p(nc',symtab)<-getSymbolTablebh1theNCseekBinbh1data_p'return(nc',symtab)--------------------------------------------------------------------------------- Symbol table-------------------------------------------------------------------------------putName::BinSymbolTable->BinHandle->Name->IO()putNameBinSymbolTable{bin_symtab_map=symtab_map_ref,bin_symtab_next=symtab_next}bhname=dosymtab_map<-readIORefsymtab_map_refcaselookupUFMsymtab_mapnameofJust(off,_)->put_bh(fromIntegraloff::Word32)Nothing->dooff<-readFastMutIntsymtab_nextwriteFastMutIntsymtab_next(off+1)writeIORefsymtab_map_ref$!addToUFMsymtab_mapname(off,name)put_bh(fromIntegraloff::Word32)dataBinSymbolTable=BinSymbolTable{bin_symtab_next::!FastMutInt,-- The next index to usebin_symtab_map::!(IORef(UniqFM(Int,Name)))-- indexed by Name}putFastString::BinDictionary->BinHandle->FastString->IO()putFastStringBinDictionary{bin_dict_next=j_r,bin_dict_map=out_r}bhf=doout<-readIORefout_rletunique=getUniquefcaselookupUFMoutuniqueofJust(j,_)->put_bh(fromIntegralj::Word32)Nothing->doj<-readFastMutIntj_rput_bh(fromIntegralj::Word32)writeFastMutIntj_r(j+1)writeIORefout_r$!addToUFMoutunique(j,f)dataBinDictionary=BinDictionary{bin_dict_next::!FastMutInt,-- The next index to usebin_dict_map::!(IORef(UniqFM(Int,FastString)))-- indexed by FastString}putSymbolTable::BinHandle->Int->UniqFM(Int,Name)->IO()putSymbolTablebhnext_offsymtab=doput_bhnext_offletnames=elems(array(0,next_off-1)(eltsUFMsymtab))mapM_(\n->serialiseNamebhnsymtab)namesgetSymbolTable::BinHandle->NameCache->IO(NameCache,ArrayIntName)getSymbolTablebhnamecache=dosz<-getbhod_names<-sequence(replicatesz(getbh))letarr=listArray(0,sz-1)names(namecache',names)=mapAccumR(fromOnDiskNamearr)namecacheod_names--return(namecache',arr)typeOnDiskName=(PackageId,ModuleName,OccName)fromOnDiskName::ArrayIntName->NameCache->OnDiskName->(NameCache,Name)fromOnDiskName_nc(pid,mod_name,occ)=letmodu=mkModulepidmod_namecache=nsNamesncincaselookupOrigNameCachecachemoduoccofJustname->(nc,name)Nothing->letus=nsUniqsncu=uniqFromSupplyusname=mkExternalNameumoduoccnoSrcSpannew_cache=extendNameCachecachemoduoccnameincasesplitUniqSupplyusof{(us',_)->(nc{nsUniqs=us',nsNames=new_cache},name)}serialiseName::BinHandle->Name->UniqFM(Int,Name)->IO()serialiseNamebhname_=doletmodu=nameModulenameput_bh(modulePackageIdmodu,moduleNamemodu,nameOccNamename)--------------------------------------------------------------------------------- GhcBinary instances--------------------------------------------------------------------------------- Hmm, why didn't we dare to make this instance already? It makes things-- much easier.instance(Ordk,Binaryk,Binaryv)=>Binary(Mapkv)whereput_bhm=put_bh(Map.toListm)getbh=fmap(Map.fromList)(getbh)instanceBinaryInterfaceFilewhereput_bh(InterfaceFileenvifaces)=doput_bhenvput_bhifacesgetbh=doenv<-getbhifaces<-getbhreturn(InterfaceFileenvifaces)instanceBinaryInstalledInterfacewhereput_bh(InstalledInterfacemoduinfodocMapexpsvisExpsoptssubMap)=doput_bhmoduput_bhinfoput_bhdocMapput_bhexpsput_bhvisExpsput_bhoptsput_bhsubMapgetbh=domodu<-getbhinfo<-getbhdocMap<-getbhexps<-getbhvisExps<-getbhopts<-getbhsubMap<-getbhreturn(InstalledInterfacemoduinfodocMapexpsvisExpsoptssubMap)instanceBinaryDocOptionwhereput_bhOptHide=doputBytebh0put_bhOptPrune=doputBytebh1put_bhOptIgnoreExports=doputBytebh2put_bhOptNotHome=doputBytebh3getbh=doh<-getBytebhcasehof0->doreturnOptHide1->doreturnOptPrune2->doreturnOptIgnoreExports3->doreturnOptNotHome_->fail"invalid binary data found"{-* Generated by DrIFT : Look, but Don't Touch. *-}instance(Binaryid)=>Binary(HsDocid)whereput_bhDocEmpty=doputBytebh0put_bh(DocAppendaaab)=doputBytebh1put_bhaaput_bhabput_bh(DocStringac)=doputBytebh2put_bhacput_bh(DocParagraphad)=doputBytebh3put_bhadput_bh(DocIdentifierae)=doputBytebh4put_bhaeput_bh(DocModuleaf)=doputBytebh5put_bhafput_bh(DocEmphasisag)=doputBytebh6put_bhagput_bh(DocMonospacedah)=doputBytebh7put_bhahput_bh(DocUnorderedListai)=doputBytebh8put_bhaiput_bh(DocOrderedListaj)=doputBytebh9put_bhajput_bh(DocDefListak)=doputBytebh10put_bhakput_bh(DocCodeBlockal)=doputBytebh11put_bhalput_bh(DocURLam)=doputBytebh12put_bhamput_bh(DocPicx)=doputBytebh13put_bhxput_bh(DocANamean)=doputBytebh14put_bhangetbh=doh<-getBytebhcasehof0->doreturnDocEmpty1->doaa<-getbhab<-getbhreturn(DocAppendaaab)2->doac<-getbhreturn(DocStringac)3->doad<-getbhreturn(DocParagraphad)4->doae<-getbhreturn(DocIdentifierae)5->doaf<-getbhreturn(DocModuleaf)6->doag<-getbhreturn(DocEmphasisag)7->doah<-getbhreturn(DocMonospacedah)8->doai<-getbhreturn(DocUnorderedListai)9->doaj<-getbhreturn(DocOrderedListaj)10->doak<-getbhreturn(DocDefListak)11->doal<-getbhreturn(DocCodeBlockal)12->doam<-getbhreturn(DocURLam)13->dox<-getbhreturn(DocPicx)14->doan<-getbhreturn(DocANamean)_->fail"invalid binary data found"instanceBinaryname=>Binary(HaddockModInfoname)whereput_bhhmi=doput_bh(hmi_descriptionhmi)put_bh(hmi_portabilityhmi)put_bh(hmi_stabilityhmi)put_bh(hmi_maintainerhmi)getbh=dodescr<-getbhporta<-getbhstabi<-getbhmaint<-getbhreturn(HaddockModInfodescrportastabimaint)instanceBinaryDocNamewhereput_bh(Documentednamemodu)=doputBytebh0put_bhnameput_bhmoduput_bh(Undocumentedname)=doputBytebh1put_bhnamegetbh=doh<-getBytebhcasehof0->doname<-getbhmodu<-getbhreturn(Documentednamemodu)1->doname<-getbhreturn(Undocumentedname)_->error"get DocName: Bad h"