diff --git a/Cabal.hs b/Cabal.hs index bad0f36..ab51d47 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -2,15 +2,13 @@ module Cabal (initializeGHC) where +import CabalApi (cabalParseFile, cabalBuildInfo, cabalDependPackages) import Control.Applicative import Control.Exception import Control.Monad import CoreMonad import Data.List -import Data.Maybe -import Distribution.PackageDescription -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Verbosity (silent) +import Distribution.PackageDescription (BuildInfo(..), usedExtensions) import ErrMsg import GHC import GHCApi @@ -29,11 +27,12 @@ initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogRea initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal where withoutCabal = do - logReader <- initSession opt ghcOptions importDirs logging + logReader <- initSession opt ghcOptions importDirs Nothing logging return (fileName,logReader) withCabal = do (owdir,cdir,cfile) <- liftIO getDirs - binfo@BuildInfo{..} <- liftIO $ parseCabalFile cfile + cabal <- liftIO $ cabalParseFile cfile + binfo@BuildInfo{..} <- liftIO $ cabalBuildInfo cabal let exts = map (addX . Gap.extensionToString) $ usedExtensions binfo lang = maybe "-XHaskell98" (addX . show) defaultLanguage libs = map ("-l" ++) extraLibs @@ -42,25 +41,13 @@ initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal idirs = case hsSourceDirs of [] -> [cdir,owdir] dirs -> map (cdir ) dirs ++ [owdir] - logReader <- initSession opt gopts idirs logging + depPkgs <- liftIO $ cabalDependPackages cabal + logReader <- initSession opt gopts idirs (Just depPkgs) logging return (fileName,logReader) addX = ("-X" ++) ---------------------------------------------------------------- --- Causes error, catched in the upper function. -parseCabalFile :: FilePath -> IO BuildInfo -parseCabalFile file = do - cabal <- readPackageDescription silent file - return . fromJust $ fromLibrary cabal <|> fromExecutable cabal - where - fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c - fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c) - toMaybe [] = Nothing - toMaybe (x:_) = Just x - ----------------------------------------------------------------- - -- CurrentWorkingDir, CabalDir, CabalFile getDirs :: IO (FilePath,FilePath,FilePath) getDirs = do diff --git a/CabalApi.hs b/CabalApi.hs new file mode 100644 index 0000000..326b810 --- /dev/null +++ b/CabalApi.hs @@ -0,0 +1,55 @@ +module CabalApi ( + cabalParseFile, + cabalBuildInfo, + cabalDependPackages + ) where + +import Control.Applicative + +import Data.Maybe (fromJust, maybeToList) +import Data.Set (fromList, toList) + +import Distribution.Verbosity (silent) +import Distribution.Package (Dependency(Dependency), PackageName(PackageName)) +import Distribution.PackageDescription + (GenericPackageDescription, + condLibrary, condExecutables, condTestSuites, condBenchmarks, + BuildInfo, libBuildInfo, buildInfo, + CondTree, condTreeConstraints, condTreeData) +import Distribution.PackageDescription.Parse (readPackageDescription) + +---------------------------------------------------------------- + +cabalParseFile :: FilePath -> IO GenericPackageDescription +cabalParseFile = readPackageDescription silent + +-- Causes error, catched in the upper function. +cabalBuildInfo :: GenericPackageDescription -> IO BuildInfo +cabalBuildInfo pd = do + return . fromJust $ fromLibrary pd <|> fromExecutable pd + where + fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c + fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c) + toMaybe [] = Nothing + toMaybe (x:_) = Just x + +getDepsOfPairs :: [(a1, CondTree v [b] a)] -> [b] +getDepsOfPairs = concatMap (condTreeConstraints . snd) + +allDependsOfDescription :: GenericPackageDescription -> [Dependency] +allDependsOfDescription pd = + concat [depLib, depExe, depTests, depBench] + where + depLib = concatMap condTreeConstraints (maybeToList . condLibrary $ pd) + depExe = getDepsOfPairs . condExecutables $ pd + depTests = getDepsOfPairs . condTestSuites $ pd + depBench = getDepsOfPairs . condBenchmarks $ pd + +getDependencyPackageName :: Dependency -> String +getDependencyPackageName (Dependency (PackageName n) _) = n + +cabalDependPackages :: GenericPackageDescription -> IO [String] +cabalDependPackages = + return . toList . fromList + . map getDependencyPackageName + . allDependsOfDescription diff --git a/GHCApi.hs b/GHCApi.hs index 34f9d4c..337f879 100644 --- a/GHCApi.hs +++ b/GHCApi.hs @@ -31,29 +31,33 @@ initSession0 :: Options -> Ghc [PackageId] initSession0 opt = getSessionDynFlags >>= (>>= setSessionDynFlags) . setGhcFlags opt -initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader -initSession opt cmdOpts idirs logging = do +initSession :: Options -> [String] -> [FilePath] -> Maybe [String] -> Bool -> Ghc LogReader +initSession opt cmdOpts idirs mayPkgs logging = do dflags <- getSessionDynFlags let opts = map noLoc cmdOpts (dflags',_,_) <- parseDynamicFlags dflags opts - (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags opt dflags' $ idirs + (dflags'',readLog) <- liftIO . (>>= setLogger logging) + . setGhcFlags opt . setFlags opt dflags' idirs $ mayPkgs _ <- setSessionDynFlags dflags'' return readLog ---------------------------------------------------------------- -setFlags :: Options -> DynFlags -> [FilePath] -> DynFlags -setFlags opt d idirs +setFlags :: Options -> DynFlags -> [FilePath] -> Maybe [String] -> DynFlags +setFlags opt d idirs mayPkgs | expandSplice opt = dopt_set d' Opt_D_dump_splices | otherwise = d' where - d' = d { - packageFlags = ghcPackage : packageFlags d - , importPaths = idirs + d' = maySetExpose $ d { + importPaths = idirs , ghcLink = LinkInMemory , hscTarget = HscInterpreted , flags = flags d } + -- Do hide-all only when depend packages specified + maySetExpose df = maybe df (\x -> (dopt_set df Opt_HideAllPackages) { + packageFlags = map ExposePackage x ++ packageFlags df + }) mayPkgs ghcPackage :: PackageFlag ghcPackage = ExposePackage "ghc" diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 5d33566..7e16dc8 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -28,6 +28,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el Executable ghc-mod Main-Is: GHCMod.hs Other-Modules: Browse + CabalApi Cabal CabalDev Check @@ -45,6 +46,7 @@ Executable ghc-mod GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5 , Cabal + , containers , convertible , directory , filepath