Merge branch 'dev' of git://github.com/DanielG/ghc-mod into DanielG-dev

Language/Haskell/GhcMod/CabalApi.hs

@@ -9,6 +9,9 @@ module Language.Haskell.GhcMod.CabalApi (
   , cabalAllTargets
   ) where
 
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.GhcPkg
+
 import Control.Applicative ((<$>))
 import Control.Exception (throwIO)
 import Control.Monad (filterM)
@@ -30,18 +33,20 @@ import Distribution.System (buildPlatform)
 import Distribution.Text (display)
 import Distribution.Verbosity (silent)
 import Distribution.Version (Version)
-import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Cradle
 import System.Directory (doesFileExist)
 import System.FilePath (dropExtension, takeFileName, (</>))
 
 ----------------------------------------------------------------
 
 -- | Getting necessary 'CompilerOptions' from three information sources.
-getCompilerOptions :: [GHCOption] -> Cradle -> PackageDescription -> IO CompilerOptions
+getCompilerOptions :: [GHCOption]
+                   -> Cradle
+                   -> PackageDescription
+                   -> IO CompilerOptions
 getCompilerOptions ghcopts cradle pkgDesc = do
     gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos
-    return $ CompilerOptions gopts idirs depPkgs
+    dbPkgs <- getPackageDbPackages rdir
+    return $ CompilerOptions gopts idirs (depPkgs dbPkgs)
   where
     wdir       = cradleCurrentDir cradle
     rdir       = cradleRootDir    cradle
@@ -49,7 +54,12 @@ getCompilerOptions ghcopts cradle pkgDesc = do
     pkgs       = cradlePackages   cradle
     buildInfos = cabalAllBuildInfo pkgDesc
     idirs      = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
-    depPkgs    = attachPackageIds pkgs $ removeThem problematicPackages $ removeMe cfile $ cabalDependPackages buildInfos
+    depPkgs ps = attachPackageIds pkgs
+                   $ removeThem problematicPackages
+                   $ removeMe cfile
+                   $ filter (`elem` ps) -- remove packages not available in any
+                                        -- package dbs
+                   $ cabalDependPackages buildInfos
 
 ----------------------------------------------------------------
 -- Dependent packages
@@ -114,7 +124,7 @@ getGHCOptions ghcopts cradle rdir binfo = do
     let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp
     return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps
   where
-    pkgDb = userPackageDbOptsForGhc $ cradlePackageDb cradle
+    pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle
     lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo
     libDirs = map ("-L" ++) $ P.extraLibDirs binfo
     exts = map (("-X" ++) . display) $ P.usedExtensions binfo
@@ -211,4 +221,3 @@ cabalAllTargets pd = do
     getExecutableTarget exe = do
       let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]
       liftIO $ filterM doesFileExist maybeExes
-

Language/Haskell/GhcMod/Cradle.hs

@@ -3,23 +3,18 @@
 module Language.Haskell.GhcMod.Cradle (
     findCradle
   , findCradleWithoutSandbox
-  , getPackageDbDir
-  , getPackageDbPackages
-  , userPackageDbOptsForGhc
-  , userPackageDbOptsForGhcPkg
-  , getSandboxDir
   ) where
 
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.GhcPkg
+
 import Control.Applicative ((<$>))
-import Control.Exception (SomeException(..))
 import qualified Control.Exception as E
 import Control.Exception.IOChoice ((||>))
 import Control.Monad (filterM)
-import Data.Char (isSpace)
-import Data.List (isPrefixOf, isSuffixOf, tails)
-import Language.Haskell.GhcMod.Types
+import Data.List (isSuffixOf)
 import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)
-import System.FilePath ((</>), takeDirectory, takeFileName)
+import System.FilePath ((</>), takeDirectory)
 
 ----------------------------------------------------------------
 
@@ -35,24 +30,24 @@ findCradle = do
 cabalCradle :: FilePath -> IO Cradle
 cabalCradle wdir = do
     (rdir,cfile) <- cabalDir wdir
-    pkgDbOpts <- getPackageDb rdir
+    pkgDbStack <- getPackageDbStack rdir
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = rdir
       , cradleCabalFile  = Just cfile
