Commit e944b32b authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Remove srcSpanStartLine/srcSpanEndLine crash

srcSpanStartLine/srcSpanEndLine panic on UnhelpfulLoc. They should not
really be exported by SrcLoc at all, but unfortunately they are used in
Lexer.x, which knows enough to avoid the panic.

However the call in RnEnv didn't know, and the panic was triggered 
by Template Haskell spliced code.  This patch fixes it by exporting
the predicate RnEnv wanted, namely isOneLineSpan.
parent 60bbc36b
......@@ -26,16 +26,17 @@ module SrcLoc (
pprDefnLoc,
SrcSpan, -- Abstract
noSrcSpan,
noSrcSpan,
mkGeneralSrcSpan,
isGoodSrcSpan,
isGoodSrcSpan, isOneLineSpan,
mkSrcSpan, srcLocSpan,
combineSrcSpans,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
srcSpanStart, srcSpanEnd,
-- These are dubious exports, because they crash on some inputs,
-- used only in Lexer.x where we are sure what the Span looks like
srcSpanFile, srcSpanEndLine, srcSpanEndCol,
Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc
) where
......@@ -222,6 +223,19 @@ isGoodSrcSpan SrcSpanMultiLine{} = True
isGoodSrcSpan SrcSpanPoint{} = True
isGoodSrcSpan _ = False
isOneLineSpan :: SrcSpan -> Bool
-- True if the span is known to straddle more than one line
-- By default, it returns False
isOneLineSpan s
| isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s
| otherwise = False
--------------------------------------------------------
-- Don't export these four;
-- they panic on Imported, Unhelpful.
-- They are for internal use only
-- Urk! Some are needed for Lexer.x; see comment in export list
srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l
......@@ -241,13 +255,13 @@ srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
--------------------------------------------------------
srcSpanStart (ImportedSpan str) = ImportedLoc str
srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanStart s =
mkSrcLoc (srcSpanFile s)
(srcSpanStartLine s)
(srcSpanStartCol s)
srcSpanStart s = mkSrcLoc (srcSpanFile s)
(srcSpanStartLine s)
(srcSpanStartCol s)
srcSpanEnd (ImportedSpan str) = ImportedLoc str
srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
......
......@@ -58,7 +58,7 @@ import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey
import UniqSupply
import BasicTypes ( IPName, mapIPName )
import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine )
srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan )
import Outputable
import Util ( sortLe )
import ListSetOps ( removeDups )
......@@ -801,7 +801,7 @@ dupNamesErr descriptor located_names
L _ name1 = head located_names
locs = map getLoc located_names
big_loc = foldr1 combineSrcSpans locs
one_line = srcSpanStartLine big_loc == srcSpanEndLine big_loc
one_line = isOneLineSpan big_loc
locations | one_line = empty
| otherwise = ptext SLIT("Bound at:") <+>
vcat (map ppr (sortLe (<=) locs))
......
......@@ -30,6 +30,7 @@ import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
dupFieldErr, checkTupSize )
import DynFlags ( DynFlag(..) )
import BasicTypes ( FixityDirection(..) )
import SrcLoc ( SrcSpan )
import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
negateName, thenMName, bindMName, failMName )
......@@ -38,7 +39,6 @@ import PrelNames ( breakpointJumpName, breakpointCondJumpName
, undefined_RDR, breakpointIdKey, breakpointCondIdKey )
import UniqFM ( eltsUFM )
import DynFlags ( GhcMode(..) )
import SrcLoc ( srcSpanFile, srcSpanStartLine )
import Name ( isTyVarName )
#endif
import Name ( Name, nameOccName, nameIsLocalOrFrom )
......@@ -963,12 +963,14 @@ mkBreakpointExpr' breakpointFunc scope
mkExpr' fnName [] = inLoc (HsVar fnName)
mkExpr' fnName (arg:args)
= lHsApp (mkExpr' fnName args) (inLoc arg)
expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, HsLit msg]
mkScopeArg args
= unLoc $ mkExpr undef (map HsVar args)
msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc)))
expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, msg]
mkScopeArg args = unLoc $ mkExpr undef (map HsVar args)
msg = srcSpanLit sloc
return (expr, emptyFVs)
#endif
srcSpanLit :: SrcSpan -> HsExpr Name
srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
\end{code}
%************************************************************************
......@@ -983,8 +985,8 @@ mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
mkAssertErrorExpr
= getSrcSpanM `thenM` \ sloc ->
let
expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
msg = HsStringPrim (mkFastString (showSDoc (ppr sloc)))
expr = HsApp (L sloc (HsVar assertErrorName))
(L sloc (srcSpanLit sloc))
in
returnM (expr, emptyFVs)
\end{code}
......
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