{-# LANGUAGE CPP #-}---- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons-- -- This library is free software; you can redistribute it and/or-- modify it under the terms of the GNU Lesser General Public-- License as published by the Free Software Foundation; either-- version 2.1 of the License, or (at your option) any later version.-- -- This library is distributed in the hope that it will be useful,-- but WITHOUT ANY WARRANTY; without even the implied warranty of-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU-- Lesser General Public License for more details.-- -- You should have received a copy of the GNU Lesser General Public-- License along with this library; if not, write to the Free Software-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307-- USA-- moduleSystem.Plugins.Env(env,withModEnv,withDepEnv,withPkgEnvs,withMerged,modifyModEnv,modifyDepEnv,modifyPkgEnv,modifyMerged,addModule,rmModule,addModules,isLoaded,loaded,addModuleDeps,getModuleDeps,rmModuleDeps,isMerged,lookupMerged,addMerge,addPkgConf,union,addStaticPkg,isStaticPkg,grabDefaultPkgConf,readPackageConf,lookupPkg)where#include "../../../config.h"importSystem.Plugins.LoadTypes(Module)importSystem.Plugins.Consts(sysPkgSuffix)importControl.Monad(liftM)importData.IORef(writeIORef,readIORef,newIORef,IORef())importData.Maybe(isJust,isNothing,fromMaybe)importData.List(nub)importSystem.IO.Unsafe(unsafePerformIO)importSystem.Directory(doesFileExist)#if defined(CYGWIN) || defined(__MINGW32__)importPreludehiding(catch,ioError)importSystem.IO.Error(catch,ioError,isDoesNotExistError)#endifimportControl.Concurrent.MVar(MVar(),newMVar,withMVar)importDistribution.Packagehiding(depends,packageName,PackageName(..))importDistribution.TextimportDistribution.InstalledPackageInfo-- import Distribution.Package hiding (packageName, PackageName(..))importDistribution.Simple.CompilerimportDistribution.Simple.GHCimportDistribution.Simple.PackageIndeximportDistribution.Simple.ProgramimportDistribution.VerbosityimportqualifiedData.MapasMimportqualifiedData.SetasS---- and map Data.Map terms to FiniteMap terms--typeFiniteMapke=M.MapkeemptyFM::FiniteMapkeyeltemptyFM=M.emptyaddToFM::(Ordkey)=>FiniteMapkeyelt->key->elt->FiniteMapkeyeltaddToFM=\mke->M.insertkemaddWithFM::(Ordkey)=>(elt->elt->elt)->FiniteMapkeyelt->key->elt->FiniteMapkeyeltaddWithFM=\combmke->M.insertWithcombkemdelFromFM::(Ordkey)=>FiniteMapkeyelt->key->FiniteMapkeyeltdelFromFM=flipM.deletelookupFM::(Ordkey)=>FiniteMapkeyelt->key->MaybeeltlookupFM=flipM.lookup---- | We need to record what modules and packages we have loaded, so if-- we read a .hi file that wants to load something already loaded, we-- can safely ignore that request. We're in the IO monad anyway, so we-- can add some extra state of our own.---- The state is a FiniteMap String (Module,Int) (a hash of-- package\/object names to Modules and how many times they've been-- loaded).---- It also contains the package.conf information, so that if there is a-- package dependency we can find it correctly, even if it has a-- non-standard path or name, and if it isn't an official package (but-- rather one provided via -package-conf). This is stored as a FiniteMap-- PackageName PackageConfig. The problem then is whether a user's-- package.conf, that uses the same package name as an existing GHC-- package, should be allowed, or should shadow a library package? I-- don't know, but I'm inclined to have the GHC package shadow the-- user's package.---- This idea is based on /Hampus Ram's dynamic loader/ dependency-- tracking system. He uses state to record dependency trees to allow-- clean unloading and other fun. This is quite cool. We're just using-- state to make sure we don't load the same package twice. Implementing-- the full dependency tree idea would be nice, though not fully-- necessary as we have the dependency information store in .hi files,-- unlike in hram's loader.--typeModEnv=FiniteMapString(Module,Int)typeDepEnv=FiniteMapModule[Module]-- represents a package.conf filetypePkgEnv=FiniteMapPackageNamePackageConfigtypeStaticPkgEnv=S.SetPackageName-- record dependencies between (src,stub) -> merged modidtypeMergeEnv=FiniteMap(FilePath,FilePath)FilePath-- multiple package.conf's kept in separate namespacestypePkgEnvs=[PkgEnv]typeEnv=(MVar(),IORefModEnv,IORefDepEnv,IORefPkgEnvs,IORefStaticPkgEnv,IORefMergeEnv)---- our environment, contains a set of loaded objects, and a map of known-- packages and their informations. Initially all we know is the default-- package.conf information.--env=unsafePerformIO$domvar<-newMVar()ref1<-newIORefemptyFM-- loaded objectsref2<-newIORefemptyFMp<-grabDefaultPkgConfref3<-newIORefp-- package.conf inforef4<-newIORef(S.fromList["base","Cabal","haskell-src","containers","arrays","directory","random","process","ghc","ghc-prim"])ref5<-newIORefemptyFM-- merged filesreturn(mvar,ref1,ref2,ref3,ref4,ref5){-# NOINLINE env #-}-- --------------------------------------------------------------- | apply 'f' to the loaded objects Env, apply 'f' to the package.conf-- FM /locks up the MVar/ so you can't recursively call a function-- inside a with any -Env function. Nice and threadsafe--withModEnv::Env->(ModEnv->IOa)->IOawithDepEnv::Env->(DepEnv->IOa)->IOawithPkgEnvs::Env->(PkgEnvs->IOa)->IOawithStaticPkgEnv::Env->(StaticPkgEnv->IOa)->IOawithMerged::Env->(MergeEnv->IOa)->IOawithModEnv(mvar,ref,_,_,_,_)f=withMVarmvar(\_->readIORefref>>=f)withDepEnv(mvar,_,ref,_,_,_)f=withMVarmvar(\_->readIORefref>>=f)withPkgEnvs(mvar,_,_,ref,_,_)f=withMVarmvar(\_->readIORefref>>=f)withStaticPkgEnv(mvar,_,_,_,ref,_)f=withMVarmvar(\_->readIORefref>>=f)withMerged(mvar,_,_,_,_,ref)f=withMVarmvar(\_->readIORefref>>=f)-- --------------------------------------------------------------- write an object name-- write a new PackageConfig--modifyModEnv::Env->(ModEnv->IOModEnv)->IO()modifyDepEnv::Env->(DepEnv->IODepEnv)->IO()modifyPkgEnv::Env->(PkgEnvs->IOPkgEnvs)->IO()modifyStaticPkgEnv::Env->(StaticPkgEnv->IOStaticPkgEnv)->IO()modifyMerged::Env->(MergeEnv->IOMergeEnv)->IO()modifyModEnv(mvar,ref,_,_,_,_)f=lockAndWritemvarreffmodifyDepEnv(mvar,_,ref,_,_,_)f=lockAndWritemvarreffmodifyPkgEnv(mvar,_,_,ref,_,_)f=lockAndWritemvarreffmodifyStaticPkgEnv(mvar,_,_,_,ref,_)f=lockAndWritemvarreffmodifyMerged(mvar,_,_,_,_,ref)f=lockAndWritemvarreff-- privatelockAndWritemvarreff=withMVarmvar(\_->readIORefref>>=f>>=writeIORefref)-- --------------------------------------------------------------- | insert a loaded module name into the environment--addModule::String->Module->IO()addModulesm=modifyModEnvenv$\fm->letc=maybe0snd(lookupFMfms)inreturn$addToFMfms(m,c+1)--getModule :: String -> IO (Maybe Module)--getModule s = withModEnv env $ \fm -> return (lookupFM fm s)---- | remove a module name from the environment. Returns True if the-- module was actually removed.--rmModule::String->IOBoolrmModules=domodifyModEnvenv$\fm->letc=maybe1snd(lookupFMfms)fm'=delFromFMfmsinifc-1<=0thenreturnfm'elsereturnfmwithModEnvenv$\fm->return(isNothing(lookupFMfms))---- | insert a list of module names all in one go--addModules::[(String,Module)]->IO()addModulesns=mapM_(uncurryaddModule)ns---- | is a module\/package already loaded?--isLoaded::String->IOBoolisLoadeds=withModEnvenv$\fm->return$isJust(lookupFMfms)---- confusing! only for filter.--loaded::String->IOBoolloadedm=dot<-isLoadedm;return(nott)-- --------------------------------------------------------------- module dependency stuff------ | Set the dependencies of a Module.--addModuleDeps::Module->[Module]->IO()addModuleDepsmdeps=modifyDepEnvenv$\fm->return$addToFMfmmdeps---- | Get module dependencies. Nothing if none have been recored.--getModuleDeps::Module->IO[Module]getModuleDepsm=withDepEnvenv$\fm->return$fromMaybe[](lookupFMfmm)---- | Unrecord a module from the environment.--rmModuleDeps::Module->IO()rmModuleDepsm=modifyDepEnvenv$\fm->return$delFromFMfmm-- ------------------------------------------------------------- Package management stuff---- | Insert a single package.conf (containing multiple configs) means:-- create a new FM. insert packages into FM. add FM to end of list of FM-- stored in the environment.--addPkgConf::FilePath->IO()addPkgConff=dops<-readPackageConffmodifyPkgEnvenv$\ls->return$unionlsps---- | add a new FM for the package.conf to the list of existing ones; if a package occurs multiple-- times, pick the one with the higher version number as the default (e.g., important for base in-- GHC 6.12)--union::PkgEnvs->[PackageConfig]->PkgEnvsunionlsps'=letfm=emptyFM-- new FM for this package.confinfoldraddOnePkgfmps':lswhere-- we add each package with and without it's version numberaddOnePkgpfm'=addToPkgEnvs(addToPkgEnvsfm'(display$sourcePackageIdp)p)(packageNamep)p-- if no version number specified, pick the higher versionaddToPkgEnvs=addWithFMhigherVersionhigherVersionpkgconf1pkgconf2|installedPackageIdpkgconf1>=installedPackageIdpkgconf2=pkgconf1|otherwise=pkgconf2-- -- | generate a PkgEnv from the system package.conf-- The path to the default package.conf was determined by /configure/-- This imposes a constraint that you must build your plugins with the-- same ghc you use to build hs-plugins. This is reasonable, we feel.--grabDefaultPkgConf::IOPkgEnvsgrabDefaultPkgConf=dopc<-configureAllKnownProgramssilentdefaultProgramConfigurationpkgIndex<-getInstalledPackagessilent[GlobalPackageDB,UserPackageDB]pcreturn$[]`union`allPackagespkgIndex---- parse a source file, expanding any $libdir we see.--readPackageConf::FilePath->IO[PackageConfig]readPackageConff=dopc<-configureAllKnownProgramssilentdefaultProgramConfigurationpkgIndex<-getInstalledPackagessilent[GlobalPackageDB,UserPackageDB,SpecificPackageDBf]pcreturn$allPackagespkgIndex-- ------------------------------------------------------------- Static package management stuff. A static package is linked with the base-- application and we should therefore not link with any of the DLLs it requires.addStaticPkg::PackageName->IO()addStaticPkgpkg=modifyStaticPkgEnvenv$\set->return$S.insertpkgsetisStaticPkg::PackageName->IOBoolisStaticPkgpkg=withStaticPkgEnvenv$\set->return$S.memberpkgset---- Package path, given a package name, look it up in the environment and-- return the path to all the libraries needed to load this package.---- What do we need to load? With the library_dirs as prefix paths:-- . anything in the hs_libraries fields, libdir expanded---- . anything in the extra_libraries fields (i.e. cbits), expanded,---- which includes system .so files.---- . also load any dependencies now, because of that weird mtl-- library that lang depends upon, but which doesn't show up in the-- interfaces for some reason.---- We return all the package paths that possibly exist, and the leave it-- up to loadObject not to load the same ones twice...--lookupPkg::PackageName->IO([FilePath],[FilePath])lookupPkgp=do(ps,(f,g))<-lookupPkg'pstatic<-isStaticPkgp(f',g')<-liftMunzip$mapMlookupPkgpsreturn$(nub$(concatf')++f,ifstaticthen[]elsenub$(concatg')++g)dataLibrarySpec=DLLString-- -lLib|DLLPathFilePath-- -LpathclassifyLdInput::FilePath->IO(MaybeLibrarySpec)classifyLdInput('-':'l':lib)=return(Just(DLLlib))classifyLdInput('-':'L':path)=return(Just(DLLPathpath))classifyLdInput_=returnNothing-- TODO need to define a MAC\/DARWIN symbol#if defined(MACOSX)mkSONameroot="lib"++root++".dylib"#elif defined(CYGWIN) || defined(__MINGW32__)-- Win32 DLLs have no .dll extension here, because addDLL tries-- both foo.dll and foo.drvmkSONameroot=root#elsemkSONameroot="lib"++root++".so"#endif#if defined(MACOSX)mkDynPkgNameroot=mkSOName(root++"_dyn")#elsemkDynPkgNameroot=mkSONameroot#endifdataHSLib=StaticFilePath|DynamicFilePath---- return any stuff to load for this package, plus the list of packages-- this package depends on. which includes stuff we have to then load-- too.--lookupPkg'::PackageName->IO([PackageName],([FilePath],[FilePath]))lookupPkg'p=withPkgEnvsenv$\fms->gofmspwherego[]_=return([],([],[]))go(fm:fms)q=caselookupFMfmqofNothing->gofmsq-- look in other pkgsJustpkg->dolethslibs=hsLibrariespkgextras'=extraLibrariespkgcbits=filter(\e->reverse(take(length"_cbits")(reversee))=="_cbits")extras'extras=filter(flipnotElemcbits)extras'ldopts=ldOptionspkgdeppkgs=packageDepspkgldInput<-mapMclassifyLdInputldoptsletldOptsLibs=[path|Just(DLLpath)<-ldInput]ldOptsPaths=[path|Just(DLLPathpath)<-ldInput]dlls=mapmkSOName(extras++ldOptsLibs)#if defined(CYGWIN) || defined(__MINGW32__)libdirs=fix_topdir(libraryDirspkg)++ldOptsPaths#elselibdirs=libraryDirspkg++ldOptsPaths#endif-- If we're loading dynamic libs we need the cbits to appear before the-- real packages.libs<-mapM(findHSliblibdirs)(cbits++hslibs)#if defined(CYGWIN) || defined(__MINGW32__)windowsos<-catch(getEnv"OS")(\e->ifisDoesNotExistErrorethenreturn"Windows_98"elseioErrore)windowsdir<-ifwindowsos=="Windows_9X"-- I don't know Windows 9X has OS system variablethenreturn"C:/windows"elsereturn"C:/winnt"sysroot<-catch(getEnv"SYSTEMROOT")(\e->ifisDoesNotExistErrorethenreturnwindowsdirelseioErrore)-- guess at a reasonable defaultletsyslibdir=sysroot++(ifwindowsos=="Windows_9X"then"/SYSTEM"else"/SYSTEM32")libs'<-mapM(findDLL$syslibdir:libdirs)dlls#elselibs'<-mapM(findDLLlibdirs)dlls#endifletslibs=[lib|Right(Staticlib)<-libs]dlibs=[lib|Right(Dynamiclib)<-libs]return(deppkgs,(slibs,map(eitheridid)libs'++dlibs))#if defined(CYGWIN) || defined(__MINGW32__)-- replace $topdirfix_topdir[]=[]fix_topdir(x:xs)=replace_topdirx:fix_topdirxsreplace_topdir[]=[]replace_topdir('$':xs)|take6xs=="topdir"=ghcLibraryPath++(drop6xs)|otherwise='$':replace_topdirxsreplace_topdir(x:xs)=x:replace_topdirxs#endif-- a list elimination form for the Maybe type--filterRight :: [Either left right] -> [right]--filterRight [] = []--filterRight (Right x:xs) = x:filterRight xs--filterRight (Left _:xs) = filterRight xs---- Check that a path to a library actually reaches a libraryfindHSlib'::[FilePath]->String->IO(MaybeFilePath)findHSlib'[]_=returnNothingfindHSlib'(dir:dirs)lib=doletl=dir</>libb<-doesFileExistlifbthenreturn$Justl-- found it!elsefindHSlib'dirslibfindHSslibdirslib=findHSlib'dirs$lib++sysPkgSuffixfindHSdlibdirslib=findHSlib'dirs$mkDynPkgNamelib-- Problem: sysPkgSuffix is ".o", but extra libraries could be-- ".so"-- Solution: first look for static library, if we don't find it-- look for a dynamic version.findHSlib::[FilePath]->String->IO(EitherStringHSLib)findHSlibdirslib=dostatic<-findHSslibdirslibcasestaticofJustfile->return$Right$StaticfileNothing->dodynamic<-findHSdlibdirslibcasedynamicofJustfile->return$Right$DynamicfileNothing->return$LeftlibfindDLL::[FilePath]->String->IO(EitherStringFilePath)findDLL[]lib=return(Leftlib)findDLL(dir:dirs)lib=doletl=dir</>libb<-doesFileExistlifbthenreturn$RightlelsefindDLLdirslib-------------------------------------------------------------------------- do we have a Module name for this merge?--isMerged::FilePath->FilePath->IOBoolisMergedab=withMergedenv$\fm->return$isJust(lookupFMfm(a,b))lookupMerged::FilePath->FilePath->IO(MaybeFilePath)lookupMergedab=withMergedenv$\fm->return$lookupFMfm(a,b)---- insert a new merge pair into env--addMerge::FilePath->FilePath->FilePath->IO()addMergeabz=modifyMergedenv$\fm->return$addToFMfm(a,b)z-------------------------------------------------------------------------- break a module cycle-- private:--(</>)::FilePath->FilePath->FilePath[]</>b=ba</>b=a++"/"++b---------------------------------------------------------------------------- We export an abstract interface to package conf`s because we have-- to handle either traditional or Cabal style package conf`s.--packageName::PackageConfig->PackageNamepackageDeps::PackageConfig->[PackageName]-- updImportDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig-- updLibraryDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfigtypePackageName=StringtypePackageConfig=InstalledPackageInfopackageName=display.pkgName.sourcePackageId-- packageName_ = pkgName . sourcePackageIdpackageDeps=(mapdisplay).depends{-
updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) =
pk { importDirs = f idirs }
updLibraryDirs f pk@(InstalledPackageInfo { libraryDirs = ldirs }) =
pk { libraryDirs = f ldirs }
-}