From: Ian Lynagh <igloo@earth.li>
Date: Sun, 20 Jan 2008 19:30:02 +0000 (+0000)
Subject: Normalise FilePaths before printing them
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9ee6397787a1400c63e3d807de5996ca6ee9ecc8

Normalise FilePaths before printing them
---

diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 44c51f3..d2df86b 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -43,6 +43,7 @@ module SrcLoc (
 import Util
 import Outputable
 import FastString
+import System.FilePath
 \end{code}
 
 %************************************************************************
@@ -129,17 +130,20 @@ cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
   = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
 cmpSrcLoc (SrcLoc _ _ _) _other = GT
 
+pprFastFilePath :: FastString -> SDoc
+pprFastFilePath path = text $ normalise $ unpackFS path
+
 instance Outputable SrcLoc where
     ppr (SrcLoc src_path src_line src_col)
       = getPprStyle $ \ sty ->
         if userStyle sty || debugStyle sty then
-	   hcat [ ftext src_path, char ':', 
-		  int src_line,
-		  char ':', int src_col
-		]
-	else
-	   hcat [text "{-# LINE ", int src_line, space,
-		 char '\"', ftext src_path, text " #-}"]
+            hcat [ pprFastFilePath src_path, char ':', 
+                   int src_line,
+                   char ':', int src_col
+                 ]
+        else
+            hcat [text "{-# LINE ", int src_line, space,
+                  char '\"', pprFastFilePath src_path, text " #-}"]
 
     ppr (UnhelpfulLoc s)  = ftext s
 \end{code}
@@ -316,15 +320,15 @@ instance Outputable SrcSpan where
     ppr span
       = getPprStyle $ \ sty ->
         if userStyle sty || debugStyle sty then
-	   pprUserSpan span
-	else
-	   hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
-		 char '\"', ftext (srcSpanFile span), text " #-}"]
+           pprUserSpan span
+        else
+           hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
+                 char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
 
 
 pprUserSpan :: SrcSpan -> SDoc
 pprUserSpan (SrcSpanOneLine src_path line start_col end_col)
-  = hcat [ ftext src_path, char ':', 
+  = hcat [ pprFastFilePath src_path, char ':', 
 	   int line,
 	   char ':', int start_col
 	 ]
@@ -335,7 +339,7 @@ pprUserSpan (SrcSpanOneLine src_path line start_col end_col)
 	  else  char '-' <> int (end_col-1)
 
 pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol)
-  = hcat [ ftext src_path, char ':', 
+  = hcat [ pprFastFilePath src_path, char ':', 
 		  parens (int sline <> char ',' <>  int scol),
 		  char '-',
 		  parens (int eline <> char ',' <>  
@@ -343,7 +347,7 @@ pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol)
 		]
 
 pprUserSpan (SrcSpanPoint src_path line col)
-  = hcat [ ftext src_path, char ':', 
+  = hcat [ pprFastFilePath src_path, char ':', 
 	   int line,
 	   char ':', int col
 	 ]
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 7ad34ac..6b1d053 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -115,6 +115,7 @@ import UniqSupply	( UniqSupply )
 import FastString	( FastString )
 import StringBuffer	( StringBuffer )
 
+import System.FilePath
 import System.Time	( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )
@@ -1342,14 +1343,15 @@ instance Outputable ModSummary where
 
 showModMsg :: HscTarget -> Bool -> ModSummary -> String
 showModMsg target recomp mod_summary
-  = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
-	            char '(', text (msHsFilePath mod_summary) <> comma,
-		    case target of
-                      HscInterpreted | recomp 
-                                 -> text "interpreted"
-                      HscNothing -> text "nothing"
-                      _other     -> text (msObjFilePath mod_summary),
-		    char ')'])
+  = showSDoc $
+        hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
+              char '(', text (normalise $ msHsFilePath mod_summary) <> comma,
+              case target of
+                  HscInterpreted | recomp 
+                             -> text "interpreted"
+                  HscNothing -> text "nothing"
+                  _          -> text (normalise $ msObjFilePath mod_summary),
+              char ')']
  where 
     mod     = moduleName (ms_mod mod_summary)
     mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)