-      , cradlePackageDb  = pkgDbOpts
+      , cradlePkgDbStack = pkgDbStack
       , cradlePackages   = []
       }
 
 sandboxCradle :: FilePath -> IO Cradle
 sandboxCradle wdir = do
     rdir <- getSandboxDir wdir
-    pkgDbOpts <- getPackageDb rdir
+    pkgDbStack <- getPackageDbStack rdir
     return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = rdir
       , cradleCabalFile  = Nothing
-      , cradlePackageDb  = pkgDbOpts
+      , cradlePkgDbStack = pkgDbStack
       , cradlePackages   = []
       }
 
@@ -61,7 +56,7 @@ plainCradle wdir = return Cradle {
         cradleCurrentDir = wdir
       , cradleRootDir    = wdir
       , cradleCabalFile  = Nothing
-      , cradlePackageDb  = Nothing
+      , cradlePkgDbStack = [GlobalDb]
       , cradlePackages   = []
       }
 
@@ -69,7 +64,7 @@ plainCradle wdir = return Cradle {
 findCradleWithoutSandbox :: IO Cradle
 findCradleWithoutSandbox = do
     cradle <- findCradle
-    return cradle { cradlePackageDb = Nothing, cradlePackages = [] }
+    return cradle { cradlePkgDbStack = [GlobalDb], cradlePackages = [] }
 
 ----------------------------------------------------------------
 
@@ -103,121 +98,6 @@ getCabalFiles dir = getFiles >>= filterM doesCabalFileExist
 
 ----------------------------------------------------------------
 
-configFile :: String
-configFile = "cabal.sandbox.config"
-
-pkgDbKey :: String
-pkgDbKey = "package-db:"
-
-pkgDbKeyLen :: Int
-pkgDbKeyLen = length pkgDbKey
-
--- | Obtaining GHC options relating to a package db directory
-getPackageDb :: FilePath -> IO (Maybe FilePath)
-getPackageDb cdir = (Just <$> getPkgDb) `E.catch` handler
-  where
-    getPkgDb = getPackageDbDir (cdir </> configFile)
-    handler :: SomeException -> IO (Maybe FilePath)
-    handler _ = return Nothing
-
--- | Extract a package db directory from the sandbox config file.
---   Exception is thrown if the sandbox config file is broken.
-getPackageDbDir :: FilePath -> IO FilePath
-getPackageDbDir sconf = do
-    -- Be strict to ensure that an error can be caught.
-    !path <- extractValue . parse <$> readFile sconf
-    return path
-  where
-    parse = head . filter ("package-db:" `isPrefixOf`) . lines
-    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop pkgDbKeyLen
-    -- dropWhileEnd is not provided prior to base 4.5.0.0.
-    dropWhileEnd :: (a -> Bool) -> [a] -> [a]
-    dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
-
--- | Creating user package db options for GHC.
---
--- >>> userPackageDbOptsForGhc (Just "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d")
--- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"]
--- >>> userPackageDbOptsForGhc (Just "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d")
--- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"]
-userPackageDbOptsForGhc :: Maybe FilePath -> [String]
-userPackageDbOptsForGhc Nothing      = []
-userPackageDbOptsForGhc (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt, pkgDb]
-  where
-    ver = extractGhcVer pkgDb
-    (noUserPkgDbOpt,pkgDbOpt)
-      | ver < 706 = ("-no-user-package-conf", "-package-conf")
-      | otherwise = ("-no-user-package-db",   "-package-db")
-
--- | Creating user package db options for ghc-pkg.
---
--- >>> userPackageDbOptsForGhcPkg (Just "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d")
--- ["--no-user-package-db","--package-db=/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"]
--- >>> userPackageDbOptsForGhcPkg (Just "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d")
--- ["--no-user-package-conf","--package-conf=/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"]
-userPackageDbOptsForGhcPkg :: Maybe FilePath -> [String]
-userPackageDbOptsForGhcPkg Nothing      = []
-userPackageDbOptsForGhcPkg (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt]
-  where
-    ver = extractGhcVer pkgDb
-    (noUserPkgDbOpt,pkgDbOpt)
-      | ver < 706 = ("--no-user-package-conf", "--package-conf=" ++ pkgDb)
-      | otherwise = ("--no-user-package-db",   "--package-db="   ++ pkgDb)
-
--- | Extracting GHC version from the path of package db.
---   Exception is thrown if the string argument is incorrect.
---
--- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"
--- 706
-extractGhcVer :: String -> Int
-extractGhcVer dir = ver
-  where
-    file = takeFileName dir
-    findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails
-    (verStr1,_:left) = break (== '.') $ findVer file
-    (verStr2,_)      = break (== '.') left
-    ver = read verStr1 * 100 + read verStr2
-
--- | Obtaining packages installed in a package db directory.
-getPackageDbPackages :: FilePath -> IO [Package]
-getPackageDbPackages cdir = (getPkgDb >>= listDbPackages) `E.catch` handler
-  where
-    getPkgDb = getPackageDbDir (cdir </> configFile)
-    handler :: SomeException -> IO [Package]
-    handler _ = return []
-
-listDbPackages :: FilePath -> IO [Package]
-listDbPackages pkgdir = do
-  files <- filter (".conf" `isSuffixOf`) <$> getDirectoryContents pkgdir
-  mapM (extractPackage . (pkgdir </>)) files
-
-extractPackage :: FilePath -> IO Package
-extractPackage pconf = do
-  contents <- lines <$> readFile pconf
-  -- Be strict to ensure that an error can be caught.
-  let !name = extractName $ parseName contents
-      !pid = extractId $ parseId contents
-  return (name, Just pid)
-  where
-    parseName = parse nameKey
-    extractName = extract nameKeyLength
-    parseId = parse idKey
-    extractId = extract idKeyLength
-    parse key = head . filter (key `isPrefixOf`)
-    extract keylen = takeWhile (not . isSpace) . dropWhile isSpace . drop keylen
-
-nameKey :: String
-nameKey = "name:"
-
-idKey :: String
-idKey = "id:"
-
-nameKeyLength :: Int
-nameKeyLength = length nameKey
-
-idKeyLength :: Int
-idKeyLength = length idKey
-
 getSandboxDir :: FilePath -> IO FilePath
 getSandboxDir dir = do
     exist <- doesFileExist sfile
@@ -228,5 +108,5 @@ getSandboxDir dir = do
       else
         getSandboxDir dir'
   where
-    sfile = dir </> configFile
+    sfile = dir </> "cabal.sandbox.config"
     dir' = takeDirectory dir

Language/Haskell/GhcMod/Debug.hs

@@ -51,7 +51,9 @@ debug opt cradle fileName = do
     cabalFile = fromMaybe "" mCabalFile
     origGopts = ghcOpts opt
     simpleCompilerOption = CompilerOptions origGopts [] []
-    fromCabalFile = parseCabalFile file >>= getCompilerOptions origGopts cradle
+    fromCabalFile = do
+        pkgDesc <- parseCabalFile file
+        getCompilerOptions origGopts cradle pkgDesc
       where
         file = fromJust mCabalFile
 

Language/Haskell/GhcMod/GHCApi.hs

@@ -11,6 +11,11 @@ module Language.Haskell.GhcMod.GHCApi (
   , getSystemLibDir
   ) where
 
+import Language.Haskell.GhcMod.CabalApi
+import Language.Haskell.GhcMod.ErrMsg
+import Language.Haskell.GhcMod.GHCChoice
+import Language.Haskell.GhcMod.GhcPkg
+
 import Control.Applicative (Alternative, (<$>))
 import Control.Monad (void, forM)
 import CoreMonad (liftIO)
@@ -20,10 +25,6 @@ import DynFlags (dopt_set)
 import Exception (ghandle, SomeException(..))
 import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..))
 import qualified GHC as G
