X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FSrcLoc.lhs;h=1a0198095985536eb691a2b060cacda485ba6449;hb=4922b3bf7e17c55b63f717fea2d9b9998bc071c6;hp=35c78a8412469632e3ad47c51aaacf2edd827ce1;hpb=2fe38b5fb0957f9428864afd69ad3ccd82fae3d0;p=ghc-hetmet.git diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 35c78a8..1a01980 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -72,6 +72,8 @@ module SrcLoc ( import Util import Outputable import FastString + +import Data.Bits \end{code} %************************************************************************ @@ -124,19 +126,22 @@ srcLocFile _other = (fsLit " Int srcLocLine (SrcLoc _ l _) = l -srcLocLine _other = panic "srcLocLine: unknown line" +srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s) -- | Raises an error when used on a "bad" 'SrcLoc' srcLocCol :: SrcLoc -> Int srcLocCol (SrcLoc _ _ c) = c -srcLocCol _other = panic "srcLocCol: unknown col" +srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s) --- | Move the 'SrcLoc' down by one line if the character is a newline --- and across by one character in any other case +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case advanceSrcLoc :: SrcLoc -> Char -> SrcLoc advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) + `shiftL` 3) + 1) advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) -advanceSrcLoc loc _ = loc -- Better than nothing +advanceSrcLoc loc _ = loc -- Better than nothing \end{code} %************************************************************************