compiler/GHC/HsToCore/Quote.hs

@@ -1666,6 +1666,9 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
   e1 <- repLE e
   repGetField e1 f
 repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
+repE (HsEmbTy _ _ t) = do
+  t1 <- repLTy (hswc_body t)
+  rep2 typeEName [unC t1]
 repE (XExpr (HsExpanded orig_expr ds_expr))
   = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
        ; if rebindable_on  -- See Note [Quotation and rebindable syntax]
@@ -2123,6 +2126,8 @@ repP p@(NPat _ (L _ l) (Just _) _)
 repP (SigPat _ p t) = do { p' <- repLP p
                          ; t' <- repLTy (hsPatSigType t)
                          ; repPsig p' t' }
+repP (EmbTyPat _ _ t) = do { t' <- repLTy (hstp_body t)
+                           ; repPtype t' }
 repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n
 repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p)
 repP other = notHandled (ThExoticPattern other)
@@ -2379,6 +2384,9 @@ repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
 repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
 
+repPtype :: Core (M TH.Type) -> MetaM (Core (M TH.Pat))
+repPtype (MkC t) = rep2 typePName [t]
+
 --------------- Expressions -----------------
 repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))
 repVarOrCon vc str
@@ -2628,6 +2636,7 @@ repOverlap mb =
         Overlapping _  -> just =<< dataCon overlappingDataConName
         Overlaps _     -> just =<< dataCon overlapsDataConName
         Incoherent _   -> just =<< dataCon incoherentDataConName
+        NonCanonical _ -> just =<< dataCon incoherentDataConName
   where
   nothing = coreNothing overlapTyConName
   just    = coreJust overlapTyConName

compiler/GHC/HsToCore/Ticks.hs

@@ -478,6 +478,7 @@ addTickHsExpr e@(HsIPVar {})            = return e
 addTickHsExpr e@(HsOverLit {})          = return e
 addTickHsExpr e@(HsOverLabel{})         = return e
 addTickHsExpr e@(HsLit {})              = return e
+addTickHsExpr e@(HsEmbTy {})            = return e
 addTickHsExpr (HsLam x mg)              = liftM (HsLam x)
                                                 (addTickMatchGroup True mg)
 addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)

compiler/GHC/HsToCore/Types.hs

@@ -79,9 +79,9 @@ data DsLclEnv
   -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".
   -- The set of reaching values Nablas is augmented as we walk inwards, refined
   -- through each pattern match in turn
-  , dsl_incoherents :: S.Set EvVar
-  -- ^ See Note [Desugaring incoherent evidence]: this field collects
-  -- all incoherent evidence variables in scope.
+  , dsl_unspecables :: S.Set EvVar
+  -- ^ See Note [Desugaring non-canonical evidence]: this field collects
+  -- all un-specialisable evidence variables in scope.
   }
 
 -- Inside [| |] brackets, the desugarer looks

compiler/GHC/HsToCore/Utils.hs

@@ -15,7 +15,7 @@ This module exports some utility functions of no great interest.
 -- | Utility functions for constructing Core syntax, principally for desugaring
 module GHC.HsToCore.Utils (
         EquationInfo(..),
-        firstPat, shiftEqns,
+        firstPat, shiftEqns, combineEqnRhss,
 
         MatchResult (..), CaseAlt(..),
         cantFailMatchResult, alwaysFailMatchResult,
@@ -194,12 +194,16 @@ The ``equation info'' used by @match@ is relatively complicated and
 worthy of a type synonym and a few handy functions.
 -}
 
-firstPat :: EquationInfo -> Pat GhcTc
-firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)
+firstPat :: EquationInfoNE -> Pat GhcTc
+firstPat (EqnMatch { eqn_pat = pat }) = unLoc pat
+firstPat (EqnDone {}) = error "firstPat: no patterns"
 
-shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
+shiftEqns :: Functor f => f EquationInfoNE -> f EquationInfo
 -- Drop the first pattern in each equation
-shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
+shiftEqns = fmap eqn_rest
+
+combineEqnRhss :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
+combineEqnRhss eqns = return $ foldr1 combineMatchResults $ map eqnMatchResult (NEL.toList eqns)
 
 -- Functions on MatchResult CoreExprs
 

compiler/GHC/Iface/Ext/Ast.hs

@@ -1027,6 +1027,9 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
                            sig
             HieRn -> pure []
         ]
