Adaptor layer for GHC API.

Browse.hs

@@ -4,6 +4,7 @@ import Control.Applicative
 import Data.Char
 import Data.List
 import GHC
+import GHCApi
 import Name
 import Types
 

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

Check.hs

@@ -6,6 +6,7 @@ import CoreMonad
 import ErrMsg
 import Exception
 import GHC
+import GHCApi
 import Prelude hiding (catch)
 import Types
 

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

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
+listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option
+                                     | option <- Gap.fOptions
                                      , prefix <- ["","no-"]
                                      ]

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]

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

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

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

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

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]

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