From c8fbdcfa2f332cd6325961f6b2b208198e452ac0 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Sat, 26 Apr 2014 11:43:30 +0900
Subject: [PATCH] Thanks to DeferTypeErrors, info/type can work even if the
 file contains errors.

---
 Language/Haskell/GhcMod/GHCApi.hs | 10 +++++++++
 Language/Haskell/GhcMod/Gap.hs    | 10 +++++++++
 Language/Haskell/GhcMod/Info.hs   | 34 +++++++++++++++----------------
 3 files changed, 37 insertions(+), 17 deletions(-)

diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs
index 3fb47e8..94ae35b 100644
--- a/Language/Haskell/GhcMod/GHCApi.hs
+++ b/Language/Haskell/GhcMod/GHCApi.hs
@@ -8,6 +8,7 @@ module Language.Haskell.GhcMod.GHCApi (
   , addTargetFiles
   , getDynamicFlags
   , getSystemLibDir
+  , withDynFlags
   ) where
 
 import Language.Haskell.GhcMod.CabalApi
@@ -191,3 +192,12 @@ getDynamicFlags :: IO DynFlags
 getDynamicFlags = do
     mlibdir <- getSystemLibDir
     G.runGhc mlibdir G.getSessionDynFlags
+
+withDynFlags :: (DynFlags -> DynFlags) -> Ghc a -> Ghc a
+withDynFlags setFlag body = G.gbracket setup teardown (\_ -> body)
+  where
+    setup = do
+        dflag <- G.getSessionDynFlags
+        void $ G.setSessionDynFlags (setFlag dflag)
+        return dflag
+    teardown = void . G.setSessionDynFlags
diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs
index ef33e29..5762ca3 100644
--- a/Language/Haskell/GhcMod/Gap.hs
+++ b/Language/Haskell/GhcMod/Gap.hs
@@ -30,6 +30,7 @@ module Language.Haskell.GhcMod.Gap (
   , GapThing(..)
   , fromTyThing
   , dumpSplicesFlag
+  , setDeferTypeErrors
   ) where
 
 import Control.Applicative hiding (empty)
@@ -363,3 +364,12 @@ dumpSplicesFlag :: DumpFlag
 dumpSplicesFlag :: DynFlag
 #endif
 dumpSplicesFlag = Opt_D_dump_splices
+
+setDeferTypeErrors :: DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ >= 707
+setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors
+#elif __GLASGOW_HASKELL__ >= 706
+setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors
+#else
+setDeferTypeErrors = id
+#endif
diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs
index edddf4d..2203192 100644
--- a/Language/Haskell/GhcMod/Info.hs
+++ b/Language/Haskell/GhcMod/Info.hs
@@ -23,12 +23,15 @@ import qualified GHC as G
 import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
 import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
 import Language.Haskell.GhcMod.GHCApi
-import Language.Haskell.GhcMod.Gap (HasType(..))
+import Language.Haskell.GhcMod.Gap (HasType(..), setDeferTypeErrors)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
 import Outputable (PprStyle)
 import TcHsSyn (hsPatType)
 
+noWaringOptions :: [String]
+noWaringOptions = ["-w:"]
+
 ----------------------------------------------------------------
 
 -- | Obtaining information of a target expression. (GHCi's info:)
@@ -37,8 +40,9 @@ infoExpr :: Options
          -> FilePath     -- ^ A target file.
          -> Expression   -- ^ A Haskell expression.
          -> IO String
-infoExpr opt cradle file expr = withGHC' $
-    inModuleContext opt cradle file (info opt file expr)
+infoExpr opt cradle file expr = withGHC' $ do
+    void $ initializeFlagsWithCradle opt cradle noWaringOptions False
+    info opt file expr
 
 -- | Obtaining information of a target expression. (GHCi's info:)
 info :: Options
@@ -47,12 +51,12 @@ info :: Options
      -> Ghc String
 info opt file expr = convert opt <$> ghandle handler body
   where
-    body = do
+    body = inModuleContext file $ do
         void $ Gap.setCtx file
         sdoc <- Gap.infoThing expr
         (dflag, style) <- getFlagStyle
         return $ showPage dflag style sdoc
-    handler (SomeException e) = return $ "Cannot show info (" ++ show e ++ ")"
+    handler (SomeException _) = return "Cannot show info"
 
 ----------------------------------------------------------------
 
@@ -74,8 +78,9 @@ typeExpr :: Options
          -> Int          -- ^ Line number.
          -> Int          -- ^ Column number.
          -> IO String
-typeExpr opt cradle file lineNo colNo = withGHC' $
-    inModuleContext opt cradle file (types opt file lineNo colNo)
+typeExpr opt cradle file lineNo colNo = withGHC' $ do
+    void $ initializeFlagsWithCradle opt cradle noWaringOptions False
+    types opt file lineNo colNo
 
 -- | Obtaining type of a target expression. (GHCi's type:)
 types :: Options
@@ -85,14 +90,13 @@ types :: Options
       -> Ghc String
 types opt file lineNo colNo = convert opt <$> ghandle handler body
   where
-    body = do
+    body = inModuleContext file $ do
         modSum <- Gap.setCtx file
         (dflag, style) <- getFlagStyle
         srcSpanTypes <- getSrcSpanType modSum lineNo colNo
         let tups = map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
-        return $ tups
-    handler (SomeException _) = return errmsg
-    errmsg = [] :: [((Int,Int,Int,Int),String)]
+        return tups
+    handler (SomeException _) = return []
 
 getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
 getSrcSpanType modSum lineNo colNo = do
@@ -131,12 +135,8 @@ pretty dflag style = showOneLine dflag style . Gap.typeForUser
 
 ----------------------------------------------------------------
 
-noWaringOptions :: [String]
-noWaringOptions = ["-w:"]
-
-inModuleContext :: Options -> Cradle -> FilePath -> Ghc String -> Ghc String
-inModuleContext opt cradle file action = do
-    void $ initializeFlagsWithCradle opt cradle noWaringOptions False
+inModuleContext :: FilePath -> Ghc a -> Ghc a
+inModuleContext file action = withDynFlags setDeferTypeErrors $ do
     setTargetFiles [file]
     action