[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Remove outdated CPP in compiler/* and template-haskell/*
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Aug 28 12:33:14 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
2f6309a4 by Vladislav Zavialov at 2023-08-27T03:47:37-04:00
Remove outdated CPP in compiler/* and template-haskell/*
The boot compiler was bumped to 9.4 in cebb5819b43.
There is no point supporting older GHC versions with CPP.
- - - - -
5248fdf7 by Zubin Duggal at 2023-08-28T15:01:09+05:30
testsuite: Add regression test for #23861
Simon says this was fixed by
commit 8d68685468d0b6e922332a3ee8c7541efbe46137
Author: sheaf <sam.derbyshire at gmail.com>
Date: Fri Aug 4 15:28:45 2023 +0200
Remove zonk in tcVTA
- - - - -
f5a72381 by Zubin Duggal at 2023-08-28T08:32:57-04:00
testsuite: Add regression test for #23864
Simon says this was fixed by
commit 59202c800f2c97c16906120ab2561f6e1556e4af
Author: Sebastian Graf <sebastian.graf at kit.edu>
Date: Fri Mar 31 17:35:22 2023 +0200
CorePrep: Eliminate EmptyCase and unsafeEqualityProof in CoreToStg instead
We eliminate EmptyCase by way of `coreToStg (Case e _ _ []) = coreToStg e` now.
The main reason is that it plays far better in conjunction with eta expansion
(as we aim to do for arguments in CorePrep, #23083), because we can discard
any arguments, `(case e of {}) eta == case e of {}`, whereas in `(e |> co) eta`
it's impossible to discard the argument.
- - - - -
27 changed files:
- compiler/GHC/Cmm/DebugBlock.hs
- compiler/GHC/CmmToAsm/BlockLayout.hs
- compiler/GHC/CmmToAsm/Reg/Graph.hs
- compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Binary/Typeable.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- + testsuite/tests/simplCore/should_compile/T23864.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T23861.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Cmm/DebugBlock.hs
=====================================
@@ -119,9 +119,6 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
-- recover by copying ticks below.
scp' | SubScope _ scp' <- scp = scp'
| CombinedScope scp' _ <- scp = scp'
-#if __GLASGOW_HASKELL__ < 901
- | otherwise = panic "findP impossible"
-#endif
scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes
=====================================
compiler/GHC/CmmToAsm/BlockLayout.hs
=====================================
@@ -738,10 +738,6 @@ sequenceChain info weights blocks@((BasicBlock entry _):_) =
= [masterChain]
| (rest,entry) <- breakChainAt entry masterChain
= [entry,rest]
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise = pprPanic "Entry point eliminated" $
- ppr masterChain
-#endif
blockList
= assert (noDups [masterChain])
=====================================
compiler/GHC/CmmToAsm/Reg/Graph.hs
=====================================
@@ -385,11 +385,6 @@ graphAddCoalesce (r1, r2) graph
, RegReal _ <- r2
= graph
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise
- = panic "graphAddCoalesce"
-#endif
-
-- | Patch registers in code using the reg -> reg mapping in this graph.
patchRegsFromGraph
=====================================
compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
=====================================
@@ -399,12 +399,6 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
-#if __GLASGOW_HASKELL__ <= 810
- -- some other instruction
- | otherwise
- = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs
-#endif
-
-- | Combine the associations from all the inward control flow edges.
--
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -1684,11 +1684,6 @@ genMachOp_slow opt op [x, y] = case op of
MO_AlignmentCheck {} -> panicOp
-#if __GLASGOW_HASKELL__ < 811
- MO_VF_Extract {} -> panicOp
- MO_V_Extract {} -> panicOp
-#endif
-
where
binLlvmOp ty binOp allow_y_cast = do
platform <- getPlatform
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -624,10 +624,6 @@ opt_univ env sym prov role oty1 oty2
where
prov' = case prov of
-#if __GLASGOW_HASKELL__ < 901
--- This alt is redundant with the first match of the FunDef
- PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco
-#endif
ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco
PluginProv _ -> prov
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -43,10 +43,6 @@ import GHC.Types.Unique.FM
import Control.Monad
import Data.Foldable ( for_ )
-#if __GLASGOW_HASKELL__ <= 810
-import GHC.Utils.Panic ( panic )
-#endif
-
{-
************************************************************************
* *
@@ -285,9 +281,6 @@ simplifyPgm logger unit_env name_ppr_ctx opts
-- Loop
do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
} }
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise = panic "do_iteration"
-#endif
where
-- Remember the counts_so_far are reversed
totalise :: [SimplCount] -> SimplCount
=====================================
compiler/GHC/Data/FastString.hs
=====================================
@@ -146,9 +146,6 @@ import Foreign
import GHC.Conc.Sync (sharedCAF)
#endif
-#if __GLASGOW_HASKELL__ < 811
-import GHC.Base (unpackCString#,unpackNBytes#)
-#endif
import GHC.Exts
import GHC.IO
@@ -583,11 +580,7 @@ hashStr sbs@(SBS.SBS ba#) = loop 0# 0#
-- DO NOT move this let binding! indexCharOffAddr# reads from the
-- pointer so we need to evaluate this based on the length check
-- above. Not doing this right caused #17909.
-#if __GLASGOW_HASKELL__ >= 901
!c = int8ToInt# (indexInt8Array# ba# n)
-#else
- !c = indexInt8Array# ba# n
-#endif
!h2 = (h *# 16777619#) `xorI#` c
in
loop h2 (n +# 1#)
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -617,9 +617,6 @@ compileForeign hsc_env lang stub_c = do
LangObjcxx -> viaCPipeline Cobjcxx
LangAsm -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp
LangJs -> \pe hsc_env ml fp -> Just <$> foreignJsPipeline pe hsc_env ml fp
-#if __GLASGOW_HASKELL__ < 811
- RawObject -> panic "compileForeign: should be unreachable"
-#endif
pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession)
res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)
case res of
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -545,10 +545,6 @@ ppr_monobind (FunBind { fun_id = fun,
ppr_monobind (PatSynBind _ psb) = ppr psb
ppr_monobind (XHsBindsLR b) = case ghcPass @idL of
-#if __GLASGOW_HASKELL__ <= 900
- GhcPs -> dataConCantHappen b
- GhcRn -> dataConCantHappen b
-#endif
GhcTc -> ppr_absbinds b
where
ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -712,9 +712,6 @@ ppr_expr (HsEmbTy _ _ ty)
= hsep [text "type", ppr ty]
ppr_expr (XExpr x) = case ghcPass @p of
-#if __GLASGOW_HASKELL__ < 811
- GhcPs -> ppr x
-#endif
GhcRn -> ppr x
GhcTc -> ppr x
@@ -749,9 +746,6 @@ ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
ppr_infix_expr (HsRecSel _ f) = Just (pprInfixOcc f)
ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
ppr_infix_expr (XExpr x) = case ghcPass @p of
-#if __GLASGOW_HASKELL__ < 901
- GhcPs -> Nothing
-#endif
GhcRn -> ppr_infix_expr_rn x
GhcTc -> ppr_infix_expr_tc x
ppr_infix_expr _ = Nothing
@@ -856,9 +850,6 @@ hsExprNeedsParens prec = go
go (XExpr x) = case ghcPass @p of
GhcTc -> go_x_tc x
GhcRn -> go_x_rn x
-#if __GLASGOW_HASKELL__ <= 900
- GhcPs -> True
-#endif
go_x_tc :: XXExprGhcTc -> Bool
go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
@@ -1302,10 +1293,6 @@ ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args)
= fall_through
ppr_cmd (XCmd x) = case ghcPass @p of
-#if __GLASGOW_HASKELL__ < 811
- GhcPs -> ppr x
- GhcRn -> ppr x
-#endif
GhcTc -> case x of
HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
@@ -1874,10 +1861,6 @@ instance OutputableBndrId p
pprHsQuote (VarBr _ False n)
= text "''" <> pprPrefixOcc (unLoc n)
pprHsQuote (XQuote b) = case ghcPass @p of
-#if __GLASGOW_HASKELL__ <= 900
- GhcPs -> dataConCantHappen b
- GhcRn -> dataConCantHappen b
-#endif
GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)
-- See Note [The life cycle of a TH quotation]
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -383,9 +383,6 @@ pprPat (ConPat { pat_con = con
pprPat (EmbTyPat _ toktype tp) = ppr toktype <+> ppr tp
pprPat (XPat ext) = case ghcPass @p of
-#if __GLASGOW_HASKELL__ < 811
- GhcPs -> dataConCantHappen ext
-#endif
GhcRn -> case ext of
HsPatExpanded orig _ -> pprPat orig
GhcTc -> case ext of
@@ -593,9 +590,6 @@ isIrrefutableHsPat is_strict = goL
go (EmbTyPat {}) = True
go (XPat ext) = case ghcPass @p of
-#if __GLASGOW_HASKELL__ < 811
- GhcPs -> dataConCantHappen ext
-#endif
GhcRn -> case ext of
HsPatExpanded _ pat -> go pat
GhcTc -> case ext of
@@ -759,9 +753,6 @@ patNeedsParens p = go @p
go (ViewPat {}) = True
go (EmbTyPat {}) = True
go (XPat ext) = case ghcPass @q of
-#if __GLASGOW_HASKELL__ < 901
- GhcPs -> dataConCantHappen ext
-#endif
GhcRn -> case ext of
HsPatExpanded orig _ -> go orig
GhcTc -> case ext of
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -850,9 +850,6 @@ instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
[ toHie expr
]
XHsBindsLR ext -> case hiePass @p of
-#if __GLASGOW_HASKELL__ < 811
- HieRn -> dataConCantHappen ext
-#endif
HieTc
| AbsBinds{ abs_exports = xs, abs_binds = binds
, abs_ev_binds = ev_binds
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -2311,9 +2311,6 @@ isStrictPattern (L loc pat) =
EmbTyPat{} -> False
XPat ext -> case ghcPass @p of
-#if __GLASGOW_HASKELL__ < 811
- GhcPs -> dataConCantHappen ext
-#endif
GhcRn
| HsPatExpanded _ p <- ext
-> isStrictPattern (L loc p)
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -396,11 +396,6 @@ handleRunStatus step expr bindings final_ids status history
| EvalComplete alloc (EvalException e) <- status
= return (ExecComplete (Left (fromSerializableException e)) alloc)
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise
- = panic "not_tracing" -- actually exhaustive, but GHC can't tell
-#endif
-
resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int
-> m ExecResult
=====================================
compiler/GHC/Tc/Errors/Hole.hs
=====================================
@@ -836,9 +836,6 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates =
Just (dataConWrapId con, dataConNonlinearType con)
_ -> Nothing }
where name = case hfc of
-#if __GLASGOW_HASKELL__ < 901
- IdHFCand id -> idName id
-#endif
GreHFCand gre -> greName gre
NameHFCand name -> name
discard_it = go subs seen maxleft ty elts
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -792,10 +792,6 @@ checkHiBootIface tcg_env boot_info
-- TODO: Maybe setGlobalTypeEnv should be strict.
setGlobalTypeEnv tcg_env_w_binds type_env' }
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise = panic "checkHiBootIface: unreachable code"
-#endif
-
{- Note [DFun impedance matching]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We return a list of "impedance-matching" bindings for the dfuns
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -2546,10 +2546,6 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
, ppr new_rewriters ])
; return new_ev }
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise
- = panic "rewriteEvidence"
-#endif
where
new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
loc = ctEvLoc old_ev
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -2981,10 +2981,6 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
-- overlap done by dropDominatedAxioms
; return fam_tc } }
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker
-#endif
-
-- | Maybe return a list of Bools that say whether a type family was declared
-- injective in the corresponding type arguments. Length of the list is equal to
-- the number of arguments (including implicit kind/coercion arguments).
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -933,9 +933,6 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
; return builder_binds } } }
-#if __GLASGOW_HASKELL__ <= 810
- | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with
-#endif
where
mb_match_group
= case dir of
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -10,9 +10,6 @@
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-#if MIN_VERSION_base(4,16,0)
-#define HAS_TYPELITCHAR
-#endif
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
=====================================
compiler/GHC/Utils/Binary/Typeable.hs
=====================================
@@ -4,9 +4,6 @@
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# OPTIONS_GHC -Wno-orphans -Wincomplete-patterns #-}
-#if MIN_VERSION_base(4,16,0)
-#define HAS_TYPELITCHAR
-#endif
-- | Orphan Binary instances for Data.Typeable stuff
module GHC.Utils.Binary.Typeable
@@ -19,9 +16,7 @@ import GHC.Prelude
import GHC.Utils.Binary
import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))
-#if __GLASGOW_HASKELL__ >= 901
import GHC.Exts (Levity(Lifted, Unlifted))
-#endif
import GHC.Serialized
import Foreign
@@ -102,13 +97,8 @@ instance Binary RuntimeRep where
put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b
put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps
put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps
-#if __GLASGOW_HASKELL__ >= 901
put_ bh (BoxedRep Lifted) = putByte bh 3
put_ bh (BoxedRep Unlifted) = putByte bh 4
-#else
- put_ bh LiftedRep = putByte bh 3
- put_ bh UnliftedRep = putByte bh 4
-#endif
put_ bh IntRep = putByte bh 5
put_ bh WordRep = putByte bh 6
put_ bh Int64Rep = putByte bh 7
@@ -129,13 +119,8 @@ instance Binary RuntimeRep where
0 -> VecRep <$> get bh <*> get bh
1 -> TupleRep <$> get bh
2 -> SumRep <$> get bh
-#if __GLASGOW_HASKELL__ >= 901
3 -> pure (BoxedRep Lifted)
4 -> pure (BoxedRep Unlifted)
-#else
- 3 -> pure LiftedRep
- 4 -> pure UnliftedRep
-#endif
5 -> pure IntRep
6 -> pure WordRep
7 -> pure Int64Rep
@@ -173,17 +158,13 @@ instance Binary KindRep where
instance Binary TypeLitSort where
put_ bh TypeLitSymbol = putByte bh 0
put_ bh TypeLitNat = putByte bh 1
-#if defined(HAS_TYPELITCHAR)
put_ bh TypeLitChar = putByte bh 2
-#endif
get bh = do
tag <- getByte bh
case tag of
0 -> pure TypeLitSymbol
1 -> pure TypeLitNat
-#if defined(HAS_TYPELITCHAR)
2 -> pure TypeLitChar
-#endif
_ -> fail "Binary.putTypeLitSort: invalid tag"
putTypeRep :: BinHandle -> TypeRep a -> IO ()
@@ -198,12 +179,6 @@ putTypeRep bh (App f x) = do
put_ bh (2 :: Word8)
putTypeRep bh f
putTypeRep bh x
-#if __GLASGOW_HASKELL__ < 903
-putTypeRep bh (Fun arg res) = do
- put_ bh (3 :: Word8)
- putTypeRep bh arg
- putTypeRep bh res
-#endif
instance Binary Serialized where
put_ bh (Serialized the_type bytes) = do
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -57,7 +57,7 @@ import Data.Ratio
import GHC.CString ( unpackCString# )
import GHC.Generics ( Generic )
import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..),
- TYPE, RuntimeRep(..), Multiplicity (..) )
+ TYPE, RuntimeRep(..), Levity(..), Multiplicity (..) )
import qualified Data.Kind as Kind (Type)
import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# )
import GHC.Ptr ( Ptr, plusPtr )
@@ -70,11 +70,6 @@ import Foreign.ForeignPtr
import Foreign.C.String
import Foreign.C.Types
-#if __GLASGOW_HASKELL__ >= 901
-import GHC.Types ( Levity(..) )
-#endif
-
-#if __GLASGOW_HASKELL__ >= 903
import Data.Array.Byte (ByteArray(..))
import GHC.Exts
( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray#
@@ -82,7 +77,6 @@ import GHC.Exts
, copyByteArray#, newPinnedByteArray#)
import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))
import GHC.ST (ST(..), runST)
-#endif
-----------------------------------------------------
--
@@ -1014,11 +1008,7 @@ class Lift (t :: TYPE r) where
-- | Turn a value into a Template Haskell expression, suitable for use in
-- a splice.
lift :: Quote m => t -> m Exp
-#if __GLASGOW_HASKELL__ >= 901
default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp
-#else
- default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp
-#endif
lift = unTypeCode . liftTyped
-- | Turn a value into a Template Haskell typed expression, suitable for use
@@ -1141,8 +1131,6 @@ instance Lift Addr# where
lift x
= return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
-#if __GLASGOW_HASKELL__ >= 903
-
-- |
-- @since 2.19.0.0
instance Lift ByteArray where
@@ -1174,8 +1162,6 @@ addrToByteArray (I# len) addr = runST $ ST $
s'' -> case unsafeFreezeByteArray# mb s'' of
(# s''', ret #) -> (# s''', ByteArray ret #)
-#endif
-
instance Lift a => Lift (Maybe a) where
liftTyped x = unsafeCodeCoerce (lift x)
=====================================
testsuite/tests/simplCore/should_compile/T23864.hs
=====================================
@@ -0,0 +1,71 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+module M where
+
+import Control.Monad.State
+import GHC.Hs
+import GHC.Types.SrcLoc
+import Type.Reflection
+import Data.Data (Data, gmapM)
+
+type HsModule1 = HsModule GhcPs
+
+type GenericM m = forall a. Data a => a -> m a
+
+everywhereM :: forall m. Monad m => GenericM m -> GenericM m
+everywhereM f = go
+ where
+ go :: GenericM m
+ go x = do
+ x' <- gmapM go x
+ f x'
+
+-- | 'State' with comments.
+type WithComments = State [LEpaComment]
+
+relocateComments :: HsModule1 -> [LEpaComment] -> HsModule1
+relocateComments = evalState . relocateCommentsBeforeTopLevelDecls
+
+-- | This function locates comments located before top-level declarations.
+relocateCommentsBeforeTopLevelDecls :: HsModule1 -> WithComments HsModule1
+relocateCommentsBeforeTopLevelDecls = everywhereM (applyM f)
+ where
+ f epa = insertCommentsByPos (const True) insertPriorComments epa
+
+-- | This function applies the given function to all 'EpAnn's.
+applyM ::
+ forall a. Typeable a
+ => (forall b. EpAnn b -> WithComments (EpAnn b))
+ -> (a -> WithComments a)
+applyM f
+ | App g _ <- typeRep @a
+ , Just HRefl <- eqTypeRep g (typeRep @EpAnn) = f
+ | otherwise = pure
+
+insertCommentsByPos ::
+ (RealSrcSpan -> Bool)
+ -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
+ -> EpAnn a
+ -> WithComments (EpAnn a)
+insertCommentsByPos cond = insertComments (cond . anchor . getLoc)
+
+insertComments ::
+ (LEpaComment -> Bool)
+ -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)
+ -> EpAnn a
+ -> WithComments (EpAnn a)
+insertComments cond inserter epa at EpAnn {..} = do
+ coms <- drainComments cond
+ pure $ epa {comments = inserter comments coms}
+insertComments _ _ EpAnnNotUsed = pure EpAnnNotUsed
+
+insertPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments
+insertPriorComments (EpaComments prior) cs =
+ EpaComments (prior ++ cs)
+insertPriorComments (EpaCommentsBalanced prior following) cs =
+ EpaCommentsBalanced (prior ++ cs) following
+
+drainComments :: (LEpaComment -> Bool) -> WithComments [LEpaComment]
+drainComments cond = undefined
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -496,3 +496,4 @@ test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -
# The -ddump-simpl of T22404 should have no let-bindings
test('T22404', [only_ways(['optasm']), check_errmsg(r'let') ], compile, ['-ddump-simpl -dsuppress-uniques'])
+test('T23864', normal, compile, ['-O -dcore-lint -package ghc -Wno-gadt-mono-local-binds'])
=====================================
testsuite/tests/typecheck/should_compile/T23861.hs
=====================================
@@ -0,0 +1,13 @@
+module M where
+
+newtype GetDiscardingUnlift a = MkGetDiscardingUnlift
+ { unGetDiscardingUnlift :: forall m. Either a m
+ }
+
+build :: forall a. a -> GetDiscardingUnlift a
+build w =
+ case build w of
+ MkGetDiscardingUnlift getDiscardingUnlift' ->
+ let getDiscardingUnlift'' :: forall m. Either a m
+ getDiscardingUnlift'' = getDiscardingUnlift' @m
+ in MkGetDiscardingUnlift getDiscardingUnlift''
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -891,3 +891,4 @@ test('T18986b', normal, compile, [''])
test('T23413', normal, compile, [''])
test('TcIncompleteRecSel', normal, compile, ['-Wincomplete-record-selectors'])
test('InstanceWarnings', normal, multimod_compile, ['InstanceWarnings', ''])
+test('T23861', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e7c20f28c9856d38bbb8c149a5f7ca50f9b76cd...f5a72381cd8b492f4b74e8f3b8843ca6dbf84724
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e7c20f28c9856d38bbb8c149a5f7ca50f9b76cd...f5a72381cd8b492f4b74e8f3b8843ca6dbf84724
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/20230828/7dea1569/attachment-0001.html>
More information about the ghc-commits
mailing list