From a7430eb4947f69779a21b89382bae661d6f7f0b6 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 14 Feb 2012 16:09:53 +0900 Subject: [PATCH] Adaptor layer for GHC API. --- Browse.hs | 1 + Cabal.hs | 1 + Check.hs | 1 + ErrMsg.hs | 30 ++++--------- Flag.hs | 15 +++---- GHCApi.hs | 60 ++++++++++++++++++++++++++ Gap.hs | 116 ++++++++++++++++++++++++++++++++++++++++++++++++++ Info.hs | 57 ++++++------------------- Lang.hs | 10 +---- List.hs | 1 + Types.hs | 61 +------------------------- ghc-mod.cabal | 31 ++++++++++++-- 12 files changed, 235 insertions(+), 149 deletions(-) create mode 100644 GHCApi.hs create mode 100644 Gap.hs diff --git a/Browse.hs b/Browse.hs index 8860ec1..a0d2c9f 100644 --- a/Browse.hs +++ b/Browse.hs @@ -4,6 +4,7 @@ import Control.Applicative import Data.Char import Data.List import GHC +import GHCApi import Name import Types diff --git a/Cabal.hs b/Cabal.hs index fb5ac78..72309d5 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -11,6 +11,7 @@ import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.Verbosity (silent) import ErrMsg import GHC +import GHCApi import System.Directory import System.FilePath import Types diff --git a/Check.hs b/Check.hs index 874e1dd..a09e797 100644 --- a/Check.hs +++ b/Check.hs @@ -6,6 +6,7 @@ import CoreMonad import ErrMsg import Exception import GHC +import GHCApi import Prelude hiding (catch) import Types diff --git a/ErrMsg.hs b/ErrMsg.hs index 95ddc79..78dbee0 100644 --- a/ErrMsg.hs +++ b/ErrMsg.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module ErrMsg ( LogReader , setLogger @@ -9,18 +7,15 @@ module ErrMsg ( import Bag import Control.Applicative import Data.IORef +import Data.Maybe import DynFlags import ErrUtils -import FastString import GHC +import qualified Gap import HscTypes import Outputable import System.FilePath -#if __GLASGOW_HASKELL__ < 702 -import Pretty -#endif - ---------------------------------------------------------------- type LogReader = IO [String] @@ -56,27 +51,18 @@ ppErrMsg err = ppMsg spn msg defaultUserStyle ++ ext ext = showMsg (errMsgExtraInfo err) defaultUserStyle ppMsg :: SrcSpan -> Message -> PprStyle -> String -#if __GLASGOW_HASKELL__ >= 702 -ppMsg (RealSrcSpan src) msg stl -#else -ppMsg src msg stl | isGoodSrcSpan src -#endif - = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ cts ++ "\0" +ppMsg spn msg stl = fromMaybe def $ do + (line,col,_,_) <- Gap.getSrcSpan spn + file <- Gap.getSrcFile spn + return $ takeFileName file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ cts ++ "\0" where - file = takeFileName $ unpackFS (srcSpanFile src) - line = show (srcSpanStartLine src) - col = show (srcSpanStartCol src) + def = "ghc-mod:0:0:Probably mutual module import occurred\0" cts = showMsg msg stl -ppMsg _ _ _ = "ghc-mod:0:0:Probably mutual module import occurred\0" ---------------------------------------------------------------- showMsg :: SDoc -> PprStyle -> String -#if __GLASGOW_HASKELL__ >= 702 -showMsg d stl = map toNull . renderWithStyle d $ stl -#else -showMsg d stl = map toNull . Pretty.showDocWith PageMode $ d stl -#endif +showMsg d stl = map toNull $ Gap.renderMsg d stl where toNull '\n' = '\0' toNull x = x diff --git a/Flag.hs b/Flag.hs index 4e727c2..a6bf88b 100644 --- a/Flag.hs +++ b/Flag.hs @@ -2,16 +2,11 @@ module Flag where -import DynFlags import Types +import qualified Gap listFlags :: Options -> IO String -listFlags opt = return $ convert opt - [ "-f" ++ prefix ++ option -#if __GLASGOW_HASKELL__ == 702 - | (option,_,_,_) <- fFlags -#else - | (option,_,_) <- fFlags -#endif - , prefix <- ["","no-"] - ] +listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option + | option <- Gap.fOptions + , prefix <- ["","no-"] + ] diff --git a/GHCApi.hs b/GHCApi.hs new file mode 100644 index 0000000..a693b5f --- /dev/null +++ b/GHCApi.hs @@ -0,0 +1,60 @@ +module GHCApi where + +import Control.Monad +import CoreMonad +import DynFlags +import ErrMsg +import Exception +import GHC +import GHC.Paths (libdir) +import Types + +---------------------------------------------------------------- + +withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) +withGHC body = ghandle ignore $ runGhc (Just libdir) body + where + ignore :: (MonadPlus m) => SomeException -> IO (m a) + ignore _ = return mzero + +---------------------------------------------------------------- + +initSession0 :: Options -> Ghc [PackageId] +initSession0 opt = getSessionDynFlags >>= + (>>= setSessionDynFlags) . setGhcFlags opt + +initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader +initSession opt cmdOpts idirs logging = do + dflags <- getSessionDynFlags + let opts = map noLoc cmdOpts + (dflags',_,_) <- parseDynamicFlags dflags opts + (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags dflags' $ idirs + setSessionDynFlags dflags'' + return readLog + +---------------------------------------------------------------- + +setFlags :: DynFlags -> [FilePath] -> DynFlags +setFlags d idirs = d' + where + d' = d { + packageFlags = ghcPackage : packageFlags d + , importPaths = idirs + , ghcLink = NoLink + , hscTarget = HscInterpreted + } + +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' + +---------------------------------------------------------------- + +setTargetFile :: (GhcMonad m) => String -> m () +setTargetFile file = do + target <- guessTarget file Nothing + setTargets [target] diff --git a/Gap.hs b/Gap.hs new file mode 100644 index 0000000..20ad2e6 --- /dev/null +++ b/Gap.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} + +module Gap ( + supportedExtensions + , getSrcSpan + , getSrcFile + , renderMsg + , setCtx + , fOptions + , toStringBuffer + , liftIO +#if __GLASGOW_HASKELL__ >= 702 +#else + , module Pretty +#endif + ) where + +import Control.Applicative hiding (empty) +import Control.Exception +import Control.Monad +import DynFlags +import FastString +import GHC +import Outputable +import StringBuffer + +#if __GLASGOW_HASKELL__ >= 702 +import CoreMonad (liftIO) +#else +import HscTypes (liftIO) +import Pretty +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +supportedExtensions :: [String] +#if __GLASGOW_HASKELL__ >= 700 +supportedExtensions = supportedLanguagesAndExtensions +#else +supportedExtensions = supportedLanguages +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) +#if __GLASGOW_HASKELL__ >= 702 +getSrcSpan (RealSrcSpan spn) +#else +getSrcSpan spn | isGoodSrcSpan spn +#endif + = Just (srcSpanStartLine spn + , srcSpanStartCol spn + , srcSpanEndLine spn + , srcSpanEndCol spn) +getSrcSpan _ = Nothing + +getSrcFile :: SrcSpan -> Maybe String +#if __GLASGOW_HASKELL__ >= 702 +getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn +#else +getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn +#endif +getSrcFile _ = Nothing + +---------------------------------------------------------------- + +renderMsg :: SDoc -> PprStyle -> String +#if __GLASGOW_HASKELL__ >= 702 +renderMsg d stl = renderWithStyle d stl +#else +renderMsg d stl = Pretty.showDocWith PageMode $ d stl +#endif + +---------------------------------------------------------------- + +toStringBuffer :: [String] -> Ghc StringBuffer +#if __GLASGOW_HASKELL__ >= 702 +toStringBuffer = return . stringToStringBuffer . unlines +#else +toStringBuffer = liftIO . stringToStringBuffer . unlines +#endif + +---------------------------------------------------------------- + +fOptions :: [String] +#if __GLASGOW_HASKELL__ == 702 +fOptions = [option | (option,_,_,_) <- fFlags] +#else +fOptions = [option | (option,_,_) <- fFlags] +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +setCtx :: [ModSummary] -> Ghc Bool +#if __GLASGOW_HASKELL__ >= 704 +setCtx ms = do + top <- map (IIModule . ms_mod) <$> filterM isTop ms + setContext top + return (not . null $ top) +#else +setCtx ms = do + top <- map ms_mod <$> filterM isTop ms + setContext top [] + return (not . null $ top) +#endif + where + isTop mos = lookupMod `gcatch` returnFalse + where + lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True + returnFalse = constE $ return False + +constE :: a -> (SomeException -> a) +constE func = \_ -> func diff --git a/Info.hs b/Info.hs index 255ff26..7bcae93 100644 --- a/Info.hs +++ b/Info.hs @@ -3,9 +3,8 @@ module Info (infoExpr, typeExpr) where import Cabal -import Control.Applicative hiding (empty) +import Control.Applicative import Control.Exception -import Control.Monad import CoreUtils import Data.Function import Data.Generics as G @@ -14,18 +13,17 @@ import Data.Maybe import Data.Ord as O import Desugar import GHC +import GHCApi +import qualified Gap import HscTypes import NameSet import Outputable import PprTyThing -import StringBuffer import System.Time import TcRnTypes import Types -#if __GLASGOW_HASKELL__ >= 702 -import CoreMonad -#endif +---------------------------------------------------------------- type Expression = String type ModuleString = String @@ -52,23 +50,16 @@ typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr ex modSum <- getModSummary $ mkModuleName modstr p <- parseModule modSum tcm <- typecheckModule p - es <- liftIO $ findExpr tcm lineNo colNo + es <- Gap.liftIO $ findExpr tcm lineNo colNo ts <- catMaybes <$> mapM (getType tcm) es let sss = map toTup $ sortBy (cmp `on` fst) ts return $ convert opt sss toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String) - toTup (spn, typ) = (l spn, pretty typ) + toTup (spn, typ) = (fourInts spn, pretty typ) - l :: SrcSpan -> (Int,Int,Int,Int) -#if __GLASGOW_HASKELL__ >= 702 - l (RealSrcSpan spn) -#else - l spn | isGoodSrcSpan spn -#endif - = (srcSpanStartLine spn, srcSpanStartCol spn - , srcSpanEndLine spn, srcSpanEndCol spn) - l _ = (0,0,0,0) + fourInts :: SrcSpan -> (Int,Int,Int,Int) + fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan cmp a b | a `isSubspanOf` b = O.LT @@ -101,7 +92,7 @@ everywhereM' f x = do getType :: GhcMonad m => TypecheckedModule -> LHsExpr Id -> m (Maybe (SrcSpan, Type)) getType tcm e = do hs_env <- getSession - (_, mbe) <- liftIO $ deSugarExpr hs_env modu rn_env ty_env e + (_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe where modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm @@ -159,36 +150,12 @@ inModuleContext opt fileName modstr action = withGHC valid map ms_imps modgraph ++ map ms_srcimps modgraph moddef = "module " ++ sanitize modstr ++ " where" header = moddef : imports -#if __GLASGOW_HASKELL__ >= 702 - importsBuf = stringToStringBuffer . unlines $ header -#else - importsBuf <- liftIO . stringToStringBuffer . unlines $ header -#endif - clkTime <- liftIO getClockTime + importsBuf <- Gap.toStringBuffer header + clkTime <- Gap.liftIO getClockTime setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))] mif m t e = m >>= \ok -> if ok then t else e sanitize = fromMaybe "SomeModule" . listToMaybe . words errorMessage = "Couldn't determine type" setContextFromTarget :: Ghc Bool -setContextFromTarget = do - ms <- depanal [] False - -#if __GLASGOW_HASKELL__ >= 704 - top <- map (IIModule . ms_mod) <$> filterM isTop ms - setContext top -#else - top <- map ms_mod <$> filterM isTop ms - setContext top [] -#endif - return (not . null $ top) - where - isTop ms = lookupMod `gcatch` returnFalse - where - lookupMod = lookupModule (ms_mod_name ms) Nothing >> return True - returnFalse = constE $ return False - ----------------------------------------------------------------- - -constE :: a -> (SomeException -> a) -constE func = \_ -> func +setContextFromTarget = depanal [] False >>= Gap.setCtx diff --git a/Lang.hs b/Lang.hs index 695b9bf..794db48 100644 --- a/Lang.hs +++ b/Lang.hs @@ -1,13 +1,7 @@ -{-# LANGUAGE CPP #-} - module Lang where -import DynFlags +import qualified Gap import Types listLanguages :: Options -> IO String -#if __GLASGOW_HASKELL__ >= 700 -listLanguages opt = return $ convert opt supportedLanguagesAndExtensions -#else -listLanguages opt = return $ convert opt supportedLanguages -#endif +listLanguages opt = return $ convert opt Gap.supportedExtensions diff --git a/List.hs b/List.hs index 5bba190..fc60960 100644 --- a/List.hs +++ b/List.hs @@ -3,6 +3,7 @@ module List (listModules) where import Control.Applicative import Data.List import GHC +import GHCApi import Packages import Types import UniqFM diff --git a/Types.hs b/Types.hs index cf76c72..c0a36b0 100644 --- a/Types.hs +++ b/Types.hs @@ -2,16 +2,6 @@ module Types where -import Control.Monad -import CoreMonad -import DynFlags -import ErrMsg -import Exception -import GHC -import GHC.Paths (libdir) - ----------------------------------------------------------------- - data OutputStyle = LispStyle | PlainStyle data Options = Options { @@ -22,6 +12,7 @@ data Options = Options { } ---------------------------------------------------------------- + convert :: ToString a => Options -> a -> String convert Options{ outputStyle = LispStyle } = toLisp convert Options{ outputStyle = PlainStyle } = toPlain @@ -56,53 +47,3 @@ quote x = "\"" ++ x ++ "\"" addNewLine :: String -> String addNewLine = (++ "\n") - ----------------------------------------------------------------- - -withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) -withGHC body = ghandle ignore $ runGhc (Just libdir) body - where - ignore :: (MonadPlus m) => SomeException -> IO (m a) - ignore _ = return mzero - ----------------------------------------------------------------- - -initSession0 :: Options -> Ghc [PackageId] -initSession0 opt = getSessionDynFlags >>= - (>>= setSessionDynFlags) . setGhcFlags opt - -initSession :: Options -> [String] -> [FilePath] -> Bool -> Ghc LogReader -initSession opt cmdOpts idirs logging = do - dflags <- getSessionDynFlags - let opts = map noLoc cmdOpts - (dflags',_,_) <- parseDynamicFlags dflags opts - (dflags'',readLog) <- liftIO . (>>= setLogger logging) . setGhcFlags opt . setFlags dflags' $ idirs - setSessionDynFlags dflags'' - return readLog - ----------------------------------------------------------------- - -setFlags :: DynFlags -> [FilePath] -> DynFlags -setFlags d idirs = d' - where - d' = d { - packageFlags = ghcPackage : packageFlags d - , importPaths = idirs - , ghcLink = NoLink - , hscTarget = HscInterpreted - } - -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' - ----------------------------------------------------------------- - -setTargetFile :: (GhcMonad m) => String -> m () -setTargetFile file = do - target <- guessTarget file Nothing - setTargets [target] diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 223834f..66e6307 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -23,14 +23,37 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el ghc-command.el ghc-info.el ghc-ins-mod.el Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: List Browse Cabal CabalDev Check Info Lang Flag Lint Types ErrMsg Paths_ghc_mod + Other-Modules: Browse + Cabal + CabalDev + Check + ErrMsg + Flag + GHCApi + Gap + Info + Lang + Lint + List + Paths_ghc_mod + Types if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall - Build-Depends: base >= 4.0 && < 5, ghc, ghc-paths, transformers, syb, - process, directory, filepath, old-time, - hlint >= 1.7.1, regex-posix, Cabal + Build-Depends: base >= 4.0 && < 5 + , Cabal + , directory + , filepath + , ghc + , ghc-paths + , hlint >= 1.7.1 + , old-time + , process + , regex-posix + , syb + , transformers + Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git