From: simonpj@microsoft.com <unknown>
Date: Tue, 8 Aug 2006 12:32:11 +0000 (+0000)
Subject: Remove srcSpanStartLine/srcSpanEndLine crash
X-Git-Tag: Before_FC_branch_merge~261
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e944b32b8e8a88a52e22cb4daa0bdb4ebbb7793f

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

diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 51d4318..8ced456 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -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
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 1c5a559..d63c450 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -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))
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index c14909e..54ed7ba 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -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}