Merge pull request #86 from khibino/build_depends

Read depend packages from *.cabal, and adjust compiler package flags.

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 (BuildInfo(..), usedExtensions)
-import Distribution.PackageDescription
-import Distribution.PackageDescription.Parse (readPackageDescription)
-import Distribution.Verbosity (silent)
 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

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

GHCApi.hs

@@ -31,29 +31,33 @@ initSession0 :: Options -> Ghc [PackageId]
 initSession0 opt = getSessionDynFlags >>=
   (>>= setSessionDynFlags) . setGhcFlags opt
 
-initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader
+initSession :: Options -> [String] -> [FilePath] -> Maybe [String] -> Bool -> Ghc LogReader
-initSession opt cmdOpts idirs logging = do
+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 :: Options -> DynFlags -> [FilePath] -> Maybe [String] -> DynFlags
-setFlags opt d idirs
+setFlags opt d idirs mayPkgs
   | expandSplice opt = dopt_set d' Opt_D_dump_splices
   | otherwise        = d'
   where
-    d' = d {
+    d' = maySetExpose $ d {
-        packageFlags = ghcPackage : packageFlags d
+        importPaths = idirs
-      , 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"

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