+      EmbTyPat _ _ tp ->
+        [ toHie $ TS (ResolvedScopes [scope, pscope]) tp
+        ]
       XPat e ->
         case hiePass @p of
           HieRn -> case e of
@@ -1199,6 +1202,9 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
       HsStatic _ expr ->
         [ toHie expr
         ]
+      HsEmbTy _ _ ty ->
+        [ toHie $ TS (ResolvedScopes []) ty
+        ]
       HsTypedBracket xbracket b -> case hiePass @p of
         HieRn ->
           [ toHie b

compiler/GHC/Iface/Make.hs

@@ -14,6 +14,7 @@ module GHC.Iface.Make
    , mkFullIface
    , mkIfaceTc
    , mkIfaceExports
+   , toIfaceWarningTxt
    )
 where
 
@@ -367,7 +368,8 @@ instanceToIfaceInst :: ClsInst -> IfaceClsInst
 instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
                              , is_cls_nm = cls_name, is_cls = cls
                              , is_tcs = rough_tcs
-                             , is_orphan = orph })
+                             , is_orphan = orph
+                             , is_warn = warn })
   = assert (cls_name == className cls) $
     IfaceClsInst { ifDFun     = idName dfun_id
                  , ifOFlag    = oflag
@@ -375,7 +377,8 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
                  , ifInstTys  = ifaceRoughMatchTcs $ tail rough_tcs
                    -- N.B. Drop the class name from the rough match template
                    --      It is put back by GHC.Core.InstEnv.mkImportedClsInst
-                 , ifInstOrph = orph }
+                 , ifInstOrph = orph
+                 , ifInstWarn = fmap toIfaceWarningTxt warn }
 
 --------------------------
 famInstToIfaceFamInst :: FamInst -> IfaceFamInst

compiler/GHC/Iface/Syntax.hs

@@ -12,7 +12,7 @@ module GHC.Iface.Syntax (
 
         IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
         IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
-        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding,
+        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,
         IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
         IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
@@ -35,6 +35,7 @@ module GHC.Iface.Syntax (
         ifaceDeclFingerprints,
         fromIfaceBooleanFormula,
         fromIfaceWarnings,
+        fromIfaceWarningTxt,
 
         -- Free Names
         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -315,7 +316,11 @@ data IfaceClsInst
                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
                    ifDFun     :: IfExtName,                -- The dfun
                    ifOFlag    :: OverlapFlag,              -- Overlap flag
-                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in GHC.Core.InstEnv
+                   ifInstOrph :: IsOrphan,                 -- See Note [Orphans] in GHC.Core.InstEnv
+                   ifInstWarn :: Maybe IfaceWarningTxt }
+                     -- Warning emitted when the instance is used
+                     -- See Note [Implementation of deprecated instances]
+                     -- in GHC.Tc.Solver.Dict
         -- There's always a separate IfaceDecl for the DFun, which gives
         -- its IdInfo with its full type and version number.
         -- The instance declarations taken together have a version number,
@@ -651,7 +656,7 @@ data IfaceBindingX r b
 -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
 -- It's used for *non-top-level* let/rec binders
 -- See Note [IdInfo on nested let-bindings]
-data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo
+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood
 
 data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails
                       | IfGblTopBndr IfaceTopBndr
@@ -659,9 +664,6 @@ data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDeta
 -- See Note [Interface File with Core: Sharing RHSs]
 data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
 
-data IfaceJoinInfo = IfaceNotJoinPoint
-                   | IfaceJoinPoint JoinArity
-
 {-
 Note [Empty case alternatives]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1574,10 +1576,6 @@ instance Outputable IfaceInfoItem where
   ppr (HsLFInfo lf_info)    = text "LambdaFormInfo:" <+> ppr lf_info
   ppr (HsTagSig tag_sig)    = text "TagSig:" <+> ppr tag_sig
 
-instance Outputable IfaceJoinInfo where
-  ppr IfaceNotJoinPoint   = empty
-  ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
-
 instance Outputable IfaceUnfolding where
   ppr (IfCoreUnfold src _ guide e)
     = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ]
@@ -2276,19 +2274,21 @@ instance Binary IfaceSrcBang where
          return (IfSrcBang a1 a2)
 
 instance Binary IfaceClsInst where
-    put_ bh (IfaceClsInst cls tys dfun flag orph) = do
+    put_ bh (IfaceClsInst cls tys dfun flag orph warn) = do
         put_ bh cls
         put_ bh tys
         put_ bh dfun
         put_ bh flag
         put_ bh orph
+        put_ bh warn
     get bh = do
         cls  <- get bh
         tys  <- get bh
         dfun <- get bh
         flag <- get bh
         orph <- get bh
-        return (IfaceClsInst cls tys dfun flag orph)
+        warn <- get bh
+        return (IfaceClsInst cls tys dfun flag orph warn)
 
 instance Binary IfaceFamInst where
     put_ bh (IfaceFamInst fam tys name orph) = do
@@ -2689,19 +2689,6 @@ instance Binary IfaceMaybeRhs where
       1 -> IfRhs <$> get bh
       _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b)
 
