Thanks to DeferTypeErrors, info/type can work even if the file contains errors.

This commit is contained in:
Kazu Yamamoto 2014-04-26 11:43:30 +09:00
parent 66a5123f8c
commit c8fbdcfa2f
3 changed files with 37 additions and 17 deletions

View File

@ -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

View File

@ -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

View File

@ -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