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 (file)
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -26,16 +26,17 @@ module SrcLoc (
        pprDefnLoc,
 
        SrcSpan,                -- Abstract
        pprDefnLoc,
 
        SrcSpan,                -- Abstract

-       noSrcSpan,
+       noSrcSpan, 

        mkGeneralSrcSpan, 
        mkGeneralSrcSpan, 

-       isGoodSrcSpan,
+       isGoodSrcSpan, isOneLineSpan,

        mkSrcSpan, srcLocSpan,
        combineSrcSpans,
        mkSrcSpan, srcLocSpan,
        combineSrcSpans,

-       srcSpanFile,
-       srcSpanStartLine, srcSpanEndLine,
-       srcSpanStartCol, srcSpanEndCol,

        srcSpanStart, srcSpanEnd,
 
        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
 
        Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc
     ) where
 

@@ -222,6 +223,19 @@ isGoodSrcSpan SrcSpanMultiLine{} = True
 isGoodSrcSpan SrcSpanPoint{} = True
 isGoodSrcSpan _ = False
 
 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
 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"
 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 (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
 
 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 (file)
--- 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,
 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 )
 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
     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))
     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 (file)
--- 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(..) )
                          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 )
 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(..) )
                         , undefined_RDR, breakpointIdKey, breakpointCondIdKey )
 import UniqFM           ( eltsUFM )
 import DynFlags         ( GhcMode(..) )

-import SrcLoc           ( srcSpanFile, srcSpanStartLine )

 import Name             ( isTyVarName )
 #endif
 import Name            ( Name, nameOccName, nameIsLocalOrFrom )
 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)
              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
          return (expr, emptyFVs)
 #endif

+
+srcSpanLit :: SrcSpan -> HsExpr Name
+srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -983,8 +985,8 @@ mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
 mkAssertErrorExpr
   = getSrcSpanM                        `thenM` \ sloc ->
     let
 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}
     in
     returnM (expr, emptyFVs)
 \end{code}