-
-
-instance Binary IfaceJoinInfo where
-    put_ bh IfaceNotJoinPoint = putByte bh 0
-    put_ bh (IfaceJoinPoint ar) = do
-        putByte bh 1
-        put_ bh ar
-    get bh = do
-        h <- getByte bh
-        case h of
-            0 -> return IfaceNotJoinPoint
-            _ -> liftM IfaceJoinPoint $ get bh
-
 instance Binary IfaceTyConParent where
     put_ bh IfNoParent = putByte bh 0
     put_ bh (IfDataInstance ax pr ty) = do
@@ -2881,9 +2868,6 @@ instance NFData IfaceFamTyConFlav where
     IfaceAbstractClosedSynFamilyTyCon -> ()
     IfaceBuiltInSynFamTyCon -> ()
 
-instance NFData IfaceJoinInfo where
-  rnf x = x `seq` ()
-
 instance NFData IfaceTickish where
   rnf = \case
     IfaceHpcTick m i -> rnf m `seq` rnf i
@@ -2909,8 +2893,8 @@ instance NFData IfaceFamInst where
     rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` ()
 
 instance NFData IfaceClsInst where
-  rnf (IfaceClsInst f1 f2 f3 f4 f5) =
-    f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` ()
+  rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) =
+    f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` rnf f6
 
 instance NFData IfaceWarnings where
   rnf = \case

compiler/GHC/IfaceToCore.hs

@@ -1228,11 +1228,12 @@ tcRoughTyCon Nothing   = RM_WildCard
 tcIfaceInst :: IfaceClsInst -> IfL ClsInst
 tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
                           , ifInstCls = cls, ifInstTys = mb_tcs
-                          , ifInstOrph = orph })
+                          , ifInstOrph = orph, ifInstWarn = iface_warn })
   = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
                     fmap tyThingId (tcIfaceImplicit dfun_name)
        ; let mb_tcs' = map tcRoughTyCon mb_tcs
-       ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph) }
+             warn = fmap fromIfaceWarningTxt iface_warn
+       ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph warn) }
 
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
@@ -1586,7 +1587,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
         ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
                               NotTopLevel name ty' info
         ; let id = mkLocalIdWithInfo name ManyTy ty' id_info
-                     `asJoinId_maybe` tcJoinInfo ji
+                     `asJoinId_maybe` ji
         ; rhs' <- tcIfaceExpr rhs
         ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
         ; return (Let (NonRec id rhs') body') }
@@ -1601,7 +1602,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
    tc_rec_bndr (IfLetBndr fs ty _ ji)
      = do { name <- newIfaceName (mkVarOccFS fs)
           ; ty'  <- tcIfaceType ty
-          ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` tcJoinInfo ji) }
+          ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }
    tc_pair (IfLetBndr _ _ info _, rhs) id
      = do { rhs' <- tcIfaceExpr rhs
           ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
@@ -1688,7 +1689,16 @@ tcIdDetails nm _ (IfRecSelId tc _first_con naughty fl)
   = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
                        (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
                        tc
-       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty, sel_fieldLabel = fl { flSelector = nm } }) }
+       ; let all_cons = recSelParentCons tc'
+             cons_partitioned
+                 = conLikesWithFields all_cons [flLabel fl]
+       ; return (RecSelId
+                   { sel_tycon = tc'
+                   , sel_naughty = naughty
+                   , sel_fieldLabel = fl { flSelector = nm }
+                   , sel_cons = cons_partitioned }
+                       -- Reconstructed here since we don't want Uniques in the Iface file
+                ) }
   where
     tyThingPatSyn (AConLike (PatSynCon ps)) = ps
     tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
@@ -1735,10 +1745,6 @@ tcIdInfo ignore_prags toplvl name ty info = do
                        | otherwise = info
            ; return (info1 `setUnfoldingInfo` unf) }
 
-tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
-tcJoinInfo (IfaceJoinPoint ar) = Just ar
-tcJoinInfo IfaceNotJoinPoint   = Nothing
-
 tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
 tcLFInfo lfi = case lfi of
     IfLFReEntrant rep_arity ->

compiler/GHC/Linker/Static.hs

@@ -239,6 +239,7 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
                           then ["-Wl,-read_only_relocs,suppress"]
                           else [])
 
+                          -- We should rather be asking does it support --gc-sections?
                       ++ (if toolSettings_ldIsGnuLd toolSettings' &&
                              not (gopt Opt_WholeArchiveHsLibs dflags)
                           then ["-Wl,--gc-sections"]

compiler/GHC/Parser/Annotation.hs

@@ -82,7 +82,8 @@ module GHC.Parser.Annotation (
   -- ** Working with comments in annotations
   noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,
   addCommentsToEpAnn, setCommentsEpAnn,
-  transferAnnsA, commentsOnlyA, removeCommentsA,
+  transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA, commentsOnlyA,
+  removeCommentsA,
 
   placeholderRealSpan,
   ) where
@@ -1154,6 +1155,26 @@ transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to
       (SrcSpanAnn (EpAnn a an' cs') loc)
         -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc
 
+-- | Transfer trailing items from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)
+transferAnnsOnlyA (SrcSpanAnn EpAnnNotUsed l) ss2
+  = (SrcSpanAnn EpAnnNotUsed l, ss2)
+transferAnnsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn EpAnnNotUsed l')
+  = (SrcSpanAnn (EpAnn a mempty cs) l, SrcSpanAnn (EpAnn (spanAsAnchor l') an emptyComments) l')
+transferAnnsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn (EpAnn a' an' cs') l')
+  = (SrcSpanAnn (EpAnn a mempty cs) l, SrcSpanAnn (EpAnn a' (an' <> an) cs') l')
+
+-- | Transfer comments from the annotations in the
+-- first 'SrcSpanAnnA' argument to those in the second.
+transferCommentsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)
+transferCommentsOnlyA (SrcSpanAnn EpAnnNotUsed l) ss2
+  = (SrcSpanAnn EpAnnNotUsed l, ss2)
+transferCommentsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn EpAnnNotUsed l')
+  = (SrcSpanAnn (EpAnn a an emptyComments ) l, SrcSpanAnn (EpAnn (spanAsAnchor l') mempty cs) l')
+transferCommentsOnlyA (SrcSpanAnn (EpAnn a an cs) l) (SrcSpanAnn (EpAnn a' an' cs') l')
+  = (SrcSpanAnn (EpAnn a an emptyComments) l, SrcSpanAnn (EpAnn a' an' (cs <> cs')) l')
+
 -- | Remove the exact print annotations payload, leaving only the
 -- anchor and comments.
 commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann

compiler/GHC/Parser/PostProcess.hs

@@ -96,6 +96,7 @@ module GHC.Parser.PostProcess (
         failOpFewArgs,
         failNotEnabledImportQualifiedPost,
         failImportQualifiedTwice,
+        requireExplicitNamespaces,
 
         SumOrTuple (..),
 
@@ -587,11 +588,14 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
                                MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))
             binds
   | has_args m1
-  = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds []
+  = go [L loc1 mtchs1] (noAnnSrcSpan $ locA loc1) binds []
   where
-    go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA
-       -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
-       -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ
+    -- See Note [Exact Print Annotations for FunBind]
+    go :: [LMatch GhcPs (LHsExpr GhcPs)] -- accumulates matches for current fun
+       -> SrcSpanAnnA                    -- current top level loc
+       -> [LHsDecl GhcPs]                -- Any docbinds seen
+       -> [LHsDecl GhcPs]                -- rest of decls to be processed
+       -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- FunBind, rest of decls
     go mtchs loc
        ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)
                                  , fun_matches =
@@ -605,13 +609,61 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)
         = let doc_decls' = doc_decl : doc_decls
           in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'
     go mtchs loc binds doc_decls
-        = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs))
-          , (reverse doc_decls) ++ binds)
+        = let
+            L llm last_m = head mtchs -- Guaranteed at least one
+            (llm',loc') = transferAnnsOnlyA llm loc -- Keep comments, transfer trailing
+
+            matches' = reverse (L llm' last_m:tail mtchs)
+            L lfm first_m =  head matches'
+            (lfm', loc'') = transferCommentsOnlyA lfm loc'
+          in
+            ( L loc'' (makeFunBind fun_id1 (mkLocatedList $ (L lfm' first_m:tail matches')))
+              , (reverse doc_decls) ++ binds)
         -- Reverse the final matches, to get it back in the right order
         -- Do the same thing with the trailing doc comments
 
 getMonoBind bind binds = (bind, binds)
 
+{- Note [Exact Print Annotations for FunBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+An individual Match that ends up in a FunBind MatchGroup is initially
+parsed as a LHsDecl. This takes the form
+
+   L loc (ValD NoExtField (FunBind ... [L lm (Match ..)]))
+
+The loc contains the annotations, in particular comments, which are to
+precede the declaration when printed, and [TrailingAnn] which are to
+follow it. The [TrailingAnn] captures semicolons that may appear after
+it when using the braces and semis style of coding.
+
+The match location (lm) has only a location in it at this point, no
+annotations. Its location is the same as the top level location in
+loc.
+
+What getMonoBind does it to take a sequence of FunBind LHsDecls that
+belong to the same function and group them into a single function with
+the component declarations all combined into the single MatchGroup as
+[LMatch GhcPs].
+
+Given that when exact printing a FunBind the exact printer simply
+iterates over all the matches and prints each in turn, the simplest
+behaviour would be to simply take the top level annotations (loc) for
+each declaration, and use them for the individual component matches
+(lm).
+
+The problem is the exact printer first has to deal with the top level
+LHsDecl, which means annotations for the loc. This needs to be able to
+be exact printed in the context of surrounding declarations, and if
+some refactor decides to move the declaration elsewhere, the leading
+comments and trailing semicolons need to be handled at that level.
+
+So the solution is to combine all the matches into one, pushing the
+annotations into the LMatch's, and then at the end extract the
+comments from the first match and [TrailingAnn] from the last to go in
+the top level LHsDecl.
+-}
+
 -- Group together adjacent FunBinds for every function.
 getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
 getMonoBindAll [] = []
@@ -1592,6 +1644,8 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
   -- | Disambiguate tuple sections and unboxed sums
   mkSumOrTuplePV
     :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)
+  -- | Disambiguate "type t" (embedded type)
+  mkHsEmbTyPV :: SrcSpan -> LHsToken "type" GhcPs -> LHsType GhcPs -> PV (LocatedA b)
   -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas
   rejectPragmaPV :: LocatedA b -> PV ()
 
@@ -1711,6 +1765,7 @@ instance DisambECP (HsCmd GhcPs) where
   mkHsBangPatPV l c _ = cmdFail l $
     text "!" <> ppr c
   mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a)
+  mkHsEmbTyPV l _ ty = cmdFail l (text "type" <+> ppr ty)
   rejectPragmaPV _ = return ()
 
 cmdFail :: SrcSpan -> SDoc -> PV a
@@ -1807,6 +1862,9 @@ instance DisambECP (HsExpr GhcPs) where
   mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)
                           >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
   mkSumOrTuplePV = mkSumOrTupleExpr
+  mkHsEmbTyPV l toktype ty =
+    return $ L (noAnnSrcSpan l) $
+      HsEmbTy noExtField toktype (mkHsWildCardBndrs ty)
   rejectPragmaPV (L _ (OpApp _ _ _ e)) =
     -- assuming left-associative parsing of operators
     rejectPragmaPV e
@@ -1892,6 +1950,9 @@ instance DisambECP (PatBuilder GhcPs) where
     hintBangPat l pb
     return $ L (noAnnSrcSpan l) (PatBuilderPat pb)
   mkSumOrTuplePV = mkSumOrTuplePat
+  mkHsEmbTyPV l toktype ty =
+    return $ L (noAnnSrcSpan l) $
+      PatBuilderPat (EmbTyPat noExtField toktype (mkHsTyPat noAnn ty))
   rejectPragmaPV _ = return ()
 
 -- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.
@@ -2792,7 +2853,7 @@ data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)
                   | ImpExpQcType EpaLocation (LocatedN RdrName)
                   | ImpExpQcWildcard
 
-mkModuleImpExp :: Maybe (LocatedP (WarningTxt GhcPs)) -> [AddEpAnn] -> LocatedA ImpExpQcSpec
+mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec
                -> ImpExpSubSpec -> P (IE GhcPs)
 mkModuleImpExp warning anns (L l specname) subs = do
   cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments
@@ -2843,9 +2904,7 @@ mkModuleImpExp warning anns (L l specname) subs = do
 mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space
              -> P (LocatedN RdrName)
 mkTypeImpExp name =
-  do allowed <- getBit ExplicitNamespacesBit
-     unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $
-                                   PsErrIllegalExplicitNamespace
+  do requireExplicitNamespaces (getLocA name)
      return (fmap (`setRdrNameSpace` tcClsName) name)
 
 checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])
@@ -2896,6 +2955,12 @@ failOpFewArgs (L loc op) =
      ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
          (PsErrOpFewArgs is_star_type op) }
 
+requireExplicitNamespaces :: MonadP m => SrcSpan -> m ()
+requireExplicitNamespaces l = do
+  allowed <- getBit ExplicitNamespacesBit
+  unless allowed $
+    addError $ mkPlainErrorMsgEnvelope l PsErrIllegalExplicitNamespace
+
 -----------------------------------------------------------------------------
 -- Misc utils
 

compiler/GHC/Platform.hs

@@ -180,11 +180,6 @@ platformOS :: Platform -> OS
 platformOS platform = case platformArchOS platform of
    ArchOS _ os -> os
 
-isARM :: Arch -> Bool
-isARM (ArchARM {}) = True
-isARM ArchAArch64  = True
-isARM _ = False
-
 -- | This predicate tells us whether the platform is 32-bit.
 target32Bit :: Platform -> Bool
 target32Bit p =
@@ -192,34 +187,6 @@ target32Bit p =
       PW4 -> True
       PW8 -> False
 
--- | This predicate tells us whether the OS supports ELF-like shared libraries.
-osElfTarget :: OS -> Bool
-osElfTarget OSLinux     = True
-osElfTarget OSFreeBSD   = True
-osElfTarget OSDragonFly = True
-osElfTarget OSOpenBSD   = True
-osElfTarget OSNetBSD    = True
-osElfTarget OSSolaris2  = True
-osElfTarget OSDarwin    = False
-osElfTarget OSMinGW32   = False
-osElfTarget OSKFreeBSD  = True
-osElfTarget OSHaiku     = True
-osElfTarget OSQNXNTO    = False
-osElfTarget OSAIX       = False
-osElfTarget OSHurd      = True
-osElfTarget OSWasi      = False
-osElfTarget OSGhcjs     = False
-osElfTarget OSUnknown   = False
- -- Defaulting to False is safe; it means don't rely on any
- -- ELF-specific functionality.  It is important to have a default for
- -- portability, otherwise we have to answer this question for every
- -- new platform we compile on (even unreg).
-
--- | This predicate tells us whether the OS support Mach-O shared libraries.
-osMachOTarget :: OS -> Bool
-osMachOTarget OSDarwin = True
-osMachOTarget _ = False
-
 osUsesFrameworks :: OS -> Bool
 osUsesFrameworks OSDarwin = True
 osUsesFrameworks _        = False

compiler/GHC/Rename/Bind.hs

@@ -581,6 +581,10 @@ isOkNoBindPattern (L _ pat) =
           ConPat _ _ cpd  -> any lpatternContainsSplice (hsConPatArgs cpd)
           XPat (HsPatExpanded _orig new) -> patternContainsSplice new
 
