[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: Fix typo
Marge Bot
gitlab at gitlab.haskell.org
Wed Jul 29 06:56:08 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4a1ec062 by Felix Wiemuth at 2020-07-29T02:55:58-04:00
Fix typo
- - - - -
6576b14b by Brandon Chinn at 2020-07-29T02:55:59-04:00
Add regression test for #16341
- - - - -
eed839ac by Brandon Chinn at 2020-07-29T02:55:59-04:00
Pass dit_rep_tc_args to dsm_stock_gen_fn
- - - - -
ad830c27 by Brandon Chinn at 2020-07-29T02:55:59-04:00
Pass tc_args to gen_fn
- - - - -
14d36e24 by Brandon Chinn at 2020-07-29T02:55:59-04:00
Filter out unreachable constructors when deriving stock instances (#16431)
- - - - -
86573c06 by Simon Peyton Jones at 2020-07-29T02:55:59-04:00
Remove an incorrect WARN in extendLocalRdrEnv
I noticed this warning going off, and discovered that it's
really fine. This small patch removes the warning, and docments
what is going on.
- - - - -
87826dae by Simon Peyton Jones at 2020-07-29T02:56:00-04:00
Kill off sc_mult and as_mult fields
They are readily derivable from other fields, so this is more
efficient, and less error prone.
Fixes #18494
- - - - -
2e870739 by Simon Peyton Jones at 2020-07-29T02:56:00-04:00
Add two bangs to improve perf of flattening
This tiny patch improves the compile time of flatten-heavy
programs by 1-2%, by adding two bangs.
Addresses (somewhat) #18502
This reduces allocation by
T9872b -1.1%
T9872d -3.3%
T5321Fun -0.2%
T5631 -0.2%
T5837 +0.1%
T6048 +0.1%
Metric Decrease:
T9872b
T9872d
- - - - -
4ea13e02 by Peter Trommler at 2020-07-29T02:56:00-04:00
configure: Fix build system on ARM
- - - - -
f0537a5c by Sylvain Henry at 2020-07-29T02:56:02-04:00
Fix bug in Natural multiplication (fix #18509)
A bug was lingering in Natural multiplication (inverting two limbs)
despite QuickCheck tests used during the development leading to wrong
results (independently of the selected backend).
- - - - -
20 changed files:
- aclocal.m4
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Functor.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Infer.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Types/Name/Reader.hs
- libraries/base/Data/Maybe.hs
- libraries/ghc-bignum/src/GHC/Num/BigNat.hs
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- libraries/ghc-bignum/src/GHC/Num/WordArray.hs
- + testsuite/tests/deriving/should_compile/T16341.hs
- testsuite/tests/deriving/should_compile/all.T
- + testsuite/tests/numeric/should_run/T18509.hs
- + testsuite/tests/numeric/should_run/T18509.stdout
- testsuite/tests/numeric/should_run/all.T
Changes:
=====================================
aclocal.m4
=====================================
@@ -206,7 +206,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
;;
arm)
GET_ARM_ISA()
- test -z "[$]2" || eval "[$]2=\"ArchARM \$ARM_ISA \$ARM_ISA_EXT \$ARM_ABI}\""
+ test -z "[$]2" || eval "[$]2=\"ArchARM \$ARM_ISA \$ARM_ISA_EXT \$ARM_ABI\""
;;
aarch64)
test -z "[$]2" || eval "[$]2=ArchARM64"
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1891,7 +1891,9 @@ substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
--
-- For the inverse operation, see 'liftCoMatch'
ty_co_subst :: LiftingContext -> Role -> Type -> Coercion
-ty_co_subst lc role ty
+ty_co_subst !lc role ty
+ -- !lc: making this function strict in lc allows callers to
+ -- pass its two components separately, rather than boxing them
= go role ty
where
go :: Role -> Type -> Coercion
@@ -2864,9 +2866,9 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
-- need a coercion (kind_co :: old_kind ~ new_kind).
--
-- The bangs here have been observed to improve performance
- -- significantly in optimized builds.
- let kind_co = mkSymCo $
- liftCoSubst Nominal lc (tyCoBinderType binder)
+ -- significantly in optimized builds; see #18502
+ let !kind_co = mkSymCo $
+ liftCoSubst Nominal lc (tyCoBinderType binder)
!casted_xi = xi `mkCastTy` kind_co
casted_co = mkCoherenceLeftCo role xi kind_co co
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -1004,7 +1004,7 @@ simplExprF1 env (App fun arg) cont
, sc_hole_ty = hole'
, sc_cont = cont } }
_ ->
- -- crucially, these are /lazy/ bindings. They will
+ -- Crucially, sc_hole_ty is a /lazy/ binding. It will
-- be forced only if we need to run contHoleType.
-- When these are forced, we might get quadratic behavior;
-- this quadratic blowup could be avoided by drilling down
@@ -1012,17 +1012,10 @@ simplExprF1 env (App fun arg) cont
-- (instead of one-at-a-time). But in practice, we have not
-- observed the quadratic behavior, so this extra entanglement
-- seems not worthwhile.
- --
- -- But the (exprType fun) is repeated, to push it into two
- -- separate, rarely used, thunks; rather than always alloating
- -- a shared thunk. Makes a small efficiency difference
- let fun_ty = exprType fun
- (m, _, _) = splitFunTy fun_ty
- in
simplExprF env fun $
ApplyToVal { sc_arg = arg, sc_env = env
, sc_hole_ty = substTy env (exprType fun)
- , sc_dup = NoDup, sc_cont = cont, sc_mult = m }
+ , sc_dup = NoDup, sc_cont = cont }
simplExprF1 env expr@(Lam {}) cont
= {-#SCC "simplExprF1-Lam" #-}
@@ -1327,8 +1320,8 @@ rebuild env expr cont
Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
-> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
- StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }
- -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont
+ StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
+ -> rebuildCall env (addValArgTo fun expr fun_ty ) cont
StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
, sc_env = se, sc_cont = cont }
-> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
@@ -1420,7 +1413,7 @@ simplCast env body co0 cont0
-- co1 :: t1 ~ s1
-- co2 :: s2 ~ t2
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_dup = dup, sc_cont = tail, sc_mult = m })
+ , sc_dup = dup, sc_cont = tail })
| Just (co1, m_co2) <- pushCoValArg co
, let new_ty = coercionRKind co1
, not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg
@@ -1444,8 +1437,7 @@ simplCast env body co0 cont0
, sc_env = arg_se'
, sc_dup = dup'
, sc_cont = tail'
- , sc_hole_ty = coercionLKind co
- , sc_mult = m }) } }
+ , sc_hole_ty = coercionLKind co }) } }
addCoerce co cont
| isReflexiveCo co = return cont -- Having this at the end makes a huge
@@ -1981,17 +1973,18 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
-- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
- (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m })
+ (ApplyToVal { sc_arg = arg, sc_env = arg_se
+ , sc_cont = cont, sc_hole_ty = fun_ty })
| fun_id `hasKey` runRWKey
, not (contIsStop cont) -- Don't fiddle around if the continuation is boring
, [ TyArg {}, TyArg {} ] <- rev_args
= do { s <- newId (fsLit "s") Many realWorldStatePrimTy
- ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ ; let (m,_,_) = splitFunTy fun_ty
+ env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
ty' = contResultType cont
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
, sc_env = env', sc_cont = cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty'
- , sc_mult = m }
+ , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
-- cont' applies to s, then K
; body' <- simplExprC env' arg cont'
; let arg' = Lam s body'
@@ -2002,10 +1995,10 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
rebuildCall env fun_info
(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_hole_ty = fun_ty
- , sc_cont = cont, sc_mult = m })
+ , sc_cont = cont })
-- Argument is already simplified
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
- = rebuildCall env (addValArgTo fun_info (m, arg) fun_ty) cont
+ = rebuildCall env (addValArgTo fun_info arg fun_ty) cont
-- Strict arguments
| isStrictArgInfo fun_info
@@ -2014,7 +2007,7 @@ rebuildCall env fun_info
simplExprF (arg_se `setInScopeFromE` env) arg
(StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
, sc_dup = Simplified
- , sc_cont = cont, sc_mult = m })
+ , sc_cont = cont })
-- Note [Shadowing]
-- Lazy arguments
@@ -2025,7 +2018,7 @@ rebuildCall env fun_info
-- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
(mkLazyArgStop arg_ty (lazyArgContext fun_info))
- ; rebuildCall env (addValArgTo fun_info (m, arg') fun_ty) cont }
+ ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
where
arg_ty = funArgTy fun_ty
@@ -2233,24 +2226,10 @@ trySeqRules in_env scrut rhs cont
, as_hole_ty = res2_ty }
, ValArg { as_arg = no_cast_scrut
, as_dmd = seqDmd
- , as_hole_ty = res3_ty
- , as_mult = Many } ]
- -- The multiplicity of the scrutiny above is Many because the type
- -- of seq requires that its first argument is unrestricted. The
- -- typing rule of case also guarantees it though. In a more
- -- general world, where the first argument of seq would have
- -- affine multiplicity, then we could use the multiplicity of
- -- the case (held in the case binder) instead.
+ , as_hole_ty = res3_ty } ]
rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
, sc_env = in_env, sc_cont = cont
- , sc_hole_ty = res4_ty, sc_mult = Many }
- -- The multiplicity in sc_mult above is the
- -- multiplicity of the second argument of seq. Since
- -- seq's type, as it stands, imposes that its second
- -- argument be unrestricted, so is
- -- sc_mult. However, a more precise typing rule,
- -- for seq, would be to have it be linear. In which
- -- case, sc_mult should be 1.
+ , sc_hole_ty = res4_ty }
-- Lazily evaluated, so we don't do most of this
@@ -3304,7 +3283,7 @@ mkDupableContWithDmds env _
mkDupableContWithDmds env _
(StrictArg { sc_fun = fun, sc_cont = cont
- , sc_fun_ty = fun_ty, sc_mult = m })
+ , sc_fun_ty = fun_ty })
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
| thumbsUpPlanA cont
= -- Use Plan A of Note [Duplicating StrictArg]
@@ -3318,18 +3297,17 @@ mkDupableContWithDmds env _
, StrictArg { sc_fun = fun { ai_args = args' }
, sc_cont = cont'
, sc_fun_ty = fun_ty
- , sc_mult = m
, sc_dup = OkToDup} ) }
| otherwise
= -- Use Plan B of Note [Duplicating StrictArg]
-- K[ f a b <> ] --> join j x = K[ f a b x ]
-- j <>
- do { let arg_ty = funArgTy fun_ty
- rhs_ty = contResultType cont
- ; arg_bndr <- newId (fsLit "arg") m arg_ty -- ToDo: check this linearity argument
+ do { let rhs_ty = contResultType cont
+ (m,arg_ty,_) = splitFunTy fun_ty
+ ; arg_bndr <- newId (fsLit "arg") m arg_ty
; let env' = env `addNewInScopeIds` [arg_bndr]
- ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (m, Var arg_bndr) fun_ty) cont
+ ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
where
thumbsUpPlanA (StrictArg {}) = False
@@ -3349,7 +3327,7 @@ mkDupableContWithDmds env dmds
mkDupableContWithDmds env dmds
(ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se
- , sc_cont = cont, sc_hole_ty = hole_ty, sc_mult = mult })
+ , sc_cont = cont, sc_hole_ty = hole_ty })
= -- e.g. [...hole...] (...arg...)
-- ==>
-- let a = ...arg...
@@ -3369,7 +3347,7 @@ mkDupableContWithDmds env dmds
-- has turned arg'' into a fresh variable
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup, sc_cont = cont'
- , sc_hole_ty = hole_ty, sc_mult = mult }) }
+ , sc_hole_ty = hole_ty }) }
mkDupableContWithDmds env _
(Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
@@ -3439,7 +3417,6 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty
, sc_fun = arg_info
, sc_fun_ty = idType join_bndr
, sc_cont = mkBoringStop res_ty
- , sc_mult = Many -- ToDo: check this!
} ) }
mkDupableAlt :: Platform -> OutId
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -125,8 +125,7 @@ data SimplCont
-- See Note [The hole type in ApplyToTy/Val]
, sc_arg :: InExpr -- The argument,
, sc_env :: StaticEnv -- see Note [StaticEnv invariant]
- , sc_cont :: SimplCont
- , sc_mult :: Mult }
+ , sc_cont :: SimplCont }
| ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ]
{ sc_arg_ty :: OutType -- Argument type
@@ -160,8 +159,7 @@ data SimplCont
, sc_fun_ty :: OutType -- Type of the function (f e1 .. en),
-- presumably (arg_ty -> res_ty)
-- where res_ty is expected by sc_cont
- , sc_cont :: SimplCont
- , sc_mult :: Mult }
+ , sc_cont :: SimplCont }
| TickIt -- (TickIt t K)[e] = K[ tick t e ]
(Tickish Id) -- Tick tickish <hole>
@@ -282,8 +280,7 @@ data ArgInfo
}
data ArgSpec
- = ValArg { as_mult :: Mult
- , as_dmd :: Demand -- Demand placed on this argument
+ = ValArg { as_dmd :: Demand -- Demand placed on this argument
, as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal
, as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2)
@@ -300,16 +297,15 @@ instance Outputable ArgInfo where
, text "args =" <+> ppr args ])
instance Outputable ArgSpec where
- ppr (ValArg { as_mult = mult, as_arg = arg }) = text "ValArg" <+> ppr mult <+> ppr arg
+ ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg
ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
ppr (CastBy c) = text "CastBy" <+> ppr c
-addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo
-addValArgTo ai (w, arg) hole_ty
+addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo
+addValArgTo ai arg hole_ty
| ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai
-- Pop the top demand and and discounts off
- , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty
- , as_mult = w, as_dmd = dmd }
+ , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }
= ai { ai_args = arg_spec : ai_args ai
, ai_dmds = dmds
, ai_discs = discs
@@ -345,9 +341,9 @@ pushSimplifiedArgs env (arg : args) k
= case arg of
TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
-> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }
- ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }
+ ValArg { as_arg = arg, as_hole_ty = hole_ty }
-> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified
- , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w }
+ , sc_hole_ty = hole_ty, sc_cont = rest }
CastBy c -> CastIt c rest
where
rest = pushSimplifiedArgs env args k
@@ -446,7 +442,7 @@ contHoleType (TickIt _ k) = contHoleType k
contHoleType (CastIt co _) = coercionLKind co
contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
= perhapsSubstTy dup se (idType b)
-contHoleType (StrictArg { sc_fun_ty = ty, sc_mult = _m }) = funArgTy ty
+contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty
contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]
contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val]
contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })
@@ -464,12 +460,14 @@ contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })
contHoleScaling :: SimplCont -> Mult
contHoleScaling (Stop _ _) = One
contHoleScaling (CastIt _ k) = contHoleScaling k
-contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) =
- (idMult id) `mkMultMul` contHoleScaling k
-contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) =
- w `mkMultMul` contHoleScaling k
-contHoleScaling (Select { sc_bndr = id, sc_cont = k }) =
- (idMult id) `mkMultMul` contHoleScaling k
+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })
+ = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (Select { sc_bndr = id, sc_cont = k })
+ = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })
+ = w `mkMultMul` contHoleScaling k
+ where
+ (w, _, _) = splitFunTy fun_ty
contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k
contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k
contHoleScaling (TickIt _ k) = contHoleScaling k
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -236,19 +236,30 @@ newPatName (LetMk is_top fix_env) rdr_name
do { name <- case is_top of
NotTopLevel -> newLocalBndrRn rdr_name
TopLevel -> newTopSrcBinder rdr_name
- ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here
- -- See Note [View pattern usage]
+ ; bindLocalNames [name] $
+ -- Do *not* use bindLocalNameFV here;
+ -- see Note [View pattern usage]
+ -- For the TopLevel case
+ -- see Note [bindLocalNames for an External name]
addLocalFixities fix_env [name] $
thing_inside name })
- -- Note: the bindLocalNames is somewhat suspicious
- -- because it binds a top-level name as a local name.
- -- however, this binding seems to work, and it only exists for
- -- the duration of the patterns and the continuation;
- -- then the top-level name is added to the global env
- -- before going on to the RHSes (see GHC.Rename.Module).
+{- Note [bindLocalNames for an External name]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the TopLevel case, the use of bindLocalNames here is somewhat
+suspicious because it binds a top-level External name in the
+LocalRdrEnv. c.f. Note [LocalRdrEnv] in GHC.Types.Name.Reader.
+
+However, this only happens when renaming the LHS (only) of a top-level
+pattern binding. Even though this only the LHS, we need to bring the
+binder into scope in the pattern itself in case the binder is used in
+subsequent view patterns. A bit bizarre, something like
+ (x, Just y <- f x) = e
+
+Anyway, bindLocalNames does work, and the binding only exists for the
+duration of the pattern; then the top-level name is added to the
+global env before going on to the RHSes (see GHC.Rename.Module).
-{-
Note [View pattern usage]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -2038,9 +2038,12 @@ genDerivStuff mechanism loc clas inst_tys tyvars
-> gen_newtype_or_via rhs_ty
-- Try a stock deriver
- DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc}
+ DerivSpecStock { dsm_stock_dit = DerivInstTys
+ { dit_rep_tc = rep_tc
+ , dit_rep_tc_args = rep_tc_args
+ }
, dsm_stock_gen_fn = gen_fn }
- -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys
+ -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys
pure (binds, [], faminsts, field_names)
-- Try DeriveAnyClass
=====================================
compiler/GHC/Tc/Deriv/Functor.hs
=====================================
@@ -151,10 +151,10 @@ is a similar algorithm for generating `p <$ x` (for some constant `p`):
$(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
-}
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-- When the argument is phantom, we can use fmap _ = coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Functor_binds loc tycon
+gen_Functor_binds loc tycon _
| Phantom <- last (tyConRoles tycon)
= (unitBag fmap_bind, emptyBag)
where
@@ -165,10 +165,10 @@ gen_Functor_binds loc tycon
coerce_Expr]
fmap_match_ctxt = mkPrefixFunRhs fmap_name
-gen_Functor_binds loc tycon
+gen_Functor_binds loc tycon tycon_args
= (listToBag [fmap_bind, replace_bind], emptyBag)
where
- data_cons = tyConDataCons tycon
+ data_cons = getPossibleDataCons tycon tycon_args
fmap_name = L loc fmap_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
@@ -787,10 +787,10 @@ could surprise users if they switch to other types, but Ryan Scott seems to
think it's okay to do it for now.
-}
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-- When the parameter is phantom, we can use foldMap _ _ = mempty
-- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Foldable_binds loc tycon
+gen_Foldable_binds loc tycon _
| Phantom <- last (tyConRoles tycon)
= (unitBag foldMap_bind, emptyBag)
where
@@ -801,7 +801,7 @@ gen_Foldable_binds loc tycon
mempty_Expr]
foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
-gen_Foldable_binds loc tycon
+gen_Foldable_binds loc tycon tycon_args
| null data_cons -- There's no real point producing anything but
-- foldMap for a type with no constructors.
= (unitBag foldMap_bind, emptyBag)
@@ -809,7 +809,7 @@ gen_Foldable_binds loc tycon
| otherwise
= (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
where
- data_cons = tyConDataCons tycon
+ data_cons = getPossibleDataCons tycon tycon_args
foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
@@ -1016,10 +1016,10 @@ removes all such types from consideration.
See Note [Generated code for DeriveFoldable and DeriveTraversable].
-}
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
-- When the argument is phantom, we can use traverse = pure . coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Traversable_binds loc tycon
+gen_Traversable_binds loc tycon _
| Phantom <- last (tyConRoles tycon)
= (unitBag traverse_bind, emptyBag)
where
@@ -1031,10 +1031,10 @@ gen_Traversable_binds loc tycon
(nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
traverse_match_ctxt = mkPrefixFunRhs traverse_name
-gen_Traversable_binds loc tycon
+gen_Traversable_binds loc tycon tycon_args
= (unitBag traverse_bind, emptyBag)
where
- data_cons = tyConDataCons tycon
+ data_cons = getPossibleDataCons tycon tycon_args
traverse_name = L loc traverse_RDR
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -33,7 +33,9 @@ module GHC.Tc.Deriv.Generate (
mkCoerceClassMethEqn,
genAuxBinds,
ordOpTbl, boxConTbl, litConTbl,
- mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
+ mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
+
+ getPossibleDataCons, tyConInstArgTys
) where
#include "HsVersions.h"
@@ -212,14 +214,14 @@ for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
-}
-gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Eq_binds loc tycon = do
+gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc tycon tycon_args = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
return (method_binds con2tag_RDR, aux_binds con2tag_RDR)
where
- all_cons = tyConDataCons tycon
+ all_cons = getPossibleDataCons tycon tycon_args
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
-- If there are ten or more (arbitrary number) nullary constructors,
@@ -396,8 +398,8 @@ gtResult OrdGE = true_Expr
gtResult OrdGT = true_Expr
------------
-gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ord_binds loc tycon = do
+gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc tycon tycon_args = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
@@ -432,7 +434,7 @@ gen_Ord_binds loc tycon = do
-- We want *zero-based* tags, because that's what
-- con2Tag returns (generated by untag_Expr)!
- tycon_data_cons = tyConDataCons tycon
+ tycon_data_cons = getPossibleDataCons tycon tycon_args
single_con_type = isSingleton tycon_data_cons
(first_con : _) = tycon_data_cons
(last_con : _) = reverse tycon_data_cons
@@ -646,8 +648,8 @@ instance ... Enum (Foo ...) where
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
-}
-gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Enum_binds loc tycon = do
+gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc tycon _ = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -738,8 +740,8 @@ gen_Enum_binds loc tycon = do
************************************************************************
-}
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Bounded_binds loc tycon
+gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds loc tycon _
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
| otherwise
@@ -825,9 +827,9 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
-}
-gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ix_binds loc tycon = do
+gen_Ix_binds loc tycon _ = do
-- See Note [Auxiliary binders]
con2tag_RDR <- new_con2tag_rdr_name loc tycon
tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -1028,10 +1030,10 @@ These instances are also useful for Read (Either Int Emp), where
we want to be able to parse (Left 3) just fine.
-}
-gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
-> (LHsBinds GhcPs, BagDerivStuff)
-gen_Read_binds get_fixity loc tycon
+gen_Read_binds get_fixity loc tycon _
= (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
where
-----------------------------------------------------------------------
@@ -1212,13 +1214,13 @@ Example
-- the most tightly-binding operator
-}
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
-> (LHsBinds GhcPs, BagDerivStuff)
-gen_Show_binds get_fixity loc tycon
+gen_Show_binds get_fixity loc tycon tycon_args
= (unitBag shows_prec, emptyBag)
where
- data_cons = tyConDataCons tycon
+ data_cons = getPossibleDataCons tycon tycon_args
shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
comma_space = nlHsVar showCommaSpace_RDR
@@ -1385,9 +1387,10 @@ we generate
gen_Data_binds :: SrcSpan
-> TyCon -- For data families, this is the
-- *representation* TyCon
+ -> [Type]
-> TcM (LHsBinds GhcPs, -- The method bindings
BagDerivStuff) -- Auxiliary bindings
-gen_Data_binds loc rep_tc
+gen_Data_binds loc rep_tc _
= do { -- See Note [Auxiliary binders]
dataT_RDR <- new_dataT_rdr_name loc rep_tc
; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
@@ -1616,8 +1619,8 @@ Example:
-}
-gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
+gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
(map (pats_etc mk_exp) data_cons)
@@ -1626,7 +1629,7 @@ gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
mk_exp = ExpBr noExtField
mk_texp = TExpBr noExtField
- data_cons = tyConDataCons tycon
+ data_cons = getPossibleDataCons tycon tycon_args
pats_etc mk_bracket data_con
= ([con_pat], lift_Expr)
@@ -2515,6 +2518,39 @@ newAuxBinderRdrName loc parent occ_fun = do
uniq <- newUnique
pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
+-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@
+-- whose return types match when checked against @tycon_args at .
+--
+-- See Note [Filter out impossible GADT data constructors]
+getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
+getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon
+ where
+ isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)
+
+-- | Given a type constructor @tycon@ of arity /n/ and a list of argument types
+-- @tycon_args@ of length /m/,
+--
+-- @
+-- tyConInstArgTys tycon tycon_args
+-- @
+--
+-- returns
+--
+-- @
+-- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]
+-- @
+--
+-- where @extra_args@ are distinct type variables.
+--
+-- Examples:
+--
+-- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.
+--
+-- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.
+tyConInstArgTys :: TyCon -> [Type] -> [Type]
+tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix
+ where
+ tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon
{-
Note [Auxiliary binders]
@@ -2733,4 +2769,56 @@ derived instances within the same module, not separated by any TH splices.
(This is the case described in "Wrinkle: Reducing code duplication".) In
situation (1), we can at least fall back on GHC's simplifier to pick up
genAuxBinds' slack.
+
+Note [Filter out impossible GADT data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Some stock-derivable classes will filter out impossible GADT data constructors,
+to rule out problematic constructors when deriving instances. e.g.
+
+```
+data Foo a where
+ X :: Foo Int
+ Y :: (Bool -> Bool) -> Foo Bool
+```
+
+when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't
+exist in the first place. For instance, if we write
+
+```
+deriving instance Eq (Foo Int)
+```
+
+it should generate:
+
+```
+instance Eq (Foo Int) where
+ X == X = True
+```
+
+Classes that filter constructors:
+
+* Eq
+* Ord
+* Show
+* Lift
+* Functor
+* Foldable
+* Traversable
+
+Classes that do not filter constructors:
+
+* Enum: doesn't make sense for GADTs in the first place
+* Bounded: only makes sense for GADTs with a single constructor
+* Ix: only makes sense for GADTs with a single constructor
+* Read: `Read a` returns `a` instead of consumes `a`, so filtering data
+ constructors would make this function _more_ partial instead of less
+* Data: derived implementations of gunfold rely on a constructor-indexing
+ scheme that wouldn't work if certain constructors were filtered out
+* Generic/Generic1: doesn't make sense for GADTs
+
+Classes that do not currently filter constructors may do so in the future, if
+there is a valid use-case and we have requirements for how they should work.
+
+See #16341 and the T16341.hs test case.
-}
=====================================
compiler/GHC/Tc/Deriv/Infer.hs
=====================================
@@ -260,9 +260,7 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys
-- substitute each type variable with its counterpart in the derived
-- instance. rep_tc_args lists each of these counterpart types in
-- the same order as the type variables.
- all_rep_tc_args
- = rep_tc_args ++ map mkTyVarTy
- (drop (length rep_tc_args) rep_tc_tvs)
+ all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args
-- Stupid constraints
stupid_constraints
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -218,8 +218,9 @@ data DerivSpecMechanism
-- instance, including what type constructor the last argument is
-- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
, dsm_stock_gen_fn ::
- SrcSpan -> TyCon
- -> [Type]
+ SrcSpan -> TyCon -- dit_rep_tc
+ -> [Type] -- dit_rep_tc_args
+ -> [Type] -- inst_tys
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
-- ^ This function returns three things:
--
@@ -424,7 +425,7 @@ instance Outputable DerivContext where
-- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
data OriginativeDerivStatus
= CanDeriveStock -- Stock class, can derive
- (SrcSpan -> TyCon -> [Type]
+ (SrcSpan -> TyCon -> [Type] -> [Type]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
| StockClassError SDoc -- Stock class, but can't do it
| CanDeriveAnyClass -- See Note [Deriving any class]
@@ -563,6 +564,7 @@ hasStockDeriving
:: Class -> Maybe (SrcSpan
-> TyCon
-> [Type]
+ -> [Type]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
hasStockDeriving clas
= assocMaybe gen_list (getUnique clas)
@@ -571,6 +573,7 @@ hasStockDeriving clas
:: [(Unique, SrcSpan
-> TyCon
-> [Type]
+ -> [Type]
-> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
gen_list = [ (eqClassKey, simpleM gen_Eq_binds)
, (ordClassKey, simpleM gen_Ord_binds)
@@ -587,25 +590,25 @@ hasStockDeriving clas
, (genClassKey, generic (gen_Generic_binds Gen0))
, (gen1ClassKey, generic (gen_Generic_binds Gen1)) ]
- simple gen_fn loc tc _
- = let (binds, deriv_stuff) = gen_fn loc tc
+ simple gen_fn loc tc tc_args _
+ = let (binds, deriv_stuff) = gen_fn loc tc tc_args
in return (binds, deriv_stuff, [])
-- Like `simple`, but monadic. The only monadic thing that these functions
-- do is allocate new Uniques, which are used for generating the names of
-- auxiliary bindings.
-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
- simpleM gen_fn loc tc _
- = do { (binds, deriv_stuff) <- gen_fn loc tc
+ simpleM gen_fn loc tc tc_args _
+ = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args
; return (binds, deriv_stuff, []) }
- read_or_show gen_fn loc tc _
+ read_or_show gen_fn loc tc tc_args _
= do { fix_env <- getDataConFixityFun tc
- ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+ ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args
field_names = all_field_names tc
; return (binds, deriv_stuff, field_names) }
- generic gen_fn _ tc inst_tys
+ generic gen_fn _ tc _ inst_tys
= do { (binds, faminst) <- gen_fn tc inst_tys
; let field_names = all_field_names tc
; return (binds, unitBag (DerivFamInst faminst), field_names) }
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -338,13 +338,24 @@ instance Ord RdrName where
************************************************************************
-}
+{- Note [LocalRdrEnv]
+~~~~~~~~~~~~~~~~~~~~~
+The LocalRdrEnv is used to store local bindings (let, where, lambda, case).
+
+* It is keyed by OccName, because we never use it for qualified names.
+
+* It maps the OccName to a Name. That Name is almost always an
+ Internal Name, but (hackily) it can be External too for top-level
+ pattern bindings. See Note [bindLocalNames for an External name]
+ in GHC.Rename.Pat
+
+* We keep the current mapping (lre_env), *and* the set of all Names in
+ scope (lre_in_scope). Reason: see Note [Splicing Exact names] in
+ GHC.Rename.Env.
+-}
+
-- | Local Reader Environment
---
--- This environment is used to store local bindings
--- (@let@, @where@, lambda, @case@).
--- It is keyed by OccName, because we never use it for qualified names
--- We keep the current mapping, *and* the set of all Names in scope
--- Reason: see Note [Splicing Exact names] in "GHC.Rename.Env"
+-- See Note [LocalRdrEnv]
data LocalRdrEnv = LRE { lre_env :: OccEnv Name
, lre_in_scope :: NameSet }
@@ -364,16 +375,15 @@ emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv
, lre_in_scope = emptyNameSet }
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
--- The Name should be a non-top-level thing
+-- See Note [LocalRdrEnv]
extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name
- = WARN( isExternalName name, ppr name )
- lre { lre_env = extendOccEnv env (nameOccName name) name
+ = lre { lre_env = extendOccEnv env (nameOccName name) name
, lre_in_scope = extendNameSet ns name }
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
+-- See Note [LocalRdrEnv]
extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names
- = WARN( any isExternalName names, ppr names )
- lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
+ = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
, lre_in_scope = extendNameSetList ns names }
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
=====================================
libraries/base/Data/Maybe.hs
=====================================
@@ -149,7 +149,7 @@ fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck
fromJust (Just x) = x
-- | The 'fromMaybe' function takes a default value and a 'Maybe'
--- value. If the 'Maybe' is 'Nothing', it returns the default values;
+-- value. If the 'Maybe' is 'Nothing', it returns the default value;
-- otherwise, it returns the value contained in the 'Maybe'.
--
-- ==== __Examples__
=====================================
libraries/ghc-bignum/src/GHC/Num/BigNat.hs
=====================================
@@ -228,8 +228,8 @@ bigNatToWordList bn = go (bigNatSize# bn)
-- | Convert two Word# (most-significant first) into a BigNat
bigNatFromWord2# :: Word# -> Word# -> BigNat#
bigNatFromWord2# 0## 0## = bigNatZero# (# #)
-bigNatFromWord2# 0## n = bigNatFromWord# n
-bigNatFromWord2# w1 w2 = wordArrayFromWord2# w1 w2
+bigNatFromWord2# 0## l = bigNatFromWord# l
+bigNatFromWord2# h l = wordArrayFromWord2# h l
-- | Convert a BigNat into a Word#
bigNatToWord# :: BigNat# -> Word#
=====================================
libraries/ghc-bignum/src/GHC/Num/Natural.hs
=====================================
@@ -86,8 +86,8 @@ naturalFromWord# x = NS x
-- | Convert two Word# (most-significant first) into a Natural
naturalFromWord2# :: Word# -> Word# -> Natural
naturalFromWord2# 0## 0## = naturalZero
-naturalFromWord2# 0## n = NS n
-naturalFromWord2# w1 w2 = NB (bigNatFromWord2# w2 w1)
+naturalFromWord2# 0## l = NS l
+naturalFromWord2# h l = NB (bigNatFromWord2# h l)
-- | Create a Natural from a Word
naturalFromWord :: Word -> Natural
=====================================
libraries/ghc-bignum/src/GHC/Num/WordArray.hs
=====================================
@@ -121,12 +121,14 @@ withNewWordArrayTrimedMaybe# sz act = case runRW# io of (# _, a #) -> a
-- | Create a WordArray# from two Word#
--
--- `byteArrayFromWord2# msw lsw = lsw:msw`
+-- `wordArrayFromWord2# h l
+-- where h is the most significant word
+-- l is the least significant word
wordArrayFromWord2# :: Word# -> Word# -> WordArray#
-wordArrayFromWord2# msw lsw =
+wordArrayFromWord2# h l =
withNewWordArray# 2# \mwa s ->
- case mwaWrite# mwa 0# lsw s of
- s -> mwaWrite# mwa 1# msw s
+ case mwaWrite# mwa 0# l s of
+ s -> mwaWrite# mwa 1# h s
-- | Create a WordArray# from one Word#
wordArrayFromWord# :: Word# -> WordArray#
=====================================
testsuite/tests/deriving/should_compile/T16341.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T16341 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Foo a where
+ Foo1 :: Foo Int
+ Foo2 :: (Bool -> Bool) -> Foo Bool
+
+-- These instances should work whether or not `Foo2` is a constructor in
+-- `Foo`, because the `Foo Int` designation precludes `Foo2` from being
+-- a reachable constructor
+deriving instance Show (Foo Int)
+deriving instance Eq (Foo Int)
+deriving instance Ord (Foo Int)
+deriving instance Lift (Foo Int)
+
+data Bar a b where
+ Bar1 :: b -> Bar Int b
+ Bar2 :: (Bool -> Bool) -> b -> Bar Bool b
+
+deriving instance Functor (Bar Int)
+deriving instance Foldable (Bar Int)
+deriving instance Traversable (Bar Int)
=====================================
testsuite/tests/deriving/should_compile/all.T
=====================================
@@ -118,6 +118,7 @@ test('T15398', normal, compile, [''])
test('T15637', normal, compile, [''])
test('T15831', normal, compile, [''])
test('T16179', normal, compile, [''])
+test('T16341', normal, compile, [''])
test('T16518', normal, compile, [''])
test('T17324', normal, compile, [''])
test('T17339', normal, compile,
=====================================
testsuite/tests/numeric/should_run/T18509.hs
=====================================
@@ -0,0 +1,6 @@
+import Numeric.Natural
+
+main :: IO ()
+main = do
+ print $ (0xFFFFFFFF0 * 0xFFFFFFFF0 :: Natural)
+ print $ (2 :: Natural) ^ (190 :: Int)
=====================================
testsuite/tests/numeric/should_run/T18509.stdout
=====================================
@@ -0,0 +1,2 @@
+4722366480670621958400
+1569275433846670190958947355801916604025588861116008628224
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -71,3 +71,4 @@ test('T497', normal, compile_and_run, ['-O'])
test('T17303', normal, compile_and_run, [''])
test('T18359', normal, compile_and_run, [''])
test('T18499', normal, compile_and_run, [''])
+test('T18509', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a287593a7cf9691278d566da1a8523ccdcf612b...f0537a5cfb2cd8078109a64d1c866433974b391c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8a287593a7cf9691278d566da1a8523ccdcf612b...f0537a5cfb2cd8078109a64d1c866433974b391c
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/20200729/a62d2a48/attachment-0001.html>
More information about the ghc-commits
mailing list