[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