+          -- The behavior of this case is unimportant, as GHC will throw an error shortly
+          -- after reaching this case for other reasons (see TcRnIllegalTypePattern).
+          EmbTyPat{} -> True
+
 {- Note [Pattern bindings that bind no variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Generally, we want to warn about pattern bindings like

compiler/GHC/Rename/Env.hs

@@ -845,8 +845,10 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name =
        -- See [Mismatched class methods and associated type families]
        -- in TcInstDecls.
   where
-    what_lkup = LookupChild { wantedParent       = the_parent
-                            , lookupDataConFirst = False }
+    what_lkup = LookupChild { wantedParent        = the_parent
+                            , lookupDataConFirst  = False
+                            , prioritiseParent    = True -- See T23664.
+                            }
 {-
 Note [Family instance binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1796,12 +1798,12 @@ warnIfDeclDeprecated gre@(GRE { gre_imp = iss })
          do { iface <- loadInterfaceForName doc name
             ; case lookupImpDeclDeprec iface gre of
                 Just deprText -> addDiagnostic $
-                  TcRnPragmaWarning {
-                    pragma_warning_occ = occ,
-                    pragma_warning_msg = deprText,
-                    pragma_warning_import_mod = importSpecModule imp_spec,
-                    pragma_warning_defined_mod = Just definedMod
-                  }
+                  TcRnPragmaWarning
+                      PragmaWarningName
+                        { pwarn_occname = occ
+                        , pwarn_impmod  = importSpecModule imp_spec
+                        , pwarn_declmod = definedMod }
+                      deprText
                 Nothing  -> return () } }
   | otherwise
   = return ()
@@ -1824,12 +1826,11 @@ warnIfExportDeprecated gre@(GRE { gre_imp = iss })
   = do { mod_warn_mbs <- mapBagM process_import_spec iss
        ; for_ (sequence mod_warn_mbs) $ mapM
            $ \(importing_mod, warn_txt) -> addDiagnostic $
-             TcRnPragmaWarning {
-               pragma_warning_occ = occ,
-               pragma_warning_msg = warn_txt,
-               pragma_warning_import_mod = importing_mod,
-               pragma_warning_defined_mod = Nothing
-             } }
+             TcRnPragmaWarning
+                PragmaWarningExport
+                  { pwarn_occname = occ
+                  , pwarn_impmod  = importing_mod }
+                warn_txt }
   where
     occ = greOccName gre
     name = greName gre

compiler/GHC/Rename/Expr.hs

@@ -564,6 +564,10 @@ rnExpr (ArithSeq _ _ seq)
            else
             return (ArithSeq noExtField Nothing new_seq, fvs) }
 
+rnExpr (HsEmbTy _ toktype ty)
+  = do { (ty', fvs) <- rnHsWcType HsTypeCtx ty
+       ; return (HsEmbTy noExtField toktype ty', fvs) }
+
 {-
 ************************************************************************
 *                                                                      *
@@ -2301,6 +2305,11 @@ isStrictPattern (L loc pat) =
     NPat{}          -> True
     NPlusKPat{}     -> True
     SplicePat{}     -> True
+
+    -- The behavior of this case is unimportant, as GHC will throw an error shortly
+    -- after reaching this case for other reasons (see TcRnIllegalTypePattern).
+    EmbTyPat{}  -> False
+
     XPat ext        -> case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
       GhcPs -> dataConCantHappen ext

compiler/GHC/Rename/Module.hs

@@ -13,7 +13,7 @@ Main pass of renamer
 -}
 
 module GHC.Rename.Module (
-        rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt
+        rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt, rnLWarningTxt
     ) where
 
 import GHC.Prelude hiding ( head )
@@ -39,6 +39,7 @@ import GHC.Rename.Names
 import GHC.Tc.Errors.Types
 import GHC.Tc.Gen.Annotation ( annCtxt )
 import GHC.Tc.Utils.Monad
+import GHC.Tc.Types.Origin ( TypedThing(..) )
 
 import GHC.Types.ForeignCall ( CCallTarget(..) )
 import GHC.Unit
@@ -308,6 +309,8 @@ rnWarningTxt (DeprecatedTxt st wst) = do
   wst' <- traverse (traverse rnHsDoc) wst
   pure (DeprecatedTxt st wst')
 
+rnLWarningTxt :: LWarningTxt GhcPs -> RnM (LWarningTxt GhcRn)
+rnLWarningTxt (L loc warn) = L loc <$> rnWarningTxt warn
 
 findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)]
 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
@@ -557,7 +560,8 @@ checkCanonicalInstances cls poly_ty mbinds = do
       addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty)
 
 rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
-rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
+rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _)
+                           , cid_poly_ty = inst_ty, cid_binds = mbinds
                            , cid_sigs = uprags, cid_tyfam_insts = ats
                            , cid_overlap_mode = oflag
                            , cid_datafam_insts = adts })
@@ -574,10 +578,13 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
              -- class type constructor...
              eith_cls = case hsTyGetAppHead_maybe head_ty' of
                Just (L _ cls) -> Right cls
