[project @ 2000-04-20 12:50:18 by simonpj]

[ghc-hetmet.git] / ghc / compiler / basicTypes / SrcLoc.lhs

diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index 0b2439b..3dccd51 100644 (file)
--- a/ghc/compiler/basicTypes/SrcLoc.lhs
+++ b/ghc/compiler/basicTypes/SrcLoc.lhs
@@ -21,13 +21,15 @@ module SrcLoc (
 
        mkGeneratedSrcLoc,      -- Code generated within the compiler
 
-       incSrcLine,
+       incSrcLine, replaceSrcLine,
        
-       srcLocFile              -- return the file name part.
+       srcLocFile,             -- return the file name part.
+       srcLocLine              -- return the line part.
     ) where
 
 #include "HsVersions.h"
 
+import Util            ( thenCmp )
 import Outputable
 import FastString      ( unpackFS )
 import GlaExts         ( Int(..), (+#) )
@@ -77,9 +79,15 @@ isNoSrcLoc other    = False
 srcLocFile :: SrcLoc -> FAST_STRING
 srcLocFile (SrcLoc fname _) = fname
 
+srcLocLine :: SrcLoc -> FAST_INT
+srcLocLine (SrcLoc _ l) = l
+
 incSrcLine :: SrcLoc -> SrcLoc
 incSrcLine (SrcLoc s l) = SrcLoc s (l +# 1#)
 incSrcLine loc         = loc
+
+replaceSrcLine :: SrcLoc -> FAST_INT -> SrcLoc
+replaceSrcLine (SrcLoc s _) l = SrcLoc s l
 \end{code}
 
 %************************************************************************
@@ -89,6 +97,29 @@ incSrcLine loc       = loc
 %************************************************************************
 
 \begin{code}
+-- SrcLoc is an instance of Ord so that we can sort error messages easily
+instance Eq SrcLoc where
+  loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of
+                  EQ    -> True
+                  other -> False
+
+instance Ord SrcLoc where
+  compare = cmpSrcLoc
+
+cmpSrcLoc NoSrcLoc NoSrcLoc = EQ
+cmpSrcLoc NoSrcLoc other    = LT
+
+cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2
+cmpSrcLoc (UnhelpfulSrcLoc s1) other               = GT
+
+cmpSrcLoc (SrcLoc s1 l1) NoSrcLoc           = GT
+cmpSrcLoc (SrcLoc s1 l1) (UnhelpfulSrcLoc _) = LT
+cmpSrcLoc (SrcLoc s1 l1) (SrcLoc s2 l2)      = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2)
+                                            where
+                                               l1 `cmpline` l2 | l1 <#  l2 = LT
+                                                               | l1 ==# l2 = EQ
+                                                               | otherwise = GT 
+                                         
 instance Outputable SrcLoc where
     ppr (SrcLoc src_path src_line)
       = getPprStyle $ \ sty ->
@@ -101,12 +132,8 @@ instance Outputable SrcLoc where
           hcat [text "{-# LINE ", int IBOX(src_line), space,
                 char '\"', ptext src_path, text " #-}"]
       where
-       src_file = remove_directory_prefix (unpackFS src_path)
-
-       remove_directory_prefix path = case break (== '/') path of
-                                         (filename, [])           -> filename
-                                         (prefix,   slash : rest) -> ASSERT( slash == '/' )
-                                                                     remove_directory_prefix rest
+       src_file = unpackFS src_path    -- Leave the directory prefix intact,
+                                       -- so emacs can find the file
 
     ppr (UnhelpfulSrcLoc s) = ptext s