Commit 7a59afce authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fall over more gracefully when there's a Template Haskell error

For a long time, Template Haskell has fallen over in a very un-graceful
way (i.e. panic) even when it encounters a programmer error.  In particular,
when DsMeta converts HsSyn to TH syntax, it may find Haskell code that
TH does not understand. This should be reported as a normal programmer
error, not with a compiler panic!

Originally the desugarer was supposed to never generate error
messages, but this TH desugaring thing does make it do so.  And in
fact, for other reasons, the desugarer now uses the TcRnIf monad, the
common monad used by the renamer, typechecker, interface checker, and
desugarer.  

This patch completes the job, by 
 - allowing the desugarer to generate errors
 - re-plumbing the error handling to take account of this
 - making DsMeta use the new facilities to report error gracefully

Quite a few lines of code are touched, but nothing deep is going on.

Fixes Trac# 760.
parent d5c6d002
......@@ -32,15 +32,12 @@ import PackageConfig ( thPackageId )
import RdrName ( GlobalRdrEnv )
import NameSet
import VarSet
import Bag ( Bag, isEmptyBag, emptyBag )
import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings,
errorsFound, WarnMsg )
import ErrUtils ( doIfSet, dumpIfSet_dyn )
import ListSetOps ( insertList )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef )
import Maybes ( catMaybes )
......@@ -55,7 +52,7 @@ import Util ( sortLe )
%************************************************************************
\begin{code}
deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
deSugar hsc_env
......@@ -78,9 +75,8 @@ deSugar hsc_env
= do { showPass dflags "Desugar"
-- Desugar the program
; ((all_prs, ds_rules, ds_fords), warns)
<- case ghcMode (hsc_dflags hsc_env) of
JustTypecheck -> return (([], [], NoStubs), emptyBag)
; mb_res <- case ghcMode dflags of
JustTypecheck -> return (Just ([], [], NoStubs))
_ -> initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
......@@ -89,11 +85,9 @@ deSugar hsc_env
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords)
}
-- If warnings are considered errors, leave.
; if errorsFound dflags (warns, emptyBag)
then return (warns, Nothing)
else do
; case mb_res of {
Nothing -> return Nothing ;
Just (all_prs, ds_rules, ds_fords) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
......@@ -161,40 +155,37 @@ deSugar hsc_env
mg_binds = ds_binds,
mg_foreign = ds_fords }
; return (warns, Just mod_guts)
}}
; return (Just mod_guts)
}}}
where
dflags = hsc_dflags hsc_env
ghci_mode = ghcMode (hsc_dflags hsc_env)
dflags = hsc_dflags hsc_env
ghci_mode = ghcMode (hsc_dflags hsc_env)
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> LHsExpr Id
-> IO CoreExpr
-> IO (Maybe CoreExpr)
-- Prints its own errors; returns Nothing if error occurred
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar"
-- Do desugaring
; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $
dsLExpr tc_expr
; mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $
dsLExpr tc_expr
-- Display any warnings
-- Note: if -Werror is used, we don't signal an error here.
; doIfSet (not (isEmptyBag ds_warns))
(printBagOfWarnings dflags ds_warns)
; case mb_core_expr of {
Nothing -> return Nothing ;
Just expr -> do {
-- Dump output
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
; return core_expr
}
where
dflags = hsc_dflags hsc_env
-- Dump output
dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
; return (Just expr) } } }
-- addExportFlags
-- Set the no-discard flag if either
......@@ -267,7 +258,7 @@ dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
; rhs' <- dsLExpr rhs
; case decomposeRuleLhs bndrs lhs' of {
Nothing -> do { dsWarn msg; return Nothing } ;
Nothing -> do { warnDs msg; return Nothing } ;
Just (bndrs', fn_id, args) -> do
-- Substitute the dict bindings eagerly,
......
......@@ -236,7 +236,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body
; case mb_lhs of
Nothing -> do { dsWarn msg; return Nothing }
Nothing -> do { warnDs msg; return Nothing }
Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
where
......
......@@ -220,7 +220,7 @@ dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _)
| HsVar funId <- fun
, idName funId `elem` [breakpointJumpName, breakpointCondJumpName]
, ids <- filter (isValidType . idType) (extractIds arg)
= do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
= do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids))
stablePtr <- ioToIOEnv $ newStablePtr ids
-- Yes, I know... I'm gonna burn in hell.
let Ptr addr# = castStablePtrToPtr stablePtr
......
This diff is collapsed.
......@@ -6,7 +6,7 @@
\begin{code}
module DsMonad (
DsM, mappM, mapAndUnzipM,
initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
foldlDs, foldrDs,
newTyVarsDs, newLocalName,
......@@ -22,7 +22,7 @@ module DsMonad (
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
-- Warnings
DsWarning, dsWarn,
DsWarning, warnDs, failWithDs,
-- Data types
DsMatchContext(..),
......@@ -37,9 +37,9 @@ import CoreSyn ( CoreExpr )
import HsSyn ( HsExpr, HsMatchContext, Pat )
import TcIface ( tcIfaceGlobal )
import RdrName ( GlobalRdrEnv )
import HscTypes ( TyThing(..), TypeEnv, HscEnv,
import HscTypes ( TyThing(..), TypeEnv, HscEnv(..),
tyThingId, tyThingTyCon, tyThingDataCon, mkPrintUnqualified )
import Bag ( emptyBag, snocBag, Bag )
import Bag ( emptyBag, snocBag )
import DataCon ( DataCon )
import TyCon ( TyCon )
import Id ( mkSysLocal, setIdUnique, Id )
......@@ -53,9 +53,8 @@ import Name ( Name, nameOccName )
import NameEnv
import OccName ( occNameFS )
import DynFlags ( DynFlags )
import ErrUtils ( WarnMsg, mkWarnMsg )
import Bag ( mapBag )
import ErrUtils ( Messages, mkWarnMsg, mkErrMsg,
printErrorsAndWarnings, errorsFound )
import DATA_IOREF ( newIORef, readIORef )
infixr 9 `thenDs`
......@@ -131,7 +130,8 @@ type DsWarning = (SrcSpan, SDoc)
data DsGblEnv = DsGblEnv {
ds_mod :: Module, -- For SCC profiling
ds_warns :: IORef (Bag DsWarning), -- Warning messages
ds_unqual :: PrintUnqualified,
ds_msgs :: IORef Messages, -- Warning messages
ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
}
......@@ -153,33 +153,57 @@ data DsMetaVal
| Splice (HsExpr Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
-- initDs returns the UniqSupply out the end (not just the result)
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
-> IO (a, Bag WarnMsg)
-> IO (Maybe a)
-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env thing_inside
= do { warn_var <- newIORef emptyBag
; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
; gbl_env = DsGblEnv { ds_mod = mod,
ds_if_env = (if_genv, if_lenv),
ds_warns = warn_var }
; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan } }
; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
; warns <- readIORef warn_var
; return (res, mapBag mk_warn warns)
}
where
print_unqual = mkPrintUnqualified rdr_env
mk_warn :: (SrcSpan,SDoc) -> WarnMsg
mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
= do { msg_var <- newIORef (emptyBag, emptyBag)
; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
tryM thing_inside -- Catch exceptions (= errors during desugaring)
-- Display any errors and warnings
-- Note: if -Werror is used, we don't signal an error here.
; let dflags = hsc_dflags hsc_env
; msgs <- readIORef msg_var
; printErrorsAndWarnings dflags msgs
; let final_res | errorsFound dflags msgs = Nothing
| otherwise = case either_res of
Right res -> Just res
Left exn -> pprPanic "initDs" (text (show exn))
-- The (Left exn) case happens when the thing_inside throws
-- a UserError exception. Then it should have put an error
-- message in msg_var, so we just discard the exception
; return final_res }
initDsTc :: DsM a -> TcM a
initDsTc thing_inside
= do { this_mod <- getModule
; tcg_env <- getGblEnv
; msg_var <- getErrsVar
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside }
mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv
-> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs mod rdr_env type_env msg_var
= (gbl_env, lcl_env)
where
if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod,
ds_if_env = (if_genv, if_lenv),
ds_unqual = mkPrintUnqualified rdr_env,
ds_msgs = msg_var }
lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan }
\end{code}
%************************************************************************
......@@ -241,12 +265,22 @@ getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
dsWarn :: SDoc -> DsM ()
dsWarn warn = do { env <- getGblEnv
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
; let msg = mkWarnMsg loc (ds_unqual env)
(ptext SLIT("Warning:") <+> warn)
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
where
msg = ptext SLIT("Warning:") <+> warn
failWithDs :: SDoc -> DsM a
failWithDs err
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkErrMsg loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
; failM }
where
\end{code}
\begin{code}
......
......@@ -91,7 +91,7 @@ The next two functions create the warning message.
\begin{code}
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
dsShadowWarn ctx@(DsMatchContext kind loc) qs
= putSrcSpanDs loc (dsWarn warn)
= putSrcSpanDs loc (warnDs warn)
where
warn | qs `lengthExceeds` maximum_output
= pp_context ctx (ptext SLIT("are overlapped"))
......@@ -104,7 +104,7 @@ dsShadowWarn ctx@(DsMatchContext kind loc) qs
dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
= putSrcSpanDs loc (dsWarn warn)
= putSrcSpanDs loc (warnDs warn)
where
warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
(\f -> hang (ptext SLIT("Patterns not matched:"))
......
......@@ -25,11 +25,11 @@ module HscMain
#include "HsVersions.h"
#ifdef GHCI
import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType )
import Module ( Module )
import HsSyn ( Stmt(..), LStmt, LHsType )
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
import CoreSyn ( CoreExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
......@@ -41,7 +41,7 @@ import PrelNames ( iNTERACTIVE )
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import SrcLoc ( noSrcLoc, getLoc )
import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan )
import VarEnv ( emptyTidyEnv )
#endif
......@@ -462,10 +462,7 @@ hscFileFrontEnd =
-------------------
-- DESUGAR
-------------------
-> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
deSugar hsc_env tc_result
printBagOfWarnings dflags warns
return maybe_ds_result
-> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result
--------------------------------------------------------------
-- Simplifiers
......@@ -805,14 +802,22 @@ hscStmt hsc_env stmt
Nothing -> return Nothing ;
Just (new_ic, bound_names, tc_expr) -> do {
-- Desugar it
; let rdr_env = ic_rn_gbl_env new_ic
type_env = ic_type_env new_ic
; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
; case mb_ds_expr of {
Nothing -> return Nothing ;
Just ds_expr -> do {
-- Then desugar, code gen, and link it
; hval <- compileExpr hsc_env iNTERACTIVE
(ic_rn_gbl_env new_ic)
(ic_type_env new_ic)
tc_expr
; let src_span = srcLocSpan interactiveSrcLoc
; hval <- compileExpr hsc_env src_span ds_expr
; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval))
}}}}}
}}}}}}}
hscTcExpr -- Typecheck an expression (but don't run it)
:: HscEnv
......@@ -892,19 +897,12 @@ hscParseThing parser dflags str
\begin{code}
#ifdef GHCI
compileExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> LHsExpr Id
-> IO HValue
compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
compileExpr hsc_env this_mod rdr_env type_env tc_expr
compileExpr hsc_env srcspan ds_expr
= do { let { dflags = hsc_dflags hsc_env ;
lint_on = dopt Opt_DoCoreLinting dflags ;
!srcspan = getLoc tc_expr }
lint_on = dopt Opt_DoCoreLinting dflags }
-- Desugar it
; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-- Flatten it
; flat_expr <- flattenExpr hsc_env ds_expr
......
......@@ -124,13 +124,14 @@ import HscTypes ( InteractiveContext(..),
Dependencies(..) )
import BasicTypes ( Fixity, RecFlag(..) )
import SrcLoc ( unLoc )
import Data.Maybe ( isNothing )
#endif
import FastString ( mkFastString )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
import Data.Maybe ( isJust, isNothing )
import Data.Maybe ( isJust )
\end{code}
......
......@@ -55,6 +55,8 @@ import Id ( idName, globalIdDetails )
import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
import DsExpr ( dsLExpr )
import DsMonad ( initDsTc )
import ErrUtils ( Message )
import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
import Outputable
......@@ -368,17 +370,14 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
-> LHsExpr Id -- Of type X
-> TcM hs_syn -- Of type t
runMeta convert expr
= do { hsc_env <- getTopEnv
; tcg_env <- getGblEnv
; this_mod <- getModule
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
= do { -- Desugar
ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
; either_hval <- tryM $ ioToTcRn $
HscMain.compileExpr
hsc_env this_mod
rdr_env type_env expr
HscMain.compileExpr hsc_env src_span ds_expr
; case either_hval of {
Left exn -> failWithTc (mk_msg "compile and link" exn) ;
Right hval -> do
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment