packages feed

ghc-lib-parser 0.20201201 → 0.20210101

raw patch · 97 files changed

+3920/−3207 lines, 97 files

Files

compiler/GHC/Builtin/Types.hs view
@@ -170,6 +170,7 @@ import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) import GHC.Unit.Module        ( Module ) import GHC.Core.Type+import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.ConLike@@ -688,8 +689,9 @@ -- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon! constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] +-- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep. liftedTypeKind, typeToTypeKind, constraintKind :: Kind-liftedTypeKind   = tYPE liftedRepTy+liftedTypeKind   = TyCoRep.TyConApp liftedTypeKindTyCon [] typeToTypeKind   = liftedTypeKind `mkVisFunTyMany` liftedTypeKind constraintKind   = mkTyConApp constraintKindTyCon [] @@ -1410,11 +1412,12 @@ runtimeRepTy = mkTyConTy runtimeRepTyCon  -- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim+-- and Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep. -- type Type = tYPE 'LiftedRep liftedTypeKindTyCon :: TyCon liftedTypeKindTyCon   = buildSynTyCon liftedTypeKindTyConName-                                       [] liftedTypeKind []-                                       (tYPE liftedRepTy)+                                       [] liftedTypeKind [] rhs+  where rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]  runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []
compiler/GHC/Builtin/Types/Prim.hs view
@@ -551,10 +551,6 @@   = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax  -------------------------------- | Given a RuntimeRep, applies TYPE to it.--- see Note [TYPE and RuntimeRep]-tYPE :: Type -> Type-tYPE rr = TyConApp tYPETyCon [rr]  -- Given a Multiplicity, applies FUN to it. functionWithMultiplicity :: Type -> Type
+ compiler/GHC/Builtin/Types/Prim.hs-boot view
@@ -0,0 +1,5 @@+module GHC.Builtin.Types.Prim where++import GHC.Core.TyCon++tYPETyCon :: TyCon
compiler/GHC/ByteCode/Types.hs view
@@ -17,12 +17,12 @@ import GHC.Prelude  import GHC.Data.FastString+import GHC.Data.SizedSeq import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps-import SizedSeq import GHC.Core.Type import GHC.Types.SrcLoc import GHCi.BreakArray
compiler/GHC/Cmm/Dataflow/Label.hs view
@@ -141,6 +141,7 @@   alterTM k f m = mapAlter f k m   foldTM k m z = mapFoldr k z m   mapTM f m = mapMap f m+  filterTM f m = mapFilter f m  ----------------------------------------------------------------------------- -- FactBase
compiler/GHC/Cmm/Expr.hs view
@@ -53,14 +53,14 @@ -----------------------------------------------------------------------------  data CmmExpr-  = CmmLit CmmLit               -- Literal+  = CmmLit !CmmLit               -- Literal   | CmmLoad !CmmExpr !CmmType   -- Read memory location   | CmmReg !CmmReg              -- Contents of register   | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)   | CmmStackSlot Area {-# UNPACK #-} !Int                                 -- addressing expression of a stack slot                                 -- See Note [CmmStackSlot aliasing]-  | CmmRegOff !CmmReg Int+  | CmmRegOff !CmmReg !Int         -- CmmRegOff reg i         --        ** is shorthand only, meaning **         -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]@@ -173,16 +173,16 @@ -}  data CmmLit-  = CmmInt !Integer  Width+  = CmmInt !Integer  !Width         -- Interpretation: the 2's complement representation of the value         -- is truncated to the specified size.  This is easier than trying         -- to keep the value within range, because we don't know whether         -- it will be used as a signed or unsigned value (the CmmType doesn't         -- distinguish between signed & unsigned).-  | CmmFloat  Rational Width+  | CmmFloat  Rational !Width   | CmmVec [CmmLit]                     -- Vector literal   | CmmLabel    CLabel                  -- Address of label-  | CmmLabelOff CLabel Int              -- Address of label + byte offset+  | CmmLabelOff CLabel !Int              -- Address of label + byte offset          -- Due to limitations in the C backend, the following         -- MUST ONLY be used inside the info table indicated by label2@@ -191,7 +191,7 @@         -- Don't use it at all unless tablesNextToCode.         -- It is also used inside the NCG during when generating         -- position-independent code.-  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset+  | CmmLabelDiffOff CLabel CLabel !Int !Width -- label1 - label2 + offset         -- In an expression, the width just has the effect of MO_SS_Conv         -- from wordWidth to the desired width.         --@@ -363,6 +363,7 @@     foldRegsDefd _ _ z (CmmGlobal _)  = z  instance UserOfRegs GlobalReg CmmReg where+    {-# INLINEABLE foldRegsUsed #-}     foldRegsUsed _ _ z (CmmLocal _)    = z     foldRegsUsed _ f z (CmmGlobal reg) = f z reg @@ -379,6 +380,7 @@ instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where   -- The (Ord r) in the context is necessary here   -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance+  {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z e = expr z e     where expr z (CmmLit _)          = z           expr z (CmmLoad addr _)    = foldRegsUsed platform f z addr
compiler/GHC/Cmm/Node.hs view
@@ -318,6 +318,7 @@ -- Instances of register and slot users / definers  instance UserOfRegs LocalReg (CmmNode e x) where+  {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr     CmmStore addr rval -> fold f (fold f z addr) rval@@ -332,6 +333,7 @@           fold f z n = foldRegsUsed platform f z n  instance UserOfRegs GlobalReg (CmmNode e x) where+  {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr     CmmStore addr rval -> fold f (fold f z addr) rval@@ -348,10 +350,12 @@ instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where   -- The (Ord r) in the context is necessary here   -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance+  {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed _        _ !z (PrimTarget _)      = z   foldRegsUsed platform f !z (ForeignTarget e _) = foldRegsUsed platform f z e  instance DefinerOfRegs LocalReg (CmmNode e x) where+  {-# INLINEABLE foldRegsDefd #-}   foldRegsDefd platform f !z n = case n of     CmmAssign lhs _ -> fold f z lhs     CmmUnsafeForeignCall _ fs _ -> fold f z fs@@ -362,6 +366,7 @@           fold f z n = foldRegsDefd platform f z n  instance DefinerOfRegs GlobalReg (CmmNode e x) where+  {-# INLINEABLE foldRegsDefd #-}   foldRegsDefd platform f !z n = case n of     CmmAssign lhs _ -> fold f z lhs     CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
compiler/GHC/Core/Coercion.hs view
@@ -13,8 +13,8 @@ -- module GHC.Core.Coercion (         -- * Main data type-        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,-        UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..),+        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionN, MCoercionR,+        UnivCoProvenance, CoercionHole(..),         coHoleCoVar, setCoHoleCoVar,         LeftOrRight(..),         Var, CoVar, TyCoVar,@@ -69,9 +69,11 @@         pickLR,          isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,-        isReflCoVar_maybe, isGReflMCo,-        coToMCo, mkTransMCo, mkTransMCoL,+        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,+        mkCoherenceRightMCo, +        coToMCo, mkTransMCo, mkTransMCoL, mkCastTyMCo, mkSymMCo, isReflMCo,+         -- ** Coercion variables         mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,         isCoVar_maybe,@@ -79,7 +81,7 @@         -- ** Free variables         tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,         tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,-        coercionSize,+        coercionSize, anyFreeVarsOfCo,          -- ** Substitution         CvSubstEnv, emptyCvSubstEnv,@@ -121,7 +123,8 @@          simplifyArgsWorker, -        badCoercionHole, badCoercionHoleCo+        hasCoercionHoleTy, hasCoercionHoleCo,+        HoleSet, coercionHolesOfType, coercionHolesOfCo        ) where  #include "GhclibHsVersions.h"@@ -154,6 +157,7 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM+import GHC.Types.Unique.Set  import GHC.Utils.Misc import GHC.Utils.Outputable@@ -331,7 +335,33 @@ mkTransMCoL MRefl     co2 = MCo co2 mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2) +-- | Get the reverse of an 'MCoercion'+mkSymMCo :: MCoercion -> MCoercion+mkSymMCo MRefl    = MRefl+mkSymMCo (MCo co) = MCo (mkSymCo co) +-- | Cast a type by an 'MCoercion'+mkCastTyMCo :: Type -> MCoercion -> Type+mkCastTyMCo ty MRefl    = ty+mkCastTyMCo ty (MCo co) = ty `mkCastTy` co++mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflLeftMCo r ty MRefl    = mkReflCo r ty+mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co++mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflRightMCo r ty MRefl    = mkReflCo r ty+mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co++-- | Like 'mkCoherenceRightCo', but with an 'MCoercion'+mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion+mkCoherenceRightMCo _ _  MRefl    co2 = co2+mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2++isReflMCo :: MCoercion -> Bool+isReflMCo MRefl = True+isReflMCo _     = False+ {- %************************************************************************ %*                                                                      *@@ -1219,7 +1249,7 @@   | otherwise   = KindCo co -mkSubCo :: Coercion -> Coercion+mkSubCo :: HasDebugCallStack => Coercion -> Coercion -- Input coercion is Nominal, result is Representational -- see also Note [Role twiddling functions] mkSubCo (Refl ty) = GRefl Representational ty MRefl@@ -1620,7 +1650,7 @@ situation where the main coercion is reflexive, via the special cases for Refl and GRefl. -This is important when flattening  (ty |> co). We flatten ty, yielding+This is important when rewriting  (ty |> co). We rewrite ty, yielding    fco :: ty ~ ty' and now we want a coercion xco between    xco :: (ty |> co) ~ (ty' |> co)@@ -1675,6 +1705,11 @@                                     -- ^ ev is evidence;                                     -- Usually a co :: old type ~ new type +instance Outputable ev => Outputable (NormaliseStepResult ev) where+  ppr NS_Done           = text "NS_Done"+  ppr NS_Abort          = text "NS_Abort"+  ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]+ mapStepResult :: (ev1 -> ev2)               -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)@@ -2629,18 +2664,19 @@ %*                                                                      * %************************************************************************ -The function below morally belongs in GHC.Tc.Solver.Flatten, but it is used also in+The function below morally belongs in GHC.Tc.Solver.Rewrite, but it is used also in FamInstEnv, and so lives here.  Note [simplifyArgsWorker] ~~~~~~~~~~~~~~~~~~~~~~~~~-Invariant (F2) of Note [Flattening] says that flattening is homogeneous.-This causes some trouble when flattening a function applied to a telescope+Invariant (F2) of Note [Rewriting] in GHC.Tc.Solver.Rewrite says that+rewriting is homogeneous.+This causes some trouble when rewriting a function applied to a telescope of arguments, perhaps with dependency. For example, suppose    type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] -and we wish to flatten the args of (with kind applications explicit)+and we wish to rewrite the args of (with kind applications explicit)    F a b (Just a c) (Right a b d) False @@ -2656,7 +2692,7 @@   [G] cco :: c ~ fc   [G] dco :: d ~ fd -The first step is to flatten all the arguments. This is done before calling+The first step is to rewrite all the arguments. This is done before calling simplifyArgsWorker. We start from    a@@ -2677,26 +2713,26 @@   co6 :: Maybe fa ~ Maybe a   co7 :: Either fa fb ~ Either a b -We now process the flattened args in left-to-right order. The first two args-need no further processing. But now consider the third argument. Let f3 = the flattened+We now process the rewritten args in left-to-right order. The first two args+need no further processing. But now consider the third argument. Let f3 = the rewritten result, Just fa (fc |> aco) |> co6.-This f3 flattened argument has kind (Maybe a), due to+This f3 rewritten argument has kind (Maybe a), due to (F2). And yet, when we build the application (F fa fb ...), we need this argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. The coercion to use is determined by the kind of F: we see in F's kind that the third argument has kind Maybe j. Critically, we also know that the argument corresponding to j-(in our example, a) flattened with a coercion co1. We can thus know the+(in our example, a) rewrote with a coercion co1. We can thus know the coercion needed for the 3rd argument is (Maybe (sym co1)), thus building (f3 |> Maybe (sym co1))  More generally, we must use the Lifting Lemma, as implemented in Coercion.liftCoSubst. As we work left-to-right, any variable that is a dependent parameter (j and k, in our example) gets mapped in a lifting context-to the coercion that is output from flattening the corresponding argument (co1-and co2, in our example). Then, after flattening later arguments, we lift the+to the coercion that is output from rewriting the corresponding argument (co1+and co2, in our example). Then, after rewriting later arguments, we lift the kind of these arguments in the lifting context that we've be building up.-This coercion is then used to keep the result of flattening well-kinded.+This coercion is then used to keep the result of rewriting well-kinded.  Working through our example, this is what happens: @@ -2712,7 +2748,7 @@    4. Lifting the kind (Either j k) with our LC      yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th-     argument to F, where f4 is the flattened form of argument 4, written above.+     argument to F, where f4 is the rewritten form of argument 4, written above.    5. We lift Bool with our LC, getting <Bool>;      casting has no effect.@@ -2753,14 +2789,14 @@   co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)   co = forall (j :: sym axStar). (<j> -> sym axStar) -  We are flattening:+  We are rewriting:   a (forall (j :: Star). (j |> axStar) -> Star)   -- 1     (Proxy |> co)                                 -- 2     (bo |> sym axStar)                            -- 3     (NoWay |> sym bc)                             -- 4       :: Star -First, we flatten all the arguments (before simplifyArgsWorker), like so:+First, we rewrite all the arguments (before simplifyArgsWorker), like so:      (forall j. j -> Type, co1 :: (forall j. j -> Type) ~                                  (forall (j :: Star). (j |> axStar) -> Star))  -- 1@@ -2772,7 +2808,7 @@  1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we    don't use it. But we do build a lifting context [k -> co1] (where co1 is a-   result of flattening an argument, written above).+   result of rewriting an argument, written above).  2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1).    This is not a dependent argument, so we don't extend the lifting context.@@ -2791,10 +2827,10 @@ decomposed it, we would end up with coercions whose types include j, which is out of scope here. Accordingly, decomposePiCos takes a list of types whose kinds are the *right-hand* types in the decomposed coercion. (See comments on-decomposePiCos.) Because the flattened types have unflattened kinds (because-flattening is homogeneous), passing the list of flattened types to decomposePiCos+decomposePiCos.) Because the rewritten types have unrewritten kinds (because+rewriting is homogeneous), passing the list of rewritten types to decomposePiCos just won't do: later arguments' kinds won't be as expected. So we need to get-the *unflattened* types to pass to decomposePiCos. We can do this easily enough+the *unrewritten* types to pass to decomposePiCos. We can do this easily enough by taking the kind of the argument coercions, passed in originally.  (Alternative 1: We could re-engineer decomposePiCos to deal with this situation.@@ -2806,7 +2842,7 @@ complication of decomposePiCos would end up layered on top of all the complication here. Please, no.) -(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker+(Alternative 3: We could pass the unrewritten arguments into simplifyArgsWorker so that we don't have to recreate them. But that would complicate the interface of this function to handle a very dark, dark corner case. Better to keep our demons to ourselves here instead of exposing them to callers. This decision is@@ -2827,7 +2863,7 @@                            == bo ~ bo   res_co :: Type ~ Star -We then use these casts on (the flattened) (3) and (4) to get+We then use these casts on (the rewritten) (3) and (4) to get    (Bool |> sym axStar |> co5 :: Type)   -- (C3)   (False |> sym bc |> co6    :: bo)     -- (C4)@@ -2848,9 +2884,9 @@  This recursive call returns ([Bool, False], [...], Refl). The Bool and False are the correct arguments we wish to return. But we must be careful about the-result coercion: our new, flattened application will have kind Type, but we+result coercion: our new, rewritten application will have kind Type, but we want to make sure that the result coercion casts this back to Star. (Why?-Because we started with an application of kind Star, and flattening is homogeneous.)+Because we started with an application of kind Star, and rewriting is homogeneous.)  So, we have to twiddle the result coercion appropriately. @@ -2894,7 +2930,7 @@       k :: Type       x :: k -  flatten (f @Type @((->) k) x)+  rewrite (f @Type @((->) k) x)  After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded.@@ -2902,7 +2938,7 @@ -}  --- This is shared between the flattener and the normaliser in GHC.Core.FamInstEnv.+-- This is shared between the rewriter and the normaliser in GHC.Core.FamInstEnv. -- See Note [simplifyArgsWorker] {-# INLINE simplifyArgsWorker #-} simplifyArgsWorker :: [TyCoBinder] -> Kind@@ -2910,15 +2946,15 @@                        -- list of binders can be shorter or longer than the list of args                    -> TyCoVarSet   -- free vars of the args                    -> [Role]   -- list of roles, r-                   -> [(Type, Coercion)] -- flattened type arguments, arg-                                         -- each comes with the coercion used to flatten it,-                                         -- with co :: flattened_type ~ original_type-                   -> ([Type], [Coercion], CoercionN)+                   -> [(Type, Coercion)] -- rewritten type arguments, arg+                                         -- each comes with the coercion used to rewrite it,+                                         -- with co :: rewritten_type ~ original_type+                   -> ([Type], [Coercion], MCoercionN) -- Returns (xis, cos, res_co), where each co :: xi ~ arg, -- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args -- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),--- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded.--- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this+-- then (f orig_tys) is well kinded. Note that (f rewritten_tys) might *not* be well-kinded.+-- Massaging the rewritten_tys in order to make (f rewritten_tys) well-kinded is what this -- function is all about. That is, (f xis), where xis are the returned arguments, *is* -- well kinded. simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs@@ -2930,25 +2966,26 @@     go :: [Type]      -- Xis accumulator, in reverse order        -> [Coercion]  -- Coercions accumulator, in reverse order                       -- These are in 1-to-1 correspondence-       -> LiftingContext  -- mapping from tyvars to flattening coercions+       -> LiftingContext  -- mapping from tyvars to rewriting coercions        -> [TyCoBinder]    -- Unsubsted binders of function's kind        -> Kind        -- Unsubsted result kind of function (not a Pi-type)-       -> [Role]      -- Roles at which to flatten these ...-       -> [(Type, Coercion)]  -- flattened arguments, with their flattening coercions-       -> ([Type], [Coercion], CoercionN)+       -> [Role]      -- Roles at which to rewrite these ...+       -> [(Type, Coercion)]  -- rewritten arguments, with their rewriting coercions+       -> ([Type], [Coercion], MCoercionN)     go acc_xis acc_cos !lc binders inner_ki _ []         -- The !lc makes the function strict in the lifting context         -- which means GHC can unbox that pair.  A modest win.       = (reverse acc_xis, reverse acc_cos, kind_co)       where         final_kind = mkPiTys binders inner_ki-        kind_co = liftCoSubst Nominal lc final_kind+        kind_co | noFreeVarsOfType final_kind = MRefl+                | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind      go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args)-      = -- By Note [Flattening] in GHC.Tc.Solver.Flatten invariant (F2),+      = -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2),          -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be          -- used as an argument to a function whose kind is different, if-         -- earlier arguments have been flattened to new types. We thus+         -- earlier arguments have been rewritten to new types. We thus          -- need a coercion (kind_co :: old_kind ~ new_kind).          --          -- The bangs here have been observed to improve performance@@ -2977,8 +3014,8 @@     go acc_xis acc_cos lc [] inner_ki roles args       = let co1 = liftCoSubst Nominal lc inner_ki             co1_kind              = coercionKind co1-            unflattened_tys       = map (coercionRKind . snd) args-            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unflattened_tys+            unrewritten_tys       = map (coercionRKind . snd) args+            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unrewritten_tys             casted_args           = ASSERT2( equalLength args arg_cos                                            , ppr args $$ ppr arg_cos )                                     [ (casted_xi, casted_co)@@ -2992,20 +3029,20 @@                -- ... -> k, that k will be substituted to perhaps reveal more                -- binders.             zapped_lc             = zapLiftingContext lc-            Pair flattened_kind _ = co1_kind-            (bndrs, new_inner)    = splitPiTys flattened_kind+            Pair rewritten_kind _ = co1_kind+            (bndrs, new_inner)    = splitPiTys rewritten_kind              (xis_out, cos_out, res_co_out)               = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args         in-        (xis_out, cos_out, res_co_out `mkTransCo` res_co)+        (xis_out, cos_out, res_co_out `mkTransMCoL` res_co)      go _ _ _ _ _ _ _ = panic         "simplifyArgsWorker wandered into deeper water than usual"            -- This debug information is commented out because leaving it in            -- causes a ~2% increase in allocations in T9872d.-           -- That's independent of the analogous case in flatten_args_fast-           -- in GHC.Tc.Solver.Flatten:+           -- That's independent of the analogous case in rewrite_args_fast+           -- in GHC.Tc.Solver.Rewrite:            -- each of these causes a 2% increase on its own, so commenting them            -- both out gives a 4% decrease in T9872d.            {-@@ -3024,31 +3061,40 @@ %************************************************************************ -} -bad_co_hole_ty :: Type -> Monoid.Any-bad_co_hole_co :: Coercion -> Monoid.Any-(bad_co_hole_ty, _, bad_co_hole_co, _)+has_co_hole_ty :: Type -> Monoid.Any+has_co_hole_co :: Coercion -> Monoid.Any+(has_co_hole_ty, _, has_co_hole_co, _)   = foldTyCo folder ()   where     folder = TyCoFolder { tcf_view  = const Nothing                         , tcf_tyvar = const2 (Monoid.Any False)                         , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = const hole+                        , tcf_hole  = const2 (Monoid.Any True)                         , tcf_tycobinder = const2                         }      const2 :: a -> b -> c -> a     const2 x _ _ = x -    hole :: CoercionHole -> Monoid.Any-    hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True-    hole _                                             = Monoid.Any False+-- | Is there a coercion hole in this type?+hasCoercionHoleTy :: Type -> Bool+hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty --- | Is there a blocking coercion hole in this type? See--- "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds]-badCoercionHole :: Type -> Bool-badCoercionHole = Monoid.getAny . bad_co_hole_ty+-- | Is there a coercion hole in this coercion?+hasCoercionHoleCo :: Coercion -> Bool+hasCoercionHoleCo = Monoid.getAny . has_co_hole_co --- | Is there a blocking coercion hole in this coercion? See--- GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]-badCoercionHoleCo :: Coercion -> Bool-badCoercionHoleCo = Monoid.getAny . bad_co_hole_co+-- | A set of 'CoercionHole's+type HoleSet = UniqSet CoercionHole++-- | Extract out all the coercion holes from a given type+coercionHolesOfType :: Type -> UniqSet CoercionHole+coercionHolesOfCo   :: Coercion -> UniqSet CoercionHole+(coercionHolesOfType, _, coercionHolesOfCo, _) = foldTyCo folder ()+  where+    folder = TyCoFolder { tcf_view  = const Nothing  -- don't look through synonyms+                        , tcf_tyvar = \ _ _ -> mempty+                        , tcf_covar = \ _ _ -> mempty+                        , tcf_hole  = const unitUniqSet+                        , tcf_tycobinder = \ _ _ _ -> ()+                        }
compiler/GHC/Core/Coercion.hs-boot view
@@ -30,7 +30,7 @@ mkGReflCo :: Role -> Type -> MCoercionN -> Coercion mkNomReflCo :: Type -> Coercion mkKindCo :: Coercion -> Coercion-mkSubCo :: Coercion -> Coercion+mkSubCo :: HasDebugCallStack => Coercion -> Coercion mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
compiler/GHC/Core/Coercion/Axiom.hs view
@@ -584,9 +584,21 @@ -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily   { sfMatchFam      :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+    -- Does this reduce on the given arguments?+    -- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)+    -- That is: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)+    --              :: F tys ~r rhs,+    -- where the r in the output is coaxrRole of the rule. It is up to the+    -- caller to ensure that this role is appropriate.+   , sfInteractTop   :: [Type] -> Type -> [TypeEqn]+    -- If given these type arguments and RHS, returns the equalities that+    -- are guaranteed to hold.+   , sfInteractInert :: [Type] -> Type ->                        [Type] -> Type -> [TypeEqn]+    -- If given one set of arguments and result, and another set of arguments+    -- and result, returns the equalities that are guaranteed to hold.   }  -- Provides default implementations that do nothing.
compiler/GHC/Core/Coercion/Opt.hs view
@@ -24,11 +24,9 @@ import GHC.Core.Coercion.Axiom import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Core.FamInstEnv ( flattenTys ) import GHC.Data.Pair import GHC.Data.List.SetOps ( getNth ) import GHC.Core.Unify-import GHC.Core.InstEnv import Control.Monad   ( zipWithM )  import GHC.Utils.Outputable@@ -1007,7 +1005,7 @@     check_no_conflict _    [] = Nothing     check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)          -- See Note [Apartness] in GHC.Core.FamInstEnv-      | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp+      | SurelyApart <- tcUnifyTysFG (const BindMe) flat lhs_incomp       = check_no_conflict flat rest       | otherwise       = Just b
compiler/GHC/Core/DataCon.hs view
@@ -21,7 +21,7 @@         substEqSpec, filterEqSpec,          -- ** Field labels-        FieldLbl(..), FieldLabel, FieldLabelString,+        FieldLabel(..), FieldLabelString,          -- ** Type construction         mkDataCon, fIRST_TAG,@@ -1564,15 +1564,13 @@ -- | Extract the type constructor, type argument, data constructor and it's -- /representation/ argument types from a type if it is a product type. ----- Precisely, we return @Just@ for any type that is all of:+-- Precisely, we return @Just@ for any data type that is all of: -- --  * Concrete (i.e. constructors visible)--- --  * Single-constructor------  * Not existentially quantified+--  * ... which has no existentials ----- Whether the type is a @data@ type or a @newtype@+-- Whether the type is a @data@ type or a @newtype@. splitDataProductType_maybe         :: Type                         -- ^ A product type, perhaps         -> Maybe (TyCon,                -- The type constructor@@ -1580,13 +1578,14 @@                   DataCon,              -- The data constructor                   [Scaled Type])        -- Its /representation/ arg types -        -- Rejecting existentials is conservative.  Maybe some things-        -- could be made to work with them, but I'm not going to sweat-        -- it through till someone finds it's important.+        -- Rejecting existentials means we don't have to worry about+        -- freshening and substituting type variables+        -- (See "GHC.Type.Id.Make.dataConArgUnpack")  splitDataProductType_maybe ty   | Just (tycon, ty_args) <- splitTyConApp_maybe ty-  , Just con <- isDataProductTyCon_maybe tycon+  , Just con <- tyConSingleDataCon_maybe tycon+  , null (dataConExTyCoVars con) -- no existentials! See above   = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)   | otherwise   = Nothing
compiler/GHC/Core/FVs.hs view
@@ -28,12 +28,13 @@         varTypeTyCoFVs,         idUnfoldingVars, idFreeVars, dIdFreeVars,         bndrRuleAndUnfoldingVarsDSet,+        bndrRuleAndUnfoldingIds,         idFVs,-        idRuleVars, idRuleRhsVars, stableUnfoldingVars,+        idRuleVars, stableUnfoldingVars,         ruleFreeVars, rulesFreeVars,         rulesFreeVarsDSet, mkRuleInfo,         ruleLhsFreeIds, ruleLhsFreeIdsList,-        ruleRhsFreeVars, ruleRhsFreeIds,+        ruleRhsFreeVars, rulesRhsFreeIds,          expr_fvs, @@ -62,8 +63,6 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name.Set-import GHC.Types.Unique.Set-import GHC.Types.Unique (Uniquable (..)) import GHC.Types.Name import GHC.Types.Var.Set import GHC.Types.Var@@ -76,7 +75,6 @@ import GHC.Builtin.Types( unrestrictedFunTyConName ) import GHC.Builtin.Types.Prim( funTyConName ) import GHC.Data.Maybe( orElse )-import GHC.Types.Basic( Activation )  import GHC.Utils.FV as FV import GHC.Utils.Misc@@ -450,88 +448,71 @@ ************************************************************************ -} +data RuleFVsFrom+  = LhsOnly+  | RhsOnly+  | BothSides++-- | Those locally-defined variables free in the left and/or right hand sides+-- of the rule, depending on the first argument. Returns an 'FV' computation.+ruleFVs :: RuleFVsFrom -> CoreRule -> FV+ruleFVs !_   (BuiltinRule {}) = emptyFV+ruleFVs from (Rule { ru_fn = _do_not_include+                     -- See Note [Rule free var hack]+                   , ru_bndrs = bndrs+                   , ru_rhs = rhs, ru_args = args })+  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs exprs)+  where+    exprs = case from of+      LhsOnly   -> args+      RhsOnly   -> [rhs]+      BothSides -> rhs:args++-- | Those locally-defined variables free in the left and/or right hand sides+-- from several rules, depending on the first argument.+-- Returns an 'FV' computation.+rulesFVs :: RuleFVsFrom -> [CoreRule] -> FV+rulesFVs from = mapUnionFV (ruleFVs from)+ -- | Those variables free in the right hand side of a rule returned as a -- non-deterministic set ruleRhsFreeVars :: CoreRule -> VarSet-ruleRhsFreeVars (BuiltinRule {}) = noFVs-ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })-  = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)-      -- See Note [Rule free var hack]+ruleRhsFreeVars = fvVarSet . ruleFVs RhsOnly --- | Those variables free in the both the left right hand sides of a rule+-- | Those locally-defined free 'Id's in the right hand side of several rules -- returned as a non-deterministic set-ruleFreeVars :: CoreRule -> VarSet-ruleFreeVars = fvVarSet . ruleFVs+rulesRhsFreeIds :: [CoreRule] -> VarSet+rulesRhsFreeIds = fvVarSet . filterFV isLocalId . rulesFVs RhsOnly --- | Those variables free in the both the left right hand sides of a rule--- returned as FV computation-ruleFVs :: CoreRule -> FV-ruleFVs (BuiltinRule {}) = emptyFV-ruleFVs (Rule { ru_fn = _do_not_include-                  -- See Note [Rule free var hack]-              , ru_bndrs = bndrs-              , ru_rhs = rhs, ru_args = args })-  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))+ruleLhsFreeIds :: CoreRule -> VarSet+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a non-deterministic set+ruleLhsFreeIds = fvVarSet . filterFV isLocalId . ruleFVs LhsOnly --- | Those variables free in the both the left right hand sides of rules--- returned as FV computation-rulesFVs :: [CoreRule] -> FV-rulesFVs = mapUnionFV ruleFVs+ruleLhsFreeIdsList :: CoreRule -> [Var]+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a deterministically ordered list+ruleLhsFreeIdsList = fvVarList . filterFV isLocalId . ruleFVs LhsOnly +-- | Those variables free in the both the left right hand sides of a rule+-- returned as a non-deterministic set+ruleFreeVars :: CoreRule -> VarSet+ruleFreeVars = fvVarSet . ruleFVs BothSides+ -- | Those variables free in the both the left right hand sides of rules -- returned as a deterministic set rulesFreeVarsDSet :: [CoreRule] -> DVarSet-rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules+rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs BothSides rules +-- | Those variables free in both the left right hand sides of several rules+rulesFreeVars :: [CoreRule] -> VarSet+rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules+ -- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable -- for putting into an 'IdInfo' mkRuleInfo :: [CoreRule] -> RuleInfo mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) -idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet--- Just the variables free on the *rhs* of a rule-idRuleRhsVars is_active id-  = mapUnionVarSet get_fvs (idCoreRules id)-  where-    get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs-                  , ru_rhs = rhs, ru_act = act })-      | is_active act-            -- See Note [Finding rule RHS free vars] in "GHC.Core.Opt.OccurAnal"-      = delOneFromUniqSet_Directly fvs (getUnique fn)-            -- Note [Rule free var hack]-      where-        fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)-    get_fvs _ = noFVs---- | Those variables free in the right hand side of several rules-rulesFreeVars :: [CoreRule] -> VarSet-rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules--ruleLhsFreeIds :: CoreRule -> VarSet--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns them as a non-deterministic set-ruleLhsFreeIds = fvVarSet . ruleLhsFVIds--ruleLhsFreeIdsList :: CoreRule -> [Var]--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns them as a deterministically ordered list-ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds--ruleLhsFVIds :: CoreRule -> FV--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns an FV computation-ruleLhsFVIds (BuiltinRule {}) = emptyFV-ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })-  = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)--ruleRhsFreeIds :: CoreRule -> VarSet--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns them as a non-deterministic set-ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet-ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })-  = fvVarSet $ filterFV isLocalId $-     addBndrs bndrs $ exprs_fvs args- {- Note [Rule free var hack]  (Not a hack any more) ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -587,9 +568,6 @@ freeVarsOfAnn :: FVAnn -> DIdSet freeVarsOfAnn fvs = fvs -noFVs :: VarSet-noFVs = emptyVarSet- aFreeVar :: Var -> DVarSet aFreeVar = unitDVarSet @@ -660,6 +638,9 @@  bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id++bndrRuleAndUnfoldingIds :: Id -> IdSet+bndrRuleAndUnfoldingIds id = fvVarSet $ filterFV isId $ bndrRuleAndUnfoldingFVs id  bndrRuleAndUnfoldingFVs :: Id -> FV bndrRuleAndUnfoldingFVs id
compiler/GHC/Core/FamInstEnv.hs view
@@ -35,10 +35,7 @@         -- Normalisation         topNormaliseType, topNormaliseType_maybe,         normaliseType, normaliseTcApp,-        topReduceTyFamApp_maybe, reduceTyFamApp_maybe,--        -- Flattening-        flattenTys+        topReduceTyFamApp_maybe, reduceTyFamApp_maybe     ) where  #include "GhclibHsVersions.h"@@ -56,11 +53,8 @@ import GHC.Types.Name import GHC.Types.Unique.DFM import GHC.Data.Maybe-import GHC.Core.Map-import GHC.Types.Unique import GHC.Types.Var import GHC.Types.SrcLoc-import GHC.Data.FastString import Control.Monad import Data.List( mapAccumL ) import Data.Array( Array, assocs )@@ -434,7 +428,8 @@ apart(target, pattern) = not (unify(flatten(target), pattern))  where flatten (implemented in flattenTys, below) converts all type-family-applications into fresh variables. (See Note [Flattening].)+applications into fresh variables. (See+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.)  Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~@@ -1147,6 +1142,7 @@    | Just ax           <- isBuiltInSynFamTyCon_maybe tc   , Just (coax,ts,ty) <- sfMatchFam ax tys+  , role == coaxrRole coax   = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)     in Just (co, ty) @@ -1181,7 +1177,8 @@                         , cab_incomps = incomps }) = branch             in_scope = mkInScopeSet (unionVarSets $                             map (tyCoVarsOfTypes . coAxBranchLHS) incomps)-            -- See Note [Flattening] below+            -- See Note [Flattening type-family applications when matching instances]+            -- in GHC.Core.Unify             flattened_target = flattenTys in_scope target_tys         in case tcMatchTys tpl_lhs target_tys of         Just subst -- matching worked. now, check for apartness.@@ -1198,10 +1195,10 @@ -- (POPL '14). This should be used when determining if an equation -- ('CoAxBranch') of a closed type family can be used to reduce a certain target -- type family application.-apartnessCheck :: [Type]     -- ^ /flattened/ target arguments. Make sure-                             -- they're flattened! See Note [Flattening].-                             -- (NB: This "flat" is a different-                             -- "flat" than is used in GHC.Tc.Solver.Flatten.)+apartnessCheck :: [Type]+  -- ^ /flattened/ target arguments. Make sure they're flattened! See+  -- Note [Flattening type-family applications when matching instances]+  -- in GHC.Core.Unify.                -> CoAxBranch -- ^ the candidate equation we wish to use                              -- Precondition: this matches the target                -> Bool       -- ^ True <=> equation can fire@@ -1321,7 +1318,7 @@     tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)     tyFamStepper rec_nts tc tys  -- Try to step a type/data family       = case topReduceTyFamApp_maybe env tc tys of-          Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, MCo res_co)+          Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, res_co)           _                      -> NS_Done  ---------------@@ -1367,14 +1364,14 @@     assemble_result :: Role       -- r, ambient role in NormM monad                     -> Type       -- nty, result type, possibly of changed kind                     -> Coercion   -- orig_ty ~r nty, possibly heterogeneous-                    -> CoercionN  -- typeKind(orig_ty) ~N typeKind(nty)+                    -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty)                     -> (Coercion, Type)   -- (co :: orig_ty ~r nty_casted, nty_casted)                                           -- where nty_casted has same kind as orig_ty     assemble_result r nty orig_to_nty kind_co       = ( final_co, nty_old_kind )       where-        nty_old_kind = nty `mkCastTy` mkSymCo kind_co-        final_co     = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty+        nty_old_kind = nty `mkCastTyMCo` mkSymMCo kind_co+        final_co     = mkCoherenceRightMCo r nty (mkSymMCo kind_co) orig_to_nty  --------------- -- | Try to simplify a type-family application, by *one* step@@ -1383,7 +1380,7 @@ --         res_co :: typeKind(F tys) ~ typeKind(rhs) -- Type families and data families; always Representational role topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type]-                        -> Maybe (Coercion, Type, Coercion)+                        -> Maybe (Coercion, Type, MCoercion) topReduceTyFamApp_maybe envs fam_tc arg_tys   | isFamilyTyCon fam_tc   -- type families and data families   , Just (co, rhs) <- reduceTyFamApp_maybe envs role fam_tc ntys@@ -1396,7 +1393,7 @@                               normalise_tc_args fam_tc arg_tys  normalise_tc_args :: TyCon -> [Type]             -- tc tys-                  -> NormM (Coercion, [Type], CoercionN)+                  -> NormM (Coercion, [Type], MCoercionN)                   -- (co, new_tys), where                   -- co :: tc tys ~ tc new_tys; might not be homogeneous                   -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys)@@ -1461,14 +1458,14 @@     go_app_tys :: Type   -- function                -> [Type] -- args                -> NormM (Coercion, Type)-    -- cf. GHC.Tc.Solver.Flatten.flatten_app_ty_args+    -- cf. GHC.Tc.Solver.Rewrite.rewrite_app_ty_args     go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys)     go_app_tys fun_ty arg_tys       = do { (fun_co, nfun) <- go fun_ty            ; case tcSplitTyConApp_maybe nfun of                Just (tc, xis) ->                  do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys))-                   -- flatten_app_ty_args avoids redundantly processing the xis,+                   -- rewrite_app_ty_args avoids redundantly processing the xis,                    -- but that's a much more performance-sensitive function.                    -- This type normalisation is not called in a loop.                     ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) }@@ -1479,29 +1476,29 @@                     ; role <- getRole                     ; let nty = mkAppTys nfun nargs                           nco = mkAppCos fun_co args_cos-                          nty_casted = nty `mkCastTy` mkSymCo res_co-                          final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco+                          nty_casted = nty `mkCastTyMCo` mkSymMCo res_co+                          final_co = mkCoherenceRightMCo role nty (mkSymMCo res_co) nco                     ; return (final_co, nty_casted) } }  normalise_args :: Kind    -- of the function                -> [Role]  -- roles at which to normalise args                -> [Type]  -- args-               -> NormM ([Coercion], [Type], Coercion)+               -> NormM ([Coercion], [Type], MCoercion) -- returns (cos, xis, res_co), where each xi is the normalised -- version of the corresponding type, each co is orig_arg ~ xi, -- and the res_co :: kind(f orig_args) ~ kind(f xis) -- NB: The xis might *not* have the same kinds as the input types, -- but the resulting application *will* be well-kinded--- cf. GHC.Tc.Solver.Flatten.flatten_args_slow+-- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow normalise_args fun_ki roles args   = do { normed_args <- zipWithM normalise1 roles args        ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args-       ; return (map mkSymCo cos, xis, mkSymCo res_co) }+       ; return (map mkSymCo cos, xis, mkSymMCo res_co) }   where     (ki_binders, inner_ki) = splitPiTys fun_ki     fvs = tyCoVarsOfTypes args -    -- flattener conventions are different from ours+    -- rewriter conventions are different from ours     impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion)     impedance_match action = do { (co, ty) <- action                                 ; return (ty, mkSymCo co) }@@ -1565,292 +1562,3 @@ instance Applicative NormM where   pure x = NormM $ \ _ _ _ -> x   (<*>)  = ap--{--************************************************************************-*                                                                      *-              Flattening-*                                                                      *-************************************************************************--Note [Flattening]-~~~~~~~~~~~~~~~~~-As described in "Closed type families with overlapping equations"-http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf-we need to flatten core types before unifying them, when checking for "surely-apart"-against earlier equations of a closed type family.-Flattening means replacing all top-level uses of type functions with-fresh variables, *taking care to preserve sharing*. That is, the type-(Either (F a b) (F a b)) should flatten to (Either c c), never (Either-c d).--Here is a nice example of why it's all necessary:--  type family F a b where-    F Int Bool = Char-    F a   b    = Double-  type family G a         -- open, no instances--How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,-while the second equation does. But, before reducing, we must make sure that the-target can never become (F Int Bool). Well, no matter what G Float becomes, it-certainly won't become *both* Int and Bool, so indeed we're safe reducing-(F (G Float) (G Float)) to Double.--This is necessary not only to get more reductions (which we might be-willing to give up on), but for substitutivity. If we have (F x x), we-can see that (F x x) can reduce to Double. So, it had better be the-case that (F blah blah) can reduce to Double, no matter what (blah)-is!  Flattening as done below ensures this.--The algorithm works by building up a TypeMap TyVar, mapping-type family applications to fresh variables. This mapping must-be threaded through all the function calls, as any entry in-the mapping must be propagated to all future nodes in the tree.--The algorithm also must track the set of in-scope variables, in-order to make fresh variables as it flattens. (We are far from a-source of fresh Uniques.) See Wrinkle 2, below.--There are wrinkles, of course:--1. The flattening algorithm must account for the possibility-   of inner `forall`s. (A `forall` seen here can happen only-   because of impredicativity. However, the flattening operation-   is an algorithm in Core, which is impredicative.)-   Suppose we have (forall b. F b) -> (forall b. F b). Of course,-   those two bs are entirely unrelated, and so we should certainly-   not flatten the two calls F b to the same variable. Instead, they-   must be treated separately. We thus carry a substitution that-   freshens variables; we must apply this substitution (in-   `coreFlattenTyFamApp`) before looking up an application in the environment.-   Note that the range of the substitution contains only TyVars, never anything-   else.--   For the sake of efficiency, we only apply this substitution when absolutely-   necessary. Namely:--   * We do not perform the substitution at all if it is empty.-   * We only need to worry about the arguments of a type family that are within-     the arity of said type family, so we can get away with not applying the-     substitution to any oversaturated type family arguments.-   * Importantly, we do /not/ achieve this substitution by recursively-     flattening the arguments, as this would be wrong. Consider `F (G a)`,-     where F and G are type families. We might decide that `F (G a)` flattens-     to `beta`. Later, the substitution is non-empty (but does not map `a`) and-     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,-     `F gamma` is unknown, and so we flatten it to `delta`, but it really-     should have been `beta`! Argh!--     Moral of the story: instead of flattening the arguments, just substitute-     them directly.--2. There are two different reasons we might add a variable-   to the in-scope set as we work:--     A. We have just invented a new flattening variable.-     B. We have entered a `forall`.--   Annoying here is that in-scope variable source (A) must be-   threaded through the calls. For example, consider (F b -> forall c. F c).-   Suppose that, when flattening F b, we invent a fresh variable c.-   Now, when we encounter (forall c. F c), we need to know c is already in-   scope so that we locally rename c to c'. However, if we don't thread through-   the in-scope set from one argument of (->) to the other, we won't know this-   and might get very confused.--   In contrast, source (B) increases only as we go deeper, as in-scope sets-   normally do. However, even here we must be careful. The TypeMap TyVar that-   contains mappings from type family applications to freshened variables will-   be threaded through both sides of (forall b. F b) -> (forall b. F b). We-   thus must make sure that the two `b`s don't get renamed to the same b1. (If-   they did, then looking up `F b1` would yield the same flatten var for-   each.) So, even though `forall`-bound variables should really be in the-   in-scope set only when they are in scope, we retain these variables even-   outside of their scope. This ensures that, if we encounter a fresh-   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a-   larger in-scope set than strictly necessary is always OK, as in-scope sets-   are only ever used to avoid collisions.--   Sadly, the freshening substitution described in (1) really mustn't bind-   variables outside of their scope: note that its domain is the *unrenamed*-   variables. This means that the substitution gets "pushed down" (like a-   reader monad) while the in-scope set gets threaded (like a state monad).-   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;-   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet-   traveling separately as necessary.--3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:--     type family F ty_1 ... ty_k :: res_k--   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a-   flattening skolem. But we must instead flatten it to-   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the-   type family.--   Why is this better? Consider the following concrete example from #16995:--     type family Param :: Type -> Type--     type family LookupParam (a :: Type) :: Type where-       LookupParam (f Char) = Bool-       LookupParam x        = Int--     foo :: LookupParam (Param ())-     foo = 42--   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to-   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if-   `alpha` is apart from `f Char`, so it won't fall through to the second-   equation. But since the `Param` type family has arity 0, we can instead-   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is-   apart from `f Char`, permitting the second equation to be reached.--   Not only does this allow more programs to be accepted, it's also important-   for correctness. Not doing this was the root cause of the Core Lint error-   in #16995.--flattenTys is defined here because of module dependencies.--}--data FlattenEnv-  = FlattenEnv { fe_type_map :: TypeMap TyVar-                 -- domain: exactly-saturated type family applications-                 -- range: fresh variables-               , fe_in_scope :: InScopeSet }-                 -- See Note [Flattening]--emptyFlattenEnv :: InScopeSet -> FlattenEnv-emptyFlattenEnv in_scope-  = FlattenEnv { fe_type_map = emptyTypeMap-               , fe_in_scope = in_scope }--updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv-updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }--flattenTys :: InScopeSet -> [Type] -> [Type]--- See Note [Flattening]--- NB: the returned types may mention fresh type variables,---     arising from the flattening.  We don't return the---     mapping from those fresh vars to the ty-fam---     applications they stand for (we could, but no need)-flattenTys in_scope tys-  = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys--coreFlattenTys :: TvSubstEnv -> FlattenEnv-               -> [Type] -> (FlattenEnv, [Type])-coreFlattenTys subst = mapAccumL (coreFlattenTy subst)--coreFlattenTy :: TvSubstEnv -> FlattenEnv-              -> Type -> (FlattenEnv, Type)-coreFlattenTy subst = go-  where-    go env ty | Just ty' <- coreView ty = go env ty'--    go env (TyVarTy tv)-      | Just ty <- lookupVarEnv subst tv = (env, ty)-      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in-                                           (env', mkTyVarTy $ setTyVarKind tv ki)-    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1-                                 (env2, ty2') = go env1 ty2 in-                             (env2, AppTy ty1' ty2')-    go env (TyConApp tc tys)-         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,-         -- which are generative and thus can be preserved during flattening-      | not (isGenerativeTyCon tc Nominal)-      = coreFlattenTyFamApp subst env tc tys--      | otherwise-      = let (env', tys') = coreFlattenTys subst env tys in-        (env', mkTyConApp tc tys')--    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })-      = let (env1, ty1') = go env  ty1-            (env2, ty2') = go env1 ty2-            (env3, mult') = go env2 mult in-        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })--    go env (ForAllTy (Bndr tv vis) ty)-      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv-            (env2, ty') = coreFlattenTy subst' env1 ty in-        (env2, ForAllTy (Bndr tv' vis) ty')--    go env ty@(LitTy {}) = (env, ty)--    go env (CastTy ty co)-      = let (env1, ty') = go env ty-            (env2, co') = coreFlattenCo subst env1 co in-        (env2, CastTy ty' co')--    go env (CoercionTy co)-      = let (env', co') = coreFlattenCo subst env co in-        (env', CoercionTy co')----- when flattening, we don't care about the contents of coercions.--- so, just return a fresh variable of the right (flattened) type-coreFlattenCo :: TvSubstEnv -> FlattenEnv-              -> Coercion -> (FlattenEnv, Coercion)-coreFlattenCo subst env co-  = (env2, mkCoVarCo covar)-  where-    (env1, kind') = coreFlattenTy subst env (coercionType co)-    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'-    -- Add the covar to the FlattenEnv's in-scope set.-    -- See Note [Flattening], wrinkle 2A.-    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)--coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv-                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)-coreFlattenVarBndr subst env tv-  = (env2, subst', tv')-  where-    -- See Note [Flattening], wrinkle 2B.-    kind          = varType tv-    (env1, kind') = coreFlattenTy subst env kind-    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')-    subst'        = extendVarEnv subst tv (mkTyVarTy tv')-    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')--coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv-                    -> TyCon         -- type family tycon-                    -> [Type]        -- args, already flattened-                    -> (FlattenEnv, Type)-coreFlattenTyFamApp tv_subst env fam_tc fam_args-  = case lookupTypeMap type_map fam_ty of-      Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args')-      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc-                     tv         = uniqAway in_scope $-                                  mkTyVar tyvar_name (typeKind fam_ty)--                     ty'   = mkAppTys (mkTyVarTy tv) leftover_args'-                     env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv-                                  , fe_in_scope = extendInScopeSet in_scope tv }-                 in (env'', ty')-  where-    arity = tyConArity fam_tc-    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv-    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )-                                    splitAt arity fam_args-    -- Apply the substitution before looking up an application in the-    -- environment. See Note [Flattening], wrinkle 1.-    -- NB: substTys short-cuts the common case when the substitution is empty.-    sat_fam_args' = substTys tcv_subst sat_fam_args-    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args-    -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening],-    -- wrinkle 3), so we split it into the arguments needed to saturate it-    -- (sat_fam_args') and the rest (leftover_args')-    fam_ty = mkTyConApp fam_tc sat_fam_args'-    FlattenEnv { fe_type_map = type_map-               , fe_in_scope = in_scope } = env'--mkFlattenFreshTyName :: Uniquable a => a -> Name-mkFlattenFreshTyName unq-  = mkSysTvName (getUnique unq) (fsLit "flt")--mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar-mkFlattenFreshCoVar in_scope kind-  = let uniq = unsafeGetFreshLocalUnique in_scope-        name = mkSystemVarName uniq (fsLit "flc")-    in mkCoVar name kind
compiler/GHC/Core/InstEnv.hs view
@@ -760,6 +760,49 @@ where the 'Nothing' indicates that 'b' can be freely instantiated. (The caller instantiates it to a flexi type variable, which will  presumably later become fixed via functional dependencies.)++Note [Infinitary substitution in lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  class C a b+  instance C c c+  instance C d (Maybe d)+  [W] C e (Maybe e)++You would think we could just use the second instance, because the first doesn't+unify. But that's just ever so slightly wrong. The reason we check for unifiers+along with matchers is that we don't want the possibility that a type variable+instantiation could cause an instance choice to change. Yet if we have+  type family M = Maybe M+and choose (e |-> M), then both instances match. This is absurd, but we cannot+rule it out. Yet, worrying about this case is awfully inconvenient to users,+and so we pretend the problem doesn't exist, by considering a lookup that runs into+this occurs-check issue to indicate that an instance surely does not apply (i.e.+is like the SurelyApart case). In the brief time that we didn't treat infinitary+substitutions specially, two tickets were filed: #19044 and #19052, both trying+to do Real Work.++Why don't we just exclude any instances that are MaybeApart? Because we might+have a [W] C e (F e), where F is a type family. The second instance above does+not match, but it should be included as a future possibility. Unification will+return MaybeApart MARTypeFamily in this case.++What can go wrong with this design choice? We might get incoherence -- but not+loss of type safety. In particular, if we have [W] C M M (for the M type family+above), then GHC might arbitrarily choose either instance, depending on how+M reduces (or doesn't).++For type families, we can't just ignore the problem (as we essentially do here),+because doing so would give us a hole in the type safety proof (as explored in+Section 6 of "Closed Type Families with Overlapping Equations", POPL'14). This+possibility of an infinitary substitution manifests as closed type families that+look like they should reduce, but don't. Users complain: #9082 and #17311. For+open type families, we actually can have unsoundness if we don't take infinitary+substitutions into account: #8162. But, luckily, for class instances, we just+risk coherence -- not great, but it seems better to give users what they likely+want. (Also, note that this problem existed for the entire decade of 201x without+anyone noticing, so it's manifestly not ruining anyone's day.) -}  -- |Look up an instance in the given instance environment. The given class application must match exactly@@ -828,18 +871,24 @@       = find ms us rest        | otherwise-      = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set,+      = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,                  (ppr cls <+> ppr tys <+> ppr all_tvs) $$                  (ppr tpl_tvs <+> ppr tpl_tys)                 )                 -- Unification will break badly if the variables overlap                 -- They shouldn't because we allocate separate uniques for them                 -- See Note [Template tyvars are fresh]-        case tcUnifyTys instanceBindFun tpl_tys tys of-            Just _   -> find ms (item:us) rest-            Nothing  -> find ms us        rest+        case tcUnifyTysFG instanceBindFun tpl_tys tys of+          -- We consider MaybeApart to be a case where the instance might+          -- apply in the future. This covers an instance like C Int and+          -- a target like [W] C (F a), where F is a type family.+            SurelyApart              -> find ms us        rest+              -- Note [Infinitary substitution in lookup]+            MaybeApart MARInfinite _ -> find ms us        rest+            _                        -> find ms (item:us) rest       where         tpl_tv_set = mkVarSet tpl_tvs+        tys_tv_set = tyCoVarsOfTypes tys  --------------- -- This is the common way to call this function.@@ -1023,20 +1072,28 @@ we are careful about multiple matches, as described above in Note [Overlapping instances] -The key_tys can contain skolem constants, and we can guarantee that those+The target tys can contain skolem constants. For existentials and instance variables,+we can guarantee that those are never going to be instantiated to anything, so we should not involve-them in the unification test.  Example:+them in the unification test. These are called "super skolems". Example:         class Foo a where { op :: a -> Int }         instance Foo a => Foo [a]       -- NB overlap         instance Foo [Int]              -- NB overlap         data T = forall a. Foo a => MkT a         f :: T -> Int         f (MkT x) = op [x,x]-The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd-complain, saying that the choice of instance depended on the instantiation-of 'a'; but of course it isn't *going* to be instantiated.+The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and+so it is a super skolem. (See the use of tcInstSuperSkolTyVarsX in+GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to+isOverlappableTyVar, and the use of Skolem in instanceBindFun, above, means+that these will be treated as fresh constants in the unification algorithm+during instance lookup. Without this treatment, GHC would complain, saying+that the choice of instance depended on the instantiation of 'a'; but of+course it isn't *going* to be instantiated. Note that it is necessary that+the unification algorithm returns SurelyApart for these super-skolems+for GHC to be able to commit to another instance. -We do this only for isOverlappableTyVar skolems.  For example we reject+We do this only for super skolems.  For example we reject         g :: forall a => [a] -> Int         g x = op x on the grounds that the correct instance depends on the instantiation of 'a'
compiler/GHC/Core/Lint.hs view
@@ -624,14 +624,6 @@                || exprIsTickedString rhs)            (badBndrTyMsg binder (text "unlifted")) -        -- Check that if the binder is top-level or recursive, it's not-        -- demanded. Primitive string literals are exempt as there is no-        -- computation to perform, see Note [Core top-level string literals].-       ; checkL (not (isStrictId binder)-            || (isNonRec rec_flag && not (isTopLevel top_lvl))-            || exprIsTickedString rhs)-           (mkStrictMsg binder)-         -- Check that if the binder is at the top level and has type Addr#,         -- that it is a string literal, see         -- Note [Core top-level string literals].@@ -3119,13 +3111,6 @@ badBndrTyMsg binder what   = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder          , text "Binder's type:" <+> ppr (idType binder) ]--mkStrictMsg :: Id -> MsgDoc-mkStrictMsg binder-  = vcat [hsep [text "Recursive or top-level binder has strict demand info:",-                     ppr binder],-              hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]-             ]  mkNonTopExportedMsg :: Id -> MsgDoc mkNonTopExportedMsg binder
− compiler/GHC/Core/Map.hs 
@@ -1,837 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--module GHC.Core.Map (-   -- * Maps over Core expressions-   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,-   -- * Maps over 'Type's-   TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,-   LooseTypeMap,-   -- ** With explicit scoping-   CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope,-   mkDeBruijnContext,-   -- * Maps over 'Maybe' values-   MaybeMap,-   -- * Maps over 'List' values-   ListMap,-   -- * Maps over 'Literal's-   LiteralMap,-   -- * Map for compressing leaves. See Note [Compressed TrieMap]-   GenMap,-   -- * 'TrieMap' class-   TrieMap(..), insertTM, deleteTM,-   lkDFreeVar, xtDFreeVar,-   lkDNamed, xtDNamed,-   (>.>), (|>), (|>>),- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Data.TrieMap-import GHC.Core-import GHC.Core.Coercion-import GHC.Types.Name-import GHC.Core.Type-import GHC.Core.TyCo.Rep-import GHC.Types.Var-import GHC.Data.FastString(FastString)--import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic--import qualified Data.Map    as Map-import qualified Data.IntMap as IntMap-import GHC.Types.Unique.FM-import GHC.Types.Var.Env-import GHC.Types.Name.Env-import Control.Monad( (>=>) )--{--This module implements TrieMaps over Core related data structures-like CoreExpr or Type. It is built on the Tries from the TrieMap-module.--The code is very regular and boilerplate-like, but there is-some neat handling of *binders*.  In effect they are deBruijn-numbered on the fly.----}--------------------------- Recall that---   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c---- NB: Be careful about RULES and type families (#5821).  So we should make sure--- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)---- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not--- known when defining GenMap so we can only specialize them here.--{-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}-{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}-{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}---{-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}-{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}-{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}--{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}-{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}-{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}--{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}-{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}-{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}---{--************************************************************************-*                                                                      *-                   CoreMap-*                                                                      *-************************************************************************--}--lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a-lkDNamed n env = lookupDNameEnv env (getName n)--xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a-xtDNamed tc f m = alterDNameEnv f m (getName tc)---{--Note [Binders]-~~~~~~~~~~~~~~- * In general we check binders as late as possible because types are-   less likely to differ than expression structure.  That's why-      cm_lam :: CoreMapG (TypeMapG a)-   rather than-      cm_lam :: TypeMapG (CoreMapG a)-- * We don't need to look at the type of some binders, notably-     - the case binder in (Case _ b _ _)-     - the binders in an alternative-   because they are totally fixed by the context--Note [Empty case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* For a key (Case e b ty (alt:alts))  we don't need to look the return type-  'ty', because every alternative has that type.--* For a key (Case e b ty []) we MUST look at the return type 'ty', because-  otherwise (Case (error () "urk") _ Int  []) would compare equal to-            (Case (error () "urk") _ Bool [])-  which is utterly wrong (#6097)--We could compare the return type regardless, but the wildly common case-is that it's unnecessary, so we have two fields (cm_case and cm_ecase)-for the two possibilities.  Only cm_ecase looks at the type.--See also Note [Empty case alternatives] in GHC.Core.--}---- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this--- is the type you want.-newtype CoreMap a = CoreMap (CoreMapG a)--instance TrieMap CoreMap where-    type Key CoreMap = CoreExpr-    emptyTM = CoreMap emptyTM-    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m-    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)-    foldTM k (CoreMap m) = foldTM k m-    mapTM f (CoreMap m) = CoreMap (mapTM f m)---- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended--- key makes it suitable for recursive traversal, since it can track binders,--- but it is strictly internal to this module.  If you are including a 'CoreMap'--- inside another 'TrieMap', this is the type you want.-type CoreMapG = GenMap CoreMapX---- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without--- the 'GenMap' optimization.-data CoreMapX a-  = CM { cm_var   :: VarMap a-       , cm_lit   :: LiteralMap a-       , cm_co    :: CoercionMapG a-       , cm_type  :: TypeMapG a-       , cm_cast  :: CoreMapG (CoercionMapG a)-       , cm_tick  :: CoreMapG (TickishMap a)-       , cm_app   :: CoreMapG (CoreMapG a)-       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]-       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))-       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))-       , cm_case  :: CoreMapG (ListMap AltMap a)-       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]-     }--instance Eq (DeBruijn CoreExpr) where-  D env1 e1 == D env2 e2 = go e1 e2 where-    go (Var v1) (Var v2)-      = case (lookupCME env1 v1, lookupCME env2 v2) of-                            (Just b1, Just b2) -> b1 == b2-                            (Nothing, Nothing) -> v1 == v2-                            _ -> False-    go (Lit lit1)    (Lit lit2)      = lit1 == lit2-    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2-    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2-    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2-    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2-    -- This seems a bit dodgy, see 'eqTickish'-    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2--    go (Lam b1 e1)  (Lam b2 e2)-      =  D env1 (varType b1) == D env2 (varType b2)-      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)-      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2--    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)-      =  go r1 r2-      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2--    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)-      = equalLength ps1 ps2-      && D env1' rs1 == D env2' rs2-      && D env1' e1  == D env2' e2-      where-        (bs1,rs1) = unzip ps1-        (bs2,rs2) = unzip ps2-        env1' = extendCMEs env1 bs1-        env2' = extendCMEs env2 bs2--    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)-      | null a1   -- See Note [Empty case alternatives]-      = null a2 && go e1 e2 && D env1 t1 == D env2 t2-      | otherwise-      =  go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2--    go _ _ = False--emptyE :: CoreMapX a-emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM-            , cm_co = emptyTM, cm_type = emptyTM-            , cm_cast = emptyTM, cm_app = emptyTM-            , cm_lam = emptyTM, cm_letn = emptyTM-            , cm_letr = emptyTM, cm_case = emptyTM-            , cm_ecase = emptyTM, cm_tick = emptyTM }--instance TrieMap CoreMapX where-   type Key CoreMapX = DeBruijn CoreExpr-   emptyTM  = emptyE-   lookupTM = lkE-   alterTM  = xtE-   foldTM   = fdE-   mapTM    = mapE-----------------------------mapE :: (a->b) -> CoreMapX a -> CoreMapX b-mapE f (CM { cm_var = cvar, cm_lit = clit-           , cm_co = cco, cm_type = ctype-           , cm_cast = ccast , cm_app = capp-           , cm_lam = clam, cm_letn = cletn-           , cm_letr = cletr, cm_case = ccase-           , cm_ecase = cecase, cm_tick = ctick })-  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit-       , cm_co = mapTM f cco, cm_type = mapTM f ctype-       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp-       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn-       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase-       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }-----------------------------lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a-lookupCoreMap cm e = lookupTM e cm--extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a-extendCoreMap m e v = alterTM e (\_ -> Just v) m--foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b-foldCoreMap k z m = foldTM k m z--emptyCoreMap :: CoreMap a-emptyCoreMap = emptyTM--instance Outputable a => Outputable (CoreMap a) where-  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])----------------------------fdE :: (a -> b -> b) -> CoreMapX a -> b -> b-fdE k m-  = foldTM k (cm_var m)-  . foldTM k (cm_lit m)-  . foldTM k (cm_co m)-  . foldTM k (cm_type m)-  . foldTM (foldTM k) (cm_cast m)-  . foldTM (foldTM k) (cm_tick m)-  . foldTM (foldTM k) (cm_app m)-  . foldTM (foldTM k) (cm_lam m)-  . foldTM (foldTM (foldTM k)) (cm_letn m)-  . foldTM (foldTM (foldTM k)) (cm_letr m)-  . foldTM (foldTM k) (cm_case m)-  . foldTM (foldTM k) (cm_ecase m)---- lkE: lookup in trie for expressions-lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a-lkE (D env expr) cm = go expr cm-  where-    go (Var v)              = cm_var  >.> lkVar env v-    go (Lit l)              = cm_lit  >.> lookupTM l-    go (Type t)             = cm_type >.> lkG (D env t)-    go (Coercion c)         = cm_co   >.> lkG (D env c)-    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)-    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish-    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)-    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)-                              >=> lkBndr env v-    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)-                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b-    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs-                                  env1 = extendCMEs env bndrs-                              in cm_letr-                                 >.> lkList (lkG . D env1) rhss-                                 >=> lkG (D env1 e)-                                 >=> lkList (lkBndr env1) bndrs-    go (Case e b ty as)     -- See Note [Empty case alternatives]-               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)-               | otherwise  = cm_case >.> lkG (D env e)-                              >=> lkList (lkA (extendCME env b)) as--xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a-xtE (D env (Var v))              f m = m { cm_var  = cm_var m-                                                 |> xtVar env v f }-xtE (D env (Type t))             f m = m { cm_type = cm_type m-                                                 |> xtG (D env t) f }-xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m-                                                 |> xtG (D env c) f }-xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }-xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)-                                                 |>> xtG (D env c) f }-xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)-                                                 |>> xtTickish t f }-xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)-                                                 |>> xtG (D env e1) f }-xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m-                                                 |> xtG (D (extendCME env v) e)-                                                 |>> xtBndr env v f }-xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m-                                                 |> xtG (D (extendCME env b) e)-                                                 |>> xtG (D env r)-                                                 |>> xtBndr env b f }-xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =-                                              let (bndrs,rhss) = unzip prs-                                                  env1 = extendCMEs env bndrs-                                              in cm_letr m-                                                 |>  xtList (xtG . D env1) rhss-                                                 |>> xtG (D env1 e)-                                                 |>> xtList (xtBndr env1)-                                                            bndrs f }-xtE (D env (Case e b ty as))     f m-                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)-                                                 |>> xtG (D env ty) f }-                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)-                                                 |>> let env1 = extendCME env b-                                                     in xtList (xtA env1) as f }---- TODO: this seems a bit dodgy, see 'eqTickish'-type TickishMap a = Map.Map (Tickish Id) a-lkTickish :: Tickish Id -> TickishMap a -> Maybe a-lkTickish = lookupTM--xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a-xtTickish = alterTM---------------------------data AltMap a   -- A single alternative-  = AM { am_deflt :: CoreMapG a-       , am_data  :: DNameEnv (CoreMapG a)-       , am_lit   :: LiteralMap (CoreMapG a) }--instance TrieMap AltMap where-   type Key AltMap = CoreAlt-   emptyTM  = AM { am_deflt = emptyTM-                 , am_data = emptyDNameEnv-                 , am_lit  = emptyTM }-   lookupTM = lkA emptyCME-   alterTM  = xtA emptyCME-   foldTM   = fdA-   mapTM    = mapA--instance Eq (DeBruijn CoreAlt) where-  D env1 a1 == D env2 a2 = go a1 a2 where-    go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2)-        = D env1 rhs1 == D env2 rhs2-    go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2)-        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2-    go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2)-        = dc1 == dc2 &&-          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2-    go _ _ = False--mapA :: (a->b) -> AltMap a -> AltMap b-mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })-  = AM { am_deflt = mapTM f adeflt-       , am_data = mapTM (mapTM f) adata-       , am_lit = mapTM (mapTM f) alit }--lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a-lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)-lkA env (LitAlt lit, _, rhs)  = am_lit >.> lookupTM lit >=> lkG (D env rhs)-lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc-                                        >=> lkG (D (extendCMEs env bs) rhs)--xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a-xtA env (DEFAULT, _, rhs)    f m =-    m { am_deflt = am_deflt m |> xtG (D env rhs) f }-xtA env (LitAlt l, _, rhs)   f m =-    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }-xtA env (DataAlt d, bs, rhs) f m =-    m { am_data  = am_data m  |> xtDNamed d-                             |>> xtG (D (extendCMEs env bs) rhs) f }--fdA :: (a -> b -> b) -> AltMap a -> b -> b-fdA k m = foldTM k (am_deflt m)-        . foldTM (foldTM k) (am_data m)-        . foldTM (foldTM k) (am_lit m)--{--************************************************************************-*                                                                      *-                   Coercions-*                                                                      *-************************************************************************--}---- We should really never care about the contents of a coercion. Instead,--- just look up the coercion's type.-newtype CoercionMap a = CoercionMap (CoercionMapG a)--instance TrieMap CoercionMap where-   type Key CoercionMap = Coercion-   emptyTM                     = CoercionMap emptyTM-   lookupTM k  (CoercionMap m) = lookupTM (deBruijnize k) m-   alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)-   foldTM k    (CoercionMap m) = foldTM k m-   mapTM f     (CoercionMap m) = CoercionMap (mapTM f m)--type CoercionMapG = GenMap CoercionMapX-newtype CoercionMapX a = CoercionMapX (TypeMapX a)--instance TrieMap CoercionMapX where-  type Key CoercionMapX = DeBruijn Coercion-  emptyTM = CoercionMapX emptyTM-  lookupTM = lkC-  alterTM  = xtC-  foldTM f (CoercionMapX core_tm) = foldTM f core_tm-  mapTM f (CoercionMapX core_tm)  = CoercionMapX (mapTM f core_tm)--instance Eq (DeBruijn Coercion) where-  D env1 co1 == D env2 co2-    = D env1 (coercionType co1) ==-      D env2 (coercionType co2)--lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a-lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co)-                                        core_tm--xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a-xtC (D env co) f (CoercionMapX m)-  = CoercionMapX (xtT (D env $ coercionType co) f m)--{--************************************************************************-*                                                                      *-                   Types-*                                                                      *-************************************************************************--}---- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@.  The extended--- key makes it suitable for recursive traversal, since it can track binders,--- but it is strictly internal to this module.  If you are including a 'TypeMap'--- inside another 'TrieMap', this is the type you want. Note that this--- lookup does not do a kind-check. Thus, all keys in this map must have--- the same kind. Also note that this map respects the distinction between--- @Type@ and @Constraint@, despite the fact that they are equivalent type--- synonyms in Core.-type TypeMapG = GenMap TypeMapX---- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the--- 'GenMap' optimization.-data TypeMapX a-  = TM { tm_var    :: VarMap a-       , tm_app    :: TypeMapG (TypeMapG a)-       , tm_tycon  :: DNameEnv a-       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders]-       , tm_tylit  :: TyLitMap a-       , tm_coerce :: Maybe a-       }-    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type---- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the--- last one? See Note [Equality on AppTys] in "GHC.Core.Type"------ Note, however, that we keep Constraint and Type apart here, despite the fact--- that they are both synonyms of TYPE 'LiftedRep (see #11715).-trieMapView :: Type -> Maybe Type-trieMapView ty-  -- First check for TyConApps that need to be expanded to-  -- AppTy chains.-  | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty-  = Just $ foldl' AppTy (TyConApp tc []) tys--  -- Then resolve any remaining nullary synonyms.-  | Just ty' <- tcView ty = Just ty'-trieMapView _ = Nothing--instance TrieMap TypeMapX where-   type Key TypeMapX = DeBruijn Type-   emptyTM  = emptyT-   lookupTM = lkT-   alterTM  = xtT-   foldTM   = fdT-   mapTM    = mapT--instance Eq (DeBruijn Type) where-  env_t@(D env t) == env_t'@(D env' t')-    | Just new_t  <- tcView t  = D env new_t == env_t'-    | Just new_t' <- tcView t' = env_t       == D env' new_t'-    | otherwise-    = case (t, t') of-        (CastTy t1 _, _)  -> D env t1 == D env t'-        (_, CastTy t1' _) -> D env t  == D env t1'--        (TyVarTy v, TyVarTy v')-            -> case (lookupCME env v, lookupCME env' v') of-                (Just bv, Just bv') -> bv == bv'-                (Nothing, Nothing)  -> v == v'-                _ -> False-                -- See Note [Equality on AppTys] in GHC.Core.Type-        (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s-            -> D env t1 == D env' t1' && D env t2 == D env' t2'-        (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s-            -> D env t1 == D env' t1' && D env t2 == D env' t2'-        (FunTy _ w1 t1 t2, FunTy _ w1' t1' t2')-            -> D env w1 == D env w1' && D env t1 == D env' t1' && D env t2 == D env' t2'-        (TyConApp tc tys, TyConApp tc' tys')-            -> tc == tc' && D env tys == D env' tys'-        (LitTy l, LitTy l')-            -> l == l'-        (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty')-            -> D env (varType tv)      == D env' (varType tv') &&-               D (extendCME env tv) ty == D (extendCME env' tv') ty'-        (CoercionTy {}, CoercionTy {})-            -> True-        _ -> False--instance {-# OVERLAPPING #-}-         Outputable a => Outputable (TypeMapG a) where-  ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m [])--emptyT :: TypeMapX a-emptyT = TM { tm_var  = emptyTM-            , tm_app  = emptyTM-            , tm_tycon  = emptyDNameEnv-            , tm_forall = emptyTM-            , tm_tylit  = emptyTyLitMap-            , tm_coerce = Nothing }--mapT :: (a->b) -> TypeMapX a -> TypeMapX b-mapT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon-           , tm_forall = tforall, tm_tylit = tlit-           , tm_coerce = tcoerce })-  = TM { tm_var    = mapTM f tvar-       , tm_app    = mapTM (mapTM f) tapp-       , tm_tycon  = mapTM f ttycon-       , tm_forall = mapTM (mapTM f) tforall-       , tm_tylit  = mapTM f tlit-       , tm_coerce = fmap f tcoerce }--------------------lkT :: DeBruijn Type -> TypeMapX a -> Maybe a-lkT (D env ty) m = go ty m-  where-    go ty | Just ty' <- trieMapView ty = go ty'-    go (TyVarTy v)                 = tm_var    >.> lkVar env v-    go (AppTy t1 t2)               = tm_app    >.> lkG (D env t1)-                                               >=> lkG (D env t2)-    go (TyConApp tc [])            = tm_tycon  >.> lkDNamed tc-    go ty@(TyConApp _ (_:_))       = pprPanic "lkT TyConApp" (ppr ty)-    go (LitTy l)                   = tm_tylit  >.> lkTyLit l-    go (ForAllTy (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)-                                               >=> lkBndr env tv-    go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)-    go (CastTy t _)                = go t-    go (CoercionTy {})             = tm_coerce--------------------xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a-xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m--xtT (D env (TyVarTy v))       f m = m { tm_var    = tm_var m |> xtVar env v f }-xtT (D env (AppTy t1 t2))     f m = m { tm_app    = tm_app m |> xtG (D env t1)-                                                            |>> xtG (D env t2) f }-xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f }-xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }-xtT (D env (CastTy t _))      f m = xtT (D env t) f m-xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }-xtT (D env (ForAllTy (Bndr tv _) ty))  f m-  = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)-                                |>> xtBndr env tv f }-xtT (D _   ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)-xtT (D _   ty@(FunTy {}))         _ _ = pprPanic "xtT FunTy" (ppr ty)--fdT :: (a -> b -> b) -> TypeMapX a -> b -> b-fdT k m = foldTM k (tm_var m)-        . foldTM (foldTM k) (tm_app m)-        . foldTM k (tm_tycon m)-        . foldTM (foldTM k) (tm_forall m)-        . foldTyLit k (tm_tylit m)-        . foldMaybe k (tm_coerce m)---------------------------data TyLitMap a = TLM { tlm_number :: Map.Map Integer a-                      , tlm_string :: UniqFM  FastString a-                      }--instance TrieMap TyLitMap where-   type Key TyLitMap = TyLit-   emptyTM  = emptyTyLitMap-   lookupTM = lkTyLit-   alterTM  = xtTyLit-   foldTM   = foldTyLit-   mapTM    = mapTyLit--emptyTyLitMap :: TyLitMap a-emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM }--mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b-mapTyLit f (TLM { tlm_number = tn, tlm_string = ts })-  = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts }--lkTyLit :: TyLit -> TyLitMap a -> Maybe a-lkTyLit l =-  case l of-    NumTyLit n -> tlm_number >.> Map.lookup n-    StrTyLit n -> tlm_string >.> (`lookupUFM` n)--xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a-xtTyLit l f m =-  case l of-    NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) }-    StrTyLit n -> m { tlm_string = alterUFM  f (tlm_string m) n }--foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b-foldTyLit l m = flip (foldUFM l) (tlm_string m)-              . flip (Map.foldr l)   (tlm_number m)------------------------------------------------------ | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this--- is the type you want. The keys in this map may have different kinds.-newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))--lkTT :: DeBruijn Type -> TypeMap a -> Maybe a-lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m-                          >>= lkG (D env ty)--xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a-xtTT (D env ty) f (TypeMap m)-  = TypeMap (m |> xtG (D env $ typeKind ty)-               |>> xtG (D env ty) f)---- Below are some client-oriented functions which operate on 'TypeMap'.--instance TrieMap TypeMap where-    type Key TypeMap = Type-    emptyTM = TypeMap emptyTM-    lookupTM k m = lkTT (deBruijnize k) m-    alterTM k f m = xtTT (deBruijnize k) f m-    foldTM k (TypeMap m) = foldTM (foldTM k) m-    mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)--foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b-foldTypeMap k z m = foldTM k m z--emptyTypeMap :: TypeMap a-emptyTypeMap = emptyTM--lookupTypeMap :: TypeMap a -> Type -> Maybe a-lookupTypeMap cm t = lookupTM t cm--extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a-extendTypeMap m t v = alterTM t (const (Just v)) m--lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a-lookupTypeMapWithScope m cm t = lkTT (D cm t) m---- | Extend a 'TypeMap' with a type in the given context.--- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to--- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over--- multiple insertions.-extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a-extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m---- | Construct a deBruijn environment with the given variables in scope.--- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@-mkDeBruijnContext :: [Var] -> CmEnv-mkDeBruijnContext = extendCMEs emptyCME---- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),--- you'll find entries inserted under (t), even if (g) is non-reflexive.-newtype LooseTypeMap a-  = LooseTypeMap (TypeMapG a)--instance TrieMap LooseTypeMap where-  type Key LooseTypeMap = Type-  emptyTM = LooseTypeMap emptyTM-  lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m-  alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)-  foldTM f (LooseTypeMap m) = foldTM f m-  mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)--{--************************************************************************-*                                                                      *-                   Variables-*                                                                      *-************************************************************************--}--type BoundVar = Int  -- Bound variables are deBruijn numbered-type BoundVarMap a = IntMap.IntMap a--data CmEnv = CME { cme_next :: !BoundVar-                 , cme_env  :: VarEnv BoundVar }--emptyCME :: CmEnv-emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv }--extendCME :: CmEnv -> Var -> CmEnv-extendCME (CME { cme_next = bv, cme_env = env }) v-  = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }--extendCMEs :: CmEnv -> [Var] -> CmEnv-extendCMEs env vs = foldl' extendCME env vs--lookupCME :: CmEnv -> Var -> Maybe BoundVar-lookupCME (CME { cme_env = env }) v = lookupVarEnv env v---- | @DeBruijn a@ represents @a@ modulo alpha-renaming.  This is achieved--- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn--- numbering.  This allows us to define an 'Eq' instance for @DeBruijn a@, even--- if this was not (easily) possible for @a@.  Note: we purposely don't--- export the constructor.  Make a helper function if you find yourself--- needing it.-data DeBruijn a = D CmEnv a---- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no--- bound binders (an empty 'CmEnv').  This is usually what you want if there--- isn't already a 'CmEnv' in scope.-deBruijnize :: a -> DeBruijn a-deBruijnize = D emptyCME--instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where-    D _   []     == D _    []       = True-    D env (x:xs) == D env' (x':xs') = D env x  == D env' x' &&-                                      D env xs == D env' xs'-    _            == _               = False--instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where-    D _   Nothing  == D _    Nothing   = True-    D env (Just x) == D env' (Just x') = D env x  == D env' x'-    _              == _                = False----------- Variable binders ----------------- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between--- binding forms whose binders have different types.  For example,--- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should--- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@:--- we can disambiguate this by matching on the type (or kind, if this--- a binder in a type) of the binder.------ We also need to do the same for multiplicity! Which, since multiplicities are--- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries--- of pairs are composition.-data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))--instance TrieMap BndrMap where-   type Key BndrMap = Var-   emptyTM  = BndrMap emptyTM-   lookupTM = lkBndr emptyCME-   alterTM  = xtBndr emptyCME-   foldTM   = fdBndrMap-   mapTM    = mapBndrMap--mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b-mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)--fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b-fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm----- Note [Binders]--- ~~~~~~~~~~~~~~--- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all--- of these data types have binding forms.--lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a-lkBndr env v (BndrMap tymap) = do-  multmap <- lkG (D env (varType v)) tymap-  lookupTM (D env <$> varMultMaybe v) multmap---xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a-xtBndr env v xt (BndrMap tymap)  =-  BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))------------ Variable occurrence --------------data VarMap a = VM { vm_bvar   :: BoundVarMap a  -- Bound variable-                   , vm_fvar   :: DVarEnv a }      -- Free variable--instance TrieMap VarMap where-   type Key VarMap = Var-   emptyTM  = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }-   lookupTM = lkVar emptyCME-   alterTM  = xtVar emptyCME-   foldTM   = fdVar-   mapTM    = mapVar--mapVar :: (a->b) -> VarMap a -> VarMap b-mapVar f (VM { vm_bvar = bv, vm_fvar = fv })-  = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv }--lkVar :: CmEnv -> Var -> VarMap a -> Maybe a-lkVar env v-  | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv-  | otherwise                  = vm_fvar >.> lkDFreeVar v--xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a-xtVar env v f m-  | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f }-  | otherwise                  = m { vm_fvar = vm_fvar m |> xtDFreeVar v f }--fdVar :: (a -> b -> b) -> VarMap a -> b -> b-fdVar k m = foldTM k (vm_bvar m)-          . foldTM k (vm_fvar m)--lkDFreeVar :: Var -> DVarEnv a -> Maybe a-lkDFreeVar var env = lookupDVarEnv env var--xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a-xtDFreeVar v f m = alterDVarEnv f m v
+ compiler/GHC/Core/Map/Type.hs view
@@ -0,0 +1,558 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module GHC.Core.Map.Type (+     -- * Re-export generic interface+   TrieMap(..),++     -- * Maps over 'Type's+   TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,+   LooseTypeMap,+   -- ** With explicit scoping+   CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope,+   mkDeBruijnContext, extendCME, extendCMEs, emptyCME,++   -- * Utilities for use by friends only+   TypeMapG, CoercionMapG,++   DeBruijn(..), deBruijnize,++   BndrMap, xtBndr, lkBndr,+   VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar,++   xtDNamed, lkDNamed++   ) where++-- This module is separate from GHC.Core.Map.Expr to avoid a module loop+-- between GHC.Core.Unify (which depends on this module) and GHC.Core++import GHC.Prelude++import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.TyCo.Rep+import GHC.Data.TrieMap++import GHC.Data.FastString+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Unique.FM+import GHC.Utils.Outputable++import GHC.Data.Maybe+import GHC.Utils.Panic++import qualified Data.Map    as Map+import qualified Data.IntMap as IntMap++import Control.Monad ( (>=>) )++-- NB: Be careful about RULES and type families (#5821).  So we should make sure+-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)++{-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}+{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}++{-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}+{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}++{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}++{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}++{-+************************************************************************+*                                                                      *+                   Coercions+*                                                                      *+************************************************************************+-}++-- We should really never care about the contents of a coercion. Instead,+-- just look up the coercion's type.+newtype CoercionMap a = CoercionMap (CoercionMapG a)++instance TrieMap CoercionMap where+   type Key CoercionMap = Coercion+   emptyTM                     = CoercionMap emptyTM+   lookupTM k  (CoercionMap m) = lookupTM (deBruijnize k) m+   alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)+   foldTM k    (CoercionMap m) = foldTM k m+   mapTM f     (CoercionMap m) = CoercionMap (mapTM f m)+   filterTM f  (CoercionMap m) = CoercionMap (filterTM f m)++type CoercionMapG = GenMap CoercionMapX+newtype CoercionMapX a = CoercionMapX (TypeMapX a)++instance TrieMap CoercionMapX where+  type Key CoercionMapX = DeBruijn Coercion+  emptyTM = CoercionMapX emptyTM+  lookupTM = lkC+  alterTM  = xtC+  foldTM f (CoercionMapX core_tm) = foldTM f core_tm+  mapTM f (CoercionMapX core_tm)  = CoercionMapX (mapTM f core_tm)+  filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)++instance Eq (DeBruijn Coercion) where+  D env1 co1 == D env2 co2+    = D env1 (coercionType co1) ==+      D env2 (coercionType co2)++lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a+lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co)+                                        core_tm++xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a+xtC (D env co) f (CoercionMapX m)+  = CoercionMapX (xtT (D env $ coercionType co) f m)++{-+************************************************************************+*                                                                      *+                   Types+*                                                                      *+************************************************************************+-}++-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'TypeMap'+-- inside another 'TrieMap', this is the type you want. Note that this+-- lookup does not do a kind-check. Thus, all keys in this map must have+-- the same kind. Also note that this map respects the distinction between+-- @Type@ and @Constraint@, despite the fact that they are equivalent type+-- synonyms in Core.+type TypeMapG = GenMap TypeMapX++-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the+-- 'GenMap' optimization.+data TypeMapX a+  = TM { tm_var    :: VarMap a+       , tm_app    :: TypeMapG (TypeMapG a)+       , tm_tycon  :: DNameEnv a++         -- only InvisArg arrows here+       , tm_funty  :: TypeMapG (TypeMapG (TypeMapG a))+                       -- keyed on the argument, result rep, and result+                       -- constraints are never linear-restricted and are always lifted++       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr+       , tm_tylit  :: TyLitMap a+       , tm_coerce :: Maybe a+       }+    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type++-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the+-- last one? See Note [Equality on AppTys] in GHC.Core.Type+--+-- Note, however, that we keep Constraint and Type apart here, despite the fact+-- that they are both synonyms of TYPE 'LiftedRep (see #11715).+--+-- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a).+trieMapView :: Type -> Maybe Type+trieMapView ty+  -- First check for TyConApps that need to be expanded to+  -- AppTy chains.+  | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty+  = Just $ foldl' AppTy (TyConApp tc []) tys++  -- Then resolve any remaining nullary synonyms.+  | Just ty' <- tcView ty = Just ty'+trieMapView _ = Nothing++instance TrieMap TypeMapX where+   type Key TypeMapX = DeBruijn Type+   emptyTM  = emptyT+   lookupTM = lkT+   alterTM  = xtT+   foldTM   = fdT+   mapTM    = mapT+   filterTM = filterT++instance Eq (DeBruijn Type) where+  env_t@(D env t) == env_t'@(D env' t')+    | Just new_t  <- tcView t  = D env new_t == env_t'+    | Just new_t' <- tcView t' = env_t       == D env' new_t'+    | otherwise+    = case (t, t') of+        (CastTy t1 _, _)  -> D env t1 == D env t'+        (_, CastTy t1' _) -> D env t  == D env t1'++        (TyVarTy v, TyVarTy v')+            -> case (lookupCME env v, lookupCME env' v') of+                (Just bv, Just bv') -> bv == bv'+                (Nothing, Nothing)  -> v == v'+                _ -> False+                -- See Note [Equality on AppTys] in GHC.Core.Type+        (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s+            -> D env t1 == D env' t1' && D env t2 == D env' t2'+        (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s+            -> D env t1 == D env' t1' && D env t2 == D env' t2'+        (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2')+            -> v1 == v1' &&+               D env w1 == D env w1' &&+               D env t1 == D env' t1' &&+               D env t2 == D env' t2'+        (TyConApp tc tys, TyConApp tc' tys')+            -> tc == tc' && D env tys == D env' tys'+        (LitTy l, LitTy l')+            -> l == l'+        (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty')+            -> D env (varType tv)      == D env' (varType tv') &&+               D (extendCME env tv) ty == D (extendCME env' tv') ty'+        (CoercionTy {}, CoercionTy {})+            -> True+        _ -> False++instance {-# OVERLAPPING #-}+         Outputable a => Outputable (TypeMapG a) where+  ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m [])++emptyT :: TypeMapX a+emptyT = TM { tm_var  = emptyTM+            , tm_app  = emptyTM+            , tm_tycon  = emptyDNameEnv+            , tm_funty  = emptyTM+            , tm_forall = emptyTM+            , tm_tylit  = emptyTyLitMap+            , tm_coerce = Nothing }++mapT :: (a->b) -> TypeMapX a -> TypeMapX b+mapT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+           , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit+           , tm_coerce = tcoerce })+  = TM { tm_var    = mapTM f tvar+       , tm_app    = mapTM (mapTM f) tapp+       , tm_tycon  = mapTM f ttycon+       , tm_funty  = mapTM (mapTM (mapTM f)) tfunty+       , tm_forall = mapTM (mapTM f) tforall+       , tm_tylit  = mapTM f tlit+       , tm_coerce = fmap f tcoerce }++-----------------+lkT :: DeBruijn Type -> TypeMapX a -> Maybe a+lkT (D env ty) m = go ty m+  where+    go ty | Just ty' <- trieMapView ty = go ty'+    go (TyVarTy v)                 = tm_var    >.> lkVar env v+    go (AppTy t1 t2)               = tm_app    >.> lkG (D env t1)+                                               >=> lkG (D env t2)+    go (TyConApp tc [])            = tm_tycon  >.> lkDNamed tc+    go ty@(TyConApp _ (_:_))       = pprPanic "lkT TyConApp" (ppr ty)+    go (LitTy l)                   = tm_tylit  >.> lkTyLit l+    go (ForAllTy (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)+                                               >=> lkBndr env tv+    go (FunTy InvisArg _ arg res)+      | Just res_rep <- getRuntimeRep_maybe res+                                   = tm_funty >.> lkG (D env arg)+                                              >=> lkG (D env res_rep)+                                              >=> lkG (D env res)+    go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)+    go (CastTy t _)                = go t+    go (CoercionTy {})             = tm_coerce++-----------------+xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a+xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m++xtT (D env (TyVarTy v))       f m = m { tm_var    = tm_var m |> xtVar env v f }+xtT (D env (AppTy t1 t2))     f m = m { tm_app    = tm_app m |> xtG (D env t1)+                                                            |>> xtG (D env t2) f }+xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f }+xtT (D env (FunTy InvisArg _ t1 t2)) f m = m { tm_funty = tm_funty m |> xtG (D env t1)+                                                                    |>> xtG (D env t2_rep)+                                                                    |>> xtG (D env t2) f }+  where t2_rep = expectJust "xtT FunTy InvisArg" (getRuntimeRep_maybe t2)+xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }+xtT (D env (CastTy t _))      f m = xtT (D env t) f m+xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }+xtT (D env (ForAllTy (Bndr tv _) ty))  f m+  = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)+                                |>> xtBndr env tv f }+xtT (D _   ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)+xtT (D _   ty@(FunTy {}))         _ _ = pprPanic "xtT FunTy" (ppr ty)++fdT :: (a -> b -> b) -> TypeMapX a -> b -> b+fdT k m = foldTM k (tm_var m)+        . foldTM (foldTM k) (tm_app m)+        . foldTM k (tm_tycon m)+        . foldTM (foldTM (foldTM k)) (tm_funty m)+        . foldTM (foldTM k) (tm_forall m)+        . foldTyLit k (tm_tylit m)+        . foldMaybe k (tm_coerce m)++filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a+filterT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+              , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit+              , tm_coerce = tcoerce })+  = TM { tm_var    = filterTM f tvar+       , tm_app    = mapTM (filterTM f) tapp+       , tm_tycon  = filterTM f ttycon+       , tm_funty  = mapTM (mapTM (filterTM f)) tfunty+       , tm_forall = mapTM (filterTM f) tforall+       , tm_tylit  = filterTM f tlit+       , tm_coerce = filterMaybe f tcoerce }++------------------------+data TyLitMap a = TLM { tlm_number :: Map.Map Integer a+                      , tlm_string :: UniqFM  FastString a+                      }++instance TrieMap TyLitMap where+   type Key TyLitMap = TyLit+   emptyTM  = emptyTyLitMap+   lookupTM = lkTyLit+   alterTM  = xtTyLit+   foldTM   = foldTyLit+   mapTM    = mapTyLit+   filterTM = filterTyLit++emptyTyLitMap :: TyLitMap a+emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM }++mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b+mapTyLit f (TLM { tlm_number = tn, tlm_string = ts })+  = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts }++lkTyLit :: TyLit -> TyLitMap a -> Maybe a+lkTyLit l =+  case l of+    NumTyLit n -> tlm_number >.> Map.lookup n+    StrTyLit n -> tlm_string >.> (`lookupUFM` n)++xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a+xtTyLit l f m =+  case l of+    NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) }+    StrTyLit n -> m { tlm_string = alterUFM  f (tlm_string m) n }++foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b+foldTyLit l m = flip (foldUFM l) (tlm_string m)+              . flip (Map.foldr l)   (tlm_number m)++filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a+filterTyLit f (TLM { tlm_number = tn, tlm_string = ts })+  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts }++-------------------------------------------------+-- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this+-- is the type you want. The keys in this map may have different kinds.+newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))++lkTT :: DeBruijn Type -> TypeMap a -> Maybe a+lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m+                          >>= lkG (D env ty)++xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a+xtTT (D env ty) f (TypeMap m)+  = TypeMap (m |> xtG (D env $ typeKind ty)+               |>> xtG (D env ty) f)++-- Below are some client-oriented functions which operate on 'TypeMap'.++instance TrieMap TypeMap where+    type Key TypeMap = Type+    emptyTM = TypeMap emptyTM+    lookupTM k m = lkTT (deBruijnize k) m+    alterTM k f m = xtTT (deBruijnize k) f m+    foldTM k (TypeMap m) = foldTM (foldTM k) m+    mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)+    filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m)++foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b+foldTypeMap k z m = foldTM k m z++emptyTypeMap :: TypeMap a+emptyTypeMap = emptyTM++lookupTypeMap :: TypeMap a -> Type -> Maybe a+lookupTypeMap cm t = lookupTM t cm++extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a+extendTypeMap m t v = alterTM t (const (Just v)) m++lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a+lookupTypeMapWithScope m cm t = lkTT (D cm t) m++-- | Extend a 'TypeMap' with a type in the given context.+-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to+-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over+-- multiple insertions.+extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a+extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m++-- | Construct a deBruijn environment with the given variables in scope.+-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@+mkDeBruijnContext :: [Var] -> CmEnv+mkDeBruijnContext = extendCMEs emptyCME++-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),+-- you'll find entries inserted under (t), even if (g) is non-reflexive.+newtype LooseTypeMap a+  = LooseTypeMap (TypeMapG a)++instance TrieMap LooseTypeMap where+  type Key LooseTypeMap = Type+  emptyTM = LooseTypeMap emptyTM+  lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m+  alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)+  foldTM f (LooseTypeMap m) = foldTM f m+  mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)+  filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)++{-+************************************************************************+*                                                                      *+                   Variables+*                                                                      *+************************************************************************+-}++type BoundVar = Int  -- Bound variables are deBruijn numbered+type BoundVarMap a = IntMap.IntMap a++data CmEnv = CME { cme_next :: !BoundVar+                 , cme_env  :: VarEnv BoundVar }++emptyCME :: CmEnv+emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv }++extendCME :: CmEnv -> Var -> CmEnv+extendCME (CME { cme_next = bv, cme_env = env }) v+  = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }++extendCMEs :: CmEnv -> [Var] -> CmEnv+extendCMEs env vs = foldl' extendCME env vs++lookupCME :: CmEnv -> Var -> Maybe BoundVar+lookupCME (CME { cme_env = env }) v = lookupVarEnv env v++-- | @DeBruijn a@ represents @a@ modulo alpha-renaming.  This is achieved+-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn+-- numbering.  This allows us to define an 'Eq' instance for @DeBruijn a@, even+-- if this was not (easily) possible for @a@.  Note: we purposely don't+-- export the constructor.  Make a helper function if you find yourself+-- needing it.+data DeBruijn a = D CmEnv a++-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no+-- bound binders (an empty 'CmEnv').  This is usually what you want if there+-- isn't already a 'CmEnv' in scope.+deBruijnize :: a -> DeBruijn a+deBruijnize = D emptyCME++instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where+    D _   []     == D _    []       = True+    D env (x:xs) == D env' (x':xs') = D env x  == D env' x' &&+                                      D env xs == D env' xs'+    _            == _               = False++instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where+    D _   Nothing  == D _    Nothing   = True+    D env (Just x) == D env' (Just x') = D env x  == D env' x'+    _              == _                = False++--------- Variable binders -------------++-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between+-- binding forms whose binders have different types.  For example,+-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should+-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@:+-- we can disambiguate this by matching on the type (or kind, if this+-- a binder in a type) of the binder.+--+-- We also need to do the same for multiplicity! Which, since multiplicities are+-- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries+-- of pairs are composition.+data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))++instance TrieMap BndrMap where+   type Key BndrMap = Var+   emptyTM  = BndrMap emptyTM+   lookupTM = lkBndr emptyCME+   alterTM  = xtBndr emptyCME+   foldTM   = fdBndrMap+   mapTM    = mapBndrMap+   filterTM = ftBndrMap++mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b+mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)++fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b+fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm+++-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all+-- of these data types have binding forms.++lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a+lkBndr env v (BndrMap tymap) = do+  multmap <- lkG (D env (varType v)) tymap+  lookupTM (D env <$> varMultMaybe v) multmap+++xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a+xtBndr env v xt (BndrMap tymap)  =+  BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))++ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a+ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm)++--------- Variable occurrence -------------+data VarMap a = VM { vm_bvar   :: BoundVarMap a  -- Bound variable+                   , vm_fvar   :: DVarEnv a }      -- Free variable++instance TrieMap VarMap where+   type Key VarMap = Var+   emptyTM  = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }+   lookupTM = lkVar emptyCME+   alterTM  = xtVar emptyCME+   foldTM   = fdVar+   mapTM    = mapVar+   filterTM = ftVar++mapVar :: (a->b) -> VarMap a -> VarMap b+mapVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv }++lkVar :: CmEnv -> Var -> VarMap a -> Maybe a+lkVar env v+  | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv+  | otherwise                  = vm_fvar >.> lkDFreeVar v++xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a+xtVar env v f m+  | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f }+  | otherwise                  = m { vm_fvar = vm_fvar m |> xtDFreeVar v f }++fdVar :: (a -> b -> b) -> VarMap a -> b -> b+fdVar k m = foldTM k (vm_bvar m)+          . foldTM k (vm_fvar m)++lkDFreeVar :: Var -> DVarEnv a -> Maybe a+lkDFreeVar var env = lookupDVarEnv env var++xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a+xtDFreeVar v f m = alterDVarEnv f m v++ftVar :: (a -> Bool) -> VarMap a -> VarMap a+ftVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv }++-------------------------------------------------+lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a+lkDNamed n env = lookupDNameEnv env (getName n)++xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a+xtDNamed tc f m = alterDNameEnv f m (getName tc)
compiler/GHC/Core/TyCo/FVs.hs view
@@ -26,7 +26,8 @@         injectiveVarsOfType, injectiveVarsOfTypes,         invisibleVarsOfType, invisibleVarsOfTypes, -        -- No Free vars+        -- Any and No Free vars+        anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo,         noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,          -- * Well-scoped free variables@@ -47,7 +48,7 @@  import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) -import Data.Monoid as DM ( Endo(..), All(..) )+import Data.Monoid as DM ( Endo(..), Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon import GHC.Types.Var@@ -855,32 +856,43 @@  {- ********************************************************************* *                                                                      *-                 No free vars+                 Any free vars *                                                                      * ********************************************************************* -} -nfvFolder :: TyCoFolder TyCoVarSet DM.All-nfvFolder = TyCoFolder { tcf_view = noView-                       , tcf_tyvar = do_tcv, tcf_covar = do_tcv-                       , tcf_hole = do_hole, tcf_tycobinder = do_bndr }+{-# INLINE afvFolder #-}   -- so that specialization to (const True) works+afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any+afvFolder check_fv = TyCoFolder { tcf_view = noView+                                , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                                , tcf_hole = do_hole, tcf_tycobinder = do_bndr }   where-    do_tcv is tv = All (tv `elemVarSet` is)-    do_hole _ _  = All True    -- I'm unsure; probably never happens+    do_tcv is tv = Any (not (tv `elemVarSet` is) && check_fv tv)+    do_hole _ _  = Any False    -- I'm unsure; probably never happens     do_bndr is tv _ = is `extendVarSet` tv -nfv_ty  :: Type       -> DM.All-nfv_tys :: [Type]     -> DM.All-nfv_co  :: Coercion   -> DM.All-(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet+anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool+anyFreeVarsOfType check_fv ty = DM.getAny (f ty)+  where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet +anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool+anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys)+  where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet++anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool+anyFreeVarsOfCo check_fv co = DM.getAny (f co)+  where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet+ noFreeVarsOfType :: Type -> Bool-noFreeVarsOfType ty = DM.getAll (nfv_ty ty)+noFreeVarsOfType ty = not $ DM.getAny (f ty)+  where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet  noFreeVarsOfTypes :: [Type] -> Bool-noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys)+noFreeVarsOfTypes tys = not $ DM.getAny (f tys)+  where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet  noFreeVarsOfCo :: Coercion -> Bool-noFreeVarsOfCo co = getAll (nfv_co co)+noFreeVarsOfCo co = not $ DM.getAny (f co)+  where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet   {- *********************************************************************@@ -983,4 +995,3 @@ -- | Get the free vars of types in scoped order tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList-
compiler/GHC/Core/TyCo/Rep.hs view
@@ -37,7 +37,7 @@         -- * Coercions         Coercion(..),         UnivCoProvenance(..),-        CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar,+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,         CoercionN, CoercionR, CoercionP, KindCoercion,         MCoercion(..), MCoercionR, MCoercionN, @@ -52,6 +52,7 @@         mkVisFunTyMany, mkVisFunTysMany,         mkInvisFunTyMany, mkInvisFunTysMany,         mkTyConApp,+        tYPE,          -- * Functions over binders         TyCoBinder(..), TyCoVarBinder, TyBinder,@@ -90,10 +91,11 @@ import GHC.Core.Coercion.Axiom  -- others-import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey )-import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy )+import GHC.Builtin.Names ( liftedTypeKindTyConKey, liftedRepDataConKey, manyDataConKey, tYPETyConKey )+import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, liftedTypeKind, manyDataConTy )+import {-# SOURCE #-} GHC.Builtin.Types.Prim ( tYPETyCon ) import GHC.Types.Basic ( LeftOrRight(..), pickLR )-import GHC.Types.Unique ( hasKey )+import GHC.Types.Unique ( hasKey, Uniquable(..) ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc@@ -1009,7 +1011,7 @@   -- The FunTyCon (->) is always a visible one   = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 } -  -- Note [mkTyConApp and Type]+  -- See Note [Prefer Type over TYPE 'LiftedRep]   | tycon `hasKey` liftedTypeKindTyConKey   = ASSERT2( null tys, ppr tycon $$ ppr tys )     liftedTypeKindTyConApp@@ -1018,21 +1020,21 @@   -- avoid reboxing every time `mkTyConApp` is called.   = ASSERT2( null tys, ppr tycon $$ ppr tys )     manyDataConTy+  -- See Note [Prefer Type over TYPE 'LiftedRep].+  | tycon `hasKey` tYPETyConKey+  , [rep] <- tys+  = tYPE rep+  -- The catch-all case   | otherwise   = TyConApp tycon tys --- This is a single, global definition of the type `Type`--- Defined here so it is only allocated once.--- See Note [mkTyConApp and Type]-liftedTypeKindTyConApp :: Type-liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []- {--Note [mkTyConApp and Type]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Whilst benchmarking it was observed in #17292 that GHC allocated a lot-of `TyConApp` constructors. Upon further inspection a large number of these-TyConApp constructors were all duplicates of `Type` applied to no arguments.+Note [Prefer Type over TYPE 'LiftedRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Core of nearly any program will have numerous occurrences of+@TYPE 'LiftedRep@ (and, equivalently, 'Type') floating about. Concretely, while+investigating #17292 we found that these constituting a majority of TyConApp+constructors on the heap:  ``` (From a sample of 100000 TyConApp closures)@@ -1046,12 +1048,59 @@ 0x45e68fd    - 538 - `TYPE ...` ``` -Therefore in `mkTyConApp` we have a special case for `Type` to ensure that-only one `TyConApp 'Type []` closure is allocated during the course of-compilation. In order to avoid a potentially expensive series of checks in-`mkTyConApp` only this egregious case is special cased at the moment.+Consequently, we try hard to ensure that operations on such types are+efficient. Specifically, we strive to++ a. Avoid heap allocation of such types+ b. Use a small (shallow in the tree-depth sense) representation+    for such types++Goal (b) is particularly useful as it makes traversals (e.g. free variable+traversal, substitution, and comparison) more efficient.+Comparison in particular takes special advantage of nullary type synonym+applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing+nullary type synonyms] in "GHC.Core.Type".++To accomplish these we use a number of tricks:++ 1. Instead of representing the lifted kind as+    @TyConApp tYPETyCon [liftedRepDataCon]@ we rather prefer to+    use the 'GHC.Types.Type' type synonym (represented as a nullary TyConApp).+    This serves goal (b) since there are no applied type arguments to traverse,+    e.g., during comparison.++ 2. We have a top-level binding to represent `TyConApp GHC.Types.Type []`+    (namely 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we+    don't need to allocate such types (goal (a)).++ 3. To avoid allocating 'TyConApp' constructors the+    'GHC.Builtin.Types.Prim.tYPE' function catches the lifted case and returns+    `liftedTypeKind` instead of building an application (goal (a)).++ 4. Similarly, 'Type.mkTyConApp' catches applications of `TYPE` and+    handles them using 'GHC.Builtin.Types.Prim.tYPE', ensuring+    that it benefits from the optimisation described above (goal (a)).++Note that it's quite important that we do not define 'liftedTypeKind' in terms+of 'mkTyConApp' since this tricks (1) and (4) would then result in a loop.++See #17958. -} +-- | Given a RuntimeRep, applies TYPE to it.+-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.+tYPE :: Type -> Type+tYPE (TyConApp tc [])+  -- See Note [Prefer Type of TYPE 'LiftedRep]+  | tc `hasKey` liftedRepDataConKey = liftedTypeKind  -- TYPE 'LiftedRep+tYPE rr = TyConApp tYPETyCon [rr]++-- This is a single, global definition of the type `Type`+-- Defined here so it is only allocated once.+-- See Note [Prefer Type over TYPE 'LiftedRep] in this module.+liftedTypeKindTyConApp :: Type+liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []+ {- %************************************************************************ %*                                                                      *@@ -1588,15 +1637,9 @@   = CoercionHole { ch_co_var  :: CoVar                        -- See Note [CoercionHoles and coercion free variables] -                 , ch_blocker :: BlockSubstFlag  -- should this hole block substitution?-                                                 -- See (2a) in TcCanonical-                                                 -- Note [Equalities with incompatible kinds]                  , ch_ref     :: IORef (Maybe Coercion)                  } -data BlockSubstFlag = YesBlockSubst-                    | NoBlockSubst- coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var @@ -1612,9 +1655,8 @@ instance Outputable CoercionHole where   ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) -instance Outputable BlockSubstFlag where-  ppr YesBlockSubst = text "YesBlockSubst"-  ppr NoBlockSubst  = text "NoBlockSubst"+instance Uniquable CoercionHole where+  getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv  {- Note [Phantom coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/TyCo/Subst.hs view
@@ -46,6 +46,7 @@         substTyVarBndr, substTyVarBndrs,         substCoVarBndr,         substTyVar, substTyVars, substTyCoVars,+        substTyCoBndr,         substForAllCoBndr,         substVarBndrUsing, substForAllCoBndrUsing,         checkValidSubst, isValidTCvSubst,@@ -424,6 +425,7 @@ -- | Generates the in-scope set for the 'TCvSubst' from the types in the -- incoming environment. No CoVars, please! mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst+mkTvSubstPrs []  = emptyTCvSubst mkTvSubstPrs prs =     ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )     mkTvSubst in_scope tenv@@ -741,7 +743,8 @@     go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys                                -- NB: mkTyConApp, not TyConApp.                                -- mkTyConApp has optimizations.-                               -- See Note [mkTyConApp and Type] in GHC.Core.TyCo.Rep+                               -- See Note [Prefer Type over TYPE 'LiftedRep]+                               -- in GHC.Core.TyCo.Rep     go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res })       = let !mult' = go mult             !arg' = go arg@@ -1052,3 +1055,10 @@     (uniq, usupply') = takeUniqFromSupply usupply     (subst' , tv )   = cloneTyVarBndr subst t uniq     (subst'', tvs)   = cloneTyVarBndrs subst' ts usupply'++substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder)+substTyCoBndr subst (Anon af ty)          = (subst, Anon af (substScaledTy subst ty))+substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis))+                                          where+                                            (subst', tv') = substVarBndr subst tv+
compiler/GHC/Core/TyCon.hs view
@@ -56,10 +56,9 @@         mustBeSaturated,         isPromotedDataCon, isPromotedDataCon_maybe,         isKindTyCon, isLiftedTypeKindTyConName,-        isTauTyCon, isFamFreeTyCon,+        isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, -        isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,-        isDataSumTyCon_maybe,+        isDataTyCon,         isEnumerationTyCon,         isNewTyCon, isAbstractTyCon,         isFamilyTyCon, isOpenFamilyTyCon,@@ -84,6 +83,7 @@         tyConCType, tyConCType_maybe,         tyConDataCons, tyConDataCons_maybe,         tyConSingleDataCon_maybe, tyConSingleDataCon,+        tyConAlgDataCons_maybe,         tyConSingleAlgDataCon_maybe,         tyConFamilySize,         tyConStupidTheta,@@ -143,7 +143,7 @@    , multiplicityTyCon    , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} GHC.Core.DataCon-   ( DataCon, dataConExTyCoVars, dataConFieldLabels+   ( DataCon, dataConFieldLabels    , dataConTyCon, dataConFullSig    , isUnboxedSumDataCon ) import GHC.Builtin.Uniques@@ -817,10 +817,15 @@         synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not                                  --          have any foralls, after expanding any                                  --          nested synonyms-        synIsFamFree  :: Bool    -- True <=> the RHS of this synonym does not mention+        synIsFamFree  :: Bool,   -- True <=> the RHS of this synonym does not mention                                  --          any type synonym families (data families                                  --          are fine), again after expanding any                                  --          nested synonyms+        synIsForgetful :: Bool   -- True <=  at least one argument is not mentioned+                                 --          in the RHS (or is mentioned only under+                                 --          forgetful synonyms)+                                 -- Test is conservative, so True does not guarantee+                                 -- forgetfulness.     }    -- | Represents families (both type and data)@@ -1779,20 +1784,21 @@  -- | Create a type synonym 'TyCon' mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind-               -> [Role] -> Type -> Bool -> Bool -> TyCon-mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free+               -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon+mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful   = SynonymTyCon {-        tyConName    = name,-        tyConUnique  = nameUnique name,-        tyConBinders = binders,-        tyConResKind = res_kind,-        tyConKind    = mkTyConKind binders res_kind,-        tyConArity   = length binders,-        tyConTyVars  = binderVars binders,-        tcRoles      = roles,-        synTcRhs     = rhs,-        synIsTau     = is_tau,-        synIsFamFree = is_fam_free+        tyConName      = name,+        tyConUnique    = nameUnique name,+        tyConBinders   = binders,+        tyConResKind   = res_kind,+        tyConKind      = mkTyConKind binders res_kind,+        tyConArity     = length binders,+        tyConTyVars    = binderVars binders,+        tcRoles        = roles,+        synTcRhs       = rhs,+        synIsTau       = is_tau,+        synIsFamFree   = is_fam_free,+        synIsForgetful = is_forgetful     }  -- | Create a type family 'TyCon'@@ -1970,72 +1976,6 @@                            = Just (tvs, rhs, co) unwrapNewTyConEtad_maybe _ = Nothing -isProductTyCon :: TyCon -> Bool--- True of datatypes or newtypes that have---   one, non-existential, data constructor--- See Note [Product types]-isProductTyCon tc@(AlgTyCon {})-  = case algTcRhs tc of-      TupleTyCon {} -> True-      DataTyCon{ data_cons = [data_con] }-                    -> null (dataConExTyCoVars data_con)-      NewTyCon {}   -> True-      _             -> False-isProductTyCon _ = False--isDataProductTyCon_maybe :: TyCon -> Maybe DataCon--- True of datatypes (not newtypes) with---   one, vanilla, data constructor--- See Note [Product types]-isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-       DataTyCon { data_cons = [con] }-         | null (dataConExTyCoVars con)  -- non-existential-         -> Just con-       TupleTyCon { data_con = con }-         -> Just con-       _ -> Nothing-isDataProductTyCon_maybe _ = Nothing--isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]-isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons = cons }-        | cons `lengthExceeds` 1-        , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?-        -> Just cons-      SumTyCon { data_cons = cons }-        | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?-        -> Just cons-      _ -> Nothing-isDataSumTyCon_maybe _ = Nothing--{- Note [Product types]-~~~~~~~~~~~~~~~~~~~~~~~-A product type is- * A data type (not a newtype)- * With one, boxed data constructor- * That binds no existential type variables--The main point is that product types are amenable to unboxing for-  * Strict function calls; we can transform-        f (D a b) = e-    to-        fw a b = e-    via the worker/wrapper transformation.  (Question: couldn't this-    work for existentials too?)--  * CPR for function results; we can transform-        f x y = let ... in D a b-    to-        fw x y = let ... in (# a, b #)--Note that the data constructor /can/ have evidence arguments: equality-constraints, type classes etc.  So it can be GADT.  These evidence-arguments are simply value arguments, and should not get in the way.--}-- -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? {-# INLINE isTypeSynonymTyCon #-}  -- See Note [Inlining coreView] in GHC.Core.Type isTypeSynonymTyCon :: TyCon -> Bool@@ -2046,11 +1986,22 @@ isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau isTauTyCon _                                    = True +-- | Is this tycon neither a type family nor a synonym that expands+-- to a type family? isFamFreeTyCon :: TyCon -> Bool isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free isFamFreeTyCon (FamilyTyCon { famTcFlav = flav })         = isDataFamFlav flav isFamFreeTyCon _                                          = True +-- | Is this a forgetful type synonym? If this is a type synonym whose+-- RHS does not mention one (or more) of its bound variables, returns+-- True. Thus, False means that all bound variables appear on the RHS;+-- True may not mean anything, as the test to set this flag is+-- conservative.+isForgetfulSynTyCon :: TyCon -> Bool+isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget+isForgetfulSynTyCon _                                          = False+ -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique -- right hand side to which a synonym family application can expand.@@ -2118,7 +2069,7 @@   (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb isClosedSynFamilyTyConWithAxiom_maybe _               = Nothing --- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an+-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an -- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is -- injective), or 'NotInjective' otherwise. tyConInjectivityInfo :: TyCon -> Injectivity@@ -2310,12 +2261,14 @@ -- ^ Expand a type synonym application, if any expandSynTyCon_maybe tc tys   | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc-  = case tys `listLengthCmp` arity of-        GT -> Just (tvs `zip` tys, rhs, drop arity tys)-        EQ -> Just (tvs `zip` tys, rhs, [])-        LT -> Nothing-  | otherwise-  = Nothing+  = case tys of+      [] -> Just ([], rhs, []) -- Avoid a bit of work in the case of nullary synonyms+      _  -> case tys `listLengthCmp` arity of+              GT -> Just (tvs `zip` tys, rhs, drop arity tys)+              EQ -> Just (tvs `zip` tys, rhs, [])+              LT -> Nothing+   | otherwise+   = Nothing  ---------------- @@ -2363,8 +2316,7 @@ -- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ -- type with one alternative, a tuple type or a @newtype@ then that constructor -- is returned. If the 'TyCon' has more than one constructor, or represents a--- primitive or function type constructor then @Nothing@ is returned. In any--- other case, the function panics+-- primitive or function type constructor then @Nothing@ is returned. tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })   = case rhs of@@ -2374,21 +2326,29 @@       _                             -> Nothing tyConSingleDataCon_maybe _           = Nothing +-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. tyConSingleDataCon :: TyCon -> DataCon tyConSingleDataCon tc   = case tyConSingleDataCon_maybe tc of       Just c  -> c       Nothing -> pprPanic "tyConDataCon" (ppr tc) +-- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes. tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon--- Returns (Just con) for single-constructor--- *algebraic* data types *not* newtypes-tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons = [c] } -> Just c-      TupleTyCon { data_con = c }   -> Just c-      _                             -> Nothing-tyConSingleAlgDataCon_maybe _        = Nothing+tyConSingleAlgDataCon_maybe tycon+  | isNewTyCon tycon = Nothing+  | otherwise        = tyConSingleDataCon_maybe tycon++-- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type+-- or a sum type with data constructors dcs. If the 'TyCon' has more than one+-- constructor, or represents a primitive or function type constructor then+-- @Nothing@ is returned.+--+-- Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes.+tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon]+tyConAlgDataCons_maybe tycon+  | isNewTyCon tycon = Nothing+  | otherwise        = tyConDataCons_maybe tycon  -- | Determine the number of value constructors a 'TyCon' has. Panics if the -- 'TyCon' is not algebraic or a tuple
compiler/GHC/Core/TyCon/Env.hs view
@@ -26,11 +26,11 @@          DTyConEnv, -        emptyDTyConEnv,+        emptyDTyConEnv, isEmptyDTyConEnv,         lookupDTyConEnv,         delFromDTyConEnv, filterDTyConEnv,-        mapDTyConEnv,-        adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv,+        mapDTyConEnv, mapMaybeDTyConEnv,+        adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv     ) where  #include "GhclibHsVersions.h"@@ -116,6 +116,9 @@ emptyDTyConEnv :: DTyConEnv a emptyDTyConEnv = emptyUDFM +isEmptyDTyConEnv :: DTyConEnv a -> Bool+isEmptyDTyConEnv = isNullUDFM+ lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a lookupDTyConEnv = lookupUDFM @@ -128,6 +131,9 @@ mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b mapDTyConEnv = mapUDFM +mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b+mapMaybeDTyConEnv = mapMaybeUDFM+ adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a adjustDTyConEnv = adjustUDFM @@ -136,3 +142,6 @@  extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a extendDTyConEnv = addToUDFM++foldDTyConEnv :: (elt -> a -> a) -> a -> DTyConEnv elt -> a+foldDTyConEnv = foldUDFM
compiler/GHC/Core/Type.hs view
@@ -29,7 +29,7 @@         mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,         splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, -        mkVisFunTy, mkInvisFunTy,+        mkFunTy, mkVisFunTy, mkInvisFunTy,         mkVisFunTys,         mkVisFunTyMany, mkInvisFunTyMany,         mkVisFunTysMany, mkInvisFunTysMany,@@ -155,6 +155,7 @@         coVarsOfType,         coVarsOfTypes, +        anyFreeVarsOfType, anyFreeVarsOfTypes,         noFreeVarsOfType,         splitVisVarsOfType, splitVisVarsOfTypes,         expandTypeSynonyms,@@ -211,6 +212,7 @@         substCoUnchecked, substCoWithUnchecked,         substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,         substVarBndr, substVarBndrs,+        substTyCoBndr,         cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,          -- * Tidying type related things up for printing@@ -382,34 +384,28 @@ -}  -- | Gives the typechecker view of a type. This unwraps synonyms but--- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into--- TYPE LiftedRep. Returns Nothing if no unwrapping happens.+-- leaves 'Constraint' alone. c.f. 'coreView', which turns 'Constraint' into+-- 'Type'. Returns 'Nothing' if no unwrapping happens. -- See also Note [coreView vs tcView]-{-# INLINE tcView #-} tcView :: Type -> Maybe Type-tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')-               -- The free vars of 'rhs' should all be bound by 'tenv', so it's-               -- ok to use 'substTy' here.-               -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.-               -- Its important to use mkAppTys, rather than (foldl AppTy),-               -- because the function part might well return a-               -- partially-applied type constructor; indeed, usually will!+tcView (TyConApp tc tys)+  | res@(Just _) <- expandSynTyConApp_maybe tc tys+  = res tcView _ = Nothing+-- See Note [Inlining coreView].+{-# INLINE tcView #-} -{-# INLINE coreView #-} coreView :: Type -> Maybe Type--- ^ This function Strips off the /top layer only/ of a type synonym+-- ^ This function strips off the /top layer only/ of a type synonym -- application (if any) its underlying representation type.--- Returns Nothing if there is nothing to look through.--- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.+-- Returns 'Nothing' if there is nothing to look through.+-- This function considers 'Constraint' to be a synonym of @Type@. -- -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing coreView ty@(TyConApp tc tys)-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')-    -- This equation is exactly like tcView+  | res@(Just _) <- expandSynTyConApp_maybe tc tys+  = res    -- At the Core level, Constraint = Type   -- See Note [coreView vs tcView]@@ -418,8 +414,48 @@     Just liftedTypeKind  coreView _ = Nothing+-- See Note [Inlining coreView].+{-# INLINE coreView #-} -{-# INLINE coreFullView #-}+-----------------------------------------------++-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@+-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a+-- synonym.+expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type+expandSynTyConApp_maybe tc tys+  | Just (tvs, rhs) <- synTyConDefn_maybe tc+  , tys `lengthAtLeast` arity+  = Just (expand_syn arity tvs rhs tys)+  | otherwise+  = Nothing+  where+    arity = tyConArity tc+-- Without this INLINE the call to expandSynTyConApp_maybe in coreView+-- will result in an avoidable allocation.+{-# INLINE expandSynTyConApp_maybe #-}++-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path+-- into call-sites.+expand_syn :: Int      -- ^ the arity of the synonym+           -> [TyVar]  -- ^ the variables bound by the synonym+           -> Type     -- ^ the RHS of the synonym+           -> [Type]   -- ^ the type arguments the synonym is instantiated at.+           -> Type+expand_syn arity tvs rhs tys+  | tys `lengthExceeds` arity = mkAppTys rhs' (drop arity tys)+  | otherwise                 = rhs'+  where+    rhs' = substTy (mkTvSubstPrs (tvs `zip` tys)) rhs+               -- The free vars of 'rhs' should all be bound by 'tenv', so it's+               -- ok to use 'substTy' here (which is what expandSynTyConApp_maybe does).+               -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.+               -- Its important to use mkAppTys, rather than (foldl AppTy),+               -- because the function part might well return a+               -- partially-applied type constructor; indeed, usually will!+-- We never want to inline this cold-path.+{-# INLINE expand_syn #-}+ coreFullView :: Type -> Type -- ^ Iterates 'coreView' until there is no more to synonym to expand. -- See Note [Inlining coreView].@@ -431,6 +467,7 @@       | otherwise = ty  coreFullView ty = ty+{-# INLINE coreFullView #-}  {- Note [Inlining coreView] in GHC.Core.Type ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1343,11 +1380,19 @@ -- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your -- type before using this function. --+-- This does *not* split types headed with (=>), as that's not a TyCon in the+-- type-checker.+-- -- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'-tcSplitTyConApp_maybe ty                         = repSplitTyConApp_maybe ty+tcSplitTyConApp_maybe (TyConApp tc tys)          = Just (tc, tys)+tcSplitTyConApp_maybe (FunTy VisArg w arg res)+  | Just arg_rep <- getRuntimeRep_maybe arg+  , Just res_rep <- getRuntimeRep_maybe res+  = Just (funTyCon, [w, arg_rep, res_rep, arg, res])+tcSplitTyConApp_maybe _ = Nothing  ------------------- repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])@@ -1358,7 +1403,7 @@ -- have enough info to extract the runtime-rep arguments that -- the funTyCon requires.  This will usually be true; -- but may be temporarily false during canonicalization:---     see Note [FunTy and decomposing tycon applications] in "GHC.Tc.Solver.Canonical"+--     see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical -- repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) repSplitTyConApp_maybe (FunTy _ w arg res)@@ -1966,13 +2011,17 @@  buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind               -> [Role] -> KnotTied Type -> TyCon--- This function is here beucase here is where we have+-- This function is here because here is where we have --   isFamFree and isTauTy buildSynTyCon name binders res_kind roles rhs-  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free+  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful   where-    is_tau      = isTauTy rhs-    is_fam_free = isFamFreeTy rhs+    is_tau       = isTauTy rhs+    is_fam_free  = isFamFreeTy rhs+    is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders ||+                   uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs)+         -- NB: This is allowed to be conservative, returning True more often+         -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon  {- ************************************************************************@@ -2194,6 +2243,36 @@ to use repSplitAppTy_maybe to break up the TyConApp into its pieces and then continue. Easy to do, but also easy to forget to do. ++Note [Comparing nullary type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of testing equality between two 'Type's of the form++  TyConApp tc []++where @tc@ is a type synonym. A naive way to perform this comparison these+would first expand the synonym and then compare the resulting expansions.++However, this is obviously wasteful and the RHS of @tc@ may be large; it is+much better to rather compare the TyCons directly. Consequently, before+expanding type synonyms in type comparisons we first look for a nullary+TyConApp and simply compare the TyCons if we find one. Of course, if we find+that the TyCons are *not* equal then we still need to perform the expansion as+their RHSs may still be equal.++We perform this optimisation in a number of places:++ * GHC.Core.Types.eqType+ * GHC.Core.Types.nonDetCmpType+ * GHC.Core.Unify.unify_ty+ * TcCanonical.can_eq_nc'+ * TcUnify.uType++This optimisation is especially helpful for the ubiquitous GHC.Types.Type,+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications+whenever possible. See [Prefer Type over TYPE 'LiftedRep] in+GHC.Core.TyCo.Rep for details.+ -}  eqType :: Type -> Type -> Bool@@ -2305,6 +2384,10 @@     -- Returns both the resulting ordering relation between the two types     -- and whether either contains a cast.     go :: RnEnv2 -> Type -> Type -> TypeOrdering+    -- See Note [Comparing nullary type synonyms].+    go _   (TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = TEQ     go env t1 t2       | Just t1' <- coreView t1 = go env t1' t2       | Just t2' <- coreView t2 = go env t1 t2'
compiler/GHC/Core/Unify.hs view
@@ -18,10 +18,13 @@         tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,         tcUnifyTysFG, tcUnifyTyWithTFs,         BindFlag(..),-        UnifyResult, UnifyResultM(..),+        UnifyResult, UnifyResultM(..), MaybeApartReason(..),          -- Matching a type against a lifted type (coercion)-        liftCoMatch+        liftCoMatch,++        -- The core flattening algorithm+        flattenTys, flattenTysX    ) where  #include "GhclibHsVersions.h"@@ -31,24 +34,28 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Types.Name( Name )+import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName ) import GHC.Core.Type     hiding ( getTvSubstEnv ) import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs   ( tyCoVarsOfCoList, tyCoFVsOfTypes ) import GHC.Core.TyCo.Subst ( mkTvSubst )+import GHC.Core.Map.Type import GHC.Utils.FV( FV, fvVarSet, fvVarList ) import GHC.Utils.Misc import GHC.Data.Pair import GHC.Utils.Outputable+import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Exts( oneShot )+import GHC.Utils.Panic+import GHC.Data.FastString +import Data.List ( mapAccumL ) import Control.Monad-import Control.Applicative hiding ( empty )-import qualified Control.Applicative+import qualified Data.Semigroup as S  {- @@ -339,6 +346,46 @@ when it should. See test case indexed-types/should_fail/Overlap15 for an example. +Note [Unificiation result]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When unifying t1 ~ t2, we return+* Unifiable s, if s is a substitution such that s(t1) is syntactically the+  same as s(t2), modulo type-synonym expansion.+* SurelyApart, if there is no substitution s such that s(t1) = s(t2),+  where "=" includes type-family reductions.+* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason.++Examples+* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify+* [(a,Int)] ~ [(Bool,b)]:  Unifiable+* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool (the unifier+                    does not try this)+* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart either; consider+       a := Loop+       where  type family Loop where Loop = Maybe Loop++There is the possibility that two types are MaybeApart for *both* reasons:++* (a, F Int) ~ (Maybe a, Bool)++What reason should we use? The *only* consumer of the reason is described+in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal+there is identify which instances might match a target later (but don't+match now) -- except that we want to ignore the possibility of infinitary+substitutions. So let's examine a concrete scenario:++  class C a b c+  instance C a (Maybe a) Bool+  -- other instances, including one that will actually match+  [W] C b b (F Int)++Do we want the instance as a future possibility? No. The only way that+instance can match is in the presence of an infinite type (infinitely+nested Maybes). We thus say that MARInfinite takes precedence, so that+InstEnv treats this case as an infinitary substitution case; the fact+that a type family is involved is only incidental. We thus define+the Semigroup instance for MaybeApartReason to prefer MARInfinite.+ Note [The substitution in MaybeApart] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?@@ -355,12 +402,6 @@ type family applications to reduce. See test case indexed-types/should_compile/Overlap14. -Note [Unification with skolems]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we discover that two types unify if and only if a skolem variable is-substituted, we can't properly unify the types. But, that skolem variable-may later be instantiated with a unifyable type. So, we return maybeApart-in these cases. -}  -- | Simple unification of two types; all type variables are bindable@@ -389,8 +430,8 @@   = case tc_unify_tys (const BindMe) twoWay True False                        rn_env emptyTvSubstEnv emptyCvSubstEnv                        [t1] [t2] of-      Unifiable  (subst, _) -> Just $ maybe_fix subst-      MaybeApart (subst, _) -> Just $ maybe_fix subst+      Unifiable          (subst, _) -> Just $ maybe_fix subst+      MaybeApart _reason (subst, _) -> Just $ maybe_fix subst       -- we want to *succeed* in questionable cases. This is a       -- pre-unification algorithm.       SurelyApart      -> Nothing@@ -429,36 +470,42 @@ -- This type does double-duty. It is used in the UM (unifier monad) and to -- return the final result. See Note [Fine-grained unification] type UnifyResult = UnifyResultM TCvSubst++-- | See Note [Unificiation result] data UnifyResultM a = Unifiable a        -- the subst that unifies the types-                    | MaybeApart a       -- the subst has as much as we know+                    | MaybeApart MaybeApartReason+                                 a       -- the subst has as much as we know                                          -- it must be part of a most general unifier                                          -- See Note [The substitution in MaybeApart]                     | SurelyApart                     deriving Functor +-- | Why are two types 'MaybeApart'? 'MARTypeFamily' takes precedence:+-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv+data MaybeApartReason = MARTypeFamily   -- ^ matching e.g. F Int ~? Bool+                      | MARInfinite     -- ^ matching e.g. a ~? Maybe a++instance Outputable MaybeApartReason where+  ppr MARTypeFamily = text "MARTypeFamily"+  ppr MARInfinite   = text "MARInfinite"++instance Semigroup MaybeApartReason where+  -- see end of Note [Unification result] for why+  MARTypeFamily <> r = r+  MARInfinite   <> _ = MARInfinite+ instance Applicative UnifyResultM where   pure  = Unifiable   (<*>) = ap  instance Monad UnifyResultM where-   SurelyApart  >>= _ = SurelyApart-  MaybeApart x >>= f = case f x of-                         Unifiable y -> MaybeApart y-                         other       -> other+  MaybeApart r1 x >>= f = case f x of+                            Unifiable y     -> MaybeApart r1 y+                            MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y+                            SurelyApart     -> SurelyApart   Unifiable x  >>= f = f x -instance Alternative UnifyResultM where-  empty = SurelyApart--  a@(Unifiable {})  <|> _                 = a-  _                 <|> b@(Unifiable {})  = b-  a@(MaybeApart {}) <|> _                 = a-  _                 <|> b@(MaybeApart {}) = b-  SurelyApart       <|> SurelyApart       = SurelyApart--instance MonadPlus UnifyResultM- -- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose -- domain elements all respond 'BindMe' to @bind_tv@) such that -- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned@@ -528,9 +575,9 @@     kis2 = map typeKind tys2  instance Outputable a => Outputable (UnifyResultM a) where-  ppr SurelyApart    = text "SurelyApart"-  ppr (Unifiable x)  = text "Unifiable" <+> ppr x-  ppr (MaybeApart x) = text "MaybeApart" <+> ppr x+  ppr SurelyApart      = text "SurelyApart"+  ppr (Unifiable x)    = text "Unifiable" <+> ppr x+  ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x  {- ************************************************************************@@ -690,9 +737,7 @@  The algorithm implemented here is rather delicate, and we depend on it to uphold certain properties. This is a summary of these required-properties. Any reference to "flattening" refers to the flattening-algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.FamInstEnv), not-the flattening algorithm in the solver.+properties.  Notation:  θ,φ    substitutions@@ -773,7 +818,7 @@ We thus must parameterize the algorithm over whether it's being used for an injectivity check (refrain from looking at non-injective arguments to type families) or not (do indeed look at those arguments).  This is-implemented  by the uf_inj_tf field of UmEnv.+implemented  by the um_inj_tf field of UMEnv.  (It's all a question of whether or not to include equation (7) from Fig. 2 of [ITF].)@@ -957,7 +1002,12 @@ -- Respects newtypes, PredTypes  unify_ty env ty1 ty2 kco-    -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type.+  -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.+  | TyConApp tc1 [] <- ty1+  , TyConApp tc2 [] <- ty2+  , tc1 == tc2                = return ()++    -- TODO: More commentary needed here   | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco   | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco   | CastTy ty1' co <- ty1     = if um_unif env@@ -975,9 +1025,11 @@   = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)  unify_ty env ty1 ty2 _kco+ -- NB: This keeps Constraint and Type distinct, as it should for use in the+ -- type-checker.   | Just (tc1, tys1) <- mb_tc_app1   , Just (tc2, tys2) <- mb_tc_app2-  , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2)+  , tc1 == tc2   = if isInjectiveTyCon tc1 Nominal     then unify_tys env tys1 tys2     else do { let inj | isTypeFamilyTyCon tc1@@ -992,7 +1044,7 @@              ; unify_tys env inj_tys1 inj_tys2             ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]-              don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 }+              don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }    | Just (tc1, _) <- mb_tc_app1   , not (isGenerativeTyCon tc1 Nominal)@@ -1000,7 +1052,7 @@     --        because the (F ty1) behaves like a variable     --        NB: if unifying, we have already dealt     --            with the 'ty2 = variable' case-  = maybeApart+  = maybeApart MARTypeFamily    | Just (tc2, _) <- mb_tc_app2   , not (isGenerativeTyCon tc2 Nominal)@@ -1008,7 +1060,7 @@     -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)     --        because the (F ty2) behaves like a variable     --        NB: we have already dealt with the 'ty1 = variable' case-  = maybeApart+  = maybeApart MARTypeFamily    where     mb_tc_app1 = tcSplitTyConApp_maybe ty1@@ -1026,6 +1078,16 @@   | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1   = unify_ty_app env ty1a [ty1b] ty2a [ty2b] +  -- tcSplitTyConApp won't split a (=>), so we handle this separately.+unify_ty env (FunTy InvisArg _w1 arg1 res1) (FunTy InvisArg _w2 arg2 res2) _kco+   -- Look at result representations, but arg representations would be redundant+   -- as anything that can appear to the left of => is lifted.+   -- And anything that can appear to the left of => is unrestricted, so skip the+   -- multiplicities.+  | Just res_rep1 <- getRuntimeRep_maybe res1+  , Just res_rep2 <- getRuntimeRep_maybe res2+  = unify_tys env [res_rep1, arg1, res1] [res_rep2, arg2, res2]+ unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()  unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco@@ -1108,7 +1170,8 @@                       -- this is because the range of the subst is the target                       -- type, not the template type. So, just check for                       -- normal type equality.-                      guard ((ty' `mkCastTy` kco) `eqType` ty)+                      unless ((ty' `mkCastTy` kco) `eqType` ty) $+                      surelyApart           Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue  uUnrefined :: UMEnv@@ -1155,12 +1218,12 @@              -- How could this happen? If we're only matching and if              -- we're comparing forall-bound variables. -           _ -> maybeApart -- See Note [Unification with skolems]+           _ -> surelyApart   }}}}  uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable   = case tvBindFlag env tv1' of-      Skolem -> maybeApart  -- See Note [Unification with skolems]+      Skolem -> surelyApart       BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)  bindTv :: UMEnv -> OutTyVar -> Type -> UM ()@@ -1178,7 +1241,7 @@         -- Make sure you include 'kco' (which ty2 does) #14846         ; occurs <- occursCheck env tv1 free_tvs2 -        ; if occurs then maybeApart+        ; if occurs then maybeApart MARInfinite                     else extendTvEnv tv1 ty2 }  occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool@@ -1203,6 +1266,9 @@    | Skolem      -- This type variable is a skolem constant                 -- Don't bind it; it only matches itself+                -- These variables are SurelyApart from other types+                -- See Note [Binding when looking up instances] in GHC.Core.InstEnv+                -- for why it must be SurelyApart.   deriving Eq  {-@@ -1259,15 +1325,6 @@                   do { (state', v) <- unUM m state                      ; unUM (k v) state' }) --- need this instance because of a use of 'guard' above-instance Alternative UM where-  empty     = UM (\_ -> Control.Applicative.empty)-  m1 <|> m2 = UM (\state ->-                  unUM m1 state <|>-                  unUM m2 state)--instance MonadPlus UM- instance MonadFail UM where     fail _   = UM (\_ -> SurelyApart) -- failed pattern match @@ -1276,9 +1333,9 @@        -> UM a -> UnifyResultM a initUM subst_env cv_subst_env um   = case unUM um state of-      Unifiable (_, subst)  -> Unifiable subst-      MaybeApart (_, subst) -> MaybeApart subst-      SurelyApart           -> SurelyApart+      Unifiable (_, subst)    -> Unifiable subst+      MaybeApart r (_, subst) -> MaybeApart r subst+      SurelyApart             -> SurelyApart   where     state = UMState { um_tv_env = subst_env                     , um_cv_env = cv_subst_env }@@ -1318,9 +1375,7 @@ checkRnEnv env varset   | isEmptyVarSet skol_vars           = return ()   | varset `disjointVarSet` skol_vars = return ()-  | otherwise                         = maybeApart-               -- ToDo: why MaybeApart?-               -- I think SurelyApart would be right+  | otherwise                         = surelyApart   where     skol_vars = um_skols env     -- NB: That isEmptyVarSet guard is a critical optimization;@@ -1328,10 +1383,10 @@     -- the type, often saving quite a bit of allocation.  -- | Converts any SurelyApart to a MaybeApart-don'tBeSoSure :: UM () -> UM ()-don'tBeSoSure um = UM $ \ state ->+don'tBeSoSure :: MaybeApartReason -> UM () -> UM ()+don'tBeSoSure r um = UM $ \ state ->   case unUM um state of-    SurelyApart -> MaybeApart (state, ())+    SurelyApart -> MaybeApart r (state, ())     other       -> other  umRnOccL :: UMEnv -> TyVar -> TyVar@@ -1343,8 +1398,8 @@ umSwapRn :: UMEnv -> UMEnv umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } -maybeApart :: UM ()-maybeApart = UM (\state -> MaybeApart (state, ()))+maybeApart :: MaybeApartReason -> UM ()+maybeApart r = UM (\state -> MaybeApart r (state, ()))  surelyApart :: UM a surelyApart = UM (\_ -> SurelyApart)@@ -1600,3 +1655,321 @@       -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))     -- NB: NoRefl variant. Otherwise, we get a loop!     _ -> Nothing++{-+************************************************************************+*                                                                      *+              Flattening+*                                                                      *+************************************************************************++Note [Flattening type-family applications when matching instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in "Closed type families with overlapping equations"+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf+we need to flatten core types before unifying them, when checking for "surely-apart"+against earlier equations of a closed type family.+Flattening means replacing all top-level uses of type functions with+fresh variables, *taking care to preserve sharing*. That is, the type+(Either (F a b) (F a b)) should flatten to (Either c c), never (Either+c d).++Here is a nice example of why it's all necessary:++  type family F a b where+    F Int Bool = Char+    F a   b    = Double+  type family G a         -- open, no instances++How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,+while the second equation does. But, before reducing, we must make sure that the+target can never become (F Int Bool). Well, no matter what G Float becomes, it+certainly won't become *both* Int and Bool, so indeed we're safe reducing+(F (G Float) (G Float)) to Double.++This is necessary not only to get more reductions (which we might be+willing to give up on), but for substitutivity. If we have (F x x), we+can see that (F x x) can reduce to Double. So, it had better be the+case that (F blah blah) can reduce to Double, no matter what (blah)+is!  Flattening as done below ensures this.++We also use this flattening operation to check for class instances.+If we have+  instance C (Maybe b)+  instance {-# OVERLAPPING #-} C (Maybe Bool)+  [W] C (Maybe (F a))+we want to know that the second instance might match later. So we+flatten the (F a) in the target before trying to unify with instances.+(This is done in GHC.Core.InstEnv.lookupInstEnv'.)++The algorithm works by building up a TypeMap TyVar, mapping+type family applications to fresh variables. This mapping must+be threaded through all the function calls, as any entry in+the mapping must be propagated to all future nodes in the tree.++The algorithm also must track the set of in-scope variables, in+order to make fresh variables as it flattens. (We are far from a+source of fresh Uniques.) See Wrinkle 2, below.++There are wrinkles, of course:++1. The flattening algorithm must account for the possibility+   of inner `forall`s. (A `forall` seen here can happen only+   because of impredicativity. However, the flattening operation+   is an algorithm in Core, which is impredicative.)+   Suppose we have (forall b. F b) -> (forall b. F b). Of course,+   those two bs are entirely unrelated, and so we should certainly+   not flatten the two calls F b to the same variable. Instead, they+   must be treated separately. We thus carry a substitution that+   freshens variables; we must apply this substitution (in+   `coreFlattenTyFamApp`) before looking up an application in the environment.+   Note that the range of the substitution contains only TyVars, never anything+   else.++   For the sake of efficiency, we only apply this substitution when absolutely+   necessary. Namely:++   * We do not perform the substitution at all if it is empty.+   * We only need to worry about the arguments of a type family that are within+     the arity of said type family, so we can get away with not applying the+     substitution to any oversaturated type family arguments.+   * Importantly, we do /not/ achieve this substitution by recursively+     flattening the arguments, as this would be wrong. Consider `F (G a)`,+     where F and G are type families. We might decide that `F (G a)` flattens+     to `beta`. Later, the substitution is non-empty (but does not map `a`) and+     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,+     `F gamma` is unknown, and so we flatten it to `delta`, but it really+     should have been `beta`! Argh!++     Moral of the story: instead of flattening the arguments, just substitute+     them directly.++2. There are two different reasons we might add a variable+   to the in-scope set as we work:++     A. We have just invented a new flattening variable.+     B. We have entered a `forall`.++   Annoying here is that in-scope variable source (A) must be+   threaded through the calls. For example, consider (F b -> forall c. F c).+   Suppose that, when flattening F b, we invent a fresh variable c.+   Now, when we encounter (forall c. F c), we need to know c is already in+   scope so that we locally rename c to c'. However, if we don't thread through+   the in-scope set from one argument of (->) to the other, we won't know this+   and might get very confused.++   In contrast, source (B) increases only as we go deeper, as in-scope sets+   normally do. However, even here we must be careful. The TypeMap TyVar that+   contains mappings from type family applications to freshened variables will+   be threaded through both sides of (forall b. F b) -> (forall b. F b). We+   thus must make sure that the two `b`s don't get renamed to the same b1. (If+   they did, then looking up `F b1` would yield the same flatten var for+   each.) So, even though `forall`-bound variables should really be in the+   in-scope set only when they are in scope, we retain these variables even+   outside of their scope. This ensures that, if we encounter a fresh+   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a+   larger in-scope set than strictly necessary is always OK, as in-scope sets+   are only ever used to avoid collisions.++   Sadly, the freshening substitution described in (1) really mustn't bind+   variables outside of their scope: note that its domain is the *unrenamed*+   variables. This means that the substitution gets "pushed down" (like a+   reader monad) while the in-scope set gets threaded (like a state monad).+   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;+   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet+   traveling separately as necessary.++3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:++     type family F ty_1 ... ty_k :: res_k++   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a+   flattening skolem. But we must instead flatten it to+   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the+   type family.++   Why is this better? Consider the following concrete example from #16995:++     type family Param :: Type -> Type++     type family LookupParam (a :: Type) :: Type where+       LookupParam (f Char) = Bool+       LookupParam x        = Int++     foo :: LookupParam (Param ())+     foo = 42++   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to+   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if+   `alpha` is apart from `f Char`, so it won't fall through to the second+   equation. But since the `Param` type family has arity 0, we can instead+   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is+   apart from `f Char`, permitting the second equation to be reached.++   Not only does this allow more programs to be accepted, it's also important+   for correctness. Not doing this was the root cause of the Core Lint error+   in #16995.++flattenTys is defined here because of module dependencies.+-}++data FlattenEnv+  = FlattenEnv { fe_type_map :: TypeMap (TyVar, TyCon, [Type])+                 -- domain: exactly-saturated type family applications+                 -- range: (fresh variable, type family tycon, args)+               , fe_in_scope :: InScopeSet }+                 -- See Note [Flattening type-family applications when matching instances]++emptyFlattenEnv :: InScopeSet -> FlattenEnv+emptyFlattenEnv in_scope+  = FlattenEnv { fe_type_map = emptyTypeMap+               , fe_in_scope = in_scope }++updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv+updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }++flattenTys :: InScopeSet -> [Type] -> [Type]+-- See Note [Flattening type-family applications when matching instances]+flattenTys in_scope tys = fst (flattenTysX in_scope tys)++flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type]))+-- See Note [Flattening type-family applications when matching instances]+-- NB: the returned types mention the fresh type variables+--     in the domain of the returned env, whose range includes+--     the original type family applications. Building a substitution+--     from this information and applying it would yield the original+--     types -- almost. The problem is that the original type might+--     have something like (forall b. F a b); the returned environment+--     can't really sensibly refer to that b. So it may include a locally-+--     bound tyvar in its range. Currently, the only usage of this env't+--     checks whether there are any meta-variables in it+--     (in GHC.Tc.Solver.Monad.mightMatchLater), so this is all OK.+flattenTysX in_scope tys+  = let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in+    (result, build_env (fe_type_map env))+  where+    build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type])+    build_env env_in+      = foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys))+               env_in emptyVarEnv++coreFlattenTys :: TvSubstEnv -> FlattenEnv+               -> [Type] -> (FlattenEnv, [Type])+coreFlattenTys subst = mapAccumL (coreFlattenTy subst)++coreFlattenTy :: TvSubstEnv -> FlattenEnv+              -> Type -> (FlattenEnv, Type)+coreFlattenTy subst = go+  where+    go env ty | Just ty' <- coreView ty = go env ty'++    go env (TyVarTy tv)+      | Just ty <- lookupVarEnv subst tv = (env, ty)+      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in+                                           (env', mkTyVarTy $ setTyVarKind tv ki)+    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1+                                 (env2, ty2') = go env1 ty2 in+                             (env2, AppTy ty1' ty2')+    go env (TyConApp tc tys)+         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,+         -- which are generative and thus can be preserved during flattening+      | not (isGenerativeTyCon tc Nominal)+      = coreFlattenTyFamApp subst env tc tys++      | otherwise+      = let (env', tys') = coreFlattenTys subst env tys in+        (env', mkTyConApp tc tys')++    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })+      = let (env1, ty1') = go env  ty1+            (env2, ty2') = go env1 ty2+            (env3, mult') = go env2 mult in+        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })++    go env (ForAllTy (Bndr tv vis) ty)+      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv+            (env2, ty') = coreFlattenTy subst' env1 ty in+        (env2, ForAllTy (Bndr tv' vis) ty')++    go env ty@(LitTy {}) = (env, ty)++    go env (CastTy ty co)+      = let (env1, ty') = go env ty+            (env2, co') = coreFlattenCo subst env1 co in+        (env2, CastTy ty' co')++    go env (CoercionTy co)+      = let (env', co') = coreFlattenCo subst env co in+        (env', CoercionTy co')+++-- when flattening, we don't care about the contents of coercions.+-- so, just return a fresh variable of the right (flattened) type+coreFlattenCo :: TvSubstEnv -> FlattenEnv+              -> Coercion -> (FlattenEnv, Coercion)+coreFlattenCo subst env co+  = (env2, mkCoVarCo covar)+  where+    (env1, kind') = coreFlattenTy subst env (coercionType co)+    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'+    -- Add the covar to the FlattenEnv's in-scope set.+    -- See Note [Flattening type-family applications when matching instances], wrinkle 2A.+    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)++coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv+                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)+coreFlattenVarBndr subst env tv+  = (env2, subst', tv')+  where+    -- See Note [Flattening type-family applications when matching instances], wrinkle 2B.+    kind          = varType tv+    (env1, kind') = coreFlattenTy subst env kind+    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')+    subst'        = extendVarEnv subst tv (mkTyVarTy tv')+    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')++coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv+                    -> TyCon         -- type family tycon+                    -> [Type]        -- args, already flattened+                    -> (FlattenEnv, Type)+coreFlattenTyFamApp tv_subst env fam_tc fam_args+  = case lookupTypeMap type_map fam_ty of+      Just (tv, _, _) -> (env', mkAppTys (mkTyVarTy tv) leftover_args')+      Nothing ->+        let tyvar_name = mkFlattenFreshTyName fam_tc+            tv         = uniqAway in_scope $+                         mkTyVar tyvar_name (typeKind fam_ty)++            ty'   = mkAppTys (mkTyVarTy tv) leftover_args'+            env'' = env' { fe_type_map = extendTypeMap type_map fam_ty+                                                       (tv, fam_tc, sat_fam_args)+                         , fe_in_scope = extendInScopeSet in_scope tv }+        in (env'', ty')+  where+    arity = tyConArity fam_tc+    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv+    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )+                                    splitAt arity fam_args+    -- Apply the substitution before looking up an application in the+    -- environment. See Note [Flattening type-family applications when matching instances],+    -- wrinkle 1.+    -- NB: substTys short-cuts the common case when the substitution is empty.+    sat_fam_args' = substTys tcv_subst sat_fam_args+    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args+    -- `fam_tc` may be over-applied to `fam_args` (see+    -- Note [Flattening type-family applications when matching instances]+    -- wrinkle 3), so we split it into the arguments needed to saturate it+    -- (sat_fam_args') and the rest (leftover_args')+    fam_ty = mkTyConApp fam_tc sat_fam_args'+    FlattenEnv { fe_type_map = type_map+               , fe_in_scope = in_scope } = env'++mkFlattenFreshTyName :: Uniquable a => a -> Name+mkFlattenFreshTyName unq+  = mkSysTvName (getUnique unq) (fsLit "flt")++mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar+mkFlattenFreshCoVar in_scope kind+  = let uniq = unsafeGetFreshLocalUnique in_scope+        name = mkSystemVarName uniq (fsLit "flc")+    in mkCoVar name kind
compiler/GHC/CoreToIface.hs view
@@ -245,7 +245,7 @@       , Just tsort <- tupleSort tc'          = tsort        | isUnboxedSumTyCon tc-      , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons)+      , Just cons <- tyConDataCons_maybe tc  = IfaceSumTyCon (length cons)        | otherwise                            = IfaceNormalTyCon
compiler/GHC/Data/Bag.hs view
@@ -17,7 +17,7 @@         filterBag, partitionBag, partitionBagWith,         concatBag, catBagMaybes, foldBag,         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,-        listToBag, bagToList, mapAccumBagL,+        listToBag, nonEmptyToBag, bagToList, mapAccumBagL,         concatMapBag, concatMapBagPair, mapMaybeBag,         mapBagM, mapBagM_,         flatMapBagM, flatMapBagPairM,@@ -35,6 +35,7 @@ import Data.Data import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL )+import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Foldable as Foldable  infixr 3 `consBag`@@ -298,6 +299,10 @@ listToBag [] = EmptyBag listToBag [x] = UnitBag x listToBag vs = ListBag vs++nonEmptyToBag :: NonEmpty a -> Bag a+nonEmptyToBag (x :| []) = UnitBag x+nonEmptyToBag (x :| xs) = ListBag (x : xs)  bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b
compiler/GHC/Data/Graph/Directed.hs view
@@ -1,7 +1,10 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}  module GHC.Data.Graph.Directed (         Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
compiler/GHC/Data/IOEnv.hs view
@@ -29,7 +29,7 @@         tryM, tryAllM, tryMostM, fixM,          -- I/O operations-        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar, updMutVarM,         atomicUpdMutVar, atomicUpdMutVar'   ) where @@ -192,6 +192,12 @@  updMutVar :: IORef a -> (a -> a) -> IOEnv env () updMutVar var upd = liftIO (modifyIORef var upd)++updMutVarM :: IORef a -> (a -> IOEnv env a) -> IOEnv env ()+updMutVarM ref upd+  = do { contents     <- liftIO $ readIORef ref+       ; new_contents <- upd contents+       ; liftIO $ writeIORef ref new_contents }  -- | Atomically update the reference.  Does not force the evaluation of the -- new variable contents.  For strict update, use 'atomicUpdMutVar''.
compiler/GHC/Data/Maybe.hs view
@@ -16,7 +16,7 @@         failME, isSuccess,          orElse,-        firstJust, firstJusts,+        firstJust, firstJusts, firstJustsM,         whenIsJust,         expectJust,         rightToMaybe,@@ -31,6 +31,7 @@ import Control.Monad.Trans.Maybe import Control.Exception (catch, SomeException(..)) import Data.Maybe+import Data.Foldable ( foldlM ) import GHC.Utils.Misc (HasCallStack)  infixr 4 `orElse`@@ -50,6 +51,15 @@ -- @Nothing@ otherwise. firstJusts :: [Maybe a] -> Maybe a firstJusts = msum++-- | Takes computations returnings @Maybes@; tries each one in order.+-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations+-- return @Nothing@.+firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)+firstJustsM = foldlM go Nothing where+  go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)+  go Nothing         action  = action+  go result@(Just _) _action = return result  expectJust :: HasCallStack => String -> Maybe a -> a {-# INLINE expectJust #-}
compiler/GHC/Data/TrieMap.hs view
@@ -16,11 +16,11 @@    -- * Maps over 'Literal's    LiteralMap,    -- * 'TrieMap' class-   TrieMap(..), insertTM, deleteTM,+   TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,     -- * Things helpful for adding additional Instances.    (>.>), (|>), (|>>), XT,-   foldMaybe,+   foldMaybe, filterMaybe,    -- * Map for leaf compression    GenMap,    lkG, xtG, mapG, fdG,@@ -40,13 +40,15 @@ import Control.Monad( (>=>) ) import Data.Kind( Type ) +import qualified Data.Semigroup as S+ {- This module implements TrieMaps, which are finite mappings whose key is a structured value like a CoreExpr or Type.  This file implements tries over general data structures. Implementation for tries over Core Expressions/Types are-available in GHC.Core.Map.+available in GHC.Core.Map.Expr.  The regular pattern for handling TrieMaps on data structures was first described (to my knowledge) in Connelly and Morris's 1995 paper "A@@ -70,6 +72,7 @@    lookupTM :: forall b. Key m -> m b -> Maybe b    alterTM  :: forall b. Key m -> XT b -> m b -> m b    mapTM    :: (a->b) -> m a -> m b+   filterTM :: (a -> Bool) -> m a -> m a     foldTM   :: (a -> b -> b) -> m a -> b -> b       -- The unusual argument order here makes@@ -82,6 +85,13 @@ deleteTM :: TrieMap m => Key m -> m a -> m a deleteTM k m = alterTM k (\_ -> Nothing) m +foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r+foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty++-- This looks inefficient.+isEmptyTM :: TrieMap m => m a -> Bool+isEmptyTM m = foldTM (\ _ _ -> False) m True+ ---------------------- -- Recall that --   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c@@ -121,6 +131,7 @@   alterTM = xtInt   foldTM k m z = IntMap.foldr k z m   mapTM f m = IntMap.map f m+  filterTM f m = IntMap.filter f m  xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a xtInt k f m = IntMap.alter f k m@@ -132,6 +143,7 @@   alterTM k f m = Map.alter f k m   foldTM k m z = Map.foldr k z m   mapTM f m = Map.map f m+  filterTM f m = Map.filter f m   {-@@ -208,6 +220,7 @@   alterTM k f m = alterUDFM f m k   foldTM k m z = foldUDFM k z m   mapTM f m = mapUDFM f m+  filterTM f m = filterUDFM f m  {- ************************************************************************@@ -229,7 +242,11 @@    alterTM  = xtMaybe alterTM    foldTM   = fdMaybe    mapTM    = mapMb+   filterTM = ftMaybe +instance TrieMap m => Foldable (MaybeMap m) where+  foldMap = foldMapTM+ mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b mapMb f (MM { mm_nothing = mn, mm_just = mj })   = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }@@ -248,6 +265,19 @@ fdMaybe k m = foldMaybe k (mm_nothing m)             . foldTM k (mm_just m) +ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a+ftMaybe f (MM { mm_nothing = mn, mm_just = mj })+  = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj }++foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b+foldMaybe _ Nothing  b = b+foldMaybe k (Just a) b = k a b++filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a+filterMaybe _ Nothing = Nothing+filterMaybe f input@(Just x) | f x       = input+                             | otherwise = Nothing+ {- ************************************************************************ *                                                                      *@@ -267,7 +297,11 @@    alterTM  = xtList alterTM    foldTM   = fdList    mapTM    = mapList+   filterTM = ftList +instance TrieMap m => Foldable (ListMap m) where+  foldMap = foldMapTM+ instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where   ppr m = text "List elts" <+> ppr (foldTM (:) m []) @@ -290,9 +324,9 @@ fdList k m = foldMaybe k          (lm_nil m)            . foldTM    (fdList k) (lm_cons m) -foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b-foldMaybe _ Nothing  b = b-foldMaybe k (Just a) b = k a b+ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a+ftList f (LM { lm_nil = mnil, lm_cons = mcons })+  = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons }  {- ************************************************************************@@ -332,7 +366,7 @@ nothing in the map, don't bother building out the (possibly infinite) recursive TrieMap structure! -Compressed triemaps are heavily used by GHC.Core.Map. So we have to mark some things+Compressed triemaps are heavily used by GHC.Core.Map.Expr. So we have to mark some things as INLINEABLE to permit specialization. -} @@ -354,7 +388,11 @@    alterTM  = xtG    foldTM   = fdG    mapTM    = mapG+   filterTM = ftG +instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where+  foldMap = foldMapTM+ --We want to be able to specialize these functions when defining eg --tries over (GenMap CoreExpr) which requires INLINEABLE @@ -403,3 +441,13 @@ fdG _ EmptyMap = \z -> z fdG k (SingletonMap _ v) = \z -> k v z fdG k (MultiMap m) = foldTM k m++{-# INLINEABLE ftG #-}+ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a+ftG _ EmptyMap = EmptyMap+ftG f input@(SingletonMap _ v)+  | f v       = input+  | otherwise = EmptyMap+ftG f (MultiMap m) = MultiMap (filterTM f m)+  -- we don't have enough information to reconstruct the key to make+  -- a SingletonMap
compiler/GHC/Driver/Env.hs view
@@ -4,6 +4,8 @@ module GHC.Driver.Env    ( Hsc(..)    , HscEnv (..)+   , hsc_home_unit+   , hsc_units    , runHsc    , mkInteractiveHscEnv    , runInteractiveHsc@@ -17,6 +19,7 @@    , prepareAnnotations    , lookupType    , lookupIfaceByModule+   , mainModIs    ) where @@ -26,11 +29,9 @@  import GHC.Driver.Ppr import GHC.Driver.Session-import {-# SOURCE #-} GHC.Driver.Plugins  import GHC.Runtime.Context-import GHC.Runtime.Interpreter.Types (Interp)-import GHC.Linker.Types ( Loader )+import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )  import GHC.Unit import GHC.Unit.Module.ModGuts@@ -38,8 +39,8 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo+import GHC.Unit.Env import GHC.Unit.External-import GHC.Unit.Finder.Types  import GHC.Core         ( CoreRule ) import GHC.Core.FamInstEnv@@ -48,10 +49,7 @@ import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) import GHC.Types.CompleteMatch import GHC.Types.Name-import GHC.Types.Name.Cache import GHC.Types.Name.Env-import GHC.Types.Target-import GHC.Types.TypeEnv import GHC.Types.TyThing  import GHC.Builtin.Names ( gHC_PRIM )@@ -59,36 +57,15 @@ import GHC.Data.Maybe import GHC.Data.Bag -import GHC.Unit.Module.Graph- import GHC.Utils.Outputable import GHC.Utils.Monad import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Misc -import Control.Monad    ( guard, ap )+import Control.Monad    ( guard ) import Data.IORef --- | The Hsc monad: Passing an environment and warning state-newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))-    deriving (Functor)--instance Applicative Hsc where-    pure a = Hsc $ \_ w -> return (a, w)-    (<*>) = ap--instance Monad Hsc where-    Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w-                                   case k a of-                                       Hsc k' -> k' e w1--instance MonadIO Hsc where-    liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)--instance HasDynFlags Hsc where-    getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)- runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do     (a, w) <- hsc hsc_env emptyBag@@ -108,96 +85,11 @@ runInteractiveHsc :: HscEnv -> Hsc a -> IO a runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) --- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.--- An HscEnv is used to compile a single module from plain Haskell source--- code (after preprocessing) to either C, assembly or C--. It's also used--- to store the dynamic linker state to allow for multiple linkers in the--- same address space.--- Things like the module graph don't change during a single compilation.------ Historical note: \"hsc\" used to be the name of the compiler binary,--- when there was a separate driver and compiler.  To compile a single--- module, the driver would invoke hsc on the source code... so nowadays--- we think of hsc as the layer of the compiler that deals with compiling--- a single module.-data HscEnv-  = HscEnv {-        hsc_dflags :: DynFlags,-                -- ^ The dynamic flag settings--        hsc_targets :: [Target],-                -- ^ The targets (or roots) of the current session--        hsc_mod_graph :: ModuleGraph,-                -- ^ The module graph of the current session--        hsc_IC :: InteractiveContext,-                -- ^ The context for evaluating interactive statements--        hsc_HPT    :: HomePackageTable,-                -- ^ The home package table describes already-compiled-                -- home-package modules, /excluding/ the module we-                -- are compiling right now.-                -- (In one-shot mode the current module is the only-                -- home-package module, so hsc_HPT is empty.  All other-                -- modules count as \"external-package\" modules.-                -- However, even in GHCi mode, hi-boot interfaces are-                -- demand-loaded into the external-package table.)-                ---                -- 'hsc_HPT' is not mutable because we only demand-load-                -- external packages; the home package is eagerly-                -- loaded, module by module, by the compilation manager.-                ---                -- The HPT may contain modules compiled earlier by @--make@-                -- but not actually below the current module in the dependency-                -- graph.-                ---                -- (This changes a previous invariant: changed Jan 05.)--        hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),-                -- ^ Information about the currently loaded external packages.-                -- This is mutable because packages will be demand-loaded during-                -- a compilation run as required.--        hsc_NC  :: {-# UNPACK #-} !(IORef NameCache),-                -- ^ As with 'hsc_EPS', this is side-effected by compiling to-                -- reflect sucking in interface files.  They cache the state of-                -- external interface files, in effect.--        hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),-                -- ^ The cached result of performing finding in the file system--        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)-                -- ^ Used for one-shot compilation only, to initialise-                -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for-                -- 'GHC.Tc.Utils.TcGblEnv'.  See also Note [hsc_type_env_var hack]--        , hsc_interp :: Maybe Interp-                -- ^ target code interpreter (if any) to use for TH and GHCi.-                -- See Note [Target code interpreter]--        , hsc_loader :: Loader-                -- ^ Loader (dynamic linker)--        , hsc_home_unit :: !HomeUnit-                -- ^ Home-unit--        , hsc_plugins :: ![LoadedPlugin]-                -- ^ plugins dynamically loaded after processing arguments. What-                -- will be loaded here is directed by DynFlags.pluginModNames.-                -- Arguments are loaded from DynFlags.pluginModNameOpts.-                ---                -- The purpose of this field is to cache the plugins so they-                -- don't have to be loaded each time they are needed.  See-                -- 'GHC.Runtime.Loader.initializePlugins'.+hsc_home_unit :: HscEnv -> HomeUnit+hsc_home_unit = ue_home_unit . hsc_unit_env -        , hsc_static_plugins :: ![StaticPlugin]-                -- ^ static plugins which do not need dynamic loading. These plugins are-                -- intended to be added by GHC API users directly to this list.-                ---                -- To add dynamically loaded plugins through the GHC API see-                -- 'addPluginModuleName' instead.- }+hsc_units :: HscEnv -> UnitState+hsc_units = ue_units . hsc_unit_env  {- @@ -391,4 +283,7 @@    --     module is in the PIT, namely GHC.Prim when compiling the base package.    -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package    -- of its own, but it doesn't seem worth the bother.++mainModIs :: HscEnv -> Module+mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env))
+ compiler/GHC/Driver/Env/Types.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveFunctor #-}+module GHC.Driver.Env.Types+  ( Hsc(..)+  , HscEnv(..)+  ) where++import GHC.Driver.Session ( DynFlags, HasDynFlags(..) )+import GHC.Linker.Types ( Loader )+import GHC.Prelude+import GHC.Runtime.Context+import GHC.Runtime.Interpreter.Types ( Interp )+import GHC.Types.Error ( WarningMessages )+import GHC.Types.Name.Cache+import GHC.Types.Target+import GHC.Types.TypeEnv+import GHC.Unit.External+import GHC.Unit.Finder.Types+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.Graph+import GHC.Unit.Env+import GHC.Unit.State+import GHC.Unit.Types+import {-# SOURCE #-} GHC.Driver.Plugins++import Control.Monad ( ap )+import Control.Monad.IO.Class+import Data.IORef++-- | The Hsc monad: Passing an environment and warning state+newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))+    deriving (Functor)++instance Applicative Hsc where+    pure a = Hsc $ \_ w -> return (a, w)+    (<*>) = ap++instance Monad Hsc where+    Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w+                                   case k a of+                                       Hsc k' -> k' e w1++instance MonadIO Hsc where+    liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)++instance HasDynFlags Hsc where+    getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)++-- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.+-- An HscEnv is used to compile a single module from plain Haskell source+-- code (after preprocessing) to either C, assembly or C--. It's also used+-- to store the dynamic linker state to allow for multiple linkers in the+-- same address space.+-- Things like the module graph don't change during a single compilation.+--+-- Historical note: \"hsc\" used to be the name of the compiler binary,+-- when there was a separate driver and compiler.  To compile a single+-- module, the driver would invoke hsc on the source code... so nowadays+-- we think of hsc as the layer of the compiler that deals with compiling+-- a single module.+data HscEnv+  = HscEnv {+        hsc_dflags :: DynFlags,+                -- ^ The dynamic flag settings++        hsc_targets :: [Target],+                -- ^ The targets (or roots) of the current session++        hsc_mod_graph :: ModuleGraph,+                -- ^ The module graph of the current session++        hsc_IC :: InteractiveContext,+                -- ^ The context for evaluating interactive statements++        hsc_HPT    :: HomePackageTable,+                -- ^ The home package table describes already-compiled+                -- home-package modules, /excluding/ the module we+                -- are compiling right now.+                -- (In one-shot mode the current module is the only+                -- home-package module, so hsc_HPT is empty.  All other+                -- modules count as \"external-package\" modules.+                -- However, even in GHCi mode, hi-boot interfaces are+                -- demand-loaded into the external-package table.)+                --+                -- 'hsc_HPT' is not mutable because we only demand-load+                -- external packages; the home package is eagerly+                -- loaded, module by module, by the compilation manager.+                --+                -- The HPT may contain modules compiled earlier by @--make@+                -- but not actually below the current module in the dependency+                -- graph.+                --+                -- (This changes a previous invariant: changed Jan 05.)++        hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),+                -- ^ Information about the currently loaded external packages.+                -- This is mutable because packages will be demand-loaded during+                -- a compilation run as required.++        hsc_NC  :: {-# UNPACK #-} !(IORef NameCache),+                -- ^ As with 'hsc_EPS', this is side-effected by compiling to+                -- reflect sucking in interface files.  They cache the state of+                -- external interface files, in effect.++        hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),+                -- ^ The cached result of performing finding in the file system++        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)+                -- ^ Used for one-shot compilation only, to initialise+                -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for+                -- 'GHC.Tc.Utils.TcGblEnv'.  See also Note [hsc_type_env_var hack]++        , hsc_interp :: Maybe Interp+                -- ^ target code interpreter (if any) to use for TH and GHCi.+                -- See Note [Target code interpreter]++        , hsc_loader :: Loader+                -- ^ Loader (dynamic linker)++        , hsc_plugins :: ![LoadedPlugin]+                -- ^ plugins dynamically loaded after processing arguments. What+                -- will be loaded here is directed by DynFlags.pluginModNames.+                -- Arguments are loaded from DynFlags.pluginModNameOpts.+                --+                -- The purpose of this field is to cache the plugins so they+                -- don't have to be loaded each time they are needed.  See+                -- 'GHC.Runtime.Loader.initializePlugins'.++        , hsc_static_plugins :: ![StaticPlugin]+                -- ^ static plugins which do not need dynamic loading. These plugins are+                -- intended to be added by GHC API users directly to this list.+                --+                -- To add dynamically loaded plugins through the GHC API see+                -- 'addPluginModuleName' instead.++        , hsc_unit_dbs :: !(Maybe [UnitDatabase UnitId])+                -- ^ Stack of unit databases for the target platform.+                --+                -- This field is populated with the result of `initUnits`.+                --+                -- 'Nothing' means the databases have never been read from disk.+                --+                -- Usually we don't reload the databases from disk if they are+                -- cached, even if the database flags changed!++        , hsc_unit_env :: UnitEnv+                -- ^ Unit environment (unit state, home unit, etc.).+                --+                -- Initialized from the databases cached in 'hsc_unit_dbs' and+                -- from the DynFlags.+ }+
compiler/GHC/Driver/Flags.hs view
@@ -263,7 +263,7 @@    | Opt_RPath    | Opt_RelativeDynlibPaths    | Opt_Hpc-   | Opt_FlatCache+   | Opt_FamAppCache    | Opt_ExternalInterpreter    | Opt_OptimalApplicativeDo    | Opt_VersionMacros
compiler/GHC/Driver/Hooks.hs view
@@ -136,8 +136,7 @@   , hscCompileCoreExprHook ::                Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)   , ghcPrimIfaceHook       :: Maybe ModIface-  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags-                                         -> CompPipeline (PhasePlus, FilePath))+  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath))   , runMetaHook            :: Maybe (MetaHook TcM)   , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool                                          -> HomePackageTable -> IO SuccessFlag)
compiler/GHC/Driver/Pipeline/Monad.hs view
@@ -6,7 +6,8 @@     CompPipeline(..), evalP   , PhasePlus(..)   , PipeEnv(..), PipeState(..), PipelineOutput(..)-  , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface+  , getPipeEnv, getPipeState, getPipeSession+  , setDynFlags, setModLocation, setForeignOs, setIface   , pipeStateDynFlags, pipeStateModIface, setPlugins   ) where @@ -110,6 +111,9 @@  getPipeState :: CompPipeline PipeState getPipeState = P $ \_env state -> return (state, state)++getPipeSession :: CompPipeline HscEnv+getPipeSession = P $ \_env state -> return (state, hsc_env state)  instance HasDynFlags CompPipeline where     getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
compiler/GHC/Driver/Ppr.hs view
@@ -24,6 +24,7 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.Driver.Session+import {-# SOURCE #-} GHC.Unit.State  import GHC.Utils.Exception import GHC.Utils.Misc@@ -31,7 +32,6 @@ import GHC.Utils.Panic import GHC.Utils.GlobalVars import GHC.Utils.Ppr       ( Mode(..) )-import {-# SOURCE #-} GHC.Unit.State  import System.IO ( Handle ) import Control.Monad.IO.Class@@ -47,12 +47,11 @@ showPprUnsafe a = renderWithContext defaultSDocContext (ppr a)  -- | Allows caller to specify the PrintUnqualified to use-showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String-showSDocForUser dflags unqual doc = renderWithContext (initSDocContext dflags sty) doc'+showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String+showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc'    where-      sty        = mkUserStyle unqual AllTheWay-      unit_state = unitState dflags-      doc'       = pprWithUnitState unit_state doc+      sty  = mkUserStyle unqual AllTheWay+      doc' = pprWithUnitState unit_state doc  showSDocDump :: SDocContext -> SDoc -> String showSDocDump ctx d = renderWithContext ctx (withPprStyle defaultDumpStyle d)@@ -66,7 +65,7 @@  printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO () printForUser dflags handle unqual depth doc-  = printSDocLn ctx PageMode handle doc+  = printSDocLn ctx (PageMode False) handle doc     where ctx = initSDocContext dflags (mkUserStyle unqual depth)  -- | Like 'printSDocLn' but specialized with 'LeftMode' and
compiler/GHC/Driver/Session.hs view
@@ -40,7 +40,7 @@         DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,         dynamicOutputFile,         sccProfilingEnabled,-        DynFlags(..), mainModIs,+        DynFlags(..),         outputFile, hiSuf, objectSuf, ways,         FlagSpec(..),         HasDynFlags(..), ContainsDynFlags(..),@@ -64,8 +64,6 @@          targetProfile, -        mkHomeUnitFromFlags,-         -- ** Log output         putLogMsg, @@ -232,13 +230,11 @@ import GHC.Platform.Ways import GHC.Platform.Profile import GHC.UniqueSubdir (uniqueSubdir)-import GHC.Unit.Home import GHC.Unit.Types import GHC.Unit.Parser import GHC.Unit.Module import GHC.Builtin.Names ( mAIN_NAME ) import {-# SOURCE #-} GHC.Driver.Hooks-import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags import GHC.Driver.Backend@@ -595,21 +591,6 @@   packageEnv            :: Maybe FilePath,         -- ^ Filepath to the package environment file (if overriding default) -  unitDatabases         :: Maybe [UnitDatabase UnitId],-        -- ^ Stack of unit databases for the target platform.-        ---        -- This field is populated by `initUnits`.-        ---        -- 'Nothing' means the databases have never been read from disk. If-        -- `initUnits` is called again, it doesn't reload the databases from-        -- disk.--  unitState             :: UnitState,-        -- ^ Consolidated unit database built by 'initUnits' from the unit-        -- databases in 'unitDatabases' and flags ('-ignore-package', etc.).-        ---        -- It also contains mapping from module names to actual Modules.-   -- Temporary files   -- These have to be IORefs, because the defaultCleanupHandler needs to   -- know what to clean when an exception happens@@ -1233,8 +1214,6 @@         ignorePackageFlags      = [],         trustFlags              = [],         packageEnv              = Nothing,-        unitDatabases           = Nothing,-        unitState               = emptyUnitState,         targetWays_             = defaultWays mySettings,         splitInfo               = Nothing, @@ -1366,7 +1345,7 @@ jsonLogAction :: LogAction jsonLogAction dflags reason severity srcSpan msg   =-    defaultLogActionHPutStrDoc dflags stdout+    defaultLogActionHPutStrDoc dflags True stdout       (withPprStyle (PprCode CStyle) (doc $$ text ""))     where       str = renderWithContext (initSDocContext dflags defaultUserStyle) msg@@ -1389,9 +1368,9 @@       SevWarning     -> printWarns       SevError       -> printWarns     where-      printOut   = defaultLogActionHPrintDoc  dflags stdout-      printErrs  = defaultLogActionHPrintDoc  dflags stderr-      putStrSDoc = defaultLogActionHPutStrDoc dflags stdout+      printOut   = defaultLogActionHPrintDoc  dflags False stdout+      printErrs  = defaultLogActionHPrintDoc  dflags False stderr+      putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout       -- Pretty print the warning flag, if any (#10752)       message = mkLocMessageAnn flagMsg severity srcSpan msg @@ -1431,16 +1410,19 @@           | otherwise = ""  -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.-defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO ()-defaultLogActionHPrintDoc dflags h d- = defaultLogActionHPutStrDoc dflags h (d $$ text "")+defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPrintDoc dflags asciiSpace h d+ = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "") -defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO ()-defaultLogActionHPutStrDoc dflags h d+-- | The boolean arguments let's the pretty printer know if it can optimize indent+-- by writing ascii ' ' characters without going through decoding.+defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPutStrDoc dflags asciiSpace h d   -- Don't add a newline at the end, so that successive   -- calls to this log-action can output all on the same line-  = printSDoc ctx Pretty.PageMode h d-    where ctx = initSDocContext dflags defaultUserStyle+  = printSDoc ctx (Pretty.PageMode asciiSpace) h d+    where+      ctx = initSDocContext dflags defaultUserStyle  newtype FlushOut = FlushOut (IO ()) @@ -1667,9 +1649,6 @@             extensionFlags = flattenExtensionFlags lang (extensions dflags)           } -mainModIs :: DynFlags -> Module-mainModIs dflags = mkHomeModule (mkHomeUnitFromFlags dflags) (mainModuleNameIs dflags)- -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l)@@ -1816,28 +1795,6 @@ setJsonLogAction :: DynFlags -> DynFlags setJsonLogAction d = d { log_action = jsonLogAction } --- | Get home unit-mkHomeUnitFromFlags :: DynFlags -> HomeUnit-mkHomeUnitFromFlags dflags =-   let !hu_id             = homeUnitId_ dflags-       !hu_instanceof     = homeUnitInstanceOf_ dflags-       !hu_instantiations = homeUnitInstantiations_ dflags-   in case (hu_instanceof, hu_instantiations) of-      (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing-      (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")-      (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")-      (Just u, is)-         -- detect fully indefinite units: all their instantiations are hole-         -- modules and the home unit id is the same as the instantiating unit-         -- id (see Note [About units] in GHC.Unit)-         | all (isHoleModule . snd) is && u == hu_id-         -> IndefiniteHomeUnit u is-         -- otherwise it must be that we (fully) instantiate an indefinite unit-         -- to make it definite.-         -- TODO: error when the unit is partially instantiated??-         | otherwise-         -> DefiniteHomeUnit hu_id (Just (u, is))- parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of     [(r, "")] -> r@@ -3414,7 +3371,7 @@   flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,   flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,   flagSpec "external-interpreter"             Opt_ExternalInterpreter,-  flagSpec "flat-cache"                       Opt_FlatCache,+  flagSpec "family-application-cache"         Opt_FamAppCache,   flagSpec "float-in"                         Opt_FloatIn,   flagSpec "force-recomp"                     Opt_ForceRecomp,   flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,@@ -3772,7 +3729,7 @@   = [ Opt_AutoLinkPackages,       Opt_DiagnosticsShowCaret,       Opt_EmbedManifest,-      Opt_FlatCache,+      Opt_FamAppCache,       Opt_GenManifest,       Opt_GhciHistory,       Opt_GhciSandbox,@@ -4143,7 +4100,9 @@         Opt_WarnMissingPatternSynonymSignatures,         Opt_WarnUnusedRecordWildcards,         Opt_WarnRedundantRecordWildcards,-        Opt_WarnStarIsType+        Opt_WarnStarIsType,+        Opt_WarnIncompleteUniPatterns,+        Opt_WarnIncompletePatternsRecUpd       ]  -- | Things you get with -Weverything, i.e. *all* known warnings flags
compiler/GHC/Driver/Session.hs-boot view
@@ -3,12 +3,10 @@ import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Utils.Outputable-import {-# SOURCE #-} GHC.Unit.State  data DynFlags  targetPlatform           :: DynFlags -> Platform-unitState                :: DynFlags -> UnitState hasPprDebug              :: DynFlags -> Bool hasNoDebugOutput         :: DynFlags -> Bool initSDocContext          :: DynFlags -> PprStyle -> SDocContext
compiler/GHC/Hs/Binds.hs view
@@ -51,6 +51,7 @@ import Data.Data hiding ( Fixity ) import Data.List hiding ( foldr ) import Data.Function+import Data.Void  {- ************************************************************************@@ -766,7 +767,7 @@        ppr_details = case details of           InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]-          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr vs)+          PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr vs)           RecCon vs      -> pprPrefixOcc psyn                             <> braces (sep (punctuate comma (map ppr vs))) @@ -1229,55 +1230,48 @@ -}  -- | Haskell Pattern Synonym Details-type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField (LIdP pass)]+type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass]  -- See Note [Record PatSyn Fields] -- | Record Pattern Synonym Field-data RecordPatSynField fld-  = RecordPatSynField {-      recordPatSynSelectorId :: fld  -- Selector name visible in rest of the file-      , recordPatSynPatVar   :: fld-      -- Filled in by renamer, the name used internally-      -- by the pattern-      } deriving (Data, Functor)-+data RecordPatSynField pass+  = RecordPatSynField+      { recordPatSynField :: FieldOcc pass+      -- ^ Field label visible in rest of the file+      , recordPatSynPatVar :: LIdP pass+      -- ^ Filled in by renamer, the name used internally by the pattern+      }   {- Note [Record PatSyn Fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~  Consider the following two pattern synonyms. -pattern P x y = ([x,True], [y,'v'])-pattern Q{ x, y } =([x,True], [y,'v'])+  pattern P x y = ([x,True], [y,'v'])+  pattern Q{ x, y } =([x,True], [y,'v'])  In P, we just have two local binders, x and y.  In Q, we have local binders but also top-level record selectors-x :: ([Bool], [Char]) -> Bool and similarly for y.+  x :: ([Bool], [Char]) -> Bool+  y :: ([Bool], [Char]) -> Char +Both are recorded in the `RecordPatSynField`s for `x` and `y`:+* recordPatSynField: the top-level record selector+* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym.+ It would make sense to support record-like syntax -pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])+  pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) -when we have a different name for the local and top-level binder-the distinction between the two names clear+when we have a different name for the local and top-level binder,+making the distinction between the two names clear.  -}-instance Outputable a => Outputable (RecordPatSynField a) where-    ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v--instance Foldable RecordPatSynField  where-    foldMap f (RecordPatSynField { recordPatSynSelectorId = visible-                                 , recordPatSynPatVar = hidden })-      = f visible `mappend` f hidden--instance Traversable RecordPatSynField where-    traverse f (RecordPatSynField { recordPatSynSelectorId =visible-                                  , recordPatSynPatVar = hidden })-      = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id-                                               , recordPatSynPatVar = pat_var })-          <$> f visible <*> f hidden+instance Outputable (RecordPatSynField a) where+    ppr (RecordPatSynField { recordPatSynField = v }) = ppr v   -- | Haskell Pattern Synonym Direction
compiler/GHC/Hs/Decls.hs view
@@ -128,6 +128,7 @@ import GHC.Data.Bag import GHC.Data.Maybe import Data.Data        hiding (TyCon,Fixity, Infix)+import Data.Void  {- ************************************************************************@@ -1617,7 +1618,9 @@  -- | The arguments in a Haskell98-style data constructor. type HsConDeclH98Details pass-   = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])+   = HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])+-- The Void argument to HsConDetails here is a reflection of the fact that+-- type applications are not allowed in data constructor declarations.  -- | The arguments in a GADT constructor. Unlike Haskell98-style constructors, -- GADT constructors cannot be declared with infix syntax. As a result, we do@@ -1716,8 +1719,8 @@     ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),                                          pprInfixOcc con,                                          ppr (hsScaledThing t2)]-    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con-                                   : map (pprHsType . unLoc . hsScaledThing) tys)+    ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con+                                    : map (pprHsType . unLoc . hsScaledThing) tys)     ppr_details (RecCon fields)  = pprPrefixOcc con                                  <+> pprConDeclFields (unLoc fields)     cxt = fromMaybe noLHsContext mcxt
compiler/GHC/Hs/Expr.hs view
@@ -38,7 +38,6 @@ -- others: import GHC.Tc.Types.Evidence import GHC.Core-import GHC.Types.Id( Id ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Basic@@ -252,8 +251,10 @@                              -- Turned from HsVar to HsUnboundVar by the                              --   renamer, when it finds an out-of-scope                              --   variable or hole.-                             -- The (XUnboundVar p) field becomes Id-                             --   after typechecking+                             -- The (XUnboundVar p) field becomes an HoleExprRef+                             --   after typechecking; this is where the+                             --   erroring expression will be written after+                             --   solving. See Note [Holes] in GHC.Tc.Types.Constraint.    | HsConLikeOut (XConLikeOut p)                  ConLike     -- ^ After typechecker only; must be different@@ -608,7 +609,11 @@  type instance XUnboundVar    GhcPs = NoExtField type instance XUnboundVar    GhcRn = NoExtField-type instance XUnboundVar    GhcTc = Id+type instance XUnboundVar    GhcTc = HoleExprRef+  -- We really don't need the whole HoleExprRef; just the IORef EvTerm+  -- would be enough. But then deriving a Data instance becomes impossible.+  -- Much, much easier just to define HoleExprRef with a Data instance and+  -- store the whole structure.  type instance XAppTypeE      GhcPs = NoExtField type instance XAppTypeE      GhcRn = NoExtField
compiler/GHC/Hs/Extension.hs view
@@ -253,9 +253,9 @@ -- | Used as a data type index for the hsSyn AST; also serves -- as a singleton type for Pass data GhcPass (c :: Pass) where-  GhcPs :: GhcPs-  GhcRn :: GhcRn-  GhcTc :: GhcTc+  GhcPs :: GhcPass 'Parsed+  GhcRn :: GhcPass 'Renamed+  GhcTc :: GhcPass 'Typechecked  -- This really should never be entered, but the data-deriving machinery -- needs the instance to exist.
compiler/GHC/Hs/ImpExp.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE DataKinds            #-} {-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeApplications     #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module GHC.Hs.Extension@@ -20,7 +22,7 @@ import GHC.Hs.Doc             ( HsDocString ) import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc ) import GHC.Types.SourceText   ( SourceText(..), StringLiteral(..), pprWithSourceText )-import GHC.Types.FieldLabel   ( FieldLbl(..) )+import GHC.Types.FieldLabel   ( FieldLabel )  import GHC.Utils.Outputable import GHC.Utils.Panic@@ -229,7 +231,6 @@                 (LIEWrappedName (IdP pass))                 IEWildcard                 [LIEWrappedName (IdP pass)]-                [XRec pass (FieldLbl (IdP pass))]         -- ^ Imported or exported Thing With given imported or exported         --         -- The thing is a Class/Type and the imported or exported things are@@ -256,46 +257,61 @@ type instance XIEVar             (GhcPass _) = NoExtField type instance XIEThingAbs        (GhcPass _) = NoExtField type instance XIEThingAll        (GhcPass _) = NoExtField-type instance XIEThingWith       (GhcPass _) = NoExtField type instance XIEModuleContents  (GhcPass _) = NoExtField type instance XIEGroup           (GhcPass _) = NoExtField type instance XIEDoc             (GhcPass _) = NoExtField type instance XIEDocNamed        (GhcPass _) = NoExtField type instance XXIE               (GhcPass _) = NoExtCon +-- See Note [IEThingWith]+type instance XIEThingWith       (GhcPass 'Renamed)     = [Located FieldLabel]+type instance XIEThingWith       (GhcPass 'Parsed)      = NoExtField+type instance XIEThingWith       (GhcPass 'Typechecked) = NoExtField++ -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)  {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~- A definition like +    {-# LANGUAGE DuplicateRecordFields #-}     module M ( T(MkT, x) ) where       data T = MkT { x :: Int } -gives rise to+gives rise to this in the output of the parser: -    IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)-    IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields)+    IEThingWith NoExtField T [MkT, x] NoIEWildcard +But in the renamer we need to attach the correct field label,+because the selector Name is mangled (see Note [FieldLabel] in+GHC.Types.FieldLabel).  Hence we change this to:++    IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard++using the TTG extension field to store the list of fields in renamed syntax+only.  (Record fields always appear in this list, regardless of whether+DuplicateRecordFields was in use at the definition site or not.)+ See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. -}  ieName :: IE (GhcPass p) -> IdP (GhcPass p)-ieName (IEVar _ (L _ n))              = ieWrappedName n-ieName (IEThingAbs  _ (L _ n))        = ieWrappedName n-ieName (IEThingWith _ (L _ n) _ _ _)  = ieWrappedName n-ieName (IEThingAll  _ (L _ n))        = ieWrappedName n+ieName (IEVar _ (L _ n))            = ieWrappedName n+ieName (IEThingAbs  _ (L _ n))      = ieWrappedName n+ieName (IEThingWith _ (L _ n) _ _)  = ieWrappedName n+ieName (IEThingAll  _ (L _ n))      = ieWrappedName n ieName _ = panic "ieName failed pattern match!"  ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)]-ieNames (IEVar       _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingAbs  _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingAll  _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n-                                       : map (ieWrappedName . unLoc) ns+ieNames (IEVar       _ (L _ n)   )   = [ieWrappedName n]+ieNames (IEThingAbs  _ (L _ n)   )   = [ieWrappedName n]+ieNames (IEThingAll  _ (L _ n)   )   = [ieWrappedName n]+ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n+                                     : map (ieWrappedName . unLoc) ns+-- NB the above case does not include names of field selectors ieNames (IEModuleContents {})     = [] ieNames (IEGroup          {})     = [] ieNames (IEDoc            {})     = []@@ -321,10 +337,9 @@     ppr (IEVar       _     var) = ppr (unLoc var)     ppr (IEThingAbs  _   thing) = ppr (unLoc thing)     ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]-    ppr (IEThingWith _ thing wc withs flds)+    ppr (IEThingWith flds thing wc withs)         = ppr (unLoc thing) <> parens (fsep (punctuate comma-                                              (ppWiths ++-                                              map (ppr . flLabel . unLoc) flds)))+                                              (ppWiths ++ ppFields) ))       where         ppWiths =           case wc of@@ -333,6 +348,10 @@               IEWildcard pos ->                 let (bs, as) = splitAt pos (map (ppr . unLoc) withs)                 in bs ++ [text ".."] ++ as+        ppFields =+          case ghcPass @p of+            GhcRn -> map ppr flds+            _     -> []     ppr (IEModuleContents _ mod')         = text "module" <+> ppr mod'     ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")
compiler/GHC/Hs/Instances.hs view
@@ -69,6 +69,11 @@ deriving instance Data (ABExport GhcRn) deriving instance Data (ABExport GhcTc) +-- deriving instance DataId p => Data (RecordPatSynField p)+deriving instance Data (RecordPatSynField GhcPs)+deriving instance Data (RecordPatSynField GhcRn)+deriving instance Data (RecordPatSynField GhcTc)+ -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) deriving instance Data (PatSynBind GhcPs GhcPs) deriving instance Data (PatSynBind GhcPs GhcRn)
compiler/GHC/Hs/Pat.hs view
@@ -317,10 +317,10 @@   -- | Haskell Constructor Pattern Details-type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))+type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))  hsConPatArgs :: HsConPatDetails p -> [LPat p]-hsConPatArgs (PrefixCon ps)   = ps+hsConPatArgs (PrefixCon _ ps) = ps hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] @@ -580,10 +580,10 @@                }        )   = case ghcPass @p of-      GhcPs -> pprUserCon (unLoc con) details-      GhcRn -> pprUserCon (unLoc con) details+      GhcPs -> regular+      GhcRn -> regular       GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case-        False -> pprUserCon (unLoc con) details+        False -> regular         True  ->           -- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an           -- error message, and we want to make sure it prints nicely@@ -595,6 +595,9 @@                        , cpt_dicts = dicts                        , cpt_binds = binds                        } = ext+  where+    regular :: OutputableBndr (ConLikeP (GhcPass p)) => SDoc+    regular = pprUserCon (unLoc con) details pprPat (XPat ext) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811   GhcPs -> noExtCon ext@@ -611,12 +614,14 @@ pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details + pprConArgs :: (OutputableBndrId p)            => HsConPatDetails (GhcPass p) -> SDoc-pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)-pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1-                                  , pprParendLPat appPrec p2 ]-pprConArgs (RecCon rpats)   = ppr rpats+pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)+  where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs)+pprConArgs (InfixCon p1 p2)    = sep [ pprParendLPat appPrec p1+                                     , pprParendLPat appPrec p2 ]+pprConArgs (RecCon rpats)      = ppr rpats  instance (Outputable arg)       => Outputable (HsRecFields p arg) where@@ -647,7 +652,7 @@ -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys   = noLoc $ ConPat { pat_con = noLoc (RealDataCon dc)-                   , pat_args = PrefixCon pats+                   , pat_args = PrefixCon [] pats                    , pat_con_ext = ConPatTc                      { cpt_tvs = []                      , cpt_dicts = []@@ -771,8 +776,6 @@          L _ (PatSynCon _pat)  -> False -- Conservative          L _ (RealDataCon con) ->            isJust (tyConSingleDataCon_maybe (dataConTyCon con))-           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because-           -- the latter is false of existentials. See #4439            && all goL (hsConPatArgs details)     go (LitPat {})         = False     go (NPat {})           = False@@ -837,7 +840,7 @@     go :: Pat (GhcPass p) -> Bool     go (NPlusKPat {})    = p > opPrec     go (SplicePat {})    = False-    go (ConPat { pat_args = ds})+    go (ConPat { pat_args = ds })                          = conPatNeedsParens p ds     go (SigPat {})       = p >= sigPrec     go (ViewPat {})      = True@@ -867,12 +870,12 @@  -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@.-conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool+conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool conPatNeedsParens p = go   where-    go (PrefixCon args) = p >= appPrec && not (null args)-    go (InfixCon {})    = p >= opPrec-    go (RecCon {})      = False+    go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))+    go (InfixCon {})       = p >= opPrec -- type args should be empty in this case+    go (RecCon {})         = False  -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
compiler/GHC/Hs/Type.hs view
@@ -24,7 +24,7 @@         HsArrow(..), arrowToHsType,         hsLinear, hsUnrestricted, isUnrestricted, -        HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,+        HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,         HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,         LHsQTyVars(..),         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,@@ -46,7 +46,7 @@          ConDeclField(..), LConDeclField, pprConDeclFields, -        HsConDetails(..),+        HsConDetails(..), noTypeArgs,          FieldOcc(..), LFieldOcc, mkFieldOcc,         AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,@@ -107,10 +107,11 @@ import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc ( count )+import GHC.Parser.Annotation  import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Maybe-import GHC.Parser.Annotation+import Data.Void  {- ************************************************************************@@ -505,7 +506,7 @@ type instance XHsWC              GhcRn b = [Name] type instance XHsWC              GhcTc b = [Name] -type instance XXHsWildCardBndrs  (GhcPass _) b = NoExtCon+type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon  -- | Types that can appear in pattern signatures, as well as the signatures for -- term-level binders in RULES.@@ -1039,12 +1040,6 @@        -- For details on above see note [Api annotations] in GHC.Parser.Annotation -  -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed*-  --                                -- Core Type through HsSyn.-  --     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation-   | HsExplicitListTy       -- A promoted explicit list         (XExplicitListTy pass)         PromotionFlag      -- whether explicitly promoted, for pretty printer@@ -1077,16 +1072,13 @@   | XHsType       (XXType pass) -data NewHsTypeX-  = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*-                   -- Core Type through HsSyn.-                   -- See also Note [Typechecking NHsCoreTys] in-                   -- GHC.Tc.Gen.HsType.-    deriving Data-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--instance Outputable NewHsTypeX where-  ppr (NHsCoreTy ty) = ppr ty+-- An escape hatch for tunnelling a Core 'Type' through 'HsType'.+-- For more details on how this works, see:+--+-- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"+--+-- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"+type HsCoreTy = Type  type instance XForAllTy        (GhcPass _) = NoExtField type instance XQualTy          (GhcPass _) = NoExtField@@ -1124,7 +1116,7 @@  type instance XWildCardTy      (GhcPass _) = NoExtField -type instance XXType         (GhcPass _) = NewHsTypeX+type instance XXType         (GhcPass _) = HsCoreTy   -- Note [Literal source text] in GHC.Types.Basic for SourceText fields in@@ -1333,18 +1325,23 @@ -- a separate data type entirely (see 'HsConDeclGADTDetails' in -- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with -- infix syntax, unlike the concepts above (#18844).-data HsConDetails arg rec-  = PrefixCon [arg]             -- C p1 p2 p3+data HsConDetails tyarg arg rec+  = PrefixCon [tyarg] [arg]     -- C @t1 @t2 p1 p2 p3   | RecCon    rec               -- C { x = p1, y = p2 }   | InfixCon  arg arg           -- p1 `C` p2   deriving Data -instance (Outputable arg, Outputable rec)-         => Outputable (HsConDetails arg rec) where-  ppr (PrefixCon args) = text "PrefixCon" <+> ppr args-  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec-  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]+-- | An empty list that can be used to indicate that there are no+-- type arguments allowed in cases where HsConDetails is applied to Void.+noTypeArgs :: [Void]+noTypeArgs = [] +instance (Outputable tyarg, Outputable arg, Outputable rec)+         => Outputable (HsConDetails tyarg arg rec) where+  ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args+  ppr (RecCon rec)            = text "RecCon:" <+> ppr rec+  ppr (InfixCon l r)          = text "InfixCon:" <+> ppr [l, r]+ {- Note [ConDeclField passs] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1901,9 +1898,13 @@  -- | Field Occurrence ----- Represents an *occurrence* of an unambiguous field.  We store--- both the 'RdrName' the user originally wrote, and after the--- renamer, the selector function.+-- Represents an *occurrence* of an unambiguous field.  This may or may not be a+-- binding occurrence (e.g. this type is used in 'ConDeclField' and+-- 'RecordPatSynField' which bind their fields, but also in 'HsRecField' for+-- record construction and patterns, which do not).+--+-- We store both the 'RdrName' the user originally wrote, and after the renamer,+-- the selector function. data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass                               , rdrNameFieldOcc :: Located RdrName                                  -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr"@@ -2250,7 +2251,7 @@     go_hs_ty (HsOpTy{})               = p >= opPrec     go_hs_ty (HsParTy{})              = False     go_hs_ty (HsDocTy _ (L _ t) _)    = go_hs_ty t-    go_hs_ty (XHsType (NHsCoreTy ty)) = go_core_ty ty+    go_hs_ty (XHsType ty)             = go_core_ty ty      go_core_ty (TyVarTy{})    = False     go_core_ty (AppTy{})      = p >= appPrec
compiler/GHC/Hs/Utils.hs view
@@ -480,28 +480,28 @@ nlConPat con pats = noLoc $ ConPat   { pat_con_ext = noExtField   , pat_con = noLoc con-  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+  , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)   }  nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn nlConPatName con pats = noLoc $ ConPat   { pat_con_ext = noExtField   , pat_con = noLoc con-  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+  , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)   }  nlNullaryConPat :: RdrName -> LPat GhcPs nlNullaryConPat con = noLoc $ ConPat   { pat_con_ext = noExtField   , pat_con = noLoc con-  , pat_args = PrefixCon []+  , pat_args = PrefixCon [] []   }  nlWildConPat :: DataCon -> LPat GhcPs nlWildConPat con = noLoc $ ConPat   { pat_con_ext = noExtField   , pat_con = noLoc $ getRdrName con-  , pat_args = PrefixCon $+  , pat_args = PrefixCon [] $      replicate (dataConSourceArity con)                nlWildPat   }@@ -1192,17 +1192,17 @@   --------------------hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [IdP (GhcPass p)]+hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _))   = foldr addPatSynSelector [] . unionManyBags $ map snd binds -addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [IdP p] -> [IdP p]+addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] addPatSynSelector bind sels   | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind-  = map (unXRec @p . recordPatSynSelectorId) as ++ sels+  = map recordPatSynField as ++ sels   | otherwise = sels  getPatSynBinds :: forall id. UnXRec id@@ -1396,7 +1396,7 @@     hs_pat _ = []      details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]-    details _ (PrefixCon ps)   = hs_lpats ps+    details _ (PrefixCon _ ps) = hs_lpats ps     details n (RecCon fs)      =       [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]         ++ hs_lpats explicit_pats
compiler/GHC/Parser/Errors.hs view
@@ -1,11 +1,11 @@ module GHC.Parser.Errors-   ( Warning(..)+   ( PsWarning(..)    , TransLayoutReason(..)    , OperatorWhitespaceSymbol(..)    , OperatorWhitespaceOccurrence(..)    , NumUnderscoreReason(..)-   , Error(..)-   , ErrorDesc(..)+   , PsError(..)+   , PsErrorDesc(..)    , LexErr(..)    , CmmParserError(..)    , LexErrKind(..)@@ -30,37 +30,38 @@ import GHC.Data.FastString import GHC.Unit.Module.Name -data Warning+-- | A warning that might arise during parsing.+data PsWarning       -- | Warn when tabulations are found-   = WarnTab+   = PsWarnTab       { tabFirst :: !SrcSpan -- ^ First occurence of a tab       , tabCount :: !Word    -- ^ Number of other occurences       } -   | WarnTransitionalLayout !SrcSpan !TransLayoutReason+   | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason       -- ^ Transitional layout warnings -   | WarnUnrecognisedPragma !SrcSpan+   | PsWarnUnrecognisedPragma !SrcSpan       -- ^ Unrecognised pragma -   | WarnHaddockInvalidPos !SrcSpan+   | PsWarnHaddockInvalidPos !SrcSpan       -- ^ Invalid Haddock comment position -   | WarnHaddockIgnoreMulti !SrcSpan+   | PsWarnHaddockIgnoreMulti !SrcSpan       -- ^ Multiple Haddock comment for the same entity -   | WarnStarBinder !SrcSpan+   | PsWarnStarBinder !SrcSpan       -- ^ Found binding occurence of "*" while StarIsType is enabled -   | WarnStarIsType !SrcSpan+   | PsWarnStarIsType !SrcSpan       -- ^ Using "*" for "Type" without StarIsType enabled -   | WarnImportPreQualified !SrcSpan+   | PsWarnImportPreQualified !SrcSpan       -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled -   | WarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol-   | WarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence+   | PsWarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol+   | PsWarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence  -- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning. data OperatorWhitespaceSymbol@@ -78,149 +79,146 @@    = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"    | TransLayout_Pipe  -- ^ "`|' at the same depth as implicit layout block") -data Error = Error-   { errDesc  :: !ErrorDesc   -- ^ Error description+data PsError = PsError+   { errDesc  :: !PsErrorDesc   -- ^ Error description    , errHints :: ![Hint]      -- ^ Hints    , errLoc   :: !SrcSpan     -- ^ Error position    } -data ErrorDesc-   = ErrLambdaCase+data PsErrorDesc+   = PsErrLambdaCase       -- ^ LambdaCase syntax used without the extension enabled -   | ErrNumUnderscores !NumUnderscoreReason+   | PsErrNumUnderscores !NumUnderscoreReason       -- ^ Underscores in literals without the extension enabled -   | ErrPrimStringInvalidChar+   | PsErrPrimStringInvalidChar       -- ^ Invalid character in primitive string -   | ErrMissingBlock+   | PsErrMissingBlock       -- ^ Missing block -   | ErrLexer !LexErr !LexErrKind+   | PsErrLexer !LexErr !LexErrKind       -- ^ Lexer error -   | ErrSuffixAT+   | PsErrSuffixAT       -- ^ Suffix occurence of `@` -   | ErrParse !String+   | PsErrParse !String       -- ^ Parse errors -   | ErrCmmLexer+   | PsErrCmmLexer       -- ^ Cmm lexer error -   | ErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))+   | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))       -- ^ Unsupported boxed sum in expression -   | ErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))+   | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))       -- ^ Unsupported boxed sum in pattern -   | ErrUnexpectedQualifiedConstructor !RdrName+   | PsErrUnexpectedQualifiedConstructor !RdrName       -- ^ Unexpected qualified constructor -   | ErrTupleSectionInPat+   | PsErrTupleSectionInPat       -- ^ Tuple section in pattern context -   | ErrIllegalBangPattern !(Pat GhcPs)+   | PsErrIllegalBangPattern !(Pat GhcPs)       -- ^ Bang-pattern without BangPattterns enabled -   | ErrOpFewArgs !StarIsType !RdrName+   | PsErrOpFewArgs !StarIsType !RdrName       -- ^ Operator applied to too few arguments -   | ErrImportQualifiedTwice+   | PsErrImportQualifiedTwice       -- ^ Import: multiple occurrences of 'qualified' -   | ErrImportPostQualified+   | PsErrImportPostQualified       -- ^ Post qualified import without 'ImportQualifiedPost' -   | ErrIllegalExplicitNamespace+   | PsErrIllegalExplicitNamespace       -- ^ Explicit namespace keyword without 'ExplicitNamespaces' -   | ErrVarForTyCon !RdrName+   | PsErrVarForTyCon !RdrName       -- ^ Expecting a type constructor but found a variable -   | ErrIllegalPatSynExport+   | PsErrIllegalPatSynExport       -- ^ Illegal export form allowed by PatternSynonyms -   | ErrMalformedEntityString+   | PsErrMalformedEntityString       -- ^ Malformed entity string -   | ErrDotsInRecordUpdate+   | PsErrDotsInRecordUpdate       -- ^ Dots used in record update -   | ErrPrecedenceOutOfRange !Int+   | PsErrPrecedenceOutOfRange !Int       -- ^ Precedence out of range -   | ErrInvalidDataCon !(HsType GhcPs)+   | PsErrInvalidDataCon !(HsType GhcPs)       -- ^ Cannot parse data constructor in a data/newtype declaration -   | ErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)+   | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)       -- ^ Cannot parse data constructor in a data/newtype declaration -   | ErrUnpackDataCon+   | PsErrUnpackDataCon       -- ^ UNPACK applied to a data constructor -   | ErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)+   | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)       -- ^ Unexpected kind application in data/newtype declaration -   | ErrInvalidRecordCon !(PatBuilder GhcPs)+   | PsErrInvalidRecordCon !(PatBuilder GhcPs)       -- ^ Not a record constructor -   | ErrIllegalUnboxedStringInPat !(HsLit GhcPs)+   | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)       -- ^ Illegal unboxed string literal in pattern -   | ErrDoNotationInPat+   | PsErrDoNotationInPat       -- ^ Do-notation in pattern -   | ErrIfTheElseInPat+   | PsErrIfTheElseInPat       -- ^ If-then-else syntax in pattern -   | ErrTypeAppInPat-      -- ^ Type-application in pattern--   | ErrLambdaCaseInPat+   | PsErrLambdaCaseInPat       -- ^ Lambda-case in pattern -   | ErrCaseInPat+   | PsErrCaseInPat       -- ^ case..of in pattern -   | ErrLetInPat+   | PsErrLetInPat       -- ^ let-syntax in pattern -   | ErrLambdaInPat+   | PsErrLambdaInPat       -- ^ Lambda-syntax in pattern -   | ErrArrowExprInPat !(HsExpr GhcPs)+   | PsErrArrowExprInPat !(HsExpr GhcPs)       -- ^ Arrow expression-syntax in pattern -   | ErrArrowCmdInPat !(HsCmd GhcPs)+   | PsErrArrowCmdInPat !(HsCmd GhcPs)       -- ^ Arrow command-syntax in pattern -   | ErrArrowCmdInExpr !(HsCmd GhcPs)+   | PsErrArrowCmdInExpr !(HsCmd GhcPs)       -- ^ Arrow command-syntax in expression -   | ErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)+   | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)       -- ^ View-pattern in expression -   | ErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)+   | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)       -- ^ Type-application without space before '@' -   | ErrLazyPatWithoutSpace !(LHsExpr GhcPs)+   | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs)       -- ^ Lazy-pattern ('~') without space after it -   | ErrBangPatWithoutSpace !(LHsExpr GhcPs)+   | PsErrBangPatWithoutSpace !(LHsExpr GhcPs)       -- ^ Bang-pattern ('!') without space after it -   | ErrUnallowedPragma !(HsPragE GhcPs)+   | PsErrUnallowedPragma !(HsPragE GhcPs)       -- ^ Pragma not allowed in this position -   | ErrQualifiedDoInCmd !ModuleName+   | PsErrQualifiedDoInCmd !ModuleName       -- ^ Qualified do block in command -   | ErrInvalidInfixHole+   | PsErrInvalidInfixHole       -- ^ Invalid infix hole, expected an infix operator -   | ErrSemiColonsInCondExpr+   | PsErrSemiColonsInCondExpr       -- ^ Unexpected semi-colons in conditional expression          !(HsExpr GhcPs) -- ^ conditional expr          !Bool           -- ^ "then" semi-colon?@@ -228,7 +226,7 @@          !Bool           -- ^ "else" semi-colon?          !(HsExpr GhcPs) -- ^ "else" expr -   | ErrSemiColonsInCondCmd+   | PsErrSemiColonsInCondCmd       -- ^ Unexpected semi-colons in conditional command          !(HsExpr GhcPs) -- ^ conditional expr          !Bool           -- ^ "then" semi-colon?@@ -236,143 +234,143 @@          !Bool           -- ^ "else" semi-colon?          !(HsCmd GhcPs)  -- ^ "else" expr -   | ErrAtInPatPos+   | PsErrAtInPatPos       -- ^ @-operator in a pattern position -   | ErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)+   | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)       -- ^ Unexpected lambda command in function application -   | ErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)+   | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)       -- ^ Unexpected case command in function application -   | ErrIfCmdInFunAppCmd !(LHsCmd GhcPs)+   | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)       -- ^ Unexpected if command in function application -   | ErrLetCmdInFunAppCmd !(LHsCmd GhcPs)+   | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs)       -- ^ Unexpected let command in function application -   | ErrDoCmdInFunAppCmd !(LHsCmd GhcPs)+   | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs)       -- ^ Unexpected do command in function application -   | ErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)+   | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)       -- ^ Unexpected do block in function application -   | ErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)+   | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)       -- ^ Unexpected mdo block in function application -   | ErrLambdaInFunAppExpr !(LHsExpr GhcPs)+   | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)       -- ^ Unexpected lambda expression in function application -   | ErrCaseInFunAppExpr !(LHsExpr GhcPs)+   | PsErrCaseInFunAppExpr !(LHsExpr GhcPs)       -- ^ Unexpected case expression in function application -   | ErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)+   | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)       -- ^ Unexpected lambda-case expression in function application -   | ErrLetInFunAppExpr !(LHsExpr GhcPs)+   | PsErrLetInFunAppExpr !(LHsExpr GhcPs)       -- ^ Unexpected let expression in function application -   | ErrIfInFunAppExpr !(LHsExpr GhcPs)+   | PsErrIfInFunAppExpr !(LHsExpr GhcPs)       -- ^ Unexpected if expression in function application -   | ErrProcInFunAppExpr !(LHsExpr GhcPs)+   | PsErrProcInFunAppExpr !(LHsExpr GhcPs)       -- ^ Unexpected proc expression in function application -   | ErrMalformedTyOrClDecl !(LHsType GhcPs)+   | PsErrMalformedTyOrClDecl !(LHsType GhcPs)       -- ^ Malformed head of type or class declaration -   | ErrIllegalWhereInDataDecl+   | PsErrIllegalWhereInDataDecl       -- ^ Illegal 'where' keyword in data declaration -   | ErrIllegalDataTypeContext !(LHsContext GhcPs)+   | PsErrIllegalDataTypeContext !(LHsContext GhcPs)       -- ^ Illegal datatyp context -   | ErrParseErrorOnInput !OccName+   | PsErrParseErrorOnInput !OccName       -- ^ Parse error on input -   | ErrMalformedDecl !SDoc !RdrName+   | PsErrMalformedDecl !SDoc !RdrName       -- ^ Malformed ... declaration for ... -   | ErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName+   | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName       -- ^ Unexpected type application in a declaration -   | ErrNotADataCon !RdrName+   | PsErrNotADataCon !RdrName       -- ^ Not a data constructor -   | ErrRecordSyntaxInPatSynDecl !(LPat GhcPs)+   | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs)       -- ^ Record syntax used in pattern synonym declaration -   | ErrEmptyWhereInPatSynDecl !RdrName+   | PsErrEmptyWhereInPatSynDecl !RdrName       -- ^ Empty 'where' clause in pattern-synonym declaration -   | ErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)+   | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)       -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration -   | ErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)+   | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)       -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration -   | ErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)+   | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)       -- ^ Declaration splice not a top-level -   | ErrInferredTypeVarNotAllowed+   | PsErrInferredTypeVarNotAllowed       -- ^ Inferred type variables not allowed here -   | ErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]+   | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]       -- ^ Multiple names in standalone kind signatures -   | ErrIllegalImportBundleForm+   | PsErrIllegalImportBundleForm       -- ^ Illegal import bundle form -   | ErrIllegalRoleName !FastString [Role]+   | PsErrIllegalRoleName !FastString [Role]       -- ^ Illegal role name -   | ErrInvalidTypeSignature !(LHsExpr GhcPs)+   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)       -- ^ Invalid type signature -   | ErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc+   | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc       -- ^ Unexpected type in declaration -   | ErrExpectedHyphen+   | PsErrExpectedHyphen       -- ^ Expected a hyphen -   | ErrSpaceInSCC+   | PsErrSpaceInSCC       -- ^ Found a space in a SCC -   | ErrEmptyDoubleQuotes !Bool-- Is TH on?+   | PsErrEmptyDoubleQuotes !Bool-- Is TH on?       -- ^ Found two single quotes -   | ErrInvalidPackageName !FastString+   | PsErrInvalidPackageName !FastString       -- ^ Invalid package name -   | ErrInvalidRuleActivationMarker+   | PsErrInvalidRuleActivationMarker       -- ^ Invalid rule activation marker -   | ErrLinearFunction+   | PsErrLinearFunction       -- ^ Linear function found but LinearTypes not enabled -   | ErrMultiWayIf+   | PsErrMultiWayIf       -- ^ Multi-way if-expression found but MultiWayIf not enabled -   | ErrExplicitForall !Bool -- is Unicode forall?+   | PsErrExplicitForall !Bool -- is Unicode forall?       -- ^ Explicit forall found but no extension allowing it is enabled -   | ErrIllegalQualifiedDo !SDoc+   | PsErrIllegalQualifiedDo !SDoc       -- ^ Found qualified-do without QualifiedDo enabled -   | ErrCmmParser !CmmParserError+   | PsErrCmmParser !CmmParserError       -- ^ Cmm parser error -   | ErrIllegalTraditionalRecordSyntax !SDoc+   | PsErrIllegalTraditionalRecordSyntax !SDoc       -- ^ Illegal traditional record syntax       --       -- TODO: distinguish errors without using SDoc -   | ErrParseErrorInCmd !SDoc+   | PsErrParseErrorInCmd !SDoc       -- ^ Parse error in command       --       -- TODO: distinguish errors without using SDoc -   | ErrParseErrorInPat !SDoc+   | PsErrParseErrorInPat !SDoc       -- ^ Parse error in pattern       --       -- TODO: distinguish errors without using SDoc@@ -393,6 +391,8 @@    | SuggestLetInDo    | SuggestPatternSynonyms    | SuggestInfixBindMaybeAtPat !RdrName+   | TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors+  data LexErrKind    = LexErrKind_EOF        -- ^ End of input
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -44,9 +44,9 @@    , errMsgReason      = Reason flag    } -pprWarning :: Warning -> ErrMsg+pprWarning :: PsWarning -> ErrMsg pprWarning = \case-   WarnTab loc tc+   PsWarnTab loc tc       -> mkParserWarn Opt_WarnTabs loc $           text "Tab character found here"             <> (if tc == 1@@ -55,7 +55,7 @@             <> text "."             $+$ text "Please use spaces instead." -   WarnTransitionalLayout loc reason+   PsWarnTransitionalLayout loc reason       -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $             text "transitional layout will not be accepted in the future:"             $$ text (case reason of@@ -63,20 +63,20 @@                TransLayout_Pipe  -> "`|' at the same depth as implicit layout block"             ) -   WarnUnrecognisedPragma loc+   PsWarnUnrecognisedPragma loc       -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $             text "Unrecognised pragma" -   WarnHaddockInvalidPos loc+   PsWarnHaddockInvalidPos loc       -> mkParserWarn Opt_WarnInvalidHaddock loc $             text "A Haddock comment cannot appear in this position and will be ignored." -   WarnHaddockIgnoreMulti loc+   PsWarnHaddockIgnoreMulti loc       -> mkParserWarn Opt_WarnInvalidHaddock loc $             text "Multiple Haddock comments for a single entity are not allowed." $$             text "The extraneous comment will be ignored." -   WarnStarBinder loc+   PsWarnStarBinder loc       -> mkParserWarn Opt_WarnStarBinder loc $             text "Found binding occurrence of" <+> quotes (text "*")             <+> text "yet StarIsType is enabled."@@ -84,7 +84,7 @@             <+> text "modules with StarIsType,"          $$ text "    including the definition module, you must qualify it." -   WarnStarIsType loc+   PsWarnStarIsType loc       -> mkParserWarn Opt_WarnStarIsType loc $              text "Using" <+> quotes (text "*")              <+> text "(or its Unicode variant) to mean"@@ -94,7 +94,7 @@           $$ text "Suggested fix: use" <+> quotes (text "Type")            <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." -   WarnImportPreQualified loc+   PsWarnImportPreQualified loc       -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $             text "Found" <+> quotes (text "qualified")              <+> text "in prepositive position"@@ -102,7 +102,7 @@              <+> text "after the module name instead."          $$ text "To allow this, enable language extension 'ImportQualifiedPost'" -   WarnOperatorWhitespaceExtConflict loc sym+   PsWarnOperatorWhitespaceExtConflict loc sym       -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $          let mk_prefix_msg operator_symbol extension_name syntax_meaning =                   text "The prefix use of a" <+> quotes (text operator_symbol)@@ -117,7 +117,7 @@            OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice"  -   WarnOperatorWhitespace loc sym occ_type+   PsWarnOperatorWhitespace loc sym occ_type       -> mkParserWarn Opt_WarnOperatorWhitespace loc $          let mk_msg occ_type_str =                   text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)@@ -130,27 +130,27 @@            OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"            OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: Error -> ErrMsg+pprError :: PsError -> ErrMsg pprError err = mkParserErr (errLoc err) $ vcat    (pp_err (errDesc err) : map pp_hint (errHints err)) -pp_err :: ErrorDesc -> SDoc+pp_err :: PsErrorDesc -> SDoc pp_err = \case-   ErrLambdaCase+   PsErrLambdaCase       -> text "Illegal lambda-case (use LambdaCase)" -   ErrNumUnderscores reason+   PsErrNumUnderscores reason       -> text $ case reason of             NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals"             NumUnderscore_Float    -> "Use NumericUnderscores to allow underscores in floating literals" -   ErrPrimStringInvalidChar+   PsErrPrimStringInvalidChar       -> text "primitive string literal must contain only characters <= \'\\xFF\'" -   ErrMissingBlock+   PsErrMissingBlock       -> text "Missing block" -   ErrLexer err kind+   PsErrLexer err kind       -> hcat          [ text $ case err of             LexError               -> "lexical error"@@ -170,53 +170,53 @@             LexErrKind_Char c -> " at character " ++ show c          ] -   ErrSuffixAT+   PsErrSuffixAT       -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace." -   ErrParse token+   PsErrParse token       | null token       -> text "parse error (possibly incorrect indentation or mismatched brackets)"        | otherwise       -> text "parse error on input" <+> quotes (text token) -   ErrCmmLexer+   PsErrCmmLexer       -> text "Cmm lexical error" -   ErrUnsupportedBoxedSumExpr s+   PsErrUnsupportedBoxedSumExpr s       -> hang (text "Boxed sums not supported:") 2               (pprSumOrTuple Boxed s) -   ErrUnsupportedBoxedSumPat s+   PsErrUnsupportedBoxedSumPat s       -> hang (text "Boxed sums not supported:") 2               (pprSumOrTuple Boxed s) -   ErrUnexpectedQualifiedConstructor v+   PsErrUnexpectedQualifiedConstructor v       -> hang (text "Expected an unqualified type constructor:") 2               (ppr v) -   ErrTupleSectionInPat+   PsErrTupleSectionInPat       -> text "Tuple section in pattern context" -   ErrIllegalBangPattern e+   PsErrIllegalBangPattern e       -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e -   ErrOpFewArgs (StarIsType star_is_type) op+   PsErrOpFewArgs (StarIsType star_is_type) op       -> text "Operator applied to too few arguments:" <+> ppr op          $$ starInfo star_is_type op -   ErrImportQualifiedTwice+   PsErrImportQualifiedTwice       -> text "Multiple occurrences of 'qualified'" -   ErrImportPostQualified+   PsErrImportPostQualified       -> text "Found" <+> quotes (text "qualified")           <+> text "in postpositive position. "          $$ text "To allow this, enable language extension 'ImportQualifiedPost'" -   ErrIllegalExplicitNamespace+   PsErrIllegalExplicitNamespace       -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" -   ErrVarForTyCon name+   PsErrVarForTyCon name       -> text "Expecting a type constructor but found a variable,"            <+> quotes (ppr name) <> text "."          $$ if isSymOcc $ rdrNameOcc name@@ -224,117 +224,114 @@                   <+> text "then enable ExplicitNamespaces and use the 'type' keyword."             else empty -   ErrIllegalPatSynExport+   PsErrIllegalPatSynExport       -> text "Illegal export form (use PatternSynonyms to enable)" -   ErrMalformedEntityString+   PsErrMalformedEntityString       -> text "Malformed entity string" -   ErrDotsInRecordUpdate+   PsErrDotsInRecordUpdate       -> text "You cannot use `..' in a record update" -   ErrPrecedenceOutOfRange i+   PsErrPrecedenceOutOfRange i       -> text "Precedence out of range: " <> int i -   ErrInvalidDataCon t+   PsErrInvalidDataCon t       -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2               (ppr t) -   ErrInvalidInfixDataCon lhs tc rhs+   PsErrInvalidInfixDataCon lhs tc rhs       -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")             2 (ppr lhs <+> ppr tc <+> ppr rhs) -   ErrUnpackDataCon+   PsErrUnpackDataCon       -> text "{-# UNPACK #-} cannot be applied to a data constructor." -   ErrUnexpectedKindAppInDataCon lhs ki+   PsErrUnexpectedKindAppInDataCon lhs ki       -> hang (text "Unexpected kind application in a data/newtype declaration:") 2               (ppr lhs <+> text "@" <> ppr ki) -   ErrInvalidRecordCon p+   PsErrInvalidRecordCon p       -> text "Not a record constructor:" <+> ppr p -   ErrIllegalUnboxedStringInPat lit+   PsErrIllegalUnboxedStringInPat lit       -> text "Illegal unboxed string literal in pattern:" $$ ppr lit -   ErrDoNotationInPat+   PsErrDoNotationInPat       -> text "do-notation in pattern" -   ErrIfTheElseInPat+   PsErrIfTheElseInPat       -> text "(if ... then ... else ...)-syntax in pattern" -   ErrTypeAppInPat-      -> text "Type applications in patterns are not yet supported"--   ErrLambdaCaseInPat+   PsErrLambdaCaseInPat       -> text "(\\case ...)-syntax in pattern" -   ErrCaseInPat+   PsErrCaseInPat       -> text "(case ... of ...)-syntax in pattern" -   ErrLetInPat+   PsErrLetInPat       -> text "(let ... in ...)-syntax in pattern" -   ErrLambdaInPat+   PsErrLambdaInPat       -> text "Lambda-syntax in pattern."          $$ text "Pattern matching on functions is not possible." -   ErrArrowExprInPat e+   PsErrArrowExprInPat e       -> text "Expression syntax in pattern:" <+> ppr e -   ErrArrowCmdInPat c+   PsErrArrowCmdInPat c       -> text "Command syntax in pattern:" <+> ppr c -   ErrArrowCmdInExpr c+   PsErrArrowCmdInExpr c       -> vcat          [ text "Arrow command found where an expression was expected:"          , nest 2 (ppr c)          ] -   ErrViewPatInExpr a b+   PsErrViewPatInExpr a b       -> sep [ text "View pattern in expression context:"              , nest 4 (ppr a <+> text "->" <+> ppr b)              ] -   ErrTypeAppWithoutSpace v e+   PsErrTypeAppWithoutSpace v e       -> sep [ text "@-pattern in expression context:"              , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)              ]          $$ text "Type application syntax requires a space before '@'"  -   ErrLazyPatWithoutSpace e+   PsErrLazyPatWithoutSpace e       -> sep [ text "Lazy pattern in expression context:"              , nest 4 (text "~" <> ppr e)              ]          $$ text "Did you mean to add a space after the '~'?" -   ErrBangPatWithoutSpace e+   PsErrBangPatWithoutSpace e       -> sep [ text "Bang pattern in expression context:"              , nest 4 (text "!" <> ppr e)              ]          $$ text "Did you mean to add a space after the '!'?" -   ErrUnallowedPragma prag+   PsErrUnallowedPragma prag       -> hang (text "A pragma is not allowed in this position:") 2               (ppr prag) -   ErrQualifiedDoInCmd m+   PsErrQualifiedDoInCmd m       -> hang (text "Parse error in command:") 2 $             text "Found a qualified" <+> ppr m <> text ".do block in a command, but"             $$ text "qualified 'do' is not supported in commands." -   ErrParseErrorInCmd s+   PsErrParseErrorInCmd s       -> hang (text "Parse error in command:") 2 s -   ErrParseErrorInPat s+   PsErrParseErrorInPat s       -> text "Parse error in pattern:" <+> s  -   ErrInvalidInfixHole+   PsErrInvalidInfixHole       -> text "Invalid infix hole, expected an infix operator" -   ErrSemiColonsInCondExpr c st t se e+   PsErrSemiColonsInCondExpr c st t se e       -> text "Unexpected semi-colons in conditional:"          $$ nest 4 expr          $$ text "Perhaps you meant to use DoAndIfThenElse?"@@ -345,7 +342,7 @@                    text "then" <+> ppr t <> pprOptSemi se <+>                    text "else" <+> ppr e -   ErrSemiColonsInCondCmd c st t se e+   PsErrSemiColonsInCondCmd c st t se e       -> text "Unexpected semi-colons in conditional:"          $$ nest 4 expr          $$ text "Perhaps you meant to use DoAndIfThenElse?"@@ -357,78 +354,78 @@                    text "else" <+> ppr e  -   ErrAtInPatPos+   PsErrAtInPatPos       -> text "Found a binding for the"          <+> quotes (text "@")          <+> text "operator in a pattern position."          $$ perhaps_as_pat -   ErrLambdaCmdInFunAppCmd a+   PsErrLambdaCmdInFunAppCmd a       -> pp_unexpected_fun_app (text "lambda command") a -   ErrCaseCmdInFunAppCmd a+   PsErrCaseCmdInFunAppCmd a       -> pp_unexpected_fun_app (text "case command") a -   ErrIfCmdInFunAppCmd a+   PsErrIfCmdInFunAppCmd a       -> pp_unexpected_fun_app (text "if command") a -   ErrLetCmdInFunAppCmd a+   PsErrLetCmdInFunAppCmd a       -> pp_unexpected_fun_app (text "let command") a -   ErrDoCmdInFunAppCmd a+   PsErrDoCmdInFunAppCmd a       -> pp_unexpected_fun_app (text "do command") a -   ErrDoInFunAppExpr m a+   PsErrDoInFunAppExpr m a       -> pp_unexpected_fun_app (prependQualified m (text "do block")) a -   ErrMDoInFunAppExpr m a+   PsErrMDoInFunAppExpr m a       -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a -   ErrLambdaInFunAppExpr a+   PsErrLambdaInFunAppExpr a       -> pp_unexpected_fun_app (text "lambda expression") a -   ErrCaseInFunAppExpr a+   PsErrCaseInFunAppExpr a       -> pp_unexpected_fun_app (text "case expression") a -   ErrLambdaCaseInFunAppExpr a+   PsErrLambdaCaseInFunAppExpr a       -> pp_unexpected_fun_app (text "lambda-case expression") a -   ErrLetInFunAppExpr a+   PsErrLetInFunAppExpr a       -> pp_unexpected_fun_app (text "let expression") a -   ErrIfInFunAppExpr a+   PsErrIfInFunAppExpr a       -> pp_unexpected_fun_app (text "if expression") a -   ErrProcInFunAppExpr a+   PsErrProcInFunAppExpr a       -> pp_unexpected_fun_app (text "proc expression") a -   ErrMalformedTyOrClDecl ty+   PsErrMalformedTyOrClDecl ty       -> text "Malformed head of type or class declaration:"          <+> ppr ty -   ErrIllegalWhereInDataDecl+   PsErrIllegalWhereInDataDecl       -> vcat             [ text "Illegal keyword 'where' in data declaration"             , text "Perhaps you intended to use GADTs or a similar language"             , text "extension to enable syntax: data T where"             ] -   ErrIllegalTraditionalRecordSyntax s+   PsErrIllegalTraditionalRecordSyntax s       -> text "Illegal record syntax (use TraditionalRecordSyntax):"          <+> s -   ErrParseErrorOnInput occ+   PsErrParseErrorOnInput occ       -> text "parse error on input" <+> ftext (occNameFS occ) -   ErrIllegalDataTypeContext c+   PsErrIllegalDataTypeContext c       -> text "Illegal datatype context (use DatatypeContexts):"          <+> pprLHsContext c -   ErrMalformedDecl what for+   PsErrMalformedDecl what for       -> text "Malformed" <+> what          <+> text "declaration for" <+> quotes (ppr for) -   ErrUnexpectedTypeAppInDecl ki what for+   PsErrUnexpectedTypeAppInDecl ki what for       -> vcat [ text "Unexpected type application"                 <+> text "@" <> ppr ki               , text "In the" <+> what@@ -436,35 +433,35 @@                 <+> quotes (ppr for)               ] -   ErrNotADataCon name+   PsErrNotADataCon name       -> text "Not a data constructor:" <+> quotes (ppr name) -   ErrRecordSyntaxInPatSynDecl pat+   PsErrRecordSyntaxInPatSynDecl pat       -> text "record syntax not supported for pattern synonym declarations:"          $$ ppr pat -   ErrEmptyWhereInPatSynDecl patsyn_name+   PsErrEmptyWhereInPatSynDecl patsyn_name       -> text "pattern synonym 'where' clause cannot be empty"          $$ text "In the pattern synonym declaration for: "             <+> ppr (patsyn_name) -   ErrInvalidWhereBindInPatSynDecl patsyn_name decl+   PsErrInvalidWhereBindInPatSynDecl patsyn_name decl       -> text "pattern synonym 'where' clause must bind the pattern synonym's name"          <+> quotes (ppr patsyn_name) $$ ppr decl -   ErrNoSingleWhereBindInPatSynDecl _patsyn_name decl+   PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl       -> text "pattern synonym 'where' clause must contain a single binding:"          $$ ppr decl -   ErrDeclSpliceNotAtTopLevel d+   PsErrDeclSpliceNotAtTopLevel d       -> hang (text "Declaration splices are allowed only"                <+> text "at the top level:")            2 (ppr d) -   ErrInferredTypeVarNotAllowed+   PsErrInferredTypeVarNotAllowed       -> text "Inferred type variables are not allowed here" -   ErrIllegalRoleName role nearby+   PsErrIllegalRoleName role nearby       -> text "Illegal role name" <+> quotes (ppr role)          $$ case nearby of              []  -> empty@@ -473,17 +470,17 @@              _   -> hang (text "Perhaps you meant one of these:")                          2 (pprWithCommas (quotes . ppr) nearby) -   ErrMultipleNamesInStandaloneKindSignature vs+   PsErrMultipleNamesInStandaloneKindSignature vs       -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")                 2 (pprWithCommas ppr vs)               , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."               ] -   ErrIllegalImportBundleForm+   PsErrIllegalImportBundleForm       -> text "Illegal import form, this syntax can only be used to bundle"          $+$ text "pattern synonyms with types in module exports." -   ErrInvalidTypeSignature lhs+   PsErrInvalidTypeSignature lhs       -> text "Invalid type signature:"          <+> ppr lhs          <+> text ":: ..."@@ -510,7 +507,7 @@          default_RDR = mkUnqual varName (fsLit "default")          pattern_RDR = mkUnqual varName (fsLit "pattern") -   ErrUnexpectedTypeInDecl t what tc tparms equals_or_where+   PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where       -> vcat [ text "Unexpected type" <+> quotes (ppr t)               , text "In the" <+> what                 <+> ptext (sLit "declaration for") <+> quotes tc'@@ -527,20 +524,20 @@             -- wrote). See #14907             tc' = ppr $ filterCTuple tc -   ErrCmmParser cmm_err -> case cmm_err of+   PsErrCmmParser cmm_err -> case cmm_err of       CmmUnknownPrimitive name     -> text "unknown primitive" <+> ftext name       CmmUnknownMacro fun          -> text "unknown macro" <+> ftext fun       CmmUnknownCConv cconv        -> text "unknown calling convention:" <+> text cconv       CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety       CmmUnrecognisedHint hint     -> text "unrecognised hint:" <+> text hint -   ErrExpectedHyphen+   PsErrExpectedHyphen       -> text "Expected a hyphen" -   ErrSpaceInSCC+   PsErrSpaceInSCC       -> text "Spaces are not allowed in SCCs" -   ErrEmptyDoubleQuotes th_on+   PsErrEmptyDoubleQuotes th_on       -> if th_on then vcat (msg ++ th_msg) else vcat msg          where             msg    = [ text "Parser error on `''`"@@ -550,23 +547,23 @@                      , text "but the type variable or constructor is missing"                      ] -   ErrInvalidPackageName pkg+   PsErrInvalidPackageName pkg       -> vcat             [ text "Parse error" <> colon <+> quotes (ftext pkg)             , text "Version number or non-alphanumeric" <+>               text "character in package name"             ] -   ErrInvalidRuleActivationMarker+   PsErrInvalidRuleActivationMarker       -> text "Invalid rule activation marker" -   ErrLinearFunction+   PsErrLinearFunction       -> text "Enable LinearTypes to allow linear functions" -   ErrMultiWayIf+   PsErrMultiWayIf       -> text "Multi-way if-expressions need MultiWayIf turned on" -   ErrExplicitForall is_unicode+   PsErrExplicitForall is_unicode       -> vcat          [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"          , text "Perhaps you intended to use RankNTypes or a similar language"@@ -577,7 +574,7 @@           forallSym True  = text "∀"           forallSym False = text "forall" -   ErrIllegalQualifiedDo qdoDoc+   PsErrIllegalQualifiedDo qdoDoc       -> vcat          [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"          , text "Perhaps you intended to use QualifiedDo"@@ -607,6 +604,8 @@          $$ if opIsAt fun                then perhaps_as_pat                else empty+   TypeApplicationsInPatternsOnlyDataCons ->+     text "Type applications in patterns are only allowed on data constructors."  perhaps_as_pat :: SDoc perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
compiler/GHC/Parser/Header.hs view
@@ -73,7 +73,7 @@            -> FilePath     -- ^ The original source filename (used for locations                            --   in the function result)            -> IO (Either-               (Bag Error)+               (Bag PsError)                ([(Maybe FastString, Located ModuleName)],                 [(Maybe FastString, Located ModuleName)],                 Located ModuleName))@@ -129,11 +129,15 @@   = []   | otherwise = [preludeImportDecl]   where-      explicit_prelude_import-       = notNull [ () | L _ (ImportDecl { ideclName = mod-                                        , ideclPkgQual = Nothing })-                          <- import_decls-                      , unLoc mod == pRELUDE_NAME ]+      explicit_prelude_import = any is_prelude_import import_decls++      is_prelude_import (L _ decl) =+        unLoc (ideclName decl) == pRELUDE_NAME+        -- allow explicit "base" package qualifier (#19082, #17045)+        && case ideclPkgQual decl of+            Nothing -> True+            Just b  -> sl_fs b == unitIdFS baseUnitId+        preludeImportDecl :: LImportDecl GhcPs       preludeImportDecl
compiler/GHC/Parser/PostProcess.hs view
@@ -260,12 +260,12 @@     check_lhs_name v@(unLoc->name) =       if isUnqual name && isTcOcc (rdrNameOcc name)       then return v-      else addFatalError $ Error (ErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v)+      else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v)     check_singular_lhs vs =       case vs of         [] -> panic "mkStandaloneKindSig: empty left-hand side"         [v] -> return v-        _ -> addFatalError $ Error (ErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)+        _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)  mkTyFamInstEqn :: HsOuterFamEqnTyVarBndrs GhcPs                -> LHsType GhcPs@@ -374,7 +374,7 @@             let nearby = fuzzyLookup (unpackFS role)                   (mapFst unpackFS possible_roles)             in-            addFatalError $ Error (ErrIllegalRoleName role nearby) [] loc_role+            addFatalError $ PsError (PsErrIllegalRoleName role nearby) [] loc_role  -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if@@ -394,7 +394,7 @@   where     check_spec :: Specificity -> SrcSpan -> P ()     check_spec SpecifiedSpec _   = return ()-    check_spec InferredSpec  loc = addFatalError $ Error ErrInferredTypeVarNotAllowed [] loc+    check_spec InferredSpec  loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] loc  {- ********************************************************************** @@ -445,7 +445,7 @@     -- called on top-level declarations.     drop_bad_decls [] = return []     drop_bad_decls (L l (SpliceD _ d) : ds) = do-      addError $ Error (ErrDeclSpliceNotAtTopLevel d) [] l+      addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] l       drop_bad_decls ds     drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -550,14 +550,14 @@ -- | Reinterpret a type constructor, including type operators, as a data --   constructor. -- See Note [Parsing data constructors is hard]-tyConToDataCon :: SrcSpan -> RdrName -> Either Error (Located RdrName)+tyConToDataCon :: SrcSpan -> RdrName -> Either PsError (Located RdrName) tyConToDataCon loc tc   | isTcOcc occ || isDataOcc occ   , isLexCon (occNameFS occ)   = return (L loc (setRdrNameSpace tc srcDataName))    | otherwise-  = Left $ Error (ErrNotADataCon tc) [] loc+  = Left $ PsError (PsErrNotADataCon tc) [] loc   where     occ = rdrNameOcc tc @@ -575,9 +575,9 @@         do { unless (name == patsyn_name) $                wrongNameBindingErr loc decl            ; match <- case details of-               PrefixCon pats -> return $ Match { m_ext = noExtField-                                                , m_ctxt = ctxt, m_pats = pats-                                                , m_grhss = rhs }+               PrefixCon _ pats -> return $ Match { m_ext = noExtField+                                                  , m_ctxt = ctxt, m_pats = pats+                                                  , m_grhss = rhs }                    where                      ctxt = FunRhs { mc_fun = ln                                    , mc_fixity = Prefix@@ -597,17 +597,17 @@     fromDecl (L loc decl) = extraDeclErr loc decl      extraDeclErr loc decl =-        addFatalError $ Error (ErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc+        addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc      wrongNameBindingErr loc decl =-      addFatalError $ Error (ErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc+      addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc      wrongNumberErr loc =-      addFatalError $ Error (ErrEmptyWhereInPatSynDecl patsyn_name) [] loc+      addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc  recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat =-    addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc+    addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc  mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]                 -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs@@ -737,7 +737,7 @@ really doesn't matter! -} -eitherToP :: MonadP m => Either Error a -> m a+eitherToP :: MonadP m => Either PsError a -> m a -- Adapts the Either monad to the P monad eitherToP (Left err)    = addFatalError err eitherToP (Right thing) = return thing@@ -751,9 +751,9 @@   = do { (tvs, anns) <- fmap unzip $ mapM check tparms        ; return (mkHsQTvs tvs, concat anns) }   where-    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ Error (ErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc+    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc     check (HsValArg ty) = chkParens [] ty-    check (HsArgPar sp) = addFatalError $ Error (ErrMalformedDecl pp_what (unLoc tc)) [] sp+    check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp         -- Keep around an action for adjusting the annotations of extra parens     chkParens :: [AddAnn] -> LHsType GhcPs               -> P (LHsTyVarBndr () GhcPs, [AddAnn])@@ -769,7 +769,7 @@     chk (L l (HsTyVar _ _ (L ltv tv)))         | isRdrTyVar tv    = return (L l (UserTyVar noExtField () (L ltv tv)))     chk t@(L loc _)-        = addFatalError $ Error (ErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc+        = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc   whereDots, equalsDots :: SDoc@@ -781,7 +781,7 @@ checkDatatypeContext Nothing = return () checkDatatypeContext (Just c)     = do allowed <- getBit DatatypeContextsBit-         unless allowed $ addError $ Error (ErrIllegalDataTypeContext c) [] (getLoc c)+         unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLoc c)  type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))@@ -811,13 +811,13 @@   where check (L loc (Unqual occ)) =           -- TODO: don't use string here, OccName has a Unique/FastString           when ((occNameString occ ==) `any` ["forall","family","role"])-            (addFatalError $ Error (ErrParseErrorOnInput occ) [] loc)+            (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] loc)         check _ = panic "checkRuleTyVarBndrNames"  checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax lr@(L loc r)     = do allowed <- getBit TraditionalRecordSyntaxBit-         unless allowed $ addError $ Error (ErrIllegalTraditionalRecordSyntax (ppr r)) [] loc+         unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] loc          return lr  -- | Check if the gadt_constrlist is empty. Only raise parse error for@@ -826,7 +826,7 @@                 -> P (Located ([AddAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.     = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax-         unless gadtSyntax $ addError $ Error ErrIllegalWhereInDataDecl [] span+         unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span          return gadts checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration. @@ -848,7 +848,7 @@      -- workaround to define '*' despite StarIsType     go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix-      = do { addWarning Opt_WarnStarBinder (WarnStarBinder l)+      = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder l)            ; let name = mkOccName tcClsName (starSym isUni)            ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } @@ -867,7 +867,7 @@                  | otherwise = getName (tupleTyCon Boxed arity)           -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)     go l _ _ _ _-      = addFatalError $ Error (ErrMalformedTyOrClDecl ty) [] l+      = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l  -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled.@@ -877,29 +877,29 @@   where     checkExpr :: LHsExpr GhcPs -> PV ()     checkExpr expr = case unLoc expr of-      HsDo _ (DoExpr m) _  -> check (ErrDoInFunAppExpr m)     expr-      HsDo _ (MDoExpr m) _ -> check (ErrMDoInFunAppExpr m)    expr-      HsLam {}             -> check ErrLambdaInFunAppExpr     expr-      HsCase {}            -> check ErrCaseInFunAppExpr       expr-      HsLamCase {}         -> check ErrLambdaCaseInFunAppExpr expr-      HsLet {}             -> check ErrLetInFunAppExpr        expr-      HsIf {}              -> check ErrIfInFunAppExpr         expr-      HsProc {}            -> check ErrProcInFunAppExpr       expr+      HsDo _ (DoExpr m) _  -> check (PsErrDoInFunAppExpr m)     expr+      HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m)    expr+      HsLam {}             -> check PsErrLambdaInFunAppExpr     expr+      HsCase {}            -> check PsErrCaseInFunAppExpr       expr+      HsLamCase {}         -> check PsErrLambdaCaseInFunAppExpr expr+      HsLet {}             -> check PsErrLetInFunAppExpr        expr+      HsIf {}              -> check PsErrIfInFunAppExpr         expr+      HsProc {}            -> check PsErrProcInFunAppExpr       expr       _                    -> return ()      checkCmd :: LHsCmd GhcPs -> PV ()     checkCmd cmd = case unLoc cmd of-      HsCmdLam {}  -> check ErrLambdaCmdInFunAppCmd cmd-      HsCmdCase {} -> check ErrCaseCmdInFunAppCmd   cmd-      HsCmdIf {}   -> check ErrIfCmdInFunAppCmd     cmd-      HsCmdLet {}  -> check ErrLetCmdInFunAppCmd    cmd-      HsCmdDo {}   -> check ErrDoCmdInFunAppCmd     cmd+      HsCmdLam {}  -> check PsErrLambdaCmdInFunAppCmd cmd+      HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd   cmd+      HsCmdIf {}   -> check PsErrIfCmdInFunAppCmd     cmd+      HsCmdLet {}  -> check PsErrLetCmdInFunAppCmd    cmd+      HsCmdDo {}   -> check PsErrDoCmdInFunAppCmd     cmd       _            -> return ()      check err a = do       blockArguments <- getBit BlockArgumentsBit       unless blockArguments $-        addError $ Error (err a) [] (getLoc a)+        addError $ PsError (err a) [] (getLoc a)  -- | Validate the context constraints and break up a context into a list -- of predicates.@@ -966,27 +966,31 @@ checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)  checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)-checkLPat e@(L l _) = checkPat l e []+checkLPat e@(L l _) = checkPat l e [] [] -checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]+checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs]          -> PV (LPat GhcPs)-checkPat loc (L l e@(PatBuilderVar (L _ c))) args+checkPat loc (L l e@(PatBuilderVar (L _ c))) tyargs args   | isRdrDataCon c = return . L loc $ ConPat       { pat_con_ext = noExtField       , pat_con = L l c-      , pat_args = PrefixCon args+      , pat_args = PrefixCon tyargs args       }+  | not (null tyargs) =+      add_hint TypeApplicationsInPatternsOnlyDataCons $+      patFail l (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs])   | not (null args) && patIsRec c =       add_hint SuggestRecursiveDo $       patFail l (ppr e)-checkPat loc (L _ (PatBuilderApp f e)) args-  = do p <- checkLPat e-       checkPat loc f (p : args)-checkPat loc (L _ e) []-  = do p <- checkAPat loc e-       return (L loc p)-checkPat loc e _-  = patFail loc (ppr e)+checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = do+  checkPat loc f (t : tyargs) args+checkPat loc (L _ (PatBuilderApp f e)) [] args = do+  p <- checkLPat e+  checkPat loc f [] (p : args)+checkPat loc (L _ e) [] [] = do+  p <- checkAPat loc e+  return (L loc p)+checkPat loc e _ _ = patFail loc (ppr e)  checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do@@ -1010,7 +1014,7 @@     -- Improve error messages for the @-operator when the user meant an @-pattern    PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do-     addError $ Error ErrAtInPatPos [] (getLoc op)+     addError $ PsError PsErrAtInPatPos [] (getLoc op)      return (WildPat noExtField)     PatBuilderOpApp l (L cl c) r@@ -1042,7 +1046,7 @@                              return (L l (fld { hsRecFieldArg = p }))  patFail :: SrcSpan -> SDoc -> PV a-patFail loc e = addFatalError $ Error (ErrParseErrorInPat e) [] loc+patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc  patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec")@@ -1134,11 +1138,11 @@   = return lrdr  checkValSigLhs lhs@(L l _)-  = addFatalError $ Error (ErrInvalidTypeSignature lhs) [] l+  = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] l  checkDoAndIfThenElse   :: (Outputable a, Outputable b, Outputable c)-  => (a -> Bool -> b -> Bool -> c -> ErrorDesc)+  => (a -> Bool -> b -> Bool -> c -> PsErrorDesc)   -> Located a -> Bool -> Located b -> Bool -> Located c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr  | semiThen || semiElse = do@@ -1148,7 +1152,7 @@                     semiElse (unLoc elseExpr)           loc = combineLocs guardExpr elseExpr -      unless doAndIfThenElse $ addError (Error e [] loc)+      unless doAndIfThenElse $ addError (PsError e [] loc)   | otherwise = return ()  isFunLhs :: Located (PatBuilder GhcPs)@@ -1255,7 +1259,7 @@ instance DisambInfixOp RdrName where   mkHsConOpPV (L l v) = return $ L l v   mkHsVarOpPV (L l v) = return $ L l v-  mkHsInfixHolePV l   = addFatalError $ Error ErrInvalidInfixHole [] l+  mkHsInfixHolePV l   = addFatalError $ PsError PsErrInvalidInfixHole [] l  -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are -- parsing an expression, a command, or a pattern.@@ -1411,10 +1415,10 @@     return $ L l (HsCmdApp noExtField c e)   mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t)   mkHsIfPV l c semi1 a semi2 b = do-    checkDoAndIfThenElse ErrSemiColonsInCondCmd c semi1 a semi2 b+    checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b     return $ L l (mkHsCmdIf c a b)   mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts)-  mkHsDoPV l (Just m)    _ = addFatalError $ Error (ErrQualifiedDoInCmd m) [] l+  mkHsDoPV l (Just m)    _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l   mkHsParPV l c = return $ L l (HsCmdPar noExtField c)   mkHsVarPV (L l v) = cmdFail l (ppr v)   mkHsLitPV (L l a) = cmdFail l (ppr a)@@ -1443,12 +1447,12 @@   rejectPragmaPV _ = return ()  cmdFail :: SrcSpan -> SDoc -> PV a-cmdFail loc e = addFatalError $ Error (ErrParseErrorInCmd e) [] loc+cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc  instance DisambECP (HsExpr GhcPs) where   type Body (HsExpr GhcPs) = HsExpr   ecpFromCmd' (L l c) = do-    addError $ Error (ErrArrowCmdInExpr c) [] l+    addError $ PsError (PsErrArrowCmdInExpr c) [] l     return (L l hsHoleExpr)   ecpFromExp' = return   mkHsLamPV l mg = return $ L l (HsLam noExtField mg)@@ -1469,7 +1473,7 @@     checkExpBlockArguments e     return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t))   mkHsIfPV l c semi1 a semi2 b = do-    checkDoAndIfThenElse ErrSemiColonsInCondExpr c semi1 a semi2 b+    checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b     return $ L l (mkHsIf c a b)   mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts)   mkHsParPV l e = return $ L l (HsPar noExtField e)@@ -1485,19 +1489,19 @@     checkRecordSyntax (L l r)   mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)   mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)-  mkHsViewPatPV l a b = addError (Error (ErrViewPatInExpr a b) [] l)+  mkHsViewPatPV l a b = addError (PsError (PsErrViewPatInExpr a b) [] l)                         >> return (L l hsHoleExpr)-  mkHsAsPatPV l v e   = addError (Error (ErrTypeAppWithoutSpace (unLoc v) e) [] l)+  mkHsAsPatPV l v e   = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l)                         >> return (L l hsHoleExpr)-  mkHsLazyPatPV l e   = addError (Error (ErrLazyPatWithoutSpace e) [] l)+  mkHsLazyPatPV l e   = addError (PsError (PsErrLazyPatWithoutSpace e) [] l)                         >> return (L l hsHoleExpr)-  mkHsBangPatPV l e   = addError (Error (ErrBangPatWithoutSpace e) [] l)+  mkHsBangPatPV l e   = addError (PsError (PsErrBangPatWithoutSpace e) [] l)                         >> return (L l hsHoleExpr)   mkSumOrTuplePV = mkSumOrTupleExpr   rejectPragmaPV (L _ (OpApp _ _ _ e)) =     -- assuming left-associative parsing of operators     rejectPragmaPV e-  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ Error (ErrUnallowedPragma prag) [] l+  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] l   rejectPragmaPV _                        = return ()  hsHoleExpr :: HsExpr GhcPs@@ -1505,21 +1509,21 @@  instance DisambECP (PatBuilder GhcPs) where   type Body (PatBuilder GhcPs) = PatBuilder-  ecpFromCmd' (L l c)    = addFatalError $ Error (ErrArrowCmdInPat c) [] l-  ecpFromExp' (L l e)    = addFatalError $ Error (ErrArrowExprInPat e) [] l-  mkHsLamPV l _          = addFatalError $ Error ErrLambdaInPat [] l-  mkHsLetPV l _ _        = addFatalError $ Error ErrLetInPat [] l+  ecpFromCmd' (L l c)    = addFatalError $ PsError (PsErrArrowCmdInPat c) [] l+  ecpFromExp' (L l e)    = addFatalError $ PsError (PsErrArrowExprInPat e) [] l+  mkHsLamPV l _          = addFatalError $ PsError PsErrLambdaInPat [] l+  mkHsLetPV l _ _        = addFatalError $ PsError PsErrLetInPat [] l   type InfixOp (PatBuilder GhcPs) = RdrName   superInfixOp m = m   mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2-  mkHsCasePV l _ _       = addFatalError $ Error ErrCaseInPat [] l-  mkHsLamCasePV l _      = addFatalError $ Error ErrLambdaCaseInPat [] l+  mkHsCasePV l _ _       = addFatalError $ PsError PsErrCaseInPat [] l+  mkHsLamCasePV l _      = addFatalError $ PsError PsErrLambdaCaseInPat [] l   type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs   superFunArg m = m   mkHsAppPV l p1 p2     = return $ L l (PatBuilderApp p1 p2)-  mkHsAppTypePV l _ _   = addFatalError $ Error ErrTypeAppInPat [] l-  mkHsIfPV l _ _ _ _ _  = addFatalError $ Error ErrIfTheElseInPat [] l-  mkHsDoPV l _ _        = addFatalError $ Error ErrDoNotationInPat [] l+  mkHsAppTypePV l p t   = return $ L l (PatBuilderAppType p (mkHsPatSigType t))+  mkHsIfPV l _ _ _ _ _  = addFatalError $ PsError PsErrIfTheElseInPat [] l+  mkHsDoPV l _ _        = addFatalError $ PsError PsErrDoNotationInPat [] l   mkHsParPV l p         = return $ L l (PatBuilderPar p)   mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)   mkHsLitPV lit@(L l a) = do@@ -1564,7 +1568,7 @@ checkUnboxedStringLitPat (L loc lit) =   case lit of     HsStringPrim _ _  -- Trac #13260-      -> addFatalError $ Error (ErrIllegalUnboxedStringInPat lit) [] loc+      -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc     _ -> return ()  mkPatRec ::@@ -1580,7 +1584,7 @@          , pat_args = RecCon (HsRecFields fs dd)          } mkPatRec p _ =-  addFatalError $ Error (ErrInvalidRecordCon (unLoc p)) [] (getLoc p)+  addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLoc p)  -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor.@@ -1625,7 +1629,7 @@  -- Normal prefix constructor, e.g.  data T = MkT A B C dataConBuilderDetails (PrefixDataConBuilder flds _)-  = PrefixCon (map hsLinear (toList flds))+  = PrefixCon noTypeArgs (map hsLinear (toList flds))  -- Infix constructor, e.g. data T = Int :! Bool dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)@@ -1644,7 +1648,7 @@     panic "mkHsAppTyPV: InfixDataConBuilder"    mkHsAppKindTyPV lhs l_at ki =-    addFatalError $ Error (ErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at+    addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at    mkHsOpTyPV lhs (L l_tc tc) rhs = do       check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative@@ -1654,7 +1658,7 @@       l = combineLocs lhs rhs       check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)       check_no_ops (HsOpTy{}) =-        addError $ Error (ErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l+        addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l       check_no_ops _ = return ()    mkUnpackednessPV unpk constr_stuff@@ -1665,7 +1669,7 @@          let l = combineLocs unpk constr_stuff          return $ L l (InfixDataConBuilder lhs' data_con rhs)     | otherwise =-      do addError $ Error ErrUnpackDataCon [] (getLoc unpk)+      do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk)          return constr_stuff  tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder)@@ -1676,7 +1680,7 @@   let data_con = L l (getRdrName (tupleDataCon Boxed (length ts)))   return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t =-  addFatalError $ Error (ErrInvalidDataCon (unLoc t)) [] (getLoc t)+  addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLoc t)  {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2125,7 +2129,7 @@ checkPrecP (L l (_,i)) (L _ ol)  | 0 <= i, i <= maxPrecedence = pure ()  | all specialOp ol = pure ()- | otherwise = addFatalError $ Error (ErrPrecedenceOutOfRange i) [] l+ | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l   where     -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs     specialOp op = unLoc op `elem` [ eqTyCon_RDR@@ -2141,7 +2145,7 @@   | isRdrDataCon c   = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp _ (fs,dd)-  | Just dd_loc <- dd = addFatalError $ Error ErrDotsInRecordUpdate [] dd_loc+  | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc   | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))  mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs@@ -2205,7 +2209,7 @@     mkCImport = do       let e = unpackFS entity       case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of-        Nothing         -> addFatalError $ Error ErrMalformedEntityString [] loc+        Nothing         -> addFatalError $ PsError PsErrMalformedEntityString [] loc         Just importSpec -> returnSpec importSpec      -- currently, all the other import conventions only support a symbol name in@@ -2331,7 +2335,7 @@     ImpExpAll          -> IEThingAll noExtField . L l <$> nameT     ImpExpList xs      ->       (\newName -> IEThingWith noExtField (L l newName)-        NoIEWildcard (wrapped xs) []) <$> nameT+        NoIEWildcard (wrapped xs)) <$> nameT     ImpExpAllWith xs                       ->       do allowed <- getBit PatternSynonymsBit          if allowed@@ -2341,14 +2345,14 @@                           (findIndex isImpExpQcWildcard withs)                 ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs             in (\newName-                        -> IEThingWith noExtField (L l newName) pos ies [])+                        -> IEThingWith noExtField (L l newName) pos ies)                <$> nameT-          else addFatalError $ Error ErrIllegalPatSynExport [] l+          else addFatalError $ PsError PsErrIllegalPatSynExport [] l   where     name = ieNameVal specname     nameT =       if isVarNameSpace (rdrNameSpace name)-        then addFatalError $ Error (ErrVarForTyCon name) [] l+        then addFatalError $ PsError (PsErrVarForTyCon name) [] l         else return $ ieNameFromSpec specname      ieNameVal (ImpExpQcName ln)  = unLoc ln@@ -2365,17 +2369,17 @@              -> P (Located RdrName) mkTypeImpExp name =   do allowed <- getBit ExplicitNamespacesBit-     unless allowed $ addError $ Error ErrIllegalExplicitNamespace [] (getLoc name)+     unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLoc name)      return (fmap (`setRdrNameSpace` tcClsName) name)  checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) checkImportSpec ie@(L _ specs) =-    case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of+    case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of       [] -> return ie       (l:_) -> importSpecError l   where     importSpecError l =-      addFatalError $ Error ErrIllegalImportBundleForm [] l+      addFatalError $ PsError PsErrIllegalImportBundleForm [] l  -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)@@ -2396,21 +2400,21 @@  warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span =-  addWarning Opt_WarnPrepositiveQualifiedModule (WarnImportPreQualified span)+  addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span)  failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()-failOpNotEnabledImportQualifiedPost loc = addError $ Error ErrImportPostQualified [] loc+failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc  failOpImportQualifiedTwice :: SrcSpan -> P ()-failOpImportQualifiedTwice loc = addError $ Error ErrImportQualifiedTwice [] loc+failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc  warnStarIsType :: SrcSpan -> P ()-warnStarIsType span = addWarning Opt_WarnStarIsType (WarnStarIsType span)+warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span)  failOpFewArgs :: MonadP m => Located RdrName -> m a failOpFewArgs (L loc op) =   do { star_is_type <- getBit StarIsTypeBit-     ; addFatalError $ Error (ErrOpFewArgs (StarIsType star_is_type) op) [] loc }+     ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] loc }  ----------------------------------------------------------------------------- -- Misc utils@@ -2423,8 +2427,8 @@  data PV_Accum =   PV_Accum-    { pv_warnings :: Bag Warning-    , pv_errors   :: Bag Error+    { pv_warnings :: Bag PsWarning+    , pv_errors   :: Bag PsError     , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]     , pv_comment_q :: [RealLocated AnnotationComment]     , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]@@ -2499,10 +2503,10 @@   PV (\ctx acc -> unPV m (modifyHint ctx) acc)  instance MonadP PV where-  addError err@(Error e hints loc) =+  addError err@(PsError e hints loc) =     PV $ \ctx acc ->       let err' | null (pv_hints ctx) = err-               | otherwise           = Error e (hints ++ pv_hints ctx) loc+               | otherwise           = PsError e (hints ++ pv_hints ctx) loc       in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} ()   addWarning option w =     PV $ \ctx acc ->@@ -2576,7 +2580,7 @@ hintBangPat span e = do     bang_on <- getBit BangPatBit     unless bang_on $-      addError $ Error (ErrIllegalBangPattern e) [] span+      addError $ PsError (PsErrIllegalBangPattern e) [] span  mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) @@ -2591,7 +2595,7 @@ mkSumOrTupleExpr l Unboxed (Sum alt arity e) =     return $ L l (ExplicitSum noExtField alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} =-    addFatalError $ Error (ErrUnsupportedBoxedSumExpr a) [] l+    addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] l  mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) @@ -2602,7 +2606,7 @@   where     toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)     toTupPat (L l p) = case p of-      Nothing -> addFatalError $ Error ErrTupleSectionInPat [] l+      Nothing -> addFatalError $ PsError PsErrTupleSectionInPat [] l       Just p' -> checkLPat p'  -- Sum@@ -2610,7 +2614,7 @@    p' <- checkLPat p    return $ L l (PatBuilderPat (SumPat noExtField p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} =-    addFatalError $ Error (ErrUnsupportedBoxedSumPat a) [] l+    addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] l  mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y =
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -192,9 +192,9 @@  reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L l _)) =-  addWarning Opt_WarnInvalidHaddock $ WarnHaddockInvalidPos (mkSrcSpanPs l)+  addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockInvalidPos (mkSrcSpanPs l) reportHdkWarning (HdkWarnExtraComment (L l _)) =-  addWarning Opt_WarnInvalidHaddock $ WarnHaddockIgnoreMulti l+  addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockIgnoreMulti l  collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =@@ -708,13 +708,13 @@       ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->         addConTrailingDoc (srcSpanEnd l_con_decl) $         case con_args of-          PrefixCon ts -> do+          PrefixCon _ ts -> do             con_doc' <- getConDoc (getLoc con_name)             ts' <- traverse addHaddockConDeclFieldTy ts             pure $ L l_con_decl $               ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,                            con_doc = con_doc',-                           con_args = PrefixCon ts' }+                           con_args = PrefixCon noTypeArgs ts' }           InfixCon t1 t2 -> do             t1' <- addHaddockConDeclFieldTy t1             con_doc' <- getConDoc (getLoc con_name)@@ -865,9 +865,9 @@                     doc <- selectDocString trailingDocs                     return $ L l' (con_fld { cd_fld_doc = doc })               con_args' <- case con_args con_decl of-                x@(PrefixCon [])    -> x <$ reportExtraDocs trailingDocs+                x@(PrefixCon _ [])  -> x <$ reportExtraDocs trailingDocs                 x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs-                PrefixCon ts -> PrefixCon <$> mapLastM mk_doc_ty ts+                PrefixCon _ ts -> PrefixCon noTypeArgs <$> mapLastM mk_doc_ty ts                 InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2                 RecCon (L l_rec flds) -> do                   flds' <- mapLastM mk_doc_fld flds@@ -1491,8 +1491,8 @@ flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =   -- 'cmpBufSpan' is safe here with the following assumptions:   ---  -- * 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'-  -- * 'partitionBindsAndSigs' does not discard this 'BufSpan'+  -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'+  -- - 'partitionBindsAndSigs' does not discard this 'BufSpan'   mergeListsBy cmpBufSpan [     mapLL (\b -> ValD noExtField b) (bagToList all_bs),     mapLL (\s -> SigD noExtField s) all_ss,
compiler/GHC/Parser/Types.hs view
@@ -41,12 +41,13 @@         Boxed -> (text "(", text ")")         Unboxed -> (text "(#", text "#)") --- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] in--- GHC.parser.PostProcess++-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p   = PatBuilderPat (Pat p)   | PatBuilderPar (Located (PatBuilder p))   | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))+  | PatBuilderAppType (Located (PatBuilder p)) (HsPatSigType GhcPs)   | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))   | PatBuilderVar (Located RdrName)   | PatBuilderOverLit (HsOverLit GhcPs)@@ -55,6 +56,7 @@   ppr (PatBuilderPat p) = ppr p   ppr (PatBuilderPar (L _ p)) = parens (ppr p)   ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2+  ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t   ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2   ppr (PatBuilderVar v) = ppr v   ppr (PatBuilderOverLit l) = ppr l
compiler/GHC/Runtime/Context.hs view
@@ -23,6 +23,7 @@ import GHC.Runtime.Eval.Types ( Resume )  import GHC.Unit+import GHC.Unit.Env  import GHC.Core.FamInstEnv import GHC.Core.InstEnv ( ClsInst, identicalClsInstHead )@@ -289,9 +290,9 @@ icInScopeTTs = ic_tythings  -- | Get the PrintUnqualified function based on the flags and this InteractiveContext-icPrintUnqual :: UnitState -> HomeUnit -> InteractiveContext -> PrintUnqualified-icPrintUnqual unit_state home_unit InteractiveContext{ ic_rn_gbl_env = grenv } =-    mkPrintUnqualified unit_state home_unit grenv+icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified+icPrintUnqual unit_env InteractiveContext{ ic_rn_gbl_env = grenv } =+    mkPrintUnqualified unit_env grenv  -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them.  Ids are easily removed when shadowed,
compiler/GHC/Settings.hs view
@@ -9,6 +9,7 @@   , Platform (..)   , PlatformMisc (..)   -- * Accessors+  , dynLibSuffix   , sProgramName   , sProjectVersion   , sGhcUsagePath@@ -161,6 +162,10 @@   { ghcNameVersion_programName    :: String   , ghcNameVersion_projectVersion :: String   }++-- | Dynamic library suffix+dynLibSuffix :: GhcNameVersion -> String+dynLibSuffix (GhcNameVersion name ver) = '-':name ++ ver  ----------------------------------------------------------------------------- -- Accessessors from 'Settings'
compiler/GHC/Tc/Errors/Hole/FitTypes.hs view
@@ -56,11 +56,11 @@   getName hfc = case hfc of                      IdHFCand cid -> idName cid                      NameHFCand cname -> cname-                     GreHFCand cgre -> gre_name cgre+                     GreHFCand cgre -> greMangledName cgre   getOccName hfc = case hfc of                      IdHFCand cid -> occName cid                      NameHFCand cname -> occName cname-                     GreHFCand cgre -> occName (gre_name cgre)+                     GreHFCand cgre -> occName (greMangledName cgre)  instance HasOccName HoleFitCandidate where   occName = getOccName
compiler/GHC/Tc/Types/Constraint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, MultiWayIf #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -9,12 +9,12 @@         QCInst(..), isPendingScInst,          -- Canonical constraints-        Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts,+        Xi, Ct(..), Cts, CtIrredStatus(..), HoleSet,+        emptyCts, andCts, andManyCts, pprCts,         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,-        isEmptyCts, isCTyEqCan, isCFunEqCan,+        isEmptyCts,         isPendingScDict, superClassesMightHelp, getPendingWantedScs,-        isCDictCan_Maybe, isCFunEqCan_maybe,-        isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt,+        isWantedCt, isDerivedCt, isGivenCt,         isUserTypeErrorCt, getUserTypeErrorMsg,         ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,         ctEvId, mkTcEqPredLikeEv,@@ -25,6 +25,9 @@         tyCoVarsOfCt, tyCoVarsOfCts,         tyCoVarsOfCtList, tyCoVarsOfCtsList, +        CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType,+        eqCanEqLHS,+         Hole(..), HoleSort(..), isOutOfScopeHole,          WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,@@ -37,6 +40,7 @@          Implication(..), implicationPrototype, checkTelescopeSkol,         ImplicStatus(..), isInsolubleStatus, isSolvedStatus,+        HasGivenEqs(..),         SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,         bumpSubGoalDepth, subGoalDepthExceeded,         CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,@@ -48,7 +52,7 @@         -- CtEvidence         CtEvidence(..), TcEvDest(..),         mkKindLoc, toKindLoc, mkGivenLoc,-        isWanted, isGiven, isDerived, isGivenOrWDeriv,+        isWanted, isGiven, isDerived,         ctEvRole,          wrapType,@@ -57,7 +61,6 @@         CtFlavourRole, ctEvFlavourRole, ctFlavourRole,         eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR,         eqCanDischargeFR,-        funEqCanDischarge, funEqCanDischargeF,          -- Pretty printing         pprEvVarTheta,@@ -100,6 +103,7 @@ import GHC.Utils.Panic  import Control.Monad ( msum )+import qualified Data.Semigroup ( (<>) )  {- ************************************************************************@@ -109,28 +113,54 @@ *   These are the constraints the low-level simplifier works with      * *                                                                      * ************************************************************************--} --- The syntax of xi (ξ) types:--- xi ::= a | T xis | xis -> xis | ... | forall a. tau--- Two important notes:---      (i) No type families, unless we are under a ForAll---      (ii) Note that xi types can contain unexpanded type synonyms;---           however, the (transitive) expansions of those type synonyms---           will not contain any type functions, unless we are under a ForAll.--- We enforce the structure of Xi types when we flatten (GHC.Tc.Solver.Canonical)+Note [CEqCan occurs check]+~~~~~~~~~~~~~~~~~~~~~~~~~~+A CEqCan relates a CanEqLHS (a type variable or type family applications) on+its left to an arbitrary type on its right. It is used for rewriting.+Because it is used for rewriting, it would be disastrous if the RHS+were to mention the LHS: this would cause a loop in rewriting. -type Xi = Type       -- In many comments, "xi" ranges over Xi+We thus perform an occurs-check. There is, of course, some subtlety: +* For type variables, the occurs-check looks deeply. This is because+  a CEqCan over a meta-variable is also used to inform unification,+  in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears+  anywhere, at all, in the RHS, unification will create an infinite+  structure, which is bad.++* For type family applications, the occurs-check is shallow; it looks+  only in places where we might rewrite. (Specifically, it does not+  look in kinds or coercions.) An occurrence of the LHS in, say, an+  RHS coercion is OK, as we do not rewrite in coercions. No loop to+  be found.++  You might also worry about the possibility that a type family+  application LHS doesn't exactly appear in the RHS, but something+  that reduces to the LHS does. Yet that can't happen: the RHS is+  already inert, with all type family redexes reduced. So a simple+  syntactic check is just fine.++The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq.++-}++-- | A 'Xi'-type is one that has been fully rewritten with respect+-- to the inert set; that is, it has been rewritten by the algorithm+-- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years,+-- meant that a type was type-family-free. It does *not* mean this+-- any more.)+type Xi = TcType+ type Cts = Bag Ct  data Ct   -- Atomic canonical constraints-  = CDictCan {  -- e.g.  Num xi+  = CDictCan {  -- e.g.  Num ty       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]        cc_class  :: Class,-      cc_tyargs :: [Xi],   -- cc_tyargs are function-free, hence Xi+      cc_tyargs :: [Xi],   -- cc_tyargs are rewritten w.r.t. inerts, so Xi        cc_pend_sc :: Bool   -- See Note [The superclass story] in GHC.Tc.Solver.Canonical                            -- True <=> (a) cc_class has superclasses@@ -144,8 +174,7 @@          -- For the might-be-soluble case, the ctev_pred of the evidence is         -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head-        --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant (TyEq:K) fails-        --      or   (F tys ~ ty)  where the CFunEqCan kind invariant fails+        --      or   (lhs1 ~ ty2)  where the CEqCan    kind invariant (TyEq:K) fails         -- See Note [CIrredCan constraints]          -- The definitely-insoluble case is for things like@@ -153,50 +182,32 @@         --    a ~ [a]         occurs check     } -  | CTyEqCan {  -- tv ~ rhs+  | CEqCan {  -- CanEqLHS ~ rhs        -- Invariants:        --   * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad-       --   * (TyEq:OC) tv not in deep tvs(rhs)   (occurs check)-       --   * (TyEq:F) If tv is a TauTv, then rhs has no foralls+       --   * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify+       --   * (TyEq:OC) lhs does not occur in rhs (occurs check)+       --               Note [CEqCan occurs check]+       --   * (TyEq:F) rhs has no foralls        --       (this avoids substituting a forall for the tyvar in other types)-       --   * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]-       --   * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*,-       --       See Note [Almost function-free]+       --   * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant]        --   * (TyEq:N) If the equality is representational, rhs has no top-level newtype-       --     See Note [No top-level newtypes on RHS of representational-       --     equalities] in GHC.Tc.Solver.Canonical-       --   * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented+       --     See Note [No top-level newtypes on RHS of representational equalities]+       --     in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is+       --     in scope.)+       --   * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented        --     to give best chance of        --     unification happening; eg if rhs is touchable then lhs is too-       --     See "GHC.Tc.Solver.Canonical" Note [Canonical orientation for tyvar/tyvar equality constraints]-       --   * (TyEq:H) The RHS has no blocking coercion holes. See "GHC.Tc.Solver.Canonical"+       --     Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify+       --   * (TyEq:H) The RHS has no blocking coercion holes. See GHC.Tc.Solver.Canonical        --     Note [Equalities with incompatible kinds], wrinkle (2)       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]-      cc_tyvar  :: TcTyVar,-      cc_rhs    :: TcType,     -- Not necessarily function-free (hence not Xi)-                               -- See invariants above+      cc_lhs    :: CanEqLHS,+      cc_rhs    :: Xi,         -- See invariants above        cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev     } -  | CFunEqCan {  -- F xis ~ fsk-       -- Invariants:-       --   * isTypeFamilyTyCon cc_fun-       --   * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant]-       --   * always Nominal role-      cc_ev     :: CtEvidence,  -- See Note [Ct/evidence invariant]-      cc_fun    :: TyCon,       -- A type function--      cc_tyargs :: [Xi],        -- cc_tyargs are function-free (hence Xi)-        -- Either under-saturated or exactly saturated-        --    *never* over-saturated (because if so-        --    we should have decomposed)--      cc_fsk    :: TcTyVar  -- [G]  always a FlatSkolTv-                            -- [W], [WD], or [D] always a FlatMetaTv-        -- See Note [The flattening story] in GHC.Tc.Solver.Flatten-    }-   | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad       cc_ev  :: CtEvidence     }@@ -207,6 +218,18 @@       --     auxiliary type  ------------+-- | A 'CanEqLHS' is a type that can appear on the left of a canonical+-- equality: a type variable or exactly-saturated type family application.+data CanEqLHS+  = TyVarLHS TcTyVar+  | TyFamLHS TyCon  -- ^ of the family+             [Xi]   -- ^ exactly saturating the family++instance Outputable CanEqLHS where+  ppr (TyVarLHS tv)              = ppr tv+  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)++------------ data QCInst  -- A much simplified version of ClsInst              -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical   = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty@@ -234,48 +257,57 @@          , hole_loc  :: CtLoc    -- ^ Where hole was written          }            -- For the hole_loc, we usually only want the TcLclEnv stored within.-           -- Except when we flatten, where we need a whole location. And this+           -- Except when we rewrite, where we need a whole location. And this            -- might get reported to the user if reducing type families in a            -- hole type loops.   -- | Used to indicate which sort of hole we have.-data HoleSort = ExprHole Id+data HoleSort = ExprHole HoleExprRef                  -- ^ Either an out-of-scope variable or a "true" hole in an                  -- expression (TypedHoles).-                 -- The 'Id' is where to store "evidence": this evidence-                 -- will be an erroring expression for -fdefer-type-errors.+                 -- The HoleExprRef says where to write the+                 -- the erroring expression for -fdefer-type-errors.               | TypeHole                  -- ^ A hole in a type (PartialTypeSignatures)+              | ConstraintHole+                 -- ^ A hole in a constraint, like @f :: (_, Eq a) => ...+                 -- Differentiated from TypeHole because a ConstraintHole+                 -- is simplified differently. See+                 -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.  instance Outputable Hole where-  ppr (Hole { hole_sort = ExprHole id+  ppr (Hole { hole_sort = ExprHole ref             , hole_occ  = occ             , hole_ty   = ty })-    = parens $ (braces $ ppr occ <> colon <> ppr id) <+> dcolon <+> ppr ty-  ppr (Hole { hole_sort = TypeHole+    = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty+  ppr (Hole { hole_sort = _other             , hole_occ  = occ             , hole_ty   = ty })     = braces $ ppr occ <> colon <> ppr ty  instance Outputable HoleSort where-  ppr (ExprHole id) = text "ExprHole:" <> ppr id-  ppr TypeHole      = text "TypeHole"+  ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref+  ppr TypeHole       = text "TypeHole"+  ppr ConstraintHole = text "CosntraintHole"  ------------ -- | Used to indicate extra information about why a CIrredCan is irreducible data CtIrredStatus   = InsolubleCIS   -- this constraint will never be solved-  | BlockedCIS     -- this constraint is blocked on a coercion hole-                   -- The hole will appear in the ctEvPred of the constraint with this status-                   -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"-                   -- Wrinkle (4a)+  | BlockedCIS HoleSet+                   -- this constraint is blocked on the coercion hole(s) listed+                   -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+                   -- Wrinkle (4a). Why store the HoleSet? See Wrinkle (2) of that+                   -- same Note.+                   -- INVARIANT: A BlockedCIS is a homogeneous equality whose+                   --   left hand side can fit in a CanEqLHS.   | OtherCIS  instance Outputable CtIrredStatus where-  ppr InsolubleCIS = text "(insoluble)"-  ppr BlockedCIS   = text "(blocked)"-  ppr OtherCIS     = text "(soluble)"+  ppr InsolubleCIS       = text "(insoluble)"+  ppr (BlockedCIS holes) = parens (text "blocked on" <+> ppr holes)+  ppr OtherCIS           = text "(soluble)"  {- Note [CIrredCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -308,61 +340,11 @@  Note [Ct kind invariant] ~~~~~~~~~~~~~~~~~~~~~~~~-CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind-of the rhs. This is necessary because both constraints are used for substitutions+CEqCan requires that the kind of the lhs matches the kind+of the rhs. This is necessary because these constraints are used for substitutions during solving. If the kinds differed, then the substitution would take a well-kinded type to an ill-kinded one. -Note [Almost function-free]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-A type is *almost function-free* if it has no type functions (something that-responds True to isTypeFamilyTyCon), except (possibly)- * under a forall, or- * in a coercion (either in a CastTy or a CercionTy)--The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF).-This is for two reasons:--1. There cannot be a top-level function. If there were, the equality should-   really be a CFunEqCan, not a CTyEqCan.--2. Nested functions aren't too bad, on the other hand. However, consider this-   scenario:--     type family F a = r | r -> a--     [D] F ty1 ~ fsk1-     [D] F ty2 ~ fsk2-     [D] fsk1 ~ [G Int]-     [D] fsk2 ~ [G Bool]--     type instance G Int = Char-     type instance G Bool = Char--   If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 ---   good! They don't look equal -- but if we aggressively reduce that G Int and-   G Bool they would become equal. The "almost function free" makes sure that-   these redexes are exposed.--   Note that this equality does *not* depend on casts or coercions, and so-   skipping these forms is OK. In addition, the result of a type family cannot-   be a polytype, so skipping foralls is OK, too. We skip foralls because we-   want the output of the flattener to be almost function-free. See Note-   [Flattening under a forall] in GHC.Tc.Solver.Flatten.--   As I (Richard E) write this, it is unclear if the scenario pictured above-   can happen -- I would expect the G Int and G Bool to be reduced. But-   perhaps it can arise somehow, and maintaining almost function-free is cheap.--Historical note: CTyEqCans used to require only condition (1) above: that no-type family was at the top of an RHS. But work on #16512 suggested that the-injectivity checks were not complete, and adding the requirement that functions-do not appear even in a nested fashion was easy (it was already true, but-unenforced).--The almost-function-free property is checked by isAlmostFunctionFree in GHC.Tc.Utils.TcType.-The flattener (in GHC.Tc.Solver.Flatten) produces types that are almost function-free.- Note [Holes] ~~~~~~~~~~~~ This Note explains how GHC tracks *holes*.@@ -377,22 +359,25 @@ When a hole is encountered, a new entry of type Hole is added to the ambient WantedConstraints. The type (hole_ty) of the hole is then simplified during solving (with respect to any Givens in surrounding implications). It is-reported with all the other errors in GHC.Tc.Errors. No type family reduction-is done on hole types; this is purely because we think it will produce-better error messages not to reduce type families. This is why the-GHC.Tc.Solver.Flatten.flattenType function uses FM_SubstOnly.+reported with all the other errors in GHC.Tc.Errors.  For expression holes, the user has the option of deferring errors until runtime with -fdefer-type-errors. In this case, the hole actually has evidence: this evidence is an erroring expression that prints an error and crashes at runtime.-The ExprHole variant of holes stores the Id that will be bound to this evidence;-during constraint generation, this Id was inserted into the expression output-by the type checker.+The ExprHole variant of holes stores an IORef EvTerm that will contain this evidence;+during constraint generation, this IORef was stored in the HsUnboundVar extension+field by the type checker. The desugarer simply dereferences to get the CoreExpr. -You might think that the type of the stored Id is the same as the type of the+Prior to fixing #17812, we used to invent an Id to hold the erroring+expression, and then bind it during type-checking. But this does not support+levity-polymorphic out-of-scope identifiers. See+typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach+described above.++You might think that the type in the HoleExprRef is the same as the type of the hole. However, because the hole type (hole_ty) is rewritten with respect to givens, this might not be the case. That is, the hole_ty is always (~) to the-type of the Id, but they might not be `eqType`. We need the type of the generated+type of the HoleExprRef, but they might not be `eqType`. We need the type of the generated evidence to match what is expected in the context of the hole, and so we must store these types separately. @@ -459,8 +444,7 @@   ppr ct = ppr (ctEvidence ct) <+> parens pp_sort     where       pp_sort = case ct of-         CTyEqCan {}      -> text "CTyEqCan"-         CFunEqCan {}     -> text "CFunEqCan"+         CEqCan {}        -> text "CEqCan"          CNonCanonical {} -> text "CNonCanonical"          CDictCan { cc_pend_sc = pend_sc }             | pend_sc   -> text "CDictCan(psc)"@@ -470,6 +454,40 @@             | pend_sc   -> text "CQuantCan(psc)"             | otherwise -> text "CQuantCan" +-----------------------------------+-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated+-- type family application?+-- Does not look through type synonyms.+canEqLHS_maybe :: Xi -> Maybe CanEqLHS+canEqLHS_maybe xi+  | Just tv <- tcGetTyVar_maybe xi+  = Just $ TyVarLHS tv++  | Just (tc, args) <- tcSplitTyConApp_maybe xi+  , isTypeFamilyTyCon tc+  , args `lengthIs` tyConArity tc+  = Just $ TyFamLHS tc args++  | otherwise+  = Nothing++-- | Convert a 'CanEqLHS' back into a 'Type'+canEqLHSType :: CanEqLHS -> TcType+canEqLHSType (TyVarLHS tv) = mkTyVarTy tv+canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args++-- | Retrieve the kind of a 'CanEqLHS'+canEqLHSKind :: CanEqLHS -> TcKind+canEqLHSKind (TyVarLHS tv) = tyVarKind tv+canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args++-- | Are two 'CanEqLHS's equal?+eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool+eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2+eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2)+  = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2+eqCanEqLHS _ _ = False+ {- ************************************************************************ *                                                                      *@@ -515,19 +533,19 @@ -- | Returns free variables of WantedConstraints as a non-deterministic -- set. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC  -- | Returns free variables of WantedConstraints as a deterministically -- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar]--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC  -- | Returns free variables of WantedConstraints as a composable FV -- computation. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoFVsOfWC :: WantedConstraints -> FV--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes })   = tyCoFVsOfCts simple `unionFV`     tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`@@ -536,7 +554,7 @@ -- | Returns free variables of Implication as a composable FV computation. -- See Note [Deterministic FV] in "GHC.Utils.FV". tyCoFVsOfImplic :: Implication -> FV--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoFVsOfImplic (Implic { ic_skols = skols                         , ic_given = givens                         , ic_wanted = wanted })@@ -705,26 +723,6 @@ isDerivedCt :: Ct -> Bool isDerivedCt = isDerived . ctEvidence -isCTyEqCan :: Ct -> Bool-isCTyEqCan (CTyEqCan {})  = True-isCTyEqCan _              = False--isCDictCan_Maybe :: Ct -> Maybe Class-isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls-isCDictCan_Maybe _              = Nothing--isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type])-isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis)-isCFunEqCan_maybe _ = Nothing--isCFunEqCan :: Ct -> Bool-isCFunEqCan (CFunEqCan {}) = True-isCFunEqCan _ = False--isCNonCanonical :: Ct -> Bool-isCNonCanonical (CNonCanonical {}) = True-isCNonCanonical _ = False- {- Note [Custom type errors in constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1103,7 +1101,7 @@  data Implication   = Implic {   -- Invariants for a tree of implications:-               -- see TcType Note [TcLevel and untouchable type variables]+               -- see TcType Note [TcLevel invariants]        ic_tclvl :: TcLevel,       -- TcLevel of unification variables                                  -- allocated /inside/ this implication@@ -1116,8 +1114,7 @@                                  --   (order does not matter)                                  -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType -      ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure-                                 -- False <=> ic_givens might have equalities+      ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?        ic_warn_inaccessible :: Bool,                                  -- True  <=> -Winaccessible-code is enabled@@ -1164,7 +1161,7 @@             , ic_skols      = []             , ic_given      = []             , ic_wanted     = emptyWC-            , ic_no_eqs     = False+            , ic_given_eqs  = MaybeGivenEqs             , ic_status     = IC_Unsolved             , ic_need_inner = emptyVarSet             , ic_need_outer = emptyVarSet }@@ -1181,9 +1178,60 @@    | IC_Unsolved   -- Neither of the above; might go either way +data HasGivenEqs -- See Note [HasGivenEqs]+  = NoGivenEqs      -- Definitely no given equalities,+                    --   except by Note [Let-bound skolems] in GHC.Tc.Solver.Monad+  | LocalGivenEqs   -- Might have Given equalities, but only ones that affect only+                    --   local skolems e.g. forall a b. (a ~ F b) => ...+  | MaybeGivenEqs   -- Might have any kind of Given equalities; no floating out+                    --   is possible.+  deriving Eq++{- Note [HasGivenEqs]+~~~~~~~~~~~~~~~~~~~~~+The GivenEqs data type describes the Given constraints of an implication constraint:++* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems+  which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.Monad+  Examples: forall a. Eq a => ...+            forall a. (Show a, Num a) => ...+            forall a. a ~ Either Int Bool => ...  -- Let-bound skolem++* LocalGivenEqs: definitely no Given equalities that would affect principal+  types.  But may have equalities that affect only skolems of this implication+  (and hence do not affect princial types)+  Examples: forall a. F a ~ Int => ...+            forall a b. F a ~ G b => ...++* MaybeGivenEqs: may have Given equalities that would affect principal+  types+  Examples: forall. (a ~ b) => ...+            forall a. F a ~ b => ...+            forall a. c a => ...       -- The 'c' might be instantiated to (b ~)+            forall a. C a b => ....+               where class x~y => C a b+               so there is an equality in the superclass of a Given++The HasGivenEqs classifications affect two things:++* Suppressing redundant givens during error reporting; see GHC.Tc.Errors+  Note [Suppress redundant givens during error reporting]++* Floating in approximateWC.++Specifically, here's how it goes:++                 Stops floating    |   Suppresses Givens in errors+                 in approximateWC  |+                 -----------------------------------------------+ NoGivenEqs         NO             |         YES+ LocalGivenEqs      NO             |         NO+ MaybeGivenEqs      YES            |         NO+-}+ instance Outputable Implication where   ppr (Implic { ic_tclvl = tclvl, ic_skols = skols-              , ic_given = given, ic_no_eqs = no_eqs+              , ic_given = given, ic_given_eqs = given_eqs               , ic_wanted = wanted, ic_status = status               , ic_binds = binds               , ic_need_inner = need_in, ic_need_outer = need_out@@ -1191,7 +1239,7 @@    = hang (text "Implic" <+> lbrace)         2 (sep [ text "TcLevel =" <+> ppr tclvl                , text "Skolems =" <+> pprTyVars skols-               , text "No-eqs =" <+> ppr no_eqs+               , text "Given-eqs =" <+> ppr given_eqs                , text "Status =" <+> ppr status                , hang (text "Given =")  2 (pprEvVars given)                , hang (text "Wanted =") 2 (ppr wanted)@@ -1212,6 +1260,25 @@ checkTelescopeSkol (ForAllSkol {}) = True checkTelescopeSkol _               = False +instance Outputable HasGivenEqs where+  ppr NoGivenEqs    = text "NoGivenEqs"+  ppr LocalGivenEqs = text "LocalGivenEqs"+  ppr MaybeGivenEqs = text "MaybeGivenEqs"++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Semigroup HasGivenEqs where+  NoGivenEqs <> other = other+  other <> NoGivenEqs = other++  MaybeGivenEqs <> _other = MaybeGivenEqs+  _other <> MaybeGivenEqs = MaybeGivenEqs++  LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Monoid HasGivenEqs where+  mempty = NoGivenEqs+ {- Note [Checking telescopes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When kind-checking a /user-written/ type, we might have a "bad telescope"@@ -1420,7 +1487,7 @@    | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence               -- HoleDest is always used for type-equalities-              -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep"+              -- See Note [Coercion holes] in GHC.Core.TyCo.Rep  data CtEvidence   = CtGiven    -- Truly given, not depending on subgoals@@ -1536,9 +1603,7 @@  * [WD] Wanted WDeriv: a single constraint that represents                       both [W] and [D]-  We keep them paired as one both for efficiency, and because-  when we have a finite map  F tys -> CFunEqCan, it's inconvenient-  to have two CFunEqCans in the range+  We keep them paired as one both for efficiency  The ctev_nosh field of a Wanted distinguishes between [W] and [WD] @@ -1561,11 +1626,6 @@              -- See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad   deriving( Eq ) -isGivenOrWDeriv :: CtFlavour -> Bool-isGivenOrWDeriv Given           = True-isGivenOrWDeriv (Wanted WDeriv) = True-isGivenOrWDeriv _               = False- instance Outputable CtFlavour where   ppr Given           = text "[G]"   ppr (Wanted WDeriv) = text "[WD]"@@ -1591,17 +1651,15 @@ -- Uses short-cuts to role for special cases ctFlavourRole (CDictCan { cc_ev = ev })   = (ctEvFlavour ev, NomEq)-ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel })+ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })   = (ctEvFlavour ev, eq_rel)-ctFlavourRole (CFunEqCan { cc_ev = ev })-  = (ctEvFlavour ev, NomEq) ctFlavourRole ct   = ctEvFlavourRole (ctEvidence ct)  {- Note [eqCanRewrite] ~~~~~~~~~~~~~~~~~~~~~~-(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form-tv ~ ty) can be used to rewrite ct2.  It must satisfy the properties of+(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form+lhs ~ ty) can be used to rewrite ct2.  It must satisfy the properties of a can-rewrite relation, see Definition [Can-rewrite relation] in GHC.Tc.Solver.Monad. @@ -1667,47 +1725,11 @@ eqMayRewriteFR (Derived,       NomEq) (Wanted WDeriv, NomEq) = True eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 -------------------{- Note [funEqCanDischarge]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have two CFunEqCans with the same LHS:-    (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2)-Can we drop x2 in favour of x1, either unifying-f2 (if it's a flatten meta-var) or adding a new Given-(f1 ~ f2), if x2 is a Given?--Answer: yes if funEqCanDischarge is true.--}--funEqCanDischarge-  :: CtEvidence -> CtEvidence-  -> ( SwapFlag   -- NotSwapped => lhs can discharge rhs-                  -- Swapped    => rhs can discharge lhs-     , Bool)      -- True <=> upgrade non-discharded one-                  --          from [W] to [WD]--- See Note [funEqCanDischarge]-funEqCanDischarge ev1 ev2-  = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 )-    ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 )-    -- CFunEqCans are all Nominal, hence asserts-    funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2)--funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool)-funEqCanDischargeF Given           _               = (NotSwapped, False)-funEqCanDischargeF _               Given           = (IsSwapped,  False)-funEqCanDischargeF (Wanted WDeriv) _               = (NotSwapped, False)-funEqCanDischargeF _               (Wanted WDeriv) = (IsSwapped,  True)-funEqCanDischargeF (Wanted WOnly)  (Wanted WOnly)  = (NotSwapped, False)-funEqCanDischargeF (Wanted WOnly)  Derived         = (NotSwapped, True)-funEqCanDischargeF Derived         (Wanted WOnly)  = (IsSwapped,  True)-funEqCanDischargeF Derived         Derived         = (NotSwapped, False)-- {- Note [eqCanDischarge] ~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have two identical CTyEqCan equality constraints+Suppose we have two identical CEqCan equality constraints (i.e. both LHS and RHS are the same)-      (x1:a~t) `eqCanDischarge` (xs:a~t)+      (x1:lhs~t) `eqCanDischarge` (xs:lhs~t) Can we just drop x2 in favour of x1?  Answer: yes if eqCanDischarge is true.
compiler/GHC/Tc/Types/Evidence.hs view
@@ -33,16 +33,20 @@   EvCallStack(..),   EvTypeable(..), +  -- * HoleExprRef+  HoleExprRef(..),+   -- * TcCoercion   TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,-  TcMCoercion,+  TcMCoercion, TcMCoercionN, TcMCoercionR,   Role(..), LeftOrRight(..), pickLR,   mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,   mkTcTyConAppCo, mkTcAppCo, mkTcFunCo,   mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,-  mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo,-  tcDowngradeRole,-  mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo,+  mkTcSymCo, mkTcSymMCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo,+  maybeTcSubCo, tcDowngradeRole,+  mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflRightMCo, mkTcGReflLeftCo, mkTcGReflLeftMCo,+  mkTcPhantomCo,   mkTcCoherenceLeftCo,   mkTcCoherenceRightCo,   mkTcKindCo,@@ -76,6 +80,7 @@ import GHC.Core.Predicate import GHC.Types.Name import GHC.Data.Pair+import GHC.Types.Basic  import GHC.Core import GHC.Core.Class (Class, classSCSelId )@@ -111,10 +116,13 @@ type TcCoercionN = CoercionN    -- A Nominal          coercion ~N type TcCoercionR = CoercionR    -- A Representational coercion ~R type TcCoercionP = CoercionP    -- a phantom coercion-type TcMCoercion = MCoercion+type TcMCoercion  = MCoercion+type TcMCoercionN = MCoercionN  -- nominal+type TcMCoercionR = MCoercionR  -- representational  mkTcReflCo             :: Role -> TcType -> TcCoercion mkTcSymCo              :: TcCoercion -> TcCoercion+mkTcSymMCo             :: TcMCoercion -> TcMCoercion mkTcTransCo            :: TcCoercion -> TcCoercion -> TcCoercion mkTcNomReflCo          :: TcType -> TcCoercionN mkTcRepReflCo          :: TcType -> TcCoercionR@@ -129,11 +137,13 @@ mkTcForAllCos          :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion mkTcNthCo              :: Role -> Int -> TcCoercion -> TcCoercion mkTcLRCo               :: LeftOrRight -> TcCoercion -> TcCoercion-mkTcSubCo              :: TcCoercionN -> TcCoercionR+mkTcSubCo              :: HasDebugCallStack => TcCoercionN -> TcCoercionR tcDowngradeRole        :: Role -> Role -> TcCoercion -> TcCoercion mkTcAxiomRuleCo        :: CoAxiomRule -> [TcCoercion] -> TcCoercionR mkTcGReflRightCo       :: Role -> TcType -> TcCoercionN -> TcCoercion+mkTcGReflRightMCo      :: Role -> TcType -> TcMCoercionN -> TcCoercion mkTcGReflLeftCo        :: Role -> TcType -> TcCoercionN -> TcCoercion+mkTcGReflLeftMCo       :: Role -> TcType -> TcMCoercionN -> TcCoercion mkTcCoherenceLeftCo    :: Role -> TcType -> TcCoercionN                        -> TcCoercion -> TcCoercion mkTcCoherenceRightCo   :: Role -> TcType -> TcCoercionN@@ -153,6 +163,7 @@  mkTcReflCo             = mkReflCo mkTcSymCo              = mkSymCo+mkTcSymMCo             = mkSymMCo mkTcTransCo            = mkTransCo mkTcNomReflCo          = mkNomReflCo mkTcRepReflCo          = mkRepReflCo@@ -169,7 +180,9 @@ tcDowngradeRole        = downgradeRole mkTcAxiomRuleCo        = mkAxiomRuleCo mkTcGReflRightCo       = mkGReflRightCo+mkTcGReflRightMCo      = mkGReflRightMCo mkTcGReflLeftCo        = mkGReflLeftCo+mkTcGReflLeftMCo       = mkGReflLeftMCo mkTcCoherenceLeftCo    = mkCoherenceLeftCo mkTcCoherenceRightCo   = mkCoherenceRightCo mkTcPhantomCo          = mkPhantomCo@@ -184,10 +197,14 @@  -- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. -- Note that the input coercion should always be nominal.-maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion+maybeTcSubCo :: HasDebugCallStack => EqRel -> TcCoercionN -> TcCoercion maybeTcSubCo NomEq  = id maybeTcSubCo ReprEq = mkTcSubCo +-- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion+maybeTcSymCo :: SwapFlag -> TcCoercion -> TcCoercion+maybeTcSymCo IsSwapped  co = mkTcSymCo co+maybeTcSymCo NotSwapped co = co  {- %************************************************************************@@ -642,6 +659,29 @@     -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at     -- @loc@, in a calling context @stk@.   deriving Data.Data++{-+************************************************************************+*                                                                      *+         Evidence for holes+*                                                                      *+************************************************************************+-}++-- | Where to store evidence for expression holes+-- See Note [Holes] in GHC.Tc.Types.Constraint+data HoleExprRef = HER (IORef EvTerm)   -- ^ where to write the erroring expression+                       TcType           -- ^ expected type of that expression+                       Unique           -- ^ for debug output only++instance Outputable HoleExprRef where+  ppr (HER _ _ u) = ppr u++instance Data.Data HoleExprRef where+  -- Placeholder; we can't traverse into HoleExprRef+  toConstr _   = abstractConstr "HoleExprRef"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = Data.mkNoRepType "HoleExprRef"  {- Note [Typeable evidence terms]
compiler/GHC/Tc/Types/Origin.hs view
@@ -432,7 +432,6 @@   | ExprHoleOrigin OccName   -- from an expression hole   | TypeHoleOrigin OccName   -- from a type hole (partial type signature)   | PatCheckOrigin      -- normalisation of a type during pattern-match checking-  | UnboundOccurrenceOf OccName   | ListOrigin          -- An overloaded list   | BracketOrigin       -- An overloaded quotation bracket   | StaticOrigin        -- A static form@@ -479,7 +478,7 @@  exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name-exprCtOrigin (HsUnboundVar _ uv)  = UnboundOccurrenceOf uv+exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) exprCtOrigin (HsOverLabel _ _ l)  = OverLabelOrigin l@@ -570,9 +569,6 @@ pprCtOrigin (KindEqOrigin t1 Nothing _ _)   = hang (ctoHerald <+> text "a kind equality when matching")        2 (ppr t1)--pprCtOrigin (UnboundOccurrenceOf name)-  = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)  pprCtOrigin (DerivOriginDC dc n _)   = hang (ctoHerald <+> text "the" <+> speakNth n
compiler/GHC/Tc/Utils/TcType.hs view
@@ -33,7 +33,7 @@    -- TcLevel   TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,-  strictlyDeeperThan, sameDepthAs,+  strictlyDeeperThan, deeperThanOrSame, sameDepthAs,   tcTypeLevel, tcTyVarLevel, maxTcLevel,   promoteSkolem, promoteSkolemX, promoteSkolemsX,   --------------------------------@@ -42,12 +42,10 @@   MetaDetails(Flexi, Indirect), MetaInfo(..),   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,-  isFskTyVar, isFmvTyVar, isFlattenTyVar,-  isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,+  isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,   isFlexi, isIndirect, isRuntimeUnkSkol,   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,-  isTouchableMetaTyVar,-  isFloatedTouchableMetaTyVar,+  isTouchableMetaTyVar, isPromotableMetaTyVar,   findDupTyVarTvs, mkTyVarNamePairs,    --------------------------------@@ -78,14 +76,15 @@   -- Again, newtypes are opaque   eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,   pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,+  tcEqTyConApps,   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,   isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,   isIntegerTy, isNaturalTy,   isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,-  isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,+  isPredTy, isTyVarClassPred, isInsolubleOccursCheck,   checkValidClsArgs, hasTyVarHead,-  isRigidTy, isAlmostFunctionFree,+  isRigidTy,    ---------------------------------   -- Misc type manipulators@@ -107,7 +106,7 @@    -- * Finding "exact" (non-dead) type variables   exactTyCoVarsOfType, exactTyCoVarsOfTypes,-  anyRewritableTyVar,+  anyRewritableTyVar, anyRewritableTyFamApp, anyRewritableCanEqLHS,    ---------------------------------   -- Foreign import and export@@ -341,10 +340,6 @@ type TcCoVar = CoVar    -- Used only during type inference type TcType = Type      -- A TcType can have mutable type variables type TcTyCoVar = Var    -- Either a TcTyVar or a CoVar-        -- Invariant on ForAllTy in TcTypes:-        --      forall a. T-        -- a cannot occur inside a MutTyVar in T; that is,-        -- T is "flattened" before quantifying over a  type TcTyVarBinder     = TyVarBinder type TcInvisTVBinder   = InvisTVBinder@@ -520,7 +515,7 @@    | MetaTv { mtv_info  :: MetaInfo            , mtv_ref   :: IORef MetaDetails-           , mtv_tclvl :: TcLevel }  -- See Note [TcLevel and untouchable type variables]+           , mtv_tclvl :: TcLevel }  -- See Note [TcLevel invariants]  vanillaSkolemTv, superSkolemTv :: TcTyVarDetails -- See Note [Binding when looking up instances] in GHC.Core.InstEnv@@ -554,29 +549,22 @@                    --   unified with a type, only with a type variable                    -- See Note [Signature skolems] -   | FlatMetaTv    -- A flatten meta-tyvar-                   -- It is a meta-tyvar, but it is always untouchable, with level 0-                   -- See Note [The flattening story] in GHC.Tc.Solver.Flatten--   | FlatSkolTv    -- A flatten skolem tyvar-                   -- Just like FlatMetaTv, but is completely "owned" by-                   --   its Given CFunEqCan.-                   -- It is filled in /only/ by unflattenGivens-                   -- See Note [The flattening story] in GHC.Tc.Solver.Flatten-    | RuntimeUnkTv  -- A unification variable used in the GHCi debugger.                    -- It /is/ allowed to unify with a polytype, unlike TauTv +   | CycleBreakerTv  -- Used to fix occurs-check problems in Givens+                     -- See Note [Type variable cycles in Givens] in+                     -- GHC.Tc.Solver.Canonical+ instance Outputable MetaDetails where   ppr Flexi         = text "Flexi"   ppr (Indirect ty) = text "Indirect" <+> ppr ty  instance Outputable MetaInfo where-  ppr TauTv         = text "tau"-  ppr TyVarTv       = text "tyv"-  ppr FlatMetaTv    = text "fmv"-  ppr FlatSkolTv    = text "fsk"-  ppr RuntimeUnkTv  = text "rutv"+  ppr TauTv          = text "tau"+  ppr TyVarTv        = text "tyv"+  ppr RuntimeUnkTv   = text "rutv"+  ppr CycleBreakerTv = text "cbv"  {- ********************************************************************* *                                                                      *@@ -585,13 +573,14 @@ ********************************************************************* -}  newtype TcLevel = TcLevel Int deriving( Eq, Ord )-  -- See Note [TcLevel and untouchable type variables] for what this Int is+  -- See Note [TcLevel invariants] for what this Int is   -- See also Note [TcLevel assignment]  {--Note [TcLevel and untouchable type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [TcLevel invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~ * Each unification variable (MetaTv)+  and skolem (SkolemTv)   and each Implication   has a level number (of type TcLevel) @@ -613,9 +602,8 @@                 LESS THAN OR EQUAL TO the ic_tclvl of I                 See Note [WantedInv] -* A unification variable is *touchable* if its level number-  is EQUAL TO that of its immediate parent implication,-  and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv)+The level of a MetaTyVar also governs its untouchability.  See+Note [Unification preconditions] in GHC.Tc.Utils.Unify.  Note [WantedInv] ~~~~~~~~~~~~~~~~@@ -690,13 +678,17 @@ strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)   = tv_tclvl > ctxt_tclvl +deeperThanOrSame :: TcLevel -> TcLevel -> Bool+deeperThanOrSame (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)+  = tv_tclvl >= ctxt_tclvl+ sameDepthAs :: TcLevel -> TcLevel -> Bool sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)   = ctxt_tclvl == tv_tclvl   -- NB: invariant ctxt_tclvl >= tv_tclvl                              --     So <= would be equivalent  checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool--- Checks (WantedInv) from Note [TcLevel and untouchable type variables]+-- Checks (WantedInv) from Note [TcLevel invariants] checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)   = ctxt_tclvl >= tv_tclvl @@ -854,27 +846,41 @@ -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts -anyRewritableTyVar :: Bool    -- Ignore casts and coercions-                   -> EqRel   -- Ambient role-                   -> (EqRel -> TcTyVar -> Bool)-                   -> TcType -> Bool--- (anyRewritableTyVar ignore_cos pred ty) returns True---    if the 'pred' returns True of any free TyVar in 'ty'+any_rewritable :: Bool    -- Ignore casts and coercions+               -> EqRel   -- Ambient role+               -> (EqRel -> TcTyVar -> Bool)           -- check tyvar+               -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family+               -> (TyCon -> Bool)                      -- expand type synonym?+               -> TcType -> Bool+-- Checks every tyvar and tyconapp (not including FunTys) within a type,+-- ORing the results of the predicates above together -- Do not look inside casts and coercions if 'ignore_cos' is True -- See Note [anyRewritableTyVar must be role-aware]-anyRewritableTyVar ignore_cos role pred ty-  = go role emptyVarSet ty+--+-- This looks like it should use foldTyCo, but that function is+-- role-agnostic, and this one must be role-aware. We could make+-- foldTyCon role-aware, but that may slow down more common usages.+{-# INLINE any_rewritable #-} -- this allows specialization of predicates+any_rewritable ignore_cos role tv_pred tc_pred should_expand+  = go role emptyVarSet   where-    -- NB: No need to expand synonyms, because we can find-    -- all free variables of a synonym by looking at its-    -- arguments-     go_tv rl bvs tv | tv `elemVarSet` bvs = False-                    | otherwise           = pred rl tv+                    | otherwise           = tv_pred rl tv +    go rl bvs ty@(TyConApp tc tys)+      | isTypeSynonymTyCon tc+      , should_expand tc+      , Just ty' <- tcView ty   -- should always match+      = go rl bvs ty'++      | tc_pred rl tc tys+      = True++      | otherwise+      = go_tc rl bvs tc tys+     go rl bvs (TyVarTy tv)       = go_tv rl bvs tv     go _ _     (LitTy {})        = False-    go rl bvs (TyConApp tc tys)  = go_tc rl bvs tc tys     go rl bvs (AppTy fun arg)    = go rl bvs fun || go NomEq bvs arg     go rl bvs (FunTy _ w arg res)  = go NomEq bvs arg_rep || go NomEq bvs res_rep ||                                      go rl bvs arg || go rl bvs res || go NomEq bvs w@@ -898,6 +904,36 @@       -- We don't have an equivalent of anyRewritableTyVar for coercions       -- (at least not yet) so take the free vars and test them +anyRewritableTyVar :: Bool     -- Ignore casts and coercions+                   -> EqRel    -- Ambient role+                   -> (EqRel -> TcTyVar -> Bool)  -- check tyvar+                   -> TcType -> Bool+anyRewritableTyVar ignore_cos role pred+  = any_rewritable ignore_cos role pred+      (\ _ _ _ -> False) -- don't check tyconapps+      (\ _ -> False)     -- don't expand synonyms+    -- NB: No need to expand synonyms, because we can find+    -- all free variables of a synonym by looking at its+    -- arguments++anyRewritableTyFamApp :: EqRel   -- Ambient role+                      -> (EqRel -> TyCon -> [TcType] -> Bool) -- check tyconapp+                          -- should return True only for type family applications+                      -> TcType -> Bool+  -- always ignores casts & coercions+anyRewritableTyFamApp role check_tyconapp+  = any_rewritable True role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon)++-- This version is used by shouldSplitWD. It *does* look in casts+-- and coercions, and it always expands type synonyms whose RHSs mention+-- type families.+anyRewritableCanEqLHS :: EqRel   -- Ambient role+                      -> (EqRel -> TcTyVar -> Bool)            -- check tyvar+                      -> (EqRel -> TyCon -> [TcType] -> Bool)  -- check type family+                      -> TcType -> Bool+anyRewritableCanEqLHS role check_tyvar check_tyconapp+  = any_rewritable False role check_tyvar check_tyconapp (not . isFamFreeTyCon)+ {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ anyRewritableTyVar is used during kick-out from the inert set,@@ -965,32 +1001,32 @@ -- See Note [TcTyVars and TyVars in the typechecker] tcIsTcTyVar tv = isTyVar tv +isPromotableMetaTyVar :: TcTyVar -> Bool+-- True is this is a meta-tyvar that can be+-- promoted to an outer level+isPromotableMetaTyVar tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  , MetaTv { mtv_info = info } <- tcTyVarDetails tv+  = isTouchableInfo info   -- Can't promote cycle breakers+  | otherwise+  = False+ isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isTouchableMetaTyVar ctxt_tclvl tv   | isTyVar tv -- See Note [Coercion variables in free variable lists]   , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv-  , not (isFlattenInfo info)+  , isTouchableInfo info   = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,              ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )     tv_tclvl `sameDepthAs` ctxt_tclvl    | otherwise = False -isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool-isFloatedTouchableMetaTyVar ctxt_tclvl tv-  | isTyVar tv -- See Note [Coercion variables in free variable lists]-  , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv-  , not (isFlattenInfo info)-  = tv_tclvl `strictlyDeeperThan` ctxt_tclvl--  | otherwise = False- isImmutableTyVar :: TyVar -> Bool isImmutableTyVar tv = isSkolemTyVar tv  isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,-  isMetaTyVar, isAmbiguousTyVar,-  isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool+  isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool  isTyConableTyVar tv         -- True of a meta-type variable that can be filled in@@ -1002,25 +1038,6 @@         _                             -> True   | otherwise = True -isFmvTyVar tv-  = ASSERT2( tcIsTcTyVar tv, ppr tv )-    case tcTyVarDetails tv of-        MetaTv { mtv_info = FlatMetaTv } -> True-        _                                -> False--isFskTyVar tv-  = ASSERT2( tcIsTcTyVar tv, ppr tv )-    case tcTyVarDetails tv of-        MetaTv { mtv_info = FlatSkolTv } -> True-        _                                -> False---- | True of both given and wanted flatten-skolems (fmv and fsk)-isFlattenTyVar tv-  = ASSERT2( tcIsTcTyVar tv, ppr tv )-    case tcTyVarDetails tv of-        MetaTv { mtv_info = info } -> isFlattenInfo info-        _                          -> False- isSkolemTyVar tv   = ASSERT2( tcIsTcTyVar tv, ppr tv )     case tcTyVarDetails tv of@@ -1054,6 +1071,14 @@         _             -> False   | otherwise = False +isCycleBreakerTyVar tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv+  = True++  | otherwise+  = False+ isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv isMetaTyVarTy _            = False@@ -1064,10 +1089,10 @@       MetaTv { mtv_info = info } -> info       _ -> pprPanic "metaTyVarInfo" (ppr tv) -isFlattenInfo :: MetaInfo -> Bool-isFlattenInfo FlatMetaTv = True-isFlattenInfo FlatSkolTv = True-isFlattenInfo _          = False+isTouchableInfo :: MetaInfo -> Bool+isTouchableInfo info+  | CycleBreakerTv <- info = False+  | otherwise              = True  metaTyVarTcLevel :: TcTyVar -> TcLevel metaTyVarTcLevel tv@@ -1540,7 +1565,15 @@ -- This ignores kinds and coercions, because this is used only for printing. pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 -+-- | Check whether two TyConApps are the same; if the number of arguments+-- are different, just checks the common prefix of arguments.+tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool+tcEqTyConApps tc1 args1 tc2 args2+  = tc1 == tc2 &&+    and (zipWith tcEqTypeNoKindCheck args1 args2)+    -- No kind check necessary: if both arguments are well typed, then+    -- any difference in the kinds of later arguments would show up+    -- as differences in earlier (dependent) arguments  -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool          -- ^ True <=> do not expand type synonyms@@ -1552,6 +1585,11 @@   = go orig_env orig_ty1 orig_ty2   where     go :: RnEnv2 -> Type -> Type -> Bool+    -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.+    go _   (TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = True+     go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2     go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' @@ -1614,7 +1652,7 @@     -- sometimes hard to know directly because @ty@ might have some casts     -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't     -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or-    -- res is unzonked/unflattened. Thus this function, which handles this+    -- res is unzonked. Thus this function, which handles this     -- corner case.     eqFunTy :: RnEnv2 -> Mult -> Type -> Type -> Type -> Bool                -- Last arg is /not/ FunTy@@ -2114,19 +2152,7 @@                         Just (tc, _) -> uniq == getUnique tc                         Nothing      -> False --- | Does the given tyvar appear at the head of a chain of applications---     (a t1 ... tn)-isTyVarHead :: TcTyVar -> TcType -> Bool-isTyVarHead tv (TyVarTy tv')   = tv == tv'-isTyVarHead tv (AppTy fun _)   = isTyVarHead tv fun-isTyVarHead tv (CastTy ty _)   = isTyVarHead tv ty-isTyVarHead _ (TyConApp {})    = False-isTyVarHead _  (LitTy {})      = False-isTyVarHead _  (ForAllTy {})   = False-isTyVarHead _  (FunTy {})      = False-isTyVarHead _  (CoercionTy {}) = False - {- Note [AppTy and ReprEq] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   a ~R# b a@@ -2146,24 +2172,6 @@   | isForAllTy ty                           = True   | otherwise                               = False ---- | Is this type *almost function-free*? See Note [Almost function-free]--- in "GHC.Tc.Types"-isAlmostFunctionFree :: TcType -> Bool-isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty'-isAlmostFunctionFree (TyVarTy {})    = True-isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 &&-                                       isAlmostFunctionFree ty2-isAlmostFunctionFree (TyConApp tc args)-  | isTypeFamilyTyCon tc = False-  | otherwise            = all isAlmostFunctionFree args-isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr)-isAlmostFunctionFree (FunTy _ w ty1 ty2) = isAlmostFunctionFree w &&-                                           isAlmostFunctionFree ty1 &&-                                           isAlmostFunctionFree ty2-isAlmostFunctionFree (LitTy {})        = True-isAlmostFunctionFree (CastTy ty _)     = isAlmostFunctionFree ty-isAlmostFunctionFree (CoercionTy {})   = True  {- ************************************************************************
compiler/GHC/Types/Avail.hs view
@@ -10,22 +10,32 @@     Avails,     AvailInfo(..),     avail,+    availField,+    availTC,     availsToNameSet,     availsToNameSetWithSelectors,     availsToNameEnv,-    availName, availNames, availNonFldNames,+    availExportsDecl,+    availName, availGreName,+    availNames, availNonFldNames,     availNamesWithSelectors,     availFlds,-    availsNamesWithOccs,-    availNamesWithOccs,+    availGreNames,+    availSubordinateGreNames,     stableAvailCmp,     plusAvail,     trimAvail,     filterAvail,     filterAvails,-    nubAvails-+    nubAvails, +    GreName(..),+    greNameMangledName,+    greNamePrintableName,+    greNameSrcSpan,+    greNameFieldLabel,+    partitionGreNames,+    stableGreNameCmp,   ) where  import GHC.Prelude@@ -33,6 +43,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set+import GHC.Types.SrcLoc  import GHC.Types.FieldLabel import GHC.Utils.Binary@@ -42,8 +53,9 @@ import GHC.Utils.Misc  import Data.Data ( Data )+import Data.Either ( partitionEithers ) import Data.List ( find )-import Data.Function+import Data.Maybe  -- ----------------------------------------------------------------------------- -- The AvailInfo type@@ -51,20 +63,19 @@ -- | Records what things are \"available\", i.e. in scope data AvailInfo -  -- | An ordinary identifier in scope-  = Avail Name+  -- | An ordinary identifier in scope, or a field label without a parent type+  -- (see Note [Representing pattern synonym fields in AvailInfo]).+  = Avail GreName    -- | A type or class in scope   --   -- The __AvailTC Invariant__: If the type or class is itself to be in scope,   -- it must be /first/ in this list.  Thus, typically:   ---  -- > AvailTC Eq [Eq, ==, \/=] []+  -- > AvailTC Eq [Eq, ==, \/=]   | AvailTC        Name         -- ^ The name of the type or class-       [Name]       -- ^ The available pieces of type or class,-                    -- excluding field selectors.-       [FieldLabel] -- ^ The record fields of the type+       [GreName]      -- ^ The available pieces of type or class                     -- (see Note [Representing fields in AvailInfo]).     deriving ( Eq    -- ^ Used when deciding if the interface has changed@@ -76,6 +87,8 @@ {- Note [Representing fields in AvailInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [FieldLabel] in GHC.Types.FieldLabel.+ When -XDuplicateRecordFields is disabled (the normal case), a datatype like @@ -83,11 +96,11 @@  gives rise to the AvailInfo -  AvailTC T [T, MkT] [FieldLabel "foo" False foo]+  AvailTC T [T, MkT, FieldLabel "foo" False foo]  whereas if -XDuplicateRecordFields is enabled it gives -  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]+  AvailTC T [T, MkT, FieldLabel "foo" True $sel:foo:MkT]  since the label does not match the selector name. @@ -101,8 +114,8 @@  gives rise to -  AvailTC F [ F, MkFInt, MkFBool ]-            [ FieldLabel "foo" True $sel:foo:MkFInt+  AvailTC F [ F, MkFInt, MkFBool+            , FieldLabel "foo" True $sel:foo:MkFInt             , FieldLabel "foo" True $sel:foo:MkFBool ]  Moreover, note that the flIsOverloaded flag need not be the same for@@ -111,8 +124,8 @@ `-XDuplicateRecordFields` enabled and one with it disabled.  Thus it is possible to have -  AvailTC F [ F, MkFInt, MkFBool ]-            [ FieldLabel "foo" True $sel:foo:MkFInt+  AvailTC F [ F, MkFInt, MkFBool+            , FieldLabel "foo" True $sel:foo:MkFInt             , FieldLabel "foo" False foo ]  If the two data instances are defined in different modules, both@@ -121,21 +134,59 @@ enabled), because they would be represented identically.  The workaround here is to enable `-XDuplicateRecordFields` on the defining modules.+++Note [Representing pattern synonym fields in AvailInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Record pattern synonym fields cannot be represented using AvailTC like fields of+normal record types (see Note [Representing fields in AvailInfo]), because they+do not always have a parent type constructor.  So we represent them using the+Avail constructor, with a NormalGreName that carries the underlying FieldLabel.++Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration++  pattern MkFoo{f} = Bar f++gives rise to the AvailInfo++  Avail (NormalGreName MkFoo)+  Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo))++However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in+an export list, then whenever `f` is imported the parent will be `T`,+represented as++  AvailTC T [ NormalGreName T+            , NormalGreName MkFoo+            , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ]++See also Note [GreNames] in GHC.Types.Name.Reader. -}  -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering-stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2-stableAvailCmp (Avail {})         (AvailTC {})   = LT-stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =-    (n `stableNameCmp` m) `thenCmp`-    (cmpList stableNameCmp ns ms) `thenCmp`-    (cmpList (stableNameCmp `on` flSelector) nfs mfs)-stableAvailCmp (AvailTC {})       (Avail {})     = GT+stableAvailCmp (Avail c1)     (Avail c2)     = c1 `stableGreNameCmp` c2+stableAvailCmp (Avail {})     (AvailTC {})   = LT+stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`+                                               (cmpList stableGreNameCmp ns ms)+stableAvailCmp (AvailTC {})   (Avail {})     = GT +stableGreNameCmp :: GreName -> GreName -> Ordering+stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2+stableGreNameCmp (NormalGreName {}) (FieldGreName  {}) = LT+stableGreNameCmp (FieldGreName  f1) (FieldGreName  f2) = flSelector f1 `stableNameCmp` flSelector f2+stableGreNameCmp (FieldGreName  {}) (NormalGreName {}) = GT+ avail :: Name -> AvailInfo-avail n = Avail n+avail n = Avail (NormalGreName n) +availField :: FieldLabel -> AvailInfo+availField fl = Avail (FieldGreName fl)++availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo+availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls)++ -- ----------------------------------------------------------------------------- -- Operations on AvailInfo @@ -152,49 +203,107 @@      where add avail env = extendNameEnvList env                                 (zip (availNames avail) (repeat avail)) +-- | Does this 'AvailInfo' export the parent decl?  This depends on the+-- invariant that the parent is first if it appears at all.+availExportsDecl :: AvailInfo -> Bool+availExportsDecl (AvailTC ty_name names)+  | n : _ <- names = NormalGreName ty_name == n+  | otherwise      = False+availExportsDecl _ = True+ -- | Just the main name made available, i.e. not the available pieces--- of type or class brought into scope by the 'GenAvailInfo'+-- of type or class brought into scope by the 'AvailInfo' availName :: AvailInfo -> Name-availName (Avail n)     = n-availName (AvailTC n _ _) = n+availName (Avail n)     = greNameMangledName n+availName (AvailTC n _) = n +availGreName :: AvailInfo -> GreName+availGreName (Avail c) = c+availGreName (AvailTC n _) = NormalGreName n+ -- | All names made available by the availability information (excluding overloaded selectors) availNames :: AvailInfo -> [Name]-availNames (Avail n)         = [n]-availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]+availNames (Avail c) = childNonOverloadedNames c+availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs +childNonOverloadedNames :: GreName -> [Name]+childNonOverloadedNames (NormalGreName n) = [n]+childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ]+ -- | All names made available by the availability information (including overloaded selectors) availNamesWithSelectors :: AvailInfo -> [Name]-availNamesWithSelectors (Avail n)         = [n]-availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs+availNamesWithSelectors (Avail c) = [greNameMangledName c]+availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs  -- | Names for non-fields made available by the availability information availNonFldNames :: AvailInfo -> [Name]-availNonFldNames (Avail n)        = [n]-availNonFldNames (AvailTC _ ns _) = ns+availNonFldNames (Avail (NormalGreName n)) = [n]+availNonFldNames (Avail (FieldGreName {})) = []+availNonFldNames (AvailTC _ ns) = mapMaybe f ns+  where+    f (NormalGreName n) = Just n+    f (FieldGreName {}) = Nothing  -- | Fields made available by the availability information availFlds :: AvailInfo -> [FieldLabel]-availFlds (AvailTC _ _ fs) = fs-availFlds _                = []+availFlds (Avail c) = maybeToList (greNameFieldLabel c)+availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs -availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]-availsNamesWithOccs = concatMap availNamesWithOccs+-- | Names and fields made available by the availability information.+availGreNames :: AvailInfo -> [GreName]+availGreNames (Avail c)      = [c]+availGreNames (AvailTC _ cs) = cs --- | 'Name's made available by the availability information, paired with--- the 'OccName' used to refer to each one.------ When @DuplicateRecordFields@ is in use, the 'Name' may be the--- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the--- 'OccName' will be the label of the field (e.g. @foo@).------ See Note [Representing fields in AvailInfo].-availNamesWithOccs :: AvailInfo -> [(Name, OccName)]-availNamesWithOccs (Avail n) = [(n, nameOccName n)]-availNamesWithOccs (AvailTC _ ns fs)-  = [ (n, nameOccName n) | n <- ns ] ++-    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]+-- | Names and fields made available by the availability information, other than+-- the main decl itself.+availSubordinateGreNames :: AvailInfo -> [GreName]+availSubordinateGreNames (Avail {}) = []+availSubordinateGreNames avail@(AvailTC _ ns)+  | availExportsDecl avail = tail ns+  | otherwise              = ns ++-- | Used where we may have an ordinary name or a record field label.+-- See Note [GreNames] in GHC.Types.Name.Reader.+data GreName = NormalGreName Name+             | FieldGreName FieldLabel+    deriving (Data, Eq)++instance Outputable GreName where+  ppr (NormalGreName n) = ppr n+  ppr (FieldGreName fl) = ppr fl++instance HasOccName GreName where+  occName (NormalGreName n) = occName n+  occName (FieldGreName fl) = occName fl++-- | A 'Name' for internal use, but not for output to the user.  For fields, the+-- 'OccName' will be the selector.  See Note [GreNames] in GHC.Types.Name.Reader.+greNameMangledName :: GreName -> Name+greNameMangledName (NormalGreName n) = n+greNameMangledName (FieldGreName fl) = flSelector fl++-- | A 'Name' suitable for output to the user.  For fields, the 'OccName' will+-- be the field label.  See Note [GreNames] in GHC.Types.Name.Reader.+greNamePrintableName :: GreName -> Name+greNamePrintableName (NormalGreName n) = n+greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl++greNameSrcSpan :: GreName -> SrcSpan+greNameSrcSpan (NormalGreName n) = nameSrcSpan n+greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl)++greNameFieldLabel :: GreName -> Maybe FieldLabel+greNameFieldLabel (NormalGreName {}) = Nothing+greNameFieldLabel (FieldGreName fl)  = Just fl++partitionGreNames :: [GreName] -> ([Name], [FieldLabel])+partitionGreNames = partitionEithers . map to_either+  where+    to_either (NormalGreName n) = Left n+    to_either (FieldGreName fl) = Right fl++ -- ----------------------------------------------------------------------------- -- Utility @@ -203,30 +312,22 @@   | debugIsOn && availName a1 /= availName a2   = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) plusAvail a1@(Avail {})         (Avail {})        = a1-plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2-plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1-plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)-  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first+plusAvail (AvailTC _ [])     a2@(AvailTC {})   = a2+plusAvail a1@(AvailTC {})       (AvailTC _ []) = a1+plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))+  = case (NormalGreName n1==s1, NormalGreName n2==s2) of  -- Maintain invariant the parent is first        (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))-                                   (fs1 `unionLists` fs2)        (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))-                                   (fs1 `unionLists` fs2)        (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))-                                   (fs1 `unionLists` fs2)        (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))-                                   (fs1 `unionLists` fs2)-plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)-  = AvailTC n1 ss1 (fs1 `unionLists` fs2)-plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)-  = AvailTC n1 ss2 (fs1 `unionLists` fs2) plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])  -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo-trimAvail (Avail n)         _ = Avail n-trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of-    Just x  -> AvailTC n [] [x]-    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []+trimAvail avail@(Avail {})         _ = avail+trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of+    Just c  -> AvailTC n [c]+    Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m])  -- | filters 'AvailInfo's by the given predicate filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]@@ -236,12 +337,11 @@ filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest =   case ie of-    Avail n | keep n    -> ie : rest+    Avail c | keep (greNameMangledName c) -> ie : rest             | otherwise -> rest-    AvailTC tc ns fs ->-        let ns' = filter keep ns-            fs' = filter (keep . flSelector) fs in-        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest+    AvailTC tc cs ->+        let cs' = filter (keep . greNameMangledName) cs+        in if null cs' then rest else AvailTC tc cs' : rest   -- | Combines 'AvailInfo's from the same family@@ -263,19 +363,17 @@ pprAvail :: AvailInfo -> SDoc pprAvail (Avail n)   = ppr n-pprAvail (AvailTC n ns fs)-  = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi-                         , fsep (punctuate comma (map (ppr . flLabel) fs))])+pprAvail (AvailTC n ns)+  = ppr n <> braces (fsep (punctuate comma (map ppr ns)))  instance Binary AvailInfo where     put_ bh (Avail aa) = do             putByte bh 0             put_ bh aa-    put_ bh (AvailTC ab ac ad) = do+    put_ bh (AvailTC ab ac) = do             putByte bh 1             put_ bh ab             put_ bh ac-            put_ bh ad     get bh = do             h <- getByte bh             case h of@@ -283,5 +381,19 @@                       return (Avail aa)               _ -> do ab <- get bh                       ac <- get bh-                      ad <- get bh-                      return (AvailTC ab ac ad)+                      return (AvailTC ab ac)++instance Binary GreName where+    put_ bh (NormalGreName aa) = do+            putByte bh 0+            put_ bh aa+    put_ bh (FieldGreName ab) = do+            putByte bh 1+            put_ bh ab+    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      return (NormalGreName aa)+              _ -> do ab <- get bh+                      return (FieldGreName ab)
compiler/GHC/Types/Demand.hs view
@@ -34,7 +34,7 @@     lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,     -- ** Other @Demand@ operations     oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand,-    peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,+    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,     addCaseBndrDmd,     -- ** Extracting one-shot information     argOneShots, argsOneShots, saturatedByOneShots,@@ -55,6 +55,7 @@     PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,     -- ** Other operations     peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,+    keepAliveDmdType,      -- * Demand signatures     StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,@@ -73,7 +74,7 @@     seqDemand, seqDemandList, seqDmdType, seqStrictSig,      -- * Zapping usage information-    zapUsageDemand, zapUsageEnvSig, zapUsedOnceDemand, zapUsedOnceSig+    zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig   ) where  #include "GhclibHsVersions.h"@@ -267,10 +268,12 @@   -- with the specified cardinality at every level.   -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'.   ---  -- @Poly n@ is semantically equivalent to @nP(n,n,...)@ or @Cn(Cn(..Cn(n)))@.-  -- So @U === UP(U,U,...)@ and @U === CU(CU(..CU(U)))@,-  --    @S === SP(S,S,...)@ and @S === CS(CS(..CS(S)))@, and so on.+  -- @Poly n@ is semantically equivalent to @Prod [n :* Poly n, ...]@ or+  -- @Call n (Poly n)@. 'mkCall' and 'mkProd' do these rewrites.   --+  -- In Note [Demand notation]: @U === P(U,U,...)@ and @U === CU(U)@,+  --                            @S === P(S,S,...)@ and @S === CS(S)@, and so on.+  --   -- We only really use 'Poly' with 'C_10' (bottom), 'C_00' (absent),   -- 'C_0N' (top) and sometimes 'C_1N', but it's simpler to treat it uniformly   -- than to have a special constructor for each of the three cases.@@ -278,7 +281,8 @@   -- ^ @Call n sd@ describes the evaluation context of @n@ function   -- applications, where every individual result is evaluated according to @sd@.   -- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative].-  -- Used only for values of function type.+  -- Used only for values of function type. Use the smart constructor 'mkCall'+  -- whenever possible!   | Prod ![Demand]   -- ^ @Prod ds@ describes the evaluation context of a case scrutinisation   -- on an expression of product type, where the product components are@@ -306,7 +310,7 @@ polyDmd C_10 = C_10 :* poly10  -- | A smart constructor for 'Prod', applying rewrite rules along the semantic--- equalities @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'+-- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly' -- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a -- polymorphic demand will never unbox. mkProd :: [Demand] -> SubDemand@@ -335,6 +339,13 @@ {-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation                         -- for Arity. Otherwise, #18304 bites us. +-- | A smart constructor for 'Call', applying rewrite rules along the semantic+-- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's+-- when possible.+mkCall :: Card -> SubDemand -> SubDemand+mkCall n cd@(Poly m) | n == m = cd+mkCall n cd                   = Call n cd+ -- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as -- necessary. viewCall :: SubDemand -> Maybe (Card, SubDemand)@@ -356,8 +367,9 @@ -- Handle Call lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))   -- See Note [Call demands are relative]-  | isAbs n2  = Call (lubCard n1 n2) (lubSubDmd d1 botSubDmd)-  | otherwise = Call (lubCard n1 n2) (lubSubDmd d1        d2)+  | isAbs n1  = mkCall (lubCard n1 n2) (lubSubDmd botSubDmd d2)+  | isAbs n2  = mkCall (lubCard n1 n2) (lubSubDmd d1 botSubDmd)+  | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1        d2) -- Handle Poly lubSubDmd (Poly n1)  (Poly n2) = Poly (lubCard n1 n2) -- Make use of reflexivity (so we'll match the Prod or Call cases again).@@ -367,7 +379,7 @@  -- | Denotes '∪' on 'Demand'. lubDmd :: Demand -> Demand -> Demand-lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1   n2   :* lubSubDmd sd1       sd2+lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2  -- | Denotes '+' on 'SubDemand'. plusSubDmd :: SubDemand -> SubDemand -> SubDemand@@ -377,8 +389,9 @@ -- Handle Call plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))   -- See Note [Call demands are relative]-  | isAbs n2  = Call (plusCard n1 n2) (lubSubDmd d1 botSubDmd)-  | otherwise = Call (plusCard n1 n2) (lubSubDmd d1        d2)+  | isAbs n1  = mkCall (plusCard n1 n2) (lubSubDmd botSubDmd d2)+  | isAbs n2  = mkCall (plusCard n1 n2) (lubSubDmd d1 botSubDmd)+  | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1        d2) -- Handle Poly plusSubDmd (Poly n1)  (Poly n2) = Poly (plusCard n1 n2) -- Make use of reflexivity (so we'll match the Prod or Call cases again).@@ -407,7 +420,7 @@ multSubDmd n sd   | Just sd' <- multTrivial n seqSubDmd sd = sd' multSubDmd n (Poly n')    = Poly (multCard n n')-multSubDmd n (Call n' sd) = Call (multCard n n') sd -- See Note [Call demands are relative]+multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative] multSubDmd n (Prod ds)    = Prod (map (multDmd n) ds)  multDmd :: Card -> Demand -> Demand@@ -457,22 +470,22 @@ -- | First argument of 'GHC.Exts.maskAsyncExceptions#': @SCS(U)@. -- Called exactly once. strictOnceApply1Dmd :: Demand-strictOnceApply1Dmd = C_11 :* Call C_11 topSubDmd+strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd  -- | First argument of 'GHC.Exts.atomically#': @MCM(U)@. -- Called at least once, possibly many times. strictManyApply1Dmd :: Demand-strictManyApply1Dmd = C_1N :* Call C_1N topSubDmd+strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd  -- | First argument of catch#: @1C1(U)@. -- Evaluates its arg lazily, but then applies it exactly once to one argument. lazyApply1Dmd :: Demand-lazyApply1Dmd = C_01 :* Call C_01 topSubDmd+lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd  -- | Second argument of catch#: @1C1(CS(U))@. -- Calls its arg lazily, but then applies it exactly once to an additional argument. lazyApply2Dmd :: Demand-lazyApply2Dmd = C_01 :* Call C_01 (Call C_11 topSubDmd)+lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)  -- | Make a 'Demand' evaluated at-most-once. oneifyDmd :: Demand -> Demand@@ -512,12 +525,12 @@ strictifyDictDmd _  dmd = dmd  -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @CS(d)@.-mkCallDmd :: SubDemand -> SubDemand-mkCallDmd sd = Call C_11 sd+mkCalledOnceDmd :: SubDemand -> SubDemand+mkCalledOnceDmd sd = mkCall C_11 sd --- | @mkCallDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.-mkCallDmds :: Arity -> SubDemand -> SubDemand-mkCallDmds arity sd = iterate mkCallDmd sd !! arity+-- | @mkCalledOnceDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.+mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand+mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity  -- | Peels one call level from the sub-demand, and also returns how many -- times we entered the lambda body.@@ -669,7 +682,7 @@ is used but the components of the case alternative are not.  Note [Don't optimise UP(U,U,...) to U]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ These two SubDemands:    UP(U,U) (@Prod [topDmd, topDmd]@)   and   U (@topSubDmd@) are semantically equivalent, but we do not turn the former into@@ -1184,6 +1197,11 @@ deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType +-- | See 'keepAliveDmdEnv'.+keepAliveDmdType :: DmdType -> VarSet -> DmdType+keepAliveDmdType (DmdType fvs ds res) vars =+  DmdType (fvs `keepAliveDmdEnv` vars) ds res+ {- Note [Demand type Divergence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1571,9 +1589,9 @@ it should not fall over. -} -zapUsageEnvSig :: StrictSig -> StrictSig--- Remove the usage environment from the demand-zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r+-- | Remove the demand environment from the signature.+zapDmdEnvSig :: StrictSig -> StrictSig+zapDmdEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r  zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand@@ -1615,8 +1633,8 @@  kill_usage_sd :: KillFlags -> SubDemand -> SubDemand kill_usage_sd kfs (Call n sd)-  | kf_called_once kfs      = Call (lubCard C_1N n) (kill_usage_sd kfs sd)-  | otherwise               = Call n                (kill_usage_sd kfs sd)+  | kf_called_once kfs      = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)+  | otherwise               = mkCall n                (kill_usage_sd kfs sd) kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds) kill_usage_sd _   sd        = sd @@ -1640,7 +1658,7 @@   where     go (Prod ds)   (TsProd tss)       | equalLength ds tss    = Prod (zipWith trimToType ds tss)-    go (Call n sd) (TsFun ts) = Call n (go sd ts)+    go (Call n sd) (TsFun ts) = mkCall n (go sd ts)     go sd@Poly{}   _          = sd     go _           _          = topSubDmd @@ -1804,7 +1822,7 @@     h <- getByte bh     case h of       0 -> Poly <$> get bh-      1 -> Call <$> get bh <*> get bh+      1 -> mkCall <$> get bh <*> get bh       2 -> Prod <$> get bh       _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))
compiler/GHC/Types/FieldLabel.hs view
@@ -1,12 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE FlexibleContexts   #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}  {- % % (c) Adam Gundry 2013-2015 % +Note [FieldLabel]+~~~~~~~~~~~~~~~~~+ This module defines the representation of FieldLabels as stored in TyCons.  As well as a selector name, these have some extra structure to support the DuplicateRecordFields extension.@@ -63,9 +68,9 @@ module GHC.Types.FieldLabel    ( FieldLabelString    , FieldLabelEnv-   , FieldLbl(..)-   , FieldLabel-   , mkFieldLabelOccs+   , FieldLabel(..)+   , fieldSelectorOccName+   , fieldLabelPrintableName    ) where @@ -89,22 +94,26 @@ type FieldLabelEnv = DFastStringEnv FieldLabel  -type FieldLabel = FieldLbl Name---- | Fields in an algebraic record type-data FieldLbl a = FieldLabel {+-- | Fields in an algebraic record type; see Note [FieldLabel].+data FieldLabel = FieldLabel {       flLabel        :: FieldLabelString, -- ^ User-visible label of the field       flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on                                           --   in the defining module for this datatype?-      flSelector     :: a                 -- ^ Record selector function+      flSelector     :: Name              -- ^ Record selector function     }-  deriving (Eq, Functor, Foldable, Traversable)-deriving instance Data a => Data (FieldLbl a)+  deriving (Data, Eq) -instance Outputable a => Outputable (FieldLbl a) where-    ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))+instance HasOccName FieldLabel where+  occName = mkVarOccFS . flLabel -instance Binary a => Binary (FieldLbl a) where+instance Outputable FieldLabel where+    ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)))++-- | We need the @Binary Name@ constraint here even though there is an instance+-- defined in "GHC.Types.Name", because the we have a SOURCE import, so the+-- instance is not in scope.  And the instance cannot be added to Name.hs-boot+-- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name".+instance Binary Name => Binary FieldLabel where     put_ bh (FieldLabel aa ab ac) = do         put_ bh aa         put_ bh ab@@ -120,11 +129,18 @@ -- and the name of the first data constructor of the type, to support -- duplicate record field names. -- See Note [Why selector names include data constructors].-mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName-mkFieldLabelOccs lbl dc is_overloaded-  = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded-               , flSelector = sel_occ }+fieldSelectorOccName :: FieldLabelString -> OccName -> Bool -> OccName+fieldSelectorOccName lbl dc is_overloaded+  | is_overloaded = mkRecFldSelOcc str+  | otherwise     = mkVarOccFS lbl   where     str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc-    sel_occ | is_overloaded = mkRecFldSelOcc str-            | otherwise     = mkVarOccFS lbl++-- | Undo the name mangling described in Note [FieldLabel] to produce a Name+-- that has the user-visible OccName (but the selector's unique).  This should+-- be used only when generating output, when we want to show the label, but may+-- need to qualify it with a module prefix.+fieldLabelPrintableName :: FieldLabel -> Name+fieldLabelPrintableName fl+  | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl))+  | otherwise         = flSelector fl
compiler/GHC/Types/ForeignCall.hs view
@@ -206,24 +206,26 @@  instance Outputable CCallSpec where   ppr (CCallSpec fun cconv safety)-    = hcat [ whenPprDebug callconv, ppr_fun fun ]+    = hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ]     where       callconv = text "{-" <> ppr cconv <> text "-}" -      gc_suf | playSafe safety = text "_GC"-             | otherwise       = empty+      gc_suf | playSafe safety = text "_safe"+             | otherwise       = text "_unsafe" -      ppr_fun (StaticTarget st _fn mPkgId isFun)-        = text (if isFun then "__pkg_ccall"-                         else "__pkg_ccall_value")+      ppr_fun (StaticTarget st lbl mPkgId isFun)+        = text (if isFun then "__ffi_static_ccall"+                         else "__ffi_static_ccall_value")        <> gc_suf        <+> (case mPkgId of             Nothing -> empty             Just pkgId -> ppr pkgId)+       <> text ":"+       <> ppr lbl        <+> (pprWithSourceText st empty)        ppr_fun DynamicTarget-        = text "__dyn_ccall" <> gc_suf <+> text "\"\""+        = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""  -- The filename for a C header file -- Note [Pragma source text] in GHC.Types.SourceText
compiler/GHC/Types/Id/Info.hs view
@@ -650,7 +650,7 @@ zapUsageEnvInfo :: IdInfo -> Maybe IdInfo zapUsageEnvInfo info     | hasDemandEnvSig (strictnessInfo info)-    = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})+    = Just (info {strictnessInfo = zapDmdEnvSig (strictnessInfo info)})     | otherwise     = Nothing
compiler/GHC/Types/Id/Make.hs view
@@ -1657,18 +1657,36 @@  Note [noinlineId magic] ~~~~~~~~~~~~~~~~~~~~~~~-noinline :: forall a. a -> a- 'noinline' is used to make sure that a function f is never inlined,-e.g., as in 'noinline f x'.  Ordinarily, the identity function with NOINLINE-could be used to achieve this effect; however, this has the unfortunate-result of leaving a (useless) call to noinline at runtime.  So we have-a little bit of magic to optimize away 'noinline' after we are done-running the simplifier.+e.g., as in 'noinline f x'.  We won't inline f because we never inline+lone variables (see Note [Lone variables] in GHC.Core.Unfold -'noinline' needs to be wired-in because it gets inserted automatically-when we serialize an expression to the interface format. See-Note [Inlining and hs-boot files] in GHC.CoreToIface+You might think that we could implement noinline like this:+   {-# NOINLINE #-}+   noinline :: forall a. a -> a+   noinline x = x++But actually we give 'noinline' a wired-in name for three distinct reasons:++1. We don't want to leave a (useless) call to noinline in the final program,+   to be executed at runtime. So we have a little bit of magic to+   optimize away 'noinline' after we are done running the simplifier.+   This is done in GHC.CoreToStg.Prep.cpeApp.++2. 'noinline' sometimes gets inserted automatically when we serialize an+   expression to the interface format, in GHC.CoreToIface.toIfaceVar.+   See Note [Inlining and hs-boot files] in GHC.CoreToIface++3. Given foo :: Eq a => [a] -> Bool, the expression+     noinline foo x xs+   where x::Int, will naturally desugar to+      noinline @Int (foo @Int dEqInt) x xs+   But now it's entirely possible htat (foo @Int dEqInt) will inline foo,+   since 'foo' is no longer a lone variable -- see #18995++   Solution: in the desugarer, rewrite+      noinline (f x y)  ==>  noinline f x y+   This is done in GHC.HsToCore.Utils.mkCoreAppDs.  Note that noinline as currently implemented can hide some simplifications since it hides strictness from the demand analyser. Specifically, the demand analyser
compiler/GHC/Types/Name.hs-boot view
@@ -3,13 +3,16 @@     module GHC.Types.Name.Occurrence ) where -import GHC.Prelude ()+import GHC.Prelude (Eq) import {-# SOURCE #-} GHC.Types.Name.Occurrence import GHC.Types.Unique import GHC.Utils.Outputable+import Data.Data (Data)  data Name +instance Eq Name+instance Data Name instance Uniquable Name instance Outputable Name @@ -22,3 +25,4 @@ nameUnique :: Name -> Unique setNameUnique :: Name -> Unique -> Name nameOccName :: Name -> OccName+tidyNameOcc :: Name -> OccName -> Name
compiler/GHC/Types/Name/Ppr.hs view
@@ -13,6 +13,7 @@ import GHC.Prelude  import GHC.Unit+import GHC.Unit.Env import GHC.Unit.State  import GHC.Core.TyCon@@ -69,12 +70,14 @@  -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics.-mkPrintUnqualified :: UnitState -> HomeUnit -> GlobalRdrEnv -> PrintUnqualified-mkPrintUnqualified unit_state home_unit env+mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified+mkPrintUnqualified unit_env env  = QueryQualify qual_name       (mkQualModule unit_state home_unit)       (mkQualPackage unit_state)   where+  unit_state = ue_units unit_env+  home_unit  = ue_home_unit unit_env   qual_name mod occ         | [gre] <- unqual_gres         , right_name gre@@ -117,7 +120,7 @@           map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ]           ++ [ eqTyConName ] -        right_name gre = nameModule_maybe (gre_name gre) == Just mod+        right_name gre = greDefinitionModule gre == Just mod          unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env         qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)
compiler/GHC/Types/Name/Reader.hs view
@@ -46,7 +46,8 @@         GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,         lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,         pprGlobalRdrEnv, globalRdrEnvElts,-        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,+        lookupGRE_RdrName, lookupGRE_Name,+        lookupGRE_GreName, lookupGRE_FieldLabel,         lookupGRE_Name_OccName,         getGRE_NameQualifier_maybes,         transformGREs, pickGREs, pickGREsModExp,@@ -55,11 +56,14 @@         gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,         greRdrNames, greSrcSpan, greQualModName,         gresToAvailInfo,+        greDefinitionModule, greDefinitionSrcSpan,+        greMangledName, grePrintableName,          -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'-        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel,+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greFieldLabel,         unQualOK, qualSpecOK, unQualSpecOK,         pprNameProvenance,+        GreName(..), greNameSrcSpan,         Parent(..), greParent_maybe,         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),         importSpecLoc, importSpecModule, isExplicitItem, bestImport,@@ -473,42 +477,35 @@ --                 greOccName gre = occ -- --              NB: greOccName gre is usually the same as---                  nameOccName (gre_name gre), but not always in the---                  case of record selectors; see greOccName+--                  nameOccName (greMangledName gre), but not always in the+--                  case of record selectors; see Note [GreNames]  -- | Global Reader Element -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt-  = GRE { gre_name :: Name-        , gre_par  :: Parent+  = GRE { gre_name :: GreName      -- ^ See Note [GreNames]+        , gre_par  :: Parent       -- ^ See Note [Parents]         , gre_lcl :: Bool          -- ^ True <=> the thing was defined locally         , gre_imp :: [ImportSpec]  -- ^ In scope through these imports     } deriving (Data, Eq)          -- INVARIANT: either gre_lcl = True or gre_imp is non-empty          -- See Note [GlobalRdrElt provenance] --- | The children of a Name are the things that are abbreviated by the ".."---   notation in export lists.  See Note [Parents]+-- | See Note [Parents] data Parent = NoParent             | ParentIs  { par_is :: Name }-            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }-              -- ^ See Note [Parents for record fields]             deriving (Eq, Data)  instance Outputable Parent where    ppr NoParent        = empty    ppr (ParentIs n)    = text "parent:" <> ppr n-   ppr (FldParent n f) = text "fldparent:"-                             <> ppr n <> colon <> ppr f  plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _)    p2 = hasParent p1 p2-plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 plusParent p1 p2@(ParentIs _)    = hasParent p2 p1-plusParent p1 p2@(FldParent _ _) = hasParent p2 p1-plusParent _ _                   = NoParent+plusParent NoParent NoParent     = NoParent  hasParent :: Parent -> Parent -> Parent #if defined(DEBUG)@@ -545,10 +542,15 @@  In A.hs, 'T' is locally bound, *and* imported as B.T. + Note [Parents] ~~~~~~~~~~~~~~~~~+The children of a Name are the things that are abbreviated by the ".." notation+in export lists.++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   Parent           Children-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   data T           Data constructors                    Record-field ids @@ -558,51 +560,66 @@   class C          Class operations                    Associated type constructors -~~~~~~~~~~~~~~~~~~~~~~~~~- Constructor      Meaning- ~~~~~~~~~~~~~~~~~~~~~~~~-  NoParent        Can not be bundled with a type constructor.-  ParentIs n      Can be bundled with the type constructor corresponding to-                  n.-  FldParent       See Note [Parents for record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Constructor      Meaning+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  NoParent         Not bundled with a type constructor.+  ParentIs n       Bundled with the type constructor corresponding to n. +Pattern synonym constructors (and their record fields, if any) are unusual:+their gre_par is NoParent in the module in which they are defined.  However, a+pattern synonym can be bundled with a type constructor on export, in which case+whenever the pattern synonym is imported the gre_par will be ParentIs. +Thus the gre_name and gre_par fields are independent, because a normal datatype+introduces FieldGreNames using ParentIs, but a record pattern synonym can+introduce FieldGreNames that use NoParent. (In the past we represented fields+using an additional constructor of the Parent type, which could not adequately+represent this situation.) See also+Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail.  -Note [Parents for record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For record fields, in addition to the Name of the type constructor-(stored in par_is), we use FldParent to store the field label.  This-extra information is used for identifying overloaded record fields-during renaming.--In a definition arising from a normal module (without--XDuplicateRecordFields), par_lbl will be Nothing, meaning that the-field's label is the same as the OccName of the selector's Name.  The-GlobalRdrEnv will contain an entry like this:+Note [GreNames]+~~~~~~~~~~~~~~~+A `GlobalRdrElt` has a field `gre_name :: GreName`, which uniquely+identifies what the `GlobalRdrElt` describes.  There are two sorts of+`GreName` (see the data type decl): -    "x" |->  GRE x (FldParent T Nothing) LocalDef+* NormalGreName Name: this is used for most entities; the Name+  uniquely identifies it. It is stored in the GlobalRdrEnv under+  the OccName of the Name. -When -XDuplicateRecordFields is enabled for the module that contains-T, the selector's Name will be mangled (see comments in GHC.Types.FieldLabel).-Thus we store the actual field label in par_lbl, and the GlobalRdrEnv-entry looks like this:+* FieldGreName FieldLabel: is used only for field labels of a+  record. With -XDuplicateRecordFields there may be many field+  labels `x` in scope; e.g.+     data T1 = MkT1 { x :: Int }+     data T2 = MkT2 { x :: Bool }+  Each has a different GlobalRdrElt with a distinct GreName.+  The two fields are uniquely identified by their record selectors,+  which are stored in the FieldLabel, and have mangled names like+  `$sel:x:MkT1`.  See Note [FieldLabel] in GHC.Types.FieldLabel. -    "x" |->  GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef+  These GREs are stored in the GlobalRdrEnv under the OccName of the+  field (i.e. "x" in both cases above), /not/ the OccName of the mangled+  record selector function. -Note that the OccName used when adding a GRE to the environment-(greOccName) now depends on the parent field: for FldParent it is the-field label, if present, rather than the selector name.+A GreName, and hence a GRE, has both a "printable" and a "mangled" Name.  These+are identical for normal names, but for record fields compiled with+-XDuplicateRecordFields they will differ. So we have two pairs of functions: -~~+ * greNameMangledName :: GreName -> Name+   greMangledName :: GlobalRdrElt -> Name+   The "mangled" Name is the actual Name of the selector function,+   e.g. $sel:x:MkT1.  This should not be displayed to the user, but is used to+   uniquely identify the field in the renamer, and later in the backend. -Record pattern synonym selectors are treated differently. Their parent-information is `NoParent` in the module in which they are defined. This is because-a pattern synonym `P` has no parent constructor either.+ * greNamePrintableName :: GreName -> Name+   grePrintableName :: GlobalRdrElt -> Name+   The "printable" Name is the "manged" Name with its OccName replaced with that+   of the field label.  This is how the field should be output to the user. -However, if `f` is bundled with a type constructor `T` then whenever `f` is-imported the parent will use the `Parent` constructor so the parent of `f` is-now `T`.+Since the right Name to use is context-dependent, we do not define a NamedThing+instance for GREName (or GlobalRdrElt), but instead make the choice explicit.   Note [Combining parents]@@ -652,32 +669,52 @@     mk_gre n       = case prov_fn n of  -- Nothing => bound locally                            -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = n, gre_par = mkParent n avail+          Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail                          , gre_lcl = True, gre_imp = [] }-          Just is -> GRE { gre_name = n, gre_par = mkParent n avail+          Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail                          , gre_lcl = False, gre_imp = [is] } -    mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded-                           , flSelector = n })-      = case prov_fn n of  -- Nothing => bound locally+    mk_fld_gre fl+      = case prov_fn (flSelector fl) of  -- Nothing => bound locally                            -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+          Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail                          , gre_lcl = True, gre_imp = [] }-          Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+          Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail                          , gre_lcl = False, gre_imp = [is] }-      where-        mb_lbl | is_overloaded = Just lbl-               | otherwise     = Nothing +instance HasOccName GlobalRdrElt where+  occName = greOccName +-- | See Note [GreNames]+greOccName :: GlobalRdrElt -> OccName+greOccName = occName . gre_name++-- | A 'Name' for the GRE for internal use.  Careful: the 'OccName' of this+-- 'Name' is not necessarily the same as the 'greOccName' (see Note [GreNames]).+greMangledName :: GlobalRdrElt -> Name+greMangledName = greNameMangledName . gre_name++-- | A 'Name' for the GRE suitable for output to the user.  Its 'OccName' will+-- be the 'greOccName' (see Note [GreNames]).+grePrintableName :: GlobalRdrElt -> Name+grePrintableName = greNamePrintableName . gre_name++-- | The SrcSpan of the name pointed to by the GRE.+greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan+greDefinitionSrcSpan = nameSrcSpan . greMangledName++-- | The module in which the name pointed to by the GRE is defined.+greDefinitionModule :: GlobalRdrElt -> Maybe Module+greDefinitionModule = nameModule_maybe . greMangledName+ greQualModName :: GlobalRdrElt -> ModuleName -- Get a suitable module qualifier for the GRE -- (used in mkPrintUnqualified)--- Prerecondition: the gre_name is always External-greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })- | lcl, Just mod <- nameModule_maybe name = moduleName mod- | (is:_) <- iss                          = is_as (is_decl is)- | otherwise                              = pprPanic "greQualModName" (ppr gre)+-- Prerecondition: the greMangledName is always External+greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss })+ | lcl, Just mod <- greDefinitionModule gre = moduleName mod+ | (is:_) <- iss                            = is_as (is_decl is)+ | otherwise                                = pprPanic "greQualModName" (ppr gre)  greRdrNames :: GlobalRdrElt -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }@@ -696,21 +733,25 @@ -- declaration.  We want to sort the export locations in -- exportClashErr by this SrcSpan, we need to extract it: greSrcSpan :: GlobalRdrElt -> SrcSpan-greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )-  | lcl           = nameSrcSpan name+greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } )+  | lcl           = greDefinitionSrcSpan gre   | (is:_) <- iss = is_dloc (is_decl is)   | otherwise     = pprPanic "greSrcSpan" (ppr gre)  mkParent :: Name -> AvailInfo -> Parent-mkParent _ (Avail _)           = NoParent-mkParent n (AvailTC m _ _) | n == m    = NoParent+mkParent _ (Avail _)                 = NoParent+mkParent n (AvailTC m _) | n == m    = NoParent                          | otherwise = ParentIs m +availParent :: AvailInfo -> Parent+availParent (AvailTC m _) = ParentIs m+availParent (Avail {})    = NoParent++ greParent_maybe :: GlobalRdrElt -> Maybe Name greParent_maybe gre = case gre_par gre of                         NoParent      -> Nothing                         ParentIs n    -> Just n-                        FldParent n _ -> Just n  -- | Takes a list of distinct GREs and folds them -- into AvailInfos. This is more efficient than mapping each individual@@ -733,46 +774,34 @@       = ( extendNameEnv_Acc comb availFromGRE env key gre         , done `extendNameSet` name )       where-        name = gre_name gre+        name = greMangledName gre         key = case greParent_maybe gre of                  Just parent -> parent-                 Nothing     -> gre_name gre+                 Nothing     -> greMangledName gre          -- We want to insert the child `k` into a list of children but         -- need to maintain the invariant that the parent is first.         --         -- We also use the invariant that `k` is not already in `ns`.-        insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]+        insertChildIntoChildren :: Name -> [GreName] -> GreName -> [GreName]         insertChildIntoChildren _ [] k = [k]         insertChildIntoChildren p (n:ns) k-          | p == k = k:n:ns+          | NormalGreName p == k = k:n:ns           | otherwise = n:k:ns          comb :: GlobalRdrElt -> AvailInfo -> AvailInfo-        comb _ (Avail n) = Avail n -- Duplicated name, should not happen-        comb gre (AvailTC m ns fls)+        comb _   (Avail n) = Avail n -- Duplicated name, should not happen+        comb gre (AvailTC m ns)           = case gre_par gre of-              NoParent    -> AvailTC m (name:ns) fls -- Not sure this ever happens-              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls-              FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls)+              NoParent    -> AvailTC m (gre_name gre:ns) -- Not sure this ever happens+              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (gre_name gre))  availFromGRE :: GlobalRdrElt -> AvailInfo-availFromGRE (GRE { gre_name = me, gre_par = parent })+availFromGRE (GRE { gre_name = child, gre_par = parent })   = case parent of-      ParentIs p                  -> AvailTC p [me] []-      NoParent   | isTyConName me -> AvailTC me [me] []-                 | otherwise      -> avail   me-      FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]--mkFieldLabel :: Name -> Maybe FastString -> FieldLabel-mkFieldLabel me mb_lbl =-          case mb_lbl of-                 Nothing  -> FieldLabel { flLabel = occNameFS (nameOccName me)-                                        , flIsOverloaded = False-                                        , flSelector = me }-                 Just lbl -> FieldLabel { flLabel = lbl-                                        , flIsOverloaded = True-                                        , flSelector = me }+      ParentIs p -> AvailTC p [child]+      NoParent | NormalGreName me <- child, isTyConName me -> AvailTC me [child]+               | otherwise -> Avail child  emptyGlobalRdrEnv :: GlobalRdrEnv emptyGlobalRdrEnv = emptyOccEnv@@ -781,7 +810,7 @@ globalRdrEnvElts env = foldOccEnv (++) [] env  instance Outputable GlobalRdrElt where-  ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))+  ppr gre = hang (ppr (greMangledName gre) <+> ppr (gre_par gre))                2 (pprNameProvenance gre)  pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc@@ -799,17 +828,13 @@                      <> colon)                  2 (vcat (map ppr gres))       where-        occ = nameOccName (gre_name (head gres))+        occ = nameOccName (greMangledName (head gres))  lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of                                   Nothing   -> []                                   Just gres -> gres -greOccName :: GlobalRdrElt -> OccName-greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl-greOccName gre                                            = nameOccName (gre_name gre)- lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] lookupGRE_RdrName rdr_name env   = case lookupOccEnv env (rdrNameOcc rdr_name) of@@ -823,6 +848,13 @@ lookupGRE_Name env name   = lookupGRE_Name_OccName env name (nameOccName name) +lookupGRE_GreName :: GlobalRdrEnv -> GreName -> Maybe GlobalRdrElt+-- ^ Look for precisely this 'GreName' in the environment.  This tests+-- whether it is in scope, ignoring anything else that might be in+-- scope with the same 'OccName'.+lookupGRE_GreName env gname+  = lookupGRE_Name_OccName env (greNameMangledName gname) (occName gname)+ lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt -- ^ Look for a particular record field selector in the environment, where the -- selector name and field label may be different: the GlobalRdrEnv is keyed on@@ -836,7 +868,7 @@ -- Note [Parents for record fields]. lookupGRE_Name_OccName env name occ   = case [ gre | gre <- lookupGlobalRdrEnv env occ-               , gre_name gre == name ] of+               , greMangledName gre == name ] of       []    -> Nothing       [gre] -> Just gre       gres  -> pprPanic "lookupGRE_Name_OccName"@@ -861,20 +893,16 @@ isLocalGRE (GRE {gre_lcl = lcl }) = lcl  isRecFldGRE :: GlobalRdrElt -> Bool-isRecFldGRE (GRE {gre_par = FldParent{}}) = True-isRecFldGRE _                             = False+isRecFldGRE = isJust . greFieldLabel  isOverloadedRecFldGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with DuplicateRecordFields? -- (See Note [Parents for record fields])-isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True-isOverloadedRecFldGRE _                                             = False+isOverloadedRecFldGRE = maybe False flIsOverloaded . greFieldLabel --- Returns the field label of this GRE, if it has one-greLabel :: GlobalRdrElt -> Maybe FieldLabelString-greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl-greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))-greLabel _                                              = Nothing+greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel+-- ^ Returns the field label of this GRE, if it has one+greFieldLabel = greNameFieldLabel . gre_name  unQualOK :: GlobalRdrElt -> Bool -- ^ Test if an unqualified version of this thing would be in scope@@ -936,17 +964,17 @@     iss' = filter unQualSpecOK iss  pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt-pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })+pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss })   | not lcl', null iss' = Nothing   | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })   where     iss' = filter (qualSpecOK mod) iss-    lcl' = lcl && name_is_from mod n+    lcl' = lcl && name_is_from mod -    name_is_from :: ModuleName -> Name -> Bool-    name_is_from mod name = case nameModule_maybe name of-                              Just n_mod -> moduleName n_mod == mod-                              Nothing    -> False+    name_is_from :: ModuleName -> Bool+    name_is_from mod = case greDefinitionModule gre of+                         Just n_mod -> moduleName n_mod == mod+                         Nothing    -> False  pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] -- ^ Pick GREs that are in scope *both* qualified *and* unqualified@@ -965,8 +993,8 @@ -- cluttered envt is no use.  Really, it's only useful for -- GHC.Base and GHC.Tuple. pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)-pickBothGRE mod gre@(GRE { gre_name = n })-  | isBuiltInSyntax n                = Nothing+pickBothGRE mod gre+  | isBuiltInSyntax (greMangledName gre)   = Nothing   | Just gre1 <- pickQualGRE mod gre   , Just gre2 <- pickUnqualGRE   gre = Just (gre1, gre2)   | otherwise                        = Nothing@@ -1104,8 +1132,8 @@      shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt     shadow_with new_name-       old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })-       = case nameModule_maybe old_name of+       old_gre@(GRE { gre_lcl = lcl, gre_imp = iss })+       = case greDefinitionModule old_gre of            Nothing -> Just old_gre   -- Old name is Internal; do not shadow            Just old_mod               | Just new_mod <- nameModule_maybe new_name@@ -1120,17 +1148,17 @@                where                 iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss-                lcl_imp | lcl       = [mk_fake_imp_spec old_name old_mod]+                lcl_imp | lcl       = [mk_fake_imp_spec old_gre old_mod]                         | otherwise = [] -    mk_fake_imp_spec old_name old_mod    -- Urgh!+    mk_fake_imp_spec old_gre old_mod    -- Urgh!       = ImpSpec id_spec ImpAll       where         old_mod_name = moduleName old_mod         id_spec      = ImpDeclSpec { is_mod = old_mod_name                                    , is_as = old_mod_name                                    , is_qual = True-                                   , is_dloc = nameSrcSpan old_name }+                                   , is_dloc = greDefinitionSrcSpan old_gre }      shadow_is :: Name -> ImportSpec -> Maybe ImportSpec     shadow_is new_name is@(ImpSpec { is_decl = id_spec })@@ -1297,10 +1325,11 @@ pprNameProvenance :: GlobalRdrElt -> SDoc -- ^ Print out one place where the name was define/imported -- (With -dppr-debug, print them all)-pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })+pprNameProvenance gre@(GRE { gre_lcl = lcl, gre_imp = iss })   = ifPprDebug (vcat pp_provs)                (head pp_provs)   where+    name = greMangledName gre     pp_provs = pp_lcl ++ map pp_is iss     pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]                     else []
compiler/GHC/Types/TyThing.hs view
@@ -253,11 +253,10 @@ tyThingAvailInfo :: TyThing -> [AvailInfo] tyThingAvailInfo (ATyCon t)    = case tyConClass_maybe t of-        Just c  -> [AvailTC n (n : map getName (classMethods c)-                                 ++ map getName (classATs c))-                             [] ]+        Just c  -> [availTC n ((n : map getName (classMethods c)+                                 ++ map getName (classATs c))) [] ]              where n = getName c-        Nothing -> [AvailTC n (n : map getName dcs) flds]+        Nothing -> [availTC n (n : map getName dcs) flds]              where n    = getName t                    dcs  = tyConDataCons t                    flds = tyConFieldLabels t
compiler/GHC/Types/Unique/DFM.hs view
@@ -15,8 +15,12 @@ -}  {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} @@ -38,6 +42,7 @@         adjustUDFM_Directly,         alterUDFM,         mapUDFM,+        mapMaybeUDFM,         plusUDFM,         plusUDFM_C,         lookupUDFM, lookupUDFM_Directly,@@ -121,7 +126,7 @@   TaggedVal     val     {-# UNPACK #-} !Int -- ^ insertion time-  deriving (Data, Functor)+  deriving stock (Data, Functor, Foldable, Traversable)  taggedFst :: TaggedVal val -> val taggedFst (TaggedVal v _) = v@@ -398,6 +403,10 @@ -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i++mapMaybeUDFM :: forall elt1 elt2 key.+                (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2+mapMaybeUDFM f (UDFM m i) = UDFM (M.mapMaybe (traverse f) m) i  anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m
+ compiler/GHC/Unit/Env.hs view
@@ -0,0 +1,61 @@+module GHC.Unit.Env+    ( UnitEnv (..)+    , preloadUnitsInfo+    , preloadUnitsInfo'+    )+where++import GHC.Prelude++import GHC.Unit.State+import GHC.Unit.Home+import GHC.Unit.Types++import GHC.Platform+import GHC.Settings+import GHC.Data.Maybe++data UnitEnv = UnitEnv+    { ue_units     :: !UnitState      -- ^ Units+    , ue_home_unit :: !HomeUnit       -- ^ Home unit+    , ue_platform  :: !Platform       -- ^ Platform+    , ue_namever   :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix)+    }++-- -----------------------------------------------------------------------------+-- Extracting information from the packages in scope++-- Many of these functions take a list of packages: in those cases,+-- the list is expected to contain the "dependent packages",+-- i.e. those packages that were found to be depended on by the+-- current module/program.  These can be auto or non-auto packages, it+-- doesn't really matter.  The list is always combined with the list+-- of preload (command-line) packages to determine which packages to+-- use.++-- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit+-- used to instantiate the home unit, and for every unit explicitly passed in+-- the given list of UnitId.+preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]+preloadUnitsInfo' unit_env ids0 = all_infos+  where+    home_unit  = ue_home_unit unit_env+    unit_state = ue_units     unit_env+    ids      = ids0 ++ inst_ids+    inst_ids+       -- An indefinite package will have insts to HOLE,+       -- which is not a real package. Don't look it up.+       -- Fixes #14525+       | isHomeUnitIndefinite home_unit = []+       | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)+    pkg_map = unitInfoMap unit_state+    preload = preloadUnits unit_state++    all_pkgs  = closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing)+    all_infos = map (unsafeLookupUnitId unit_state) <$> all_pkgs+++-- | Lookup 'UnitInfo' for every preload unit from the UnitState and for every+-- unit used to instantiate the home unit.+preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo]+preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env []
compiler/GHC/Unit/Home.hs view
@@ -43,9 +43,7 @@ -- unit identifier) with `homeUnitMap`. -- -- TODO: this isn't implemented yet. UnitKeys are still converted too early into--- UnitIds in GHC.Unit.State.readUnitDataBase and wiring of home unit--- instantiations is done inplace in DynFlags by--- GHC.Unit.State.upd_wired_in_home_instantiations.+-- UnitIds in GHC.Unit.State.readUnitDataBase data GenHomeUnit u    = DefiniteHomeUnit UnitId (Maybe (u, GenInstantiations u))       -- ^ Definite home unit (i.e. that we can compile).
compiler/GHC/Unit/Info.hs view
@@ -19,24 +19,42 @@    , unitPackageNameString    , unitPackageIdString    , pprUnitInfo++   , collectIncludeDirs+   , collectExtraCcOpts+   , collectLibraryDirs+   , collectFrameworks+   , collectFrameworksDirs+   , unitHsLibs    ) where  #include "GhclibHsVersions.h"  import GHC.Prelude+import GHC.Platform.Ways -import GHC.Unit.Database-import Data.Version-import Data.Bifunctor+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic +import GHC.Types.Unique+ import GHC.Data.FastString import qualified GHC.Data.ShortText as ST-import GHC.Utils.Outputable+ import GHC.Unit.Module as Module-import GHC.Types.Unique import GHC.Unit.Ppr+import GHC.Unit.Database +import GHC.Settings++import Data.Version+import Data.Bifunctor+import Data.List (isPrefixOf, stripPrefix)+import qualified Data.Set as Set++ -- | Information about an installed unit -- -- We parameterize on the unit identifier:@@ -165,3 +183,75 @@    (unitPackageNameString i)    (unitPackageVersion i)    ((unpackFS . unPackageName) <$> unitComponentName i)++-- | Find all the include directories in the given units+collectIncludeDirs :: [UnitInfo] -> [FilePath]+collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps))++-- | Find all the C-compiler options in the given units+collectExtraCcOpts :: [UnitInfo] -> [String]+collectExtraCcOpts ps = map ST.unpack (concatMap unitCcOptions ps)++-- | Find all the library directories in the given units for the given ways+collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath]+collectLibraryDirs ws = ordNub . filter notNull . concatMap (libraryDirsForWay ws)++-- | Find all the frameworks in the given units+collectFrameworks :: [UnitInfo] -> [String]+collectFrameworks ps = map ST.unpack (concatMap unitExtDepFrameworks ps)++-- | Find all the package framework paths in these and the preload packages+collectFrameworksDirs :: [UnitInfo] -> [String]+collectFrameworksDirs ps = map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps)))++-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.+libraryDirsForWay :: Ways -> UnitInfo -> [String]+libraryDirsForWay ws+  | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs+  | otherwise        = map ST.unpack . unitLibraryDirs++unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String]+unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p)+  where+        ways1 = Set.filter (/= WayDyn) ways0+        -- the name of a shared library is libHSfoo-ghc<version>.so+        -- we leave out the _dyn, because it is superfluous++        -- debug and profiled RTSs include support for -eventlog+        ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1+              = Set.filter (/= WayTracing) ways1+              | otherwise+              = ways1++        tag     = waysTag (fullWays ways2)+        rts_tag = waysTag ways2++        mkDynName x+         | not (ways0 `hasWay` WayDyn) = x+         | "HS" `isPrefixOf` x         = x ++ dynLibSuffix namever+           -- For non-Haskell libraries, we use the name "Cfoo". The .a+           -- file is libCfoo.a, and the .so is libfoo.so. That way the+           -- linker knows what we mean for the vanilla (-lCfoo) and dyn+           -- (-lfoo) ways. We therefore need to strip the 'C' off here.+         | Just x' <- stripPrefix "C" x = x'+         | otherwise+            = panic ("Don't understand library name " ++ x)++        -- Add _thr and other rts suffixes to packages named+        -- `rts` or `rts-1.0`. Why both?  Traditionally the rts+        -- package is called `rts` only.  However the tooling+        -- usually expects a package name to have a version.+        -- As such we will gradually move towards the `rts-1.0`+        -- package name, at which point the `rts` package name+        -- will eventually be unused.+        --+        -- This change elevates the need to add custom hooks+        -- and handling specifically for the `rts` package for+        -- example in ghc-cabal.+        addSuffix rts@"HSrts"    = rts       ++ (expandTag rts_tag)+        addSuffix rts@"HSrts-1.0"= rts       ++ (expandTag rts_tag)+        addSuffix other_lib      = other_lib ++ (expandTag tag)++        expandTag t | null t = ""+                    | otherwise = '_':t+
compiler/GHC/Unit/Module/Graph.hs view
@@ -1,17 +1,26 @@+{-# LANGUAGE LambdaCase      #-} {-# LANGUAGE RecordWildCards #-}  module GHC.Unit.Module.Graph    ( ModuleGraph+   , ModuleGraphNode(..)    , emptyMG    , mkModuleGraph+   , mkModuleGraph'    , extendMG+   , extendMGInst+   , extendMG'+   , filterToposortToModules    , mapMG    , mgModSummaries+   , mgModSummaries'+   , mgExtendedModSummaries    , mgElemModule    , mgLookupModule    , mgBootModules    , needsTemplateHaskellOrQQ    , isTemplateHaskellOrQQNonBoot+   , showModMsg    ) where @@ -19,21 +28,50 @@  import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.Maybe+import GHC.Data.Graph.Directed ( SCC(..) )++import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Driver.Session +import GHC.Types.SourceFile ( hscSourceString )+ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Env import GHC.Unit.Types+import GHC.Utils.Outputable +import System.FilePath --- | A ModuleGraph contains all the nodes from the home package (only).--- There will be a node for each source module, plus a node for each hi-boot--- module.+-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.+-- Edges between nodes mark dependencies arising from module imports+-- and dependencies arising from backpack instantiations.+data ModuleGraphNode+  -- | Instantiation nodes track the instantiation of other units+  -- (backpack dependencies) with the holes (signatures) of the current package.+  = InstantiationNode InstantiatedUnit+  -- | There is a module summary node for each module, signature, and boot module being built.+  | ModuleNode ExtendedModSummary++instance Outputable ModuleGraphNode where+  ppr = \case+    InstantiationNode iuid -> ppr iuid+    ModuleNode ems -> ppr ems++-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See+-- '@ModuleGraphNode@' for information about the nodes. --+-- Modules need to be compiled. hs-boots need to be typechecked before+-- the associated "real" module so modules with {-# SOURCE #-} imports can be+-- built. Instantiations also need to be typechecked to ensure that the module+-- fits the signature. Substantiation typechecking is roughly comparable to the+-- check that the module and its hs-boot agree.+-- -- The graph is not necessarily stored in topologically-sorted order.  Use -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph-  { mg_mss :: [ModSummary]+  { mg_mss :: [ModuleGraphNode]   , mg_non_boot :: ModuleEnv ModSummary     -- a map of all non-boot ModSummaries keyed by Modules   , mg_boot :: ModuleSet@@ -56,7 +94,9 @@ -- To preserve invariants 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg-  { mg_mss = map f mg_mss+  { mg_mss = flip fmap mg_mss $ \case+      InstantiationNode iuid -> InstantiationNode iuid+      ModuleNode (ExtendedModSummary ms bds) -> ModuleNode (ExtendedModSummary (f ms) bds)   , mg_non_boot = mapModuleEnv f mg_non_boot   } @@ -64,8 +104,14 @@ mgBootModules ModuleGraph{..} = mg_boot  mgModSummaries :: ModuleGraph -> [ModSummary]-mgModSummaries = mg_mss+mgModSummaries mg = [ m | ModuleNode (ExtendedModSummary m _) <- mgModSummaries' mg ] +mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary]+mgExtendedModSummaries mg = [ ems | ModuleNode ems <- mgModSummaries' mg ]++mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]+mgModSummaries' = mg_mss+ mgElemModule :: ModuleGraph -> Module -> Bool mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot @@ -82,11 +128,11 @@     || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&   (isBootSummary ms == NotBoot) --- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is+-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is -- not an element of the ModuleGraph.-extendMG :: ModuleGraph -> ModSummary -> ModuleGraph-extendMG ModuleGraph{..} ms = ModuleGraph-  { mg_mss = ms:mg_mss+extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph+extendMG ModuleGraph{..} ems@(ExtendedModSummary ms _) = ModuleGraph+  { mg_mss = ModuleNode ems : mg_mss   , mg_non_boot = case isBootSummary ms of       IsBoot -> mg_non_boot       NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms@@ -96,6 +142,67 @@   , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms   } -mkModuleGraph :: [ModSummary] -> ModuleGraph+extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph+extendMGInst mg depUnitId = mg+  { mg_mss = InstantiationNode depUnitId : mg_mss mg+  }++extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph+extendMG' mg = \case+  InstantiationNode depUnitId -> extendMGInst mg depUnitId+  ModuleNode ems -> extendMG mg ems++mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph mkModuleGraph = foldr (flip extendMG) emptyMG++mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph+mkModuleGraph' = foldr (flip extendMG') emptyMG++-- | This function filters out all the instantiation nodes from each SCC of a+-- topological sort. Use this with care, as the resulting "strongly connected components"+-- may not really be strongly connected in a direct way, as instantiations have been+-- removed. It would probably be best to eliminate uses of this function where possible.+filterToposortToModules+  :: [SCC ModuleGraphNode] -> [SCC ModSummary]+filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case+  InstantiationNode _ -> Nothing+  ModuleNode (ExtendedModSummary node _) -> Just node+  where+    -- This higher order function is somewhat bogus,+    -- as the definition of "strongly connected component"+    -- is not necessarily respected.+    mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b)+    mapMaybeSCC f = \case+      AcyclicSCC a -> AcyclicSCC <$> f a+      CyclicSCC as -> case mapMaybe f as of+        [] -> Nothing+        [a] -> Just $ AcyclicSCC a+        as -> Just $ CyclicSCC as++showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc+showModMsg _ _ (InstantiationNode indef_unit) =+  ppr $ instUnitInstanceOf indef_unit+showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) =+  if gopt Opt_HideSourcePaths dflags+      then text mod_str+      else hsep $+         [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')+         , char '('+         , text (op $ msHsFilePath mod_summary) <> char ','+         ] +++         if gopt Opt_BuildDynamicToo dflags+            then [ text obj_file <> char ','+                 , text dyn_file+                 , char ')'+                 ]+            else [ text obj_file, char ')' ]+  where+    op       = normalise+    mod      = moduleName (ms_mod mod_summary)+    mod_str  = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)+    dyn_file = op $ msDynObjFilePath mod_summary dflags+    obj_file = case backend dflags of+                Interpreter | recomp -> "interpreted"+                NoBackend            -> "nothing"+                _                    -> (op $ msObjFilePath mod_summary)
compiler/GHC/Unit/Module/ModSummary.hs view
@@ -1,7 +1,11 @@+{-# LANGUAGE LambdaCase #-}+ -- | A ModSummary is a node in the compilation manager's dependency graph -- (ModuleGraph) module GHC.Unit.Module.ModSummary-   ( ModSummary (..)+   ( ExtendedModSummary (..)+   , extendModSummaryNoDeps+   , ModSummary (..)    , ms_installed_mod    , ms_mod_name    , ms_imps@@ -13,7 +17,6 @@    , msObjFilePath    , msDynObjFilePath    , isBootSummary-   , showModMsg    , findTarget    ) where@@ -22,9 +25,7 @@  import GHC.Hs -import GHC.Driver.Ppr import GHC.Driver.Session-import GHC.Driver.Backend  import GHC.Unit.Types import GHC.Unit.Module@@ -40,9 +41,24 @@ import GHC.Utils.Outputable  import Data.Time-import System.FilePath --- | A single node in a 'ModuleGraph'. The nodes of the module graph+-- | Enrichment of 'ModSummary' with backpack dependencies+data ExtendedModSummary = ExtendedModSummary+  { emsModSummary :: {-# UNPACK #-} !ModSummary+  , emsInstantiatedUnits :: [InstantiatedUnit]+  -- ^ Extra backpack deps+  -- NB: This is sometimes left empty in situations where the instantiated units+  -- would not be used. See call sites of 'extendModSummaryNoDeps'.+  }++instance Outputable ExtendedModSummary where+  ppr = \case+    ExtendedModSummary ms bds -> ppr ms <+> ppr bds++extendModSummaryNoDeps :: ModSummary -> ExtendedModSummary+extendModSummaryNoDeps ms = ExtendedModSummary ms []++-- | Data for a module node in a 'ModuleGraph'. Module nodes of the module graph -- are one of: -- -- * A regular Haskell source module@@ -53,7 +69,7 @@         ms_mod          :: Module,           -- ^ Identity of the module         ms_hsc_src      :: HscSource,-          -- ^ The module source either plain Haskell or hs-boot+          -- ^ The module source either plain Haskell, hs-boot, or hsig         ms_location     :: ModLocation,           -- ^ Location of the various files belonging to the module         ms_hs_date      :: UTCTime,@@ -150,31 +166,6 @@              char '}'             ] -showModMsg :: DynFlags -> Bool -> ModSummary -> SDoc-showModMsg dflags recomp mod_summary =-   if gopt Opt_HideSourcePaths dflags-      then text mod_str-      else hsep $-         [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')-         , char '('-         , text (op $ msHsFilePath mod_summary) <> char ','-         ] ++-         if gopt Opt_BuildDynamicToo dflags-            then [ text obj_file <> char ','-                 , text dyn_file-                 , char ')'-                 ]-            else [ text obj_file, char ')' ]-  where-    op       = normalise-    mod      = moduleName (ms_mod mod_summary)-    mod_str  = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)-    dyn_file = op $ msDynObjFilePath mod_summary dflags-    obj_file = case backend dflags of-                Interpreter | recomp -> "interpreted"-                NoBackend            -> "nothing"-                _                    -> (op $ msObjFilePath mod_summary)- findTarget :: ModSummary -> [Target] -> Maybe Target findTarget ms ts =   case filter (matches ms) ts of@@ -188,3 +179,5 @@         = f == f'     _ `matches` _         = False++
compiler/GHC/Unit/State.hs view
@@ -1,6 +1,7 @@ -- (c) The University of Glasgow, 2006  {-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}  -- | Unit manipulation module GHC.Unit.State (@@ -9,6 +10,7 @@         -- * Reading the package config, and processing cmdline args         UnitState(..),         UnitDatabase (..),+        UnitErr (..),         emptyUnitState,         initUnits,         readUnitDatabases,@@ -33,18 +35,16 @@         lookupModuleInAllUnits,         lookupModuleWithSuggestions,         lookupPluginModuleWithSuggestions,+        requirementMerges,         LookupResult(..),         ModuleSuggestion(..),         ModuleOrigin(..),         UnusableUnitReason(..),         pprReason, -        -- * Inspecting the set of packages in scope-        getUnitIncludePath,-        getUnitExtraCcOpts,-        getPreloadUnitsAnd,--        collectIncludeDirs,+        closeUnitDeps,+        closeUnitDeps',+        mayThrowUnitErr,          -- * Module hole substitution         ShHoleSubst,@@ -73,19 +73,23 @@  import GHC.Prelude +import GHC.Driver.Session+ import GHC.Platform-import GHC.Unit.Home+import GHC.Platform.Ways+ import GHC.Unit.Database import GHC.Unit.Info import GHC.Unit.Ppr import GHC.Unit.Types import GHC.Unit.Module-import GHC.Driver.Session-import GHC.Platform.Ways+import GHC.Unit.Home+ import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet+ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable@@ -94,7 +98,7 @@ import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST-import GHC.Utils.Error  ( debugTraceMsg, MsgDoc, dumpIfSet_dyn,+import GHC.Utils.Error  ( debugTraceMsg, dumpIfSet_dyn,                           withTiming, DumpFormat (..) ) import GHC.Utils.Exception @@ -342,8 +346,8 @@    , unitConfigFlagsPlugins :: [PackageFlag]       -- ^ Plugins exposed units    } -initUnitConfig :: DynFlags -> UnitConfig-initUnitConfig dflags =+initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig+initUnitConfig dflags cached_dbs =    let !hu_id             = homeUnitId_ dflags        !hu_instanceof     = homeUnitInstanceOf_ dflags        !hu_instantiations = homeUnitInstantiations_ dflags@@ -376,7 +380,7 @@       , unitConfigHideAll        = gopt Opt_HideAllPackages dflags       , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags -      , unitConfigDBCache      = unitDatabases dflags+      , unitConfigDBCache      = cached_dbs       , unitConfigFlagsDB      = packageDBFlags dflags       , unitConfigFlagsExposed = packageFlags dflags       , unitConfigFlagsIgnored = ignorePackageFlags dflags@@ -573,28 +577,56 @@ -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'.-initUnits :: DynFlags -> IO DynFlags-initUnits dflags = do+initUnits :: DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit)+initUnits dflags cached_dbs = do    let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()   let ctx     = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages   let printer = debugTraceMsg dflags                    -- printer for trace messages -  (state,dbs) <- withTiming dflags (text "initializing unit database")+  (unit_state,dbs) <- withTiming dflags (text "initializing unit database")                    forceUnitInfoMap-                   (mkUnitState ctx printer (initUnitConfig dflags))+                 $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) -  dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Module Map"-    FormatText (pprModuleMap (moduleNameProvidersMap state))+  dumpIfSet_dyn dflags Opt_D_dump_mod_map "Module Map"+    FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})+                $ pprModuleMap (moduleNameProvidersMap unit_state)) -  let dflags'  = dflags-                  { unitDatabases = Just dbs -- databases are cached and never read again-                  , unitState     = state-                  }-      dflags'' = upd_wired_in_home_instantiations dflags'+  let home_unit = mkHomeUnit unit_state+                             (homeUnitId_ dflags)+                             (homeUnitInstanceOf_ dflags)+                             (homeUnitInstantiations_ dflags) -  return dflags''+  return (dbs,unit_state,home_unit) +mkHomeUnit+    :: UnitState+    -> UnitId                 -- ^ Home unit id+    -> Maybe UnitId           -- ^ Home unit instance of+    -> [(ModuleName, Module)] -- ^ Home unit instantiations+    -> HomeUnit+mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =+    let+        -- Some wired units can be used to instantiate the home unit. We need to+        -- replace their unit keys with their wired unit ids.+        wmap              = wireMap unit_state+        hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_+    in case (hu_instanceof, hu_instantiations) of+      (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing+      (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")+      (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")+      (Just u, is)+         -- detect fully indefinite units: all their instantiations are hole+         -- modules and the home unit id is the same as the instantiating unit+         -- id (see Note [About units] in GHC.Unit)+         | all (isHoleModule . snd) is && u == hu_id+         -> IndefiniteHomeUnit u is+         -- otherwise it must be that we (fully) instantiate an indefinite unit+         -- to make it definite.+         -- TODO: error when the unit is partially instantiated??+         | otherwise+         -> DefiniteHomeUnit hu_id (Just (u, is))+ -- ----------------------------------------------------------------------------- -- Reading the unit database(s) @@ -759,30 +791,28 @@ -- -trust and -distrust.  applyTrustFlag-   :: SDocContext-   -> UnitPrecedenceMap+   :: UnitPrecedenceMap    -> UnusableUnits    -> [UnitInfo]    -> TrustFlag-   -> IO [UnitInfo]-applyTrustFlag ctx prec_map unusable pkgs flag =+   -> MaybeErr UnitErr [UnitInfo]+applyTrustFlag prec_map unusable pkgs flag =   case flag of     -- we trust all matching packages. Maybe should only trust first one?     -- and leave others the same or set them untrusted     TrustPackage str ->        case selectPackages prec_map (PackageArg str) pkgs unusable of-         Left ps       -> trustFlagErr ctx flag ps-         Right (ps,qs) -> return (map trust ps ++ qs)+         Left ps       -> Failed (TrustFlagErr flag ps)+         Right (ps,qs) -> Succeeded (map trust ps ++ qs)           where trust p = p {unitIsTrusted=True}      DistrustPackage str ->        case selectPackages prec_map (PackageArg str) pkgs unusable of-         Left ps       -> trustFlagErr ctx flag ps-         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)+         Left ps       -> Failed (TrustFlagErr flag ps)+         Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs)  applyPackageFlag-   :: SDocContext-   -> UnitPrecedenceMap+   :: UnitPrecedenceMap    -> UnitInfoMap    -> PreloadUnitClosure    -> UnusableUnits@@ -790,15 +820,15 @@            -- any previously exposed packages with the same name    -> [UnitInfo]    -> VisibilityMap           -- Initially exposed-   -> PackageFlag               -- flag to apply-   -> IO VisibilityMap        -- Now exposed+   -> PackageFlag             -- flag to apply+   -> MaybeErr UnitErr VisibilityMap -- Now exposed -applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm flag =+applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =   case flag of     ExposePackage _ arg (ModRenaming b rns) ->        case findPackages prec_map pkg_map closure arg pkgs unusable of-         Left ps         -> packageFlagErr ctx flag ps-         Right (p:_) -> return vm'+         Left ps     -> Failed (PackageFlagErr flag ps)+         Right (p:_) -> Succeeded vm'           where            n = fsPackageName p @@ -861,9 +891,8 @@      HidePackage str ->        case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of-         Left ps  -> packageFlagErr ctx flag ps-         Right ps -> return vm'-          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)+         Left ps  -> Failed (PackageFlagErr flag ps)+         Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps)  -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages.  Furthermore, any packages it returns are *renamed*@@ -970,34 +999,6 @@ comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -packageFlagErr :: SDocContext-               -> PackageFlag-               -> [(UnitInfo, UnusableUnitReason)]-               -> IO a-packageFlagErr ctx flag reasons-  = packageFlagErr' ctx (pprFlag flag) reasons--trustFlagErr :: SDocContext-             -> TrustFlag-             -> [(UnitInfo, UnusableUnitReason)]-             -> IO a-trustFlagErr ctx flag reasons-  = packageFlagErr' ctx (pprTrustFlag flag) reasons--packageFlagErr' :: SDocContext-               -> SDoc-               -> [(UnitInfo, UnusableUnitReason)]-               -> IO a-packageFlagErr' ctx flag_doc reasons-  = throwGhcExceptionIO (CmdLineError (renderWithContext ctx $ err))-  where err = text "cannot satisfy " <> flag_doc <>-                (if null reasons then Outputable.empty else text ": ") $$-              nest 4 (ppr_reasons $$-                      text "(use -v for more information)")-        ppr_reasons = vcat (map ppr_reason reasons)-        ppr_reason (p, reason) =-            pprReason (ppr (unitId p) <+> text "is") reason- pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of     HidePackage p   -> text "-hide-package " <> text p@@ -1117,17 +1118,6 @@ -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in GHC.Builtin.Names. --- | Some wired units can be used to instantiate the home unit. We need to--- replace their unit keys with their wired unit ids.-upd_wired_in_home_instantiations :: DynFlags -> DynFlags-upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations_ = wiredInsts }-   where-      state        = unitState dflags-      wiringMap    = wireMap state-      unwiredInsts = homeUnitInstantiations_ dflags-      wiredInsts   = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts-- upd_wired_in_mod :: WiringMap -> Module -> Module upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m @@ -1482,7 +1472,8 @@    -- Apply trust flags (these flags apply regardless of whether   -- or not packages are visible or not)-  pkgs1 <- foldM (applyTrustFlag ctx prec_map unusable)+  pkgs1 <- mayThrowUnitErr+            $ foldM (applyTrustFlag prec_map unusable)                  (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg))   let prelim_pkg_db = mkUnitInfoMap pkgs1 @@ -1540,7 +1531,8 @@   -- -hide-package).  This needs to know about the unusable packages, since if a   -- user tries to enable an unusable package, we should let them know.   ---  vis_map2 <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable+  vis_map2 <- mayThrowUnitErr+                $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable                         (unitConfigHideAll cfg) pkgs1)                             vis_map1 other_flags @@ -1568,7 +1560,8 @@                         -- won't work.                         | otherwise = vis_map2                 plugin_vis_map2-                    <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable+                    <- mayThrowUnitErr+                        $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable                                 hide_plugin_pkgs pkgs1)                              plugin_vis_map1                              (reverse (unitConfigFlagsPlugins cfg))@@ -1614,8 +1607,9 @@       preload3 = ordNub $ (basicLinkedUnits ++ preload1)    -- Close the preload packages with their dependencies-  let dep_preload_err = closeUnitDeps pkg_db (zip (map toUnitId preload3) (repeat Nothing))-  dep_preload <- throwErr ctx dep_preload_err+  dep_preload <- mayThrowUnitErr+                    $ closeUnitDeps pkg_db+                    $ zip (map toUnitId preload3) (repeat Nothing)    let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map       mod_map2 = mkUnusableModuleNameProvidersMap unusable@@ -1635,7 +1629,6 @@          , requirementContext           = req_ctx          , allowVirtualUnits            = unitConfigAllowVirtual cfg          }-   return (state, raw_dbs)  -- | Given a wired-in 'Unit', "unwire" it into the 'Unit'@@ -1775,31 +1768,7 @@ mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin mkModMap pkg mod = Map.singleton (mkModule pkg mod) --- -------------------------------------------------------------------------------- Extracting information from the packages in scope --- Many of these functions take a list of packages: in those cases,--- the list is expected to contain the "dependent packages",--- i.e. those packages that were found to be depended on by the--- current module/program.  These can be auto or non-auto packages, it--- doesn't really matter.  The list is always combined with the list--- of preload (command-line) packages to determine which packages to--- use.---- | Find all the include directories in these and the preload packages-getUnitIncludePath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]-getUnitIncludePath ctx unit_state home_unit pkgs =-  collectIncludeDirs `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs--collectIncludeDirs :: [UnitInfo] -> [FilePath]-collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps))---- | Find all the C-compiler options in these and the preload packages-getUnitExtraCcOpts :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]-getUnitExtraCcOpts ctx unit_state home_unit pkgs = do-  ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs-  return $ map ST.unpack (concatMap unitCcOptions ps)- -- ----------------------------------------------------------------------------- -- Package Utils @@ -1923,39 +1892,15 @@     map fst (filter visible (Map.toList (moduleNameProvidersMap state)))   where visible (_, ms) = any originVisible (Map.elems ms) --- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit--- used to instantiate the home unit, and for every unit explicitly passed in--- the given list of UnitId.-getPreloadUnitsAnd :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]-getPreloadUnitsAnd ctx unit_state home_unit ids0 =-  let-      ids      = ids0 ++ inst_ids-      inst_ids-         -- An indefinite package will have insts to HOLE,-         -- which is not a real package. Don't look it up.-         -- Fixes #14525-         | isHomeUnitIndefinite home_unit = []-         | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)-      pkg_map = unitInfoMap unit_state-      preload = preloadUnits unit_state-  in do-  all_pkgs <- throwErr ctx (closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing))-  return (map (unsafeLookupUnitId unit_state) all_pkgs)--throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a-throwErr ctx m = case m of-   Failed e    -> throwGhcExceptionIO (CmdLineError (renderWithContext ctx e))-   Succeeded r -> return r- -- | Takes a list of UnitIds (and their "parent" dependency, used for error -- messages), and returns the list with dependencies included, in reverse -- dependency order (a units appears before those it depends on).-closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]+closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps  -- | Similar to closeUnitDeps but takes a list of already loaded units as an -- additional argument.-closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]+closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps  -- | Add a UnitId and those it depends on (recursively) to the given list of@@ -1968,16 +1913,11 @@ add_unit :: UnitInfoMap             -> [UnitId]             -> (UnitId,Maybe UnitId)-            -> MaybeErr MsgDoc [UnitId]+            -> MaybeErr UnitErr [UnitId] add_unit pkg_map ps (p, mb_parent)   | p `elem` ps = return ps     -- Check if we've already added this unit   | otherwise   = case lookupUnitId' pkg_map p of-      Nothing -> Failed $-                   (ftext (fsLit "unknown package:") <+> ppr p)-                   <> case mb_parent of-                         Nothing     -> Outputable.empty-                         Just parent -> space <> parens (text "dependency of"-                                                  <+> ftext (unitIdFS parent))+      Nothing   -> Failed (CloseUnitErr p mb_parent)       Just info -> do          -- Add the unit's dependents also          ps' <- foldM add_unit_key ps (unitDepends info)@@ -1985,6 +1925,57 @@         where           add_unit_key ps key             = add_unit pkg_map ps (key, Just p)++data UnitErr+  = CloseUnitErr !UnitId !(Maybe UnitId)+  | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]+  | TrustFlagErr   !TrustFlag   ![(UnitInfo,UnusableUnitReason)]++mayThrowUnitErr :: MaybeErr UnitErr a -> IO a+mayThrowUnitErr = \case+    Failed e    -> throwGhcExceptionIO+                    $ CmdLineError+                    $ renderWithContext defaultSDocContext+                    $ withPprStyle defaultUserStyle+                    $ ppr e+    Succeeded a -> return a++instance Outputable UnitErr where+    ppr = \case+        CloseUnitErr p mb_parent+            -> (ftext (fsLit "unknown unit:") <+> ppr p)+               <> case mb_parent of+                     Nothing     -> Outputable.empty+                     Just parent -> space <> parens (text "dependency of"+                                              <+> ftext (unitIdFS parent))+        PackageFlagErr flag reasons+            -> flag_err (pprFlag flag) reasons++        TrustFlagErr flag reasons+            -> flag_err (pprTrustFlag flag) reasons+      where+        flag_err flag_doc reasons =+            text "cannot satisfy "+            <> flag_doc+            <> (if null reasons then Outputable.empty else text ": ")+            $$ nest 4 (vcat (map ppr_reason reasons) $$+                      text "(use -v for more information)")++        ppr_reason (p, reason) =+            pprReason (ppr (unitId p) <+> text "is") reason++-- | Return this list of requirement interfaces that need to be merged+-- to form @mod_name@, or @[]@ if this is not a requirement.+requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]+requirementMerges pkgstate mod_name =+    fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))+    where+      -- update IndefUnitId ppr info as they may have changed since the+      -- time the IndefUnitId was created+      fixupModule (Module iud name) = Module iud' name+         where+            iud' = iud { instUnitInstanceOf = cid' }+            cid' = instUnitInstanceOf iud  -- -----------------------------------------------------------------------------
compiler/GHC/Unit/Types.hs view
@@ -676,5 +676,5 @@  instance Outputable a => Outputable (GenWithIsBoot a) where   ppr (GWIB  { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of-    IsBoot -> []-    NotBoot -> [text "{-# SOURCE #-}"]+    IsBoot -> [ text "{-# SOURCE #-}" ]+    NotBoot -> []
compiler/GHC/Utils/Error.hs view
@@ -327,7 +327,8 @@                                 $$ blankLine                                 $$ doc                         return $ mkDumpDoc hdr d-        defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc')+        -- When we dump to files we use UTF8. Which allows ascii spaces.+        defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc')      -- write the dump to stdout     writeDump Nothing = do
compiler/GHC/Utils/Monad.hs view
@@ -88,9 +88,7 @@  zipWithAndUnzipM :: Monad m                  => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])-{-# INLINABLE zipWithAndUnzipM #-}--- See Note [flatten_args performance] in GHC.Tc.Solver.Flatten for why this--- pragma is essential.+{-# INLINABLE zipWithAndUnzipM #-}  -- this allows specialization to a given monad zipWithAndUnzipM f (x:xs) (y:ys)   = do { (c, d) <- f x y        ; (cs, ds) <- zipWithAndUnzipM f xs ys
compiler/GHC/Utils/Outputable.hs view
@@ -115,6 +115,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set+import qualified Data.IntSet as IntSet import Data.String import Data.Word import System.IO        ( Handle )@@ -566,7 +567,7 @@  renderWithContext :: SDocContext -> SDoc -> String renderWithContext ctx sdoc-  = let s = Pretty.style{ Pretty.mode       = PageMode,+  = let s = Pretty.style{ Pretty.mode       = PageMode False,                           Pretty.lineLength = sdocLineLength ctx }     in Pretty.renderStyle s $ runSDoc sdoc ctx @@ -862,6 +863,9 @@  instance (Outputable a) => Outputable (Set a) where     ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))++instance Outputable IntSet.IntSet where+    ppr s = braces (fsep (punctuate comma (map ppr (IntSet.toList s))))  instance (Outputable a, Outputable b) => Outputable (a, b) where     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
compiler/GHC/Utils/Ppr.hs view
@@ -917,16 +917,26 @@           , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length           } --- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).+-- | The default style (@mode=PageMode False, lineLength=100, ribbonsPerLine=1.5@). style :: Style-style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode False }  -- | Rendering mode.-data Mode = PageMode     -- ^ Normal+data Mode = PageMode { asciiSpace :: Bool }    -- ^ Normal           | ZigZagMode   -- ^ With zig-zag cuts           | LeftMode     -- ^ No indentation, infinitely long lines           | OneLineMode  -- ^ All on one line +-- | Can we output an ascii space character for spaces?+--   Mostly true, but not for e.g. UTF16+--   See Note [putSpaces optimizations] for why we bother+--   to track this.+hasAsciiSpace :: Mode -> Bool+hasAsciiSpace mode =+  case mode of+    PageMode asciiSpace -> asciiSpace+    _ -> False+ -- | Render the @Doc@ to a String using the given @Style@. renderStyle :: Style -> Doc -> String renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)@@ -1034,6 +1044,20 @@ -- printDoc adds a newline to the end printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") +{- Note [putSpaces optimizations]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When using dump flags a lot of what we are dumping ends up being whitespace.+This is especially true for Core/Stg dumps. Enough so that it's worth optimizing.++Especially in the common case of writing to an UTF8 or similarly encoded file+where space is equal to ascii space we use hPutBuf to write a preallocated+buffer to the file. This avoids a fair bit of allocation.++For other cases we fall back to the old and slow path for simplicity.++-}+ printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () -- printDoc_ does not add a newline at the end, so that -- successive calls can output stuff on the same line@@ -1051,9 +1075,27 @@                           -- the I/O library's encoding layer. (#3398)     put (ZStr s)   next = hPutFZS  hdl s >> next     put (LStr s)   next = hPutPtrString hdl s >> next-    put (RStr n c) next = hPutStr hdl (replicate n c) >> next+    put (RStr n c) next+      | c == ' '+      = putSpaces n >> next+      | otherwise+      = hPutStr hdl (replicate n c) >> next+    putSpaces n+      -- If we use ascii spaces we are allowed to use hPutBuf+      -- See Note [putSpaces optimizations]+      | hasAsciiSpace mode+      , n <= 100+      = hPutBuf hdl (Ptr spaces') n+      | hasAsciiSpace mode+      , n > 100+      = hPutBuf hdl (Ptr spaces') 100 >> putSpaces (n-100) +      | otherwise = hPutStr hdl (replicate n ' ')+     done = return () -- hPutChar hdl '\n'+    -- 100 spaces, so we avoid the allocation of replicate n ' '+    spaces' = "                                                                                                    "#+    -- some versions of hPutBuf will barf if the length is zero hPutPtrString :: Handle -> PtrString -> IO ()
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 0.20201201+version: 0.20210101 license: BSD3 license-file: LICENSE category: Development@@ -174,7 +174,7 @@         GHC.Core.InstEnv         GHC.Core.Lint         GHC.Core.Make-        GHC.Core.Map+        GHC.Core.Map.Type         GHC.Core.Multiplicity         GHC.Core.Opt.Arity         GHC.Core.Opt.CallerCC@@ -217,6 +217,7 @@         GHC.Data.OrdList         GHC.Data.Pair         GHC.Data.ShortText+        GHC.Data.SizedSeq         GHC.Data.Stream         GHC.Data.StringBuffer         GHC.Data.TrieMap@@ -225,6 +226,7 @@         GHC.Driver.CmdLine         GHC.Driver.Config         GHC.Driver.Env+        GHC.Driver.Env.Types         GHC.Driver.Flags         GHC.Driver.Hooks         GHC.Driver.Monad@@ -365,6 +367,7 @@         GHC.UniqueSubdir         GHC.Unit         GHC.Unit.Database+        GHC.Unit.Env         GHC.Unit.External         GHC.Unit.Finder.Types         GHC.Unit.Home@@ -421,4 +424,3 @@         Language.Haskell.TH.Ppr         Language.Haskell.TH.PprLib         Language.Haskell.TH.Syntax-        SizedSeq
ghc-lib/stage0/compiler/build/GHC/Parser.hs view
@@ -454,8 +454,8 @@ happyOut65 :: (HappyAbsSyn ) -> HappyWrap65 happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut65 #-}-newtype HappyWrap66 = HappyWrap66 (Maybe (Located Token))-happyIn66 :: (Maybe (Located Token)) -> (HappyAbsSyn )+newtype HappyWrap66 = HappyWrap66 (Located (Maybe (Located Token)))+happyIn66 :: (Located (Maybe (Located Token))) -> (HappyAbsSyn ) happyIn66 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap66 x) {-# INLINE happyIn66 #-} happyOut66 :: (HappyAbsSyn ) -> HappyWrap66@@ -778,8 +778,8 @@ happyOut111 :: (HappyAbsSyn ) -> HappyWrap111 happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut111 #-}-newtype HappyWrap112 = HappyWrap112 ([RecordPatSynField (Located RdrName)])-happyIn112 :: ([RecordPatSynField (Located RdrName)]) -> (HappyAbsSyn )+newtype HappyWrap112 = HappyWrap112 ([RecordPatSynField GhcPs])+happyIn112 :: ([RecordPatSynField GhcPs]) -> (HappyAbsSyn ) happyIn112 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap112 x) {-# INLINE happyIn112 #-} happyOut112 :: (HappyAbsSyn ) -> HappyWrap112@@ -3331,7 +3331,7 @@ 	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 ->  	( if (getVARSYM happy_var_1 == fsLit "-")                    then return [mj AnnMinus happy_var_1]-                   else do { addError $ Error ErrExpectedHyphen [] (getLoc happy_var_1)+                   else do { addError $ PsError PsErrExpectedHyphen [] (getLoc happy_var_1)                            ; return [] })}) 	) (\r -> happyReturn (happyIn26 r)) @@ -4158,18 +4158,20 @@ 	case happyOut67 happy_x_8 of { (HappyWrap67 happy_var_8) ->  	case happyOut68 happy_x_9 of { (HappyWrap68 happy_var_9) ->  	( do {-                  ; checkImportDecl happy_var_4 happy_var_7-                  ; ams (L (comb4 happy_var_1 happy_var_6 (snd happy_var_8) happy_var_9) $+                  ; let { ; mPreQual = unLoc happy_var_4+                          ; mPostQual = unLoc happy_var_7 }+                  ; checkImportDecl mPreQual mPostQual+                  ; ams (L (comb5 happy_var_1 happy_var_6 happy_var_7 (snd happy_var_8) happy_var_9) $                       ImportDecl { ideclExt = noExtField                                   , ideclSourceSrc = snd $ fst happy_var_2                                   , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5                                   , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3-                                  , ideclQualified = importDeclQualifiedStyle happy_var_4 happy_var_7+                                  , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual                                   , ideclImplicit = False                                   , ideclAs = unLoc (snd happy_var_8)                                   , ideclHiding = unLoc happy_var_9 })-                         (mj AnnImport happy_var_1 : fst (fst happy_var_2) ++ fst happy_var_3 ++ fmap (mj AnnQualified) (maybeToList happy_var_4)-                                          ++ fst happy_var_5 ++ fmap (mj AnnQualified) (maybeToList happy_var_7) ++ fst happy_var_8)+                         (mj AnnImport happy_var_1 : fst (fst happy_var_2) ++ fst happy_var_3 ++ fmap (mj AnnQualified) (maybeToList mPreQual)+                                          ++ fst happy_var_5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst happy_var_8)                   })}}}}}}}}}) 	) (\r -> happyReturn (happyIn62 r)) @@ -4211,7 +4213,7 @@ 	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 ->  	( do { let { pkgFS = getSTRING happy_var_1 }                         ; unless (looksLikePackageName (unpackFS pkgFS)) $-                             addError $ Error (ErrInvalidPackageName pkgFS) [] (getLoc happy_var_1)+                             addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc happy_var_1)                         ; return ([mj AnnPackageName happy_var_1], Just (StringLiteral (getSTRINGs happy_var_1) pkgFS)) })}) 	) (\r -> happyReturn (happyIn65 r)) @@ -4226,13 +4228,13 @@ happyReduction_125 happy_x_1 	 =  case happyOutTok happy_x_1 of { happy_var_1 ->  	happyIn66-		 (Just happy_var_1+		 (sL1 happy_var_1 (Just happy_var_1) 	)}  happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) happyReduce_126 = happySpecReduce_0  50# happyReduction_126 happyReduction_126  =  happyIn66-		 (Nothing+		 (noLoc Nothing 	)  happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -5604,7 +5606,7 @@ 	 =  case happyOut267 happy_x_1 of { (HappyWrap267 happy_var_1) ->  	case happyOut111 happy_x_2 of { (HappyWrap111 happy_var_2) ->  	happyIn110-		 ((happy_var_1, PrefixCon happy_var_2, [])+		 ((happy_var_1, PrefixCon noTypeArgs happy_var_2, []) 	)}}  happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -5655,7 +5657,7 @@ happyReduction_250 happy_x_1 	 =  case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) ->  	happyIn112-		 ([RecordPatSynField happy_var_1 happy_var_1]+		 ([RecordPatSynField (mkFieldOcc happy_var_1) happy_var_1] 	)}  happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -5668,7 +5670,7 @@ 	case happyOutTok happy_x_2 of { happy_var_2 ->  	case happyOut112 happy_x_3 of { (HappyWrap112 happy_var_3) ->  	( addAnnotation (getLoc happy_var_1) AnnComma (getLoc happy_var_2) >>-                                         return ((RecordPatSynField happy_var_1 happy_var_1) : happy_var_3 ))}}})+                                         return ((RecordPatSynField (mkFieldOcc happy_var_1) happy_var_1) : happy_var_3 ))}}}) 	) (\r -> happyReturn (happyIn112 r))  happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -6154,7 +6156,7 @@ 	 = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 ->  	( if (getVARSYM happy_var_1 == fsLit "~")                    then return [mj AnnTilde happy_var_1]-                   else do { addError $ Error ErrInvalidRuleActivationMarker [] (getLoc happy_var_1)+                   else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc happy_var_1)                            ; return [] })}) 	) (\r -> happyReturn (happyIn130 r)) @@ -11940,7 +11942,7 @@ getSCC lt = do let s = getSTRING lt                -- We probably actually want to be more restrictive than this                if ' ' `elem` unpackFS s-                   then addFatalError $ Error ErrSpaceInSCC [] (getLoc lt)+                   then addFatalError $ PsError PsErrSpaceInSCC [] (getLoc lt)                    else return s  -- Utilities for combining source spans@@ -11956,6 +11958,11 @@     (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $                 combineSrcSpans (getLoc c) (getLoc d)) +comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan+comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`+    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $+       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))+ -- strict constructor version: {-# INLINE sL #-} sL :: SrcSpan -> a -> Located a@@ -12025,7 +12032,7 @@ hintLinear :: MonadP m => SrcSpan -> m () hintLinear span = do   linearEnabled <- getBit LinearTypesBit-  unless linearEnabled $ addError $ Error ErrLinearFunction [] span+  unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span  -- Does this look like (a %m)? looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool@@ -12044,14 +12051,14 @@ hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do   mwiEnabled <- getBit MultiWayIfBit-  unless mwiEnabled $ addError $ Error ErrMultiWayIf [] span+  unless mwiEnabled $ addError $ PsError PsErrMultiWayIf [] span  -- Hint about explicit-forall hintExplicitForall :: Located Token -> P () hintExplicitForall tok = do     forall   <- getBit ExplicitForallBit     rulePrag <- getBit InRulePragBit-    unless (forall || rulePrag) $ addError $ Error (ErrExplicitForall (isUnicode tok)) [] (getLoc tok)+    unless (forall || rulePrag) $ addError $ PsError (PsErrExplicitForall (isUnicode tok)) [] (getLoc tok)  -- Hint about qualified-do hintQualifiedDo :: Located Token -> P ()@@ -12059,7 +12066,7 @@     qualifiedDo   <- getBit QualifiedDoBit     case maybeQDoDoc of       Just qdoDoc | not qualifiedDo ->-        addError $ Error (ErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)+        addError $ PsError (PsErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)       _ -> return ()   where     maybeQDoDoc = case unLoc tok of@@ -12073,7 +12080,7 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do     thQuotes <- getBit ThQuotesBit-    addFatalError $ Error (ErrEmptyDoubleQuotes thQuotes) [] span+    addFatalError $ PsError (PsErrEmptyDoubleQuotes thQuotes) [] span  {- %************************************************************************
ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs view
@@ -1027,7 +1027,7 @@                  Layout prev_off _ : _ -> prev_off < offset                  _                     -> True       if isOK then pop_and open_brace span buf len-              else addFatalError $ Error ErrMissingBlock [] (mkSrcSpanPs span)+              else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span)  pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState@@ -1406,7 +1406,7 @@   commentEnd lexToken input commentAcc finalizeComment buf span  errBrace :: AlexInput -> RealSrcSpan -> P a-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (Error (ErrLexer LexUnterminatedComment LexErrKind_EOF) [])+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) [])  open_brace, close_brace :: Action open_brace span _str _len = do@@ -1465,7 +1465,7 @@           lambdaCase <- getBit LambdaCaseBit           unless lambdaCase $ do             pState <- getPState-            addError $ Error ErrLambdaCase [] (mkSrcSpanPs (last_loc pState))+            addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState))           return ITlcase         _ -> return ITcase       maybe_layout keyword@@ -1498,7 +1498,7 @@ varsym_prefix = sym $ \span exts s ->   let warnExtConflict errtok =         do { addWarning Opt_WarnOperatorWhitespaceExtConflict $-               WarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok+               PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok            ; return (ITvarsym s) }   in   if | s == fsLit "@" ->@@ -1522,17 +1522,17 @@      | s == fsLit "~" -> return ITtilde      | otherwise ->          do { addWarning Opt_WarnOperatorWhitespace $-                WarnOperatorWhitespace (mkSrcSpanPs span) s+                PsWarnOperatorWhitespace (mkSrcSpanPs span) s                   OperatorWhitespaceOccurrence_Prefix             ; return (ITvarsym s) }  -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action varsym_suffix = sym $ \span _ s ->-  if | s == fsLit "@" -> failMsgP (Error ErrSuffixAT [])+  if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT [])      | otherwise ->          do { addWarning Opt_WarnOperatorWhitespace $-                WarnOperatorWhitespace (mkSrcSpanPs span) s+                PsWarnOperatorWhitespace (mkSrcSpanPs span) s                   OperatorWhitespaceOccurrence_Suffix             ; return (ITvarsym s) } @@ -1542,7 +1542,7 @@   if | s == fsLit "@" -> return ITat      | otherwise ->          do { addWarning Opt_WarnOperatorWhitespace $-                WarnOperatorWhitespace (mkSrcSpanPs span) s+                PsWarnOperatorWhitespace (mkSrcSpanPs span) s                   OperatorWhitespaceOccurrence_TightInfix             ;  return (ITvarsym s) } @@ -1590,7 +1590,7 @@   let src = lexemeToString buf len   when ((not numericUnderscores) && ('_' `elem` src)) $ do     pState <- getPState-    addError $ Error (ErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))+    addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))   return $ L span $ itint (SourceText src)        $! transint $ parseUnsignedInteger        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int@@ -1631,7 +1631,7 @@   let src = lexemeToString buf (len-drop)   when ((not numericUnderscores) && ('_' `elem` src)) $ do     pState <- getPState-    addError $ Error (ErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))+    addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))   return (L span $! (f $! src))  tok_float, tok_primfloat, tok_primdouble :: String -> Token@@ -1801,7 +1801,7 @@               = case alexGetChar i of                   Just (c,i') | c == x    -> isString i' xs                   _other -> False-          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (Error (ErrLexer LexUnterminatedOptions LexErrKind_EOF) [])+          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) [])   -- -----------------------------------------------------------------------------@@ -1839,7 +1839,7 @@                 setInput i                 when (any (> '\xFF') s') $ do                   pState <- getPState-                  let err = Error ErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))+                  let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))                   addError err                 return (ITprimstring (SourceText s') (unsafeMkByteString s'))               _other ->@@ -2102,7 +2102,7 @@ quasiquote_error start = do   (AI end buf) <- getInput   reportLexError start (psRealLoc end) buf-    (\k -> Error (ErrLexer LexUnterminatedQQ k) [])+    (\k -> PsError (PsErrLexer LexUnterminatedQQ k) [])  -- ----------------------------------------------------------------------------- -- Warnings@@ -2112,7 +2112,7 @@     addTabWarning (psRealSpan srcspan)     lexToken -warnThen :: WarningFlag -> (SrcSpan -> Warning) -> Action -> Action+warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action warnThen flag warning action srcspan buf len = do     addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing))     action srcspan buf len@@ -2172,8 +2172,8 @@ data PState = PState {         buffer     :: StringBuffer,         options    :: ParserOpts,-        warnings   :: Bag Warning,-        errors     :: Bag Error,+        warnings   :: Bag PsWarning,+        errors     :: Bag PsError,         tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file         tab_count  :: !Word,             -- number of tab warnings in the file         last_tk    :: Maybe Token,@@ -2253,12 +2253,12 @@                 POk s1 a         -> (unP (k a)) s1                 PFailed s1 -> PFailed s1 -failMsgP :: (SrcSpan -> Error) -> P a+failMsgP :: (SrcSpan -> PsError) -> P a failMsgP f = do   pState <- getPState   addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> Error) -> P a+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a failLocMsgP loc1 loc2 f =   addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing)) @@ -2710,15 +2710,15 @@   --   to the accumulator and parsing continues. This allows GHC to report   --   more than one parse error per file.   ---  addError :: Error -> m ()+  addError :: PsError -> m ()    -- | Add a warning to the accumulator.   --   Use 'getMessages' to get the accumulated warnings.-  addWarning :: WarningFlag -> Warning -> m ()+  addWarning :: WarningFlag -> PsWarning -> m ()    -- | Add a fatal error. This will be the last error reported by the parser, and   --   the parser will not produce any result, ending in a 'PFailed' state.-  addFatalError :: Error -> m a+  addFatalError :: PsError -> m a    -- | Check if a given flag is currently set in the bitmap.   getBit :: ExtBits -> m Bool@@ -2764,19 +2764,19 @@  -- | Get a bag of the errors that have been accumulated so far. --   Does not take -Werror into account.-getErrorMessages :: PState -> Bag Error+getErrorMessages :: PState -> Bag PsError getErrorMessages p = errors p  -- | Get the warnings and errors accumulated so far. --   Does not take -Werror into account.-getMessages :: PState -> (Bag Warning, Bag Error)+getMessages :: PState -> (Bag PsWarning, Bag PsError) getMessages p =   let ws = warnings p       -- we add the tabulation warning on the fly because       -- we count the number of occurences of tab characters       ws' = case tab_first p of                Nothing -> ws-               Just tf -> WarnTab (RealSrcSpan tf Nothing) (tab_count p)+               Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p)                            `consBag` ws   in (ws', errors p) @@ -2824,8 +2824,8 @@   -> StringBuffer       -- current buffer (placed just after the last token)   -> Int                -- length of the previous token   -> SrcSpan-  -> Error-srcParseErr options buf len loc = Error (ErrParse token) suggests loc+  -> PsError+srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc   where    token = lexemeToString (offsetBytes (-len) buf) len    pattern = decodePrevNChars 8 buf@@ -2860,7 +2860,7 @@   loc <- getRealSrcLoc   (AI end buf) <- getInput   reportLexError loc (psRealLoc end) buf-    (\k -> Error (ErrLexer e k) [])+    (\k -> PsError (PsErrLexer e k) [])  -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a@@ -2976,7 +2976,7 @@              (ITwhere, ALRLayout _ col : ls, _)               | newLine && thisCol == col && transitional ->                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional-                      $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where+                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where                     setALRContext ls                     setNextToken t                     -- Note that we use lastLoc, as we may need to close@@ -2986,7 +2986,7 @@              (ITvbar, ALRLayout _ col : ls, _)               | newLine && thisCol == col && transitional ->                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional-                      $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe+                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe                     setALRContext ls                     setNextToken t                     -- Note that we use lastLoc, as we may need to close@@ -3108,7 +3108,7 @@         return (L span ITeof)     AlexError (AI loc2 buf) ->         reportLexError (psRealLoc loc1) (psRealLoc loc2) buf-          (\k -> Error (ErrLexer LexError k) [])+          (\k -> PsError (PsErrLexer LexError k) [])     AlexSkip inp2 _ -> do         setInput inp2         lexToken@@ -3122,7 +3122,7 @@         unless (isComment lt') (setLastTk lt')         return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> Error) -> P a+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a reportLexError loc1 loc2 buf f   | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)   | otherwise =@@ -3339,7 +3339,7 @@ alex_action_34 =  endPrag  alex_action_35 =  dispatch_pragmas fileHeaderPrags  alex_action_36 =  nested_comment lexToken -alex_action_37 =  warnThen Opt_WarnUnrecognisedPragmas WarnUnrecognisedPragma+alex_action_37 =  warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma                     (nested_comment lexToken)  alex_action_38 =  multiline_doc_comment  alex_action_39 =  nested_doc_comment
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -12,6 +12,10 @@   , ("negateInt#","Unary negation.\n    Since the negative @Int#@ range extends one further than the\n    positive range, @negateInt#@ of the most negative number is an\n    identity operation. This way, @negateInt#@ is always its own inverse.")   , ("addIntC#","Add signed integers reporting overflow.\n          First member of result is the sum truncated to an @Int#@;\n          second member is zero if the true sum fits in an @Int#@,\n          nonzero if overflow occurred (the sum is either too large\n          or too small to fit in an @Int#@).")   , ("subIntC#","Subtract signed integers reporting overflow.\n          First member of result is the difference truncated to an @Int#@;\n          second member is zero if the true difference fits in an @Int#@,\n          nonzero if overflow occurred (the difference is either too large\n          or too small to fit in an @Int#@).")+  , ("int2Float#","Convert an @Int#@ to the corresponding @Float#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @int2Float# 1# == 1.0#@")+  , ("int2Double#","Convert an @Int#@ to the corresponding @Double#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @int2Double# 1# == 1.0##@")+  , ("word2Float#","Convert an @Word#@ to the corresponding @Float#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @word2Float# 1## == 1.0#@")+  , ("word2Double#","Convert an @Word#@ to the corresponding @Double#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @word2Double# 1## == 1.0##@")   , ("uncheckedIShiftL#","Shift left.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")   , ("uncheckedIShiftRA#","Shift right arithmetic.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")   , ("uncheckedIShiftRL#","Shift right logical.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")
ghc-lib/stage0/lib/ghcversion.h view
@@ -5,11 +5,10 @@ #define __GLASGOW_HASKELL__ 901 #endif #if !defined(__GLASGOW_HASKELL_FULL_VERSION__)-#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.0.20201201"+#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.20201228" #endif -#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20201201+#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20201228  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "b94a65afe1e270245cd5b9fe03d59b726dfba8c4"+cProjectGitCommitId   = "2113a1d600e579bb0f54a0526a03626f105c0365"  cProjectVersion       :: String-cProjectVersion       = "9.1.0.20201201"+cProjectVersion       = "9.1.20201228"  cProjectVersionInt    :: String cProjectVersionInt    = "901"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "020201201"+cProjectPatchLevel    = "20201228"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "0"+cProjectPatchLevel1   = "20201228"  cProjectPatchLevel2   :: String-cProjectPatchLevel2   = "20201201"+cProjectPatchLevel2   = ""
+ libraries/ghc-boot/GHC/Data/SizedSeq.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}+module GHC.Data.SizedSeq+  ( SizedSeq(..)+  , emptySS+  , addToSS+  , addListToSS+  , ssElts+  , sizeSS+  ) where++import Prelude -- See note [Why do we import Prelude here?]+import Control.DeepSeq+import Data.Binary+import Data.List+import GHC.Generics++data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a]+  deriving (Generic, Show)++instance Functor SizedSeq where+  fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l)++instance Foldable SizedSeq where+  foldr f c ss = foldr f c (ssElts ss)++instance Traversable SizedSeq where+  traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l)++instance Binary a => Binary (SizedSeq a)++instance NFData a => NFData (SizedSeq a) where+  rnf (SizedSeq _ xs) = rnf xs++emptySS :: SizedSeq a+emptySS = SizedSeq 0 []++addToSS :: SizedSeq a -> a -> SizedSeq a+addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)++addListToSS :: SizedSeq a -> [a] -> SizedSeq a+addListToSS (SizedSeq n r_xs) xs+  = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)++ssElts :: SizedSeq a -> [a]+ssElts (SizedSeq _ r_xs) = reverse r_xs++sizeSS :: SizedSeq a -> Word+sizeSS (SizedSeq n _) = n
libraries/ghc-boot/GHC/Platform/ArchOS.hs view
@@ -73,8 +73,8 @@  -- | PowerPC 64-bit ABI data PPC_64ABI-   = ELF_V1-   | ELF_V2+   = ELF_V1 -- ^ PowerPC64+   | ELF_V2 -- ^ PowerPC64 LE    deriving (Read, Show, Eq)  -- | Operating systems.
libraries/ghci/GHCi/Message.hs view
@@ -454,7 +454,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\   (major1) <  9 || \   (major1) == 9 && (major2) <  1 || \-  (major1) == 9 && (major2) == 1 && (minor) <= 0)+  (major1) == 9 && (major2) == 1 && (minor) <= 20201228) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo
− libraries/ghci/SizedSeq.hs 
@@ -1,48 +0,0 @@-{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}-module SizedSeq-  ( SizedSeq(..)-  , emptySS-  , addToSS-  , addListToSS-  , ssElts-  , sizeSS-  ) where--import Prelude -- See note [Why do we import Prelude here?]-import Control.DeepSeq-import Data.Binary-import Data.List-import GHC.Generics--data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a]-  deriving (Generic, Show)--instance Functor SizedSeq where-  fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l)--instance Foldable SizedSeq where-  foldr f c ss = foldr f c (ssElts ss)--instance Traversable SizedSeq where-  traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l)--instance Binary a => Binary (SizedSeq a)--instance NFData a => NFData (SizedSeq a) where-  rnf (SizedSeq _ xs) = rnf xs--emptySS :: SizedSeq a-emptySS = SizedSeq 0 []--addToSS :: SizedSeq a -> a -> SizedSeq a-addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)--addListToSS :: SizedSeq a -> [a] -> SizedSeq a-addListToSS (SizedSeq n r_xs) xs-  = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)--ssElts :: SizedSeq a -> [a]-ssElts (SizedSeq _ r_xs) = reverse r_xs--sizeSS :: SizedSeq a -> Word-sizeSS (SizedSeq n _) = n
libraries/template-haskell/Language/Haskell/TH/Lib.hs view
@@ -162,6 +162,8 @@   , tupE   , unboxedTupE +  , conP+   , Role   , InjectivityAnn   )@@ -349,3 +351,9 @@  mdoE :: Quote m => [m Stmt] -> m Exp mdoE = Internal.mdoE Nothing++-------------------------------------------------------------------------------+-- * Patterns++conP :: Quote m => Name -> [m Pat] -> m Pat+conP n xs = Internal.conP n [] xs
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs view
@@ -125,9 +125,10 @@ unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) } -conP :: Quote m => Name -> [m Pat] -> m Pat-conP n ps = do ps' <- sequenceA ps-               pure (ConP n ps')+conP :: Quote m => Name -> [m Type] -> [m Pat] -> m Pat+conP n ts ps = do ps' <- sequenceA ps+                  ts' <- sequenceA ts+                  pure (ConP n ts' ps') infixP :: Quote m => m Pat -> Name -> m Pat -> m Pat infixP p1 n p2 = do p1' <- p1                     p2' <- p2
libraries/template-haskell/Language/Haskell/TH/Ppr.hs view
@@ -304,13 +304,15 @@ pprPat _ (VarP v)     = pprName' Applied v pprPat i (TupP ps)   | [_] <- ps-  = pprPat i (ConP (tupleDataName 1) ps)+  = pprPat i (ConP (tupleDataName 1) [] ps)   | otherwise   = parens (commaSep ps) pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity-pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s-                                              <+> sep (map (pprPat appPrec) ps)+pprPat i (ConP s ts ps)  = parensIf (i >= appPrec) $+      pprName' Applied s+  <+> sep (map (\t -> char '@' <> pprParendType t) ts)+  <+> sep (map (pprPat appPrec) ps) pprPat _ (ParensP p)  = parens $ pprPat noPrec p pprPat i (UInfixP p1 n p2)                       = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>
libraries/template-haskell/Language/Haskell/TH/Syntax.hs view
@@ -1296,7 +1296,7 @@             case nameSpace n of                 Just DataName -> do                     ps' <- sequence ps-                    return (ConP n ps')+                    return (ConP n [] ps')                 _ -> error $ "Can't construct a pattern from name "                           ++ showName n @@ -2018,7 +2018,7 @@   | TupP [Pat]                      -- ^ @{ (p1,p2) }@   | UnboxedTupP [Pat]               -- ^ @{ (\# p1,p2 \#) }@   | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@-  | ConP Name [Pat]                 -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@+  | ConP Name [Type] [Pat]          -- ^ @data T1 = C1 t1 t2; {C1 \@ty1 p1 p2} = e@   | InfixP Pat Name Pat             -- ^ @foo ({x :+ y}) = e@   | UInfixP Pat Name Pat            -- ^ @foo ({x :+ y}) = e@                                     --