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

This commit is contained in:
Kazu Yamamoto 2014-04-16 11:24:39 +09:00
commit 2dc1eb645a
16 changed files with 278 additions and 192 deletions

View File

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

View File

@ -3,23 +3,18 @@
module Language.Haskell.GhcMod.Cradle ( module Language.Haskell.GhcMod.Cradle (
findCradle findCradle
, findCradleWithoutSandbox , findCradleWithoutSandbox
, getPackageDbDir
, getPackageDbPackages
, userPackageDbOptsForGhc
, userPackageDbOptsForGhcPkg
, getSandboxDir
) where ) where
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (SomeException(..))
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Exception.IOChoice ((||>)) import Control.Exception.IOChoice ((||>))
import Control.Monad (filterM) import Control.Monad (filterM)
import Data.Char (isSpace) import Data.List (isSuffixOf)
import Data.List (isPrefixOf, isSuffixOf, tails)
import Language.Haskell.GhcMod.Types
import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist) 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 :: FilePath -> IO Cradle
cabalCradle wdir = do cabalCradle wdir = do
(rdir,cfile) <- cabalDir wdir (rdir,cfile) <- cabalDir wdir
pkgDbOpts <- getPackageDb rdir pkgDbStack <- getPackageDbStack rdir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = rdir , cradleRootDir = rdir
, cradleCabalFile = Just cfile , cradleCabalFile = Just cfile
, cradlePackageDb = pkgDbOpts , cradlePkgDbStack = pkgDbStack
, cradlePackages = [] , cradlePackages = []
} }
sandboxCradle :: FilePath -> IO Cradle sandboxCradle :: FilePath -> IO Cradle
sandboxCradle wdir = do sandboxCradle wdir = do
rdir <- getSandboxDir wdir rdir <- getSandboxDir wdir
pkgDbOpts <- getPackageDb rdir pkgDbStack <- getPackageDbStack rdir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = rdir , cradleRootDir = rdir
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePackageDb = pkgDbOpts , cradlePkgDbStack = pkgDbStack
, cradlePackages = [] , cradlePackages = []
} }
@ -61,7 +56,7 @@ plainCradle wdir = return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = wdir , cradleRootDir = wdir
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePackageDb = Nothing , cradlePkgDbStack = [GlobalDb]
, cradlePackages = [] , cradlePackages = []
} }
@ -69,7 +64,7 @@ plainCradle wdir = return Cradle {
findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox :: IO Cradle
findCradleWithoutSandbox = do findCradleWithoutSandbox = do
cradle <- findCradle 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 :: FilePath -> IO FilePath
getSandboxDir dir = do getSandboxDir dir = do
exist <- doesFileExist sfile exist <- doesFileExist sfile
@ -228,5 +108,5 @@ getSandboxDir dir = do
else else
getSandboxDir dir' getSandboxDir dir'
where where
sfile = dir </> configFile sfile = dir </> "cabal.sandbox.config"
dir' = takeDirectory dir dir' = takeDirectory dir

View File

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

View File

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

View File

@ -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

View File

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

View File

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

View File

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

View File

@ -26,7 +26,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
Extra-Source-Files: ChangeLog Extra-Source-Files: ChangeLog
test/data/*.cabal test/data/*.cabal
test/data/*.hs 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/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/dummy
test/data/broken-cabal/*.cabal test/data/broken-cabal/*.cabal
test/data/broken-sandbox/*.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/src/Check/Test/*.hs
test/data/check-test-subdir/test/*.hs test/data/check-test-subdir/test/*.hs
test/data/check-test-subdir/test/Bar/*.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/*.cabal
test/data/ghc-mod-check/*.hs test/data/ghc-mod-check/*.hs
test/data/ghc-mod-check/Data/*.hs test/data/ghc-mod-check/Data/*.hs
@ -54,6 +56,7 @@ Library
Language.Haskell.GhcMod.ErrMsg Language.Haskell.GhcMod.ErrMsg
Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.Flag
Language.Haskell.GhcMod.GHCApi Language.Haskell.GhcMod.GHCApi
Language.Haskell.GhcMod.GhcPkg
Language.Haskell.GhcMod.GHCChoice Language.Haskell.GhcMod.GHCChoice
Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.Gap
Language.Haskell.GhcMod.Info Language.Haskell.GhcMod.Info
@ -117,10 +120,11 @@ Test-Suite doctest
Test-Suite spec Test-Suite spec
Default-Language: Haskell2010 Default-Language: Haskell2010
Main-Is: Spec.hs Main-Is: Main.hs
Hs-Source-Dirs: test, . Hs-Source-Dirs: test, .
Type: exitcode-stdio-1.0 Type: exitcode-stdio-1.0
Other-Modules: Dir Other-Modules: Dir
Spec
BrowseSpec BrowseSpec
CabalApiSpec CabalApiSpec
CheckSpec CheckSpec
@ -129,6 +133,7 @@ Test-Suite spec
LangSpec LangSpec
LintSpec LintSpec
ListSpec ListSpec
GhcPkgSpec
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, containers , containers
, directory , directory

View File

@ -9,9 +9,17 @@ import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Test.Hspec import Test.Hspec
import System.Directory
import System.FilePath
import Dir import Dir
import Config (cProjectVersionInt) -- ghc version
ghcVersion :: Int
ghcVersion = read cProjectVersionInt
spec :: Spec spec :: Spec
spec = do spec = do
describe "parseCabalFile" $ do describe "parseCabalFile" $ do
@ -20,6 +28,7 @@ spec = do
describe "getCompilerOptions" $ do describe "getCompilerOptions" $ do
it "gets necessary CompilerOptions" $ do it "gets necessary CompilerOptions" $ do
cwd <- getCurrentDirectory
withDirectory "test/data/subdir1/subdir2" $ \dir -> do withDirectory "test/data/subdir1/subdir2" $ \dir -> do
cradle <- findCradle cradle <- findCradle
pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle
@ -28,7 +37,10 @@ spec = do
ghcOptions = ghcOptions res ghcOptions = ghcOptions res
, includeDirs = map (toRelativeDir dir) (includeDirs 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)]} 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 describe "cabalDependPackages" $ do
it "extracts dependent packages" $ do it "extracts dependent packages" $ do

View File

@ -4,7 +4,7 @@ import Control.Applicative
import Data.List (isSuffixOf) import Data.List (isSuffixOf)
import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import System.Directory (canonicalizePath) import System.Directory (canonicalizePath,getCurrentDirectory)
import System.FilePath ((</>), pathSeparator) import System.FilePath ((</>), pathSeparator)
import Test.Hspec import Test.Hspec
@ -21,17 +21,18 @@ spec = do
cradleCurrentDir = curDir cradleCurrentDir = curDir
, cradleRootDir = curDir , cradleRootDir = curDir
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePackageDb = Nothing , cradlePkgDbStack = [GlobalDb]
, cradlePackages = [] , cradlePackages = []
} }
it "finds a cabal file and a sandbox" $ do it "finds a cabal file and a sandbox" $ do
cwd <- getCurrentDirectory
withDirectory "test/data/subdir1/subdir2" $ \dir -> do withDirectory "test/data/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> findCradle res <- relativeCradle dir <$> findCradle
res `shouldBe` Cradle { res `shouldBe` Cradle {
cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2" cradleCurrentDir = "test" </> "data" </> "subdir1" </> "subdir2"
, cradleRootDir = "test" </> "data" , cradleRootDir = "test" </> "data"
, cradleCabalFile = Just ("test" </> "data" </> "cabalapi.cabal") , 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 = [] , cradlePackages = []
} }
it "works even if a sandbox config file is broken" $ do it "works even if a sandbox config file is broken" $ do
@ -41,23 +42,10 @@ spec = do
cradleCurrentDir = "test" </> "data" </> "broken-sandbox" cradleCurrentDir = "test" </> "data" </> "broken-sandbox"
, cradleRootDir = "test" </> "data" </> "broken-sandbox" , cradleRootDir = "test" </> "data" </> "broken-sandbox"
, cradleCabalFile = Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal") , cradleCabalFile = Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
, cradlePackageDb = Nothing , cradlePkgDbStack = [GlobalDb, UserDb]
, cradlePackages = [] , 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 :: FilePath -> Cradle -> Cradle
relativeCradle dir cradle = cradle { relativeCradle dir cradle = cradle {
cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle

27
test/GhcPkgSpec.hs Normal file
View File

@ -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)

12
test/Main.hs Normal file
View File

@ -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

View File

@ -1 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-} {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}

View File

@ -4,15 +4,15 @@
-- if you want to change the default settings for this sandbox. -- if you want to change the default settings for this sandbox.
local-repo: /home/me/work/ghc-mod/test/data/.cabal-sandbox/packages local-repo: @CWD@/test/data/.cabal-sandbox/packages
logs-dir: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs logs-dir: @CWD@/test/data/.cabal-sandbox/logs
world-file: /home/me/work/ghc-mod/test/data/.cabal-sandbox/world world-file: @CWD@/test/data/.cabal-sandbox/world
user-install: False user-install: False
package-db: /home/me/work/ghc-mod/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d package-db: @CWD@/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 build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log
install-dirs install-dirs
prefix: /home/me/work/ghc-mod/test/data/.cabal-sandbox prefix: @CWD@/test/data/.cabal-sandbox
bindir: $prefix/bin bindir: $prefix/bin
libdir: $prefix/lib libdir: $prefix/lib
libsubdir: $arch-$os-$compiler/$pkgid libsubdir: $arch-$os-$compiler/$pkgid

View File

@ -4,15 +4,15 @@
-- if you want to change the default settings for this sandbox. -- if you want to change the default settings for this sandbox.
local-repo: /home/me/work/ghc-mod/test/data/.cabal-sandbox/packages local-repo: @CWD@/test/data/.cabal-sandbox/packages
logs-dir: /home/me/work/ghc-mod/test/data/.cabal-sandbox/logs logs-dir: @CWD@/test/data/.cabal-sandbox/logs
world-file: /home/me/work/ghc-mod/test/data/.cabal-sandbox/world world-file: @CWD@/test/data/.cabal-sandbox/world
user-install: False user-install: False
package-db: test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d 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 install-dirs
prefix: /home/me/work/ghc-mod/test/data/.cabal-sandbox prefix: @CWD@/test/data/.cabal-sandbox
bindir: $prefix/bin bindir: $prefix/bin
libdir: $prefix/lib libdir: $prefix/lib
libsubdir: $arch-$os-$compiler/$pkgid libsubdir: $arch-$os-$compiler/$pkgid