From 30b8366526b0d314ff8d3f9a015eeb07c83af619 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 15 Apr 2014 05:13:10 +0200 Subject: [PATCH 1/4] Refactor the way packages databases are handled - cradle now stores a list of active package databases instead of only the user store (if present). - rename `cradlePackageDb` -> `cradlePkgDbStack` as that`s what the ghc documentaion calls this kind of thing - `getPackageDbPackages` now returns names of all visible packages in the given directory. Also the implementation now uses `ghc-pkg` instead of manually looking at the package database --- Language/Haskell/GhcMod/CabalApi.hs | 7 +- Language/Haskell/GhcMod/Cradle.hs | 144 ++------------- Language/Haskell/GhcMod/Debug.hs | 4 +- Language/Haskell/GhcMod/GHCApi.hs | 15 +- Language/Haskell/GhcMod/GhcPkg.hs | 165 ++++++++++++++++++ Language/Haskell/GhcMod/Internal.hs | 4 - Language/Haskell/GhcMod/PkgDoc.hs | 11 +- Language/Haskell/GhcMod/Types.hs | 9 +- ghc-mod.cabal | 5 +- test/CabalApiSpec.hs | 5 +- test/CradleSpec.hs | 22 +-- test/GhcPkgSpec.hs | 27 +++ test/Main.hs | 12 ++ test/Spec.hs | 2 +- ...sandbox.config => cabal.sandbox.config.in} | 14 +- ...sandbox.config => cabal.sandbox.config.in} | 12 +- 16 files changed, 271 insertions(+), 187 deletions(-) create mode 100644 Language/Haskell/GhcMod/GhcPkg.hs create mode 100644 test/GhcPkgSpec.hs create mode 100644 test/Main.hs rename test/data/{cabal.sandbox.config => cabal.sandbox.config.in} (55%) rename test/data/check-packageid/{cabal.sandbox.config => cabal.sandbox.config.in} (65%) diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 766c9af..ff478ea 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/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,8 +33,6 @@ 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, ()) @@ -114,7 +115,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 diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index e51a1b5..bb88b9b 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 34bb233..d3b5fe6 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index a0e73bb..7d54c96 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs new file mode 100644 index 0000000..bcdb523 --- /dev/null +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -0,0 +1,165 @@ +{-# 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) + +-- | 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) = + [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) + +ghcDbOpt :: GhcPkgDb -> [String] +ghcDbOpt GlobalDb = ["-global-package-db"] +ghcDbOpt UserDb = ["-user-package-db"] +ghcDbOpt (PackageDb 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") + +-- | 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 + + +-- 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 diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 6fe88db..f1d674e 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index 6c11a48..f8dd9d4 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/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") diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 10f2a92..6207bb3 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index be8c222..9985f6e 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -54,6 +54,7 @@ Library Language.Haskell.GhcMod.ErrMsg Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.GHCApi + Language.Haskell.GhcMod.GhcPkg Language.Haskell.GhcMod.GHCChoice Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.Info @@ -117,10 +118,11 @@ Test-Suite doctest Test-Suite spec Default-Language: Haskell2010 - Main-Is: Spec.hs + Main-Is: Main.hs Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 Other-Modules: Dir + Spec BrowseSpec CabalApiSpec CheckSpec @@ -129,6 +131,7 @@ Test-Suite spec LangSpec LintSpec ListSpec + GhcPkgSpec Build-Depends: base >= 4.0 && < 5 , containers , directory diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index a2128d6..27e57cf 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -9,6 +9,8 @@ import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types import Test.Hspec +import System.Directory +import System.FilePath import Dir @@ -20,6 +22,7 @@ spec = do describe "getCompilerOptions" $ do it "gets necessary CompilerOptions" $ do + cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do cradle <- findCradle pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle @@ -28,7 +31,7 @@ spec = do ghcOptions = ghcOptions res , includeDirs = map (toRelativeDir dir) (includeDirs res) } - res' `shouldBe` CompilerOptions {ghcOptions = ["-no-user-package-db","-package-db","/home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]} + res' `shouldBe` CompilerOptions {ghcOptions = ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]} describe "cabalDependPackages" $ do it "extracts dependent packages" $ do diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index a7cc247..bdf07d2 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -4,7 +4,7 @@ import Control.Applicative import Data.List (isSuffixOf) import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types -import System.Directory (canonicalizePath) +import System.Directory (canonicalizePath,getCurrentDirectory) import System.FilePath ((), pathSeparator) import Test.Hspec @@ -21,17 +21,18 @@ spec = do cradleCurrentDir = curDir , cradleRootDir = curDir , cradleCabalFile = Nothing - , cradlePackageDb = Nothing + , cradlePkgDbStack = [GlobalDb] , cradlePackages = [] } it "finds a cabal file and a sandbox" $ do + cwd <- getCurrentDirectory withDirectory "test/data/subdir1/subdir2" $ \dir -> do res <- relativeCradle dir <$> findCradle res `shouldBe` Cradle { cradleCurrentDir = "test" "data" "subdir1" "subdir2" , cradleRootDir = "test" "data" , cradleCabalFile = Just ("test" "data" "cabalapi.cabal") - , cradlePackageDb = Just ("test" "data" ".cabal-sandbox" "/home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") + , cradlePkgDbStack = [GlobalDb, PackageDb (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")] , cradlePackages = [] } it "works even if a sandbox config file is broken" $ do @@ -41,23 +42,10 @@ spec = do cradleCurrentDir = "test" "data" "broken-sandbox" , cradleRootDir = "test" "data" "broken-sandbox" , cradleCabalFile = Just ("test" "data" "broken-sandbox" "dummy.cabal") - , cradlePackageDb = Nothing + , cradlePkgDbStack = [GlobalDb, UserDb] , cradlePackages = [] } - describe "getPackageDbDir" $ do - it "parses a config file and extracts package db" $ do - pkgDb <- getPackageDbDir "test/data/cabal.sandbox.config" - pkgDb `shouldBe` "/home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" - - it "throws an error if a config file is broken" $ do - getPackageDbDir "test/data/bad.config" `shouldThrow` anyException - - describe "getPackageDbPackages" $ do - it "find a config file and extracts packages with their ids" $ do - pkgs <- getPackageDbPackages "test/data/check-packageid" - pkgs `shouldBe` [("template-haskell", Just "template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c")] - relativeCradle :: FilePath -> Cradle -> Cradle relativeCradle dir cradle = cradle { cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs new file mode 100644 index 0000000..c2cfff4 --- /dev/null +++ b/test/GhcPkgSpec.hs @@ -0,0 +1,27 @@ +module GhcPkgSpec where + +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.GhcPkg + +import Control.Applicative +import System.Directory +import System.FilePath (()) +import Test.Hspec + +import Dir + +spec :: Spec +spec = do + describe "getSandboxDb" $ do + it "parses a config file and extracts sandbox package db" $ do + cwd <- getCurrentDirectory + pkgDb <- getSandboxDb "test/data/" + pkgDb `shouldBe` (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") + + it "throws an error if a config file is broken" $ do + getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException + + describe "getPackageDbPackages" $ do + it "find a config file and extracts packages" $ do + pkgs <- getPackageDbPackages "test/data/check-packageid" + pkgs `shouldSatisfy` (\x -> length x >= 1) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..859ffd9 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,12 @@ +import Spec +import Dir + +import Test.Hspec +import System.Process + +main = do + let sandboxes = [ "test/data", "test/data/check-packageid" ] + genSandboxCfg dir = withDirectory dir $ \cwd -> do + system ("sed 's|@CWD@|" ++ cwd ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config") + genSandboxCfg `mapM` sandboxes + hspec spec diff --git a/test/Spec.hs b/test/Spec.hs index a824f8c..b4e92e7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/test/data/cabal.sandbox.config b/test/data/cabal.sandbox.config.in similarity index 55% rename from test/data/cabal.sandbox.config rename to test/data/cabal.sandbox.config.in index 9697fff..5057c11 100644 --- a/test/data/cabal.sandbox.config +++ b/test/data/cabal.sandbox.config.in @@ -4,15 +4,15 @@ -- if you want to change the default settings for this sandbox. -local-repo: /home/me/work/ghc-mod/test/data/.cabal-sandbox/packages -logs-dir: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs -world-file: /home/me/work/ghc-mod/test/data/.cabal-sandbox/world +local-repo: @CWD@/test/data/.cabal-sandbox/packages +logs-dir: @CWD@/test/data/.cabal-sandbox/logs +world-file: @CWD@/test/data/.cabal-sandbox/world user-install: False -package-db: /home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs/build.log +package-db: @CWD@/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d +build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log -install-dirs - prefix: /home/me/work/ghc-mod/test/data/.cabal-sandbox +install-dirs + prefix: @CWD@/test/data/.cabal-sandbox bindir: $prefix/bin libdir: $prefix/lib libsubdir: $arch-$os-$compiler/$pkgid diff --git a/test/data/check-packageid/cabal.sandbox.config b/test/data/check-packageid/cabal.sandbox.config.in similarity index 65% rename from test/data/check-packageid/cabal.sandbox.config rename to test/data/check-packageid/cabal.sandbox.config.in index 4de501a..76ad788 100644 --- a/test/data/check-packageid/cabal.sandbox.config +++ b/test/data/check-packageid/cabal.sandbox.config.in @@ -4,15 +4,15 @@ -- if you want to change the default settings for this sandbox. -local-repo: /home/me/work/ghc-mod/test/data/.cabal-sandbox/packages -logs-dir: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs -world-file: /home/me/work/ghc-mod/test/data/.cabal-sandbox/world +local-repo: @CWD@/test/data/.cabal-sandbox/packages +logs-dir: @CWD@/test/data/.cabal-sandbox/logs +world-file: @CWD@/test/data/.cabal-sandbox/world user-install: False package-db: test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs/build.log +build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log -install-dirs - prefix: /home/me/work/ghc-mod/test/data/.cabal-sandbox +install-dirs + prefix: @CWD@/test/data/.cabal-sandbox bindir: $prefix/bin libdir: $prefix/lib libsubdir: $arch-$os-$compiler/$pkgid From 7d75787ae39a929db1a2a78a25f92096e81355d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 15 Apr 2014 05:18:42 +0200 Subject: [PATCH 2/4] Only add available package to ghc options Fixes #185 --- Language/Haskell/GhcMod/CabalApi.hs | 16 ++++++++++++---- test/CabalApiSpec.hs | 1 + 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index ff478ea..7b34123 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -39,10 +39,14 @@ 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 @@ -50,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 @@ -212,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 - diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 27e57cf..4020db8 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -33,6 +33,7 @@ spec = do } res' `shouldBe` CompilerOptions {ghcOptions = ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]} + describe "cabalDependPackages" $ do it "extracts dependent packages" $ do pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" From be4172b4540e437e50821c971022b2b84ebebacc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 15 Apr 2014 05:51:07 +0200 Subject: [PATCH 3/4] Add cabal.sandbox.config.in to Extra-Source-Files --- ghc-mod.cabal | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 9985f6e..860ddf3 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -26,7 +26,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el Extra-Source-Files: ChangeLog test/data/*.cabal test/data/*.hs - test/data/cabal.sandbox.config + test/data/cabal.sandbox.config.in test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/dummy test/data/broken-cabal/*.cabal test/data/broken-sandbox/*.cabal @@ -35,6 +35,8 @@ Extra-Source-Files: ChangeLog test/data/check-test-subdir/src/Check/Test/*.hs test/data/check-test-subdir/test/*.hs test/data/check-test-subdir/test/Bar/*.hs + test/data/check-packageid/cabal.sandbox.config.in + test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf test/data/ghc-mod-check/*.cabal test/data/ghc-mod-check/*.hs test/data/ghc-mod-check/Data/*.hs From bb438feb83f435833518f884e502ac4bc9b531c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 15 Apr 2014 17:14:10 +0200 Subject: [PATCH 4/4] User ghc's cProjectVersionInt to get version information --- Language/Haskell/GhcMod/GhcPkg.hs | 47 ++++++++++--------------------- test/CabalApiSpec.hs | 10 ++++++- 2 files changed, 24 insertions(+), 33 deletions(-) diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index bcdb523..d408779 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -21,6 +21,11 @@ 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) @@ -87,43 +92,21 @@ ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack -> [String] ghcDbStackOpts dbs = (ghcDbOpt `concatMap` dbs) - ghcPkgDbOpt :: GhcPkgDb -> [String] ghcPkgDbOpt GlobalDb = ["--global"] ghcPkgDbOpt UserDb = ["--user"] -ghcPkgDbOpt (PackageDb 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) +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 = ["-global-package-db"] -ghcDbOpt UserDb = ["-user-package-db"] -ghcDbOpt (PackageDb 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") - --- | 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 - +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 diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 4020db8..7701fe7 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -14,6 +14,12 @@ import System.FilePath import Dir +import Config (cProjectVersionInt) -- ghc version + +ghcVersion :: Int +ghcVersion = read cProjectVersionInt + + spec :: Spec spec = do describe "parseCabalFile" $ do @@ -31,7 +37,9 @@ spec = do ghcOptions = ghcOptions res , includeDirs = map (toRelativeDir dir) (includeDirs res) } - res' `shouldBe` CompilerOptions {ghcOptions = ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]} + if ghcVersion < 706 + then res' `shouldBe` CompilerOptions {ghcOptions = ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]} + else res' `shouldBe` CompilerOptions {ghcOptions = ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"], includeDirs = ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"], depPackages = [("Cabal", Nothing), ("base", Nothing) , ("template-haskell", Nothing)]} describe "cabalDependPackages" $ do