[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Fix TH pretty-printer's parenthesization
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Sep 27 22:05:35 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b02f8042 by Mario Blažević at 2023-09-27T17:33:28-04:00
Fix TH pretty-printer's parenthesization
This PR Fixes `Language.Haskell.TH.Ppr.pprint` so it correctly emits parentheses where needed.
Fixes #23962, #23968, #23971, and #23986
- - - - -
79104334 by Krzysztof Gogolewski at 2023-09-27T17:34:04-04:00
Add a testcase for #17564
The code in the ticket relied on the behaviour of Derived constraints.
Derived constraints were removed in GHC 9.4 and now the code works
as expected.
- - - - -
57ca6c3d by sheaf at 2023-09-27T18:05:01-04:00
lint-codes: add new modes of operation
This commit adds two new modes of operation to the lint-codes
utility:
list - list all statically used diagnostic codes
outdated - list all outdated diagnostic codes
The previous behaviour is now:
test - test consistency and coverage of diagnostic codes
- - - - -
008f192a by sheaf at 2023-09-27T18:05:01-04:00
lint codes: avoid using git-grep
We manually traverse through the filesystem to find the diagnostic codes
embedded in .stdout and .stderr files, to avoid any issues with old
versions of grep.
Fixes #23843
- - - - -
a6a701cc by sheaf at 2023-09-27T18:05:01-04:00
lint-codes: add Hadrian targets
This commit adds new Hadrian targets:
codes, codes:used - list all used diagnostic codes
codes:outdated - list outdated diagnostic codes
This allows users to easily query GHC for used and outdated
diagnostic codes, e.g.
hadrian/build -j --flavour=<..> codes
will list all used diagnostic codes in the command line by running
the lint-codes utility in the "list codes" mode of operation.
The diagnostic code consistency and coverage test is still run as usual,
through the testsuite:
hadrian/build test --only="codes"
- - - - -
ebe2d0fd by Ben Gamari at 2023-09-27T18:05:02-04:00
hadrian: Install LICENSE files in bindists
Fixes #23548.
- - - - -
25 changed files:
- hadrian/bindist/Makefile
- hadrian/hadrian.cabal
- hadrian/src/Main.hs
- hadrian/src/Rules/BinaryDist.hs
- + hadrian/src/Rules/Codes.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- + linters/lint-codes/LintCodes/Args.hs
- linters/lint-codes/LintCodes/Coverage.hs
- linters/lint-codes/LintCodes/Static.hs
- linters/lint-codes/Main.hs
- linters/lint-codes/lint-codes.cabal
- testsuite/tests/diagnostic-codes/Makefile
- testsuite/tests/th/T11463.stdout
- + testsuite/tests/th/T23962.hs
- + testsuite/tests/th/T23962.stdout
- + testsuite/tests/th/T23968.hs
- + testsuite/tests/th/T23968.stdout
- + testsuite/tests/th/T23971.hs
- + testsuite/tests/th/T23971.stdout
- + testsuite/tests/th/T23986.hs
- + testsuite/tests/th/T23986.stdout
- testsuite/tests/th/TH_PprStar.stderr
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_compile/T17564.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
hadrian/bindist/Makefile
=====================================
@@ -78,6 +78,7 @@ endif
install: install_bin install_lib install_extra
install: install_man install_docs update_package_db
+install: install_data
ifeq "$(RelocatableBuild)" "YES"
ActualLibsDir=${ghclibdir}
@@ -209,6 +210,15 @@ install_docs:
$(INSTALL_SCRIPT) docs-utils/gen_contents_index "$(DESTDIR)$(docdir)/html/libraries/"; \
fi
+.PHONY: install_data
+install_data:
+ @echo "Copying data to $(DESTDIR)share"
+ $(INSTALL_DIR) "$(DESTDIR)$(datadir)"
+ cd share; $(FIND) . -type f -exec sh -c \
+ '$(INSTALL_DIR) "$(DESTDIR)$(datadir)/`dirname $$1`" && \
+ $(INSTALL_DATA) "$$1" "$(DESTDIR)$(datadir)/`dirname $$1`"' \
+ sh '{}' ';';
+
MAN_SECTION := 1
MAN_PAGES := manpage/ghc.1
=====================================
hadrian/hadrian.cabal
=====================================
@@ -78,6 +78,7 @@ executable hadrian
, Rules.BinaryDist
, Rules.CabalReinstall
, Rules.Clean
+ , Rules.Codes
, Rules.Compile
, Rules.Dependencies
, Rules.Docspec
=====================================
hadrian/src/Main.hs
=====================================
@@ -15,6 +15,7 @@ import qualified Base
import qualified CommandLine
import qualified Environment
import qualified Rules
+import qualified Rules.Codes
import qualified Rules.Clean
import qualified Rules.Docspec
import qualified Rules.Documentation
@@ -99,6 +100,7 @@ main = do
Rules.Docspec.docspecRules
Rules.Documentation.documentationRules
Rules.Clean.cleanRules
+ Rules.Codes.codesRules
Rules.Lint.lintRules
Rules.Nofib.nofibRules
Rules.oracleRules
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -253,6 +253,12 @@ bindistRules = do
-- shipping it
removeFile (bindistFilesDir -/- mingwStamp)
+ -- Include LICENSE files and related data.
+ -- On Windows LICENSE files are in _build/lib/doc, which is
+ -- already included above.
+ unless windowsHost $ do
+ copyDirectory (ghcBuildDir -/- "share") bindistFilesDir
+
-- Include bash-completion script in binary distributions. We don't
-- currently install this but merely include it for the user's
-- reference. See #20802.
=====================================
hadrian/src/Rules/Codes.hs
=====================================
@@ -0,0 +1,37 @@
+module Rules.Codes
+ ( codesRules
+ ) where
+
+import Base
+import Packages ( programPath, lintCodes )
+import Settings.Program ( programContext )
+
+data Usage
+ = Used
+ | Outdated
+
+describeUsage :: Usage -> String
+describeUsage Used = "used"
+describeUsage Outdated = "outdated"
+
+usageArg :: Usage -> String
+usageArg Used = "list"
+usageArg Outdated = "outdated"
+
+codesRules :: Rules ()
+codesRules = do
+ "codes:used" ~> codes Used
+ "codes:outdated" ~> codes Outdated
+ "codes" ~> codes Used
+
+codes :: Usage -> Action ()
+codes usage = do
+ let stage = Stage1 -- ?
+ codesProgram <- programPath =<< programContext stage lintCodes
+ need [ codesProgram ]
+ ghcLibDir <- stageLibPath stage
+ let args = [ usageArg usage, ghcLibDir ]
+ cmdLine = unwords ( codesProgram : args )
+ putBuild $ "| Computing " ++ describeUsage usage ++ " diagnostic codes."
+ putBuild $ "| " <> cmdLine
+ cmd_ cmdLine
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -407,7 +407,7 @@ ppr_dec isTop (NewtypeD ctxt t xs ksig c decs)
ppr_dec isTop (TypeDataD t xs ksig cs)
= ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs []
ppr_dec _ (ClassD ctxt c xs fds ds)
- = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
+ = text "class" <+> pprCxt ctxt <+> pprName' Applied c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
ppr_dec _ (InstanceD o ctxt i ds) =
text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
@@ -420,7 +420,7 @@ ppr_dec _ (DefaultD tys) =
text "default" <+> parens (sep $ punctuate comma $ map ppr tys)
ppr_dec _ (PragmaD p) = ppr p
ppr_dec isTop (DataFamilyD tc tvs kind)
- = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
+ = text "data" <+> maybeFamily <+> pprName' Applied tc <+> hsep (map ppr tvs) <+> maybeKind
where
maybeFamily | isTop = text "family"
| otherwise = empty
@@ -552,7 +552,7 @@ ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs
ppr_deriv_clause :: DerivClause -> Doc
ppr_deriv_clause (DerivClause ds ctxt)
= text "deriving" <+> pp_strat_before
- <+> ppr_cxt_preds ctxt
+ <+> ppr_cxt_preds appPrec ctxt
<+> pp_strat_after
where
-- @via@ is unique in that in comes /after/ the class being derived,
@@ -871,11 +871,11 @@ pprInfixT p = \case
instance Ppr Type where
ppr = pprType noPrec
instance Ppr TypeArg where
- ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty)
+ ppr (TANormal ty) = ppr ty
ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)
pprParendTypeArg :: TypeArg -> Doc
-pprParendTypeArg (TANormal ty) = parensIf (isStarT ty) (pprParendType ty)
+pprParendTypeArg (TANormal ty) = pprParendType ty
pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki)
isStarT :: Type -> Bool
@@ -980,14 +980,12 @@ instance Ppr Role where
------------------------------
pprCxt :: Cxt -> Doc
pprCxt [] = empty
-pprCxt ts = ppr_cxt_preds ts <+> text "=>"
-
-ppr_cxt_preds :: Cxt -> Doc
-ppr_cxt_preds [] = empty
-ppr_cxt_preds [t at ImplicitParamT{}] = parens (ppr t)
-ppr_cxt_preds [t at ForallT{}] = parens (ppr t)
-ppr_cxt_preds [t] = ppr t
-ppr_cxt_preds ts = parens (commaSep ts)
+pprCxt ts = ppr_cxt_preds funPrec ts <+> text "=>"
+
+ppr_cxt_preds :: Precedence -> Cxt -> Doc
+ppr_cxt_preds _ [] = text "()"
+ppr_cxt_preds p [t] = pprType p t
+ppr_cxt_preds _ ts = parens (commaSep ts)
------------------------------
instance Ppr Range where
=====================================
linters/lint-codes/LintCodes/Args.hs
=====================================
@@ -0,0 +1,72 @@
+module LintCodes.Args
+ ( Mode(..)
+ , parseArgs
+ )
+ where
+
+-- lint-codes
+import LintCodes.Static
+ ( LibDir(..) )
+
+--------------------------------------------------------------------------------
+
+-- | Mode in which to run the 'lint-codes' executable.
+data Mode
+ -- | Run the 'lint-codes' test, checking:
+ --
+ -- 1. all non-outdated 'GhcDiagnosticCode' equations are statically used;
+ -- 2. all outdated 'GhcDiagnosticCode' equations are statically unused;
+ -- 3. all statically used diagnostic codes are covered by the testsuite.
+ = Test
+ -- | List all statically used diagnostic codes.
+ | List
+ -- | List outdated diagnostic codes.
+ | Outdated
+
+parseArgs :: [String] -> (Mode, Maybe LibDir)
+parseArgs args
+ | not (any isHelp args)
+ , mode_arg : rest <- args
+ = ( parseMode mode_arg, parseMbLibDir rest )
+ | otherwise
+ = error $ errorMsgWithHeader lintCodesHeader
+
+parseMode :: String -> Mode
+parseMode "test" = Test
+parseMode "list" = List
+parseMode "outdated" = Outdated
+parseMode mode =
+ error $ errorMsgWithHeader
+ "Invalid mode of operation '" ++ mode ++ "'."
+
+isHelp :: String -> Bool
+isHelp "help" = True
+isHelp "-h" = True
+isHelp "--help" = True
+isHelp _ = False
+
+
+parseMbLibDir :: [String] -> Maybe LibDir
+parseMbLibDir [] = Nothing
+parseMbLibDir (fp:_) = Just $ LibDir { libDir = fp }
+
+lintCodesHeader :: String
+lintCodesHeader = "lint-codes - GHC diagnostic code coverage tool"
+
+errorMsgWithHeader :: String -> String
+errorMsgWithHeader header = unlines
+ [ header
+ , ""
+ , "Usage: lint-codes (test|list|outdated) [libdir]"
+ , ""
+ , " - Use 'test' to check consistency and coverage of GHC diagnostic codes"
+ , " (must be inside a GHC Git tree)."
+ , " - Use 'list' to list all diagnostic codes emitted by GHC."
+ , " - Use 'outdated' to list outdated diagnostic codes."
+ , ""
+ , ""
+ , "If you see an error of the form:"
+ , " lint-codes: Missing file: test/lib/settings"
+ , "It likely means you are passing an incorrect libdir."
+ , "You can query the libdir for the GHC you are using with 'ghc --print-libdir'."
+ ]
=====================================
linters/lint-codes/LintCodes/Coverage.hs
=====================================
@@ -1,13 +1,39 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
module LintCodes.Coverage
( getCoveredCodes )
where
+-- base
+import Data.Char
+ ( isAlphaNum, isDigit, isSpace )
+import Data.Maybe
+ ( mapMaybe )
+import Data.List
+ ( dropWhileEnd )
+
+-- bytestring
+import qualified Data.ByteString as ByteString
+ ( readFile )
+
-- containers
import Data.Set
( Set )
import qualified Data.Set as Set
( fromList )
+-- directory
+import System.Directory
+ ( doesDirectoryExist, listDirectory )
+
+-- filepath
+import System.FilePath
+ ( (</>), takeExtension )
+
-- ghc
import GHC.Types.Error
( DiagnosticCode(..) )
@@ -16,6 +42,17 @@ import GHC.Types.Error
import System.Process
( readProcess )
+-- text
+import Data.Text
+ ( Text )
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+ ( decodeUtf8' )
+
+-- transformers
+import Control.Monad.Trans.State.Strict
+ ( State, runState, get, put )
+
--------------------------------------------------------------------------------
-- Diagnostic code coverage from testsuite .stdout and .stderr files
@@ -23,24 +60,101 @@ import System.Process
-- files.
getCoveredCodes :: IO (Set DiagnosticCode)
getCoveredCodes =
- -- Run git grep on .stdout and .stderr files in the testsuite subfolder.
- do { codes <- lines
- <$> readProcess "git"
- [ "grep", "-Eoh", codeRegex
- -- -oh: only show the match, and omit the filename.
- , "--", ":/testsuite/*.stdout", ":/testsuite/*.stderr"
- , ":!*/codes.stdout" -- Don't include the output of this test itself.
- ] ""
- ; return $ Set.fromList $ map parseCode codes }
-
--- | Regular expression to parse a diagnostic code.
-codeRegex :: String
-codeRegex = "\\[[A-Za-z]+-[0-9]+\\]"
-
--- | Turn a string that matches the 'codeRegex' regular expression
--- into its corresponding 'DiagnosticCode'.
-parseCode :: String -> DiagnosticCode
-parseCode c =
- case break (== '-') $ drop 1 c of
- (ns, rest) ->
- DiagnosticCode ns ( read $ init $ drop 1 rest )
+ do { top <- dropWhileEnd isSpace
+ <$> readProcess "git" ["rev-parse", "--show-toplevel"] ""
+ -- TODO: would be better to avoid using git entirely.
+ ; let testRoot = top </> "testsuite" </> "tests"
+ ; traverseFilesFrom includeFile diagnosticCodesIn testRoot
+ }
+
+-- | Excluded files: we don't look for diagnostic codes in these, as they
+-- are not actual diagnostic codes emitted by the compiler.
+excludeList :: [ FilePath ]
+excludeList = [ "codes.stdout" ]
+
+-- | Which files should we include in the search for diagnostic codes in the
+-- output of the testsuite: `.stdout` and `.stderr` files.
+includeFile :: FilePath -> Bool
+includeFile fn
+ = fn `notElem` excludeList
+ && takeExtension fn `elem` [ ".stdout", ".stderr" ]
+
+-- | Collect all diagnostic codes mentioned in the given 'Text'.
+diagnosticCodesIn :: Text -> Set DiagnosticCode
+diagnosticCodesIn txt =
+ Set.fromList $ mapMaybe getCode
+ $ concatMap (enclosedBy '[' ']')
+ $ Text.lines txt
+
+ where
+ getCode :: Text -> Maybe DiagnosticCode
+ getCode txt_inside_brackets
+ | let (ns, Text.drop 1 -> code) = Text.breakOn "-" txt_inside_brackets
+ , not $ Text.null ns
+ , not $ Text.null code
+ , Text.all isAlphaNum ns
+ , Text.all isDigit code
+ , let ns' = Text.unpack ns
+ = let diag = DiagnosticCode ns' ( read $ Text.unpack code )
+ in if ns' `elem` expectedDiagnosticNameSpaces
+ then Just diag
+ else Nothing
+ -- error "lint-codes: unexpected diagnostic code [" ++ show diag ++ "]."
+ | otherwise
+ = Nothing
+
+-- | Which diagnostic code namespaces are relevant to this test?
+expectedDiagnosticNameSpaces :: [String]
+expectedDiagnosticNameSpaces = ["GHC"]
+
+-- | Capture pieces of a text enclosed by matching delimiters.
+--
+-- > enclosedBy '(' ')' "ab(cd(e)f)g(hk)l"
+-- > ["cd(e)f", "hk"]
+enclosedBy :: Char -> Char -> Text -> [Text]
+enclosedBy open close = go . recur
+ where
+ recur = Text.breakOn (Text.singleton open)
+ go (_, Text.drop 1 -> rest)
+ | Text.null rest
+ = []
+ | let ((ok, rest'), n) = ( `runState` 1 ) $ Text.spanM matchingParen rest
+ = if n == 0
+ then (if Text.null ok then id else (ok:)) $ go $ recur rest'
+ else []
+
+ matchingParen :: Char -> State Int Bool
+ matchingParen c =
+ do { s <- get
+ ; if | c == open
+ -> do { put (s+1); return True }
+ | c == close
+ -> do { put (s-1); return (s /= 1) }
+ | otherwise
+ -> return True }
+
+-- | Recursive traversal from a root directory of all files satisfying
+-- the inclusion predicate, collecting up a result according to
+-- the parsing function.
+traverseFilesFrom :: forall b. Monoid b
+ => ( FilePath -> Bool ) -- ^ inclusion predicate
+ -> ( Text -> b ) -- ^ parsing function
+ -> FilePath -- ^ directory root
+ -> IO b
+traverseFilesFrom include_file parse_contents = go
+ where
+ go top
+ = do { ps <- listDirectory top
+ ; (`foldMap` ps) \ p ->
+ do { let path = top </> p
+ ; is_dir <- doesDirectoryExist path
+ ; if is_dir
+ then go path
+ else if not $ include_file p
+ then return mempty
+ else
+ do { bs <- ByteString.readFile path
+ ; return $ case Text.decodeUtf8' bs of
+ { Left _ -> mempty
+ ; Right txt -> parse_contents txt
+ } } } }
=====================================
linters/lint-codes/LintCodes/Static.hs
=====================================
@@ -5,17 +5,11 @@
module LintCodes.Static
( FamEqnIndex, Use(..), used, outdated
- , getFamEqnCodes
+ , LibDir(..), getFamEqnCodes
, staticallyUsedCodes
)
where
--- base
-import Data.Maybe
- ( listToMaybe )
-import System.Environment
- ( getArgs )
-
-- containers
import Data.Map.Strict
( Map )
@@ -111,9 +105,9 @@ outdated _ = Nothing
-- of Template Haskell at compile-time is problematic for Hadrian.
-- | The diagnostic codes returned by the 'GhcDiagnosticCode' type family.
-getFamEqnCodes :: IO ( Map DiagnosticCode ( FamEqnIndex, String, Use ) )
-getFamEqnCodes =
- do { tc <- ghcDiagnosticCodeTyCon
+getFamEqnCodes :: Maybe LibDir -> IO ( Map DiagnosticCode ( FamEqnIndex, String, Use ) )
+getFamEqnCodes mb_libDir =
+ do { tc <- ghcDiagnosticCodeTyCon mb_libDir
; return $ case isClosedSynFamilyTyConWithAxiom_maybe tc of
{ Nothing -> error "can't find equations for 'GhcDiagnosticCode'"
; Just ax -> Map.fromList
@@ -145,11 +139,12 @@ parseBranchRHS rhs
| otherwise
= Used
+newtype LibDir = LibDir { libDir :: FilePath }
+
-- | Look up the 'GhcDiagnosticCode' type family using the GHC API.
-ghcDiagnosticCodeTyCon :: IO TyCon
-ghcDiagnosticCodeTyCon =
- do { args <- getArgs
- ; runGhc (listToMaybe args)
+ghcDiagnosticCodeTyCon :: Maybe LibDir -> IO TyCon
+ghcDiagnosticCodeTyCon mb_libDir =
+ runGhc (libDir <$> mb_libDir)
-- STEP 1: start a GHC API session with "-package ghc"
do { dflags1 <- getSessionDynFlags
@@ -176,4 +171,4 @@ ghcDiagnosticCodeTyCon =
_ -> error "lint-codes: failed to look up TyCon for 'GhcDiagnosticCode'"
}
- ; _ -> error "lint-codes: failed to find 'GHC.Types.Error.Codes'" } } } }
+ ; _ -> error "lint-codes: failed to find 'GHC.Types.Error.Codes'" } } }
=====================================
linters/lint-codes/Main.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TupleSections #-}
@@ -10,6 +11,8 @@ import Data.List
( sortOn )
import Text.Printf
( printf )
+import System.Environment
+ ( getArgs )
-- containers
import Data.Map.Strict
@@ -22,8 +25,10 @@ import GHC.Types.Error
( DiagnosticCode(..) )
-- lint-codes
+import LintCodes.Args
+ ( Mode(..), parseArgs )
import LintCodes.Static
- ( FamEqnIndex, used, outdated
+ ( FamEqnIndex, Use, used, outdated
, getFamEqnCodes
, staticallyUsedCodes
)
@@ -35,9 +40,38 @@ import LintCodes.Coverage
main :: IO ()
main = do
+ args <- getArgs
+ let !(!mode, mb_libDir) = parseArgs args
+
+ famEqnCodes <- getFamEqnCodes mb_libDir
+
+ case mode of
+ Test -> testCodes famEqnCodes
+ List -> listCodes famEqnCodes
+ Outdated -> listOutdatedCodes famEqnCodes
+
+-- | List all statically used diagnostic codes.
+listCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
+listCodes famEqnCodes = do
+ let usedCodes = Map.mapMaybe used famEqnCodes
+ `Map.intersection` staticallyUsedCodes
+ putStrLn $ showDiagnosticCodesWith printCode usedCodes
+
+-- | List all outdated diagnostic codes.
+listOutdatedCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
+listOutdatedCodes famEqnCodes = do
+ let outdatedCodes = Map.mapMaybe outdated famEqnCodes
+ putStrLn $ showDiagnosticCodesWith printCode outdatedCodes
+
+-- | Test consistency and coverage of diagnostic codes.
+--
+-- Assumes we are in a GHC Git tree, as we look at all testsuite .stdout and
+-- .stderr files.
+testCodes :: Map DiagnosticCode ( FamEqnIndex, String, Use ) -> IO ()
+testCodes famEqnCodes = do
+
------------------------------
-- Static consistency checks.
- famEqnCodes <- getFamEqnCodes
let
familyEqnUsedCodes = Map.mapMaybe used famEqnCodes
@@ -145,13 +179,15 @@ showDiagnosticCodesWith f codes = unlines $ map showCodeCon $ sortOn famEqnIndex
famEqnIndex :: (DiagnosticCode, (FamEqnIndex, String)) -> FamEqnIndex
famEqnIndex (_, (i,_)) = i
-printUnused, printOutdatedUsed, printUntested :: (DiagnosticCode, String) -> String
+printUnused, printOutdatedUsed, printUntested, printCode :: (DiagnosticCode, String) -> String
printUnused (code, con) =
"Unused equation: GhcDiagnosticCode " ++ show con ++ " = " ++ showDiagnosticCodeNumber code
printOutdatedUsed (code, con) =
"Outdated equation is used: GhcDiagnosticCode " ++ show con ++ " = Outdated " ++ showDiagnosticCodeNumber code
printUntested (code, con) =
"[" ++ show code ++ "] is untested (constructor = " ++ con ++ ")"
+printCode (code, con) =
+ "[" ++ show code ++ "] " ++ show con
showDiagnosticCodeNumber :: DiagnosticCode -> String
showDiagnosticCodeNumber (DiagnosticCode { diagnosticCodeNumber = c })
=====================================
linters/lint-codes/lint-codes.cabal
=====================================
@@ -14,6 +14,7 @@ executable lint-codes
Main.hs
other-modules:
+ LintCodes.Args
LintCodes.Coverage
LintCodes.Static
=====================================
testsuite/tests/diagnostic-codes/Makefile
=====================================
@@ -3,4 +3,4 @@ TOP=../..
LIBDIR := "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
codes:
- (cd $(TOP)/.. && $(LINT_CODES) $(LIBDIR))
+ (cd $(TOP)/.. && $(LINT_CODES) test $(LIBDIR))
=====================================
testsuite/tests/th/T11463.stdout
=====================================
@@ -1,2 +1,2 @@
data Main.Proxy1 (a_0 :: Main.Id1 k_1) = Main.Proxy1
-data Main.Proxy2 (a_0 :: Main.Id2 (*) k_1) = Main.Proxy2
+data Main.Proxy2 (a_0 :: Main.Id2 * k_1) = Main.Proxy2
=====================================
testsuite/tests/th/T23962.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE Haskell2010, KindSignatures, StarIsType, TemplateHaskell #-}
+
+import Data.Typeable (Proxy (Proxy))
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+ runQ [|typeOf (Proxy :: Proxy *)|]
+ >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23962.stdout
=====================================
@@ -0,0 +1 @@
+typeOf (Data.Proxy.Proxy :: Data.Proxy.Proxy *)
=====================================
testsuite/tests/th/T23968.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE Haskell2010, TemplateHaskell, TypeFamilies, TypeOperators #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+ runQ [d|data family (a + b) c d|]
+ >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23968.stdout
=====================================
@@ -0,0 +1 @@
+data family (+_0) a_1 b_2 c_3 d_4
=====================================
testsuite/tests/th/T23971.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE Haskell2010, MultiParamTypeClasses, TypeOperators, TemplateHaskell #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+ runQ [d|class a ## b|]
+ >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23971.stdout
=====================================
@@ -0,0 +1 @@
+class (##_0) a_1 b_2
=====================================
testsuite/tests/th/T23986.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE Haskell2010, DeriveAnyClass, MultiParamTypeClasses, QuantifiedConstraints, TemplateHaskell #-}
+
+import Control.Monad.Reader (MonadReader)
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+class C a b
+
+main = do
+ runQ [d|data Foo deriving (C a)|] >>= putStrLn . pprint
+ runQ [d|newtype Foo m a = MkFoo (m a) deriving (forall r. MonadReader r)|] >>= putStrLn . pprint
+ runQ [d|class (forall r. MonadReader r m) => MonadReaderPlus m|] >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23986.stdout
=====================================
@@ -0,0 +1,7 @@
+data Foo_0 deriving (Main.C a_1)
+newtype Foo_0 m_1 a_2
+ = MkFoo_3 (m_1 a_2)
+ deriving (forall r_4 . Control.Monad.Reader.Class.MonadReader r_4)
+class (forall r_0 .
+ Control.Monad.Reader.Class.MonadReader r_0
+ m_1) => MonadReaderPlus_2 m_1
=====================================
testsuite/tests/th/TH_PprStar.stderr
=====================================
@@ -1,2 +1,2 @@
(Data.Proxy.Proxy @(*) GHC.Base.String -> *) ->
-Data.Either.Either (*) ((* -> *) -> *)
+Data.Either.Either * ((* -> *) -> *)
=====================================
testsuite/tests/th/all.T
=====================================
@@ -589,3 +589,7 @@ test('T23829_hasty', normal, compile_fail, [''])
test('T23829_hasty_b', normal, compile_fail, [''])
test('T23927', normal, compile_and_run, [''])
test('T23954', normal, compile_and_run, [''])
+test('T23962', normal, compile_and_run, [''])
+test('T23968', normal, compile_and_run, [''])
+test('T23971', normal, compile_and_run, [''])
+test('T23986', normal, compile_and_run, [''])
=====================================
testsuite/tests/typecheck/should_compile/T17564.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE QuantifiedConstraints, MultiParamTypeClasses,
+ KindSignatures, FlexibleInstances, TypeFamilies #-}
+
+module T17564 where
+
+import Data.Kind
+
+class (forall (a :: Type -> Type). a b ~ a c) => C b c
+instance C a a
+
+class (b ~ c) => D b c
+instance D a a
+
+foo :: C a b => a -> b
+foo = undefined
+
+bar = foo
+
+food :: D a b => a -> b
+food = undefined
+
+bard = food
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -894,3 +894,4 @@ test('TcIncompleteRecSel', normal, compile, ['-Wincomplete-record-selectors'])
test('InstanceWarnings', normal, multimod_compile, ['InstanceWarnings', ''])
test('T23861', normal, compile, [''])
test('T23918', normal, compile, [''])
+test('T17564', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aa4ee7f064cbd19f7d2c6774631ffde28bbc70ae...ebe2d0fd2555752a171ffbb6784c9bc1e8efaa63
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aa4ee7f064cbd19f7d2c6774631ffde28bbc70ae...ebe2d0fd2555752a171ffbb6784c9bc1e8efaa63
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/20230927/dbe49515/attachment-0001.html>
More information about the ghc-commits
mailing list