Implementing "ghc-mod debug".

Debug.hs

@@ -0,0 +1,39 @@
+module Debug where
+
+import CabalApi
+import GHCApi
+import Control.Applicative
+import Data.List (intercalate)
+import Data.Maybe
+import Prelude
+import Types
+
+----------------------------------------------------------------
+
+debugInfo :: Options -> Cradle -> String -> IO String
+debugInfo opt cradle fileName = unlines <$> debug opt cradle fileName
+
+debug :: Options -> Cradle -> String -> IO [String]
+debug opt cradle fileName = do
+    (gopts, incDir, pkgs, langext) <-
+        if cabal then
+            fromCabalFile (ghcOpts opt) cradle
+          else
+            return (ghcOpts opt, [], [], [])
+    dflags <- getDynFlags
+    hdrext <- getHeaderExtension dflags fileName
+    let th = useTemplateHaskell (Just langext) hdrext
+    return [
+        "GHC version:         " ++ ghcVer
+      , "Current directory:   " ++ currentDir
+      , "Cabal file:          " ++ cabalFile
+      , "GHC options:         " ++ intercalate " " gopts
+      , "Include directories: " ++ intercalate " " incDir
+      , "Dependent packages:  " ++ intercalate ", " pkgs
+      , "Fast check:          " ++ if th then "No" else "Yes"
+      ]
+  where
+    ghcVer = cradleGHCVersion cradle
+    currentDir = cradleCurrentDir cradle
+    cabal = isJust $ cradleCabalFile cradle
+    cabalFile = fromMaybe "" $ cradleCabalFile cradle

GHCApi.hs

@@ -61,16 +61,24 @@ initSession :: Options
             -> FilePath
             -> Ghc LogReader
 initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do
-    dflags <- getSessionDynFlags
+    dflags0 <- getSessionDynFlags
-    hdrExts <- liftIO $ map unLoc <$> getOptionsFromFile dflags file
+    hdrExts <- liftIO $ getHeaderExtension dflags0 file
     let th = useTemplateHaskell mLangExts hdrExts
         opts = map noLoc cmdOpts
-    (dflags',_,_) <- parseDynamicFlags dflags opts
+    (dflags1,_,_) <- parseDynamicFlags dflags0 opts
-    (dflags'',readLog) <- liftIO . (>>= setLogger logging)
+    let dflags2 = modifyFlags opt dflags1 idirs mDepPkgs th
-                          . setGhcFlags opt . setFlags opt dflags' idirs mDepPkgs $ th
+    dflags3 <- setGhcFlags opt dflags2
-    _ <- setSessionDynFlags dflags''
+    (dflags4,readLog) <- liftIO $ setLogger logging dflags3
+    _ <- setSessionDynFlags dflags4
     return readLog
 
+----------------------------------------------------------------
+
+getHeaderExtension :: DynFlags -> FilePath -> IO [String]
+getHeaderExtension dflags file = map unLoc <$> getOptionsFromFile dflags file
+
+----------------------------------------------------------------
+
 useTemplateHaskell :: Maybe [LangExt] -> [HeaderExt] -> Bool
 useTemplateHaskell mLangExts hdrExts = th1 || th2
   where
@@ -79,25 +87,28 @@ useTemplateHaskell mLangExts hdrExts = th1 || th2
 
 ----------------------------------------------------------------
 
-setFlags :: Options -> DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> DynFlags
+modifyFlags :: Options -> DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> DynFlags
-setFlags opt d idirs mDepPkgs th
+modifyFlags opt d idirs mDepPkgs th
-  | expandSplice opt = dopt_set d' Opt_D_dump_splices
+  | expandSplice opt = dopt_set d'' Opt_D_dump_splices
-  | otherwise        = d'
+  | otherwise        = d''
   where
-    d' = addDevPkgs mDepPkgs $ d {
+    d' = d {
         importPaths = idirs
       , ghcLink     = if th then LinkInMemory else NoLink
       , hscTarget   = if th then HscInterpreted else HscNothing
       , flags       = flags d
       }
+    d'' = maybe d' (addDevPkgs d') mDepPkgs
 
-addDevPkgs :: Maybe [Package] -> DynFlags -> DynFlags
+addDevPkgs :: DynFlags -> [Package] -> DynFlags
-addDevPkgs Nothing df     = df
+addDevPkgs df pkgs = df''
-addDevPkgs (Just pkgs) df = df' {
-    packageFlags = map ExposePackage pkgs ++ packageFlags df
-  }
   where
     df' = dopt_set df Opt_HideAllPackages
+    df'' = df' {
+        packageFlags = map ExposePackage pkgs ++ packageFlags df
+      }
+
+----------------------------------------------------------------
 
 setGhcFlags :: Monad m => Options -> DynFlags -> m DynFlags
 setGhcFlags opt flagset =
@@ -110,3 +121,8 @@ setTargetFile :: (GhcMonad m) => String -> m ()
 setTargetFile file = do
     target <- guessTarget file Nothing
     setTargets [target]
+
+----------------------------------------------------------------
+
+getDynFlags :: IO DynFlags
+getDynFlags = runGhc (Just libdir) getSessionDynFlags

GHCMod.hs

@@ -9,6 +9,7 @@ import Control.Exception
 import Cradle
 import Data.Typeable
 import Data.Version
+import Debug
 import Flag
 import Info
 import Lang
@@ -98,6 +99,7 @@ main = flip catches handlers $ do
       "list"   -> listModules opt
       "check"  -> withFile (checkSyntax opt cradle) cmdArg1
       "expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1
+      "debug"  -> withFile (debugInfo opt cradle) 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