-import Language.Haskell.GhcMod.CabalApi
-import Language.Haskell.GhcMod.Cradle (userPackageDbOptsForGhc)
-import Language.Haskell.GhcMod.ErrMsg
-import Language.Haskell.GhcMod.GHCChoice
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
 import System.Exit (exitSuccess)
@@ -89,10 +90,10 @@ initializeFlagsWithCradle opt cradle ghcopts logging
         logger <- initSession SingleFile opt compOpts logging
         return (logger, Nothing)
       where
-        pkgDb = userPackageDbOptsForGhc $ cradlePackageDb cradle
+        pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle
         compOpts
-          | null pkgDb = CompilerOptions ghcopts importDirs []
-          | otherwise  = CompilerOptions (ghcopts ++ pkgDb) [wdir,rdir] []
+          | null pkgOpts = CompilerOptions ghcopts importDirs []
+          | otherwise    = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []
         wdir = cradleCurrentDir cradle
         rdir = cradleRootDir    cradle
 

Language/Haskell/GhcMod/GhcPkg.hs

@@ -0,0 +1,148 @@
+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
+module Language.Haskell.GhcMod.GhcPkg (
+    ghcPkgList
+  , ghcPkgDbOpt
+  , ghcPkgDbStackOpts
+  , ghcDbStackOpts
+  , ghcDbOpt
+  , getSandboxDb
+  , getPackageDbStack
+  , getPackageDbPackages
+  ) where
+
+import Language.Haskell.GhcMod.Types
+
+import Control.Applicative ((<$>))
+import Control.Exception (SomeException(..))
+import qualified Control.Exception as E
+--import Control.Exception.IOChoice ((||>))
+import Data.Char (isSpace)
+import Data.List (isPrefixOf, tails)
+import System.FilePath ((</>), takeFileName)
+import System.Process (readProcess)
+
+import Config (cProjectVersionInt) -- ghc version
+
+ghcVersion :: Int
+ghcVersion = read cProjectVersionInt
+
+-- | Get path to sandbox package db
+getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
+                         -- (containing the @cabal.sandbox.config@ file)
+             -> IO FilePath
+getSandboxDb cdir =
+    getSandboxDbDir (cdir </> "cabal.sandbox.config")
+
+-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
+--   Exception is thrown if the sandbox config file is broken.
+getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file
+                -> IO FilePath
+getSandboxDbDir sconf = do
+    -- Be strict to ensure that an error can be caught.
+    !path <- extractValue . parse <$> readFile sconf
+    return path
+  where
+    key = "package-db:"
+    keyLen = length key
+
+    parse = head . filter (key `isPrefixOf`) . lines
+    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
+    -- dropWhileEnd is not provided prior to base 4.5.0.0.
+    dropWhileEnd :: (a -> Bool) -> [a] -> [a]
+    dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
+
+-- | Get a list of packages from the global, user or cabal sandbox package
+-- database.
+--
+--   If a sandbox exists this will return packages from the global package db
+--   and the sandbox, otherwise packages from the global and user package db are
+--   returned.
+getPackageDbPackages :: FilePath -- ^ Project Directory (where the
+                                 -- cabal.sandbox.config file would be if it
+                                 -- exists)
+                     -> IO [PackageBaseName]
+getPackageDbPackages cdir =
+    ghcPkgList =<< getPackageDbStack cdir
+
+getPackageDbStack :: FilePath -- ^ Project Directory (where the
+                                 -- cabal.sandbox.config file would be if it
+                                 -- exists)
+                  -> IO [GhcPkgDb]
+getPackageDbStack cdir =
+    (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
+      `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]
+
+
+-- | List packages in one or more ghc package stores
+ghcPkgList :: [GhcPkgDb] -> IO [PackageBaseName]
+ghcPkgList dbs =
+    words <$> readProcess "ghc-pkg" opts ""
+  where
+    opts =
+        ["--simple-output", "--names-only", "list"]
+          ++ ghcPkgDbStackOpts dbs
+
+-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
+ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
+                  -> [String]
+ghcPkgDbStackOpts dbs = (ghcPkgDbOpt `concatMap` dbs)
+
+-- | Get options needed to add a list of package dbs to ghc's db stack
+ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
+                  -> [String]
+ghcDbStackOpts dbs = (ghcDbOpt `concatMap` dbs)
+
+ghcPkgDbOpt :: GhcPkgDb -> [String]
+ghcPkgDbOpt GlobalDb = ["--global"]
+ghcPkgDbOpt UserDb   = ["--user"]
+ghcPkgDbOpt (PackageDb pkgDb)
+    | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]
+    | otherwise = ["--no-user-package-db",   "--package-db="   ++ pkgDb]
+
+ghcDbOpt :: GhcPkgDb -> [String]
+ghcDbOpt GlobalDb | ghcVersion < 706 = ["-global-package-conf"]
+                  | otherwise = ["-global-package-db"]
+ghcDbOpt UserDb   | ghcVersion < 706 = ["-user-package-conf"]
+                  | otherwise = ["-user-package-db"]
+ghcDbOpt (PackageDb pkgDb)
+    | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
+    | otherwise = ["-no-user-package-db",   "-package-db",   pkgDb]
+
+-- getPackageDbPackages :: FilePath -> IO [Package]
+-- getPackageDbPackages cdir = (getPkgDb >>= listDbPackages) `E.catch` handler
+--   where
+--     getPkgDb = getPackageDbDir (cdir </> configFile)
+--     handler :: SomeException -> IO [Package]
+--     handler _ = return []
+
+-- listDbPackages :: FilePath -> IO [Package]
+-- listDbPackages pkgdir = do
+--   files <- filter (".conf" `isSuffixOf`) <$> getDirectoryContents pkgdir
+--   mapM (extractPackage . (pkgdir </>)) files
+
+-- extractPackage :: FilePath -> IO Package
+-- extractPackage pconf = do
+--   contents <- lines <$> readFile pconf
+--   -- Be strict to ensure that an error can be caught.
+--   let !name = extractName $ parseName contents
+--       !pid = extractId $ parseId contents
+--   return (name, Just pid)
+--   where
+--     parseName = parse nameKey
+--     extractName = extract nameKeyLength
+--     parseId = parse idKey
+--     extractId = extract idKeyLength
+--     parse key = head . filter (key `isPrefixOf`)
+--     extract keylen = takeWhile (not . isSpace) . dropWhile isSpace . drop keylen
+
+-- nameKey :: String
+-- nameKey = "name:"
+
+-- idKey :: String
+-- idKey = "id:"
+
+-- nameKeyLength :: Int
+-- nameKeyLength = length nameKey
+
+-- idKeyLength :: Int
+-- idKeyLength = length idKey

Language/Haskell/GhcMod/Internal.hs

@@ -7,9 +7,6 @@ module Language.Haskell.GhcMod.Internal (
   , Package
   , IncludeDir
   , CompilerOptions(..)
-  -- * Cradle
-  , userPackageDbOptsForGhc
-  , userPackageDbOptsForGhcPkg
   -- * Cabal API
   , parseCabalFile
   , getCompilerOptions
@@ -38,7 +35,6 @@ module Language.Haskell.GhcMod.Internal (
 
 import Language.Haskell.GhcMod.Browse
 import Language.Haskell.GhcMod.CabalApi
-import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.ErrMsg
 import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.GHCChoice

Language/Haskell/GhcMod/PkgDoc.hs

@@ -1,8 +1,9 @@
 module Language.Haskell.GhcMod.PkgDoc (packageDoc) where
 
-import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.Cradle
+import Language.Haskell.GhcMod.GhcPkg
+
+import Control.Applicative ((<$>))
 import System.Process (readProcess)
 
 -- | Obtaining the package name and the doc path of a module.
@@ -22,6 +23,8 @@ pkgDoc cradle mdl = do
         let ret = pkg ++ " " ++ drop 14 htmlpath
         return ret
   where
-    toModuleOpts = ["find-module", mdl, "--simple-output"] ++ userPackageDbOptsForGhcPkg (cradlePackageDb cradle)
-    toDocDirOpts pkg = ["field", pkg, "haddock-html"] ++ userPackageDbOptsForGhcPkg (cradlePackageDb cradle)
+    toModuleOpts = ["find-module", mdl, "--simple-output"]
+                   ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)
+    toDocDirOpts pkg = ["field", pkg, "haddock-html"]
+                       ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)
     trim = takeWhile (`notElem` " \n")

Language/Haskell/GhcMod/Types.hs

@@ -88,14 +88,17 @@ data Cradle = Cradle {
   , cradleRootDir    :: FilePath
   -- | The file name of the found cabal file.
   , cradleCabalFile  :: Maybe FilePath
-  -- | User package db. (\"\/foo\/bar\/i386-osx-ghc-7.6.3-packages.conf.d\")
-  , cradlePackageDb  :: Maybe FilePath
-  -- | Dependent packages.
+  -- | Package database stack
+  , cradlePkgDbStack  :: [GhcPkgDb]
+  -- | Package dependencies
   , cradlePackages   :: [Package]
   } deriving (Eq, Show)
 
 ----------------------------------------------------------------
 
+-- | GHC package database flags.
+data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
+
 -- | A single GHC command line option.
 type GHCOption  = String