[Git][ghc/ghc][wip/az/exactprint] Adding test infrastructure for check-exact
Alan Zimmerman
gitlab at gitlab.haskell.org
Wed May 13 22:16:33 UTC 2020
Alan Zimmerman pushed to branch wip/az/exactprint at Glasgow Haskell Compiler / GHC
Commits:
18f174bf by Alan Zimmerman at 2020-05-13T22:40:55+01:00
Adding test infrastructure for check-exact
Like check-ppr, but checking for an exact reproduction of the parsed
source file.
- - - - -
8 changed files:
- + compiler/GHC/Hs/Exact.hs
- compiler/ghc.cabal.in
- ghc.mk
- hadrian/src/Packages.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/Test.hs
- hadrian/src/Settings/Builders/Make.hs
- testsuite/mk/boilerplate.mk
Changes:
=====================================
compiler/GHC/Hs/Exact.hs
=====================================
@@ -0,0 +1,123 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module GHC.Hs.Exact
+ (
+ ExactPrint(..)
+ ) where
+
+-- Module to provide "exact" printing of a GhcPs syntax fragment.
+-- This will be the the home of the functionality currently in ghc-exactprint.
+
+import GHC.Hs.Extension
+import GHC.Types.Name.Reader
+import GHC.Types.SrcLoc
+import GHC.Utils.Outputable
+
+-- ---------------------------------------------------------------------
+
+-- | Modeled on Outputable
+class ExactPrint a where
+ exact :: a -> SDoc
+
+-- ---------------------------------------------------------------------
+
+instance ExactPrint (LocatedA RdrName) where
+ exact (L l n) = ppr n
+
+{-
+Code in ghc-exactprint
+
+isSymRdr :: GHC.RdrName -> Bool
+isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "."
+
+instance Annotate GHC.RdrName where
+ markAST l n = do
+ let
+ str = rdrName2String n
+ isSym = isSymRdr n
+ doNormalRdrName = do
+ let str' = case str of
+ -- TODO: unicode support?
+ "forall" -> if spanLength l == 1 then "∀" else str
+ _ -> str
+
+ let
+ markParen :: GHC.AnnKeywordId -> Annotated ()
+ markParen pa = do
+ if isSym
+ then ifInContext (Set.fromList [PrefixOp,PrefixOpDollar])
+ (mark pa) -- '('
+ (markOptional pa)
+ else markOptional pa
+
+ markOptional GHC.AnnSimpleQuote
+ markParen GHC.AnnOpenP
+ unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0
+ cnt <- countAnns GHC.AnnVal
+ case cnt of
+ 0 -> markExternal l GHC.AnnVal str'
+ 1 -> markWithString GHC.AnnVal str'
+ _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n)
+ unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1
+ markParen GHC.AnnCloseP
+
+ case n of
+ GHC.Unqual _ -> doNormalRdrName
+ GHC.Qual _ _ -> doNormalRdrName
+ GHC.Orig _ _ -> if str == "~"
+ then doNormalRdrName
+ -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen)
+ else markExternal l GHC.AnnVal str
+ -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str
+ -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]"
+ GHC.Exact n' -> do
+ case str of
+ -- Special handling for Exact RdrNames, which are built-in Names
+ "[]" -> do
+ mark GHC.AnnOpenS -- '['
+ mark GHC.AnnCloseS -- ']'
+ "()" -> do
+ mark GHC.AnnOpenP -- '('
+ mark GHC.AnnCloseP -- ')'
+ ('(':'#':_) -> do
+ markWithString GHC.AnnOpen "(#" -- '(#'
+ let cnt = length $ filter (==',') str
+ replicateM_ cnt (mark GHC.AnnCommaTuple)
+ markWithString GHC.AnnClose "#)"-- '#)'
+ "[::]" -> do
+ markWithString GHC.AnnOpen "[:" -- '[:'
+ markWithString GHC.AnnClose ":]" -- ':]'
+ "->" -> do
+ mark GHC.AnnOpenP -- '('
+ mark GHC.AnnRarrow
+ mark GHC.AnnCloseP -- ')'
+ -- "~#" -> do
+ -- mark GHC.AnnOpenP -- '('
+ -- mark GHC.AnnTildehsh
+ -- mark GHC.AnnCloseP
+ "~" -> do
+ doNormalRdrName
+ "*" -> do
+ markExternal l GHC.AnnVal str
+ "★" -> do -- Note: unicode star
+ markExternal l GHC.AnnVal str
+ ":" -> do
+ -- Note: The OccName for ":" has the following attributes (via occAttributes)
+ -- (d, Data DataSym Sym Val )
+ -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
+ doNormalRdrName
+ -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName
+ ('(':',':_) -> do
+ mark GHC.AnnOpenP
+ let cnt = length $ filter (==',') str
+ replicateM_ cnt (mark GHC.AnnCommaTuple)
+ mark GHC.AnnCloseP -- ')'
+ _ -> do
+ let isSym' = isSymRdr (GHC.nameRdrName n')
+ when isSym' $ mark GHC.AnnOpenP -- '('
+ markWithString GHC.AnnVal str
+ when isSym $ mark GHC.AnnCloseP -- ')'
+ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName")
+
+
+-}
=====================================
compiler/ghc.cabal.in
=====================================
@@ -335,6 +335,7 @@ Library
GHC.Hs.Binds
GHC.Hs.Decls
GHC.Hs.Doc
+ GHC.Hs.Exact
GHC.Hs.Expr
GHC.Hs.ImpExp
GHC.Hs.Lit
=====================================
ghc.mk
=====================================
@@ -554,6 +554,7 @@ ghc/stage2/package-data.mk: compiler/stage2/package-data.mk
utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk
utils/check-api-annotations/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/check-ppr/dist-install/package-data.mk: compiler/stage2/package-data.mk
+utils/check-exact/dist-install/package-data.mk: compiler/stage2/package-data.mk
# add the final package.conf dependency: ghc-prim depends on RTS
libraries/ghc-prim/dist-install/package-data.mk : rts/dist/package.conf.inplace
@@ -665,6 +666,7 @@ BUILD_DIRS += utils/ghc-pkg
BUILD_DIRS += utils/testremove
BUILD_DIRS += utils/check-api-annotations
BUILD_DIRS += utils/check-ppr
+BUILD_DIRS += utils/check-exact
BUILD_DIRS += utils/ghc-cabal
BUILD_DIRS += utils/hpc
BUILD_DIRS += utils/runghc
@@ -710,6 +712,7 @@ ifneq "$(CrossCompiling) $(Stage1Only)" "NO NO"
# See Note [Stage1Only vs stage=1] in mk/config.mk.in.
BUILD_DIRS := $(filter-out utils/check-api-annotations,$(BUILD_DIRS))
BUILD_DIRS := $(filter-out utils/check-ppr,$(BUILD_DIRS))
+BUILD_DIRS := $(filter-out utils/check-exact,$(BUILD_DIRS))
endif
endif # CLEANING
=====================================
hadrian/src/Packages.hs
=====================================
@@ -2,6 +2,7 @@
module Packages (
-- * GHC packages
array, base, binary, bytestring, cabal, checkApiAnnotations, checkPpr,
+ checkExact,
compareSizes, compiler, containers, deepseq, deriveConstants, directory,
exceptions, filepath, genapply, genprimopcode, ghc, ghcBoot, ghcBootTh,
ghcCompact, ghcHeap, ghci, ghcPkg, ghcPrim, haddock, haskeline,
@@ -52,6 +53,7 @@ bytestring = lib "bytestring"
cabal = lib "Cabal" `setPath` "libraries/Cabal/Cabal"
checkApiAnnotations = util "check-api-annotations"
checkPpr = util "check-ppr"
+checkExact = util "check-exact"
compareSizes = util "compareSizes" `setPath` "utils/compare_sizes"
compiler = top "ghc" `setPath` "compiler"
containers = lib "containers" `setPath` "libraries/containers/containers"
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -148,7 +148,7 @@ bindistRules = do
need $ map (bindistFilesDir -/-)
(["configure", "Makefile"] ++ bindistInstallFiles)
need $ map ((bindistFilesDir -/- "wrappers") -/-) ["check-api-annotations"
- , "check-ppr", "ghc", "ghc-iserv", "ghc-pkg"
+ , "check-ppr", "check-exact", "ghc", "ghc-iserv", "ghc-pkg"
, "ghci-script", "haddock", "hpc", "hp2ps", "hsc2hs"
, "runghc"]
=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -28,6 +28,10 @@ checkPprProgPath, checkPprSourcePath :: FilePath
checkPprProgPath = "test/bin/check-ppr" <.> exe
checkPprSourcePath = "utils/check-ppr/Main.hs"
+checkExactProgPath, checkExactSourcePath :: FilePath
+checkExactProgPath = "test/bin/check-exact" <.> exe
+checkExactSourcePath = "utils/check-exact/Main.hs"
+
checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath :: FilePath
checkApiAnnotationsProgPath = "test/bin/check-api-annotations" <.> exe
checkApiAnnotationsSourcePath = "utils/check-api-annotations/Main.hs"
@@ -35,6 +39,7 @@ checkApiAnnotationsSourcePath = "utils/check-api-annotations/Main.hs"
checkPrograms :: [(FilePath, FilePath, Package)]
checkPrograms =
[ (checkPprProgPath, checkPprSourcePath, checkPpr)
+ , (checkExactProgPath, checkExactSourcePath, checkExact)
, (checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath, checkApiAnnotations)
]
@@ -53,8 +58,9 @@ testRules = do
-- Reasons why this is required are not entirely clear.
cmd ["bash"] ["-c", ghc0Path ++ " " ++ ghcConfigHsPath ++ " -o " ++ (root -/- ghcConfigProgPath)]
- -- Rules for building check-ppr and check-ppr-annotations with the compiler
- -- we are going to test (in-tree or out-of-tree).
+ -- Rules for building check-ppr, check-exact and
+ -- check-ppr-annotations with the compiler we are going to test
+ -- (in-tree or out-of-tree).
forM_ checkPrograms $ \(progPath, sourcePath, progPkg) ->
root -/- progPath %> \path -> do
need [ sourcePath ]
@@ -117,7 +123,9 @@ testRules = do
]
pythonPath <- builderPath Python
- need [ root -/- checkPprProgPath, root -/- checkApiAnnotationsProgPath ]
+ need [ root -/- checkPprProgPath
+ , root -/- checkExactProgPath
+ , root -/- checkApiAnnotationsProgPath ]
-- Set environment variables for test's Makefile.
-- TODO: Ideally we would define all those env vars in 'env', so that
@@ -133,6 +141,7 @@ testRules = do
setEnv "TEST_HC_OPTS" ghcFlags
setEnv "TEST_HC_OPTS_INTERACTIVE" ghciFlags
setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath)
+ setEnv "CHECK_EXACT" (top -/- root -/- checkExactProgPath)
setEnv "CHECK_API_ANNOTATIONS"
(top -/- root -/- checkApiAnnotationsProgPath)
=====================================
hadrian/src/Settings/Builders/Make.hs
=====================================
@@ -25,12 +25,14 @@ validateBuilderArgs = builder (Make "testsuite/tests") ? do
top <- expr topDirectory
compiler <- expr $ fullpath ghc
checkPpr <- expr $ fullpath checkPpr
+ checkExact <- expr $ fullpath checkExact
checkApiAnnotations <- expr $ fullpath checkApiAnnotations
args <- expr $ userSetting defaultTestArgs
return [ setTestSpeed $ testSpeed args
, "THREADS=" ++ show threads
, "TEST_HC=" ++ (top -/- compiler)
, "CHECK_PPR=" ++ (top -/- checkPpr)
+ , "CHECK_EXACT=" ++ (top -/- checkExact)
, "CHECK_API_ANNOTATIONS=" ++ (top -/- checkApiAnnotations)
]
where
=====================================
testsuite/mk/boilerplate.mk
=====================================
@@ -227,6 +227,9 @@ ifeq "$(CHECK_PPR)" ""
CHECK_PPR := $(abspath $(TOP)/../inplace/bin/check-ppr)
endif
+ifeq "$(CHECK_EXACT)" ""
+CHECK_EXACT := $(abspath $(TOP)/../inplace/bin/check-exact)
+endif
# -----------------------------------------------------------------------------
# configuration of TEST_HC
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18f174bf73f046df5201f389c273fc4e0e5a7ec8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18f174bf73f046df5201f389c273fc4e0e5a7ec8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200513/f39abcae/attachment-0001.html>
More information about the ghc-commits
mailing list