-               Nothing        -> Left
-                 ( getLocA head_ty'
-                 , TcRnIllegalInstanceHeadDecl head_ty'
-                 )
+               Nothing        ->
+                  Left
+                   ( getLocA head_ty'
+                   , TcRnIllegalInstance $
+                       IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $
+                       IllegalInstanceHead $ InstHeadNonClass Nothing
+                   )
          -- ...finally, attempt to retrieve the class type constructor, failing
          -- with an error message if there isn't one. To avoid excessive
          -- amounts of error messages, we will only report one of the errors
@@ -607,7 +614,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
 
        ; let all_fvs = meth_fvs `plusFV` more_fvs
                                 `plusFV` inst_fvs
-       ; return (ClsInstDecl { cid_ext = noExtField
+       ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps
+       ; return (ClsInstDecl { cid_ext = inst_warn_rn
                              , cid_poly_ty = inst_ty', cid_binds = mbinds'
                              , cid_sigs = uprags', cid_tyfam_insts = ats'
                              , cid_overlap_mode = oflag
@@ -721,7 +729,9 @@ rnFamEqn doc atfi
                && not (cls_tkv `elemNameSet` pat_fvs)
                     -- ...but not bound on the LHS.
              bad_tvs = filter improperly_scoped inst_head_tvs
-       ; unless (null bad_tvs) (addErr (TcRnBadAssocRhs bad_tvs))
+       ; unless (null bad_tvs) $ addErr $
+           TcRnIllegalInstance $ IllegalFamilyInstance $
+             FamInstRHSOutOfScopeTyVars Nothing bad_tvs
 
        ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs
              -- See Note [Type family equations and occurrences]
@@ -1100,7 +1110,7 @@ simplistic solution above, as it fixes the egregious bug in #18470.
 -}
 
 rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
-rnSrcDerivDecl (DerivDecl _ ty mds overlap)
+rnSrcDerivDecl (DerivDecl (inst_warn_ps, ann) ty mds overlap)
   = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
        ; unless standalone_deriv_ok (addErr TcRnUnexpectedStandaloneDerivingDecl)
        ; checkInferredVars ctxt nowc_ty
@@ -1113,7 +1123,8 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
            NFC_StandaloneDerivedInstanceHead
            (getLHsInstDeclHead $ dropWildCards ty')
        ; warnNoDerivStrat mds' loc
-       ; return (DerivDecl noAnn ty' mds' overlap, fvs) }
+       ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps
+       ; return (DerivDecl (inst_warn_rn, ann) ty' mds' overlap, fvs) }
   where
     ctxt    = DerivDeclCtx
     loc = getLocA nowc_ty

compiler/GHC/Rename/Names.hs

@@ -1258,12 +1258,11 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items))
               reason <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails
               pure (TcRnDodgyImports (DodgyImportsHiding reason))
             warning_msg (DeprecatedExport n w) =
-              pure (TcRnPragmaWarning {
-                      pragma_warning_occ = occName n
-                    , pragma_warning_msg = w
-                    , pragma_warning_import_mod = moduleName import_mod
-                    , pragma_warning_defined_mod = Nothing
-                    })
+              pure $ TcRnPragmaWarning
+                         PragmaWarningExport
+                           { pwarn_occname = occName n
+                           , pwarn_impmod  = moduleName import_mod }
+                         w
 
             run_lookup :: IELookupM a -> TcRn (Maybe a)
             run_lookup m = case m of

compiler/GHC/Rename/Pat.hs

@@ -633,6 +633,10 @@ rnPatAndThen mk (SplicePat _ splice)
            (rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed
        }
 
+rnPatAndThen _ (EmbTyPat _ toktype tp)
+  = do { tp' <- rnHsTyPat HsTypePatCtx tp
+       ; return (EmbTyPat noExtField toktype tp') }
+
 --------------------
 rnConPatAndThen :: NameMaker
                 -> LocatedN RdrName    -- the constructor

compiler/GHC/Stg/Lint.hs

@@ -415,7 +415,7 @@ lintAppCbvMarks e@(StgApp fun args) = do
         (text "marks" <> ppr marks $$
         text "args" <> ppr args $$
         text "arity" <> ppr (idArity fun) $$
-        text "join_arity" <> ppr (isJoinId_maybe fun))
+        text "join_arity" <> ppr (idJoinPointHood fun))
 lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"
 
 {-