diff --git a/Browse.hs b/Browse.hs --- a/Browse.hs +++ b/Browse.hs @@ -13,6 +13,7 @@ import Type import Types import Var +import DataCon (dataConRepType) ---------------------------------------------------------------- @@ -32,8 +33,8 @@ formatOps' [] = error "formatOps'" browse :: Options -> String -> IO [String] -browse opt mdlName = withGHC $ do - _ <- initSession0 opt +browse opt mdlName = withGHCDummyFile $ do + initializeFlags opt getModule >>= getModuleInfo >>= listExports where getModule = findModule (mkModuleName mdlName) Nothing @@ -59,11 +60,15 @@ inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm showThing :: TyThing -> Maybe String -showThing (AnId i) = Just $ getOccString i ++ " :: " ++ showOutputable (removeForAlls $ varType i) -showThing (ATyCon t) = unwords . toList <$> tyType t +showThing (AnId i) = Just $ formatType varType i +showThing (ADataCon d) = Just $ formatType dataConRepType d +showThing (ATyCon t) = unwords . toList <$> tyType t where toList t' = t' : getOccString t : map getOccString (tyConTyVars t) showThing _ = Nothing + +formatType :: NamedThing a => (a -> Type) -> a -> String +formatType f x = getOccString x ++ " :: " ++ showOutputable (removeForAlls $ f x) tyType :: TyCon -> Maybe String tyType typ diff --git a/Cabal.hs b/Cabal.hs deleted file mode 100644 --- a/Cabal.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} - -module Cabal (initializeGHC, getDirs, fromCabal) where - -import CabalApi (cabalParseFile, cabalBuildInfo, cabalDependPackages) -import Control.Applicative -import Control.Exception -import Control.Monad -import CoreMonad -import Data.List -import Distribution.PackageDescription (BuildInfo(..), usedExtensions) -import Distribution.Text (display) -import ErrMsg -import GHC -import GHCApi -import GHCChoice -import System.Directory -import System.FilePath -import Types - ----------------------------------------------------------------- - -importDirs :: [String] -importDirs = [".","..","../..","../../..","../../../..","../../../../.."] - -initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader) -initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal - where - withoutCabal = do - logReader <- initSession opt ghcOptions importDirs Nothing logging - return (fileName,logReader) - withCabal = do - (gopts,idirs,depPkgs) <- liftIO $ fromCabal ghcOptions - logReader <- initSession opt gopts idirs (Just depPkgs) logging - return (fileName,logReader) - -fromCabal :: [String] -> IO ([String], [FilePath], [String]) -fromCabal ghcOptions = do - (owdir,cdir,cfile) <- getDirs - cabal <- cabalParseFile cfile - binfo@BuildInfo{..} <- cabalBuildInfo cabal - let exts = map (("-X" ++) . display) $ usedExtensions binfo - lang = maybe "-XHaskell98" (("-X" ++) . display) defaultLanguage - libs = map ("-l" ++) extraLibs - libDirs = map ("-L" ++) extraLibDirs - gopts = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs - idirs = case hsSourceDirs of - [] -> [cdir,owdir] - dirs -> map (cdir ) dirs ++ [owdir] - depPkgs <- removeMe cfile <$> cabalDependPackages cabal - return (gopts,idirs,depPkgs) - -removeMe :: FilePath -> [String] -> [String] -removeMe cabalfile depPkgs = filter (/= me) depPkgs - where - me = dropExtension $ takeFileName cabalfile - ----------------------------------------------------------------- - --- CurrentWorkingDir, CabalDir, CabalFile -getDirs :: IO (FilePath,FilePath,FilePath) -getDirs = do - wdir <- getCurrentDirectory - (cdir,cfile) <- cabalDir wdir - return (wdir,cdir,cfile) - --- Causes error, catched in the upper function. --- CabalDir, CabalFile -cabalDir :: FilePath -> IO (FilePath,FilePath) -cabalDir dir = do - cnts <- (filter isCabal <$> getDirectoryContents dir) - >>= filterM (\file -> doesFileExist (dir file)) - let dir' = takeDirectory dir - case cnts of - [] | dir' == dir -> throwIO $ userError "No cabal file" - | otherwise -> cabalDir dir' - cfile:_ -> return (dir,dir cfile) - where - isCabal name = ".cabal" `isSuffixOf` name && length name > 6 diff --git a/CabalApi.hs b/CabalApi.hs --- a/CabalApi.hs +++ b/CabalApi.hs @@ -1,55 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} + module CabalApi ( - cabalParseFile, - cabalBuildInfo, - cabalDependPackages + fromCabalFile + , cabalParseFile + , cabalBuildInfo + , cabalAllDependPackages + , cabalAllExtentions + , getGHCVersion ) where import Control.Applicative - -import Data.Maybe (fromJust, maybeToList) +import Control.Exception (throwIO) +import Data.List (intercalate) +import Data.Maybe (fromJust, maybeToList, mapMaybe) import Data.Set (fromList, toList) - -import Distribution.Verbosity (silent) import Distribution.Package (Dependency(Dependency), PackageName(PackageName)) import Distribution.PackageDescription - (GenericPackageDescription, - condLibrary, condExecutables, condTestSuites, condBenchmarks, - BuildInfo, libBuildInfo, buildInfo, - CondTree, condTreeConstraints, condTreeData) import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Simple.Program (ghcProgram) +import Distribution.Simple.Program.Types (programName, programFindVersion) +import Distribution.Text (display) +import Distribution.Verbosity (silent) +import Distribution.Version (versionBranch) +import Language.Haskell.Extension (Extension(..)) +import System.FilePath +import Types ---------------------------------------------------------------- +fromCabalFile :: [GHCOption] + -> Cradle + -> IO ([GHCOption],[IncludeDir],[Package],[LangExt]) +fromCabalFile ghcOptions cradle = + cookInfo ghcOptions cradle <$> cabalParseFile cfile + where + Just cfile = cradleCabalFile cradle + +cookInfo :: [String] -> Cradle -> GenericPackageDescription + -> ([GHCOption],[IncludeDir],[Package],[LangExt]) +cookInfo ghcOptions cradle cabal = (gopts,idirs,depPkgs,hdrExts) + where + owdir = cradleCurrentDir cradle + Just cdir = cradleCabalDir cradle + Just cfile = cradleCabalFile cradle + binfo = cabalBuildInfo cabal + gopts = getGHCOptions ghcOptions binfo + idirs = includeDirectroies cdir owdir $ hsSourceDirs binfo + depPkgs = removeMe cfile $ cabalAllDependPackages cabal + hdrExts = cabalAllExtentions cabal + +removeMe :: FilePath -> [String] -> [String] +removeMe cabalfile = filter (/= me) + where + me = dropExtension $ takeFileName cabalfile + +---------------------------------------------------------------- + cabalParseFile :: FilePath -> IO GenericPackageDescription -cabalParseFile = readPackageDescription silent +cabalParseFile = readPackageDescription silent +---------------------------------------------------------------- + +getGHCOptions :: [String] -> BuildInfo -> [String] +getGHCOptions ghcOptions binfo = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs + where + exts = map (("-X" ++) . display) $ usedExtensions binfo + lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo + libs = map ("-l" ++) $ extraLibs binfo + libDirs = map ("-L" ++) $ extraLibDirs binfo + +---------------------------------------------------------------- + -- Causes error, catched in the upper function. -cabalBuildInfo :: GenericPackageDescription -> IO BuildInfo -cabalBuildInfo pd = - return . fromJust $ fromLibrary pd <|> fromExecutable pd +cabalBuildInfo :: GenericPackageDescription -> BuildInfo +cabalBuildInfo pd = fromJust $ fromLibrary pd <|> fromExecutable pd where fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c) - toMaybe [] = Nothing + toMaybe [] = Nothing toMaybe (x:_) = Just x -getDepsOfPairs :: [(a1, CondTree v [b] a)] -> [b] -getDepsOfPairs = concatMap (condTreeConstraints . snd) +---------------------------------------------------------------- -allDependsOfDescription :: GenericPackageDescription -> [Dependency] -allDependsOfDescription pd = - concat [depLib, depExe, depTests, depBench] +cabalAllDependPackages :: GenericPackageDescription -> [Package] +cabalAllDependPackages pd = uniqueAndSort pkgs where - depLib = concatMap condTreeConstraints (maybeToList . condLibrary $ pd) - depExe = getDepsOfPairs . condExecutables $ pd - depTests = getDepsOfPairs . condTestSuites $ pd - depBench = getDepsOfPairs . condBenchmarks $ pd + pkgs = map getDependencyPackageName $ cabalAllDependency pd -getDependencyPackageName :: Dependency -> String -getDependencyPackageName (Dependency (PackageName n) _) = n +cabalAllDependency :: GenericPackageDescription -> [Dependency] +cabalAllDependency = fromPackageDescription getDeps getDeps getDeps getDeps + where + getDeps :: [Tree a] -> [Dependency] + getDeps = concatMap condTreeConstraints -cabalDependPackages :: GenericPackageDescription -> IO [String] -cabalDependPackages = - return . toList . fromList - . map getDependencyPackageName - . allDependsOfDescription +getDependencyPackageName :: Dependency -> Package +getDependencyPackageName (Dependency (PackageName nm) _) = nm + +---------------------------------------------------------------- + +cabalAllExtentions :: GenericPackageDescription -> [LangExt] +cabalAllExtentions pd = uniqueAndSort exts + where + buildInfos = cabalAllBuildInfos pd + eexts = concatMap oldExtensions buildInfos + ++ concatMap defaultExtensions buildInfos + exts = mapMaybe getExtensionName eexts + +getExtensionName :: Extension -> Maybe LangExt +getExtensionName (EnableExtension nm) = Just (display nm) +getExtensionName _ = Nothing + +---------------------------------------------------------------- + +cabalAllBuildInfos :: GenericPackageDescription -> [BuildInfo] +cabalAllBuildInfos = fromPackageDescription f1 f2 f3 f4 + where + f1 = map (libBuildInfo . condTreeData) + f2 = map (buildInfo . condTreeData) + f3 = map (testBuildInfo . condTreeData) + f4 = map (benchmarkBuildInfo . condTreeData) + +---------------------------------------------------------------- + +type Tree = CondTree ConfVar [Dependency] + +fromPackageDescription :: ([Tree Library] -> [a]) + -> ([Tree Executable] -> [a]) + -> ([Tree TestSuite] -> [a]) + -> ([Tree Benchmark] -> [a]) + -> GenericPackageDescription + -> [a] +fromPackageDescription f1 f2 f3 f4 pd = lib ++ exe ++ tests ++ bench + where + lib = f1 . maybeToList . condLibrary $ pd + exe = f2 . map snd . condExecutables $ pd + tests = f3 . map snd . condTestSuites $ pd + bench = f4 . map snd . condBenchmarks $ pd + +---------------------------------------------------------------- + +includeDirectroies :: String -> String -> [FilePath] -> [String] +includeDirectroies cdir owdir [] = uniqueAndSort [cdir,owdir] +includeDirectroies cdir owdir dirs = uniqueAndSort (map (cdir ) dirs ++ [owdir]) + +---------------------------------------------------------------- + +uniqueAndSort :: [String] -> [String] +uniqueAndSort = toList . fromList + +---------------------------------------------------------------- + +getGHCVersion :: IO (String, Int) +getGHCVersion = ghcVer >>= toTupple + where + ghcVer = programFindVersion ghcProgram silent (programName ghcProgram) + toTupple Nothing = throwIO $ userError "ghc not found" + toTupple (Just v) + | length vs < 2 = return (verstr, 0) + | otherwise = return (verstr, ver) + where + vs = versionBranch v + ver = (vs !! 0) * 100 + (vs !! 1) + verstr = intercalate "." . map show $ vs diff --git a/CabalDev.hs b/CabalDev.hs deleted file mode 100644 --- a/CabalDev.hs +++ /dev/null @@ -1,52 +0,0 @@ -module CabalDev (modifyOptions) where - -{- - If the directory 'cabal-dev/packages-X.X.X.conf' exists, add it to the - options ghc-mod uses to check the source. Otherwise just pass it on. --} - -import Control.Applicative ((<$>)) -import Control.Exception (throwIO) -import Control.Exception.IOChoice -import Data.List (find) -import System.Directory -import System.FilePath (splitPath,joinPath,()) -import Text.Regex.Posix ((=~)) -import Types - -modifyOptions :: Options -> IO Options -modifyOptions opts = found ||> notFound - where - found = addPath opts <$> findCabalDev (sandbox opts) - notFound = return opts - -findCabalDev :: Maybe String -> IO FilePath -findCabalDev Nothing = getCurrentDirectory >>= searchIt . splitPath -findCabalDev (Just path) = do - exist <- doesDirectoryExist path - if exist then - findConf path - else - findCabalDev Nothing - -addPath :: Options -> String -> Options -addPath orig_opts path = orig_opts { ghcOpts = opts' } - where - orig_ghcopt = ghcOpts orig_opts - opts' = orig_ghcopt ++ ["-package-conf", path, "-no-user-package-conf"] - -searchIt :: [FilePath] -> IO FilePath -searchIt [] = throwIO $ userError "Not found" -searchIt path = do - exist <- doesDirectoryExist cabalDir - if exist then - findConf cabalDir - else - searchIt $ init path - where - cabalDir = joinPath path "cabal-dev/" - -findConf :: FilePath -> IO FilePath -findConf path = do - Just f <- find (=~ "packages.*\\.conf") <$> getDirectoryContents path - return $ path f diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,12 @@ +2013-03-05 v1.12.0 + + * "ghc-mod debug" to see which cabal file and sand box are used + * Fast "ghc-mod check" if Template Haskell is not used + * "ghc-mod brwose -d" displays more information (@eagletmt) + 2013-03-01 v1.11.5 - * New option "-d" for "ghc-mod brouse" to show symbols with type + * New option "-d" for "ghc-mod browse" to show symbols with type info (@moidex) 2013-02-15 v1.11.4 diff --git a/Check.hs b/Check.hs --- a/Check.hs +++ b/Check.hs @@ -1,6 +1,5 @@ module Check (checkSyntax) where -import Cabal import Control.Applicative import CoreMonad import ErrMsg @@ -12,17 +11,17 @@ ---------------------------------------------------------------- -checkSyntax :: Options -> String -> IO String -checkSyntax opt file = unlines <$> check opt file +checkSyntax :: Options -> Cradle -> String -> IO String +checkSyntax opt cradle file = unlines <$> check opt cradle file ---------------------------------------------------------------- -check :: Options -> String -> IO [String] -check opt fileName = withGHC' fileName $ checkIt `gcatch` handleErrMsg +check :: Options -> Cradle -> String -> IO [String] +check opt cradle fileName = withGHC fileName $ checkIt `gcatch` handleErrMsg where checkIt = do - (file,readLog) <- initializeGHC opt fileName options True - setTargetFile file + readLog <- initializeFlagsWithCradle opt cradle fileName options True + setTargetFile fileName _ <- load LoadAllTargets liftIO readLog options diff --git a/Cradle.hs b/Cradle.hs new file mode 100644 --- /dev/null +++ b/Cradle.hs @@ -0,0 +1,73 @@ +module Cradle (findCradle) where + +import Control.Applicative ((<$>)) +import Control.Exception (throwIO) +import Control.Monad +import Data.List (isSuffixOf) +import System.Directory +import System.FilePath ((),takeDirectory) +import Types + +-- An error would be thrown +findCradle :: Maybe FilePath -> String -> IO Cradle +findCradle (Just sbox) strver = do + pkgConf <- checkPackageConf sbox strver + 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 + wdir <- getCurrentDirectory + cfiles <- cabalDir wdir + case cfiles of + Nothing -> return Cradle { + cradleCurrentDir = wdir + , cradleCabalDir = Nothing + , cradleCabalFile = Nothing + , cradlePackageConf = Nothing + } + Just (cdir,cfile) -> do + let sbox = cdir "cabal-dev/" + pkgConf = packageConfName sbox strver + exist <- doesFileExist pkgConf + return Cradle { + cradleCurrentDir = wdir + , cradleCabalDir = Just cdir + , cradleCabalFile = Just cfile + , cradlePackageConf = if exist then Just pkgConf else Nothing + } + +cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath)) +cabalDir dir = do + cnts <- (filter isCabal <$> getDirectoryContents dir) + >>= filterM (\file -> doesFileExist (dir file)) + let dir' = takeDirectory dir + case cnts of + [] | dir' == dir -> return Nothing + | otherwise -> cabalDir dir' + cfile:_ -> return $ Just (dir,dir cfile) + where + isCabal name = ".cabal" `isSuffixOf` name && length name > 6 + +packageConfName :: FilePath -> String -> FilePath +packageConfName path ver = path "packages-" ++ ver ++ ".conf" + +checkPackageConf :: FilePath -> String -> IO FilePath +checkPackageConf path ver = do + let conf = packageConfName path ver + exist <- doesFileExist conf + if exist then + return conf + else + throwIO $ userError $ conf ++ " not found" diff --git a/Debug.hs b/Debug.hs new file mode 100644 --- /dev/null +++ b/Debug.hs @@ -0,0 +1,37 @@ +module Debug (debugInfo) where + +import CabalApi +import GHCApi +import Control.Applicative +import Data.List (intercalate) +import Data.Maybe +import Prelude +import Types + +---------------------------------------------------------------- + +debugInfo :: Options -> Cradle -> String -> String -> IO String +debugInfo opt cradle ver fileName = unlines <$> debug opt cradle ver fileName + +debug :: Options -> Cradle -> String -> String -> IO [String] +debug opt cradle ver fileName = do + (gopts, incDir, pkgs, langext) <- + if cabal then + fromCabalFile (ghcOpts opt) cradle + else + return (ghcOpts opt, [], [], []) + dflags <- getDynamicFlags + fast <- getFastCheck dflags fileName (Just langext) + return [ + "GHC version: " ++ ver + , "Current directory: " ++ currentDir + , "Cabal file: " ++ cabalFile + , "GHC options: " ++ unwords gopts + , "Include directories: " ++ unwords incDir + , "Dependent packages: " ++ intercalate ", " pkgs + , "Fast check: " ++ if fast then "Yes" else "No" + ] + where + currentDir = cradleCurrentDir cradle + cabal = isJust $ cradleCabalFile cradle + cabalFile = fromMaybe "" $ cradleCabalFile cradle diff --git a/ErrMsg.hs b/ErrMsg.hs --- a/ErrMsg.hs +++ b/ErrMsg.hs @@ -14,6 +14,7 @@ import qualified Gap import HscTypes import Outputable +import System.FilePath (normalise) ---------------------------------------------------------------- @@ -52,10 +53,10 @@ ppMsg :: SrcSpan -> Severity-> SDoc -> PprStyle -> String ppMsg spn sev msg stl = fromMaybe def $ do (line,col,_,_) <- Gap.getSrcSpan spn - file <- Gap.getSrcFile spn + file <- normalise <$> Gap.getSrcFile spn let severityCaption = Gap.showSeverityCaption sev return $ file ++ ":" ++ show line ++ ":" - ++ show col ++ ":" ++ severityCaption ++ cts ++ "\0" + ++ show col ++ ":" ++ severityCaption ++ cts ++ "\0" where def = "ghc-mod:0:0:Probably mutual module import occurred\0" cts = showMsg msg stl diff --git a/GHCApi.hs b/GHCApi.hs --- a/GHCApi.hs +++ b/GHCApi.hs @@ -1,24 +1,36 @@ -module GHCApi where +module GHCApi ( + withGHC + , withGHCDummyFile + , initializeFlags + , initializeFlagsWithCradle + , setTargetFile + , getDynamicFlags + , getFastCheck + ) where +import CabalApi import Control.Applicative import Control.Exception +import Control.Monad import CoreMonad +import Data.Maybe (isJust) import DynFlags import ErrMsg import Exception import GHC import GHC.Paths (libdir) +import HeaderInfo import System.Exit import System.IO import Types ---------------------------------------------------------------- -withGHC :: Alternative m => Ghc (m a) -> IO (m a) -withGHC = withGHC' "Dummy" +withGHCDummyFile :: Alternative m => Ghc (m a) -> IO (m a) +withGHCDummyFile = withGHC "Dummy" -withGHC' :: Alternative m => FilePath -> Ghc (m a) -> IO (m a) -withGHC' file body = ghandle ignore $ runGhc (Just libdir) $ do +withGHC :: Alternative m => FilePath -> Ghc (m a) -> IO (m a) +withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do dflags <- getSessionDynFlags defaultCleanupHandler dflags body where @@ -30,45 +42,108 @@ ---------------------------------------------------------------- -initSession0 :: Options -> Ghc [PackageId] -initSession0 opt = getSessionDynFlags >>= - (>>= setSessionDynFlags) . setGhcFlags opt +importDirs :: [IncludeDir] +importDirs = [".","..","../..","../../..","../../../..","../../../../.."] -initSession :: Options -> [String] -> [FilePath] -> Maybe [String] -> Bool -> Ghc LogReader -initSession opt cmdOpts idirs mayPkgs logging = do - dflags <- getSessionDynFlags - let opts = map noLoc cmdOpts - (dflags',_,_) <- parseDynamicFlags dflags opts - (dflags'',readLog) <- liftIO . (>>= setLogger logging) - . setGhcFlags opt . setFlags opt dflags' idirs $ mayPkgs - _ <- setSessionDynFlags dflags'' +initializeFlagsWithCradle :: Options -> Cradle -> FilePath -> [GHCOption] -> Bool -> Ghc LogReader +initializeFlagsWithCradle opt cradle fileName ghcOptions logging + | cabal = do + (gopts,idirs,depPkgs,hdrExts) <- liftIO $ fromCabalFile ghcOptions cradle + initSession opt gopts idirs (Just depPkgs) (Just hdrExts) logging fileName + | otherwise = + initSession opt ghcOptions importDirs Nothing Nothing logging fileName + where + cabal = isJust $ cradleCabalFile cradle + +---------------------------------------------------------------- + +initSession :: Options + -> [GHCOption] + -> [IncludeDir] + -> Maybe [Package] + -> Maybe [LangExt] + -> Bool + -> FilePath + -> Ghc LogReader +initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do + dflags0 <- getSessionDynFlags + (dflags1,readLog) <- setupDynamicFlags dflags0 + _ <- setSessionDynFlags dflags1 return readLog + where + setupDynamicFlags df0 = do + df1 <- modifyFlagsWithOpts df0 cmdOpts + fast <- liftIO $ getFastCheck df0 file mLangExts + let df2 = modifyFlags df1 idirs mDepPkgs fast (expandSplice opt) + df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt + liftIO $ setLogger logging df3 ---------------------------------------------------------------- -setFlags :: Options -> DynFlags -> [FilePath] -> Maybe [String] -> DynFlags -setFlags opt d idirs mayPkgs - | expandSplice opt = dopt_set d' Opt_D_dump_splices - | otherwise = d' +initializeFlags :: Options -> Ghc () +initializeFlags opt = do + dflags0 <- getSessionDynFlags + dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt + void $ setSessionDynFlags dflags1 + +---------------------------------------------------------------- + +getHeaderExtension :: DynFlags -> FilePath -> IO [HeaderExt] +getHeaderExtension dflags file = map unLoc <$> getOptionsFromFile dflags file + +---------------------------------------------------------------- + +getFastCheck :: DynFlags -> FilePath -> Maybe [LangExt] -> IO Bool +getFastCheck dflags file mLangExts = do + hdrExts <- getHeaderExtension dflags file + return . not $ useTemplateHaskell mLangExts hdrExts + +useTemplateHaskell :: Maybe [LangExt] -> [HeaderExt] -> Bool +useTemplateHaskell mLangExts hdrExts = th1 || th2 where - d' = maySetExpose $ d { - importPaths = idirs - , ghcLink = LinkInMemory - , hscTarget = HscInterpreted - , flags = flags d + th1 = "-XTemplateHaskell" `elem` hdrExts + th2 = maybe False ("TemplateHaskell" `elem`) mLangExts + +---------------------------------------------------------------- + +-- FIXME removing Options +modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Bool -> DynFlags +modifyFlags d0 idirs mDepPkgs fast splice + | splice = setSplice d3 + | otherwise = d3 + where + d1 = d0 { importPaths = idirs } + d2 = setFastOrNot d1 fast + d3 = maybe d2 (addDevPkgs d2) mDepPkgs + +setSplice :: DynFlags -> DynFlags +setSplice dflag = dopt_set dflag Opt_D_dump_splices + +setFastOrNot :: DynFlags -> Bool -> DynFlags +setFastOrNot dflags False = dflags { + ghcLink = LinkInMemory + , hscTarget = HscInterpreted + } +setFastOrNot dflags True = dflags { + ghcLink = NoLink + , hscTarget = HscNothing + } + +addDevPkgs :: DynFlags -> [Package] -> DynFlags +addDevPkgs df pkgs = df'' + where + df' = dopt_set df Opt_HideAllPackages + df'' = df' { + packageFlags = map ExposePackage pkgs ++ packageFlags df } - -- Do hide-all only when depend packages specified - maySetExpose df = maybe df (\x -> (dopt_set df Opt_HideAllPackages) { - packageFlags = map ExposePackage x ++ packageFlags df - }) mayPkgs -ghcPackage :: PackageFlag -ghcPackage = ExposePackage "ghc" +---------------------------------------------------------------- -setGhcFlags :: Monad m => Options -> DynFlags -> m DynFlags -setGhcFlags opt flagset = - do (flagset',_,_) <- parseDynamicFlags flagset (map noLoc (ghcOpts opt)) - return flagset' +modifyFlagsWithOpts :: DynFlags -> [String] -> Ghc DynFlags +modifyFlagsWithOpts dflags cmdOpts = + tfst <$> parseDynamicFlags dflags (map noLoc cmdOpts) + where + tfst (a,_,_) = a ---------------------------------------------------------------- @@ -76,3 +151,8 @@ setTargetFile file = do target <- guessTarget file Nothing setTargets [target] + +---------------------------------------------------------------- + +getDynamicFlags :: IO DynFlags +getDynamicFlags = runGhc (Just libdir) getSessionDynFlags diff --git a/GHCMod.hs b/GHCMod.hs --- a/GHCMod.hs +++ b/GHCMod.hs @@ -3,15 +3,17 @@ module Main where import Browse -import CabalDev (modifyOptions) +import CabalApi import Check import Control.Applicative import Control.Exception +import Cradle import Data.Typeable import Data.Version +import Debug +import Flag import Info import Lang -import Flag import Lint import List import Paths_ghc_mod @@ -36,6 +38,7 @@ ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] [ ...]\n" ++ "\t ghc-mod check" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "\n" + ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod lint [-h opt] \n" @@ -86,16 +89,23 @@ main = flip catches handlers $ do args <- getArgs let (opt',cmdArg) = parseArgs argspec args - opt <- modifyOptions opt' - res <- case safelist cmdArg 0 of + (strVer,ver) <- getGHCVersion + cradle <- findCradle (sandbox opt') strVer + let opt = adjustOpts opt' cradle ver + cmdArg0 = cmdArg !. 0 + cmdArg1 = cmdArg !. 1 + cmdArg2 = cmdArg !. 2 + cmdArg3 = cmdArg !. 3 + cmdArg4 = cmdArg !. 4 + res <- case cmdArg0 of "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt - "check" -> withFile (checkSyntax opt) (safelist cmdArg 1) - "expand" -> withFile (checkSyntax opt { expandSplice = True }) - (safelist cmdArg 1) - "type" -> withFile (typeExpr opt (safelist cmdArg 2) (read $ safelist cmdArg 3) (read $ safelist cmdArg 4)) (safelist cmdArg 1) - "info" -> withFile (infoExpr opt (safelist cmdArg 2) (safelist cmdArg 3)) (safelist cmdArg 1) - "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) + "check" -> withFile (checkSyntax opt cradle) cmdArg1 + "expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1 + "debug" -> withFile (debugInfo opt cradle strVer) cmdArg1 + "type" -> withFile (typeExpr opt cradle cmdArg2 (read cmdArg3) (read cmdArg4)) cmdArg1 + "info" -> withFile (infoExpr opt cradle cmdArg2 cmdArg3) cmdArg1 + "lint" -> withFile (lintSyntax opt) cmdArg1 "lang" -> listLanguages opt "flag" -> listFlags opt "boot" -> do @@ -127,9 +137,16 @@ if exist then cmd file else throw (FileNotExist file) - safelist xs idx + 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 ---------------------------------------------------------------- @@ -144,3 +161,9 @@ , "Data.Maybe" , "System.IO" ] + + +ghcPackageConfOptions :: Int -> String -> [String] +ghcPackageConfOptions ver file + | ver >= 706 = ["-package-db", file, "-no-user-package-conf"] + | otherwise = ["-package-conf", file, "-no-user-package-conf"] diff --git a/Info.hs b/Info.hs --- a/Info.hs +++ b/Info.hs @@ -3,7 +3,6 @@ module Info (infoExpr, typeExpr) where -import Cabal import Control.Applicative import CoreUtils import Data.Function @@ -23,8 +22,8 @@ import Outputable import PprTyThing import Pretty (showDocWith, Mode(OneLineMode)) -import TcRnTypes import TcHsSyn (hsPatType) +import TcRnTypes import Types ---------------------------------------------------------------- @@ -34,12 +33,12 @@ ---------------------------------------------------------------- -infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr +infoExpr :: Options -> Cradle -> ModuleString -> Expression -> FilePath -> IO String +infoExpr opt cradle modstr expr file = (++ "\n") <$> info opt cradle file modstr expr -info :: Options -> FilePath -> ModuleString -> FilePath -> IO String -info opt fileName modstr expr = - inModuleContext opt fileName modstr exprToInfo "Cannot show info" +info :: Options -> Cradle -> FilePath -> ModuleString -> FilePath -> IO String +info opt cradle fileName modstr expr = + inModuleContext opt cradle fileName modstr exprToInfo "Cannot show info" where exprToInfo = infoThing expr @@ -65,12 +64,12 @@ instance HasType (LPat Id) where getType _ (L spn pat) = return $ Just (spn, hsPatType pat) -typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String -typeExpr opt modstr lineNo colNo file = Info.typeOf opt file modstr lineNo colNo +typeExpr :: Options -> Cradle -> ModuleString -> Int -> Int -> FilePath -> IO String +typeExpr opt cradle modstr lineNo colNo file = Info.typeOf opt cradle file modstr lineNo colNo -typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String -typeOf opt fileName modstr lineNo colNo = - inModuleContext opt fileName modstr exprToType errmsg +typeOf :: Options -> Cradle -> FilePath -> ModuleString -> Int -> Int -> IO String +typeOf opt cradle fileName modstr lineNo colNo = + inModuleContext opt cradle fileName modstr exprToType errmsg where exprToType = do modSum <- getModSummary $ mkModuleName modstr @@ -138,17 +137,17 @@ ---------------------------------------------------------------- -inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String -inModuleContext opt fileName modstr action errmsg = - withGHC (valid ||> invalid ||> return errmsg) +inModuleContext :: Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String +inModuleContext opt cradle fileName modstr action errmsg = + withGHCDummyFile (valid ||> invalid ||> return errmsg) where valid = do - (file,_) <- initializeGHC opt fileName ["-w"] False - setTargetFile file + _ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False + setTargetFile fileName _ <- load LoadAllTargets doif setContextFromTarget action invalid = do - _ <- initializeGHC opt fileName ["-w"] False + _ <- initializeFlagsWithCradle opt cradle fileName ["-w"] False setTargetBuffer _ <- load LoadAllTargets doif setContextFromTarget action diff --git a/List.hs b/List.hs --- a/List.hs +++ b/List.hs @@ -14,8 +14,8 @@ listModules opt = convert opt . nub . sort <$> list opt list :: Options -> IO [String] -list opt = withGHC $ do - _ <- initSession0 opt +list opt = withGHCDummyFile $ do + initializeFlags opt getExposedModules <$> getSessionDynFlags where getExposedModules = map moduleNameString diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -61,3 +61,20 @@ addNewLine :: String -> String addNewLine = (++ "\n") + +---------------------------------------------------------------- + +data Cradle = Cradle { + cradleCurrentDir :: FilePath + , cradleCabalDir :: Maybe FilePath + , cradleCabalFile :: Maybe FilePath + , cradlePackageConf :: Maybe FilePath + } deriving (Eq, Show) + +---------------------------------------------------------------- + +type GHCOption = String +type IncludeDir = FilePath +type Package = String +type LangExt = String +type HeaderExt = String diff --git a/elisp/ghc-flymake.el b/elisp/ghc-flymake.el --- a/elisp/ghc-flymake.el +++ b/elisp/ghc-flymake.el @@ -20,7 +20,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst ghc-flymake-allowed-file-name-masks - '("\\.l?hs$" ghc-flymake-init)) + '("\\.l?hs$" ghc-flymake-init nil ghc-emacs23-larter-hack)) (defconst ghc-flymake-err-line-patterns '("^\\(.*\\):\\([0-9]+\\):\\([0-9]+\\):[ ]*\\(.+\\)" 1 2 3 4)) @@ -30,6 +30,23 @@ (add-to-list 'flymake-err-line-patterns ghc-flymake-err-line-patterns) + +;; flymake of Emacs 23 or later does not display errors +;; if they occurred in other files. So, let's cheat flymake. +(defun ghc-emacs23-larter-hack (tmp-file) + (let ((real-name (flymake-get-real-file-name tmp-file)) + (hack-name (flymake-get-real-file-name source-file-name))) + (unless (string= real-name hack-name) + ;; Change the local variable, line-err-info, + ;; in flymake-parse-err-lines. + (setq line-err-info + (flymake-ler-make-ler + nil + 1 + (flymake-ler-type line-err-info) + (concat real-name ": " (flymake-ler-text line-err-info)) + (flymake-ler-full-file line-err-info)))) + hack-name)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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: 1.11.5 +Version: 1.12.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -28,6 +28,7 @@ Extra-Source-Files: ChangeLog test/data/*.cabal test/data/*.hs + test/data/cabal-dev/packages-7.6.2.conf test/data/ghc-mod-check/*.hs test/data/ghc-mod-check/*.cabal test/data/ghc-mod-check/Data/*.hs @@ -37,9 +38,9 @@ Main-Is: GHCMod.hs Other-Modules: Browse CabalApi - Cabal - CabalDev Check + Cradle + Debug ErrMsg Flag GHCApi @@ -65,7 +66,6 @@ , io-choice , old-time , process - , regex-posix , syb , time , transformers @@ -77,7 +77,6 @@ Type: exitcode-stdio-1.0 Other-Modules: Expectation BrowseSpec - CabalSpec CabalApiSpec CheckSpec FlagSpec @@ -98,7 +97,6 @@ , io-choice , old-time , process - , regex-posix , syb , time , transformers diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -17,3 +17,7 @@ it "lists up symbols with type info in the module" $ do syms <- lines <$> browseModule defaultOptions { detailed = True } "Data.Either" syms `shouldContain` "either :: (a -> c) -> (b -> c) -> Either a b -> c" + + it "lists up data constructors with type info in the module" $ do + syms <- lines <$> browseModule defaultOptions { detailed = True} "Data.Either" + syms `shouldContain` "Left :: a -> Either a b" diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -1,17 +1,18 @@ module CabalApiSpec where +import Control.Applicative import Test.Hspec import CabalApi spec :: Spec spec = do - describe "cabalDependPackages" $ do + describe "cabalAllDependPackages" $ do it "extracts dependent packages" $ do - pkgs <- cabalParseFile "test/data/cabalapi.cabal" >>= cabalDependPackages + pkgs <- cabalAllDependPackages <$> cabalParseFile "test/data/cabalapi.cabal" pkgs `shouldBe` ["Cabal","base","containers","convertible","directory","filepath","ghc","ghc-paths","ghc-syb-utils","hlint","hspec","io-choice","old-time","process","regex-posix","syb","time","transformers"] describe "cabalBuildInfo" $ do it "extracts build info" $ do - info <- cabalParseFile "test/data/cabalapi.cabal" >>= cabalBuildInfo + info <- cabalBuildInfo <$> cabalParseFile "test/data/cabalapi.cabal" let infoStr = show info infoStr `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 = []}" diff --git a/test/CabalSpec.hs b/test/CabalSpec.hs deleted file mode 100644 --- a/test/CabalSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -module CabalSpec where - -import Control.Applicative -import System.Directory -import Test.Hspec -import Cabal -import Expectation - -spec :: Spec -spec = do - describe "getDirs" $ do - it "obtains two directories and a cabal file" $ do - len <- length <$> getCurrentDirectory - withDirectory "test/data/subdir1/subdir2" $ do - (x,y,z) <- getDirs - (drop len x, drop len y, drop len z) `shouldBe` ("/test/data/subdir1/subdir2","/test/data","/test/data/cabalapi.cabal") - - describe "getDirs" $ do - it "obtains two directories and a cabal file" $ do - len <- length <$> getCurrentDirectory - withDirectory "test/data/subdir1/subdir2" $ do - (x,y,z) <- fromCabal [] - (x, map (drop len) y, z) `shouldBe` (["-XHaskell98"],["/test/data","/test/data/subdir1/subdir2"],["Cabal","base","containers","convertible","directory","filepath","ghc","ghc-paths","ghc-syb-utils","hlint","hspec","io-choice","old-time","process","regex-posix","syb","time","transformers"]) diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -1,14 +1,18 @@ module CheckSpec where -import Test.Hspec +import CabalApi import Check +import Cradle import Expectation +import Test.Hspec import Types spec :: Spec spec = do describe "checkSyntax" $ do it "can check even if an executable depends on its library" $ do - withDirectory "test/data/ghc-mod-check" $ do - res <- checkSyntax defaultOptions "main.hs" + withDirectory_ "test/data/ghc-mod-check" $ do + (strVer,_) <- getGHCVersion + cradle <- findCradle Nothing strVer + res <- checkSyntax defaultOptions cradle "main.hs" res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\NUL\n" diff --git a/test/Expectation.hs b/test/Expectation.hs --- a/test/Expectation.hs +++ b/test/Expectation.hs @@ -9,7 +9,12 @@ let res = element `elem` containers res `shouldBe` True -withDirectory :: FilePath -> IO a -> IO a +withDirectory_ :: FilePath -> IO a -> IO a +withDirectory_ dir action = bracket getCurrentDirectory + setCurrentDirectory + (\_ -> setCurrentDirectory dir >> action) + +withDirectory :: FilePath -> (FilePath -> IO a) -> IO a withDirectory dir action = bracket getCurrentDirectory setCurrentDirectory - (\_ -> setCurrentDirectory dir >> action) + (\d -> setCurrentDirectory dir >> action d) diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -1,14 +1,18 @@ module InfoSpec where -import Test.Hspec +import CabalApi +import Cradle import Expectation import Info +import Test.Hspec import Types spec :: Spec spec = do describe "typeExpr" $ do it "shows types of the expression and its outers" $ do - withDirectory "test/data/ghc-mod-check" $ do - res <- typeExpr defaultOptions "Data.Foo" 9 5 "Data/Foo.hs" + withDirectory_ "test/data/ghc-mod-check" $ do + (strVer,_) <- getGHCVersion + cradle <- findCradle Nothing strVer + res <- typeExpr defaultOptions cradle "Data.Foo" 9 5 "Data/Foo.hs" res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" diff --git a/test/data/cabal-dev/packages-7.6.2.conf b/test/data/cabal-dev/packages-7.6.2.conf new file mode 100644 --- /dev/null +++ b/test/data/cabal-dev/packages-7.6.2.conf @@ -0,0 +1,1 @@ +dummy