From 81c58585a2a0c048e59f0162379057be80f497ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 11 Jul 2014 10:43:51 +0200 Subject: [PATCH] Add functions for dealing with packages, modules and bindings to GHCApi --- Language/Haskell/GhcMod/GHCApi.hs | 89 +++++++++++++++++++++++++++++-- Language/Haskell/GhcMod/Types.hs | 6 +++ test/GhcApiSpec.hs | 31 +++++++++++ 3 files changed, 123 insertions(+), 3 deletions(-) create mode 100644 test/GhcApiSpec.hs diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index ba98bfe..5fc9f6f 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -9,6 +9,13 @@ module Language.Haskell.GhcMod.GHCApi ( , withCmdFlags , setNoWaringFlags , setAllWaringFlags + , ghcPkgDb + , package + , modules + , findModule + , moduleInfo + , localModuleInfo + , bindings ) where import Language.Haskell.GhcMod.CabalApi @@ -19,14 +26,17 @@ import Language.Haskell.GhcMod.Types import Control.Applicative ((<$>)) import Control.Monad (forM, void) +import Distribution.Package (InstalledPackageId(..)) import Data.Maybe (isJust, fromJust) -import Exception (ghandle, SomeException(..)) +import qualified Data.Map.Strict as M import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) import qualified GHC as G import GhcMonad import GHC.Paths (libdir) -import System.Exit (exitSuccess) -import System.IO (hPutStr, hPrint, stderr) +import qualified Packages as G +import qualified Module as G +import qualified OccName as G + import System.IO.Unsafe (unsafePerformIO) ---------------------------------------------------------------- @@ -178,3 +188,76 @@ allWarningFlags = unsafePerformIO $ do df <- G.getSessionDynFlags df' <- addCmdOpts ["-Wall"] df return $ G.warningFlags df' + +---------------------------------------------------------------- +-- get Packages,Modules,Bindings + +ghcPkgDb :: GhcMonad m => m PkgDb +ghcPkgDb = M.fromList <$> + maybe [] (map toKv . filterInternal) <$> pkgDatabase <$> G.getSessionDynFlags + where + toKv pkg = (fromInstalledPackageId $ G.installedPackageId pkg, pkg) + filterInternal = + filter ((/= InstalledPackageId "builtin_rts") . G.installedPackageId) + +package :: G.PackageConfig -> Package +package = fromInstalledPackageId . G.installedPackageId + +modules :: G.PackageConfig -> [ModuleString] +modules = map G.moduleNameString . G.exposedModules + +findModule :: ModuleString -> PkgDb -> [Package] +findModule m db = do + M.elems $ package `M.map` (containsModule `M.filter` db) + where + containsModule :: G.PackageConfig -> Bool + containsModule pkgConf = + G.mkModuleName m `elem` G.exposedModules pkgConf + + +ghcPkgId :: Package -> G.PackageId +ghcPkgId (name,_,_) = + -- TODO: Adding the package version too breaks 'findModule' for some reason + -- this isn't a big deal since in the common case where we're in a cabal + -- project we just use cabal's view of package dependencies anyways so we're + -- guaranteed to only have one version of each package exposed. However when + -- we're operating without a cabal project this will probaly cause trouble. + G.stringToPackageId name + +type Binding = String + +-- | @moduleInfo mpkg module@. @mpkg@ should be 'Nothing' iff. moduleInfo +-- should look for @module@ in the working directory. +-- +-- To map a 'ModuleString' to a package see 'findModule' +moduleInfo :: GhcMonad m + => Maybe Package + -> ModuleString + -> m (Maybe G.ModuleInfo) +moduleInfo mpkg mdl = do + let mdlName = G.mkModuleName mdl + mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg + loadLocalModule + G.findModule mdlName mfsPkgId >>= G.getModuleInfo + where + loadLocalModule = case mpkg of + Just _ -> return () + Nothing -> setTargetFiles [mdl] + +localModuleInfo :: GhcMonad m => ModuleString -> m (Maybe G.ModuleInfo) +localModuleInfo mdl = moduleInfo Nothing mdl + +bindings :: G.ModuleInfo -> [Binding] +bindings minfo = do + map (G.occNameString . G.getOccName) $ G.modInfoExports minfo + + +---------------------------------------------------------------- +-- for PkgDoc + +-- import Distribution.InstalledPackageInfo (showInstalledPackageInfoField) +-- haddockHtml :: GhcMonad m => Package -> m String +-- haddockHtml pkg = do +-- extractField info . fromJust . lookup pkg <$> ghcPkgDb +-- where +-- extractField = fromJust $ showInstalledPackageInfoField "haddock-html" diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 4dfb161..b42b018 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,6 +1,9 @@ module Language.Haskell.GhcMod.Types where import Data.List (intercalate) +import qualified Data.Map as M + +import PackageConfig (PackageConfig) -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. @@ -87,6 +90,9 @@ showPkg (n,v,_) = intercalate "-" [n,v] showPkgId :: Package -> String showPkgId (n,v,i) = intercalate "-" [n,v,i] +-- | Collection of packages +type PkgDb = (M.Map Package PackageConfig) + -- | Haskell expression. type Expression = String diff --git a/test/GhcApiSpec.hs b/test/GhcApiSpec.hs new file mode 100644 index 0000000..71d2c27 --- /dev/null +++ b/test/GhcApiSpec.hs @@ -0,0 +1,31 @@ +module GhcApiSpec where + +import Control.Applicative +import Control.Monad +import Data.List (sort) +import Language.Haskell.GhcMod.GHCApi +import Test.Hspec +import TestUtils +import CoreMonad (liftIO) + +import Dir + +spec :: Spec +spec = do + describe "findModule" $ do + it "finds Data.List in `base' and `haskell2010'" + $ withDirectory_ "test/data" $ runD $ do + pkgs <- findModule "Data.List" <$> ghcPkgDb + let pkgNames = pkgName `map` pkgs + liftIO $ pkgNames `shouldContain` ["base", "haskell2010"] + + describe "moduleInfo" $ do + it "works for modules from global packages (e.g. base:Data.List)" + $ withDirectory_ "test/data" $ runD $ do + Just info <- moduleInfo (Just ("base","","")) "Data.List" + liftIO $ sort (bindings info) `shouldContain` ["++"] + + it "works for local modules" + $ withDirectory_ "test/data" $ runD $ do + Just info <- moduleInfo Nothing "Baz" + liftIO $ bindings info `shouldContain` ["baz"]