summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
60bbc36)
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.
pprDefnLoc,
SrcSpan, -- Abstract
pprDefnLoc,
SrcSpan, -- Abstract
+ 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
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
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
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 )
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))
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 )
, 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 )
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}
%************************************************************************
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}