Add functions for dealing with packages, modules and bindings to GHCApi
This commit is contained in:
parent
73bf4cbc4e
commit
81c58585a2
@ -9,6 +9,13 @@ module Language.Haskell.GhcMod.GHCApi (
|
|||||||
, withCmdFlags
|
, withCmdFlags
|
||||||
, setNoWaringFlags
|
, setNoWaringFlags
|
||||||
, setAllWaringFlags
|
, setAllWaringFlags
|
||||||
|
, ghcPkgDb
|
||||||
|
, package
|
||||||
|
, modules
|
||||||
|
, findModule
|
||||||
|
, moduleInfo
|
||||||
|
, localModuleInfo
|
||||||
|
, bindings
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Language.Haskell.GhcMod.CabalApi
|
import Language.Haskell.GhcMod.CabalApi
|
||||||
@ -19,14 +26,17 @@ import Language.Haskell.GhcMod.Types
|
|||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Monad (forM, void)
|
import Control.Monad (forM, void)
|
||||||
|
import Distribution.Package (InstalledPackageId(..))
|
||||||
import Data.Maybe (isJust, fromJust)
|
import Data.Maybe (isJust, fromJust)
|
||||||
import Exception (ghandle, SomeException(..))
|
import qualified Data.Map.Strict as M
|
||||||
import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
|
import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
|
||||||
import qualified GHC as G
|
import qualified GHC as G
|
||||||
import GhcMonad
|
import GhcMonad
|
||||||
import GHC.Paths (libdir)
|
import GHC.Paths (libdir)
|
||||||
import System.Exit (exitSuccess)
|
import qualified Packages as G
|
||||||
import System.IO (hPutStr, hPrint, stderr)
|
import qualified Module as G
|
||||||
|
import qualified OccName as G
|
||||||
|
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
@ -178,3 +188,76 @@ allWarningFlags = unsafePerformIO $ do
|
|||||||
df <- G.getSessionDynFlags
|
df <- G.getSessionDynFlags
|
||||||
df' <- addCmdOpts ["-Wall"] df
|
df' <- addCmdOpts ["-Wall"] df
|
||||||
return $ G.warningFlags 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"
|
||||||
|
@ -1,6 +1,9 @@
|
|||||||
module Language.Haskell.GhcMod.Types where
|
module Language.Haskell.GhcMod.Types where
|
||||||
|
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
import PackageConfig (PackageConfig)
|
||||||
|
|
||||||
-- | Output style.
|
-- | Output style.
|
||||||
data OutputStyle = LispStyle -- ^ S expression style.
|
data OutputStyle = LispStyle -- ^ S expression style.
|
||||||
@ -87,6 +90,9 @@ showPkg (n,v,_) = intercalate "-" [n,v]
|
|||||||
showPkgId :: Package -> String
|
showPkgId :: Package -> String
|
||||||
showPkgId (n,v,i) = intercalate "-" [n,v,i]
|
showPkgId (n,v,i) = intercalate "-" [n,v,i]
|
||||||
|
|
||||||
|
-- | Collection of packages
|
||||||
|
type PkgDb = (M.Map Package PackageConfig)
|
||||||
|
|
||||||
-- | Haskell expression.
|
-- | Haskell expression.
|
||||||
type Expression = String
|
type Expression = String
|
||||||
|
|
||||||
|
31
test/GhcApiSpec.hs
Normal file
31
test/GhcApiSpec.hs
Normal file
@ -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"]
|
Loading…
Reference in New Issue
Block a user