From 955b1b4091e7ccbfd68765d6c36525eb0002f913 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 28 Mar 2014 12:05:11 +0900 Subject: [PATCH] user package db options for both GHC and ghc-pkg. --- Language/Haskell/GhcMod/CabalApi.hs | 3 +- Language/Haskell/GhcMod/Cradle.hs | 67 ++++++++++++++++++----------- Language/Haskell/GhcMod/Internal.hs | 4 ++ Language/Haskell/GhcMod/PkgDoc.hs | 7 +-- Language/Haskell/GhcMod/Types.hs | 4 +- test/CradleSpec.hs | 30 ++++++------- 6 files changed, 69 insertions(+), 46 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 0abb66b..a0da4f4 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -31,6 +31,7 @@ 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, ()) @@ -113,7 +114,7 @@ getGHCOptions ghcopts cradle cdir binfo = do let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps where - pkgDb = cradlePackageDbOpts cradle + pkgDb = userPackageDbOptsForGhc $ cradlePackageDb 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 2dcd756..ed89fc3 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -5,6 +5,8 @@ module Language.Haskell.GhcMod.Cradle ( , findCradleWithoutSandbox , getPackageDbDir , getPackageDbPackages + , userPackageDbOptsForGhc + , userPackageDbOptsForGhcPkg ) where import Control.Applicative ((<$>)) @@ -30,30 +32,30 @@ findCradle = do where handler :: FilePath -> SomeException -> IO Cradle handler wdir _ = return Cradle { - cradleCurrentDir = wdir - , cradleCabalDir = Nothing - , cradleCabalFile = Nothing - , cradlePackageDbOpts = [] - , cradlePackages = [] + cradleCurrentDir = wdir + , cradleCabalDir = Nothing + , cradleCabalFile = Nothing + , cradlePackageDb = Nothing + , cradlePackages = [] } findCradle' :: FilePath -> IO Cradle findCradle' wdir = do (cdir,cfile) <- cabalDir wdir - pkgDbOpts <- getPackageDbOpts cdir + pkgDbOpts <- getPackageDb cdir return Cradle { - cradleCurrentDir = wdir - , cradleCabalDir = Just cdir - , cradleCabalFile = Just cfile - , cradlePackageDbOpts = pkgDbOpts - , cradlePackages = [] + cradleCurrentDir = wdir + , cradleCabalDir = Just cdir + , cradleCabalFile = Just cfile + , cradlePackageDb = pkgDbOpts + , cradlePackages = [] } -- Just for testing findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox = do cradle <- findCradle - return cradle { cradlePackageDbOpts = [], cradlePackages = [] } + return cradle { cradlePackageDb = Nothing, cradlePackages = [] } ---------------------------------------------------------------- @@ -97,12 +99,12 @@ pkgDbKeyLen :: Int pkgDbKeyLen = length pkgDbKey -- | Obtaining GHC options relating to a package db directory -getPackageDbOpts :: FilePath -> IO [GHCOption] -getPackageDbOpts cdir = (sandboxArguments <$> getPkgDb) `E.catch` handler +getPackageDb :: FilePath -> IO (Maybe FilePath) +getPackageDb cdir = (Just <$> getPkgDb) `E.catch` handler where getPkgDb = getPackageDbDir (cdir configFile) - handler :: SomeException -> IO [GHCOption] - handler _ = return [] + 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. @@ -118,20 +120,35 @@ getPackageDbDir sconf = do dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] --- | Adding necessary GHC options to the package db. --- Exception is thrown if the string argument is incorrect. +-- | Creating user package db options for GHC. -- --- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" +-- >>> 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"] --- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-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"] -sandboxArguments :: FilePath -> [String] -sandboxArguments pkgDb = [noUserPkgDbOpt, pkgDbOpt, pkgDb] +userPackageDbOptsForGhc :: Maybe FilePath -> [String] +userPackageDbOptsForGhc Nothing = [] +userPackageDbOptsForGhc (Just pkgDb) = [noUserPkgDbOpt, pkgDbOpt, pkgDb] where ver = extractGhcVer pkgDb - (pkgDbOpt,noUserPkgDbOpt) - | ver < 706 = ("-package-conf","-no-user-package-conf") - | otherwise = ("-package-db", "-no-user-package-db") + (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. diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index f1d674e..6fe88db 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -7,6 +7,9 @@ module Language.Haskell.GhcMod.Internal ( , Package , IncludeDir , CompilerOptions(..) + -- * Cradle + , userPackageDbOptsForGhc + , userPackageDbOptsForGhcPkg -- * Cabal API , parseCabalFile , getCompilerOptions @@ -35,6 +38,7 @@ 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 eb58a1c..114b11c 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.PkgDoc (packageDoc) where import Control.Applicative ((<$>)) import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Cradle import System.Process (readProcess) -- | Obtaining the package name and the doc path of a module. @@ -17,10 +18,10 @@ pkgDoc cradle mdl = do if pkg == "" then return "\n" else do - htmlpath <- readProcess "ghc-pkg" ["field", pkg, "haddock-html"] [] + htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) [] let ret = pkg ++ " " ++ drop 14 htmlpath return ret where - toModuleOpts = ["find-module", "--simple-output"] ++ cradlePackageDbOpts cradle ++ [mdl] + toModuleOpts = ["find-module", mdl, "--simple-output"] ++ userPackageDbOptsForGhcPkg (cradlePackageDb cradle) + toDocDirOpts pkg = ["field", pkg, "haddock-html"] ++ userPackageDbOptsForGhcPkg (cradlePackageDb cradle) trim = takeWhile (/= '\n') - diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 0aedaf6..001ef5a 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -88,8 +88,8 @@ data Cradle = Cradle { , cradleCabalDir :: Maybe FilePath -- | The file name of the found cabal file. , cradleCabalFile :: Maybe FilePath - -- | The package db options. ([\"-no-user-package-db\",\"-package-db\",\"\/foo\/bar\/i386-osx-ghc-7.6.3-packages.conf.d\"]) - , cradlePackageDbOpts :: [GHCOption] + -- | User package db. (\"\/foo\/bar\/i386-osx-ghc-7.6.3-packages.conf.d\") + , cradlePackageDb :: Maybe FilePath -- | Dependent packages. , cradlePackages :: [Package] } deriving (Eq, Show) diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 87c47ad..13cf55f 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -18,31 +18,31 @@ spec = do curDir <- stripLastDot <$> canonicalizePath "/" res <- findCradle res `shouldBe` Cradle { - cradleCurrentDir = curDir - , cradleCabalDir = Nothing - , cradleCabalFile = Nothing - , cradlePackageDbOpts = [] - , cradlePackages = [] + cradleCurrentDir = curDir + , cradleCabalDir = Nothing + , cradleCabalFile = Nothing + , cradlePackageDb = Nothing + , cradlePackages = [] } it "finds a cabal file and a sandbox" $ do withDirectory "test/data/subdir1/subdir2" $ \dir -> do res <- relativeCradle dir <$> findCradle res `shouldBe` Cradle { - cradleCurrentDir = "test" "data" "subdir1" "subdir2" - , cradleCabalDir = Just ("test" "data") - , cradleCabalFile = Just ("test" "data" "cabalapi.cabal") - , cradlePackageDbOpts = ["-no-user-package-db", "-package-db", "test" "data" ".cabal-sandbox" "/home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] - , cradlePackages = [] + cradleCurrentDir = "test" "data" "subdir1" "subdir2" + , cradleCabalDir = Just ("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") + , cradlePackages = [] } it "works even if a sandbox config file is broken" $ do withDirectory "test/data/broken-sandbox" $ \dir -> do res <- relativeCradle dir <$> findCradle res `shouldBe` Cradle { - cradleCurrentDir = "test" "data" "broken-sandbox" - , cradleCabalDir = Just ("test" "data" "broken-sandbox") - , cradleCabalFile = Just ("test" "data" "broken-sandbox" "dummy.cabal") - , cradlePackageDbOpts = [] - , cradlePackages = [] + cradleCurrentDir = "test" "data" "broken-sandbox" + , cradleCabalDir = Just ("test" "data" "broken-sandbox") + , cradleCabalFile = Just ("test" "data" "broken-sandbox" "dummy.cabal") + , cradlePackageDb = Nothing + , cradlePackages = [] } describe "getPackageDbDir" $ do