diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2013-09-16 v3.1.0 + * API breaks backward compatibility. + * Supporting sandbox sharing. + 2013-09-16 v3.0.2 * Fixing a bug of "dist/build/autogen/cabal_macros.h". diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -4,9 +4,6 @@ -- * Cradle Cradle(..) , findCradle - -- * GHC version - , GHCVersion - , getGHCVersion -- * Options , Options(..) , LineSeparator(..) @@ -48,4 +45,3 @@ import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.List import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.CabalApi diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -1,19 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} module Language.Haskell.GhcMod.CabalApi ( - fromCabalFile + getCompilerOptions , parseCabalFile , cabalAllBuildInfo , cabalDependPackages , cabalSourceDirs - , getGHCVersion + , cabalAllTargets ) where import Control.Applicative ((<$>)) import Control.Exception (throwIO) -import Data.List (intercalate) import Data.Maybe (maybeToList) import Data.Set (fromList, toList) +import Distribution.ModuleName (toFilePath) import Distribution.Package (Dependency(Dependency) , PackageName(PackageName) , PackageIdentifier(pkgName)) @@ -26,34 +26,23 @@ import Distribution.System (buildPlatform) import Distribution.Text (display) import Distribution.Verbosity (silent) -import Distribution.Version (versionBranch, Version) +import Distribution.Version (Version) import Language.Haskell.GhcMod.Types import System.Directory (doesFileExist) import System.FilePath ---------------------------------------------------------------- --- | Parsing a cabal file in 'Cradle' and returns --- options for GHC, include directories for modules and --- package names of dependency. -fromCabalFile :: [GHCOption] - -> Cradle - -> IO ([GHCOption],[IncludeDir],[Package]) -fromCabalFile ghcOptions cradle = - parseCabalFile cfile >>= cookInfo ghcOptions cradle - where - Just cfile = cradleCabalFile cradle - -cookInfo :: [GHCOption] -> Cradle -> PackageDescription - -> IO ([GHCOption],[IncludeDir],[Package]) -cookInfo ghcOptions cradle cabal = do - gopts <- getGHCOptions ghcOptions cdir $ head buildInfos - return (gopts,idirs,depPkgs) +-- | Getting necessary 'CompilerOptions' from three information sources. +getCompilerOptions :: [GHCOption] -> Cradle -> PackageDescription -> IO CompilerOptions +getCompilerOptions ghcopts cradle pkgDesc = do + gopts <- getGHCOptions ghcopts cradle cdir $ head buildInfos + return $ CompilerOptions gopts idirs depPkgs where wdir = cradleCurrentDir cradle Just cdir = cradleCabalDir cradle Just cfile = cradleCabalFile cradle - buildInfos = cabalAllBuildInfo cabal + buildInfos = cabalAllBuildInfo pkgDesc idirs = includeDirectories cdir wdir $ cabalSourceDirs buildInfos depPkgs = removeThem problematicPackages $ removeMe cfile $ cabalDependPackages buildInfos @@ -77,12 +66,14 @@ -- Include directories for modules cabalBuildDirs :: [FilePath] -cabalBuildDirs = ["dist/build"] +cabalBuildDirs = ["dist/build", "dist/build/autogen"] includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath] includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir]) where - extdirs = map (cdir ) $ dirs ++ cabalBuildDirs + extdirs = map expand $ dirs ++ cabalBuildDirs + expand "." = cdir + expand subdir = cdir subdir ---------------------------------------------------------------- @@ -105,12 +96,13 @@ ---------------------------------------------------------------- -getGHCOptions :: [GHCOption] -> FilePath -> BuildInfo -> IO [GHCOption] -getGHCOptions ghcOptions cdir binfo = do +getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption] +getGHCOptions ghcopts cradle cdir binfo = do cabalCpp <- cabalCppOptions cdir let cpps = map ("-optP" ++) $ cppOptions binfo ++ cabalCpp - return $ ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps + return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps where + pkgDb = cradlePackageDbOpts cradle lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo libDirs = map ("-L" ++) $ extraLibDirs binfo exts = map (("-X" ++) . display) $ usedExtensions binfo @@ -159,18 +151,6 @@ ---------------------------------------------------------------- --- | Getting GHC version. 7.6.3 becames 706 in the second of the result. -getGHCVersion :: IO (GHCVersion, Int) -getGHCVersion = toTupple <$> getGHC - where - toTupple v - | length vs < 2 = (verstr, 0) - | otherwise = (verstr, ver) - where - vs = versionBranch v - ver = (vs !! 0) * 100 + (vs !! 1) - verstr = intercalate "." . map show $ vs - getGHCId :: IO CompilerId getGHCId = CompilerId GHC <$> getGHC @@ -180,3 +160,19 @@ case mv of Nothing -> throwIO $ userError "ghc not found" Just v -> return $ v + +---------------------------------------------------------------- + +-- | Extracting all 'Module' 'FilePath's for libraries, executables, +-- tests and benchmarks. +cabalAllTargets :: PackageDescription -> ([FilePath],[FilePath],[FilePath],[FilePath]) +cabalAllTargets pd = targets + where + lib = case library pd of + Nothing -> [] + Just l -> libModules l + + targets = (map toFilePath $ lib, + map modulePath $ executables pd, + map toFilePath $ concatMap testModules $ testSuites pd, + map toFilePath $ concatMap benchmarkModules $ benchmarks pd) diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -37,7 +37,7 @@ check opt cradle fileNames = checkIt `gcatch` handleErrMsg ls where checkIt = do - readLog <- initializeFlagsWithCradle opt cradle options True + (readLog,_) <- initializeFlagsWithCradle opt cradle options True setTargetFiles fileNames checkSlowAndSet void $ load LoadAllTargets diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -1,66 +1,44 @@ module Language.Haskell.GhcMod.Cradle (findCradle) where +import Data.Char (isSpace) import Control.Applicative ((<$>)) -import Control.Exception (throwIO) -import Control.Monad (unless, filterM) -import Data.List (isSuffixOf) -import Distribution.System (buildPlatform) -import qualified Distribution.Text as Text (display) +import Control.Exception as E (catch, throwIO, SomeException) +import Control.Monad (filterM) +import Data.List (isPrefixOf, isSuffixOf, tails) import Language.Haskell.GhcMod.Types -import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, doesDirectoryExist) -import System.FilePath ((),takeDirectory) +import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist) +import System.FilePath ((), takeDirectory, takeFileName) ---------------------------------------------------------------- -- | Finding 'Cradle'. --- An error would be thrown. -findCradle :: Maybe FilePath -- ^ A 'FilePath' for a sandbox. - -> GHCVersion - -> IO Cradle -findCradle (Just sbox) strver = do - (pkgConf,exist) <- checkPackageConf sbox strver - unless exist $ throwIO $ userError $ pkgConf ++ " not found" - wdir <- getCurrentDirectory - cfiles <- cabalDir wdir - return $ case cfiles of - Nothing -> Cradle { - cradleCurrentDir = wdir - , cradleCabalDir = Nothing - , cradleCabalFile = Nothing - , cradlePackageConf = Just pkgConf - } - Just (cdir,cfile,_) -> Cradle { - cradleCurrentDir = wdir - , cradleCabalDir = Just cdir - , cradleCabalFile = Just cfile - , cradlePackageConf = Just pkgConf - } -findCradle Nothing strver = do +-- Find a cabal file by tracing ancestor directories. +-- Find a sandbox according to a cabal sandbox config +-- in a cabal directory. +findCradle :: IO Cradle +findCradle = do wdir <- getCurrentDirectory - cfiles <- cabalDir wdir - case cfiles of - Nothing -> return Cradle { - cradleCurrentDir = wdir - , cradleCabalDir = Nothing - , cradleCabalFile = Nothing - , cradlePackageConf = Nothing - } - Just (cdir,cfile,Nothing) -> do - return Cradle { - cradleCurrentDir = wdir - , cradleCabalDir = Just cdir - , cradleCabalFile = Just cfile - , cradlePackageConf = Nothing - } - Just (cdir,cfile,Just sbox) -> do - (pkgConf,exist) <- checkPackageConf sbox strver - return Cradle { - cradleCurrentDir = wdir - , cradleCabalDir = Just cdir - , cradleCabalFile = Just cfile - , cradlePackageConf = if exist then Just pkgConf else Nothing - } + findCradle' wdir `E.catch` handler wdir + where + handler :: FilePath -> SomeException -> IO Cradle + handler wdir _ = return Cradle { + cradleCurrentDir = wdir + , cradleCabalDir = Nothing + , cradleCabalFile = Nothing + , cradlePackageDbOpts = [] + } +findCradle' :: FilePath -> IO Cradle +findCradle' wdir = do + (cdir,cfile) <- cabalDir wdir + pkgDbOpts <- getPackageDbOpts cdir + return Cradle { + cradleCurrentDir = wdir + , cradleCabalDir = Just cdir + , cradleCabalFile = Just cfile + , cradlePackageDbOpts = pkgDbOpts + } + ---------------------------------------------------------------- cabalSuffix :: String @@ -72,52 +50,71 @@ -- Finding a Cabal file up to the root directory -- Input: a directly to investigate -- Output: (the path to the directory containing a Cabal file --- ,the path to the Cabal file --- ,Just the path to the sandbox directory) -cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath,Maybe FilePath)) +-- ,the path to the Cabal file) +cabalDir :: FilePath -> IO (FilePath,FilePath) cabalDir dir = do - cnts <- (filter isCabal <$> getDirectoryContents dir) - >>= filterM (\file -> doesFileExist (dir file)) - let dir' = takeDirectory dir + cnts <- getCabalFiles dir case cnts of - [] | dir' == dir -> return Nothing + [] | dir' == dir -> throwIO $ userError "cabal files not found" | otherwise -> cabalDir dir' - cfile:_ -> do - msbox <- checkSandbox dir - return $ Just (dir,dir cfile, msbox) + cfile:_ -> return (dir,dir cfile) where + dir' = takeDirectory dir + +getCabalFiles :: FilePath -> IO [FilePath] +getCabalFiles dir = getFiles >>= filterM doesCabalFileExist + where isCabal name = cabalSuffix `isSuffixOf` name && length name > cabalSuffixLength + getFiles = filter isCabal <$> getDirectoryContents dir + doesCabalFileExist file = doesFileExist $ dir file ---------------------------------------------------------------- -sandboxConfig :: String -sandboxConfig = "cabal.sandbox.config" +configFile :: String +configFile = "cabal.sandbox.config" -sandboxDir :: String -sandboxDir = ".cabal-sandbox" +pkgDbKey :: String +pkgDbKey = "package-db:" -checkSandbox :: FilePath -> IO (Maybe FilePath) -checkSandbox dir = do - let conf = dir sandboxConfig - sbox = dir sandboxDir - sandboxConfigExists <- doesFileExist conf - sandboxExists <- doesDirectoryExist sbox - if sandboxConfigExists && sandboxExists then - return (Just sbox) - else - return Nothing +pkgDbKeyLen :: Int +pkgDbKeyLen = length pkgDbKey ----------------------------------------------------------------- +-- | Extract a package db directory from the sandbox config file. +getPackageDbOpts :: FilePath -> IO [GHCOption] +getPackageDbOpts cdir = (sandboxArguments <$> getPkgDb ) `E.catch` handler + where + getPkgDb = extractValue . parse <$> readFile (cdir configFile) + parse = head . filter ("package-db:" `isPrefixOf`) . lines + extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen + handler :: SomeException -> IO [GHCOption] + handler _ = return [] -packageConfName :: GHCVersion -> FilePath -packageConfName strver = Text.display buildPlatform - ++ "-ghc-" - ++ strver - ++ "-packages.conf.d" +-- | Adding necessary GHC options to the package db. +-- Exception is thrown if the string argument is incorrect. +-- +-- >>> sandboxArguments "/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" +-- ["-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] + where + ver = extractGhcVer pkgDb + (pkgDbOpt,noUserPkgDbOpt) + | ver < 706 = ("-package-conf","-no-user-package-conf") + | otherwise = ("-package-db", "-no-user-package-db") -checkPackageConf :: FilePath -> GHCVersion -> IO (FilePath, Bool) -checkPackageConf path strver = do - let dir = path packageConfName strver - exist <- doesDirectoryExist dir - return (dir,exist) +-- | 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 diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -17,30 +17,27 @@ -- | Obtaining debug information. debugInfo :: Options -> Cradle - -> GHCVersion -> FilePath -- ^ A target file. -> IO String -debugInfo opt cradle ver fileName = unlines <$> withGHC fileName (debug opt cradle ver fileName) +debugInfo opt cradle fileName = unlines <$> withGHC fileName (debug opt cradle fileName) -- | Obtaining debug information. debug :: Options -> Cradle - -> GHCVersion -> FilePath -- ^ A target file. -> Ghc [String] -debug opt cradle ver fileName = do - (gopts, incDir, pkgs) <- +debug opt cradle fileName = do + CompilerOptions gopts incDir pkgs <- if cabal then - liftIO $ fromCabalFile (ghcOpts opt) cradle ||> return (ghcOpts opt, [], []) + liftIO (fromCabalFile ||> return simpleCompilerOption) else - return (ghcOpts opt, [], []) + return simpleCompilerOption [fast] <- do void $ initializeFlagsWithCradle opt cradle gopts True setTargetFiles [fileName] pure . canCheckFast <$> depanal [] False return [ - "GHC version: " ++ ver - , "Current directory: " ++ currentDir + "Current directory: " ++ currentDir , "Cabal file: " ++ cabalFile , "GHC options: " ++ unwords gopts , "Include directories: " ++ unwords incDir @@ -49,5 +46,11 @@ ] where currentDir = cradleCurrentDir cradle - cabal = isJust $ cradleCabalFile cradle - cabalFile = fromMaybe "" $ cradleCabalFile cradle + mCabalFile = cradleCabalFile cradle + cabal = isJust mCabalFile + cabalFile = fromMaybe "" mCabalFile + origGopts = ghcOpts opt + simpleCompilerOption = CompilerOptions origGopts [] [] + fromCabalFile = parseCabalFile file >>= getCompilerOptions origGopts cradle + where + file = fromJust mCabalFile diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -16,7 +16,8 @@ import Control.Exception import Control.Monad import CoreMonad -import Data.Maybe (isJust) +import Data.Maybe (isJust,fromJust) +import Distribution.PackageDescription (PackageDescription) import DynFlags import Exception import GHC @@ -24,8 +25,8 @@ import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.ErrMsg import Language.Haskell.GhcMod.GHCChoice -import Language.Haskell.GhcMod.Types import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Types import System.Exit import System.IO @@ -60,37 +61,44 @@ -- | Initialize the 'DynFlags' relating to the compilation of a single -- file or GHC session according to the 'Cradle' and 'Options' -- provided. -initializeFlagsWithCradle :: GhcMonad m => Options -> Cradle -> [GHCOption] -> Bool -> m LogReader -initializeFlagsWithCradle opt cradle ghcOptions logging +initializeFlagsWithCradle :: GhcMonad m => Options -> Cradle -> [GHCOption] -> Bool -> m (LogReader, Maybe PackageDescription) +initializeFlagsWithCradle opt cradle ghcopts logging | cabal = withCabal |||> withoutCabal | otherwise = withoutCabal where - cabal = isJust $ cradleCabalFile cradle + mCradleFile = cradleCabalFile cradle + cabal = isJust mCradleFile withCabal = do - (gopts,idirs,depPkgs) <- liftIO $ fromCabalFile ghcOptions cradle - initSession CabalPkg opt gopts idirs (Just depPkgs) logging - withoutCabal = - initSession SingleFile opt ghcOptions importDirs Nothing logging + pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile + compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc + logger <- initSession CabalPkg opt compOpts logging + return (logger, Just pkgDesc) + withoutCabal = do + logger <- initSession SingleFile opt compOpts logging + return (logger, Nothing) + where + compOpts = CompilerOptions ghcopts importDirs [] ---------------------------------------------------------------- initSession :: GhcMonad m => Build -> Options - -> [GHCOption] - -> [IncludeDir] - -> Maybe [Package] + -> CompilerOptions -> Bool -> m LogReader -initSession build opt cmdOpts idirs mDepPkgs logging = do +initSession build opt compOpts logging = do dflags0 <- getSessionDynFlags (dflags1,readLog) <- setupDynamicFlags dflags0 _ <- setSessionDynFlags dflags1 return readLog where + cmdOpts = ghcOptions compOpts + idirs = includeDirs compOpts + depPkgs = depPackages compOpts ls = lineSeparator opt setupDynamicFlags df0 = do df1 <- modifyFlagsWithOpts df0 cmdOpts - let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build + let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt liftIO $ setLogger logging df3 ls @@ -107,14 +115,14 @@ ---------------------------------------------------------------- -- FIXME removing Options -modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Build -> DynFlags -modifyFlags d0 idirs mDepPkgs splice build +modifyFlags :: DynFlags -> [IncludeDir] -> [Package] -> Bool -> Build -> DynFlags +modifyFlags d0 idirs pepPkgs splice build | splice = setSplice d4 | otherwise = d4 where d1 = d0 { importPaths = idirs } d2 = setFastOrNot d1 Fast - d3 = maybe d2 (Gap.addDevPkgs d2) mDepPkgs + d3 = Gap.addDevPkgs d2 pepPkgs d4 | build == CabalPkg = Gap.setCabalPkg d3 | otherwise = d3 diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -207,6 +207,7 @@ ---------------------------------------------------------------- addDevPkgs :: DynFlags -> [Package] -> DynFlags +addDevPkgs df [] = df addDevPkgs df pkgs = df'' where #if __GLASGOW_HASKELL__ >= 707 diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -6,12 +6,14 @@ , GHCOption , Package , IncludeDir + , CompilerOptions(..) -- * Cabal API - , fromCabalFile , parseCabalFile + , getCompilerOptions , cabalAllBuildInfo , cabalDependPackages , cabalSourceDirs + , cabalAllTargets -- * GHC API , canCheckFast -- * Getting 'DynFlags' diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -19,8 +19,6 @@ , detailed :: Bool -- | Whether or not Template Haskell should be expanded. , expandSplice :: Bool - -- | The sandbox directory. - , sandbox :: Maybe FilePath -- | Line separator string. , lineSeparator :: LineSeparator } @@ -34,7 +32,6 @@ , operators = False , detailed = False , expandSplice = False - , sandbox = Nothing , lineSeparator = LineSeparator "\0" } @@ -85,24 +82,21 @@ , cradleCabalDir :: Maybe FilePath -- | The file name of the found cabal file. , cradleCabalFile :: Maybe FilePath - -- | The sandbox directory. (e.g. \"\/foo\/bar\/packages-\.conf/\") - , cradlePackageConf :: 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] } deriving (Eq, Show) ---------------------------------------------------------------- --- | A single GHC option, as it would appear on the command line. +-- | A single GHC command line option. type GHCOption = String --- | Include directories for modules +-- | An include directory for modules. type IncludeDir = FilePath --- | Package names +-- | A package name. type Package = String --- | GHC version in 'String'. -type GHCVersion = String - -- | Haskell expression. type Expression = String @@ -110,3 +104,10 @@ type ModuleString = String data CheckSpeed = Slow | Fast + +-- | Option information for GHC +data CompilerOptions = CompilerOptions { + ghcOptions :: [GHCOption] -- ^ Command line options + , includeDirs :: [IncludeDir] -- ^ Include directories for modules + , depPackages :: [Package] -- ^ Dependent package names + } deriving (Eq, Show) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 3.0.2 +Version: 3.1.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -86,6 +86,15 @@ , filepath , ghc , ghc-mod + +Test-Suite doctest + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + HS-Source-Dirs: test + Ghc-Options: -threaded -Wall + Main-Is: doctests.hs + Build-Depends: base + , doctest >= 0.9.3 Test-Suite spec Default-Language: Haskell2010 diff --git a/src/GHCMod.hs b/src/GHCMod.hs --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -55,9 +55,6 @@ , Option "d" ["detailed"] (NoArg (\opts -> opts { detailed = True })) "print detailed info" - , Option "s" ["sandbox"] - (ReqArg (\s opts -> opts { sandbox = Just s }) "path") - "specify a sandbox" , Option "b" ["boundary"] (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") "specify line separator (default is Nul string)" @@ -87,11 +84,9 @@ hSetEncoding stdout utf8 -- #endif args <- getArgs - let (opt',cmdArg) = parseArgs argspec args - (strVer,ver) <- getGHCVersion - cradle <- findCradle (sandbox opt') strVer - let opt = adjustOpts opt' cradle ver - cmdArg0 = cmdArg !. 0 + let (opt,cmdArg) = parseArgs argspec args + cradle <- findCradle + let cmdArg0 = cmdArg !. 0 cmdArg1 = cmdArg !. 1 cmdArg2 = cmdArg !. 2 cmdArg3 = cmdArg !. 3 @@ -105,7 +100,7 @@ "list" -> listModules opt "check" -> checkSyntax opt cradle remainingArgs "expand" -> checkSyntax opt { expandSplice = True } cradle remainingArgs - "debug" -> nArgs 1 $ debugInfo opt cradle strVer cmdArg1 + "debug" -> nArgs 1 $ debugInfo opt cradle cmdArg1 "type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4) "info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg2 cmdArg3 "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1 @@ -148,13 +143,6 @@ xs !. idx | length xs <= idx = throw SafeList | otherwise = xs !! idx - adjustOpts opt cradle ver = case mPkgConf of - Nothing -> opt - Just pkgConf -> opt { - ghcOpts = ghcPackageConfOptions ver pkgConf ++ ghcOpts opt - } - where - mPkgConf = cradlePackageConf cradle ---------------------------------------------------------------- @@ -169,9 +157,3 @@ , "Data.Maybe" , "System.IO" ] - - -ghcPackageConfOptions :: Int -> String -> [String] -ghcPackageConfOptions ver file - | ver >= 706 = ["-package-db", file, "-no-user-package-db"] - | otherwise = ["-package-conf", file, "-no-user-package-conf"] diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -4,15 +4,32 @@ import Control.Applicative import Control.Exception +import Data.Maybe import Language.Haskell.GhcMod.CabalApi +import Language.Haskell.GhcMod.Cradle +import Language.Haskell.GhcMod.Types import Test.Hspec +import Dir + spec :: Spec spec = do describe "parseCabalFile" $ do it "throws an exception if the cabal file is broken" $ do parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True) + describe "getCompilerOptions" $ do + it "gets necessary CompilerOptions" $ do + withDirectory "test/data/subdir1/subdir2" $ \dir -> do + cradle <- findCradle + pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle + res <- getCompilerOptions [] cradle pkgDesc + let res' = res { + ghcOptions = map (toRelativeDir dir) (ghcOptions res) + , includeDirs = map (toRelativeDir dir) (includeDirs res) + } + res' `shouldBe` CompilerOptions {ghcOptions = ["-no-user-package-db","-package-db","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","base","template-haskell"]} + describe "cabalDependPackages" $ do it "extracts dependent packages" $ do pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" @@ -22,8 +39,11 @@ it "extracts all hs-source-dirs" $ do dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal" dirs `shouldBe` ["src", "test"] + it "extracts all hs-source-dirs including \".\"" $ do + dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" + dirs `shouldBe` [".", "test"] - describe "cabalBuildInfo" $ do + describe "cabalAllBuildInfo" $ do it "extracts build info" $ do info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]" diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -12,26 +12,24 @@ describe "checkSyntax" $ do it "can check even if an executable depends on its library" $ do withDirectory_ "test/data/ghc-mod-check" $ do - (strVer,_) <- getGHCVersion - cradle <- findCradle Nothing strVer + cradle <- findCradle res <- checkSyntax defaultOptions cradle ["main.hs"] res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n" it "can check even if a test module imports another test module located at different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do - cradle <- getGHCVersion >>= findCradle Nothing . fst + cradle <- findCradle res <- checkSyntax defaultOptions cradle ["test/Bar/Baz.hs"] res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\NUL\n") `isSuffixOf`) it "can detect mutually imported modules" $ do withDirectory_ "test/data" $ do - (strVer,_) <- getGHCVersion - cradle <- findCradle Nothing strVer + cradle <- findCradle res <- checkSyntax defaultOptions cradle ["Mutual1.hs"] res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) it "can check a module using QuasiQuotes" $ do withDirectory_ "test/data" $ do - cradle <- getGHCVersion >>= findCradle Nothing . fst + cradle <- findCradle res <- checkSyntax defaultOptions cradle ["Baz.hs"] res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) diff --git a/test/DebugSpec.hs b/test/DebugSpec.hs --- a/test/DebugSpec.hs +++ b/test/DebugSpec.hs @@ -7,9 +7,8 @@ checkFast :: String -> String -> IO () checkFast file ans = withDirectory_ "test/data" $ do - (strVer,_) <- getGHCVersion - cradle <- findCradle Nothing strVer - res <- debugInfo defaultOptions cradle strVer file + let cradle = Cradle "." Nothing Nothing [] + res <- debugInfo defaultOptions cradle file lines res `shouldContain` [ans] spec :: Spec diff --git a/test/Dir.hs b/test/Dir.hs --- a/test/Dir.hs +++ b/test/Dir.hs @@ -1,7 +1,9 @@ module Dir where -import System.Directory import Control.Exception as E +import Data.List (isPrefixOf) +import System.Directory +import System.FilePath (addTrailingPathSeparator) withDirectory_ :: FilePath -> IO a -> IO a withDirectory_ dir action = bracket getCurrentDirectory @@ -12,3 +14,11 @@ withDirectory dir action = bracket getCurrentDirectory setCurrentDirectory (\d -> setCurrentDirectory dir >> action d) + +toRelativeDir :: FilePath -> FilePath -> FilePath +toRelativeDir dir file + | dir' `isPrefixOf` file = drop len file + | otherwise = file + where + dir' = addTrailingPathSeparator dir + len = length dir' diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -13,39 +13,38 @@ describe "typeExpr" $ do it "shows types of the expression and its outers" $ do withDirectory_ "test/data/ghc-mod-check" $ do - (strVer,_) <- getGHCVersion - cradle <- findCradle Nothing strVer + cradle <- findCradle res <- typeExpr defaultOptions cradle "Data/Foo.hs" "Data.Foo" 9 5 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" it "works with a module using TemplateHaskell" $ do withDirectory_ "test/data" $ do - cradle <- getGHCVersion >>= findCradle Nothing . fst + cradle <- findCradle res <- typeExpr defaultOptions cradle "Bar.hs" "Bar" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do withDirectory_ "test/data" $ do - cradle <- getGHCVersion >>= findCradle Nothing . fst + cradle <- findCradle res <- typeExpr defaultOptions cradle "Main.hs" "Main" 3 8 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "infoExpr" $ do it "works for non-export functions" $ do withDirectory_ "test/data" $ do - cradle <- getGHCVersion >>= findCradle Nothing . fst + cradle <- findCradle res <- infoExpr defaultOptions cradle "Info.hs" "Info" "fib" res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) it "works with a module using TemplateHaskell" $ do withDirectory_ "test/data" $ do - cradle <- getGHCVersion >>= findCradle Nothing . fst + cradle <- findCradle res <- infoExpr defaultOptions cradle "Bar.hs" "Bar" "foo" res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) it "works with a module that imports another module using TemplateHaskell" $ do withDirectory_ "test/data" $ do - cradle <- getGHCVersion >>= findCradle Nothing . fst + cradle <- findCradle res <- infoExpr defaultOptions cradle "Main.hs" "Main" "bar" res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "-package" + , "ghc" + , "Language/Haskell/GhcMod.hs" + ]