ghc-mod 1.11.1 → 1.11.2
raw patch · 6 files changed
+94/−35 lines, 6 filesdep +containersdep ~Cabal
Dependencies added: containers
Dependency ranges changed: Cabal
Files
- Cabal.hs +7/−20
- CabalApi.hs +55/−0
- ErrMsg.hs +7/−5
- GHCApi.hs +12/−8
- Gap.hs +9/−0
- ghc-mod.cabal +4/−2
Cabal.hs view
@@ -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 ----------------------------------------------------------------
+ CabalApi.hs view
@@ -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
ErrMsg.hs view
@@ -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
GHCApi.hs view
@@ -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"
Gap.hs view
@@ -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
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 1.11.1+Version: 1.11.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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