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