diff --git a/Cabal.hs b/Cabal.hs --- a/Cabal.hs +++ b/Cabal.hs @@ -2,15 +2,13 @@ module Cabal (initializeGHC) where +import CabalApi (cabalParseFile, cabalBuildInfo, cabalDependPackages) import Control.Applicative import Control.Exception import Control.Monad import CoreMonad import Data.List -import Data.Maybe -import Distribution.PackageDescription -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Verbosity (silent) +import Distribution.PackageDescription (BuildInfo(..), usedExtensions) import ErrMsg import GHC import GHCApi @@ -29,11 +27,12 @@ initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal where withoutCabal = do - logReader <- initSession opt ghcOptions importDirs logging + logReader <- initSession opt ghcOptions importDirs Nothing logging return (fileName,logReader) withCabal = do (owdir,cdir,cfile) <- liftIO getDirs - binfo@BuildInfo{..} <- liftIO $ parseCabalFile cfile + cabal <- liftIO $ cabalParseFile cfile + binfo@BuildInfo{..} <- liftIO $ cabalBuildInfo cabal let exts = map (addX . Gap.extensionToString) $ usedExtensions binfo lang = maybe "-XHaskell98" (addX . show) defaultLanguage libs = map ("-l" ++) extraLibs @@ -42,22 +41,10 @@ idirs = case hsSourceDirs of [] -> [cdir,owdir] dirs -> map (cdir ) dirs ++ [owdir] - logReader <- initSession opt gopts idirs logging + depPkgs <- liftIO $ cabalDependPackages cabal + logReader <- initSession opt gopts idirs (Just depPkgs) logging return (fileName,logReader) addX = ("-X" ++) - ----------------------------------------------------------------- - --- Causes error, catched in the upper function. -parseCabalFile :: FilePath -> IO BuildInfo -parseCabalFile file = do - cabal <- readPackageDescription silent file - return . fromJust $ fromLibrary cabal <|> fromExecutable cabal - where - fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c - fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c) - toMaybe [] = Nothing - toMaybe (x:_) = Just x ---------------------------------------------------------------- diff --git a/CabalApi.hs b/CabalApi.hs new file mode 100644 --- /dev/null +++ b/CabalApi.hs @@ -0,0 +1,55 @@ +module CabalApi ( + cabalParseFile, + cabalBuildInfo, + cabalDependPackages + ) where + +import Control.Applicative + +import Data.Maybe (fromJust, maybeToList) +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) + +---------------------------------------------------------------- + +cabalParseFile :: FilePath -> IO GenericPackageDescription +cabalParseFile = readPackageDescription silent + +-- Causes error, catched in the upper function. +cabalBuildInfo :: GenericPackageDescription -> IO BuildInfo +cabalBuildInfo pd = do + return . fromJust $ fromLibrary pd <|> fromExecutable pd + where + fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c + fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c) + 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] + where + depLib = concatMap condTreeConstraints (maybeToList . condLibrary $ pd) + depExe = getDepsOfPairs . condExecutables $ pd + depTests = getDepsOfPairs . condTestSuites $ pd + depBench = getDepsOfPairs . condBenchmarks $ pd + +getDependencyPackageName :: Dependency -> String +getDependencyPackageName (Dependency (PackageName n) _) = n + +cabalDependPackages :: GenericPackageDescription -> IO [String] +cabalDependPackages = + return . toList . fromList + . map getDependencyPackageName + . allDependsOfDescription diff --git a/ErrMsg.hs b/ErrMsg.hs --- a/ErrMsg.hs +++ b/ErrMsg.hs @@ -30,7 +30,7 @@ let newdf = Gap.setLogAction df $ appendLog ref return (newdf, reverse <$> readIORef ref) where - appendLog ref _ _ src stl msg = modifyIORef ref (\ls -> ppMsg src msg stl : ls) + appendLog ref _ sev src stl msg = modifyIORef ref (\ls -> ppMsg src sev msg stl : ls) ---------------------------------------------------------------- @@ -43,17 +43,19 @@ ---------------------------------------------------------------- ppErrMsg :: ErrMsg -> String -ppErrMsg err = ppMsg spn msg defaultUserStyle ++ ext +ppErrMsg err = ppMsg spn SevError msg defaultUserStyle ++ ext where spn = head (errMsgSpans err) msg = errMsgShortDoc err ext = showMsg (errMsgExtraInfo err) defaultUserStyle -ppMsg :: SrcSpan -> SDoc -> PprStyle -> String -ppMsg spn msg stl = fromMaybe def $ do +ppMsg :: SrcSpan -> Severity-> SDoc -> PprStyle -> String +ppMsg spn sev msg stl = fromMaybe def $ do (line,col,_,_) <- Gap.getSrcSpan spn file <- Gap.getSrcFile spn - return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ cts ++ "\0" + let severityCaption = Gap.showSeverityCaption sev + return $ file ++ ":" ++ show line ++ ":" + ++ 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 @@ -31,29 +31,33 @@ initSession0 opt = getSessionDynFlags >>= (>>= setSessionDynFlags) . setGhcFlags opt -initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader -initSession opt cmdOpts idirs logging = do +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 + (dflags'',readLog) <- liftIO . (>>= setLogger logging) + . setGhcFlags opt . setFlags opt dflags' idirs $ mayPkgs _ <- setSessionDynFlags dflags'' return readLog ---------------------------------------------------------------- -setFlags :: Options -> DynFlags -> [FilePath] -> DynFlags -setFlags opt d idirs +setFlags :: Options -> DynFlags -> [FilePath] -> Maybe [String] -> DynFlags +setFlags opt d idirs mayPkgs | expandSplice opt = dopt_set d' Opt_D_dump_splices | otherwise = d' where - d' = d { - packageFlags = ghcPackage : packageFlags d - , importPaths = idirs + d' = maySetExpose $ d { + importPaths = idirs , ghcLink = LinkInMemory , hscTarget = HscInterpreted , flags = flags d } + -- 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" diff --git a/Gap.hs b/Gap.hs --- a/Gap.hs +++ b/Gap.hs @@ -16,6 +16,7 @@ , toStringBuffer , liftIO , extensionToString + , showSeverityCaption #if __GLASGOW_HASKELL__ >= 702 #else , module Pretty @@ -201,6 +202,14 @@ lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True returnFalse = return False + +showSeverityCaption :: Severity -> String +#if __GLASGOW_HASKELL__ >= 706 +showSeverityCaption SevWarning = "Warning:" +showSeverityCaption _ = "" +#else +showSeverityCaption = const "" +#endif ---------------------------------------------------------------- -- This is Cabal, not GHC API 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.1 +Version: 1.11.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -28,6 +28,7 @@ Executable ghc-mod Main-Is: GHCMod.hs Other-Modules: Browse + CabalApi Cabal CabalDev Check @@ -44,7 +45,8 @@ Types GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5 - , Cabal + , Cabal >= 1.10 + , containers , convertible , directory , filepath