[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Added pprType with precedence argument, as a prerequisite to fix issues #21723 and #21942.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Aug 23 18:16:29 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b946232c by Mario Blažević at 2022-08-22T22:06:21-04:00
Added pprType with precedence argument, as a prerequisite to fix issues #21723 and #21942.
* refines the precedence levels, adding `qualPrec` and `funPrec` to better control parenthesization
* `pprParendType`, `pprFunArgType`, and `instance Ppr Type` all just call `pprType` with proper precedence
* `ParensT` constructor is now always printed parenthesized
* adds the precedence argument to `pprTyApp` as well, as it needs to keep track and pass it down
* using `>=` instead of former `>` to match the Core type printing logic
* some test outputs have changed, losing extraneous parentheses
- - - - -
fe4ff0f7 by Mario Blažević at 2022-08-22T22:06:21-04:00
Fix and test for issue #21723
- - - - -
33968354 by Mario Blažević at 2022-08-22T22:06:21-04:00
Test for issue #21942
- - - - -
c9655251 by Mario Blažević at 2022-08-22T22:06:21-04:00
Updated the changelog
- - - - -
80102356 by Ben Gamari at 2022-08-22T22:06:57-04:00
hadrian: Don't duplicate binaries on installation
Previously we used `install` on symbolic links, which ended up
copying the target file rather than installing a symbolic link.
Fixes #22062.
- - - - -
700e00ed by M Farkas-Dyck at 2022-08-23T14:16:09-04:00
Unbreak Haddock comments in `GHC.Core.Opt.WorkWrap.Utils`.
Closes #22092.
- - - - -
3172c7b0 by Cheng Shao at 2022-08-23T14:16:11-04:00
driver: don't actually merge objects when ar -L works
- - - - -
14 changed files:
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- hadrian/bindist/Makefile
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/changelog.md
- testsuite/tests/th/T15845.stderr
- + testsuite/tests/th/T21723.hs
- + testsuite/tests/th/T21723.stdout
- + testsuite/tests/th/T21942.hs
- + testsuite/tests/th/T21942.stdout
- testsuite/tests/th/T9262.stderr
- testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
- testsuite/tests/th/TH_unresolvedInfix.stdout
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -136,19 +136,18 @@ the unusable strictness-info into the interfaces.
data WwOpts
= MkWwOpts
- -- | Environment of type/data family instances
- { wo_fam_envs :: !FamInstEnvs
- -- | Options for the "Simple optimiser"
- , wo_simple_opts :: !SimpleOpts
- -- | Whether to enable "Constructed Product Result" analysis.
- -- (Originally from DOI: 10.1017/S0956796803004751)
- , wo_cpr_anal :: !Bool
- -- | Used for absent argument error message
- , wo_module :: !Module
- -- | Generate workers even if the only effect is some args get passed
- -- unlifted. See Note [WW for calling convention]
- , wo_unlift_strict :: !Bool
- }
+ { -- | Environment of type/data family instances
+ wo_fam_envs :: !FamInstEnvs
+ , -- | Options for the "Simple optimiser"
+ wo_simple_opts :: !SimpleOpts
+ , -- | Whether to enable "Constructed Product Result" analysis.
+ -- (Originally from DOI: 10.1017/S0956796803004751)
+ wo_cpr_anal :: !Bool
+ , -- | Used for absent argument error message
+ wo_module :: !Module
+ , -- | Generate workers even if the only effect is some args get passed
+ -- unlifted. See Note [WW for calling convention]
+ wo_unlift_strict :: !Bool }
type WwResult
= ([Demand], -- Demands for worker (value) args
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -1180,7 +1180,7 @@ via gcc.
-- | See Note [Object merging].
joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()
joinObjectFiles hsc_env o_files output_fn
- | can_merge_objs = do
+ | can_merge_objs && not dashLSupported = do
let toolSettings' = toolSettings dflags
ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
=====================================
hadrian/bindist/Makefile
=====================================
@@ -139,7 +139,11 @@ install_bin_libdir:
@echo "Copying binaries to $(DESTDIR)$(ActualBinsDir)"
$(INSTALL_DIR) "$(DESTDIR)$(ActualBinsDir)"
for i in $(BINARIES); do \
- $(INSTALL_PROGRAM) $$i "$(DESTDIR)$(ActualBinsDir)"; \
+ if test -L "$$i"; then \
+ cp -RP "$$i" "$(DESTDIR)$(ActualBinsDir)"; \
+ else \
+ $(INSTALL_PROGRAM) "$$i" "$(DESTDIR)$(ActualBinsDir)"; \
+ fi; \
done
# Work around #17418 on Darwin
if [ -e "${XATTR}" ]; then \
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -23,10 +23,12 @@ nestDepth :: Int
nestDepth = 4
type Precedence = Int
-appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence
-appPrec = 4 -- Argument of a function application
-opPrec = 3 -- Argument of an infix operator
-unopPrec = 2 -- Argument of an unresolved infix operator
+appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence
+appPrec = 6 -- Argument of a function or type application
+opPrec = 5 -- Argument of an infix operator
+unopPrec = 4 -- Argument of an unresolved infix operator
+funPrec = 3 -- Argument of a function arrow
+qualPrec = 2 -- Forall-qualified type or result of a function arrow
sigPrec = 1 -- Argument of an explicit type signature
noPrec = 0 -- Others
@@ -220,7 +222,7 @@ pprExp _ (CompE ss) =
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
- <+> dcolon <+> ppr t
+ <+> dcolon <+> pprType sigPrec t
pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)
pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
pprExp i (StaticE e) = parensIf (i >= appPrec) $
@@ -792,60 +794,63 @@ pprStrictType :: (Strict, Type) -> Doc
pprStrictType = pprBangType
------------------------------
-pprParendType :: Type -> Doc
-pprParendType (VarT v) = pprName' Applied v
+pprType :: Precedence -> Type -> Doc
+pprType _ (VarT v) = pprName' Applied v
-- `Applied` is used here instead of `ppr` because of infix names (#13887)
-pprParendType (ConT c) = pprName' Applied c
-pprParendType (TupleT 0) = text "()"
-pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1))
-pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
-pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
-pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
-pprParendType ArrowT = parens (text "->")
-pprParendType MulArrowT = text "FUN"
-pprParendType ListT = text "[]"
-pprParendType (LitT l) = pprTyLit l
-pprParendType (PromotedT c) = text "'" <> pprName' Applied c
-pprParendType (PromotedTupleT 0) = text "'()"
-pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1))
-pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))
-pprParendType PromotedNilT = text "'[]"
-pprParendType PromotedConsT = text "'(:)"
-pprParendType StarT = char '*'
-pprParendType ConstraintT = text "Constraint"
-pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)
-pprParendType WildCardT = char '_'
-pprParendType t@(InfixT {}) = parens (pprInfixT t)
-pprParendType t@(UInfixT {}) = parens (pprInfixT t)
-pprParendType t@(PromotedInfixT {}) = parens (pprInfixT t)
-pprParendType t@(PromotedUInfixT {}) = parens (pprInfixT t)
-pprParendType (ParensT t) = ppr t
-pprParendType tuple | (TupleT n, args) <- split tuple
- , length args == n
- = parens (commaSep args)
-pprParendType (ImplicitParamT n t) = text ('?':n) <+> text "::" <+> ppr t
-pprParendType EqualityT = text "(~)"
-pprParendType t@(ForallT {}) = parens (ppr t)
-pprParendType t@(ForallVisT {}) = parens (ppr t)
-pprParendType t@(AppT {}) = parens (ppr t)
-pprParendType t@(AppKindT {}) = parens (ppr t)
-
-pprInfixT :: Type -> Doc
-pprInfixT = \case
- (InfixT x n y) -> with x n y "" ppr
- (UInfixT x n y) -> with x n y "" pprInfixT
- (PromotedInfixT x n y) -> with x n y "'" ppr
- (PromotedUInfixT x n y) -> with x n y "'" pprInfixT
- t -> ppr t
+pprType _ (ConT c) = pprName' Applied c
+pprType _ (TupleT 0) = text "()"
+pprType p (TupleT 1) = pprType p (ConT (tupleTypeName 1))
+pprType _ (TupleT n) = parens (hcat (replicate (n-1) comma))
+pprType _ (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
+pprType _ (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
+pprType _ ArrowT = parens (text "->")
+pprType _ MulArrowT = text "FUN"
+pprType _ ListT = text "[]"
+pprType _ (LitT l) = pprTyLit l
+pprType _ (PromotedT c) = text "'" <> pprName' Applied c
+pprType _ (PromotedTupleT 0) = text "'()"
+pprType p (PromotedTupleT 1) = pprType p (PromotedT (tupleDataName 1))
+pprType _ (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))
+pprType _ PromotedNilT = text "'[]"
+pprType _ PromotedConsT = text "'(:)"
+pprType _ StarT = char '*'
+pprType _ ConstraintT = text "Constraint"
+pprType _ (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)
+pprType _ WildCardT = char '_'
+pprType p t@(InfixT {}) = pprInfixT p t
+pprType p t@(UInfixT {}) = pprInfixT p t
+pprType p t@(PromotedInfixT {}) = pprInfixT p t
+pprType p t@(PromotedUInfixT {}) = pprInfixT p t
+pprType _ (ParensT t) = parens (pprType noPrec t)
+pprType p (ImplicitParamT n ty) =
+ parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty
+pprType _ EqualityT = text "(~)"
+pprType p (ForallT tvars ctxt ty) =
+ parensIf (p >= funPrec) $ sep [pprForall tvars ctxt, pprType qualPrec ty]
+pprType p (ForallVisT tvars ty) =
+ parensIf (p >= funPrec) $ sep [pprForallVis tvars [], pprType qualPrec ty]
+pprType p t at AppT{} = pprTyApp p (split t)
+pprType p t at AppKindT{} = pprTyApp p (split t)
+
+------------------------------
+pprParendType :: Type -> Doc
+pprParendType = pprType appPrec
+
+pprInfixT :: Precedence -> Type -> Doc
+pprInfixT p = \case
+ InfixT x n y -> with x n y "" opPrec
+ UInfixT x n y -> with x n y "" unopPrec
+ PromotedInfixT x n y -> with x n y "'" opPrec
+ PromotedUInfixT x n y -> with x n y "'" unopPrec
+ t -> pprParendType t
where
- with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y
+ with x n y prefix p' =
+ parensIf
+ (p >= p')
+ (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y)
instance Ppr Type where
- ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
- ppr (ForallVisT tvars ty) = sep [pprForallVis tvars [], ppr ty]
- ppr ty = pprTyApp (split ty)
- -- Works, in a degenerate way, for SigT, and puts parens round (ty :: kind)
- -- See Note [Pretty-printing kind signatures]
+ ppr = pprType noPrec
instance Ppr TypeArg where
ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty)
ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)
@@ -866,38 +871,40 @@ parens around it. E.g. the parens are required here:
type instance F Int = (Bool :: *)
So we always print a SigT with parens (see #10050). -}
-pprTyApp :: (Type, [TypeArg]) -> Doc
-pprTyApp (MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])
- | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", ppr arg2]
- | c == manyName = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
-pprTyApp (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =
- sep [pprFunArgType arg1 <+> text "%" <> ppr argm <+> text "->", ppr arg2]
-pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
-pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) =
- sep [pprFunArgType arg1 <+> text "~", ppr arg2]
-pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg)
-pprTyApp (TupleT 1, args) = pprTyApp (ConT (tupleTypeName 1), args)
-pprTyApp (PromotedTupleT 1, args) = pprTyApp (PromotedT (tupleDataName 1), args)
-pprTyApp (TupleT n, args)
+pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc
+pprTyApp p app@(MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])
+ | p >= funPrec = parens (pprTyApp noPrec app)
+ | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", pprType qualPrec arg2]
+ | c == manyName = sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]
+pprTyApp p (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =
+ parensIf (p >= funPrec) $
+ sep [pprFunArgType arg1 <+> text "%" <> pprType appPrec argm <+> text "->",
+ pprType qualPrec arg2]
+pprTyApp p (ArrowT, [TANormal arg1, TANormal arg2]) =
+ parensIf (p >= funPrec) $
+ sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]
+pprTyApp p (EqualityT, [TANormal arg1, TANormal arg2]) =
+ parensIf (p >= opPrec) $
+ sep [pprType opPrec arg1 <+> text "~", pprType opPrec arg2]
+pprTyApp _ (ListT, [TANormal arg]) = brackets (pprType noPrec arg)
+pprTyApp p (TupleT 1, args) = pprTyApp p (ConT (tupleTypeName 1), args)
+pprTyApp _ (TupleT n, args)
| length args == n, Just args' <- traverse fromTANormal args
= parens (commaSep args')
-pprTyApp (PromotedTupleT n, args)
+pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), args)
+pprTyApp _ (PromotedTupleT n, args)
| length args == n, Just args' <- traverse fromTANormal args
= quoteParens (commaSep args')
-pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args)
+pprTyApp p (fun, args) =
+ parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args)
fromTANormal :: TypeArg -> Maybe Type
fromTANormal (TANormal arg) = Just arg
fromTANormal (TyArg _) = Nothing
-pprFunArgType :: Type -> Doc -- Should really use a precedence argument
--- Everything except forall and (->) binds more tightly than (->)
-pprFunArgType ty@(ForallT {}) = parens (ppr ty)
-pprFunArgType ty@(ForallVisT {}) = parens (ppr ty)
-pprFunArgType ty@(((MulArrowT `AppT` _) `AppT` _) `AppT` _) = parens (ppr ty)
-pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
-pprFunArgType ty@(SigT _ _) = parens (ppr ty)
-pprFunArgType ty = ppr ty
+-- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->).
+pprFunArgType :: Type -> Doc
+pprFunArgType = pprType funPrec
data ForallVisFlag = ForallVis -- forall a -> {...}
| ForallInvis -- forall a. {...}
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -1,5 +1,10 @@
# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
+## 2.20.0.0
+
+ * The `Ppr.pprInfixT` function has gained a `Precedence` argument.
+ * The values of named precedence levels like `Ppr.appPrec` have changed.
+
## 2.19.0.0
* Add `DefaultD` constructor to support Haskell `default` declarations.
=====================================
testsuite/tests/th/T15845.stderr
=====================================
@@ -1,5 +1,5 @@
data family T15845.F1 (a_0 :: *) (b_1 :: *) :: *
-data instance forall (a_2 :: *) (b_3 :: *). T15845.F1 ([a_2]) b_3
+data instance forall (a_2 :: *) (b_3 :: *). T15845.F1 [a_2] b_3
= T15845.MkF1
data family T15845.F2 (a_0 :: *) :: *
data instance forall (a_1 :: *). T15845.F2 a_1 = T15845.MkF2
=====================================
testsuite/tests/th/T21723.hs
=====================================
@@ -0,0 +1,8 @@
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = do
+ putStrLn $ pprint (InfixT (ArrowT `AppT` StarT `AppT` StarT) (mkName ":>:") StarT)
+ putStrLn $ pprint (InfixT (ParensT $ ArrowT `AppT` StarT `AppT` StarT) (mkName ":>:") StarT)
=====================================
testsuite/tests/th/T21723.stdout
=====================================
@@ -0,0 +1,2 @@
+(* -> *) :>: *
+(* -> *) :>: *
=====================================
testsuite/tests/th/T21942.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE LinearTypes, TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = runQ [t| forall a m n. a %(m n) -> a |] >>= putStrLn . pprint
=====================================
testsuite/tests/th/T21942.stdout
=====================================
@@ -0,0 +1 @@
+forall a_0 m_1 n_2 . a_0 %(m_1 n_2) -> a_0
=====================================
testsuite/tests/th/T9262.stderr
=====================================
@@ -1 +1 @@
-instance GHC.Classes.Eq a_0 => GHC.Classes.Eq ([a_0])
+instance GHC.Classes.Eq a_0 => GHC.Classes.Eq [a_0]
=====================================
testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
=====================================
@@ -3,13 +3,13 @@ data instance forall (a_1 :: *). TH_reifyExplicitForAllFams.F (GHC.Maybe.Maybe a
= TH_reifyExplicitForAllFams.MkF a_1
class TH_reifyExplicitForAllFams.C (a_0 :: *)
where {type TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *}
-instance TH_reifyExplicitForAllFams.C ([a_2])
+instance TH_reifyExplicitForAllFams.C [a_2]
type family TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
type instance forall (a_2 :: *)
- (b_3 :: *). TH_reifyExplicitForAllFams.G ([a_2])
+ (b_3 :: *). TH_reifyExplicitForAllFams.G [a_2]
b_3 = Data.Proxy.Proxy b_3
type family TH_reifyExplicitForAllFams.H (a_0 :: *) (b_1 :: *) :: * where
- forall (x_2 :: *) (y_3 :: *). TH_reifyExplicitForAllFams.H ([x_2])
+ forall (x_2 :: *) (y_3 :: *). TH_reifyExplicitForAllFams.H [x_2]
(Data.Proxy.Proxy y_3) = Data.Either.Either x_2
y_3
forall (z_4 :: *). TH_reifyExplicitForAllFams.H z_4
=====================================
testsuite/tests/th/TH_unresolvedInfix.stdout
=====================================
@@ -44,5 +44,5 @@ N :+ (N :+ N :+ N)
(N)
N :+ (N :+ N :+ N)
(N)
-(Int + (Int + Int + Int))
-Int
+Int + (Int + (Int + Int))
+(Int)
=====================================
testsuite/tests/th/all.T
=====================================
@@ -553,3 +553,5 @@ test('T20711', normal, compile_and_run, [''])
test('T20868', normal, compile_and_run, [''])
test('Lift_ByteArray', normal, compile_and_run, [''])
test('T21920', normal, compile_and_run, [''])
+test('T21723', normal, compile_and_run, [''])
+test('T21942', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa7e1c02752b6be391c7c76825979e6dc7b969e3...3172c7b0807a8a27b54ac4ff139e1b69d68609cf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa7e1c02752b6be391c7c76825979e6dc7b969e3...3172c7b0807a8a27b54ac4ff139e1b69d68609cf
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/20220823/93ffa05e/attachment-0001.html>
More information about the ghc-commits
mailing list