From ce2cc64f0b4c447bf83fd0d0b260f00126a0c4d6 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 17 Nov 2014 19:19:10 -0600
Subject: [PATCH] Adding dedicated Show instances for SrcSpan/SrcLoc

Summary:
The derived Show instances for SrcSpan and SrcLoc are very verbose.

This patch replaces them with hand-made ones which use positional
syntax for the record constructors, rather than exhaustively listing
each one.

Test Plan: sh ./validate

Reviewers: austin

Reviewed By: austin

Subscribers: thomie, carter

Differential Revision: https://phabricator.haskell.org/D445
---
 compiler/basicTypes/SrcLoc.lhs                | 20 +++++++++--
 .../tests/ghc-api/show-srcspan/.gitignore     |  5 +++
 testsuite/tests/ghc-api/show-srcspan/Makefile | 13 ++++++++
 testsuite/tests/ghc-api/show-srcspan/all.T    |  1 +
 .../tests/ghc-api/show-srcspan/showsrcspan.hs | 33 +++++++++++++++++++
 .../ghc-api/show-srcspan/showsrcspan.stdout   |  7 ++++
 6 files changed, 76 insertions(+), 3 deletions(-)
 create mode 100644 testsuite/tests/ghc-api/show-srcspan/.gitignore
 create mode 100644 testsuite/tests/ghc-api/show-srcspan/Makefile
 create mode 100644 testsuite/tests/ghc-api/show-srcspan/all.T
 create mode 100644 testsuite/tests/ghc-api/show-srcspan/showsrcspan.hs
 create mode 100644 testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout

diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 6b464542a5c7..c7e1fbea9f89 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -99,11 +99,11 @@ data RealSrcLoc
   = SrcLoc      FastString              -- A precise location (file name)
                 {-# UNPACK #-} !Int     -- line number, begins at 1
                 {-# UNPACK #-} !Int     -- column number, begins at 1
-  deriving Show
 
 data SrcLoc
   = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
   | UnhelpfulLoc FastString     -- Just a general indication
+  deriving Show
 \end{code}
 
 %************************************************************************
@@ -259,8 +259,7 @@ data RealSrcSpan
           srcSpanLine     :: {-# UNPACK #-} !Int,
           srcSpanCol      :: {-# UNPACK #-} !Int
         }
-  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we
-                                -- derive Show for Token
+  deriving (Eq, Typeable)
 
 data SrcSpan =
     RealSrcSpan !RealSrcSpan
@@ -433,6 +432,21 @@ instance Ord SrcSpan where
      (srcSpanStart a `compare` srcSpanStart b) `thenCmp`
      (srcSpanEnd   a `compare` srcSpanEnd   b)
 
+instance Show RealSrcLoc where
+  show (SrcLoc filename row col)
+      = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col
+
+-- Show is used by Lexer.x, because we derive Show for Token
+instance Show RealSrcSpan where
+  show (SrcSpanOneLine file l sc ec)
+    = "SrcSpanOneLine " ++ show file ++ " "
+                        ++ intercalate " " (map show [l,sc,ec])
+  show (SrcSpanMultiLine file sl sc el ec)
+    = "SrcSpanMultiLine " ++ show file ++ " "
+                          ++ intercalate " " (map show [sl,sc,el,ec])
+  show (SrcSpanPoint file l c)
+    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [l,c])
+
 
 instance Outputable RealSrcSpan where
     ppr span = pprUserRealSpan True span
diff --git a/testsuite/tests/ghc-api/show-srcspan/.gitignore b/testsuite/tests/ghc-api/show-srcspan/.gitignore
new file mode 100644
index 000000000000..e135b8508712
--- /dev/null
+++ b/testsuite/tests/ghc-api/show-srcspan/.gitignore
@@ -0,0 +1,5 @@
+showsrcspan
+*.hi
+*.o
+*.run.*
+*.normalised
diff --git a/testsuite/tests/ghc-api/show-srcspan/Makefile b/testsuite/tests/ghc-api/show-srcspan/Makefile
new file mode 100644
index 000000000000..e467b61d75d3
--- /dev/null
+++ b/testsuite/tests/ghc-api/show-srcspan/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+	rm -f *.o *.hi
+
+showsrcspan: clean
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc showsrcspan
+	./showsrcspan "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+
+.PHONY: clean
diff --git a/testsuite/tests/ghc-api/show-srcspan/all.T b/testsuite/tests/ghc-api/show-srcspan/all.T
new file mode 100644
index 000000000000..fbb8d04cde0c
--- /dev/null
+++ b/testsuite/tests/ghc-api/show-srcspan/all.T
@@ -0,0 +1 @@
+test('showsrcspan', normal, run_command, ['$MAKE -s --no-print-directory showsrcspan'])
\ No newline at end of file
diff --git a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.hs b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.hs
new file mode 100644
index 000000000000..bf73b59f1853
--- /dev/null
+++ b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.hs
@@ -0,0 +1,33 @@
+module Main where
+
+import Data.Data
+import System.IO
+import GHC
+import FastString
+import SrcLoc
+import MonadUtils
+import Outputable
+import Bag (filterBag,isEmptyBag)
+import System.Directory (removeFile)
+import System.Environment( getArgs )
+
+main::IO()
+main = do
+  let
+    loc1 = mkSrcLoc (mkFastString "filename") 1 3
+    loc2 = mkSrcLoc (mkFastString "filename") 1 5
+    loc3 = mkSrcLoc (mkFastString "filename") 10 1
+    badLoc = mkGeneralSrcLoc (mkFastString "bad loc")
+
+    pointSpan = mkSrcSpan loc1 loc1
+    lineSpan  = mkSrcSpan loc1 loc2
+    multiSpan = mkSrcSpan loc2 loc3
+    badSpan  = mkGeneralSrcSpan (mkFastString "bad span")
+
+  print $ show loc1
+  print $ show loc2
+  print $ show badLoc
+  print $ show pointSpan
+  print $ show lineSpan
+  print $ show multiSpan
+  print $ show badSpan
diff --git a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
new file mode 100644
index 000000000000..f89656598a8a
--- /dev/null
+++ b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
@@ -0,0 +1,7 @@
+"RealSrcLoc SrcLoc \"filename\" 1 3"
+"RealSrcLoc SrcLoc \"filename\" 1 5"
+"UnhelpfulLoc \"bad loc\""
+"RealSrcSpan SrcSpanPoint \"filename\" 1 3"
+"RealSrcSpan SrcSpanOneLine \"filename\" 1 3 5"
+"RealSrcSpan SrcSpanMultiLine \"filename\" 1 5 10 1"
+"UnhelpfulSpan \"bad span\""
-- 
GitLab