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 , addTargetFiles
, getDynamicFlags , getDynamicFlags
, getSystemLibDir , getSystemLibDir
, withDynFlags
) where ) where
import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.CabalApi
@ -191,3 +192,12 @@ getDynamicFlags :: IO DynFlags
getDynamicFlags = do getDynamicFlags = do
mlibdir <- getSystemLibDir mlibdir <- getSystemLibDir
G.runGhc mlibdir G.getSessionDynFlags 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(..) , GapThing(..)
, fromTyThing , fromTyThing
, dumpSplicesFlag , dumpSplicesFlag
, setDeferTypeErrors
) where ) where
import Control.Applicative hiding (empty) import Control.Applicative hiding (empty)
@ -363,3 +364,12 @@ dumpSplicesFlag :: DumpFlag
dumpSplicesFlag :: DynFlag dumpSplicesFlag :: DynFlag
#endif #endif
dumpSplicesFlag = Opt_D_dump_splices 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 GHC.SYB.Utils (Stage(TypeChecker), everythingStaged)
import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle) import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle)
import Language.Haskell.GhcMod.GHCApi 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 qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Outputable (PprStyle) import Outputable (PprStyle)
import TcHsSyn (hsPatType) import TcHsSyn (hsPatType)
noWaringOptions :: [String]
noWaringOptions = ["-w:"]
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Obtaining information of a target expression. (GHCi's info:) -- | Obtaining information of a target expression. (GHCi's info:)
@ -37,8 +40,9 @@ infoExpr :: Options
-> FilePath -- ^ A target file. -> FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression. -> Expression -- ^ A Haskell expression.
-> IO String -> IO String
infoExpr opt cradle file expr = withGHC' $ infoExpr opt cradle file expr = withGHC' $ do
inModuleContext opt cradle file (info opt file expr) void $ initializeFlagsWithCradle opt cradle noWaringOptions False
info opt file expr
-- | Obtaining information of a target expression. (GHCi's info:) -- | Obtaining information of a target expression. (GHCi's info:)
info :: Options info :: Options
@ -47,12 +51,12 @@ info :: Options
-> Ghc String -> Ghc String
info opt file expr = convert opt <$> ghandle handler body info opt file expr = convert opt <$> ghandle handler body
where where
body = do body = inModuleContext file $ do
void $ Gap.setCtx file void $ Gap.setCtx file
sdoc <- Gap.infoThing expr sdoc <- Gap.infoThing expr
(dflag, style) <- getFlagStyle (dflag, style) <- getFlagStyle
return $ showPage dflag style sdoc 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 -- ^ Line number.
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> IO String -> IO String
typeExpr opt cradle file lineNo colNo = withGHC' $ typeExpr opt cradle file lineNo colNo = withGHC' $ do
inModuleContext opt cradle file (types opt file lineNo colNo) void $ initializeFlagsWithCradle opt cradle noWaringOptions False
types opt file lineNo colNo
-- | Obtaining type of a target expression. (GHCi's type:) -- | Obtaining type of a target expression. (GHCi's type:)
types :: Options types :: Options
@ -85,14 +90,13 @@ types :: Options
-> Ghc String -> Ghc String
types opt file lineNo colNo = convert opt <$> ghandle handler body types opt file lineNo colNo = convert opt <$> ghandle handler body
where where
body = do body = inModuleContext file $ do
modSum <- Gap.setCtx file modSum <- Gap.setCtx file
(dflag, style) <- getFlagStyle (dflag, style) <- getFlagStyle
srcSpanTypes <- getSrcSpanType modSum lineNo colNo srcSpanTypes <- getSrcSpanType modSum lineNo colNo
let tups = map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes let tups = map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
return $ tups return tups
handler (SomeException _) = return errmsg handler (SomeException _) = return []
errmsg = [] :: [((Int,Int,Int,Int),String)]
getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)] getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)]
getSrcSpanType modSum lineNo colNo = do getSrcSpanType modSum lineNo colNo = do
@ -131,12 +135,8 @@ pretty dflag style = showOneLine dflag style . Gap.typeForUser
---------------------------------------------------------------- ----------------------------------------------------------------
noWaringOptions :: [String] inModuleContext :: FilePath -> Ghc a -> Ghc a
noWaringOptions = ["-w:"] inModuleContext file action = withDynFlags setDeferTypeErrors $ do
inModuleContext :: Options -> Cradle -> FilePath -> Ghc String -> Ghc String
inModuleContext opt cradle file action = do
void $ initializeFlagsWithCradle opt cradle noWaringOptions False
setTargetFiles [file] setTargetFiles [file]
action action