{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} -------------------------------------------------------------------------------- -- This is an adaption of GHC's SrcLoc.lhs -- -- Copyright 2004, The University Court of the University of Glasgow. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions -- are met: -- * Redistributions of source code must retain the above -- * copyright notice, this list of conditions and the following -- * disclaimer. -- * Redistributions in binary form must reproduce the above -- * copyright notice, this list of conditions and the following -- * disclaimer in the documentation and/or other materials -- * provided with the distribution. -- * Neither name of the University nor the names of its -- * contributors may be used to endorse or promote products -- * derived from this software without specific prior written -- * permission. -- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY -- OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED -- WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -- DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE -- UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -- INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED -- OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- module Intel.Cnc.Spec.SrcLoc where import Data.Data import Data.Bits import System.IO import System.IO.Unsafe import Text.PrettyPrint.HughesPJClass -- I don't actually see why we would need interned strings for -- filenames. How many unique files are they? They should be shared -- properly even as normal strings. And how often do they need to be -- compared? --type FileNameString = Atom type FileNameString = String mkFileNameString = id data SrcLoc = SrcLoc { srcFilename :: FileNameString, srcLine :: {-# UNPACK #-} !Int, srcColumn :: {-# UNPACK #-} !Int } | UnhelpfulLoc FileNameString -- Just a general indication deriving (Eq,Ord,Show,Typeable,Data) -- data SrcLoc -- -- = SrcLoc Atom -- A precise location (file name) -- = SrcLoc String -- A precise location (file name) -- {-# UNPACK #-} !Int -- line number, begins at 1 -- {-# UNPACK #-} !Int -- column number, begins at 1 -- deriving (Eq,Ord,Show,Data,Typeable) --data Loc a = Loc SrcLoc a deriving (Eq,Ord,Show) --unknownLoc = SrcLoc "" 0 0 mkSrcLoc :: FileNameString -> Int -> Int -> SrcLoc mkSrcLoc x line col = SrcLoc x line col -- | Built-in "bad" 'SrcLoc' values for particular locations noSrcLoc, generatedSrcLoc :: SrcLoc -- interactiveSrcLoc noSrcLoc = UnhelpfulLoc (mkFileNameString "") generatedSrcLoc = UnhelpfulLoc (mkFileNameString "") --interactiveSrcLoc = UnhelpfulLoc (mkFileNameString "") -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location mkGeneralSrcLoc :: FileNameString -> SrcLoc mkGeneralSrcLoc = UnhelpfulLoc -- | 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) {- | A SrcSpan delimits a portion of a text file. It could be represented by a pair of (line,column) coordinates, but in fact we optimise slightly by using more compact representations for single-line and zero-length spans, both of which are quite common. The end position is defined to be the column /after/ the end of the span. That is, a span of (1,1)-(1,2) is one character long, and a span of (1,1)-(1,1) is zero characters long. -} data SrcSpan = SrcSpanOneLine -- a common case: a single line { srcSpanFile :: !FileNameString, srcSpanLine :: {-# UNPACK #-} !Int, srcSpanSCol :: {-# UNPACK #-} !Int, srcSpanECol :: {-# UNPACK #-} !Int } | SrcSpanMultiLine { srcSpanFile :: !FileNameString, srcSpanSLine :: {-# UNPACK #-} !Int, srcSpanSCol :: {-# UNPACK #-} !Int, srcSpanELine :: {-# UNPACK #-} !Int, srcSpanECol :: {-# UNPACK #-} !Int } | SrcSpanPoint { srcSpanFile :: !FileNameString, srcSpanLine :: {-# UNPACK #-} !Int, srcSpanCol :: {-# UNPACK #-} !Int } | UnhelpfulSpan !FileNameString -- Just a general indication -- also used to indicate an empty span deriving (Eq,Typeable,Data) -- | Create a 'SrcSpan' corresponding to a single point srcLocSpan :: SrcLoc -> SrcSpan srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col -- | Create a 'SrcSpan' between two points in a file mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str mkSrcSpan loc1 loc2 | line1 == line2 = if col1 == col2 then SrcSpanPoint file line1 col1 else SrcSpanOneLine file line1 col1 col2 | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 where line1 = srcLine loc1 line2 = srcLine loc2 col1 = srcColumn loc1 col2 = srcColumn loc2 file = srcFilename loc1 -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l combineSrcSpans start end = case line1 `compare` line2 of EQ -> case col1 `compare` col2 of EQ -> SrcSpanPoint file line1 col1 LT -> SrcSpanOneLine file line1 col1 col2 GT -> SrcSpanOneLine file line1 col2 col1 LT -> SrcSpanMultiLine file line1 col1 line2 col2 GT -> SrcSpanMultiLine file line2 col2 line1 col1 where line1 = srcSpanStartLine start col1 = srcSpanStartCol start line2 = srcSpanEndLine end col2 = srcSpanEndCol end file = srcSpanFile start -- | Test if a 'SrcSpan' is "good", i.e. has precise location information isGoodSrcSpan :: SrcSpan -> Bool isGoodSrcSpan SrcSpanOneLine{} = True isGoodSrcSpan SrcSpanMultiLine{} = True isGoodSrcSpan SrcSpanPoint{} = True isGoodSrcSpan _ = False isOneLineSpan :: SrcSpan -> Bool -- ^ True if the span is known to straddle only one line. -- For "bad" 'SrcSpan', it returns False isOneLineSpan s | isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s | otherwise = False -- | Raises an error when used on a "bad" 'SrcSpan' srcSpanStartLine :: SrcSpan -> Int -- | Raises an error when used on a "bad" 'SrcSpan' srcSpanEndLine :: SrcSpan -> Int -- | Raises an error when used on a "bad" 'SrcSpan' srcSpanStartCol :: SrcSpan -> Int -- | Raises an error when used on a "bad" 'SrcSpan' srcSpanEndCol :: SrcSpan -> Int panic = error srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine" srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine" srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol" srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol" -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str srcSpanStart s = mkSrcLoc (srcSpanFile s) (srcSpanStartLine s) (srcSpanStartCol s) srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str srcSpanEnd s = mkSrcLoc (srcSpanFile s) (srcSpanEndLine s) (srcSpanEndCol s) -- | Obtains the filename for a 'SrcSpan' if it is "good" srcSpanFileName_maybe :: SrcSpan -> Maybe FileNameString srcSpanFileName_maybe (SrcSpanOneLine { srcSpanFile = nm }) = Just nm srcSpanFileName_maybe (SrcSpanMultiLine { srcSpanFile = nm }) = Just nm srcSpanFileName_maybe (SrcSpanPoint { srcSpanFile = nm}) = Just nm -- [2010.07.23] Hmm... why was this written to ignore the file that's there? srcSpanFileName_maybe _ = Nothing -- [2010.07.23] Should replace it with this: srcSpanFileName :: SrcSpan -> FileNameString srcSpanFileName (SrcSpanOneLine { srcSpanFile = nm }) = nm srcSpanFileName (SrcSpanMultiLine { srcSpanFile = nm }) = nm srcSpanFileName (SrcSpanPoint { srcSpanFile = nm}) = nm srcSpanFileName (UnhelpfulSpan file) = file srcSpanSetFileName :: FileNameString -> SrcSpan -> SrcSpan srcSpanSetFileName file (s@SrcSpanOneLine{..}) = s { srcSpanFile = file } srcSpanSetFileName file (s@SrcSpanMultiLine{..}) = s { srcSpanFile = file } srcSpanSetFileName file (s@SrcSpanPoint{..}) = s { srcSpanFile = file } srcSpanSetFileName file (UnhelpfulSpan _) = UnhelpfulSpan file -- We want to order SrcSpans first by the start point, then by the end point. instance Ord SrcSpan where a `compare` b = (srcSpanStart a `compare` srcSpanStart b) `thenCmp` (srcSpanEnd a `compare` srcSpanEnd b) -- | Determines whether a span encloses a given line and column index spans :: SrcSpan -> (Int, Int) -> Bool spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span where loc = mkSrcLoc (srcSpanFile span) l c -- | Determines whether a span is enclosed by another one isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other -> SrcSpan -- ^ The span it may be enclosed by -> Bool isSubspanOf src parent | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False | otherwise = srcSpanStart parent <= srcSpanStart src && srcSpanEnd parent >= srcSpanEnd src ---------------------------------------------------------------------------------------------------- instance Pretty SrcLoc where pPrint (UnhelpfulLoc s) = pPrint s pPrint (SrcLoc f l c) = (if null f then empty else pPrint f) <+> text "line " <> int l <> text ", column " <> int c -- Eventually this should print a snippet of the file: -- Hmm... I'm not sure about columns. instance Pretty SrcSpan where pPrint span = -- NOTE: I thought this was zero-indexed but it seems to be one-indexed. Good. let startL = srcLine$ srcSpanStart span startC = srcColumn$ srcSpanStart span endL = srcLine$ srcSpanEnd span endC = srcColumn$ srcSpanEnd span in sep [text ("file " ++ (srcFilename $ srcSpanStart span)), if (startL,startC) == (endL,endC) then text $ "at line:column " ++ (show startL) ++ ":" ++ (show startC) else text $ "between line:column " ++ (show startL) ++ ":" ++ (show startC) ++ " and " ++ (show endL) ++ ":" ++ (show endC)] -- This gives a detailed (multiline) printout with a snippet of the original file. showSpanDetailed :: SrcSpan -> String showSpanDetailed span = "\nLocation:\n" ++ (show$ nest 4$ pPrint span) ++ "\n\nContext in original file:\n" ++ "----------------------------------------\n" ++ (indent_lines 4 $ unsafePerformIO (snippet span)) ++ "----------------------------------------\n" -- A constant, how many lines of context do we want: snippet_lines = 7 -- If we wanted to get all fancy we could use ascii codes to bold or -- color the actual characters within this context: snippet :: SrcSpan -> IO String snippet span = do let file = srcSpanFileName span line1 = srcLine$ srcSpanStart span line2 = srcLine$ srcSpanEnd span -- If the span is less than snippet_lines long we could provide context AROUND it... not currently though. numlines = min snippet_lines (line2 - line1 + 1) handle <- openFile file ReadMode contents <- hGetContents handle let snip = take numlines $ drop (line1-1) $ lines contents return$ unlines snip indent_lines n str = unlines $ map ((take n $ repeat ' ')++) (lines str) -- pPrint (srcSpanStart span) <> text " : " <> -- pPrint (srcSpanEnd span) -- Might as well use the pretty version for plain show: instance Show SrcSpan where show = show . pPrint -- An error with a location. locErr span msg = error$ msg ++ "\n Location: "++ (show span) ---------------------------------------------------------------------------------------------------- infixr 9 `thenCmp` thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} thenCmp EQ ordering = ordering thenCmp ordering _ = ordering ---------------------------------------------------------------------------------------------------- -- Type class for decorated things. ---------------------------------------------------------------------------------------------------- -- | Everything that is decorated with annotations (e.g. source -- locations) should be able to provide them or strip them. -- This replicates most of the benefit of using a "Located" type. -- -- Some generic programming could probably provide this for free. class Decorated t where mapDecor :: (a -> b) -> t a -> t b getDecor :: t a -> a stripDecor :: t a -> t () stripDecor = mapDecor (\_ -> ())