ghc-lib 0.20191101 → 0.20191201
raw patch · 127 files changed
+2673/−2376 lines, 127 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC/HsToCore/PmCheck.hs +99/−108
- compiler/GHC/HsToCore/PmCheck/Oracle.hs +182/−175
- compiler/GHC/StgToCmm/Bind.hs +1/−1
- compiler/GHC/StgToCmm/Expr.hs +1/−1
- compiler/GHC/StgToCmm/Prof.hs +2/−2
- compiler/GHC/ThToHs.hs +104/−97
- compiler/cmm/CLabel.hs +1/−1
- compiler/cmm/Cmm.hs +2/−0
- compiler/cmm/CmmImplementSwitchPlans.hs +1/−1
- compiler/cmm/CmmNode.hs +1/−1
- compiler/cmm/CmmParse.y +1/−1
- compiler/cmm/CmmSwitch.hs +1/−1
- compiler/coreSyn/CoreLint.hs +16/−14
- compiler/coreSyn/CorePrep.hs +8/−15
- compiler/deSugar/Coverage.hs +70/−81
- compiler/deSugar/Desugar.hs +8/−9
- compiler/deSugar/DsArrows.hs +22/−22
- compiler/deSugar/DsBinds.hs +5/−11
- compiler/deSugar/DsExpr.hs +63/−60
- compiler/deSugar/DsForeign.hs +3/−3
- compiler/deSugar/DsGRHSs.hs +2/−3
- compiler/deSugar/DsListComp.hs +5/−5
- compiler/deSugar/DsMeta.hs +146/−155
- compiler/deSugar/DsMonad.hs +1/−1
- compiler/deSugar/DsUsage.hs +1/−1
- compiler/deSugar/DsUtils.hs +82/−76
- compiler/deSugar/ExtractDocs.hs +16/−14
- compiler/deSugar/Match.hs +27/−28
- compiler/deSugar/MatchCon.hs +3/−3
- compiler/deSugar/MatchLit.hs +8/−8
- compiler/ghci/ByteCodeGen.hs +1/−1
- compiler/ghci/Debugger.hs +5/−3
- compiler/hieFile/HieAst.hs +13/−22
- compiler/hieFile/HieBin.hs +1/−1
- compiler/iface/FlagChecker.hs +5/−1
- compiler/iface/IfaceEnv.hs +1/−1
- compiler/iface/LoadIface.hs +5/−6
- compiler/iface/MkIface.hs +10/−11
- compiler/llvmGen/Llvm/Types.hs +4/−10
- compiler/llvmGen/LlvmCodeGen.hs +9/−3
- compiler/llvmGen/LlvmCodeGen/Base.hs +8/−12
- compiler/main/CodeOutput.hs +2/−5
- compiler/main/DriverPipeline.hs +88/−91
- compiler/main/DynamicLoading.hs +2/−1
- compiler/main/GHC.hs +3/−5
- compiler/main/GhcMake.hs +1/−1
- compiler/main/HscMain.hs +39/−49
- compiler/main/HscStats.hs +7/−9
- compiler/main/PprTyThing.hs +2/−3
- compiler/main/SysTools/Process.hs +7/−1
- compiler/main/SysTools/Tasks.hs +3/−4
- compiler/main/TidyPgm.hs +3/−8
- compiler/nativeGen/BlockLayout.hs +2/−3
- compiler/nativeGen/Dwarf/Types.hs +2/−1
- compiler/nativeGen/Format.hs +1/−1
- compiler/nativeGen/PIC.hs +2/−2
- compiler/nativeGen/PPC/CodeGen.hs +1/−1
- compiler/nativeGen/RegAlloc/Graph/Spill.hs +1/−1
- compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +1/−1
- compiler/nativeGen/RegClass.hs +1/−1
- compiler/nativeGen/SPARC/CodeGen/Expand.hs +1/−1
- compiler/nativeGen/X86/Instr.hs +1/−1
- compiler/rename/RnEnv.hs +8/−2
- compiler/rename/RnExpr.hs +94/−22
- compiler/rename/RnHsDoc.hs +2/−2
- compiler/rename/RnNames.hs +2/−1
- compiler/rename/RnPat.hs +48/−51
- compiler/rename/RnSource.hs +75/−79
- compiler/rename/RnSplice.hs +15/−15
- compiler/rename/RnTypes.hs +62/−66
- compiler/rename/RnUtils.hs +2/−2
- compiler/simplCore/CSE.hs +50/−8
- compiler/simplCore/CallArity.hs +2/−2
- compiler/simplCore/Exitify.hs +2/−2
- compiler/simplCore/SetLevels.hs +34/−5
- compiler/simplCore/SimplCore.hs +3/−3
- compiler/simplCore/SimplMonad.hs +4/−3
- compiler/simplCore/SimplUtils.hs +15/−18
- compiler/simplCore/Simplify.hs +10/−5
- compiler/simplStg/SimplStg.hs +8/−8
- compiler/simplStg/StgLiftLams/Analysis.hs +1/−1
- compiler/specialise/Specialise.hs +2/−2
- compiler/stgSyn/StgFVs.hs +6/−6
- compiler/stranal/DmdAnal.hs +17/−2
- compiler/typecheck/FamInst.hs +106/−100
- compiler/typecheck/FunDeps.hs +1/−0
- compiler/typecheck/Inst.hs +1/−0
- compiler/typecheck/TcAnnotations.hs +1/−1
- compiler/typecheck/TcArrows.hs +2/−2
- compiler/typecheck/TcBinds.hs +39/−32
- compiler/typecheck/TcCanonical.hs +1/−1
- compiler/typecheck/TcClassDcl.hs +1/−1
- compiler/typecheck/TcDeriv.hs +268/−193
- compiler/typecheck/TcDerivInfer.hs +37/−45
- compiler/typecheck/TcDerivUtils.hs +193/−58
- compiler/typecheck/TcEnv.hs +4/−4
- compiler/typecheck/TcErrors.hs +3/−2
- compiler/typecheck/TcExpr.hs +12/−59
- compiler/typecheck/TcFlatten.hs +3/−2
- compiler/typecheck/TcGenDeriv.hs +22/−22
- compiler/typecheck/TcHoleErrors.hs +1/−1
- compiler/typecheck/TcHsSyn.hs +78/−88
- compiler/typecheck/TcHsType.hs +5/−4
- compiler/typecheck/TcInstDcls.hs +1/−1
- compiler/typecheck/TcInteract.hs +2/−2
- compiler/typecheck/TcMType.hs +2/−1
- compiler/typecheck/TcMatches.hs +21/−9
- compiler/typecheck/TcPat.hs +21/−24
- compiler/typecheck/TcPatSyn.hs +29/−30
- compiler/typecheck/TcRnDriver.hs +27/−27
- compiler/typecheck/TcRnExports.hs +19/−19
- compiler/typecheck/TcRnMonad.hs +26/−48
- compiler/typecheck/TcSMonad.hs +4/−5
- compiler/typecheck/TcSigs.hs +2/−2
- compiler/typecheck/TcSimplify.hs +1/−1
- compiler/typecheck/TcSplice.hs +44/−8
- compiler/typecheck/TcTyClsDecls.hs +56/−60
- compiler/typecheck/TcTyDecls.hs +17/−17
- compiler/typecheck/TcUnify.hs +2/−1
- compiler/typecheck/TcValidity.hs +5/−4
- compiler/utils/Dominators.hs +3/−3
- compiler/utils/GraphOps.hs +2/−2
- ghc-lib.cabal +2/−3
- ghc-lib/stage0/lib/DerivedConstants.h +3/−3
- ghc-lib/stage0/lib/ghcautoconf.h +5/−2
- ghc-lib/stage0/lib/ghcversion.h +2/−2
- ghc-lib/stage0/lib/llvm-targets +23/−23
compiler/GHC/HsToCore/PmCheck.hs view
@@ -42,6 +42,7 @@ import Util import Outputable import DataCon+import TyCon import Var (EvVar) import Coercion import TcEvidence@@ -236,7 +237,7 @@ data PmResult = PmResult { pmresultRedundant :: [Located [LPat GhcTc]]- , pmresultUncovered :: UncoveredCandidates+ , pmresultUncovered :: [Delta] , pmresultInaccessible :: [Located [LPat GhcTc]] , pmresultApproximate :: Precision } @@ -248,24 +249,6 @@ , text "pmresultApproximate" <+> ppr (pmresultApproximate pmr) ] --- | Either a list of patterns that are not covered, or their type, in case we--- have no patterns at hand. Not having patterns at hand can arise when--- handling EmptyCase expressions, in two cases:------ * The type of the scrutinee is a trivially inhabited type (like Int or Char)--- * The type of the scrutinee cannot be reduced to WHNF.------ In both these cases we have no inhabitation candidates for the type at hand,--- but we don't want to issue just a wildcard as missing. Instead, we print a--- type annotated wildcard, so that the user knows what kind of patterns is--- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).-data UncoveredCandidates = UncoveredPatterns [Id] [Delta]- | TypeOfUncovered Type--instance Outputable UncoveredCandidates where- ppr (UncoveredPatterns vva deltas) = text "UnPat" <+> ppr vva $$ ppr deltas- ppr (TypeOfUncovered ty) = text "UnTy" <+> ppr ty- {- %************************************************************************ %* *@@ -279,7 +262,7 @@ checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p]) res <- checkSingle' locn var p- dsPmWarn dflags ctxt res+ dsPmWarn dflags ctxt [var] res -- | Check a single pattern binding (let) checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> DsM PmResult@@ -291,12 +274,15 @@ PartialResult cs us ds pc <- pmCheck grds [] 1 missing dflags <- getDynFlags us' <- getNFirstUncovered [var] (maxUncoveredPatterns dflags + 1) us- let uc = UncoveredPatterns [var] us'+ let plain = PmResult { pmresultRedundant = []+ , pmresultUncovered = us'+ , pmresultInaccessible = []+ , pmresultApproximate = pc } return $ case (cs,ds) of- (Covered, _ ) -> PmResult [] uc [] pc -- useful- (NotCovered, NotDiverged) -> PmResult m uc [] pc -- redundant- (NotCovered, Diverged ) -> PmResult [] uc m pc -- inaccessible rhs- where m = [cL locn [cL locn p]]+ (Covered , _ ) -> plain -- useful+ (NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant+ (NotCovered, Diverged ) -> plain { pmresultInaccessible = m } -- inaccessible rhs+ where m = [L locn [L locn p]] -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions.@@ -307,7 +293,7 @@ dflags <- getDynFlags let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc- match = cL combinedLoc $+ match = L combinedLoc $ Match { m_ext = noExtField , m_ctxt = hs_ctx , m_pats = []@@ -324,30 +310,26 @@ , text "Matches:"]) 2 (vcat (map ppr matches)))- res <- case matches of- -- Check EmptyCase separately- -- See Note [Checking EmptyCase Expressions] in GHC.HsToCore.PmCheck.Oracle- [] | [var] <- vars -> checkEmptyCase' var- _normal_match -> checkMatches' vars matches- dsPmWarn dflags ctxt res+ res <- checkMatches' vars matches+ dsPmWarn dflags ctxt vars res --- | Check a matchgroup (case, functions, etc.). To be called on a non-empty--- list of matches. For empty case expressions, use checkEmptyCase' instead.+-- | Check a matchgroup (case, functions, etc.). checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM PmResult-checkMatches' vars matches- | null matches = panic "checkMatches': EmptyCase"- | otherwise = do- missing <- getPmDelta- tracePm "checkMatches': missing" (ppr missing)- (rs,us,ds,pc) <- go matches [missing]- dflags <- getDynFlags- us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us- let up = UncoveredPatterns vars us'- return $ PmResult {- pmresultRedundant = map hsLMatchToLPats rs- , pmresultUncovered = up- , pmresultInaccessible = map hsLMatchToLPats ds- , pmresultApproximate = pc }+checkMatches' vars matches = do+ init_delta <- getPmDelta+ missing <- case matches of+ -- This must be an -XEmptyCase. See Note [Checking EmptyCase]+ [] | [var] <- vars -> maybeToList <$> addTmCt init_delta (TmVarNonVoid var)+ _ -> pure [init_delta]+ tracePm "checkMatches': missing" (ppr missing)+ (rs,us,ds,pc) <- go matches missing+ dflags <- getDynFlags+ us' <- getNFirstUncovered vars (maxUncoveredPatterns dflags + 1) us+ return $ PmResult {+ pmresultRedundant = map hsLMatchToLPats rs+ , pmresultUncovered = us'+ , pmresultInaccessible = map hsLMatchToLPats ds+ , pmresultApproximate = pc } where go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered -> DsM ( [LMatch GhcTc (LHsExpr GhcTc)]@@ -378,31 +360,35 @@ (NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2) hsLMatchToLPats :: LMatch id body -> Located [LPat id]- hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats- hsLMatchToLPats _ = panic "checkMatches'"---- | Check an empty case expression. Since there are no clauses to process, we--- only compute the uncovered set. See Note [Checking EmptyCase Expressions]--- in "GHC.HsToCore.PmCheck.Oracle" for details.-checkEmptyCase' :: Id -> DsM PmResult-checkEmptyCase' x = do- delta <- getPmDelta- us <- inhabitants delta (idType x) >>= \case- -- Inhabitation checking failed / the type is trivially inhabited- Left ty -> pure (TypeOfUncovered ty)- -- A list of oracle states for the different satisfiable constructors is- -- available. Turn this into a value set abstraction.- Right (va, deltas) -> pure (UncoveredPatterns [va] deltas)- pure (PmResult [] us [] Precise)+ hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats+ hsLMatchToLPats _ = panic "checkMatches'" getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta] getNFirstUncovered _ 0 _ = pure [] getNFirstUncovered _ _ [] = pure [] getNFirstUncovered vars n (delta:deltas) = do- front <- provideEvidenceForEquation vars n delta+ front <- provideEvidence vars n delta back <- getNFirstUncovered vars (n - length front) deltas pure (front ++ back) +{- Note [Checking EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-XEmptyCase is useful for matching on empty data types like 'Void'. For example,+the following is a complete match:++ f :: Void -> ()+ f x = case x of {}++Really, -XEmptyCase is the only way to write a program that at the same time is+safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning+(@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an+exception into divergence (@f x = f x@).++Semantically, unlike every other case expression, -XEmptyCase is strict in its+match var x, which rules out ⊥ as an inhabitant. So we add x /~ ⊥ to the+initial Delta and check if there are any values left to match on.+-}+ {- %************************************************************************ %* *@@ -470,20 +456,18 @@ translatePat fam_insts x pat = case pat of WildPat _ty -> pure [] VarPat _ y -> pure (mkPmLetVar (unLoc y) x)- -- XPat wraps a Located (Pat GhcTc) in GhcTc. The Located part is important- XPat p -> translatePat fam_insts x (unLoc p)- ParPat _ p -> translatePat fam_insts x p+ ParPat _ p -> translateLPat fam_insts x p LazyPat _ _ -> pure [] -- like a wildcard BangPat _ p -> -- Add the bang in front of the list, because it will happen before any -- nested stuff.- (PmBang x :) <$> translatePat fam_insts x p+ (PmBang x :) <$> translateLPat fam_insts x p -- (x@pat) ==> Translate pat with x as match var and handle impedance -- mismatch with incoming match var- AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translatePat fam_insts y p+ AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p - SigPat _ p _ty -> translatePat fam_insts x p+ SigPat _ p _ty -> translateLPat fam_insts x p -- See Note [Translate CoPats] -- Generally the translation is@@ -497,7 +481,7 @@ pure (PmLet y (wrap_rhs_y (Var x)) : grds) -- (n + k) ===> let b = x >= k, True <- b, let n = x-k- NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do+ NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do b <- mkPmId boolTy let grd_b = vanillaConGrd b trueDataCon [] [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]@@ -507,7 +491,7 @@ -- (fun -> pat) ===> let y = fun x, pat <- y where y is a match var of pat ViewPat _arg_ty lexpr pat -> do- (y, grds) <- translatePatV fam_insts pat+ (y, grds) <- translateLPatV fam_insts pat fun <- dsLExpr lexpr pure $ PmLet y (App fun (Var x)) : grds @@ -516,7 +500,7 @@ translateListPat fam_insts x ps -- overloaded list- ListPat (ListPatTc _elem_ty (Just (pat_ty, to_list))) pats -> do+ ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do dflags <- getDynFlags case splitListTyConApp_maybe pat_ty of Just _e_ty@@ -524,7 +508,7 @@ -- Just translate it as a regular ListPat -> translateListPat fam_insts x pats _ -> do- y <- selectMatchVar pat+ y <- mkPmId (mkListTy elem_ty) grds <- translateListPat fam_insts y pats rhs_y <- dsSyntaxExpr to_list [Var x] pure $ PmLet y rhs_y : grds@@ -543,14 +527,14 @@ -- -- See #14547, especially comment#9 and comment#10. - ConPatOut { pat_con = (dL->L _ con)+ ConPatOut { pat_con = L _ con , pat_arg_tys = arg_tys , pat_tvs = ex_tvs , pat_dicts = dicts , pat_args = ps } -> do translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps - NPat ty (dL->L _ olit) mb_neg _ -> do+ NPat ty (L _ olit) mb_neg _ -> do -- See Note [Literal short cut] in MatchLit.hs -- We inline the Literal short cut for @ty@ here, because @ty@ is more -- precise than the field of OverLitTc, which is all that dsOverLit (which@@ -576,12 +560,12 @@ mkPmLitGrds x lit TuplePat _tys pats boxity -> do- (vars, grdss) <- mapAndUnzipM (translatePatV fam_insts) pats+ (vars, grdss) <- mapAndUnzipM (translateLPatV fam_insts) pats let tuple_con = tupleDataCon boxity (length vars) pure $ vanillaConGrd x tuple_con vars : concat grdss SumPat _ty p alt arity -> do- (y, grds) <- translatePatV fam_insts p+ (y, grds) <- translateLPatV fam_insts p let sum_con = sumDataCon alt arity -- See Note [Unboxed tuple RuntimeRep vars] in TyCon pure $ vanillaConGrd x sum_con [y] : grds@@ -590,6 +574,7 @@ -- Not supposed to happen ConPatIn {} -> panic "Check.translatePat: ConPatIn" SplicePat {} -> panic "Check.translatePat: SplicePat"+ XPat n -> noExtCon n -- | 'translatePat', but also select and return a new match var. translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec)@@ -598,12 +583,19 @@ grds <- translatePat fam_insts x pat pure (x, grds) +translateLPat :: FamInstEnvs -> Id -> LPat GhcTc -> DsM GrdVec+translateLPat fam_insts x = translatePat fam_insts x . unLoc++-- | 'translateLPat', but also select and return a new match var.+translateLPatV :: FamInstEnvs -> LPat GhcTc -> DsM (Id, GrdVec)+translateLPatV fam_insts = translatePatV fam_insts . unLoc+ -- | @translateListPat _ x [p1, ..., pn]@ is basically -- @translateConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever -- constructing the 'ConPatOut's.-translateListPat :: FamInstEnvs -> Id -> [Pat GhcTc] -> DsM GrdVec+translateListPat :: FamInstEnvs -> Id -> [LPat GhcTc] -> DsM GrdVec translateListPat fam_insts x pats = do- vars_and_grdss <- traverse (translatePatV fam_insts) pats+ vars_and_grdss <- traverse (translateLPatV fam_insts) pats mkListGrds x vars_and_grdss -- | Translate a constructor pattern@@ -637,7 +629,7 @@ -- Translate the mentioned field patterns. We're doing this first to get -- the Ids for pm_con_args. let trans_pat (n, pat) = do- (var, pvec) <- translatePatV fam_insts pat+ (var, pvec) <- translateLPatV fam_insts pat pure ((n, var), pvec) (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats @@ -665,16 +657,16 @@ -- Translate a single match translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (GrdVec, [GrdVec])-translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))+translateMatch fam_insts vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do- pats' <- concat <$> zipWithM (translatePat fam_insts) vars pats+ pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats guards' <- mapM (translateGuards fam_insts) guards -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr guards, ppr guards']) return (pats', guards') where extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]- extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs- extractGuards _ = panic "translateMatch"+ extractGuards (L _ (GRHS _ gs _)) = map unLoc gs+ extractGuards _ = panic "translateMatch" guards = map extractGuards (grhssGRHSs grhss) translateMatch _ _ _ = panic "translateMatch"@@ -706,15 +698,15 @@ -- | Translate a pattern guard -- @pat <- e ==> let x = e; <guards for pat <- x>@-translateBind :: FamInstEnvs -> Pat GhcTc -> LHsExpr GhcTc -> DsM GrdVec+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM GrdVec translateBind fam_insts p e = dsLExpr e >>= \case Var y | Nothing <- isDataConId_maybe y -- RHS is a variable, so that will allow us to omit the let- -> translatePat fam_insts y p+ -> translateLPat fam_insts y p rhs -> do- x <- selectMatchVar p- (PmLet x rhs :) <$> translatePat fam_insts x p+ (x, grds) <- translateLPatV fam_insts p+ pure (PmLet x rhs : grds) -- | Translate a boolean guard -- @e ==> let x = e; True <- x@@@ -955,7 +947,7 @@ * pmCheck :: PatVec -> [PatVec] -> ValVec -> Delta -> DsM PartialResult This function implements functions `covered`, `uncovered` and- `divergent` from the paper at once. Calls out to the auxilary function+ `divergent` from the paper at once. Calls out to the auxiliary function `pmCheckGuards` for handling (possibly multiple) guarded RHSs when the whole clause is checked. Slightly different from the paper because it does not even produce the covered and uncovered sets. Since we only care about whether a@@ -1069,7 +1061,8 @@ pr_pos <- pmCheckM ps guards n (addPmConCts delta x con dicts args) -- The var is forced regardless of whether @con@ was satisfiable- let pr_pos' = forceIfCanDiverge delta x pr_pos+ -- See Note [Divergence of Newtype matches]+ let pr_pos' = addConMatchStrictness delta x con pr_pos -- Stuff for <next equation> pr_neg <- addRefutableAltCon delta x con >>= \case@@ -1114,6 +1107,13 @@ | canDiverge delta x = forces | otherwise = id +-- | 'forceIfCanDiverge' if the 'PmAltCon' was not a Newtype.+-- See Note [Divergence of Newtype matches].+addConMatchStrictness :: Delta -> Id -> PmAltCon -> PartialResult -> PartialResult+addConMatchStrictness _ _ (PmAltConLike (RealDataCon dc)) res+ | isNewTyCon (dataConTyCon dc) = res+addConMatchStrictness delta x _ res = forceIfCanDiverge delta x res+ -- ---------------------------------------------------------------------------- -- * Propagation of term constraints inwards when checking nested matches @@ -1236,29 +1236,25 @@ = notNull (filter (`wopt` dflags) allPmCheckWarnings) -- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)-dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()-dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result+dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> PmResult -> DsM ()+dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result = when (flag_i || flag_u) $ do let exists_r = flag_i && notNull redundant exists_i = flag_i && notNull inaccessible && not is_rec_upd- exists_u = flag_u && (case uncovered of- TypeOfUncovered _ -> True- UncoveredPatterns _ unc -> notNull unc)+ exists_u = flag_u && notNull uncovered approx = precision == Approximate when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_r $ forM_ redundant $ \(dL->L l q) -> do+ when exists_r $ forM_ redundant $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant"))- when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do+ when exists_i $ forM_ inaccessible $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $- case uncovered of- TypeOfUncovered ty -> warnEmptyCase ty- UncoveredPatterns vars unc -> pprEqns vars unc+ pprEqns vars uncovered where PmResult { pmresultRedundant = redundant@@ -1287,11 +1283,6 @@ in hang (text "Patterns not matched:") 4 (vcat (take maxPatterns us) $$ dots maxPatterns us) - -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for- -- which we only know the type and have no inhabitants at hand)- warnEmptyCase ty = pprContext False ctx (text "are non-exhaustive") $ \_ ->- hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)- approx_msg = vcat [ hang (text "Pattern match checker ran into -fmax-pmcheck-models="@@ -1375,7 +1366,7 @@ (ppr_match, pref) = case kind of- FunRhs { mc_fun = (dL->L _ fun) }+ FunRhs { mc_fun = L _ fun } -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp)
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -8,20 +8,20 @@ -- | The pattern match oracle. The main export of the module are the functions -- 'addTmCt', 'addVarCoreCt', 'addRefutableAltCon' and 'addTypeEvidence' for--- adding facts to the oracle, and 'provideEvidenceForEquation' to turn a+-- adding facts to the oracle, and 'provideEvidence' to turn a -- 'Delta' into a concrete evidence for an equation. module GHC.HsToCore.PmCheck.Oracle ( DsM, tracePm, mkPmId,- Delta, initDelta, canDiverge, lookupRefuts, lookupSolution,+ Delta, initDelta, lookupRefuts, lookupSolution, TmCt(..),- inhabitants, addTypeEvidence, -- Add type equalities addRefutableAltCon, -- Add a negative term equality addTmCt, -- Add a positive term equality x ~ e addVarCoreCt, -- Add a positive term equality x ~ core_expr- provideEvidenceForEquation,+ canDiverge, -- Try to add the term equality x ~ ⊥+ provideEvidence, ) where #include "HsVersions.h"@@ -35,6 +35,7 @@ import ErrUtils import Util import Bag+import UniqSet import UniqDSet import Unique import Id@@ -75,9 +76,10 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Data.Bifunctor (second)-import Data.Foldable (foldlM)+import Data.Foldable (foldlM, minimumBy) import Data.List (find) import qualified Data.List.NonEmpty as NonEmpty+import Data.Ord (comparing) import qualified Data.Semigroup as Semigroup import Data.Tuple (swap) @@ -101,32 +103,10 @@ -- * Caching possible matches of a COMPLETE set markMatched :: ConLike -> PossibleMatches -> PossibleMatches-markMatched con (PM tc ms) = PM tc (fmap (`delOneFromUniqDSet` con) ms)-markMatched _ NoPM = NoPM---- | Satisfiability decisions as a data type. The @proof@ can carry a witness--- for satisfiability and might even be instantiated to 'Data.Void.Void' to--- degenerate into a semi-decision predicate.-data Satisfiability proof- = Unsatisfiable- | PossiblySatisfiable- | Satisfiable !proof--maybeSatisfiable :: Maybe a -> Satisfiability a-maybeSatisfiable (Just a) = Satisfiable a-maybeSatisfiable Nothing = Unsatisfiable---- | Tries to return one of the possible 'ConLike's from one of the COMPLETE--- sets. If the 'PossibleMatches' was inhabited before (cf. 'ensureInhabited')--- this 'ConLike' is evidence for that assurance.-getUnmatchedConstructor :: PossibleMatches -> Satisfiability ConLike-getUnmatchedConstructor NoPM = PossiblySatisfiable-getUnmatchedConstructor (PM _tc ms)- = maybeSatisfiable $ NonEmpty.head <$> traverse pick_one_conlike ms+markMatched _ NoPM = NoPM+markMatched con (PM ms) = PM (del_one_con con <$> ms) where- pick_one_conlike cs = case uniqDSetToList cs of- [] -> Nothing- (cl:_) -> Just cl+ del_one_con = flip delOneFromUniqDSet --------------------------------------------------- -- * Instantiating constructors, types and evidence@@ -172,8 +152,13 @@ -- to the type oracle let ty_cs = map TyCt (substTheta subst (eqSpecPreds eq_spec ++ thetas)) -- Figure out the types of strict constructor fields- let arg_is_banged = map isBanged $ conLikeImplBangs con- strict_arg_tys = filterByList arg_is_banged field_tys'+ let arg_is_strict+ | RealDataCon dc <- con+ , isNewTyCon (dataConTyCon dc)+ = [True] -- See Note [Divergence of Newtype matches]+ | otherwise+ = map isBanged $ conLikeImplBangs con+ strict_arg_tys = filterByList arg_is_strict field_tys' return (vars, listToBag ty_cs, strict_arg_tys) -------------------------@@ -277,7 +262,7 @@ -- ^ 'tcNormalise' was able to simplify the type with some local constraint -- from the type oracle, but 'topNormaliseTypeX' couldn't identify a type -- redex.- | HadRedexes Type [(Type, DataCon)] Type+ | HadRedexes Type [(Type, DataCon, Type)] Type -- ^ 'tcNormalise' may or may not been able to simplify the type, but -- 'topNormaliseTypeX' made progress either way and got rid of at least one -- outermost type or data family redex or newtype.@@ -289,8 +274,10 @@ -- Core (modulo casts). -- The second field is the list of Newtype 'DataCon's that we looked through -- in the chain of reduction steps between the Source type and the Core type.- -- We also keep the type of the DataCon application, so that we don't have to- -- reconstruct it in inhabitationCandidates.build_newtype.+ -- We also keep the type of the DataCon application and its field, so that we+ -- don't have to reconstruct it in 'inhabitationCandidates' and+ -- 'provideEvidence'.+ -- For an example, see Note [Type normalisation]. -- | Just give me the potentially normalised source type, unchanged or not! normalisedSourceType :: TopNormaliseTypeResult -> Type@@ -298,6 +285,13 @@ normalisedSourceType (NormalisedByConstraints ty) = ty normalisedSourceType (HadRedexes ty _ _) = ty +-- | Return the fields of 'HadRedexes'. Returns appropriate defaults in the+-- other cases.+tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)+tntrGuts (NoChange ty) = (ty, [], ty)+tntrGuts (NormalisedByConstraints ty) = (ty, [], ty)+tntrGuts (HadRedexes src_ty ds core_ty) = (src_ty, ds, core_ty)+ instance Outputable TopNormaliseTypeResult where ppr (NoChange ty) = text "NoChange" <+> ppr ty ppr (NormalisedByConstraints ty) = text "NormalisedByConstraints" <+> ppr ty@@ -315,7 +309,7 @@ -- -- Behaves like `topNormaliseType_maybe`, but instead of returning a -- coercion, it returns useful information for issuing pattern matching--- warnings. See Note [Type normalisation for EmptyCase] for details.+-- warnings. See Note [Type normalisation] for details. -- It also initially 'tcNormalise's the type with the bag of local constraints. -- -- See 'TopNormaliseTypeResult' for the meaning of the return value.@@ -327,7 +321,7 @@ = do env <- dsGetFamInstEnvs -- Before proceeding, we chuck typ into the constraint solver, in case -- solving for given equalities may reduce typ some. See- -- "Wrinkle: local equalities" in Note [Type normalisation for EmptyCase].+ -- "Wrinkle: local equalities" in Note [Type normalisation]. (_, mb_typ') <- initTcDsForSolver $ tcNormalise inert typ -- If tcNormalise didn't manage to simplify the type, continue anyway. -- We might be able to reduce type applications nonetheless!@@ -364,13 +358,13 @@ -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into -- a loop. If it would fall into a loop, it produces 'NS_Abort'.- newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon)] -> [(Type, DataCon)])+ newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon, Type)] -> [(Type, DataCon, Type)]) newTypeStepper rec_nts tc tys | Just (ty', _co) <- instNewTyCon_maybe tc tys , let orig_ty = TyConApp tc tys = case checkRecTc rec_nts tc of Just rec_nts' -> let tyf = (orig_ty:)- tmf = ((orig_ty, tyConSingleDataCon tc):)+ tmf = ((orig_ty, tyConSingleDataCon tc, ty'):) in NS_Step rec_nts' ty' (tyf, tmf) Nothing -> NS_Abort | otherwise@@ -423,13 +417,14 @@ is_algebraic_like :: TyCon -> Bool is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon -{- Note [Type normalisation for EmptyCase]+{- Note [Type normalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-EmptyCase is an exception for pattern matching, since it is strict. This means-that it boils down to checking whether the type of the scrutinee is inhabited.-Function pmTopNormaliseType gets rid of the outermost type function/data-family redex and newtypes, in search of an algebraic type constructor, which is-easier to check for inhabitation.+Constructs like -XEmptyCase or a previous unsuccessful pattern match on a data+constructor place a non-void constraint on the matched thing. This means that it+boils down to checking whether the type of the scrutinee is inhabited. Function+pmTopNormaliseType gets rid of the outermost type function/data family redex and+newtypes, in search of an algebraic type constructor, which is easier to check+for inhabitation. It returns 3 results instead of one, because there are 2 subtle points: 1. Newtypes are isomorphic to the underlying type in core but not in the source@@ -444,7 +439,8 @@ newtypes. (b) dcs is the list of newtype constructors "skipped", every time we normalise a newtype to its core representation, we keep track of the source data- constructor and the type we unwrap.+ constructor. For convenienve, we also track the type we unwrap and the+ type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)] (c) core_ty is the rewritten type. That is, pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty) implies@@ -468,7 +464,7 @@ In this case pmTopNormaliseType env ty_cs (F Int) results in - Just (G2, [(G2,MkG2),(G1,MkG1)], R:TInt)+ Just (G2, [(G2,MkG2,G1),(G1,MkG1,T Int)], R:TInt) Which means that in source Haskell: - G2 is equivalent to F Int (in contrast, G1 isn't).@@ -520,6 +516,7 @@ tyOracle (TySt inert) cts = do { evs <- traverse nameTyCt cts ; let new_inert = inert `unionBags` evs+ ; tracePm "tyOracle" (ppr cts) ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability new_inert ; case res of -- Note how this implicitly gives all former PredTyCts a name, so@@ -534,8 +531,7 @@ -- constraints was empty. Will only recheck 'PossibleMatches' in the term oracle -- for emptiness if the first argument is 'True'. tyIsSatisfiable :: Bool -> Bag TyCt -> SatisfiabilityCheck-tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \delta -> do- tracePm "tyIsSatisfiable" (ppr new_ty_cs)+tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \delta -> if isEmptyBag new_ty_cs then pure (Just delta) else tyOracle (delta_ty_st delta) new_ty_cs >>= \case@@ -684,6 +680,12 @@ let ty' = normalisedSourceType res case splitTyConApp_maybe ty' of Nothing -> pure vi{ vi_ty = ty' }+ Just (tc, [_])+ | tc == tYPETyCon+ -- TYPE acts like an empty data type on the term-level (#14086), but+ -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a+ -- special case.+ -> pure vi{ vi_ty = ty', vi_cache = PM (pure emptyUniqDSet) } Just (tc, tc_args) -> do -- See Note [COMPLETE sets on data families] (tc_rep, tc_fam) <- case tyConFamInst_maybe tc of@@ -703,7 +705,7 @@ -- pprTrace "initPossibleMatches" (ppr ty $$ ppr ty' $$ ppr tc_rep <+> ppr tc_fam <+> ppr tc_args $$ ppr (rdcs ++ pscs)) (return ()) case NonEmpty.nonEmpty (rdcs ++ pscs) of Nothing -> pure vi{ vi_ty = ty' } -- Didn't find any COMPLETE sets- Just cs -> pure vi{ vi_ty = ty', vi_cache = PM tc_rep (mkUniqDSet <$> cs) }+ Just cs -> pure vi{ vi_ty = ty', vi_cache = PM (mkUniqDSet <$> cs) } initPossibleMatches _ vi = pure vi -- | @initLookupVarInfo ts x@ looks up the 'VarInfo' for @x@ in @ts@ and tries@@ -759,21 +761,43 @@ ------------------------------------------------ -- * Exported utility functions querying 'Delta' --- | Check whether a constraint (x ~ BOT) can succeed,--- given the resulting state of the term oracle.+-- | Check whether adding a constraint @x ~ BOT@ to 'Delta' succeeds. canDiverge :: Delta -> Id -> Bool-canDiverge MkDelta{ delta_tm_st = ts } x- -- If the variable seems not evaluated, there is a possibility for- -- constraint x ~ BOT to be satisfiable. That's the case when we haven't found- -- a solution (i.e. some equivalent literal or constructor) for it yet.- -- Even if we don't have a solution yet, it might be involved in a negative- -- constraint, in which case we must already have evaluated it earlier.- | VI _ [] [] _ <- lookupVarInfo ts x- = True- -- Variable x is already in WHNF or we know some refutable shape, so the- -- constraint is non-satisfiable- | otherwise = False+canDiverge delta@MkDelta{ delta_tm_st = ts } x+ | VI _ pos neg _ <- lookupVarInfo ts x+ = null neg && all pos_can_diverge pos+ where+ pos_can_diverge (PmAltConLike (RealDataCon dc), [y])+ -- See Note [Divergence of Newtype matches]+ | isNewTyCon (dataConTyCon dc) = canDiverge delta y+ pos_can_diverge _ = False +{- Note [Divergence of Newtype matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Newtypes behave rather strangely when compared to ordinary DataCons. In a+pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation+testing purposes (e.g. at construction sites), they behave rather like a DataCon+with a *strict* field, because they don't contribute their own bottom and are+inhabited iff the wrapped type is inhabited.++This distinction becomes apparent in #17248:++ newtype T2 a = T2 a+ g _ True = ()+ g (T2 _) True = ()+ g !_ True = ()++If we treat Newtypes like we treat regular DataCons, we would mark the third+clause as redundant, which clearly is unsound. The solution:+1. When checking the PmCon in 'pmCheck', never mark the result as Divergent if+ it's a Newtype match.+2. Regard @T2 x@ as 'canDiverge' iff @x@ 'canDiverge'. E.g. @T2 x ~ _|_@ <=>+ @x ~ _|_@. This way, the third clause will still be marked as inaccessible+ RHS instead of redundant.+3. When testing for inhabitants ('mkOneConFull'), we regard the newtype field as+ strict, so that the newtype is inhabited iff its field is inhabited.+-}+ lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon] -- Unfortunately we need the extra bit of polymorphism and the unfortunate -- duplication of lookupVarInfo here.@@ -922,8 +946,8 @@ pure delta{ delta_tm_st = TmSt (setEntrySDIE env x vi') reps} ensureInhabited :: Delta -> VarInfo -> DsM (Maybe VarInfo)- -- Returns (Just vi) guarantees that at least one member- -- of each ConLike in the COMPLETE set satisfies the oracle+ -- Returns (Just vi) if at least one member of each ConLike in the COMPLETE+ -- set satisfies the oracle -- -- Internally uses and updates the ConLikeSets in vi_cache. --@@ -934,8 +958,8 @@ where set_cache vi cache = vi { vi_cache = cache } - test NoPM = pure (Just NoPM)- test (PM tc ms) = runMaybeT (PM tc <$> traverse one_set ms)+ test NoPM = pure (Just NoPM)+ test (PM ms) = runMaybeT (PM <$> traverse one_set ms) one_set cs = find_one_inh cs (uniqDSetToList cs) @@ -961,6 +985,7 @@ Nothing -> pure True -- be conservative about this Just arg_tys -> do (_vars, ty_cs, strict_arg_tys) <- mkOneConFull arg_tys con+ tracePm "inh_test" (ppr con $$ ppr ty_cs) -- No need to run the term oracle compared to pmIsSatisfiable fmap isJust <$> runSatisfiabilityCheck delta $ mconcat -- Important to pass False to tyIsSatisfiable here, so that we won't@@ -1108,27 +1133,23 @@ NormalisedByConstraints ty' -> alts_to_check ty' ty' [] HadRedexes src_ty dcs core_ty -> alts_to_check src_ty core_ty dcs where- -- All these types are trivially inhabited- trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon- , intTyCon, wordTyCon, word8TyCon ]-- build_newtype :: (Type, DataCon) -> Id -> DsM (Id, TmCt)- build_newtype (ty, dc) x = do+ build_newtype :: (Type, DataCon, Type) -> Id -> DsM (Id, TmCt)+ build_newtype (ty, dc, _arg_ty) x = do -- ty is the type of @dc x@. It's a @dataConTyCon dc@ application. y <- mkPmId ty pure (y, TmVarCon y (PmAltConLike (RealDataCon dc)) [x]) - build_newtypes :: Id -> [(Type, DataCon)] -> DsM (Id, [TmCt])+ build_newtypes :: Id -> [(Type, DataCon, Type)] -> DsM (Id, [TmCt]) build_newtypes x = foldrM (\dc (x, cts) -> go dc x cts) (x, []) where go dc x cts = second (:cts) <$> build_newtype dc x -- Inhabitation candidates, using the result of pmTopNormaliseType- alts_to_check :: Type -> Type -> [(Type, DataCon)]+ alts_to_check :: Type -> Type -> [(Type, DataCon, Type)] -> DsM (Either Type (TyCon, Id, [InhabitationCandidate])) alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of Just (tc, _)- | tc `elem` trivially_inhabited+ | isTyConTriviallyInhabited tc -> case dcs of [] -> return (Left src_ty) (_:_) -> do inner <- mkPmId core_ty@@ -1150,17 +1171,15 @@ -- For other types conservatively assume that they are inhabited. _other -> return (Left src_ty) -inhabitants :: Delta -> Type -> DsM (Either Type (Id, [Delta]))-inhabitants delta ty = inhabitationCandidates delta ty >>= \case- Left ty' -> pure (Left ty')- Right (_, va, candidates) -> do- deltas <- flip mapMaybeM candidates $- \InhabitationCandidate{ ic_tm_cs = tm_cs- , ic_ty_cs = ty_cs- , ic_strict_arg_tys = strict_arg_tys } -> do- pmIsSatisfiable delta tm_cs ty_cs strict_arg_tys- pure (Right (va, deltas))+-- | All these types are trivially inhabited+triviallyInhabitedTyCons :: UniqSet TyCon+triviallyInhabitedTyCons = mkUniqSet [+ charTyCon, doubleTyCon, floatTyCon, intTyCon, wordTyCon, word8TyCon+ ] +isTyConTriviallyInhabited :: TyCon -> Bool+isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons+ ---------------------------- -- * Detecting vacuous types @@ -1187,7 +1206,7 @@ (c) A list of all newtype data constructors dcs, each one corresponding to a newtype rewrite performed in (b). - For an example see also Note [Type normalisation for EmptyCase]+ For an example see also Note [Type normalisation] in types/FamInstEnv.hs. 2. Function Check.checkEmptyCase' performs the check:@@ -1282,8 +1301,8 @@ HadRedexes _ cons _ -> any meets_criteria cons _ -> False where- meets_criteria :: (Type, DataCon) -> Bool- meets_criteria (_, con) =+ meets_criteria :: (Type, DataCon, Type) -> Bool+ meets_criteria (_, con, _) = null (dataConEqSpec con) && -- (1) null (dataConImplBangs con) -- (2) @@ -1415,22 +1434,19 @@ -------------------------------------------- -- * Providing positive evidence for a Delta --- | @provideEvidenceForEquation vs n delta@ returns a list of+-- | @provideEvidence vs n delta@ returns a list of -- at most @n@ (but perhaps empty) refinements of @delta@ that instantiate -- @vs@ to compatible constructor applications or wildcards. -- Negative information is only retained if literals are involved or when -- for recursive GADTs.-provideEvidenceForEquation :: [Id] -> Int -> Delta -> DsM [Delta]-provideEvidenceForEquation = go init_ts+provideEvidence :: [Id] -> Int -> Delta -> DsM [Delta]+provideEvidence = go where- -- Choosing 1 here will not be enough for RedBlack, but any other bound- -- might potentially lead to combinatorial explosion, so we are extremely- -- cautious and pick 2 here.- init_ts = setRecTcMaxBound 2 initRecTc- go _ _ 0 _ = pure []- go _ [] _ delta = pure [delta]- go rec_ts (x:xs) n delta = do- VI ty pos neg pm <- initLookupVarInfo delta x+ go _ 0 _ = pure []+ go [] _ delta = pure [delta]+ go (x:xs) n delta = do+ tracePm "provideEvidence" (ppr x $$ ppr xs $$ ppr delta $$ ppr n)+ VI _ pos neg _ <- initLookupVarInfo delta x case pos of _:_ -> do -- All solutions must be valid at once. Try to find candidates for their@@ -1443,91 +1459,81 @@ -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@ -- and @z@ that is valid at the same time. These constitute arg_vas below. let arg_vas = concatMap (\(_cl, args) -> args) pos- go rec_ts (arg_vas ++ xs) n delta+ go (arg_vas ++ xs) n delta []- -- First the simple case where we don't need to query the oracles- | isVanillaDataType ty- -- So no type info unleashed in pattern match- , null neg- -- No term-level info either- || notNull [ l | PmAltLit l <- neg ]- -- ... or there are literals involved, in which case we don't want- -- to split on possible constructors- -> go rec_ts xs n delta- [] -> do- -- We have to pick one of the available constructors and try it- -- It's important that each of the ConLikeSets in pm is still inhabited,- -- so that it doesn't matter from which we pick.- -- I think we implicitly uphold that invariant, but not too sure- case getUnmatchedConstructor pm of- Unsatisfiable -> pure []- -- No COMPLETE sets available, so we can assume it's inhabited- PossiblySatisfiable -> go rec_ts xs n delta- Satisfiable cl- | Just rec_ts' <- checkRecTc rec_ts (fst (splitTyConApp ty))- -> split_at_con rec_ts' delta n x xs cl- | otherwise- -- We ran out of fuel; just conservatively assume that this is- -- inhabited.- -> go rec_ts xs n delta+ -- When there are literals involved, just print negative info+ -- instead of listing missed constructors+ | notNull [ l | PmAltLit l <- neg ]+ -> go xs n delta+ [] -> try_instantiate x xs n delta - -- | @split_at_con _ delta _ x _ con@ splits the given delta into two- -- models: One where we assume x is con and one where we assume it can't be- -- con. Really similar to the ConVar case in Check, only that we don't- -- really have a pattern driving the split.- split_at_con- :: RecTcChecker -- ^ Detects when we split the same TyCon too often- -> Delta -- ^ The model we like to refine to the split- -> Int -- ^ The number of equations still to produce- -> Id -> [Id] -- ^ Head and tail of the value abstractions- -> ConLike -- ^ The ConLike over which to split- -> DsM [Delta]- split_at_con rec_ts delta n x xs cl = do- -- This will be really similar to the ConVar case- -- We may need to reduce type famlies/synonyms in x's type first- res <- pmTopNormaliseType (delta_ty_st delta) (idType x)- let res_ty = normalisedSourceType res+ -- | Tries to instantiate a variable by possibly following the chain of+ -- newtypes and then instantiating to all ConLikes of the wrapped type's+ -- minimal residual COMPLETE set.+ try_instantiate :: Id -> [Id] -> Int -> Delta -> DsM [Delta]+ -- Convention: x binds the outer constructor in the chain, y the inner one.+ try_instantiate x xs n delta = do+ (_src_ty, dcs, core_ty) <- tntrGuts <$> pmTopNormaliseType (delta_ty_st delta) (idType x)+ let build_newtype (x, delta) (_ty, dc, arg_ty) = do+ y <- lift $ mkPmId arg_ty+ delta' <- addVarConCt delta x (PmAltConLike (RealDataCon dc)) [y]+ pure (y, delta')+ runMaybeT (foldlM build_newtype (x, delta) dcs) >>= \case+ Nothing -> pure []+ Just (y, newty_delta) -> do+ -- Pick a COMPLETE set and instantiate it (n at max). Take care of ⊥.+ pm <- vi_cache <$> initLookupVarInfo newty_delta y+ mb_cls <- pickMinimalCompleteSet newty_delta pm+ case uniqDSetToList <$> mb_cls of+ Just cls@(_:_) -> instantiate_cons y core_ty xs n newty_delta cls+ Just [] | not (canDiverge newty_delta y) -> pure []+ -- Either ⊥ is still possible (think Void) or there are no COMPLETE+ -- sets available, so we can assume it's inhabited+ _ -> go xs n newty_delta++ instantiate_cons :: Id -> Type -> [Id] -> Int -> Delta -> [ConLike] -> DsM [Delta]+ instantiate_cons _ _ _ _ _ [] = pure []+ instantiate_cons _ _ _ 0 _ _ = pure []+ instantiate_cons _ ty xs n delta _+ -- We don't want to expose users to GHC-specific constructors for Int etc.+ | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True+ = go xs n delta+ instantiate_cons x ty xs n delta (cl:cls) = do env <- dsGetFamInstEnvs- case guessConLikeUnivTyArgsFromResTy env res_ty cl of- Nothing -> pure [delta] -- We can't split this one, so assume it's inhabited+ case guessConLikeUnivTyArgsFromResTy env ty cl of+ Nothing -> pure [delta] -- No idea idea how to refine this one, so just finish off with a wildcard Just arg_tys -> do (arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl let new_tm_cs = unitBag (TmVarCon x (PmAltConLike cl) arg_vars) -- Now check satifiability mb_delta <- pmIsSatisfiable delta new_tm_cs new_ty_cs strict_arg_tys- tracePm "split_at_con" (vcat [ ppr x- , ppr new_tm_cs- , ppr new_ty_cs- , ppr strict_arg_tys- , ppr delta- , ppr mb_delta ])- ev_pos <- case mb_delta of+ tracePm "instantiate_cons" (vcat [ ppr x+ , ppr (idType x)+ , ppr ty+ , ppr cl+ , ppr arg_tys+ , ppr new_tm_cs+ , ppr new_ty_cs+ , ppr strict_arg_tys+ , ppr delta+ , ppr mb_delta+ , ppr n ])+ con_deltas <- case mb_delta of Nothing -> pure []- Just delta' -> go rec_ts (arg_vars ++ xs) n delta'-- -- Only n' more equations to go...- let n' = n - length ev_pos- ev_neg <- addRefutableAltCon delta x (PmAltConLike cl) >>= \case- Nothing -> pure []- Just delta' -> go rec_ts (x:xs) n' delta'-- -- Actually there was no need to split if we see that both branches- -- were inhabited and we had no negative information on the variable!- -- So only refine delta if we find that one branch was indeed- -- uninhabited.- let neg = lookupRefuts delta x- case (ev_pos, ev_neg) of- ([], _) -> pure ev_neg- (_, []) -> pure ev_pos- _ | null neg -> pure [delta]- | otherwise -> pure (ev_pos ++ ev_neg)+ -- NB: We don't prepend arg_vars as we don't have any evidence on+ -- them and we only want to split once on a data type. They are+ -- inhabited, otherwise pmIsSatisfiable would have refuted.+ Just delta' -> go xs n delta'+ other_cons_deltas <- instantiate_cons x ty xs (n - length con_deltas) delta cls+ pure (con_deltas ++ other_cons_deltas) --- | Checks if every data con of the type 'isVanillaDataCon'.-isVanillaDataType :: Type -> Bool-isVanillaDataType ty = fromMaybe False $ do- (tc, _) <- splitTyConApp_maybe ty- dcs <- tyConDataCons_maybe tc- pure (all isVanillaDataCon dcs)+pickMinimalCompleteSet :: Delta -> PossibleMatches -> DsM (Maybe ConLikeSet)+pickMinimalCompleteSet _ NoPM = pure Nothing+-- TODO: First prune sets with type info in delta. But this is good enough for+-- now and less costly. See #17386.+pickMinimalCompleteSet _ (PM clss) = do+ tracePm "pickMinimalCompleteSet" (ppr $ NonEmpty.toList clss)+ pure (Just (minimumBy (comparing sizeUniqDSet) clss)) -- | See if we already encountered a semantically equivalent expression and -- return its representative.@@ -1558,6 +1564,7 @@ -- This is the right thing for casts involving data family instances and -- their representation TyCon, though (which are not visible in source -- syntax). See Note [COMPLETE sets on data families]+ -- core_expr x e | pprTrace "core_expr" (ppr x $$ ppr e) False = undefined core_expr x (Cast e _co) = core_expr x e core_expr x (Tick _t e) = core_expr x e core_expr x e
compiler/GHC/StgToCmm/Bind.hs view
@@ -180,7 +180,7 @@ 3. emit all the inits, and then all the bodies We'd rather not have separate functions to do steps 1 and 2 for- each binding, since in pratice they share a lot of code. So we+ each binding, since in practice they share a lot of code. So we have just one function, cgRhs, that returns a pair of the CgIdInfo for step 1, and a monadic computation to generate the code in step 2.
compiler/GHC/StgToCmm/Expr.hs view
@@ -414,7 +414,7 @@ Consider case (x :: HValue) |> co of (y :: MutVar# Int) DEFAULT -> ...-We want to gnerate an assignment+We want to generate an assignment y := x We want to allow this assignment to be generated in the case when the types are compatible, because this allows some slightly-dodgy but
compiler/GHC/StgToCmm/Prof.hs view
@@ -328,14 +328,14 @@ ldvEnterClosure closure_info node_reg = do dflags <- getDynFlags let tag = funTag dflags closure_info- -- don't forget to substract node's tag+ -- don't forget to subtract node's tag ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag)) ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do dflags <- getDynFlags- let -- don't forget to substract node's tag+ let -- don't forget to subtract node's tag ldv_wd = ldvWord dflags cl_ptr new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
compiler/GHC/ThToHs.hs view
@@ -58,27 +58,28 @@ ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]-convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))+convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]+convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds)) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)-convertToHsExpr loc e- = initCvt loc $ wrapMsg "expression" e $ cvtl e+convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)+convertToHsExpr origin loc e+ = initCvt origin loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)-convertToPat loc p- = initCvt loc $ wrapMsg "pattern" p $ cvtPat p+convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)+convertToPat origin loc p+ = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)-convertToHsType loc t- = initCvt loc $ wrapMsg "type" t $ cvtType t+convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)+convertToHsType origin loc t+ = initCvt origin loc $ wrapMsg "type" t $ cvtType t --------------------------------------------------------------------newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }+newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) } deriving (Functor)- -- Push down the source location;+ -- Push down the Origin (that is configurable by+ -- -fenable-th-splice-warnings) and source location; -- Can fail, with a single error message -- NB: If the conversion succeeds with (Right x), there should@@ -91,45 +92,47 @@ -- the spliced-in declarations get a location that at least relates to the splice point instance Applicative CvtM where- pure x = CvtM $ \loc -> Right (loc,x)+ pure x = CvtM $ \_ loc -> Right (loc,x) (<*>) = ap instance Monad CvtM where- (CvtM m) >>= k = CvtM $ \loc -> case m loc of- Left err -> Left err- Right (loc',v) -> unCvtM (k v) loc'+ (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of+ Left err -> Left err+ Right (loc',v) -> unCvtM (k v) origin loc' -initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a-initCvt loc (CvtM m) = fmap snd (m loc)+initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a+initCvt origin loc (CvtM m) = fmap snd (m origin loc) force :: a -> CvtM () force a = a `seq` return () failWith :: MsgDoc -> CvtM a-failWith m = CvtM (\_ -> Left m)+failWith m = CvtM (\_ _ -> Left m) +getOrigin :: CvtM Origin+getOrigin = CvtM (\origin loc -> Right (loc,origin))+ getL :: CvtM SrcSpan-getL = CvtM (\loc -> Right (loc,loc))+getL = CvtM (\_ loc -> Right (loc,loc)) setL :: SrcSpan -> CvtM ()-setL loc = CvtM (\_ -> Right (loc, ()))+setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a-returnL x = CvtM (\loc -> Right (loc, cL loc x))+returnL :: a -> CvtM (Located a)+returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)+returnJustL :: a -> CvtM (Maybe (Located a)) returnJustL = fmap Just . returnL -wrapParL :: HasSrcSpan a =>- (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)-wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))+wrapParL :: (Located a -> a) -> a -> CvtM a+wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x))) wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing wrapMsg what item (CvtM m)- = CvtM (\loc -> case m loc of- Left err -> Left (err $$ getPprStyle msg)- Right v -> Right v)+ = CvtM $ \origin loc -> case m origin loc of+ Left err -> Left (err $$ getPprStyle msg)+ Right v -> Right v where -- Show the item in pretty syntax normally, -- but with all its constructors if you say -dppr-debug@@ -138,10 +141,10 @@ then text (show item) else text (pprint item)) -wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a-wrapL (CvtM m) = CvtM (\loc -> case m loc of- Left err -> Left err- Right (loc',v) -> Right (loc',cL loc v))+wrapL :: CvtM a -> CvtM (Located a)+wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of+ Left err -> Left err+ Right (loc', v) -> Right (loc', L loc v) ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]@@ -152,7 +155,8 @@ | TH.VarP s <- pat = do { s' <- vNameL s ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)- ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] }+ ; th_origin <- getOrigin+ ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] } | otherwise = do { pat' <- cvtPat pat@@ -172,7 +176,8 @@ | otherwise = do { nm' <- vNameL nm ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls- ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' }+ ; th_origin <- getOrigin+ ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' } cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm@@ -273,14 +278,14 @@ ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext funPrec ctxt- ; (dL->L loc ty') <- cvtType ty- ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'+ ; (L loc ty') <- cvtType ty+ ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts'- , cid_overlap_mode = fmap (cL loc . overlap) o } }+ , cid_overlap_mode = fmap (L loc . overlap) o } } where overlap pragma = case pragma of@@ -344,7 +349,7 @@ , feqn_fixity = Prefix } }}} cvtDec (TySynInstD eqn)- = do { (dL->L _ eqn') <- cvtTySynEqn eqn+ = do { (L _ eqn') <- cvtTySynEqn eqn ; returnJustL $ InstD noExtField $ TyFamInstD { tfid_ext = noExtField , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }@@ -370,8 +375,8 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext funPrec cxt ; ds' <- traverse cvtDerivStrategy ds- ; (dL->L loc ty') <- cvtType ty- ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'+ ; (L loc ty') <- cvtType ty+ ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' ; returnJustL $ DerivD noExtField $ DerivDecl { deriv_ext =noExtField , deriv_strategy = ds'@@ -403,7 +408,8 @@ cvtDir _ ImplBidir = return ImplicitBidirectional cvtDir n (ExplBidir cls) = do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls- ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }+ ; th_origin <- getOrigin+ ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms } cvtDec (TH.PatSynSigD nm ty) = do { nm' <- cNameL nm@@ -464,8 +470,6 @@ ; let (binds', prob_fams') = partitionWith is_bind prob_binds' ; let (fams', bads) = partitionWith is_fam_decl prob_fams' ; unless (null bads) (failWith (mkBadDecMsg doc bads))- --We use FromSource as the origin of the bind- -- because the TH declaration is user-written ; return (listToBag binds', sigs', fams', ats', adts') } ----------------@@ -518,29 +522,29 @@ ------------------------------------------------------------------- is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)-is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)+is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d) is_fam_decl decl = Right decl is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)-is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))- = Left (cL loc d)+is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))+ = Left (L loc d) is_tyfam_inst decl = Right decl is_datafam_inst :: LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)-is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d })))- = Left (cL loc d)+is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d })))+ = Left (L loc d) is_datafam_inst decl = Right decl is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)-is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)-is_sig decl = Right decl+is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)+is_sig decl = Right decl is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)-is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)-is_bind decl = Right decl+is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)+is_bind decl = Right decl is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)@@ -577,12 +581,12 @@ cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt- ; (dL->L _ con') <- cvtConstr con+ ; L _ con' <- cvtConstr con ; returnL $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = Just lcxt- add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))- = Just (cL loc (cxt1 ++ cxt2))+ add_cxt (L loc cxt1) (Just (L _ cxt2))+ = Just (L loc (cxt1 ++ cxt2)) add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs)@@ -600,13 +604,19 @@ add_forall _ _ (XConDecl nec) = noExtCon nec +cvtConstr (GadtC [] _strtys _ty)+ = failWith (text "GadtC must have at least one constructor name")+ cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys- ; (dL->L _ ty') <- cvtType ty+ ; L _ ty' <- cvtType ty ; c_ty <- mk_arr_apps args ty' ; returnL $ fst $ mkGadtDecl c' c_ty} +cvtConstr (RecGadtC [] _varstrtys _ty)+ = failWith (text "RecGadtC must have at least one constructor name")+ cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty@@ -635,12 +645,12 @@ cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty)- = do { (dL->L li i') <- vNameL i+ = do { L li i' <- vNameL i ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_ext = noExtField , cd_fld_names- = [cL li $ FieldOcc noExtField (cL li i')]+ = [L li $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -895,16 +905,15 @@ -- lambda expressions. See #13856. cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; let pats = map (parenthesizePat appPrec) ps'- ; return $ HsLam noExtField (mkMatchGroup FromSource+ ; th_origin <- getOrigin+ ; return $ HsLam noExtField (mkMatchGroup th_origin [mkSimpleMatch LambdaExpr pats e'])} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms+ ; th_origin <- getOrigin ; return $ HsLamCase noExtField- (mkMatchGroup FromSource ms')+ (mkMatchGroup th_origin ms') }- cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExtField e' }- -- Note [Dropping constructors]- -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = cvt_tup es Boxed cvt (UnboxedTupE es) = cvt_tup es Unboxed cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e@@ -920,8 +929,9 @@ cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms+ ; th_origin <- getOrigin ; return $ HsCase noExtField e'- (mkMatchGroup FromSource ms') }+ (mkMatchGroup th_origin ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (MDoE ss) = cvtHsDo MDoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss@@ -1012,14 +1022,13 @@ {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we drop constructors from the input (for instance, when we encounter @TupE [e]@)-we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@-could meet @UInfix@ constructors containing the @TupE [e]@. For example:+When we drop constructors from the input, we must insert parentheses around the+argument. For example: - UInfixE x * (TupE [UInfixE y + z])+ UInfixE x * (AppE (InfixE (Just y) + Nothing) z) -If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet-and the above expression would be reassociated to+If we convert the InfixE expression to an operator section but don't insert+parentheses, the above expression would be reassociated to OpApp (OpApp x * y) + z @@ -1049,7 +1058,7 @@ (map noLoc es') boxity } -{- Note [Operator assocation]+{- Note [Operator association] We must be quite careful about adding parens: * Infix (UInfix ...) op arg Needs parens round the first arg * Infix (Infix ...) op arg Needs parens round the first arg@@ -1122,8 +1131,8 @@ ; let Just (stmts'', last') = snocView stmts' ; last'' <- case last' of- (dL->L loc (BodyStmt _ body _ _))- -> return (cL loc (mkLastStmt body))+ (L loc (BodyStmt _ body _ _))+ -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) }@@ -1152,8 +1161,8 @@ cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of- (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875- _ -> p'+ (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875+ _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) }@@ -1248,8 +1257,6 @@ | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } cvtp (TH.VarP s) = do { s' <- vName s ; return $ Hs.VarPat noExtField (noLoc s') }-cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExtField p' }- -- Note [Dropping constructors] cvtp (TupP ps) = do { ps' <- cvtPats ps ; return $ TuplePat noExtField ps' Boxed } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps@@ -1290,10 +1297,10 @@ cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p)- = do { (dL->L ls s') <- vNameL s+ = do { L ls s' <- vNameL s ; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl- = cL ls $ mkFieldOcc (cL ls s')+ = L ls $ mkFieldOcc (L ls s') , hsRecFieldArg = p' , hsRecPun = False}) } @@ -1495,7 +1502,7 @@ PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax | Just normals <- m_normals- , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals+ , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals -> do returnL (HsExplicitListTy noExtField ip (ty1:tys2)) | otherwise@@ -1568,7 +1575,7 @@ go type_args where -- See Note [Adding parens for splices]- add_parens lt@(dL->L _ t)+ add_parens lt@(L _ t) | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) | otherwise = return lt @@ -1672,9 +1679,9 @@ | null exis, null provs = cvtType (ForallT univs reqs ty) | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty)- ; return $ cL l (HsQualTy { hst_ctxt = cL l []- , hst_xqual = noExtField- , hst_body = ty' }) }+ ; return $ L l (HsQualTy { hst_ctxt = L l []+ , hst_xqual = noExtField+ , hst_body = ty' }) } | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty)@@ -1682,11 +1689,11 @@ { hst_fvf = ForallInvis , hst_bndrs = univs' , hst_xforall = noExtField- , hst_body = cL l cxtTy }- cxtTy = HsQualTy { hst_ctxt = cL l []+ , hst_body = L l cxtTy }+ cxtTy = HsQualTy { hst_ctxt = L l [] , hst_xqual = noExtField , hst_body = ty' }- ; return $ cL l forTy }+ ; return $ L l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty = cvtType ty @@ -1745,10 +1752,10 @@ -- ^ The complete type, quantified with a forall if necessary mkHsForAllTy tvs loc fvf tvs' rho_ty | null tvs = rho_ty- | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf- , hst_bndrs = hsQTvExplicit tvs'- , hst_xforall = noExtField- , hst_body = rho_ty }+ | otherwise = L loc $ HsForAllTy { hst_fvf = fvf+ , hst_bndrs = hsQTvExplicit tvs'+ , hst_xforall = noExtField+ , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided@@ -1770,9 +1777,9 @@ -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty- | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField- , hst_ctxt = ctxt'- , hst_body = ty }+ | otherwise = L loc $ HsQualTy { hst_xqual = noExtField+ , hst_ctxt = ctxt'+ , hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName
compiler/cmm/CLabel.hs view
@@ -348,7 +348,7 @@ -- external packages. It is safe to treat the RTS package as "external". | ForeignLabelInExternalPackage - -- | Label is in the package currenly being compiled.+ -- | Label is in the package currently being compiled. -- This is only used for creating hacky tmp labels during code generation. -- Don't use it in any code that might be inlined across a package boundary -- (ie, core code) else the information will be wrong relative to the
compiler/cmm/Cmm.hs view
@@ -109,6 +109,8 @@ -- Info Tables ----------------------------------------------------------------------------- +-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains+-- the extra info (beyond the executable code) that belongs to that CmmDecl. data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable , stack_info :: CmmStackInfo }
compiler/cmm/CmmImplementSwitchPlans.hs view
@@ -67,7 +67,7 @@ -- This is important as the expression could contain expensive code like -- memory loads or divisions which we REALLY don't want to duplicate. --- This happend in parts of the handwritten RTS Cmm code. See also #16933+-- This happened in parts of the handwritten RTS Cmm code. See also #16933 -- See Note [Floating switch expressions] floatSwitchExpr :: DynFlags -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
compiler/cmm/CmmNode.hs view
@@ -669,7 +669,7 @@ scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2 -- Equality and order is based on the head uniques defined above. We--- take care to short-cut the (extremly) common cases.+-- take care to short-cut the (extremely) common cases. instance Eq CmmTickScope where GlobalScope == GlobalScope = True GlobalScope == _ = False
compiler/cmm/CmmParse.y view
@@ -574,7 +574,7 @@ :: { (FastString, CLabel) } -- A label imported without an explicit packageId.- -- These are taken to come frome some foreign, unnamed package.+ -- These are taken to come from some foreign, unnamed package. : NAME { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
compiler/cmm/CmmSwitch.hs view
@@ -195,7 +195,7 @@ -- .quad _c20q -- .quad _c20r --- | The list of all labels occuring in the SwitchTargets value.+-- | The list of all labels occurring in the SwitchTargets value. switchTargetsToList :: SwitchTargets -> [Label] switchTargetsToList (SwitchTargets _ _ mbdef branches) = maybeToList mbdef ++ M.elems branches
compiler/coreSyn/CoreLint.hs view
@@ -46,12 +46,12 @@ import ErrUtils import Coercion import SrcLoc-import Kind import Type import RepType import TyCoRep -- checks validity of types/coercions import TyCoSubst import TyCoFVs+import TyCoPpr ( pprTyVar ) import TyCon import CoAxiom import BasicTypes@@ -63,7 +63,6 @@ import Util import InstEnv ( instanceDFunId ) import OptCoercion ( checkAxInstCo )-import UniqSupply import CoreArity ( typeArity ) import Demand ( splitStrictSig, isBotRes ) @@ -672,7 +671,7 @@ ) -- imitate @lintCoreExpr (App ...)@ (do fun_ty <- lintCoreExpr fun- addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]+ lintCoreArgs fun_ty [Type t, info, e] ) binders0 go _ = markAllJoinsBad $ lintCoreExpr rhs@@ -792,8 +791,7 @@ (_, dups) = removeDups compare bndrs lintCoreExpr e@(App _ _)- = addLoc (AnExpr e) $- do { fun_ty <- lintCoreFun fun (length args)+ = do { fun_ty <- lintCoreFun fun (length args) ; lintCoreArgs fun_ty args } where (fun, args) = collectArgs e@@ -2264,27 +2262,30 @@ failWithL :: MsgDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) ->- (Nothing, (warns, addMsg env errs msg))+ (Nothing, (warns, addMsg True env errs msg)) addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) ->- (Just (), (warns, addMsg env errs msg))+ (Just (), (warns, addMsg True env errs msg)) addWarnL :: MsgDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) ->- (Just (), (addMsg env warns msg, errs))+ (Just (), (addMsg False env warns msg, errs)) -addMsg :: LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc-addMsg env msgs msg+addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc+addMsg is_error env msgs msg = ASSERT( notNull loc_msgs ) msgs `snocBag` mk_msg msg where loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first loc_msgs = map dumpLoc (le_loc env) - cxt_doc = vcat $ reverse $ map snd loc_msgs- context = cxt_doc $$ whenPprDebug extra- extra = text "Substitution:" <+> ppr (le_subst env)+ cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs+ , text "Substitution:" <+> ppr (le_subst env) ]+ context | is_error = cxt_doc+ | otherwise = whenPprDebug cxt_doc+ -- Print voluminous info for Lint errors+ -- but not for warnings msg_span = case [ span | (loc,_) <- loc_msgs , let span = srcLocSpan loc@@ -2776,8 +2777,9 @@ dflags <- getDynFlags let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} } withoutFlag corem =+ -- TODO: supply tag here as well ? liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>- getUniqueSupplyM <*> getModule <*>+ getUniqMask <*> getModule <*> getVisibleOrphanMods <*> getPrintUnqualified <*> getSrcSpanM <*> pure corem
compiler/coreSyn/CorePrep.hs view
@@ -560,6 +560,7 @@ cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr -> UniqSM (JoinId, CpeRhs) -- Used for all join bindings+-- No eta-expansion: see Note [Do not eta-expand join points] in SimplUtils cpeJoinPair env bndr rhs = ASSERT(isJoinId bndr) do { let Just join_arity = isJoinId_maybe bndr@@ -1140,6 +1141,7 @@ Instead CoreArity.etaExpand gives f = /\a -> \y -> let s = h 3 in g s y+ -} cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs@@ -1160,6 +1162,8 @@ ==> case x of { p -> map f } -} +-- When updating this function, make sure it lines up with+-- CoreUtils.tryEtaReduce! tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _) | ok_to_eta_reduce f@@ -1179,25 +1183,14 @@ ok bndr (Var arg) = bndr == arg ok _ _ = False - -- We can't eta reduce something which must be saturated.+ -- We can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) ok_to_eta_reduce _ = False -- Safe. ToDo: generalise -tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)- | not (any (`elemVarSet` fvs) bndrs)- = case tryEtaReducePrep bndrs body of- Just e -> Just (Let bind e)- Nothing -> Nothing- where- fvs = exprFreeVars r --- NB: do not attempt to eta-reduce across ticks--- Otherwise we risk reducing--- \x. (Tick (Breakpoint {x}) f x)--- ==> Tick (breakpoint {x}) f--- which is bogus (#17228)--- tryEtaReducePrep bndrs (Tick tickish e)--- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e+tryEtaReducePrep bndrs (Tick tickish e)+ | tickishFloatable tickish+ = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e tryEtaReducePrep _ _ = Nothing
compiler/deSugar/Coverage.hs view
@@ -121,7 +121,7 @@ guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead.- let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest ->+ let top_pos = catMaybes $ foldr (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds in case top_pos of@@ -255,12 +255,12 @@ addTickLHsBinds = mapBagM addTickLHsBind addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)-addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds,+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do withEnv add_inlines $ do binds' <- addTickLHsBinds binds- return $ cL pos $ bind { abs_binds = binds' }+ return $ L pos $ bind { abs_binds = binds' } where -- in AbsBinds, the Id on each binding is not the actual top-level -- Id that we are defining, they are related by the abs_exports@@ -280,7 +280,7 @@ | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } -addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do+addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity@@ -292,7 +292,7 @@ -- See Note [inline sccs] tickish <- tickishType `liftM` getEnv- if inline && tickish == ProfNotes then return (cL pos funBind) else do+ if inline && tickish == ProfNotes then return (L pos funBind) else do (fvs, mg) <- getFreeVars $@@ -321,8 +321,8 @@ return Nothing let mbCons = maybe Prelude.id (:)- return $ cL pos $ funBind { fun_matches = mg- , fun_tick = tick `mbCons` fun_tick funBind }+ return $ L pos $ funBind { fun_matches = mg+ , fun_tick = tick `mbCons` fun_tick funBind } where -- a binding is a simple pattern binding if it is a funbind with@@ -331,8 +331,8 @@ isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 -- TODO: Revisit this-addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs- , pat_rhs = rhs }))) = do+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs+ , pat_rhs = rhs }))) = do let name = "(...)" (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs let pat' = pat { pat_rhs = rhs'}@@ -342,7 +342,7 @@ decl_path <- getPathEntry let top_lev = null decl_path if not (shouldTickPatBind density top_lev)- then return (cL pos pat')+ then return (L pos pat') else do -- Allocate the ticks@@ -355,14 +355,12 @@ rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat') patvar_tickss = zipWith mbCons patvar_ticks (snd (pat_ticks pat') ++ repeat [])- return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }+ return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } -- Only internal stuff, not from source, uses VarBind, so we ignore it.-addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind-addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind-addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind-addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884-+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind+addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind bindTick@@ -397,7 +395,7 @@ -- selectively add ticks to interesting expressions addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExpr e@(dL->L pos e0) = do+addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it@@ -413,7 +411,7 @@ -- (because the body will definitely have a tick somewhere). ToDo: perhaps -- we should treat 'case' and 'if' the same way? addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprRHS e@(dL->L pos e0) = do+addTickLHsExprRHS e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it@@ -442,7 +440,7 @@ -- break012. This gives the user the opportunity to inspect the -- values of the let-bound variables. addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprLetBody e@(dL->L pos e0) = do+addTickLHsExprLetBody e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it@@ -456,9 +454,9 @@ -- because the scope of this tick is completely subsumed by -- another. addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprNever (dL->L pos e0) = do+addTickLHsExprNever (L pos e0) = do e1 <- addTickHsExpr e0- return $ cL pos e1+ return $ L pos e1 -- general heuristic: expressions which do not denote values are good -- break points@@ -475,16 +473,16 @@ isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprOptAlt oneOfMany (dL->L pos e0)+addTickLHsExprOptAlt oneOfMany (L pos e0) = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)- (addTickLHsExpr (cL pos e0))+ (addTickLHsExpr (L pos e0)) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addBinTickLHsExpr boxLabel (dL->L pos e0)+addBinTickLHsExpr boxLabel (L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel pos $ addTickHsExpr e0)- (addTickLHsExpr (cL pos e0))+ (addTickLHsExpr (L pos e0)) -- -----------------------------------------------------------------------------@@ -493,7 +491,7 @@ -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)-addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsConLikeOut _ con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e@@ -552,14 +550,14 @@ = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x (dL->L l binds) e) =+addTickHsExpr (HsLet x (L l binds) e) = bindLocals (collectLocalBinders binds) $- liftM2 (HsLet x . cL l)+ liftM2 (HsLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e)-addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))+addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())- ; return (HsDo srcloc cxt (cL l stmts')) }+ ; return (HsDo srcloc cxt (L l stmts')) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox@@ -606,20 +604,12 @@ addTickHsExpr (HsBinTick x t0 t1 e) = liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do+addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2-addTickHsExpr (HsSCC x src nm e) =- liftM3 (HsSCC x)- (return src)- (return nm)- (addTickLHsExpr e)-addTickHsExpr (HsCoreAnn x src nm e) =- liftM3 (HsCoreAnn x)- (return src)- (return nm)- (addTickLHsExpr e)+addTickHsExpr (HsPragE x p e) =+ liftM (HsPragE x p) (addTickLHsExpr e) addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e@@ -637,19 +627,18 @@ addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)-addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e- ; return (cL l (Present x e')) }-addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))-addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec-addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884+addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e+ ; return (L l (Present x e')) }+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))+addTickTupArg (L _ (XTupArg nec)) = noExtCon nec addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc))-addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches- return $ mg { mg_alts = cL l matches' }+ return $ mg { mg_alts = L l matches' } addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)@@ -663,11 +652,11 @@ addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc))-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded- return $ GRHSs x guarded' (cL l local_binds')+ return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec@@ -681,7 +670,7 @@ addTickGRHS _ _ (XGRHS nec) = noExtCon nec addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do d <- getDensity case d of TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr@@ -724,13 +713,13 @@ (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard')-addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do- liftM (LetStmt x . cL l)+addTickStmt _isGuard (LetStmt x (L l binds)) = do+ liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs)- (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))+ (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do args' <- mapM (addTickApplicativeArg isGuard) args@@ -745,7 +734,7 @@ t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr- t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr))+ t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr)) return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } @@ -769,15 +758,16 @@ addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where- addTickArg (ApplicativeArgOne x pat expr isBody) =+ addTickArg (ApplicativeArgOne x pat expr isBody fail) = (ApplicativeArgOne x) <$> addTickLPat pat <*> addTickLHsExpr expr <*> pure isBody+ <*> addTickSyntaxExpr hpcSrcSpan fail addTickArg (ApplicativeArgMany x stmts ret pat) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts- <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))+ <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat addTickArg (XApplicativeArg nec) = noExtCon nec @@ -830,7 +820,7 @@ -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do- x' <- fmap unLoc (addTickLHsExpr (cL pos x))+ x' <- fmap unLoc (addTickLHsExpr (L pos x)) return $ syn { syn_expr = x' } -- we do not walk into patterns. addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)@@ -844,9 +834,9 @@ addTickHsCmdTop (XCmdTop nec) = noExtCon nec addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)-addTickLHsCmd (dL->L pos c0) = do+addTickLHsCmd (L pos c0) = do c1 <- addTickHsCmd c0- return $ cL pos c1+ return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) addTickHsCmd (HsCmdLam x matchgroup) =@@ -871,14 +861,14 @@ (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x (dL->L l binds) c) =+addTickHsCmd (HsCmdLet x (L l binds) c) = bindLocals (collectLocalBinders binds) $- liftM2 (HsCmdLet x . cL l)+ liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c)-addTickHsCmd (HsCmdDo srcloc (dL->L l stmts))+addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())- ; return (HsCmdDo srcloc (cL l stmts')) }+ ; return (HsCmdDo srcloc (L l stmts')) } addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = liftM5 HsCmdArrApp@@ -904,9 +894,9 @@ addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) -> TM (MatchGroup GhcTc (LHsCmd GhcTc))-addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do+addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do matches' <- mapM (liftL addTickCmdMatch) matches- return $ mg { mg_alts = cL l matches' }+ return $ mg { mg_alts = L l matches' } addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))@@ -917,11 +907,11 @@ addTickCmdMatch (XMatch nec) = noExtCon nec addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))-addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do+addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded- return $ GRHSs x guarded' (cL l local_binds')+ return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds addTickCmdGRHSs (XGRHSs nec) = noExtCon nec@@ -968,8 +958,8 @@ (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard')-addTickCmdStmt (LetStmt x (dL->L l binds)) = do- liftM (LetStmt x . cL l)+addTickCmdStmt (LetStmt x (L l binds)) = do+ liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)@@ -993,9 +983,9 @@ addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) -> TM (LHsRecField' id (LHsExpr GhcTc))-addTickHsRecField (dL->L l (HsRecField id expr pun))+addTickHsRecField (L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr- ; return (cL l (HsRecField id expr' pun)) }+ ; return (L l (HsRecField id expr' pun)) } addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)@@ -1175,10 +1165,10 @@ (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)- return (cL pos (HsTick noExtField tickish (cL pos e)))+ return (L pos (HsTick noExtField tickish (L pos e))) ) (do e <- m- return (cL pos e)+ return (L pos e) ) -- the tick application inherits the source position of its@@ -1246,7 +1236,7 @@ allocBinTickBox boxLabel pos m = do env <- getEnv case tickishType env of- HpcTicks -> do e <- liftM (cL pos) m+ HpcTicks -> do e <- liftM (L pos) m ifGoodTickSrcSpan pos (mkBinTickBoxHpc boxLabel pos e) (return e)@@ -1262,8 +1252,8 @@ c = tickBoxCount st mes = mixEntries st in- ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c)- $ cL pos $ HsBinTick noExtField (c+1) (c+2) e+ ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)+ $ L pos $ HsBinTick noExtField (c+1) (c+2) e -- notice that F and T are reversed, -- because we are building the list in -- reverse...@@ -1290,12 +1280,11 @@ matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where- matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))+ matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss- matchCount (dL->L _ (Match { m_grhss = XGRHSs nec }))+ matchCount (L _ (Match { m_grhss = XGRHSs nec })) = noExtCon nec- matchCount (dL->L _ (XMatch nec)) = noExtCon nec- matchCount _ = panic "matchCount: Impossible Match" -- due to #15884+ matchCount (L _ (XMatch nec)) = noExtCon nec type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
compiler/deSugar/Desugar.hs view
@@ -369,13 +369,13 @@ -} dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)-dsRule (dL->L loc (HsRule { rd_name = name- , rd_act = rule_act- , rd_tmvs = vars- , rd_lhs = lhs- , rd_rhs = rhs }))+dsRule (L loc (HsRule { rd_name = name+ , rd_act = rule_act+ , rd_tmvs = vars+ , rd_lhs = lhs+ , rd_rhs = rhs })) = putSrcSpanDs loc $- do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]+ do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $@@ -412,8 +412,7 @@ ; return (Just rule) } } }-dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec-dsRule _ = panic "dsRule: Impossible Match" -- due to #15884+dsRule (L _ (XRuleDecl nec)) = noExtCon nec warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () -- See Note [Rules and inlining/other rules]@@ -528,7 +527,7 @@ {-# RULES "rule-for-g" forally. g [y] = ... #-} Then "rule-for-f" and "rule-for-g" would compete. Better to add phase control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes-active; or perhpas after "rule-for-g" has become inactive. This is checked+active; or perhaps after "rule-for-g" has become inactive. This is checked by 'competesWith' Class methods have a built-in RULE to select the method from the dictionary,
compiler/deSugar/DsArrows.hs view
@@ -316,7 +316,7 @@ :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr-dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do+dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) (core_cmd, _free_vars, env_ids)@@ -327,7 +327,7 @@ fail_expr <- mkFailExpr ProcExpr env_stk_ty var <- selectSimpleMatchVarL pat match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr- let pat_ty = hsPatType pat+ let pat_ty = hsLPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) core_cmd@@ -455,8 +455,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLam _ (MG { mg_alts- = (dL->L _ [dL->L _ (Match { m_pats = pats- , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) }))+ = (L _ [L _ (Match { m_pats = pats+ , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) let@@ -567,7 +567,7 @@ -} dsCmd ids local_vars stack_ty res_ty- (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches)+ (HsCmdCase _ exp (MG { mg_alts = L l matches , mg_ext = MatchGroupTc arg_tys _ , mg_origin = origin })) env_ids = do@@ -616,7 +616,7 @@ in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase noExtField exp- (MG { mg_alts = cL l matches'+ (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc arg_tys sum_ty , mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty,@@ -632,7 +632,7 @@ -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body)+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds)@@ -660,7 +660,7 @@ -- ---> premap (\ (env,stk) -> env) c dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty- (dL->L loc stmts))+ (L loc stmts)) env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty@@ -706,7 +706,7 @@ -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids- (dL->L _ (HsCmdTop+ (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids')@@ -778,7 +778,7 @@ -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do+dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do putSrcSpanDs loc $ dsNoLevPoly res_ty (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids@@ -868,7 +868,7 @@ -- but that's likely to be defined in terms of first. dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do- let pat_ty = hsPatType pat+ let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd let pat_vars = mkVarSet (collectPatBinders pat) let@@ -1139,8 +1139,8 @@ leavesMatch :: LMatch GhcTc (Located (body GhcTc)) -> [(Located (body GhcTc), IdSet)]-leavesMatch (dL->L _ (Match { m_pats = pats- , m_grhss = GRHSs _ grhss (dL->L _ binds) }))+leavesMatch (L _ (Match { m_pats = pats+ , m_grhss = GRHSs _ grhss (L _ binds) })) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet`@@ -1149,7 +1149,7 @@ [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars)- | (dL->L _ (GRHS _ stmts body)) <- grhss]+ | L _ (GRHS _ stmts body) <- grhss] leavesMatch _ = panic "leavesMatch" -- Replace the leaf commands in a match@@ -1161,12 +1161,12 @@ -> ([Located (body' GhcTc)], -- remaining leaf expressions LMatch GhcTc (Located (body' GhcTc))) -- updated match replaceLeavesMatch _res_ty leaves- (dL->L loc+ (L loc match@(Match { m_grhss = GRHSs x grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in- (leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))+ (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" replaceLeavesGRHS@@ -1174,8 +1174,8 @@ -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command -> ([Located (body' GhcTc)], -- remaining leaf expressions LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS-replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _))- = (leaves, cL loc (GRHS x stmts leaf))+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))+ = (leaves, L loc (GRHS x stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" @@ -1221,14 +1221,14 @@ --------------------- collectl :: LPat GhcTc -> [Id] -> [Id] -- See Note [Dictionary binders in ConPatOut]-collectl (dL->L _ pat) bndrs+collectl (L _ pat) bndrs = go pat where- go (VarPat _ (dL->L _ var)) = var : bndrs+ go (VarPat _ (L _ var)) = var : bndrs go (WildPat _) = bndrs go (LazyPat _ pat) = collectl pat bndrs go (BangPat _ pat) = collectl pat bndrs- go (AsPat _ (dL->L _ a) pat) = a : collectl pat bndrs+ go (AsPat _ (L _ a) pat) = a : collectl pat bndrs go (ParPat _ pat) = collectl pat bndrs go (ListPat _ pats) = foldr collectl bndrs pats@@ -1241,7 +1241,7 @@ ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _ _) = bndrs go (NPat {}) = bndrs- go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs+ go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs go (SigPat _ pat _) = collectl pat bndrs go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
compiler/deSugar/DsBinds.hs view
@@ -101,7 +101,7 @@ unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds bang_binds = filterBag (isBangedHsBind . unLoc) binds - top_level_err desc (dL->L loc bind)+ top_level_err desc (L loc bind) = putSrcSpanDs loc $ errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind))@@ -118,8 +118,8 @@ ------------------------ dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)])-dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags- putSrcSpanDs loc $ dsHsBind dflags bind+dsLHsBind (L loc bind) = do dflags <- getDynFlags+ putSrcSpanDs loc $ dsHsBind dflags bind -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags@@ -143,7 +143,7 @@ else [] ; return (force_var, [core_bind]) } -dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)+dsHsBind dflags b@(FunBind { fun_id = L _ fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick })@@ -657,7 +657,7 @@ -- rhs is in the Id's unfolding -> Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))-dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"@@ -1072,12 +1072,6 @@ augment (\a. g a) (build h) otherwise we don't match when given an argument like augment (\a. h a a) (build h)--Note [Matching seqId]-~~~~~~~~~~~~~~~~~~~-The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack-and this code turns it back into an application of seq!-See Note [Rules for seq] in MkId for the details. Note [Unused spec binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/deSugar/DsExpr.hs view
@@ -37,7 +37,6 @@ import TcType import TcEvidence import TcRnMonad-import TcHsSyn import Type import CoreSyn import CoreUtils@@ -50,6 +49,7 @@ import Module import ConLike import DataCon+import TyCoPpr( pprWithTYPE ) import TysWiredIn import PrelNames import BasicTypes@@ -72,11 +72,11 @@ -} dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr-dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body-dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $- dsValBinds binds body-dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body-dsLocalBinds _ _ = panic "dsLocalBinds"+dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body+dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $+ dsValBinds binds body+dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body+dsLocalBinds _ _ = panic "dsLocalBinds" ------------------------- -- caller sets location@@ -94,7 +94,7 @@ -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where- ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body+ ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) ds_ip_bind _ _ = panic "dsIPBinds"@@ -108,7 +108,7 @@ -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body- | [dL->L loc bind] <- bagToList hsbinds+ | [L loc bind] <- bagToList hsbinds -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes@@ -192,13 +192,13 @@ ; ds_binds <- dsTcEvBinds_s ev_binds ; return (mkCoreLets ds_binds body2) } -dsUnliftedBind (FunBind { fun_id = (dL->L l fun)+dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed- = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))+ = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches ; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( isIdHsWrapper co_fn )@@ -231,7 +231,7 @@ dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (dL->L loc e)+dsLExpr (L loc e) = putSrcSpanDs loc $ do { core_expr <- dsExpr e -- uncomment this check to test the hsExprType function in TcHsSyn@@ -246,7 +246,7 @@ -- See Note [Levity polymorphism checking] in DsMonad -- See Note [Levity polymorphism invariants] in CoreSyn dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr-dsLExprNoLP (dL->L loc e)+dsLExprNoLP (L loc e) = putSrcSpanDs loc $ do { e' <- dsExpr e ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)@@ -260,7 +260,7 @@ -> HsExpr GhcTc -> DsM CoreExpr ds_expr _ (HsPar _ e) = dsLExpr e ds_expr _ (ExprWithTySig _ e _) = dsLExpr e-ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var+ds_expr w (HsVar _ (L _ var)) = dsHsVar w var ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them ds_expr w (HsConLikeOut _ con) = dsConLike w con ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"@@ -285,7 +285,7 @@ ; warnAboutIdentities dflags e' wrapped_ty ; return wrapped_e } -ds_expr _ (NegApp _ (dL->L loc+ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) = do { expr' <- putSrcSpanDs loc $ do@@ -377,12 +377,12 @@ core_op [Var x_id, Var y_id])) ds_expr _ (ExplicitTuple _ tup_args boxity)- = do { let go (lam_vars, args) (dL->L _ (Missing ty))+ = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) }- go (lam_vars, args) (dL->L _ (Present _ expr))+ go (lam_vars, args) (L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr@@ -402,20 +402,8 @@ map Type types ++ [core_expr]) ) } -ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do- dflags <- getDynFlags- if gopt Opt_SccProfilingOn dflags- then do- mod_name <- getModule- count <- goptM Opt_ProfCountEntries- let nm = sl_fs cc- flavour <- ExprCC <$> getCCIndexM nm- Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)- <$> dsLExpr expr- else dsLExpr expr--ds_expr _ (HsCoreAnn _ _ _ expr)- = dsLExpr expr+ds_expr _ (HsPragE _ prag expr) =+ ds_prag_expr prag expr ds_expr _ (HsCase _ discrim matches) = do { core_discrim <- dsLExpr discrim@@ -431,11 +419,11 @@ -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. ---ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty-ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts-ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts-ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts-ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts+ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty+ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts+ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts+ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts+ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr@@ -485,7 +473,7 @@ g = ... makeStatic loc f ... -} -ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do+ds_expr _ (HsStatic _ expr@(L loc _)) = do expr_ds <- dsLExprNoLP expr let ty = exprType expr_ds makeStaticId <- dsLookupGlobalId makeStaticName@@ -624,7 +612,7 @@ -- of the record selector, and we must not make that a local binder -- else we shadow other uses of the record selector -- Hence 'lcl_id'. Cf #2735- ds_field (dL->L _ rec_field)+ ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) ; let fld_id = unLoc (hsRecUpdFieldId rec_field) ; lcl_id <- newSysLocalDs (idType fld_id)@@ -745,18 +733,32 @@ mkBinaryTickBox ixT ixF e2 } -ds_expr _ (HsTickPragma _ _ _ _ expr) = do- dflags <- getDynFlags- if gopt Opt_Hpc dflags- then panic "dsExpr:HsTickPragma"- else dsLExpr expr- -- HsSyn constructs that just shouldn't be here: ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_expr _ (XExpr nec) = noExtCon nec +ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr+ds_prag_expr (HsPragSCC _ _ cc) expr = do+ dflags <- getDynFlags+ if gopt Opt_SccProfilingOn dflags+ then do+ mod_name <- getModule+ count <- goptM Opt_ProfCountEntries+ let nm = sl_fs cc+ flavour <- ExprCC <$> getCCIndexM nm+ Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True)+ <$> dsLExpr expr+ else dsLExpr expr+ds_prag_expr (HsPragCore _ _ _) expr+ = dsLExpr expr+ds_prag_expr (HsPragTick _ _ _ _) expr = do+ dflags <- getDynFlags+ if gopt Opt_Hpc dflags+ then panic "dsExpr:HsPragTick"+ else dsLExpr expr+ds_prag_expr (XHsPragE x) _ = noExtCon x ------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr@@ -775,7 +777,7 @@ findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel- = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds+ = [hsRecFieldArg fld | L _ fld <- rbinds , sel == idName (unLoc $ hsRecFieldId fld) ] {-@@ -894,7 +896,7 @@ = goL stmts where goL [] = panic "dsDo"- goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)+ goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body@@ -924,25 +926,26 @@ let (pats, rhss) = unzip (map (do_arg . snd) args) - do_arg (ApplicativeArgOne _ pat expr _) =- (pat, dsLExpr expr)+ do_arg (ApplicativeArgOne _ pat expr _ fail_op) =+ ((pat, fail_op), dsLExpr expr) do_arg (ApplicativeArgMany _ stmts ret pat) =- (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))+ ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) do_arg (XApplicativeArg nec) = noExtCon nec - arg_tys = map hsPatType pats- ; rhss' <- sequence rhss - ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)+ ; body' <- dsLExpr $ noLoc $ HsDo body_ty DoExpr (noLoc stmts) - ; let fun = cL noSrcSpan $ HsLam noExtField $- MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats- body']- , mg_ext = MatchGroupTc arg_tys body_ty- , mg_origin = Generated }+ ; let match_args (pat, fail_op) (vs,body)+ = do { var <- selectSimpleMatchVarL pat+ ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat+ body_ty (cantFailMatchResult body)+ ; match_code <- handle_failure pat match fail_op+ ; return (var:vs, match_code)+ } - ; fun' <- dsLExpr fun+ ; (vars, body) <- foldrM match_args ([],body') pats+ ; let fun' = mkLams vars body ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r] ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss') ; case mb_join of@@ -958,7 +961,7 @@ , recS_ret_ty = body_ty} }) stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where- new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)+ new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail @@ -999,7 +1002,7 @@ | otherwise = extractMatchResult match (error "It can't fail") -mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String+mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ showPpr dflags (getLoc pat) @@ -1139,7 +1142,7 @@ checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () checkForcedEtaExpansion expr ty | Just var <- case expr of- HsVar _ (dL->L _ var) -> Just var+ HsVar _ (L _ var) -> Just var HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty
compiler/deSugar/DsForeign.hs view
@@ -97,7 +97,7 @@ (vcat cs $$ vcat fe_init_code), foldr (appOL . toOL) nilOL bindss) where- do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl)+ do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id)@@ -106,10 +106,10 @@ traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport { fd_name = (dL->L _ id)+ do_decl (ForeignExport { fd_name = L _ id , fd_e_ext = co , fd_fe = CExport- (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do+ (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) do_decl (XForeignDecl nec) = noExtCon nec
compiler/deSugar/DsGRHSs.hs view
@@ -70,10 +70,9 @@ dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM MatchResult-dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))+dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty-dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec-dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884+dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec {- ************************************************************************
compiler/deSugar/DsListComp.hs view
@@ -279,7 +279,7 @@ let u3_ty@u1_ty = exprType core_list1 -- two names, same thing -- u1_ty is a [alpha] type, and u2_ty = alpha- let u2_ty = hsPatType pat+ let u2_ty = hsLPatType pat let res_ty = exprType core_list2 h_ty = u1_ty `mkVisFunTy` res_ty@@ -373,7 +373,7 @@ -> DsM CoreExpr dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type- let x_ty = hsPatType pat+ let x_ty = hsLPatType pat let b_ty = idType n_id -- create some new local id's@@ -484,8 +484,8 @@ dsMonadComp stmts = dsMcStmts stmts dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr-dsMcStmts [] = panic "dsMcStmts"-dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)+dsMcStmts [] = panic "dsMcStmts"+dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr@@ -639,7 +639,7 @@ | otherwise = extractMatchResult match (error "It can't fail") - mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String+ mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in monad comprehension at " ++ showPpr dflags (getLoc pat)
compiler/deSugar/DsMeta.hs view
@@ -170,15 +170,15 @@ wrapGenSyms ss q_decs } where- no_splice (dL->L loc _)+ no_splice (L loc _) = notHandledL loc "Splices within declaration brackets" empty- no_default_decl (dL->L loc decl)+ no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl)- no_warn (dL->L loc (Warning _ thing _))+ no_warn (L loc (Warning _ thing _)) = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing no_warn _ = panic "repTopDs"- no_doc (dL->L loc _)+ no_doc (L loc _) = notHandledL loc "Haddock documentation" empty repTopDs (XHsGroup nec) = noExtCon nec @@ -192,7 +192,7 @@ XValBindsLR (NValBinds _ sigs) -> sigs get_scoped_tvs :: LSig GhcRn -> [Name]-get_scoped_tvs (dL->L _ signature)+get_scoped_tvs (L _ signature) | TypeSig _ _ sig <- signature = get_scoped_tvs_from_sig (hswc_body sig) | ClassOpSig _ _ _ sig <- signature@@ -279,7 +279,7 @@ Note [Don't quantify implicit type variables in quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you're not careful, it's suprisingly easy to take this quoted declaration:+If you're not careful, it's surprisingly easy to take this quoted declaration: [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b idProxy x = x@@ -302,24 +302,24 @@ -- repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $- repFamilyDecl (L loc fam)+repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $+ repFamilyDecl (L loc fam) -repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))+repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repSynDecl tc1 bndrs rhs ; return (Just (loc, dec)) } -repTyClD (dL->L loc (DataDecl { tcdLName = tc- , tcdTyVars = tvs- , tcdDataDefn = defn }))+repTyClD (L loc (DataDecl { tcdLName = tc+ , tcdTyVars = tvs+ , tcdDataDefn = defn })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repDataDefn tc1 (Left bndrs) defn ; return (Just (loc, dec)) } -repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,+repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds }))@@ -341,7 +341,7 @@ ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))+repRoleD (L loc (RoleAnnotDecl _ tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles ; roles2 <- coreList roleTyConName roles1@@ -351,7 +351,7 @@ ------------------------- repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repKiSigD (dL->L loc kisig) =+repKiSigD (L loc kisig) = case kisig of StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v XStandaloneKindSig nec -> noExtCon nec@@ -393,11 +393,11 @@ ; repTySyn tc bndrs ty1 } repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info- , fdLName = tc- , fdTyVars = tvs- , fdResultSig = dL->L _ resultSig- , fdInjectivityAnn = injectivity }))+repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info+ , fdLName = tc+ , fdTyVars = tvs+ , fdResultSig = L _ resultSig+ , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_ext = []@@ -453,7 +453,7 @@ -> DsM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = do { coreNothing injAnnTyConName }-repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =+repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = do { lhs' <- lookupBinder (unLoc lhs) ; rhs1 <- mapM (lookupBinder . unLoc) rhs ; rhs2 <- coreList nameTyConName rhs1@@ -473,7 +473,7 @@ repLFunDeps fds = repList funDepTyConName repLFunDep fds repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)-repLFunDep (dL->L _ (xs, ys))+repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs ys' <- repList nameTyConName (lookupBinder . unLoc) ys repFunDep xs' ys'@@ -481,13 +481,13 @@ -- Represent instance declarations -- repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl ; return (loc, dec) }-repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) = do { dec <- repDataFamInstD fi_decl ; return (loc, dec) }-repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))+repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } repInstD _ = panic "repInstD"@@ -523,8 +523,8 @@ repClsInstD (XClsInstDecl nec) = noExtCon nec repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat- , deriv_type = ty }))+repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat+ , deriv_type = ty })) = do { dec <- addSimpleTyVarBinds tvs $ do { cxt' <- repLContext cxt ; strat' <- repDerivStrategy strat@@ -611,9 +611,8 @@ = noExtCon nec repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)-repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ- , fd_fi = CImport (dL->L _ cc)- (dL->L _ s) mch cis _ }))+repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ+ , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name MkC typ' <- repHsSigType typ MkC cc' <- repCCallConv cc@@ -654,7 +653,7 @@ repSafety PlaySafe = rep2 safeName [] repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]-repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))+repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName@@ -668,12 +667,12 @@ repFixD _ = panic "repFixD" repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repRuleD (dL->L loc (HsRule { rd_name = n- , rd_act = act- , rd_tyvs = ty_bndrs- , rd_tmvs = tm_bndrs- , rd_lhs = lhs- , rd_rhs = rhs }))+repRuleD (L loc (HsRule { rd_name = n+ , rd_act = act+ , rd_tyvs = ty_bndrs+ , rd_tmvs = tm_bndrs+ , rd_lhs = lhs+ , rd_rhs = rhs })) = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs ; ss <- mkGenSyms tm_bndr_names@@ -695,29 +694,28 @@ repRuleD _ = panic "repRuleD" ruleBndrNames :: LRuleBndr GhcRn -> [Name]-ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n]-ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))+ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]+ruleBndrNames (L _ (RuleBndrSig _ n sig)) | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig = unLoc n : vars-ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) = panic "ruleBndrNames"-ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) = panic "ruleBndrNames"-ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec-ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884+ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)-repRuleBndr (dL->L _ (RuleBndr _ n))+repRuleBndr (L _ (RuleBndr _ n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] }-repRuleBndr (dL->L _ (RuleBndrSig _ n sig))+repRuleBndr (L _ (RuleBndrSig _ n sig)) = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } repRuleBndr _ = panic "repRuleBndr" repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)-repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))+repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp'@@ -725,10 +723,10 @@ repAnnD _ = panic "repAnnD" repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)-repAnnProv (ValueAnnProvenance (dL->L _ n))+repAnnProv (ValueAnnProvenance (L _ n)) = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level ; rep2 valueAnnotationName [ n' ] }-repAnnProv (TypeAnnProvenance (dL->L _ n))+repAnnProv (TypeAnnProvenance (L _ n)) = do { MkC n' <- globalVar n ; rep2 typeAnnotationName [ n' ] } repAnnProv ModuleAnnProvenance@@ -739,17 +737,17 @@ ------------------------------------------------------- repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)-repC (dL->L _ (ConDeclH98 { con_name = con- , con_forall = (dL->L _ False)- , con_mb_cxt = Nothing- , con_args = args }))+repC (L _ (ConDeclH98 { con_name = con+ , con_forall = L _ False+ , con_mb_cxt = Nothing+ , con_args = args })) = repDataCon con args -repC (dL->L _ (ConDeclH98 { con_name = con- , con_forall = (dL->L _ is_existential)- , con_ex_tvs = con_tvs- , con_mb_cxt = mcxt- , con_args = args }))+repC (L _ (ConDeclH98 { con_name = con+ , con_forall = L _ is_existential+ , con_ex_tvs = con_tvs+ , con_mb_cxt = mcxt+ , con_args = args })) = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> do { c' <- repDataCon con args ; ctxt' <- repMbContext mcxt@@ -759,11 +757,11 @@ } } -repC (dL->L _ (ConDeclGADT { con_names = cons- , con_qvars = qtvs- , con_mb_cxt = mcxt- , con_args = args- , con_res_ty = res_ty }))+repC (L _ (ConDeclGADT { con_names = cons+ , con_qvars = qtvs+ , con_mb_cxt = mcxt+ , con_args = args+ , con_res_ty = res_ty })) | isEmptyLHsQTvs qtvs -- No implicit or explicit variables , Nothing <- mcxt -- No context -- ==> no need for a forall@@ -783,7 +781,7 @@ repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) repMbContext Nothing = repContext []-repMbContext (Just (dL->L _ cxt)) = repContext cxt+repMbContext (Just (L _ cxt)) = repContext cxt repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []@@ -812,14 +810,14 @@ ------------------------------------------------------- repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])-repDerivs (dL->L _ clauses)+repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses repDerivClause :: LHsDerivingClause GhcRn -> DsM (Core TH.DerivClauseQ)-repDerivClause (dL->L _ (HsDerivingClause+repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs- , deriv_clause_tys = (dL->L _ dct) }))+ , deriv_clause_tys = L _ dct })) = do MkC dcs' <- repDerivStrategy dcs MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct']@@ -853,22 +851,22 @@ rep_sigs = concatMapM rep_sig rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]-rep_sig (dL->L loc (TypeSig _ nms ty))+rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms-rep_sig (dL->L loc (PatSynSig _ nms ty))+rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms-rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty))+rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms | otherwise = mapM (rep_ty_sig sigDName loc ty) nms-rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)-rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level-rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc-rep_sig (dL->L loc (SpecSig _ nm tys ispec))+rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)+rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc+rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec loc) tys-rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc-rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty-rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty-rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))+rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc+rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty+rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty+rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc rep_sig _ = panic "rep_sig" @@ -990,7 +988,7 @@ -> Maybe (Located Name) -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]-rep_complete_sig (dL->L _ cls) mty loc+rep_complete_sig (L _ cls) mty loc = do { mty' <- repMaybe nameTyConName lookupLOcc mty ; cls' <- repList nameTyConName lookupLOcc cls ; sig <- repPragComplete cls' mty'@@ -1066,18 +1064,18 @@ -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)-repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm = repPlainTV nm-repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm = repLTy ki >>= repKindedTV nm repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind" -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)-repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) )+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) ) = do { nm' <- lookupBinder nm ; repPlainTV nm' }-repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki))+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm ; ki' <- repLTy ki ; repKindedTV nm' ki' }@@ -1135,7 +1133,7 @@ repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty repTy ty@(HsQualTy {}) = repForall ForallInvis ty -repTy (HsTyVar _ _ (dL->L _ n))+repTy (HsTyVar _ _ (L _ n)) | isLiftedTypeKindTyConName n = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | n `hasKey` funTyConKey = repArrowTyCon@@ -1216,11 +1214,10 @@ repMaybeLTy = repMaybe kindQTyConName repLTy repRole :: Located (Maybe Role) -> DsM (Core TH.Role)-repRole (dL->L _ (Just Nominal)) = rep2 nominalRName []-repRole (dL->L _ (Just Representational)) = rep2 representationalRName []-repRole (dL->L _ (Just Phantom)) = rep2 phantomRName []-repRole (dL->L _ Nothing) = rep2 inferRName []-repRole _ = panic "repRole: Impossible Match" -- due to #15884+repRole (L _ (Just Nominal)) = rep2 nominalRName []+repRole (L _ (Just Representational)) = rep2 representationalRName []+repRole (L _ (Just Phantom)) = rep2 phantomRName []+repRole (L _ Nothing) = rep2 inferRName [] ----------------------------------------------------------------------------- -- Splices@@ -1256,10 +1253,10 @@ -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)-repLE (dL->L loc e) = putSrcSpanDs loc (repE e)+repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)-repE (HsVar _ (dL->L _ x)) =+repE (HsVar _ (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x@@ -1279,8 +1276,8 @@ -- HsOverlit can definitely occur repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit _ l) = do { a <- repLiteral l; repLit a }-repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m-repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))+repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m+repE (HsLamCase _ (MG { mg_alts = (L _ ms) })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms }@@ -1301,7 +1298,7 @@ repE (HsPar _ x) = repLE x repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }-repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))+repE (HsCase _ e (MG { mg_alts = (L _ ms) })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2@@ -1315,13 +1312,13 @@ = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' }-repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs+repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet-repE e@(HsDo _ ctxt (dL->L _ sts))+repE e@(HsDo _ ctxt (L _ sts)) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs);@@ -1343,9 +1340,9 @@ repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))- tupArgToCoreExp a- | L _ (Present _ e) <- dL a = do { e' <- repLE e- ; coreJust expQTyConName e' }+ tupArgToCoreExp (L _ a)+ | Present _ e <- a = do { e' <- repLE e+ ; coreJust expQTyConName e' } | otherwise = coreNothing expQTyConName in do { args <- mapM tupArgToCoreExp es@@ -1398,17 +1395,17 @@ sname <- repNameS occ repUnboundVar sname -repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)-repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)-repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)+repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e)+repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e)+repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) repE e = notHandled "Expression form" (ppr e) -------------------------------------------------------------------------------- Building representations of auxillary structures like Match, Clause, Stmt,+-- Building representations of auxiliary structures like Match, Clause, Stmt, repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)-repMatchTup (dL->L _ (Match { m_pats = [p]- , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =+repMatchTup (L _ (Match { m_pats = [p]+ , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p@@ -1420,8 +1417,8 @@ repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)-repClauseTup (dL->L _ (Match { m_pats = ps- , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =+repClauseTup (L _ (Match { m_pats = ps+ , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps@@ -1430,11 +1427,11 @@ gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}}-repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec+repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec repClauseTup _ = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)-repGuards [dL->L _ (GRHS _ [] e)]+repGuards [L _ (GRHS _ [] e)] = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM repLGRHS other@@ -1444,10 +1441,10 @@ repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))-repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))+repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) }-repLGRHS (dL->L _ (GRHS _ ss rhs))+repLGRHS (L _ (GRHS _ ss rhs)) = do { (gs, ss') <- repLSts ss ; rhs' <- addBinds gs $ repLE rhs ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'@@ -1460,16 +1457,16 @@ where rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) -> DsM (Core (TH.Q TH.FieldExp))- rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)- ; e <- repLE (hsRecFieldArg fld)- ; repFieldExp fn e }+ rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)+ ; e <- repLE (hsRecFieldArg fld)+ ; repFieldExp fn e } repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) repUpdFields = repList fieldExpQTyConName rep_fld where rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))- rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of- Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)+ rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of+ Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } _ -> notHandled "Ambiguous record updates" (ppr fld)@@ -1481,7 +1478,7 @@ -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] -- First gensym new names for every variable in any of the patterns. -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))--- if variables didn't shaddow, the static gensym wouldn't be necessary+-- if variables didn't shadow, the static gensym wouldn't be necessary -- and we could reuse the original names (x and x). -- -- do { x'1 <- gensym "x"@@ -1513,7 +1510,7 @@ ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }}-repSts (LetStmt _ (dL->L _ bs) : ss) =+repSts (LetStmt _ (L _ bs) : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss)@@ -1590,18 +1587,16 @@ repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b) rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)-rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))+rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) = do { name <- case ename of- Left (dL->L _ n) -> rep_implicit_param_name n+ Left (L _ n) -> rep_implicit_param_name n Right _ -> panic "rep_implicit_param_bind: post typechecking" ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' ; return (loc, ipb) }-rep_implicit_param_bind (dL->L _ b@(XIPBind _))+rep_implicit_param_bind (L _ b@(XIPBind _)) = notHandled "Implicit parameter bind extension" (ppr b)-rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"- -- due to #15884 rep_implicit_param_name :: HsIPName -> DsM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)@@ -1624,13 +1619,12 @@ -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns-rep_bind (dL->L loc (FunBind+rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts- = (dL->L _ [dL->L _ (Match- { m_pats = []- , m_grhss = GRHSs _ guards- (dL->L _ wheres) }+ = (L _ [L _ (Match+ { m_pats = []+ , m_grhss = GRHSs _ guards (L _ wheres) } )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards)@@ -1640,26 +1634,26 @@ ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (dL->L loc (FunBind { fun_id = fn- , fun_matches = MG { mg_alts = (dL->L _ ms) } }))+rep_bind (L loc (FunBind { fun_id = fn+ , fun_matches = MG { mg_alts = L _ ms } })) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec+rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec -rep_bind (dL->L loc (PatBind { pat_lhs = pat- , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))+rep_bind (L loc (PatBind { pat_lhs = pat+ , pat_rhs = GRHSs _ guards (L _ wheres) })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') }-rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec+rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec -rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))+rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v ; e2 <- repLE e ; x <- repNormal e2@@ -1668,11 +1662,11 @@ ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"-rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn- , psb_args = args- , psb_def = pat- , psb_dir = dir })))+rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"+rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn+ , psb_args = args+ , psb_def = pat+ , psb_dir = dir }))) = do { syn' <- lookupLBinder syn ; dir' <- repPatSynDir dir ; ss <- mkGenArgSyms args@@ -1707,11 +1701,8 @@ wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec -rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec)))- = noExtCon nec-rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec-rep_bind _ = panic "rep_bind: Impossible match!"- -- due to #15884+rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec+rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec repPatSynD :: Core TH.Name -> Core TH.PatSynArgsQ@@ -1747,7 +1738,7 @@ repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) repPatSynDir Unidirectional = rep2 unidirPatSynName [] repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []-repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec@@ -1781,16 +1772,16 @@ -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)-repLambda (dL->L _ (Match { m_pats = ps- , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]- (dL->L _ (EmptyLocalBinds _)) } ))+repLambda (L _ (Match { m_pats = ps+ , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]+ (L _ (EmptyLocalBinds _)) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m)+repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) -----------------------------------------------------------------------------@@ -1837,12 +1828,12 @@ } where rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))- rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)- ; MkC p <- repLP (hsRecFieldArg fld)- ; rep2 fieldPatName [v,p] }+ rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)+ ; MkC p <- repLP (hsRecFieldArg fld)+ ; rep2 fieldPatName [v,p] } -repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l- ; repPlit a }+repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l+ ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP (SigPat _ p t) = do { p' <- repLP p@@ -2117,7 +2108,7 @@ repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] -repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM (Core TH.ExpQ) repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
compiler/deSugar/DsMonad.hs view
@@ -530,7 +530,7 @@ discardWarningsDs :: DsM a -> DsM a -- Ignore warnings inside the thing inside;--- used to ignore inaccessable cases etc. inside generated code+-- used to ignore inaccessible cases etc. inside generated code discardWarningsDs thing_inside = do { env <- getGblEnv ; old_msgs <- readTcRef (ds_msgs env)
compiler/deSugar/DsUsage.hs view
@@ -314,7 +314,7 @@ usg_entities = Map.toList ent_hashs, usg_safe = imp_safe } where- maybe_iface = lookupIfaceByModule dflags hpt pit mod+ maybe_iface = lookupIfaceByModule hpt pit mod -- In one-shot mode, the interfaces for home-package -- modules accumulate in the PIT not HPT. Sigh.
compiler/deSugar/DsUtils.hs view
@@ -408,82 +408,88 @@ return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) {--'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.+'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. -Note [Desugaring seq (1)] cf #1031-~~~~~~~~~~~~~~~~~~~~~~~~~- f x y = x `seq` (y `seq` (# x,y #))+Note [Desugaring seq]+~~~~~~~~~~~~~~~~~~~~~ -The [CoreSyn let/app invariant] means that, other things being equal, because-the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:+There are a few subtleties in the desugaring of `seq`: - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v+ 1. (as described in #1031) -But that is bad for two reasons:- (a) we now evaluate y before x, and- (b) we can't bind v to an unboxed pair+ Consider,+ f x y = x `seq` (y `seq` (# x,y #)) -Seq is very, very special! So we recognise it right here, and desugar to- case x of _ -> case y of _ -> (# x,y #)+ The [CoreSyn let/app invariant] means that, other things being equal, because+ the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: -Note [Desugaring seq (2)] cf #2273-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider- let chp = case b of { True -> fst x; False -> 0 }- in chp `seq` ...chp...-Here the seq is designed to plug the space leak of retaining (snd x)-for too long.+ f x y = case (y `seq` (# x,y #)) of v -> x `seq` v -If we rely on the ordinary inlining of seq, we'll get- let chp = case b of { True -> fst x; False -> 0 }- case chp of _ { I# -> ...chp... }+ But that is bad for two reasons:+ (a) we now evaluate y before x, and+ (b) we can't bind v to an unboxed pair -But since chp is cheap, and the case is an alluring contet, we'll-inline chp into the case scrutinee. Now there is only one use of chp,-so we'll inline a second copy. Alas, we've now ruined the purpose of-the seq, by re-introducing the space leak:- case (case b of {True -> fst x; False -> 0}) of- I# _ -> ...case b of {True -> fst x; False -> 0}...+ Seq is very, very special! So we recognise it right here, and desugar to+ case x of _ -> case y of _ -> (# x,y #) -We can try to avoid doing this by ensuring that the binder-swap in the-case happens, so we get his at an early stage:- case chp of chp2 { I# -> ...chp2... }-But this is fragile. The real culprit is the source program. Perhaps we-should have said explicitly- let !chp2 = chp in ...chp2...+ 2. (as described in #2273) -But that's painful. So the code here does a little hack to make seq-more robust: a saturated application of 'seq' is turned *directly* into-the case expression, thus:- x `seq` e2 ==> case x of x -> e2 -- Note shadowing!- e1 `seq` e2 ==> case x of _ -> e2+ Consider+ let chp = case b of { True -> fst x; False -> 0 }+ in chp `seq` ...chp...+ Here the seq is designed to plug the space leak of retaining (snd x)+ for too long. -So we desugar our example to:- let chp = case b of { True -> fst x; False -> 0 }- case chp of chp { I# -> ...chp... }-And now all is well.+ If we rely on the ordinary inlining of seq, we'll get+ let chp = case b of { True -> fst x; False -> 0 }+ case chp of _ { I# -> ...chp... } -The reason it's a hack is because if you define mySeq=seq, the hack-won't work on mySeq.+ But since chp is cheap, and the case is an alluring contet, we'll+ inline chp into the case scrutinee. Now there is only one use of chp,+ so we'll inline a second copy. Alas, we've now ruined the purpose of+ the seq, by re-introducing the space leak:+ case (case b of {True -> fst x; False -> 0}) of+ I# _ -> ...case b of {True -> fst x; False -> 0}... -Note [Desugaring seq (3)] cf #2409-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The isLocalId ensures that we don't turn- True `seq` e-into- case True of True { ... }-which stupidly tries to bind the datacon 'True'.+ We can try to avoid doing this by ensuring that the binder-swap in the+ case happens, so we get his at an early stage:+ case chp of chp2 { I# -> ...chp2... }+ But this is fragile. The real culprit is the source program. Perhaps we+ should have said explicitly+ let !chp2 = chp in ...chp2...++ But that's painful. So the code here does a little hack to make seq+ more robust: a saturated application of 'seq' is turned *directly* into+ the case expression, thus:+ x `seq` e2 ==> case x of x -> e2 -- Note shadowing!+ e1 `seq` e2 ==> case x of _ -> e2++ So we desugar our example to:+ let chp = case b of { True -> fst x; False -> 0 }+ case chp of chp { I# -> ...chp... }+ And now all is well.++ The reason it's a hack is because if you define mySeq=seq, the hack+ won't work on mySeq.++ 3. (as described in #2409)++ The isLocalId ensures that we don't turn+ True `seq` e+ into+ case True of True { ... }+ which stupidly tries to bind the datacon 'True'. -} -- NB: Make sure the argument is not levity polymorphic mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr-mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2- | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]+mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2+ | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] where case_bndr = case arg1 of Var v1 | isInternalName (idName v1)- -> v1 -- Note [Desugaring seq (2) and (3)]+ -> v1 -- Note [Desugaring seq], points (2) and (3) _ -> mkWildValBinder ty1 mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore@@ -668,11 +674,11 @@ -- and all the desugared binds mkSelectorBinds ticks pat val_expr- | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A)+ | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B)- = do { let pat_ty = hsPatType pat'+ = do { let pat_ty = hsLPatType pat' ; val_var <- newSysLocalDsNoLP pat_ty ; let mk_bind tick bndr_var@@ -715,9 +721,9 @@ strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens-strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p-strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p-strip_bangs lp = lp+strip_bangs (L _ (ParPat _ p)) = strip_bangs p+strip_bangs (L _ (BangPat _ p)) = strip_bangs p+strip_bangs lp = lp is_flat_prod_lpat :: LPat (GhcPass p) -> Bool is_flat_prod_lpat = is_flat_prod_pat . unLoc@@ -725,7 +731,7 @@ is_flat_prod_pat :: Pat (GhcPass p) -> Bool is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps-is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon)+is_flat_prod_pat (ConPatOut { pat_con = L _ pcon , pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con)@@ -753,12 +759,12 @@ mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat-mkLHsPatTup lpats = cL (getLoc (head lpats)) $+mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns-mkVanillaTuplePat pats box = TuplePat (map hsPatType pats) pats box+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box -- The Big equivalents for the source tuple expressions mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc@@ -946,25 +952,25 @@ | otherwise -- -XStrict = go lpat where- go lp@(dL->L l p)+ go lp@(L l p) = case p of- ParPat x p -> cL l (ParPat x (go p))+ ParPat x p -> L l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp- _ -> cL l (BangPat noExtField lp)+ _ -> L l (BangPat noExtField lp) -- | Unconditionally make a 'Pat' strict. addBang :: LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- ^ Banged pattern addBang = go where- go lp@(dL->L l p)+ go lp@(L l p) = case p of- ParPat x p -> cL l (ParPat x (go p))- LazyPat _ lp' -> cL l (BangPat noExtField lp')+ ParPat x p -> L l (ParPat x (go p))+ LazyPat _ lp' -> L l (BangPat noExtField lp') -- Should we bring the extension value over? BangPat _ _ -> lp- _ -> cL l (BangPat noExtField lp)+ _ -> L l (BangPat noExtField lp) isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) @@ -974,24 +980,24 @@ -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated.-isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))+isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon-isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))+isTrueLHsExpr (L _ (HsConLikeOut _ con)) | con `hasKey` getUnique trueDataCon = Just return-isTrueLHsExpr (dL->L _ (HsTick _ tickish e))+isTrueLHsExpr (L _ (HsTick _ tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out.-isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e))+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e-isTrueLHsExpr _ = Nothing+isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e+isTrueLHsExpr _ = Nothing
compiler/deSugar/ExtractDocs.hs view
@@ -12,6 +12,7 @@ import GHC.Hs.Doc import GHC.Hs.Decls import GHC.Hs.Extension+import GHC.Hs.Pat import GHC.Hs.Types import GHC.Hs.Utils import Name@@ -114,7 +115,8 @@ (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]+getMainDeclBinder :: XRec pass Pat ~ Located (Pat pass) =>+ HsDecl pass -> [IdP pass] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of@@ -141,13 +143,13 @@ getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) DataFamInstD _ (DataFamInstDecl- { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l+ { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some -- reason.- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l+ { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"@@ -164,7 +166,7 @@ subordinates instMap decl = case decl of InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body =- FamEqn { feqn_tycon = (dL->L l _)+ FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn @@ -175,7 +177,7 @@ _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d)- | (dL->L _ d, doc) <- classDecls dd+ | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn@@ -189,8 +191,8 @@ | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons- , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)- , (dL->L _ n) <- ns ]+ , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)+ , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ concatMap (unLoc . deriv_clause_tys . unLoc) $@@ -198,15 +200,15 @@ , Just instName <- [M.lookup l instMap] ] extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)- extract_deriv_ty ty =- case dL ty of+ extract_deriv_ty (L l ty) =+ case ty of -- deriving (forall a. C a {- ^ Doc comment -})- L l (HsForAllTy{ hst_fvf = ForallInvis- , hst_body = dL->L _ (HsDocTy _ _ doc) })- -> Just (l, doc)+ HsForAllTy{ hst_fvf = ForallInvis+ , hst_body = L _ (HsDocTy _ _ doc) }+ -> Just (l, doc) -- deriving (C a {- ^ Doc comment -})- L l (HsDocTy _ _ doc) -> Just (l, doc)- _ -> Nothing+ HsDocTy _ _ doc -> Just (l, doc)+ _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
compiler/deSugar/Match.hs view
@@ -271,7 +271,7 @@ = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable- let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1+ let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty'@@ -407,16 +407,16 @@ tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)-tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p+tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] }-tidy1 v _ (VarPat _ (dL->L _ var))+tidy1 v _ (VarPat _ (L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] }-tidy1 v o (AsPat _ (dL->L _ var) pat)+tidy1 v o (AsPat _ (L _ var) pat) = do { (wrap, pat') <- tidy1 v o (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -472,7 +472,7 @@ ; return (idDsWrapper, tidyLitPat lit) } -- NPats: we *might* be able to replace these w/ a simpler form-tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq)+tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) = do { unless (isGenerated o) $ let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } | otherwise = lit@@ -480,7 +480,7 @@ ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } -- NPlusKPat: we may want to warn about the literals-tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _)+tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) = do { unless (isGenerated o) $ do warnAboutOverflowedOverLit lit1 warnAboutOverflowedOverLit lit2@@ -495,15 +495,15 @@ -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang-tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p-tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p+tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p+tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time tidy_bang_pat v o l (AsPat x v' p)- = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p)))+ = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) tidy_bang_pat v o l (CoPat x w p t)- = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t)+ = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t) -- Discard bang around strict pattern tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p@@ -512,7 +512,7 @@ tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p -- Data/newtype constructors-tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))+tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc) , pat_args = args , pat_arg_tys = arg_tys }) -- Newtypes: push bang inwards (#9844)@@ -538,7 +538,7 @@ -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p))+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan@@ -549,16 +549,16 @@ -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args)- PrefixCon [cL l (BangPat noExtField arg)]+ PrefixCon [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)- | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf+ | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds)- RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg- = cL l (BangPat noExtField arg) })] })+ RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg+ = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf- = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))]+ = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -724,7 +724,7 @@ JJQC 30-Nov-1997 -} -matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)+matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches , mg_ext = MatchGroupTc arg_tys rhs_ty , mg_origin = origin }) = do { dflags <- getDynFlags@@ -747,7 +747,7 @@ ; return (new_vars, result_expr) } where -- Called once per equation in the match, or alternative in the case- mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))+ mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do { dflags <- getDynFlags ; let upats = map (unLoc . decideBangHood dflags) pats dicts = collectEvVarsPats upats@@ -763,8 +763,7 @@ ; return (EqnInfo { eqn_pats = upats , eqn_orig = FromSource , eqn_rhs = match_result }) }- mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec- mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884+ mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec handleWarnings = if isGenerated origin then discardWarningsDs@@ -1004,8 +1003,8 @@ exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens- exp (HsPar _ (dL->L _ e)) e' = exp e e'- exp e (HsPar _ (dL->L _ e')) = exp e e'+ exp (HsPar _ (L _ e)) e' = exp e e'+ exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'@@ -1058,8 +1057,8 @@ wrap res_wrap1 res_wrap2 ---------- tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2- tup_arg (dL->L _ (Missing t1)) (dL->L _ (Missing t2)) = eqType t1 t2+ tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2+ tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False ---------@@ -1094,13 +1093,13 @@ eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys patGroup :: DynFlags -> Pat GhcTc -> PatGroup-patGroup _ (ConPatOut { pat_con = (dL->L _ con)+patGroup _ (ConPatOut { pat_con = L _ con , pat_arg_tys = tys }) | RealDataCon dcon <- con = PgCon dcon | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang-patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =+patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = case (oval, isJust mb_neg) of (HsIntegral i, False) -> PgN (fromInteger (il_value i)) (HsIntegral i, True ) -> PgN (-fromInteger (il_value i))@@ -1108,7 +1107,7 @@ (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) PgOverS s-patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =+patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
compiler/deSugar/MatchCon.hs view
@@ -170,7 +170,7 @@ alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where- ConPatOut { pat_con = (dL->L _ con1)+ ConPatOut { pat_con = L _ con1 , pat_arg_tys = arg_tys, pat_wrap = wrapper1, pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } = firstPat eqn1@@ -192,7 +192,7 @@ = arg_vars where fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars- lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env+ lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env (idName (unLoc (hsRecFieldId rpat))) select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" matchOneConLike _ _ [] = panic "matchOneCon []"@@ -209,7 +209,7 @@ same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields flds1 flds2- = all2 (\(dL->L _ f1) (dL->L _ f2)+ = all2 (\(L _ f1) (L _ f2) -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) (rec_flds flds1) (rec_flds flds2)
compiler/deSugar/MatchLit.hs view
@@ -288,11 +288,11 @@ getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- ^ See if the expression is an 'Integral' literal. -- Remember to look through automatically-added tick-boxes! (#8384)-getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e-getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e-getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e-getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit-getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit+getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e+getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e+getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e+getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit+getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit getLHsIntegralLit _ = Nothing -- | If 'Integral', extract the value and type name of the overloaded literal.@@ -469,7 +469,7 @@ matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal- = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1+ = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr@@ -500,7 +500,7 @@ matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns)- = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus+ = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2@@ -513,7 +513,7 @@ adjustMatchResult (foldr1 (.) wraps) $ match_result) } where- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats })+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
compiler/ghci/ByteCodeGen.hs view
@@ -38,12 +38,12 @@ import CoreFVs import Type import RepType-import Kind ( isLiftedTypeKind ) import DataCon import TyCon import Util import VarSet import TysPrim+import TyCoPpr ( pprType ) import ErrUtils import Unique import FastString
compiler/ghci/Debugger.hs view
@@ -74,7 +74,8 @@ -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) go subst id = do- let id' = id `setIdType` substTy subst (idType id)+ let id_ty' = substTy subst (idType id)+ id' = id `setIdType` id_ty' term_ <- GHC.obtainTermFromId maxBound force id' term <- tidyTermTyVars term_ term' <- if bindThings@@ -85,13 +86,14 @@ -- mapping the old tyvars to the reconstructed types. let reconstructed_type = termType term hsc_env <- getSession- case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of+ case (improveRTTIType hsc_env id_ty' reconstructed_type) of Nothing -> return (subst, term') Just subst' -> do { dflags <- GHC.getSessionDynFlags ; liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" (fsep $ [text "RTTI Improvement for", ppr id,- text "is the substitution:" , ppr subst'])+ text "old substitution:" , ppr subst,+ text "new substitution:" , ppr subst']) ; return (subst `unionTCvSubst` subst', term')} tidyTermTyVars :: GhcMonad m => Term -> m Term
compiler/hieFile/HieAst.hs view
@@ -374,8 +374,8 @@ -> [LPat (GhcPass p)] -> [PScoped (LPat (GhcPass p))] patScopes rsp useScope patScope xs =- map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $- listScopes patScope (map dL xs)+ map (\(RS sc a) -> PS rsp useScope sc a) $+ listScopes patScope xs -- | 'listScopes' specialised to 'TVScoped' things tvScopes@@ -402,7 +402,7 @@ bax (x :: a) = ... -- a is in scope here Because of HsWC and HsIB pass on their scope to their children we must wrap the LHsType in pattern signatures in a-Shielded explictly, so that the HsWC/HsIB scope is not passed+Shielded explicitly, so that the HsWC/HsIB scope is not passed on the the LHsType -} @@ -478,9 +478,6 @@ -- Most probably the rest will be unhelpful anyway loc _ = noSrcSpan -instance HasLoc (Pat (GhcPass a)) where- loc (dL -> L l _) = l- {- Note [Real DataCon Name] The typechecker subtitutes the conLikeWrapId for the name, but we don't want this showing up in the hieFile, so we replace the name in the Id with the@@ -581,11 +578,11 @@ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) _ -> makeNode bind spn -instance HasType (LPat GhcRn) where- getTypeNode (dL -> L spn pat) = makeNode pat spn+instance HasType (Located (Pat GhcRn)) where+ getTypeNode (L spn pat) = makeNode pat spn -instance HasType (LPat GhcTc) where- getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)+instance HasType (Located (Pat GhcTc)) where+ getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat) instance HasType (LHsExpr GhcRn) where getTypeNode (L spn e) = makeNode e spn@@ -768,8 +765,8 @@ , ToHie (TScoped (ProtectedSig a)) , HasType (LPat a) , Data (HsSplice a)- ) => ToHie (PScoped (LPat (GhcPass p))) where- toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =+ ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where+ toHie (PS rsp scope pscope lpat@(L ospan opat)) = concatM $ getTypeNode lpat : case opat of WildPat _ -> []@@ -781,7 +778,7 @@ ] AsPat _ lname pat -> [ toHie $ C (PatternBind scope- (combineScopes (mkLScope (dL pat)) pscope)+ (combineScopes (mkLScope pat) pscope) rsp) lname , toHie $ PS rsp scope pscope pat@@ -825,7 +822,7 @@ ] SigPat _ pat sig -> [ toHie $ PS rsp scope pscope pat- , let cscope = mkLScope (dL pat) in+ , let cscope = mkLScope pat in toHie $ TS (ResolvedScopes [cscope, scope, pscope]) (protectSig @a cscope sig) -- See Note [Scoping Rules for SigPat]@@ -981,10 +978,7 @@ ArithSeq _ _ info -> [ toHie info ]- HsSCC _ _ _ expr ->- [ toHie expr- ]- HsCoreAnn _ _ _ expr ->+ HsPragE _ _ expr -> [ toHie expr ] HsProc _ pat cmdtop ->@@ -1000,9 +994,6 @@ HsBinTick _ _ _ expr -> [ toHie expr ]- HsTickPragma _ _ _ _ expr ->- [ toHie expr- ] HsWrap _ _ a -> [ toHie $ L mspan a ]@@ -1177,7 +1168,7 @@ , Data (StmtLR a a (Located (HsExpr a))) , Data (HsLocalBinds a) ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where- toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM+ toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM [ toHie $ PS Nothing sc NoScope pat , toHie expr ]
compiler/hieFile/HieBin.hs view
@@ -117,7 +117,7 @@ symtab_p_p <- tellBin bh0 put_ bh0 symtab_p_p - -- Make some intial state+ -- Make some initial state symtab_next <- newFastMutInt writeFastMutInt symtab_next 0 symtab_map <- newIORef emptyUFM
compiler/iface/FlagChecker.hs view
@@ -57,7 +57,11 @@ -- -fprof-auto etc. prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0 - flags = (mainis, safeHs, lang, cpp, paths, prof)+ -- Ticky+ ticky =+ map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk]++ flags = (mainis, safeHs, lang, cpp, paths, prof, ticky) in -- pprTrace "flags" (ppr flags) $ computeFingerprint nameio flags
compiler/iface/IfaceEnv.hs view
@@ -87,7 +87,7 @@ -- of the Name, so we set this field in the Name we return. -- -- Then (bogus) multiple bindings of the same Name- -- get different SrcLocs can can be reported as such.+ -- get different SrcLocs can be reported as such. -- -- Possible other reason: it might be in the cache because we -- encountered an occurrence before the binding site for an
compiler/iface/LoadIface.hs view
@@ -409,7 +409,7 @@ -- Check whether we have the interface already ; dflags <- getDynFlags- ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {+ ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded@@ -549,7 +549,7 @@ * And that means we end up loading M.hi-boot, because those data types are not yet in the type environment. -But in this wierd case, /all/ we need is the types. We don't need+But in this weird case, /all/ we need is the types. We don't need instances, rules etc. And if we put the instances in the EPS we get "duplicate instance" warnings when we compile the "real" instance in M itself. Hence the strange business of just updateing@@ -675,14 +675,13 @@ traceIf (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes") (eps, hpt) <- getEpsAndHpt- dflags <- getDynFlags- case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of+ case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of Just r -> return (Succeeded r) Nothing -> readAndCache imod insts (_, Nothing) -> return (Succeeded emptyUniqDSet) where- tryEpsAndHpt dflags eps hpt =- fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)+ tryEpsAndHpt eps hpt =+ fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod) tryDepsCache eps imod insts = case lookupInstalledModuleEnv (eps_free_holes eps) imod of Just ifhs -> Just (renameFreeHoles ifhs insts)
compiler/iface/MkIface.hs view
@@ -164,7 +164,7 @@ mkFullIface hsc_env partial_iface = do full_iface <- {-# SCC "addFingerprints" #-}- addFingerprints hsc_env partial_iface (mi_decls partial_iface)+ addFingerprints hsc_env partial_iface -- Debug printing dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" (pprModIface full_iface)@@ -365,7 +365,7 @@ orig_mod = nameModule name lookup mod = do MASSERT2( isExternalName name, ppr name )- iface <- case lookupIfaceByModule dflags hpt pit mod of+ iface <- case lookupIfaceByModule hpt pit mod of Just iface -> return iface Nothing -> do -- This can occur when we're writing out ifaces for@@ -409,13 +409,13 @@ -- See Note [Fingerprinting IfaceDecls] addFingerprints :: HscEnv- -> PartialModIface -- The new interface (lacking decls)- -> [IfaceDecl] -- The new decls- -> IO ModIface -- Updated interface-addFingerprints hsc_env iface0 new_decls+ -> PartialModIface+ -> IO ModIface+addFingerprints hsc_env iface0 = do eps <- hscEPS hsc_env let+ decls = mi_decls iface0 warn_fn = mkIfaceWarnCache (mi_warns iface0) fix_fn = mkIfaceFixCache (mi_fixities iface0) @@ -433,7 +433,7 @@ -- from its OccName. See Note [default method Name] top_lvl_name_env = mkOccEnv [ (nameOccName nm, nm)- | IfaceId { ifName = nm } <- new_decls ]+ | IfaceId { ifName = nm } <- decls ] -- Dependency edges between declarations in the current module. -- This is computed by finding the free external names of each@@ -441,7 +441,7 @@ -- declaration implicitly depends on). edges :: [ Node Unique IfaceDeclABI ] edges = [ DigraphNode abi (getUnique (getOccName decl)) out- | decl <- new_decls+ | decl <- decls , let abi = declABI decl , let out = localOccs $ freeNamesDeclABI abi ]@@ -466,7 +466,7 @@ -- e.g. a reference to a constructor must be turned into a reference -- to the TyCon for the purposes of calculating dependencies. parent_map :: OccEnv OccName- parent_map = foldl' extend emptyOccEnv new_decls+ parent_map = foldl' extend emptyOccEnv decls where extend env d = extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] where n = getOccName d@@ -751,9 +751,8 @@ let hpt = hsc_HPT hsc_env pit = eps_PIT eps- dflags = hsc_dflags hsc_env get_orph_hash mod =- case lookupIfaceByModule dflags hpt pit mod of+ case lookupIfaceByModule hpt pit mod of Just iface -> return (mi_orphan_hash (mi_final_exts iface)) Nothing -> do -- similar to 'mkHashFun' iface <- initIfaceLoad hsc_env . withException
compiler/llvmGen/Llvm/Types.hs view
@@ -843,8 +843,10 @@ [x,y] -> [x,y] _ -> error "dToStr: too many hex digits for float" - str = map toUpper $ concat $ fixEndian $ map hex bs- in text "0x" <> text str+ in sdocWithDynFlags (\dflags ->+ let fixEndian = if wORDS_BIGENDIAN dflags then id else reverse+ str = map toUpper $ concat $ fixEndian $ map hex bs+ in text "0x" <> text str) -- Note [LLVM Float Types] -- ~~~~~~~~~~~~~~~~~~~~~~~@@ -873,14 +875,6 @@ ppFloat :: Float -> SDoc ppFloat = ppDouble . widenFp---- | Reverse or leave byte data alone to fix endianness on this target.-fixEndian :: [a] -> [a]-#if defined(WORDS_BIGENDIAN)-fixEndian = id-#else-fixEndian = reverse-#endif --------------------------------------------------------------------------------
compiler/llvmGen/LlvmCodeGen.hs view
@@ -27,6 +27,7 @@ import BufWrite import DynFlags+import GHC.Platform ( platformArch, Arch(..) ) import ErrUtils import FastString import Outputable@@ -41,10 +42,10 @@ -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator ---llvmCodeGen :: DynFlags -> Handle -> UniqSupply+llvmCodeGen :: DynFlags -> Handle -> Stream.Stream IO RawCmmGroup a -> IO a-llvmCodeGen dflags h us cmm_stream+llvmCodeGen dflags h cmm_stream = withTiming dflags (text "LLVM CodeGen") (const ()) $ do bufh <- newBufHandle h @@ -64,9 +65,14 @@ "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..."+ let isS390X = platformArch (targetPlatform dflags) == ArchS390X+ let major_ver = head . llvmVersionList $ ver+ when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $+ "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>+ "You are using LLVM version: " <> text (llvmVersionStr ver) -- run code generation- a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh us $+ a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $ llvmCodeGen' (liftStream cmm_stream) bFlush bufh
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -218,7 +218,7 @@ { envVersion :: LlvmVersion -- ^ LLVM version , envDynFlags :: DynFlags -- ^ Dynamic flags , envOutput :: BufHandle -- ^ Output buffer- , envUniq :: UniqSupply -- ^ Supply of unique values+ , envMask :: !Char -- ^ Mask for creating unique values , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs , envUniqMeta :: UniqFM MetaId -- ^ Global metadata nodes , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type@@ -249,16 +249,12 @@ instance MonadUnique LlvmM where getUniqueSupplyM = do- us <- getEnv envUniq- let (us1, us2) = splitUniqSupply us- modifyEnv (\s -> s { envUniq = us2 })- return us1+ mask <- getEnv envMask+ liftIO $! mkSplitUniqSupply mask getUniqueM = do- us <- getEnv envUniq- let (u,us') = takeUniqFromSupply us- modifyEnv (\s -> s { envUniq = us' })- return u+ mask <- getEnv envMask+ liftIO $! uniqFromMask mask -- | Lifting of IO actions. Not exported, as we want to encapsulate IO. liftIO :: IO a -> LlvmM a@@ -266,8 +262,8 @@ return (x, env) -- | Get initial Llvm environment.-runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM a -> IO a-runLlvm dflags ver out us m = do+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a+runLlvm dflags ver out m = do (a, _) <- runLlvmM m env return a where env = LlvmEnv { envFunMap = emptyUFM@@ -278,7 +274,7 @@ , envVersion = ver , envDynFlags = dflags , envOutput = out- , envUniq = us+ , envMask = 'n' , envFreshMeta = MetaId 0 , envUniqMeta = emptyUFM }
compiler/main/CodeOutput.hs view
@@ -176,11 +176,9 @@ outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a outputLlvm dflags filenm cmm_stream- = do ncg_uniqs <- mkSplitUniqSupply 'n'-- {-# SCC "llvm_output" #-} doOutput filenm $+ = do {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-}- llvmCodeGen dflags f ncg_uniqs cmm_stream+ llvmCodeGen dflags f cmm_stream {- ************************************************************************@@ -262,4 +260,3 @@ outputForeignStubs_help fname doc_str header footer = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") return True-
compiler/main/DriverPipeline.hs view
@@ -66,6 +66,7 @@ import Ar import Bag ( unitBag ) import FastString ( mkFastString )+import MkIface ( mkFullIface ) import Exception import System.Directory@@ -76,7 +77,6 @@ import Data.Maybe import Data.Version import Data.Either ( partitionEithers )-import Data.IORef import Data.Time ( UTCTime ) @@ -98,15 +98,18 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = handleSourceError (\err -> return (Left (srcErrorMessages err))) $ ghandle handler $- fmap Right $- ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)+ fmap Right $ do+ MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)+ (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) Nothing -- We keep the processed file for the whole session to save on -- duplicated work in ghci. (Temporary TFL_GhcSession) Nothing{-no ModLocation-} []{-no foreign objects-}+ -- We stop before Hsc phase so we shouldn't generate an interface+ MASSERT(isNothing mb_iface)+ return (dflags, fp) where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 handler (ProgramError msg) = return $ Left $ unitBag $@@ -150,21 +153,18 @@ -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne' m_tc_result mHscMessage- hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable+ hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable source_modified0 = do debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) -- Run the pipeline up to codeGen (so everything up to, but not including, STG)- (status, hmi_details, m_iface) <- hscIncrementalCompile+ (status, plugin_dflags) <- hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env summary source_modified mb_old_iface (mod_index, nmods) - -- Build HMI from the results of the Core pipeline.- let coreHmi m_linkable = HomeModInfo (expectIface m_iface) hmi_details m_linkable- let flags = hsc_dflags hsc_env0 in do unless (gopt Opt_KeepHiFiles flags) $ addFilesToClean flags TFL_CurrentModule $@@ -173,28 +173,32 @@ addFilesToClean flags TFL_GhcSession $ [ml_obj_file $ ms_location summary] + -- Use an HscEnv with DynFlags updated with the plugin info (returned from+ -- hscIncrementalCompile)+ let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags }+ case (status, hsc_lang) of- (HscUpToDate, _) ->+ (HscUpToDate iface hmi_details, _) -> -- TODO recomp014 triggers this assert. What's going on?!- -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )- return $! coreHmi maybe_old_linkable- (HscNotGeneratingCode, HscNothing) ->+ -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )+ return $! HomeModInfo iface hmi_details mb_old_linkable+ (HscNotGeneratingCode iface hmi_details, HscNothing) -> let mb_linkable = if isHsBootOrSig src_flavour then Nothing -- TODO: Questionable. else Just (LM (ms_hs_date summary) this_mod [])- in return $! coreHmi mb_linkable- (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"+ in return $! HomeModInfo iface hmi_details mb_linkable+ (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode" (_, HscNothing) -> panic "compileOne HscNothing"- (HscUpdateBoot, HscInterpreted) -> do- return $! coreHmi Nothing- (HscUpdateBoot, _) -> do+ (HscUpdateBoot iface hmi_details, HscInterpreted) -> do+ return $! HomeModInfo iface hmi_details Nothing+ (HscUpdateBoot iface hmi_details, _) -> do touchObjectFile dflags object_filename- return $! coreHmi Nothing- (HscUpdateSig, HscInterpreted) ->+ return $! HomeModInfo iface hmi_details Nothing+ (HscUpdateSig iface hmi_details, HscInterpreted) -> do let !linkable = LM (ms_hs_date summary) this_mod []- in return $! coreHmi (Just linkable)- (HscUpdateSig, _) -> do+ return $! HomeModInfo iface hmi_details (Just linkable)+ (HscUpdateSig iface hmi_details, _) -> do output_fn <- getOutputFilename next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location)@@ -202,33 +206,35 @@ -- #10660: Use the pipeline instead of calling -- compileEmptyStub directly, so -dynamic-too gets -- handled properly- _ <- runPipeline StopLn hsc_env+ _ <- runPipeline StopLn hsc_env' (output_fn, Nothing, Just (HscOut src_flavour- mod_name HscUpdateSig))+ mod_name (HscUpdateSig iface hmi_details))) (Just basename) Persistent (Just location) [] o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename]- return $! coreHmi $ Just linkable- (HscRecomp cgguts summary iface_gen, HscInterpreted) -> do- -- In interpreted mode the regular codeGen backend is not run- -- so we generate a interface without codeGen info.- (iface, no_change) <- iface_gen- -- If we interpret the code, then we can write the interface file here.- liftIO $ hscMaybeWriteIface dflags iface no_change- (ms_location summary)+ return $! HomeModInfo iface hmi_details (Just linkable)+ (HscRecomp { hscs_guts = cgguts,+ hscs_mod_location = mod_location,+ hscs_mod_details = hmi_details,+ hscs_partial_iface = partial_iface,+ hscs_old_iface_hash = mb_old_iface_hash,+ hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do+ -- In interpreted mode the regular codeGen backend is not run so we+ -- generate a interface without codeGen info.+ final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface+ liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash mod_location - (hasStub, comp_bc, spt_entries) <-- hscInteractive hsc_env cgguts summary+ (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location stub_o <- case hasStub of Nothing -> return [] Just stub_c -> do- stub_o <- compileStub hsc_env stub_c+ stub_o <- compileStub hsc_env' stub_c return [DotO stub_o] let hs_unlinked = [BCOs comp_bc spt_entries]@@ -241,42 +247,26 @@ -- be out of date. let !linkable = LM unlinked_time (ms_mod summary) (hs_unlinked ++ stub_o)- return $! HomeModInfo iface hmi_details (Just linkable)- (HscRecomp cgguts summary iface_gen, _) -> do+ return $! HomeModInfo final_iface hmi_details (Just linkable)+ (HscRecomp{}, _) -> do output_fn <- getOutputFilename next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline.-- -- We use this IORef the get out the iface from the otherwise- -- opaque pipeline once it's created. Otherwise we would have- -- to thread it through runPipeline.- if_ref <- newIORef Nothing :: IO (IORef (Maybe ModIface))- let iface_gen' = do- res@(iface, _no_change) <- iface_gen- writeIORef if_ref $ Just iface- return res-- _ <- runPipeline StopLn hsc_env+ (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env' (output_fn, Nothing,- Just (HscOut src_flavour mod_name- (HscRecomp cgguts summary iface_gen')))+ Just (HscOut src_flavour mod_name status)) (Just basename) Persistent (Just location) []- iface <- (expectJust "Iface callback") <$> readIORef if_ref -- The object filename comes from the ModLocation o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename]- return $! HomeModInfo iface hmi_details (Just linkable)+ return $! HomeModInfo iface details (Just linkable) where dflags0 = ms_hspp_opts summary-- expectIface :: Maybe ModIface -> ModIface- expectIface = expectJust "compileOne': Interface expected "- this_mod = ms_mod summary location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location)@@ -361,7 +351,7 @@ LangObjcxx -> Cobjcxx LangAsm -> As True -- allow CPP RawObject -> panic "compileForeign: should be unreachable"- (_, stub_o) <- runPipeline StopLn hsc_env+ (_, stub_o, _) <- runPipeline StopLn hsc_env (stub_c, Nothing, Just (RealPhase phase)) Nothing (Temporary TFL_GhcSession) Nothing{-no ModLocation-}@@ -570,7 +560,7 @@ -- -o foo applies to the file we are compiling now | otherwise = Persistent - ( _, out_file) <- runPipeline stop_phase hsc_env+ ( _, out_file, _) <- runPipeline stop_phase hsc_env (src, Nothing, fmap RealPhase mb_phase) Nothing output@@ -613,7 +603,8 @@ -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects- -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)+ -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+ -- ^ (final flags, output filename, interface) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os @@ -707,20 +698,21 @@ -> FilePath -- ^ Input filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects, if we have one- -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)+ -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+ -- ^ (final flags, output filename, interface) runPipeline' start_phase hsc_env env input_fn maybe_loc foreign_os = do -- Execute the pipeline...- let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }-- evalP (pipeLoop start_phase input_fn) env state+ let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing }+ (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state+ return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state) -- --------------------------------------------------------------------------- -- outer pipeline loop -- | pipeLoop runs phases until we reach the stop phase-pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)+pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath pipeLoop phase input_fn = do env <- getPipeEnv dflags <- getDynFlags@@ -736,7 +728,7 @@ -- further compilation stages can tell what the original filename was. case output_spec env of Temporary _ ->- return (dflags, input_fn)+ return input_fn output -> do pst <- getPipeState final_fn <- liftIO $ getOutputFilename@@ -746,7 +738,7 @@ let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn- return (dflags, final_fn)+ return final_fn | not (realPhase `happensBefore'` stopPhase)@@ -1143,9 +1135,13 @@ -- run the compiler! let msg hsc_env _ what _ = oneShotMsg hsc_env what- (result, _, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'+ (result, plugin_dflags) <-+ liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' mod_summary source_unchanged Nothing (1,1) + -- In the rest of the pipeline use the dflags with plugin info+ setDynFlags plugin_dflags+ return (HscOut src_flavour mod_name result, panic "HscOut doesn't have an input filename") @@ -1158,21 +1154,21 @@ next_phase = hscPostBackendPhase src_flavour hsc_lang case result of- HscNotGeneratingCode ->+ HscNotGeneratingCode _ _ -> return (RealPhase StopLn, panic "No output filename from Hsc when no-code")- HscUpToDate ->+ HscUpToDate _ _ -> do liftIO $ touchObjectFile dflags o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't get Nothing) -- but we touch it anyway, to keep 'make' happy (we think). return (RealPhase StopLn, o_file)- HscUpdateBoot ->+ HscUpdateBoot _ _ -> do -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make liftIO $ touchObjectFile dflags o_file return (RealPhase StopLn, o_file)- HscUpdateSig ->+ HscUpdateSig _ _ -> do -- We need to create a REAL but empty .o file -- because we are going to attempt to put it in a library PipeState{hsc_env=hsc_env'} <- getPipeState@@ -1180,21 +1176,29 @@ basename = dropExtension input_fn liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name return (RealPhase StopLn, o_file)- HscRecomp cgguts mod_summary iface_gen+ HscRecomp { hscs_guts = cgguts,+ hscs_mod_location = mod_location,+ hscs_mod_details = mod_details,+ hscs_partial_iface = partial_iface,+ hscs_old_iface_hash = mb_old_iface_hash,+ hscs_iface_dflags = iface_dflags } -> do output_fn <- phaseOutputFilename next_phase PipeState{hsc_env=hsc_env'} <- getPipeState (outputFilename, mStub, foreign_files) <- liftIO $- hscGenHardCode hsc_env' cgguts mod_summary output_fn-+ hscGenHardCode hsc_env' cgguts mod_location output_fn - (iface, no_change) <- liftIO iface_gen+ final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface)+ -- TODO(osa): ModIface and ModDetails need to be in sync,+ -- but we only generate ModIface with the backend info. See+ -- !2100 for more discussion on this. This will be fixed+ -- with !1304 or !2100.+ setIface final_iface mod_details -- See Note [Writing interface files] let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo- liftIO $ hscMaybeWriteIface if_dflags iface no_change- (ms_location mod_summary)+ liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location stub_o <- liftIO (mapM (compileStub hsc_env') mStub) foreign_os <- liftIO $@@ -1207,25 +1211,18 @@ -- Cmm phase runPhase (RealPhase CmmCpp) input_fn dflags- = do- output_fn <- phaseOutputFilename Cmm+ = do output_fn <- phaseOutputFilename Cmm liftIO $ doCpp dflags False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) runPhase (RealPhase Cmm) input_fn dflags- = do- let hsc_lang = hscTarget dflags-- let next_phase = hscPostBackendPhase HsSrcFile hsc_lang-- output_fn <- phaseOutputFilename next_phase-- PipeState{hsc_env} <- getPipeState-- liftIO $ hscCompileCmmFile hsc_env input_fn output_fn-- return (RealPhase next_phase, output_fn)+ = do let hsc_lang = hscTarget dflags+ let next_phase = hscPostBackendPhase HsSrcFile hsc_lang+ output_fn <- phaseOutputFilename next_phase+ PipeState{hsc_env} <- getPipeState+ liftIO $ hscCompileCmmFile hsc_env input_fn output_fn+ return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- -- Cc phase
compiler/main/DynamicLoading.hs view
@@ -39,7 +39,8 @@ import HscTypes import GHCi.RemoteTypes ( HValue )-import Type ( Type, eqType, mkTyConTy, pprTyThingCategory )+import Type ( Type, eqType, mkTyConTy )+import TyCoPpr ( pprTyThingCategory ) import TyCon ( TyCon ) import Name ( Name, nameModule_maybe ) import Id ( idType )
compiler/main/GHC.hs view
@@ -257,9 +257,6 @@ getLoc, unLoc, getRealSrcSpan, unRealSrcSpan, - -- ** HasSrcSpan- HasSrcSpan(..), SrcSpanLess, dL, cL,- -- *** Combining and comparing Located values eqLocated, cmpLocated, combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost,@@ -321,6 +318,7 @@ import Id import TysPrim ( alphaTyVars ) import TyCon+import TyCoPpr ( pprForAll ) import Class import DataCon import Name hiding ( varName )@@ -1391,7 +1389,7 @@ addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] -> [(Located Token, String)] addSourceToTokens _ _ [] = []-addSourceToTokens loc buf (t@(dL->L span _) : ts)+addSourceToTokens loc buf (t@(L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts@@ -1417,7 +1415,7 @@ getFile (RealSrcSpan s : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id- go loc ((dL->L span _, str):ts)+ go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts RealSrcSpan s
compiler/main/GhcMake.hs view
@@ -730,7 +730,7 @@ -- -- | Unloading unload :: HscEnv -> [Linkable] -> IO ()-unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'+unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables' = case ghcLink (hsc_dflags hsc_env) of LinkInMemory -> Linker.unload hsc_env stable_linkables _other -> return ()
compiler/main/HscMain.hs view
@@ -727,7 +727,7 @@ -> SourceModified -> Maybe ModIface -> (Int,Int)- -> IO (HscStatus, ModDetails, Maybe ModIface)+ -> IO (HscStatus, DynFlags) hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index = do@@ -768,13 +768,14 @@ -- in make mode, since this HMI will go into the HPT. details <- genModDetails hsc_env' iface return details- return (HscUpToDate, details, Just iface)+ return (HscUpToDate iface details, dflags) -- We finished type checking. (mb_old_hash is the hash of -- the interface that existed on disk; it's possible we had -- to retypecheck but the resulting interface is exactly -- the same.)- Right (FrontendTypecheck tc_result, mb_old_hash) ->- finish mod_summary tc_result mb_old_hash+ Right (FrontendTypecheck tc_result, mb_old_hash) -> do+ status <- finish mod_summary tc_result mb_old_hash+ return (status, dflags) -- Runs the post-typechecking frontend (desugar and simplify). We want to -- generate most of the interface as late as possible. This gets us up-to-date@@ -791,7 +792,7 @@ finish :: ModSummary -> TcGblEnv -> Maybe Fingerprint- -> Hsc (HscStatus, ModDetails, Maybe ModIface)+ -> Hsc HscStatus finish summary tc_result mb_old_hash = do hsc_env <- getHscEnv let dflags = hsc_dflags hsc_env@@ -799,26 +800,25 @@ hsc_src = ms_hsc_src summary should_desugar = ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile- mk_simple_iface :: Hsc (HscStatus, ModDetails, Maybe ModIface)+ mk_simple_iface :: Hsc HscStatus mk_simple_iface = do- let hsc_status =- case (target, hsc_src) of- (HscNothing, _) -> HscNotGeneratingCode- (_, HsBootFile) -> HscUpdateBoot- (_, HsigFile) -> HscUpdateSig- _ -> panic "finish"- (iface, no_change, details) <- liftIO $+ (iface, mb_old_iface_hash, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash - liftIO $ hscMaybeWriteIface dflags iface no_change (ms_location summary)- return (hsc_status, details, Just iface)+ liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) - -- we usually desugar even when we are not generating code, otherwise- -- we would miss errors thrown by the desugaring (see #10600). The only- -- exceptions are when the Module is Ghc.Prim or when- -- it is not a HsSrcFile Module.+ return $ case (target, hsc_src) of+ (HscNothing, _) -> HscNotGeneratingCode iface details+ (_, HsBootFile) -> HscUpdateBoot iface details+ (_, HsigFile) -> HscUpdateSig iface details+ _ -> panic "finish"+ if should_desugar then do+ -- We usually desugar even when we are not generating code, otherwise we+ -- would miss errors thrown by the desugaring (see #10600). The only+ -- exceptions are when the Module is Ghc.Prim or when it is not a+ -- HsSrcFile Module. desugared_guts0 <- hscDesugar' (ms_location summary) tc_result if target == HscNothing -- We are not generating code, so we can skip simplification@@ -837,20 +837,12 @@ -- See Note [Avoiding space leaks in toIface*] for details. force (mkPartialIface hsc_env details desugared_guts) - let iface_gen :: IO (ModIface, Bool)- iface_gen = do- -- Build a fully instantiated ModIface.- -- This has to happen *after* code gen so that the back-end- -- info has been set.- -- This captures hsc_env, but it seems we keep it alive in other- -- ways as well so we don't bother extracting only the relevant parts.- dumpIfaceStats hsc_env- final_iface <- mkFullIface hsc_env partial_iface- let no_change = mb_old_hash == Just (mi_iface_hash (mi_final_exts final_iface))- return (final_iface, no_change)-- return ( HscRecomp cg_guts summary iface_gen- , details, Nothing )+ return HscRecomp { hscs_guts = cg_guts,+ hscs_mod_location = ms_location summary,+ hscs_mod_details = details,+ hscs_partial_iface = partial_iface,+ hscs_old_iface_hash = mb_old_hash,+ hscs_iface_dflags = dflags } else mk_simple_iface @@ -868,16 +860,18 @@ In this case we create the interface file inside RunPhase using the interface generator contained inside the HscRecomp status. -}-hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO ()-hscMaybeWriteIface dflags iface no_change location =+hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()+hscMaybeWriteIface dflags iface old_iface location = do let force_write_interface = gopt Opt_WriteInterface dflags write_interface = case hscTarget dflags of HscNothing -> False HscInterpreted -> False _ -> True- in when (write_interface || force_write_interface) $- hscWriteIface dflags iface no_change location+ no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) + when (write_interface || force_write_interface) $+ hscWriteIface dflags iface no_change location+ -------------------------------------------------------------- -- NoRecomp handlers --------------------------------------------------------------@@ -1221,12 +1215,11 @@ lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do- dflags <- getDynFlags hsc_env <- getHscEnv hsc_eps <- liftIO $ hscEPS hsc_env let pkgIfaceT = eps_PIT hsc_eps homePkgT = hsc_HPT hsc_env- iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m+ iface = lookupIfaceByModule homePkgT pkgIfaceT m -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk@@ -1341,13 +1334,13 @@ hscSimpleIface :: HscEnv -> TcGblEnv -> Maybe Fingerprint- -> IO (ModIface, Bool, ModDetails)+ -> IO (ModIface, Maybe Fingerprint, ModDetails) hscSimpleIface hsc_env tc_result mb_old_iface = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface hscSimpleIface' :: TcGblEnv -> Maybe Fingerprint- -> Hsc (ModIface, Bool, ModDetails)+ -> Hsc (ModIface, Maybe Fingerprint, ModDetails) hscSimpleIface' tc_result mb_old_iface = do hsc_env <- getHscEnv details <- liftIO $ mkBootModDetailsTc hsc_env tc_result@@ -1356,10 +1349,9 @@ <- {-# SCC "MkFinalIface" #-} liftIO $ mkIfaceTc hsc_env safe_mode details tc_result- let no_change = mb_old_iface == Just (mi_iface_hash (mi_final_exts new_iface)) -- And the answer is ... liftIO $ dumpIfaceStats hsc_env- return (new_iface, no_change, details)+ return (new_iface, mb_old_iface, details) -------------------------------------------------------------- -- BackEnd combinators@@ -1411,10 +1403,10 @@ in addBootSuffix_maybe (mi_boot iface) with_hi -- | Compile to hard-code.-hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath+hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)]) -- ^ @Just f@ <=> _stub.c is f-hscGenHardCode hsc_env cgguts mod_summary output_filename = do+hscGenHardCode hsc_env cgguts location output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod,@@ -1425,7 +1417,6 @@ cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env- location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes@@ -1479,9 +1470,9 @@ hscInteractive :: HscEnv -> CgGuts- -> ModSummary+ -> ModLocation -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])-hscInteractive hsc_env cgguts mod_summary = do+hscInteractive hsc_env cgguts location = do let dflags = hsc_dflags hsc_env let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need.@@ -1492,7 +1483,6 @@ cg_modBreaks = mod_breaks, cg_spt_entries = spt_entries } = cgguts - location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes
compiler/main/HscStats.hs view
@@ -22,7 +22,7 @@ -- | Source Statistics ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc-ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))+ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list@@ -84,7 +84,7 @@ default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls val_decls = [d | ValD _ d <- decls] - real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es }+ real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } n_exports = length real_exports export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True ; _ -> False})@@ -104,7 +104,7 @@ (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)+ count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) count_bind (PatBind {}) = (0,1,0) count_bind (FunBind {}) = (0,1,0) count_bind (PatSynBind {}) = (0,0,1)@@ -119,12 +119,10 @@ sig_info (ClassOpSig {}) = (0,0,0,0,1) sig_info _ = (0,0,0,0,0) - import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual- , ideclAs = as, ideclHiding = spec }))+ import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual+ , ideclAs = as, ideclHiding = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)- import_info (dL->L _ (XImportDecl nec)) = noExtCon nec- import_info _ = panic " import_info: Impossible Match"- -- due to #15884+ import_info (L _ (XImportDecl nec)) = noExtCon nec safe_info False = 0 safe_info True = 1@@ -138,7 +136,7 @@ data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs- , dd_derivs = (dL->L _ derivs)}})+ , dd_derivs = L _ derivs}}) = ( length cs , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) 0 derivs )
compiler/main/PprTyThing.hs view
@@ -21,15 +21,14 @@ import GhcPrelude -import Type ( ArgFlag(..), TyThing(..), mkTyVarBinders, pprUserForAll )+import Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..) , showToHeader, pprIfaceDecl ) import CoAxiom ( coAxiomTyCon ) import HscTypes( tyThingParent_maybe ) import MkIface ( tyThingToIfaceDecl )-import Type ( tidyOpenType ) import FamInstEnv( FamInst(..), FamFlavor(..) )-import Type( Type, pprTypeApp, pprSigmaType )+import TyCoPpr ( pprUserForAll, pprTypeApp, pprSigmaType ) import Name import VarEnv( emptyTidyEnv ) import Outputable
compiler/main/SysTools/Process.hs view
@@ -83,16 +83,22 @@ if null b_dirs then return Nothing else do env <- getEnvironment- return (Just (map mangle_path env))+ return (Just (mangle_paths env)) where (b_dirs, _) = partitionWith get_b_opt opts get_b_opt (Option ('-':'B':dir)) = Left dir get_b_opt other = Right other + -- Work around #1110 on Windows only (lest we stumble into #17266).+#if defined(mingw32_HOST_OS)+ mangle_paths = map mangle_path mangle_path (path,paths) | map toUpper path == "PATH" = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other+#else+ mangle_paths = id+#endif -----------------------------------------------------------------------------
compiler/main/SysTools/Tasks.hs view
@@ -127,10 +127,9 @@ Nothing -> ([], userOpts_c) Just language -> ([Option "-x", Option languageName], opts) where- s = settings dflags (languageName, opts) = case language of- LangC -> ("c", sOpt_c s ++ userOpts_c)- LangCxx -> ("c++", sOpt_cxx s ++ userOpts_cxx)+ LangC -> ("c", userOpts_c)+ LangCxx -> ("c++", userOpts_cxx) LangObjc -> ("objective-c", userOpts_c) LangObjcxx -> ("objective-c++", userOpts_cxx) LangAsm -> ("assembler", [])@@ -243,7 +242,7 @@ -- -- `-optl` args come at the end, so that later `-l` options -- given there manually can fill in symbols needed by- -- Haskell libaries coming in via `args`.+ -- Haskell libraries coming in via `args`. linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags let (p,args0) = pgm_l dflags optl_args = map Option (getOpts dflags opt_l)
compiler/main/TidyPgm.hs view
@@ -63,7 +63,7 @@ import Control.Monad import Data.Function-import Data.List ( sortBy )+import Data.List ( sortBy, mapAccumL ) import Data.IORef ( atomicModifyIORef' ) {-@@ -1089,12 +1089,7 @@ init_env = (init_occ_env, emptyVarEnv) - tidy _ env [] = (env, [])- tidy cvt_literal env (b:bs)- = let (env1, b') = tidyTopBind dflags this_mod cvt_literal unfold_env- env b- (env2, bs') = tidy cvt_literal env1 bs- in (env2, b':bs')+ tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env) ------------------------ tidyTopBind :: DynFlags@@ -1285,7 +1280,7 @@ In particular CorePrep expands Integer and Natural literals. So in the prediction code here we resort to applying the same expansion (cvt_literal).-There are also numberous other ways in which we can introduce inconsistencies+There are also numerous other ways in which we can introduce inconsistencies between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] for one such example.
compiler/nativeGen/BlockLayout.hs view
@@ -79,7 +79,7 @@ Edge weights not only represent likelyhood of control transfer between blocks but also how much a block would benefit from being placed sequentially after it's predecessor.- For example blocks which are preceeded by an info table are more likely to end+ For example blocks which are preceded by an info table are more likely to end up in a different cache line than their predecessor and we can't eliminate the jump so there is less benefit to placing them sequentially. @@ -359,7 +359,7 @@ -- While we could take into account the space between the two blocks which -- share an edge this blows up compile times quite a bit. It requires -- us to find all edges between two chains, check the distance for all edges,--- rank them based on the distance and and only then we can select two chains+-- rank them based on the distance and only then we can select two chains -- to combine. Which would add a lot of complexity for little gain. -- -- So instead we just rank by the strength of the edge and use the first pair we@@ -891,4 +891,3 @@ lookupDeleteUFM m k = do -- Maybe monad v <- lookupUFM m k return (v, delFromUFM m k)-
compiler/nativeGen/Dwarf/Types.hs view
@@ -230,7 +230,8 @@ -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform). -- pad such that first entry begins at multiple of entry size. pad n = vcat $ replicate n $ pprByte 0- initialLength = 8 + paddingSize + 2*2*wordSize+ -- Fix for #17428+ initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize in pprDwWord (ppr initialLength) $$ pprHalf 2 $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
compiler/nativeGen/Format.hs view
@@ -3,7 +3,7 @@ -- -- TODO: Signed vs unsigned? ----- TODO: This module is currenly shared by all architectures because+-- TODO: This module is currently shared by all architectures because -- NCGMonad need to know about it to make a VReg. It would be better -- to have architecture specific formats, and do the overloading -- properly. eg SPARC doesn't care about FF80.
compiler/nativeGen/PIC.hs view
@@ -420,7 +420,7 @@ -- On AIX we use an indirect local TOC anchored by 'gotLabel'. -- This way we use up only one global TOC entry per compilation-unit--- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode)+-- (this is quite similar to GCC's @-mminimal-toc@ compilation mode) picRelative dflags _ OSAIX lbl = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags) @@ -623,7 +623,7 @@ -- XCOFF / AIX ----- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To+-- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To -- workaround the limitation of a global TOC we use an indirect TOC -- with the label `ghc_toc_table`. --
compiler/nativeGen/PPC/CodeGen.hs view
@@ -1690,7 +1690,7 @@ `appOL` codeAfter) GCPAIX -> return ( dynCode -- AIX/XCOFF follows the PowerOPEN ABI- -- which is quite similiar to LinuxPPC64/ELFv1+ -- which is quite similar to LinuxPPC64/ELFv1 `appOL` codeBefore `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20)) `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))
compiler/nativeGen/RegAlloc/Graph/Spill.hs view
@@ -297,7 +297,7 @@ patchInstr reg instr = do nUnique <- newUnique - -- The register we're rewriting is suppoed to be virtual.+ -- The register we're rewriting is supposed to be virtual. -- If it's not then something has gone horribly wrong. let nReg = case reg of
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs view
@@ -297,7 +297,7 @@ -- | Show a spill cost record, including the degree from the graph--- and final calulated spill cost.+-- and final calculated spill cost. pprSpillCostRecord :: (VirtualReg -> RegClass) -> (Reg -> SDoc)
compiler/nativeGen/RegClass.hs view
@@ -12,7 +12,7 @@ -- | The class of a register. -- Used in the register allocator.--- We treat all registers in a class as being interchangable.+-- We treat all registers in a class as being interchangeable. -- data RegClass = RcInteger
compiler/nativeGen/SPARC/CodeGen/Expand.hs view
@@ -51,7 +51,7 @@ -- | In the SPARC instruction set the FP register pairs that are used--- to hold 64 bit floats are refered to by just the first reg+-- to hold 64 bit floats are referred to by just the first reg -- of the pair. Remap our internal reg pairs to the appropriate reg. -- -- For example:
compiler/nativeGen/X86/Instr.hs view
@@ -816,7 +816,7 @@ -- | | -- +-------------------+ ----- In essense each allocation larger than a page size needs to be chunked and+-- In essence each allocation larger than a page size needs to be chunked and -- a probe emitted after each page allocation. You have to hit the guard -- page so the kernel can map in the next page, otherwise you'll segfault. --
compiler/rename/RnEnv.hs view
@@ -1137,7 +1137,7 @@ deal with `DataKinds`. There is however, as always, one exception to this scheme. If we find-an ambiguous occurence of a record selector and DuplicateRecordFields+an ambiguous occurrence of a record selector and DuplicateRecordFields is enabled then we defer the selection until the typechecker. -}@@ -1555,7 +1555,13 @@ = [rdr_name] where occ = rdrNameOcc rdr_name- rdr_name_tc = setRdrNameSpace rdr_name tcName+ rdr_name_tc =+ case rdr_name of+ -- The (~) type operator is always in scope, so we need a special case+ -- for it here, or else :info (~) fails in GHCi.+ -- See Note [eqTyCon (~) is built-in syntax]+ Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR+ _ -> setRdrNameSpace rdr_name tcName {- Note [dataTcOccs and Exact Names]
compiler/rename/RnExpr.hs view
@@ -232,16 +232,15 @@ = do { addErr (sectionErr expr); rnSection expr } ----------------------------------------------rnExpr (HsCoreAnn x src ann expr)- = do { (expr', fvs_expr) <- rnLExpr expr- ; return (HsCoreAnn x src ann expr', fvs_expr) }--rnExpr (HsSCC x src lbl expr)- = do { (expr', fvs_expr) <- rnLExpr expr- ; return (HsSCC x src lbl expr', fvs_expr) }-rnExpr (HsTickPragma x src info srcInfo expr)+rnExpr (HsPragE x prag expr) = do { (expr', fvs_expr) <- rnLExpr expr- ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }+ ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }+ where+ rn_prag :: HsPragE GhcPs -> HsPragE GhcRn+ rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann+ rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl+ rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo+ rn_prag (XHsPragE x) = noExtCon x rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches@@ -1369,7 +1368,7 @@ where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss- | otherwise = cL (getLoc (head ss)) rec_stmt+ | otherwise = L (getLoc (head ss)) rec_stmt rec_stmt = empty_rec_stmt { recS_stmts = ss , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds }@@ -1492,12 +1491,45 @@ <*> ... <*> argexpr(arg_n) += Relevant modules in the rest of the compiler =++ApplicativeDo touches a few phases in the compiler:++* Renamer: The journey begins here in the renamer, where do-blocks are+ scheduled as outlined above and transformed into applicative+ combinators. However, the code is still represented as a do-block+ with special forms of applicative statements. This allows us to+ recover the original do-block when e.g. printing type errors, where+ we don't want to show any of the applicative combinators since they+ don't exist in the source code.+ See ApplicativeStmt and ApplicativeArg in HsExpr.++* Typechecker: ApplicativeDo passes through the typechecker much like any+ other form of expression. The only crux is that the typechecker has to+ be aware of the special ApplicativeDo statements in the do-notation, and+ typecheck them appropriately.+ Relevant module: TcMatches++* Desugarer: Any do-block which contains applicative statements is desugared+ as outlined above, to use the Applicative combinators.+ Relevant module: DsExpr+ -} -- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and -- 'pureName' due to @RebindableSyntax@. data MonadNames = MonadNames { return_name, pure_name :: Name } +instance Outputable MonadNames where+ ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =+ hcat+ [text "MonadNames { return_name = "+ ,ppr return_name+ ,text ", pure_name = "+ ,ppr pure_name+ ,text "}"+ ]+ -- | rearrange a list of statements using ApplicativeDoStmt. See -- Note [ApplicativeDo]. rearrangeForApplicativeDo@@ -1640,16 +1672,27 @@ -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint.-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _)) tail _tail_fvs | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail -- See Note [ApplicativeDo and strict patterns]- = mkApplicativeStmt ctxt [ApplicativeArgOne noExtField pat rhs False] False tail'-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))+ = mkApplicativeStmt ctxt [ApplicativeArgOne+ { xarg_app_arg_one = noExtField+ , app_arg_pattern = pat+ , arg_expr = rhs+ , is_body_stmt = False+ , fail_operator = fail_op}]+ False tail'+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)) tail _tail_fvs | (False,tail') <- needJoin monad_names tail = mkApplicativeStmt ctxt- [ApplicativeArgOne noExtField nlWildPatName rhs True] False tail'+ [ApplicativeArgOne+ { xarg_app_arg_one = noExtField+ , app_arg_pattern = nlWildPatName+ , arg_expr = rhs+ , is_body_stmt = True+ , fail_operator = fail_op}] False tail' stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = return (s : tail, emptyNameSet)@@ -1663,14 +1706,30 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees let (stmts', fvss) = unzip pairs- let (need_join, tail') = needJoin monad_names tail+ let (need_join, tail') =+ if any hasStrictPattern trees+ then (True, tail)+ else needJoin monad_names tail+ (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' return (stmts, unionNameSets (fvs:fvss)) where- stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))- = return (ApplicativeArgOne noExtField pat exp False, emptyFVs)- stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =- return (ApplicativeArgOne noExtField nlWildPatName exp True, emptyFVs)+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _))+ = return (ApplicativeArgOne+ { xarg_app_arg_one = noExtField+ , app_arg_pattern = pat+ , arg_expr = exp+ , is_body_stmt = False+ , fail_operator = fail_op+ }, emptyFVs)+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) =+ return (ApplicativeArgOne+ { xarg_app_arg_one = noExtField+ , app_arg_pattern = nlWildPatName+ , arg_expr = exp+ , is_body_stmt = True+ , fail_operator = fail_op+ }, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)@@ -1684,9 +1743,15 @@ if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do- (ret,fvs) <- lookupStmtNamePoly ctxt returnMName- return (HsApp noExtField (noLoc ret) tup, fvs)- return ( ApplicativeArgMany noExtField stmts' mb_ret pat+ ret <- lookupSyntaxName' returnMName+ let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup+ return (expr, emptyFVs)+ return ( ApplicativeArgMany+ { xarg_app_arg_many = noExtField+ , app_stmts = stmts'+ , final_expr = mb_ret+ , bv_pattern = pat+ } , fvs1 `plusFV` fvs2) @@ -1789,6 +1854,13 @@ NPlusKPat{} -> True SplicePat{} -> True _otherwise -> panic "isStrictPattern"++hasStrictPattern :: ExprStmtTree -> Bool+hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat+hasStrictPattern (StmtTreeOne _) = False+hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b+hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees+ isLetStmt :: LStmt a b -> Bool isLetStmt (L _ LetStmt{}) = True
compiler/rename/RnHsDoc.hs view
@@ -17,9 +17,9 @@ Nothing -> return Nothing rnLHsDoc :: LHsDocString -> RnM LHsDocString-rnLHsDoc (dL->L pos doc) = do+rnLHsDoc (L pos doc) = do doc' <- rnHsDoc doc- return (cL pos doc')+ return (L pos doc') rnHsDoc :: HsDocString -> RnM HsDocString rnHsDoc = pure
compiler/rename/RnNames.hs view
@@ -32,6 +32,7 @@ import GhcPrelude import DynFlags+import TyCoPpr import GHC.Hs import TcEnv import RnEnv@@ -91,7 +92,7 @@ graph. So we can just worry mostly about direct imports. There is one trust property that can change for a package though without-recompliation being triggered: package trust. So we must check that all+recompilation being triggered: package trust. So we must check that all packages a module tranitively depends on to be trusted are still trusted when we are compiling this module (as due to recompilation avoidance some modules below may not be considered trusted any more without recompilation being
compiler/rename/RnPat.hs view
@@ -129,13 +129,12 @@ ; (r,fvs2) <- k v ; return (r, fvs1 `plusFV` fvs2) }) -wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) =>- (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b+wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) -- Set the location, and also wrap it around the value returned-wrapSrcSpanCps fn (dL->L loc a)+wrapSrcSpanCps fn (L loc a) = CpsRn (\k -> setSrcSpan loc $ unCpsRn (fn a) $ \v ->- k (cL loc v))+ k (L loc v)) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr@@ -220,9 +219,9 @@ rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)-newPatLName name_maker rdr_name@(dL->L loc _)+newPatLName name_maker rdr_name@(L loc _) = do { name <- newPatName name_maker rdr_name- ; return (cL loc name) }+ ; return (L loc name) } newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name@@ -391,10 +390,10 @@ ; return (LazyPat x pat') } rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (BangPat x pat') }-rnPatAndThen mk (VarPat x (dL->L l rdr))+rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM- ; name <- newPatName mk (cL loc rdr)- ; return (VarPat x (cL l name)) }+ ; name <- newPatName mk (L loc rdr)+ ; return (VarPat x (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) @@ -424,7 +423,7 @@ where normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } -rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq)+rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit ; mb_neg' -- See Note [Negative zero] <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName@@ -436,9 +435,9 @@ (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName- ; return (NPat x (cL l lit') mb_neg' eq') }+ ; return (NPat x (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ )+rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as@@ -446,8 +445,8 @@ -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName- ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name)- (cL l lit') lit' ge minus) }+ ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)+ (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat x rdr pat)@@ -540,7 +539,7 @@ -> Located Name -- Constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn))-rnHsRecPatsAndThen mk (dL->L _ con)+rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields@@ -548,10 +547,10 @@ ; check_unused_wildcard (implicit_binders flds' <$> dd) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where- mkVarPat l n = VarPat noExtField (cL l n)- rn_field (dL->L l fld, n') =+ mkVarPat l n = VarPat noExtField (L l n)+ rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)- ; return (cL l (fld { hsRecFieldArg = arg' })) }+ ; return (L l (fld { hsRecFieldArg = arg' })) } loc = maybe noSrcSpan getLoc dd @@ -585,12 +584,12 @@ | HsRecFieldUpd rnHsRecFields- :: forall arg. HasSrcSpan arg =>+ :: forall arg. HsRecFieldContext- -> (SrcSpan -> RdrName -> SrcSpanLess arg)+ -> (SrcSpan -> RdrName -> arg) -- When punning, use this to build a new field- -> HsRecFields GhcPs arg- -> RnM ([LHsRecField GhcRn arg], FreeVars)+ -> HsRecFields GhcPs (Located arg)+ -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation)@@ -616,38 +615,36 @@ HsRecFieldPat con -> Just con _ {- update -} -> Nothing - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg- -> RnM (LHsRecField GhcRn arg)- rn_fld pun_ok parent (dL->L l+ rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)+ -> RnM (LHsRecField GhcRn (Located arg))+ rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl =- (dL->L loc (FieldOcc _ (dL->L ll lbl)))+ (L loc (FieldOcc _ (L ll lbl))) , hsRecFieldArg = arg , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun- then do { checkErr pun_ok (badPun (cL loc lbl))+ then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)- ; return (cL loc (mk_arg loc arg_rdr)) }+ ; return (L loc (mk_arg loc arg_rdr)) } else return arg- ; return (cL l (HsRecField- { hsRecFieldLbl = (cL loc (FieldOcc- sel (cL ll lbl)))+ ; return (L l (HsRecField+ { hsRecFieldLbl = (L loc (FieldOcc+ sel (L ll lbl))) , hsRecFieldArg = arg' , hsRecPun = pun })) }- rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _))+ rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) = panic "rnHsRecFields"- rn_fld _ _ _ = panic "rn_fld: Impossible Match"- -- due to #15884 rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor)- -> [LHsRecField GhcRn arg] -- Explicit fields- -> RnM ([LHsRecField GhcRn arg]) -- Field Labels we need to fill in- rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match+ -> [LHsRecField GhcRn (Located arg)] -- Explicit fields+ -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in+ rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We@@ -679,9 +676,9 @@ _other -> True ] ; addUsedGREs dot_dot_gres- ; return [ cL loc (HsRecField- { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))- , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)+ ; return [ L loc (HsRecField+ { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))+ , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl@@ -726,9 +723,9 @@ rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs -> RnM (LHsRecUpdField GhcRn, FreeVars)- rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f- , hsRecFieldArg = arg- , hsRecPun = pun }))+ rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f+ , hsRecFieldArg = arg+ , hsRecPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker@@ -744,10 +741,10 @@ Just r -> return r } else fmap Left $ lookupGlobalOccRn lbl ; arg' <- if pun- then do { checkErr pun_ok (badPun (cL loc lbl))+ then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)- ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) }+ ; return (L loc (HsVar noExtField (L loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -757,14 +754,14 @@ Right _ -> fvs lbl' = case sel of Left sel_name ->- cL loc (Unambiguous sel_name (cL loc lbl))+ L loc (Unambiguous sel_name (L loc lbl)) Right [sel_name] ->- cL loc (Unambiguous sel_name (cL loc lbl))- Right _ -> cL loc (Ambiguous noExtField (cL loc lbl))+ L loc (Unambiguous sel_name (L loc lbl))+ Right _ -> L loc (Ambiguous noExtField (L loc lbl)) - ; return (cL l (HsRecField { hsRecFieldLbl = lbl'- , hsRecFieldArg = arg''- , hsRecPun = pun }), fvs') }+ ; return (L l (HsRecField { hsRecFieldLbl = lbl'+ , hsRecFieldArg = arg''+ , hsRecPun = pun }), fvs') } dup_flds :: [NE.NonEmpty RdrName] -- Each list represents a RdrName that occurred more than once
compiler/rename/RnSource.hs view
@@ -284,7 +284,7 @@ rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates- ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups+ ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups in addErrAt loc (dupWarnDecl lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocM rn_deprec) decls@@ -304,7 +304,7 @@ what = text "deprecation" warn_rdr_dups = findDupRdrNames- $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls+ $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))@@ -477,9 +477,9 @@ -- checkCanonicalMonadInstances | cls == applicativeClassName = do- forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of- FunBind { fun_id = (dL->L _ name)+ FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName -> addWarnNonCanonicalMethod1@@ -492,9 +492,9 @@ _ -> return () | cls == monadClassName = do- forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of- FunBind { fun_id = (dL->L _ name)+ FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName -> addWarnNonCanonicalMethod2@@ -523,9 +523,9 @@ -- checkCanonicalMonoidInstances | cls == semigroupClassName = do- forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of- FunBind { fun_id = (dL->L _ name)+ FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName -> addWarnNonCanonicalMethod1@@ -534,9 +534,9 @@ _ -> return () | cls == monoidClassName = do- forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+ forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of- FunBind { fun_id = (dL->L _ name)+ FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName -> addWarnNonCanonicalMethod2NoDefault@@ -549,10 +549,9 @@ -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" -- binding, and return @Just rhsName@ if this is the case isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name- isAliasMG MG {mg_alts = (dL->L _- [dL->L _ (Match { m_pats = []+ isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] , m_grhss = grhss })])}- | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss+ | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss , EmptyLocalBinds _ <- unLoc lbinds , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing@@ -612,7 +611,7 @@ ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; cls <- case hsTyGetAppHead_maybe head_ty' of- Just (dL->L _ cls) -> pure cls+ Just (L _ cls) -> pure cls Nothing -> do -- The instance is malformed. We'd still like -- to make *some* progress (rather than failing outright), so@@ -686,7 +685,7 @@ ; tycon' <- lookupFamInstName mb_cls tycon ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats -- Use the "...Dups" form because it's needed- -- below to report unsed binder on the LHS+ -- below to report unused binder on the LHS -- Implicitly bound variables, empty if we have an explicit 'forall' according -- to the "forall-or-nothing" rule.@@ -794,7 +793,7 @@ , feqn_rhs = rhs }}) = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs ; (eqn'@(HsIB { hsib_body =- FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)+ FamEqn { feqn_tycon = L _ tycon' }}), fvs) <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn ; case ctf_info of NotClosedTyFam -> pure ()@@ -1041,15 +1040,15 @@ = go vars names $ \ vars' -> bindLocalNamesFV names (thing_inside vars') where- go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside+ go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside = go vars ns $ \ vars' ->- thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars')+ thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') - go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars)+ go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' ->- thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars')+ thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)@@ -1474,12 +1473,12 @@ 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_annot list- ((dL->L loc first_decl) :| _) = sorted_list+ ((L loc first_decl) :| _) = sorted_list - pp_role_annot (dL->L loc decl) = hang (ppr decl)+ pp_role_annot (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2+ cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list@@ -1489,12 +1488,12 @@ 2 (vcat $ map pp_kisig $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_loc list- ((dL->L loc first_decl) :| _) = sorted_list+ ((L loc first_decl) :| _) = sorted_list - pp_kisig (dL->L loc decl) =+ pp_kisig (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2+ cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2 {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1640,7 +1639,7 @@ -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs =- [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs+ [op | L _ (ClassOpSig _ False ops _) <- sigs , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only@@ -1750,15 +1749,15 @@ } where h98_style = case condecls of -- Note [Stupid theta]- (dL->L _ (ConDeclGADT {})) : _ -> False- _ -> True+ (L _ (ConDeclGADT {})) : _ -> False+ _ -> True - rn_derivs (dL->L loc ds)+ rn_derivs (L loc ds) = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds- ; return (cL loc ds', fvs) }+ ; return (L loc ds', fvs) } rnDataDefn _ (XHsDataDefn nec) = noExtCon nec warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)@@ -1787,21 +1786,19 @@ rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc- (dL->L loc (HsDerivingClause+ (L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs- , deriv_clause_tys = (dL->L loc' dct) }))+ , deriv_clause_tys = L loc' dct })) = do { (dcs', dct', fvs) <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct ; warnNoDerivStrat dcs' loc- ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField- , deriv_clause_strategy = dcs'- , deriv_clause_tys = cL loc' dct' })+ ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField+ , deriv_clause_strategy = dcs'+ , deriv_clause_tys = L loc' dct' }) , fvs ) }-rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec))+rnLHsDerivingClause _ (L _ (XHsDerivingClause nec)) = noExtCon nec-rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match"- -- due to #15884 rnLDerivStrategy :: forall a. HsDocContext@@ -1811,10 +1808,10 @@ rnLDerivStrategy doc mds thing_inside = case mds of Nothing -> boring_case Nothing- Just (dL->L loc ds) ->+ Just (L loc ds) -> setSrcSpan loc $ do (ds', thing, fvs) <- rn_deriv_strat ds- pure (Just (cL loc ds'), thing, fvs)+ pure (Just (L loc ds'), thing, fvs) where rn_deriv_strat :: DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars)@@ -1902,7 +1899,7 @@ ---------------------- rn_info :: Located Name -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)- rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns))+ rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns)) = do { (eqns', fvs) <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) -- no class context@@ -1985,17 +1982,17 @@ -> LFamilyResultSig GhcRn -- ^ Result signature -> LInjectivityAnn GhcPs -- ^ Injectivity annotation -> RnM (LInjectivityAnn GhcRn)-rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv))- (dL->L srcSpan (InjectivityAnn injFrom injTo))+rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))+ (L srcSpan (InjectivityAnn injFrom injTo)) = do- { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors)+ { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) <- askNoErrs $ bindLocalNames [hsLTyVarName resTv] $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo- ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') }+ ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv@@ -2031,12 +2028,12 @@ -- -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar.-rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) =+rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = setSrcSpan srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo- return $ cL srcSpan (InjectivityAnn injFrom' injTo')+ return $ L srcSpan (InjectivityAnn injFrom' injTo') return $ injDecl' {-@@ -2102,7 +2099,7 @@ all_fvs) }} rnConDecl decl@(ConDeclGADT { con_names = names- , con_forall = (dL->L _ explicit_forall)+ , con_forall = L _ explicit_forall , con_qvars = qtvs , con_mb_cxt = mcxt , con_args = args@@ -2178,12 +2175,12 @@ ; (new_ty2, fvs2) <- rnLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } -rnConDeclDetails con doc (RecCon (dL->L l fields))+rnConDeclDetails con doc (RecCon (L l fields)) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn- ; return (RecCon (cL l new_fields), fvs) }+ ; return (RecCon (L l new_fields), fvs) } ------------------------------------------------- @@ -2210,20 +2207,19 @@ -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names- | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n)- , psb_args = RecCon as }))) <- bind+ | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n+ , psb_args = RecCon as }))) <- bind = do- bnd_name <- newTopSrcBinder (cL bind_loc n)+ bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs- mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name))+ mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names)- | (dL->L bind_loc (PatSynBind _- (PSB { psb_id = (dL->L _ n)}))) <- bind+ | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do- bnd_name <- newTopSrcBinder (cL bind_loc n)+ bnd_name <- newTopSrcBinder (L bind_loc n) return ((bnd_name, []): names) | otherwise = return names@@ -2249,9 +2245,9 @@ rnHsTyVars tvs = mapM rnHsTyVar tvs rnHsTyVar :: Located RdrName -> RnM (Located Name)-rnHsTyVar (dL->L l tyvar) = do+rnHsTyVar (L l tyvar) = do tyvar' <- lookupOccRn tyvar- return (cL l tyvar')+ return (L l tyvar') {- *********************************************************@@ -2274,7 +2270,7 @@ -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- This stuff reverses the declarations (again) but it doesn't matter addl gp [] = return (gp, Nothing)-addl gp ((dL->L l d) : ds) = add gp l d ds+addl gp (L l d : ds) = add gp l d ds add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]@@ -2282,7 +2278,7 @@ -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split-add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds+add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds = do { (ds', _) <- rnTopSpliceDecls qq ; addl gp (ds' ++ ds) }@@ -2308,52 +2304,52 @@ -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds | isClassDecl d- = let fsigs = [ cL l f- | (dL->L l (FixSig _ f)) <- tcdSigs d ] in- addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds+ = let fsigs = [ L l f+ | L l (FixSig _ f) <- tcdSigs d ] in+ addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise- = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds+ = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds- = addl (gp {hs_fixds = cL l f : ts}) ds+ = addl (gp {hs_fixds = L l f : ts}) ds -- Standalone kind signatures: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds- = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds+ = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds- = addl (gp {hs_valds = add_sig (cL l d) ts}) ds+ = addl (gp {hs_valds = add_sig (L l d) ts}) ds -- Value declarations: use add_bind add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds- = addl (gp { hs_valds = add_bind (cL l d) ts }) ds+ = addl (gp { hs_valds = add_bind (L l d) ts }) ds -- Role annotations: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds- = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds+ = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds -- NB instance declarations go into TyClGroups. We throw them into the first -- group, just as we do for the TyClD case. The renamer will go on to group -- and order them later. add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds- = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds+ = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds -- The rest are routine add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds- = addl (gp { hs_derivds = cL l d : ts }) ds+ = addl (gp { hs_derivds = L l d : ts }) ds add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds- = addl (gp { hs_defds = cL l d : ts }) ds+ = addl (gp { hs_defds = L l d : ts }) ds add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds- = addl (gp { hs_fords = cL l d : ts }) ds+ = addl (gp { hs_fords = L l d : ts }) ds add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds- = addl (gp { hs_warnds = cL l d : ts }) ds+ = addl (gp { hs_warnds = L l d : ts }) ds add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds- = addl (gp { hs_annds = cL l d : ts }) ds+ = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds- = addl (gp { hs_ruleds = cL l d : ts }) ds+ = addl (gp { hs_ruleds = L l d : ts }) ds add gp l (DocD _ d) ds- = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds+ = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec add (XHsGroup nec) _ _ _ = noExtCon nec
compiler/rename/RnSplice.hs view
@@ -361,13 +361,13 @@ -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote- = cL q_span $ HsApp noExtField (cL q_span- $ HsApp noExtField (cL q_span (HsVar noExtField (cL q_span quote_selector)))- quoterExpr)- quoteExpr+ = L q_span $ HsApp noExtField (L q_span+ $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector)))+ quoterExpr)+ quoteExpr where- quoterExpr = cL q_span $! HsVar noExtField $! (cL q_span quoter)- quoteExpr = cL q_span $! HsLit noExtField $! HsString NoSourceText quote+ quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter)+ quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName@@ -379,19 +379,19 @@ -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM- ; n' <- newLocalBndrRn (cL loc splice_name)+ ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsTypedSplice x hasParen n' expr', fvs) } rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM- ; n' <- newLocalBndrRn (cL loc splice_name)+ ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsUntypedSplice x hasParen n' expr', fvs) } rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { loc <- getSrcSpanM- ; splice_name' <- newLocalBndrRn (cL loc splice_name)+ ; splice_name' <- newLocalBndrRn (L loc splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn quoter@@ -620,7 +620,7 @@ -- See Note [Delaying modFinalizers in untyped splices]. ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) . HsSpliced noExtField (ThModFinalizers mod_finalizers)- . HsSplicedPat) `onHasSrcSpan`+ . HsSplicedPat) `mapLoc` pat , emptyFVs ) }@@ -629,12 +629,12 @@ ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)-rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg)+rnSpliceDecl (SpliceDecl _ (L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where pend_decl_splice rn_splice = ( makePending UntypedDeclSplice rn_splice- , SpliceDecl noExtField (cL loc rn_splice) flg)+ , SpliceDecl noExtField (L loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) rnSpliceDecl (XSpliceDecl nec) = noExtCon nec@@ -739,8 +739,8 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) = do { loc <- case mb_src of- Nothing -> getSrcSpanM- Just (dL->L loc _) -> return loc+ Nothing -> getSrcSpanM+ Just (L loc _) -> return loc ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) ; when is_decl $ -- Raw material for -dth-dec-file@@ -753,7 +753,7 @@ spliceDebugDoc loc = let code = case mb_src of Nothing -> ending- Just e -> nest 2 (ppr e) : ending+ Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending ending = [ text "======>", nest 2 gen ] in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) 2 (sep code)
compiler/rename/RnTypes.hs view
@@ -164,10 +164,10 @@ rn_lty env hs_ty ; return (nwcs, hs_ty', fvs) } where- rn_lty env (dL->L loc hs_ty)+ rn_lty env (L loc hs_ty) = setSrcSpan loc $ do { (hs_ty', fvs) <- rn_ty env hs_ty- ; return (cL loc hs_ty', fvs) }+ ; return (L loc hs_ty', fvs) } rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear@@ -179,23 +179,23 @@ , hst_bndrs = tvs', hst_body = hs_body' } , fvs) } - rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt+ rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt , hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt- , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last+ , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1- ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)]+ ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField- , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }+ , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField- , hst_ctxt = cL cx hs_ctxt'+ , hst_ctxt = L cx hs_ctxt' , hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } @@ -336,7 +336,7 @@ vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] ; loc <- getSrcSpanM- ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs+ ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs ; bindLocalNamesFV vars $ thing_inside vars }@@ -467,11 +467,11 @@ -------------- rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)-rnTyKiContext env (dL->L loc cxt)+rnTyKiContext env (L loc cxt) = do { traceRn "rncontext" (ppr cxt) ; let env' = env { rtke_what = RnConstraint } ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt- ; return (cL loc cxt', fvs) }+ ; return (L loc cxt', fvs) } rnContext :: HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)@@ -479,10 +479,10 @@ -------------- rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)-rnLHsTyKi env (dL->L loc ty)+rnLHsTyKi env (L loc ty) = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi env ty- ; return (cL loc ty', fvs) }+ ; return (L loc ty', fvs) } rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) @@ -504,7 +504,7 @@ , hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name))+rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ unlessXOptM LangExt.PolyKinds $ addErr $ withHsDocContext (rtke_ctxt env) $@@ -513,7 +513,7 @@ -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name- ; return (HsTyVar noExtField ip (cL loc name), unitFV name) }+ ; return (HsTyVar noExtField ip (L loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) = setSrcSpan (getLoc l_op) $@@ -660,20 +660,20 @@ rnLTyVar :: Located RdrName -> RnM (Located Name) -- Called externally; does not deal with wildards-rnLTyVar (dL->L loc rdr_name)+rnLTyVar (L loc rdr_name) = do { tyvar <- lookupTypeOccRn rdr_name- ; return (cL loc tyvar) }+ ; return (L loc tyvar) } -------------- rnHsTyOp :: Outputable a => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars)-rnHsTyOp env overall_ty (dL->L loc op)+rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op ; unless (ops_ok || op' `hasKey` eqTyConKey) $ addErr (opTyErr op overall_ty)- ; let l_op' = cL loc op'+ ; let l_op' = L loc op' ; return (l_op', unitFV op') } --------------@@ -989,35 +989,33 @@ -> LHsTyVarBndr GhcPs -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars)-bindLHsTyVarBndr _doc mb_assoc (dL->L loc+bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x- lrdr@(dL->L lv _))) thing_inside+ lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $- thing_inside (cL loc (UserTyVar x (cL lv nm))) }+ thing_inside (L loc (UserTyVar x (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind))+bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm]- $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind'))+ $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec-bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match"- -- due to #15884+bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name-newTyVarNameRn mb_assoc (dL->L loc rdr)+newTyVarNameRn mb_assoc (L loc rdr) = do { rdr_env <- getLocalRdrEnv ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of (Just _, Just n) -> return n -- Use the same Name as the parent class decl - _ -> newLocalBndrRn (cL loc rdr) }+ _ -> newLocalBndrRn (L loc rdr) } {- ********************************************************* * *@@ -1044,23 +1042,21 @@ rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars)-rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc))+rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc- ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc)+ ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn- lookupField (FieldOcc _ (dL->L lr rdr)) =- FieldOcc (flSelector fl) (cL lr rdr)+ lookupField (FieldOcc _ (L lr rdr)) =+ FieldOcc (flSelector fl) (L lr rdr) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl lookupField (XFieldOcc nec) = noExtCon nec-rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec-rnField _ _ _ = panic "rnField: Impossible Match"- -- due to #15884+rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec {- ************************************************************************@@ -1094,13 +1090,13 @@ -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22))+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 (\t1 t2 -> HsOpTy noExtField t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22))+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 @@ -1116,8 +1112,8 @@ mk_hs_op_ty mk1 op1 fix1 ty1 mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)- ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) }- | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22)))+ ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }+ | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 ; return (mk2 (noLoc new_ty) ty22) }@@ -1133,35 +1129,35 @@ -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2-mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2+mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2- return (OpApp fix1 e11 op1 (cL loc' new_e))+ return (OpApp fix1 e11 op1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2-mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2+mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2- return (NegApp noExtField (cL loc' new_e) neg_name)+ return (NegApp noExtField (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg-mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) return (OpApp fix1 e1 op1 e2)@@ -1194,10 +1190,10 @@ get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar-get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n)-get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv-get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld-get_op other = pprPanic "get_op" (ppr other)+get_op (L _ (HsVar _ n)) = NormalOp (unLoc n)+get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv+get_op (L _ (HsRecFld _ fld)) = RecFldOp fld+get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to@@ -1229,9 +1225,9 @@ -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2-mkOpFormRn a1@(dL->L loc+mkOpFormRn a1@(L loc (HsCmdTop _- (dL->L _ (HsCmdArrForm x op1 f (Just fix1)+ (L _ (HsCmdArrForm x op1 f (Just fix1) [a11,a12])))) op2 fix2 a2 | nofix_error@@ -1241,7 +1237,7 @@ | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExtField op1 f (Just fix1)- [a11, cL loc (HsCmdTop [] (cL loc new_c))])+ [a11, L loc (HsCmdTop [] (L loc new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2@@ -1255,7 +1251,7 @@ mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2+mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 = do { fix1 <- lookupFixityRn (unLoc op1) ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1266,7 +1262,7 @@ else if associate_right then do { new_p <- mkConOpPatRn op2 fix2 p12 p2- ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) }+ ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? else return (ConPatIn op2 (InfixCon p1 p2)) } @@ -1284,12 +1280,12 @@ -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = (dL->L _ ms) })+checkPrecMatch op (MG { mg_alts = (L _ ms) }) = mapM_ check ms where- check (dL->L _ (Match { m_pats = (dL->L l1 p1)- : (dL->L l2 p2)- : _ }))+ check (L _ (Match { m_pats = (L l1 p1)+ : (L l2 p2)+ : _ })) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True@@ -1398,7 +1394,7 @@ 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()-badKindSigErr doc (dL->L loc ty)+badKindSigErr doc (L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty))@@ -1416,7 +1412,7 @@ inTypeDoc ty = text "In the type" <+> quotes (ppr ty) warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()-warnUnusedForAll in_doc (dL->L loc tv) used_names+warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ addWarnAt (Reason Opt_WarnUnusedForalls) loc $@@ -1653,7 +1649,7 @@ extractHsTysRdrTyVarsDups tys = extract_ltys tys [] --- Returns the free kind variables of any explictly-kinded binders, returning+-- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. -- NB: Does /not/ delete the binders themselves.@@ -1668,9 +1664,9 @@ -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]-extractRdrKindSigVars (dL->L _ resultSig)- | KindSig _ k <- resultSig = extractHsTyRdrTyVars k- | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k+extractRdrKindSigVars (L _ resultSig)+ | KindSig _ k <- resultSig = extractHsTyRdrTyVars k+ | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k | otherwise = [] -- Get type/kind variables mentioned in the kind signature, preserving@@ -1695,7 +1691,7 @@ extract_lty :: LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups-extract_lty (dL->L _ ty) acc+extract_lty (L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv ltv acc HsBangTy _ _ ty -> extract_lty ty acc@@ -1758,7 +1754,7 @@ tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]--- Returns the free kind variables of any explictly-kinded binders, returning+-- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. -- NB: Does /not/ delete the binders themselves.@@ -1767,7 +1763,7 @@ -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = foldr extract_lty []- [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs]+ [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] extract_tv :: Located RdrName -> [Located RdrName] -> [Located RdrName]
compiler/rename/RnUtils.hs view
@@ -66,7 +66,7 @@ newLocalBndrRn :: Located RdrName -> RnM Name -- Used for non-top-level binders. These should -- never be qualified.-newLocalBndrRn (dL->L loc rdr_name)+newLocalBndrRn (L loc rdr_name) | Just name <- isExact_maybe rdr_name = return name -- This happens in code generated by Template Haskell -- See Note [Binders in Template Haskell] in Convert.hs@@ -127,7 +127,7 @@ where filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names -- See Note [Binders in Template Haskell] in Convert- get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr)+ get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () checkDupAndShadowedNames envs names
compiler/simplCore/CSE.hs view
@@ -15,7 +15,7 @@ import CoreSubst import Var ( Var ) import VarEnv ( elemInScopeSet, mkInScopeSet )-import Id ( Id, idType, isDeadBinder+import Id ( Id, idType, isDeadBinder, idHasRules , idInlineActivation, setInlineActivation , zapIdOccInfo, zapIdUsageInfo, idInlinePragma , isJoinId, isJoinId_maybe )@@ -256,7 +256,7 @@ is of unlifted type, this would destroy the let/app invariant if (x |> co) was not ok-for-speculation. -But surely (x |> co) is ok-for-speculation, becasue it's a trivial+But surely (x |> co) is ok-for-speculation, because it's a trivial expression, and x's type is also unlifted, presumably. Well, maybe not if you are using unsafe casts. I actually found a case where we had@@ -392,9 +392,15 @@ delayInlining :: TopLevelFlag -> Id -> Id -- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already+-- See Note [Delay inlining after CSE] delayInlining top_lvl bndr | isTopLevel top_lvl , isAlwaysActive (idInlineActivation bndr)+ , idHasRules bndr -- Only if the Id has some RULES,+ -- which might otherwise get lost+ -- These rules are probably auto-generated specialisations,+ -- since Ids with manual rules usually have manually-inserted+ -- delayed inlining anyway = bndr `setInlineActivation` activeAfterInitial | otherwise = bndr@@ -494,13 +500,49 @@ Now there is terrible danger that, in an importing module, we'll inline 'g' before we have a chance to run its specialisation! -Solution: during CSE, when adding a top-level- g = f-binding after a "hit" in the CSE cache, add a NOINLINE[2] activation-to it, to ensure it's not inlined right away.+Solution: during CSE, afer a "hit" in the CSE cache+ * when adding a binding+ g = f+ * for a top-level function g+ * and g has specialisation RULES+add a NOINLINE[2] activation to it, to ensure it's not inlined+right away. -Why top level only? Because for nested bindings we are already past-phase 2 and will never return there.+Notes:+* Why top level only? Because for nested bindings we are already past+ phase 2 and will never return there.++* Why "only if g has RULES"? Because there is no point in+ doing this if there are no RULES; and other things being+ equal it delays optimisation to delay inlining (#17409)+++---- Historical note ---++This patch is simpler and more direct than an earlier+version:++ commit 2110738b280543698407924a16ac92b6d804dc36+ Author: Simon Peyton Jones <simonpj@microsoft.com>+ Date: Mon Jul 30 13:43:56 2018 +0100++ Don't inline functions with RULES too early++We had to revert this patch because it made GHC itself slower.++Why? It delayed inlining of /all/ functions with RULES, and that was+very bad in TcFlatten.flatten_ty_con_app++* It delayed inlining of liftM+* That delayed the unravelling of the recursion in some dictionary+ bindings.+* That delayed some eta expansion, leaving+ flatten_ty_con_app = \x y. let <stuff> in \z. blah+* That allowed the float-out pass to put sguff between+ the \y and \z.+* And that permanently stopped eta expasion of the function,+ even once <stuff> was simplified.+ -} tryForCSE :: CSEnv -> InExpr -> OutExpr
compiler/simplCore/CallArity.hs view
@@ -162,7 +162,7 @@ Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} * Let v = rhs in body: In addition to the results from the subexpressions, add all co-calls from- everything that the body calls together with v to everthing that is called+ everything that the body calls together with v to everything that is called by v. Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body@@ -318,7 +318,7 @@ If we decide that the variable bound in `let x = e1 in e2` is not interesting, the analysis of `e2` will not report anything about `x`. To ensure that `callArityBind` does still do the right thing we have to take that into account-everytime we would be lookup up `x` in the analysis result of `e2`.+every time we would be lookup up `x` in the analysis result of `e2`. * Instead of calling lookupCallArityRes, we return (0, True), indicating that this variable might be called many times with no arguments. * Instead of checking `calledWith x`, we assume that everything can be called
compiler/simplCore/Exitify.hs view
@@ -431,7 +431,7 @@ inlining. Exit join points, recognizeable using `isExitJoinId` are join points with an-occurence in a recursive group, and can be recognized (after the occurence+occurrence in a recursive group, and can be recognized (after the occurrence analyzer ran!) using `isExitJoinId`. This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, because the lambdas of a non-recursive join point are not considered for@@ -493,7 +493,7 @@ We do not just `filter (`elemVarSet` fvs) captured`, as there might be shadowing, and `captured` may contain multiple variables with the same Unique. I-these cases we want to abstract only over the last occurence, hence the `foldr`+these cases we want to abstract only over the last occurrence, hence the `foldr` (with emphasis on the `r`). This is #15110. -}
compiler/simplCore/SetLevels.hs view
@@ -504,7 +504,7 @@ Here we can float the (case y ...) out, because y is sure to be evaluated, to give f x vs = case x of { MkT y ->- caes y of I# w ->+ case y of I# w -> let f vs = ...(e)...f.. in f vs @@ -536,6 +536,32 @@ * We only do this with a single-alternative case ++Note [Setting levels when floating single-alternative cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Handling level-setting when floating a single-alternative case binding+is a bit subtle, as evidenced by #16978. In particular, we must keep+in mind that we are merely moving the case and its binders, not the+body. For example, suppose 'a' is known to be evaluated and we have++ \z -> case a of+ (x,_) -> <body involving x and z>++After floating we may have:++ case a of+ (x,_) -> \z -> <body involving x and z>+ {- some expression involving x and z -}++When analysing <body involving...> we want to use the /ambient/ level,+and /not/ the desitnation level of the 'case a of (x,-) ->' binding.++#16978 was caused by us setting the context level to the destination+level of `x` when analysing <body>. This led us to conclude that we+needed to quantify over some of its free variables (e.g. z), resulting+in shadowing and very confusing Core Lint failures.++ Note [Check the output scrutinee for exprIsHNF] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this:@@ -751,7 +777,7 @@ It's controlled by a flag (floatConsts), because doing this too early loses opportunities for RULES which (needless to say) are important in some nofib programs (gcd is an example). [SPJ note:-I think this is obselete; the flag seems always on.]+I think this is obsolete; the flag seems always on.] Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1669,14 +1695,17 @@ | otherwise = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty +-- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) new_lvl vs = do { us <- getUniqueSupplyM ; let (subst', vs') = cloneBndrs subst us vs- env' = env { le_ctxt_lvl = new_lvl- , le_join_ceil = new_lvl- , le_lvl_env = addLvls new_lvl lvl_env vs'+ -- N.B. We are not moving the body of the case, merely its case+ -- binders. Consequently we should *not* set le_ctxt_lvl and+ -- le_join_ceil. See Note [Setting levels when floating+ -- single-alternative cases].+ env' = env { le_lvl_env = addLvls new_lvl lvl_env vs' , le_subst = subst' , le_env = foldl' add_id id_env (vs `zip` vs') }
compiler/simplCore/SimplCore.hs view
@@ -72,13 +72,13 @@ , mg_loc = loc , mg_deps = deps , mg_rdr_env = rdr_env })- = do { us <- mkSplitUniqSupply 's'- -- make sure all plugins are loaded+ = do { -- make sure all plugins are loaded ; let builtin_passes = getCoreToDo dflags orph_mods = mkModuleSet (mod : dep_orphs deps)+ uniq_mask = 's' ;- ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod+ ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod orph_mods print_unqual loc $ do { hsc_env' <- getHscEnv ; dflags' <- liftIO $ initializePlugins hsc_env'
compiler/simplCore/SimplMonad.hs view
@@ -36,7 +36,8 @@ import FastString import MonadUtils import ErrUtils as Err-import Panic (throwGhcExceptionIO, GhcException (..))+import Util ( count )+import Panic (throwGhcExceptionIO, GhcException (..)) import BasicTypes ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap ) @@ -186,8 +187,8 @@ = do { uniq <- getUniqueM ; let name = mkSystemVarName uniq (fsLit "$j") join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes]- -- Note [idArity for join points] in SimplUtils- arity = length (filter isId bndrs)+ arity = count isId bndrs+ -- arity: See Note [Invariants on join points] invariant 2b, in CoreSyn join_arity = length bndrs details = JoinId join_arity id_info = vanillaIdInfo `setArityInfo` arity
compiler/simplCore/SimplUtils.hs view
@@ -46,6 +46,7 @@ import CoreSyn import qualified CoreSubst import PprCore+import TyCoPpr ( pprParendType ) import CoreFVs import CoreUtils import CoreArity@@ -557,7 +558,7 @@ LHS of a rule it's not, because 'as' and 'bs' are now not bound on the LHS. -This is a pretty pathalogical example, so I'm not losing sleep over+This is a pretty pathological example, so I'm not losing sleep over it, but the simplest solution was to check sm_inline; if it is False, which it is on the LHS of a rule (see updModeForRules), then don't make use of the strictness info for the function.@@ -1157,12 +1158,12 @@ extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) one_occ IAmDead = True -- Happens in ((\x.1) v)- one_occ (OneOcc { occ_one_br = True -- One textual occurrence- , occ_in_lam = in_lam- , occ_int_cxt = int_cxt })- | not in_lam = isNotTopLevel top_lvl || early_phase- | otherwise = int_cxt && canInlineInLam rhs- one_occ _ = False+ one_occ OneOcc{ occ_one_br = InOneBranch+ , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase+ one_occ OneOcc{ occ_one_br = InOneBranch+ , occ_in_lam = IsInsideLam+ , occ_int_cxt = IsInteresting } = canInlineInLam rhs+ one_occ _ = False pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env) mode = getMode env@@ -1296,7 +1297,7 @@ -- PRINCIPLE: when we've already simplified an expression once, -- make sure that we only inline it if it's reasonably small. - && (not in_lam ||+ && (in_lam == NotInsideLam || -- Outside a lambda, we want to be reasonably aggressive -- about inlining into multiple branches of case -- e.g. let x = <non-value>@@ -1305,7 +1306,7 @@ -- the uses in C1, C2 are not 'interesting' -- An example that gets worse if you add int_cxt here is 'clausify' - (isCheapUnfolding unfolding && int_cxt))+ (isCheapUnfolding unfolding && int_cxt == IsInteresting)) -- isCheap => acceptable work duplication; in_lam may be true -- int_cxt to prevent us inlining inside a lambda without some -- good reason. See the notes on int_cxt in preInlineUnconditionally@@ -1517,7 +1518,7 @@ -- Note [Do not eta-expand join points] -- But do return the correct arity and bottom-ness, because -- these are used to set the bndr's IdInfo (#15517)- -- Note [idArity for join points]+ -- Note [Invariants on join points] invariant 2b, in CoreSyn | otherwise = do { (new_arity, is_bot, new_rhs) <- try_expand@@ -1611,13 +1612,6 @@ $j2 = if n > 0 then $j1 else (...) eta -Note [idArity for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because of Note [Do not eta-expand join points] we have it that the idArity-of a join point is always (less than or) equal to the join arity.-Essentially, for join points we set `idArity $j = count isId join_lam_bndrs`.-It really can be less if there are type-level binders in join_lam_bndrs.- Note [Do not eta-expand PAPs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to have old_arity = manifestArity rhs, which meant that we@@ -2257,7 +2251,10 @@ -- InIds, so it's crucial that isExitJoinId is only called on freshly -- occ-analysed code. It's not a generic function you can call anywhere. isExitJoinId :: Var -> Bool-isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id)+isExitJoinId id+ = isJoinId id+ && isOneOcc (idOccInfo id)+ && occ_in_lam (idOccInfo id) == IsInsideLam {- Note [Dead binders]
compiler/simplCore/Simplify.hs view
@@ -1623,7 +1623,7 @@ = thing_inside env cont | not (sm_case_case (getMode env))- -- See Note [Join points wih -fno-case-of-case]+ -- See Note [Join points with -fno-case-of-case] = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont@@ -1691,7 +1691,7 @@ with mkDuableCont. -Note [Join points wih -fno-case-of-case]+Note [Join points with -fno-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Supose case-of-case is switched off, and we are simplifying @@ -2090,11 +2090,16 @@ no_cast_scrut = drop_casts scrut scrut_ty = exprType no_cast_scrut seq_id_ty = idType seqId+ res1_ty = piResultTy seq_id_ty rhs_rep+ res2_ty = piResultTy res1_ty scrut_ty rhs_ty = substTy in_env (exprType rhs)- out_args = [ TyArg { as_arg_ty = scrut_ty+ rhs_rep = getRuntimeRep rhs_ty+ out_args = [ TyArg { as_arg_ty = rhs_rep , as_hole_ty = seq_id_ty }+ , TyArg { as_arg_ty = scrut_ty+ , as_hole_ty = res1_ty } , TyArg { as_arg_ty = rhs_ty- , as_hole_ty = piResultTy seq_id_ty scrut_ty }+ , as_hole_ty = res2_ty } , ValArg no_cast_scrut] rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs , sc_env = in_env, sc_cont = cont }@@ -2960,7 +2965,7 @@ | exprIsTrivial scrut = return (emptyFloats env , extendIdSubst env bndr (DoneEx scrut Nothing)) | otherwise = do { dc_args <- mapM (simplVar env) bs- -- dc_ty_args are aready OutTypes,+ -- dc_ty_args are already OutTypes, -- but bs are InBndrs ; let con_app = Var (dataConWorkId dc) `mkTyApps` dc_ty_args
compiler/simplStg/SimplStg.hs view
@@ -32,15 +32,17 @@ import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict -newtype StgM a = StgM { _unStgM :: StateT UniqSupply IO a }+newtype StgM a = StgM { _unStgM :: StateT Char IO a } deriving (Functor, Applicative, Monad, MonadIO) instance MonadUnique StgM where- getUniqueSupplyM = StgM (state splitUniqSupply)- getUniqueM = StgM (state takeUniqFromSupply)+ getUniqueSupplyM = StgM $ do { mask <- get+ ; liftIO $! mkSplitUniqSupply mask}+ getUniqueM = StgM $ do { mask <- get+ ; liftIO $! uniqFromMask mask} -runStgM :: UniqSupply -> StgM a -> IO a-runStgM us (StgM m) = evalStateT m us+runStgM :: Char -> StgM a -> IO a+runStgM mask (StgM m) = evalStateT m mask stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module being compiled@@ -50,10 +52,8 @@ stg2stg dflags this_mod binds = do { dump_when Opt_D_dump_stg "STG:" binds ; showPass dflags "Stg2Stg"- ; us <- mkSplitUniqSupply 'g'- -- Do the main business!- ; binds' <- runStgM us $+ ; binds' <- runStgM 'g' $ foldM do_stg_pass binds (getStgToDo dflags) ; dump_when Opt_D_dump_stg_final "Final STG:" binds'
compiler/simplStg/StgLiftLams/Analysis.hs view
@@ -412,7 +412,7 @@ is_memoized_rhs StgRhsCon{} = True is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd - -- Don't lift binders occuring as arguments. This would result in complex+ -- Don't lift binders occurring as arguments. This would result in complex -- argument expressions which would have to be given a name, reintroducing -- the very allocation at each call site that we wanted to get rid off in -- the first place.
compiler/specialise/Specialise.hs view
@@ -576,7 +576,7 @@ ************************************************************************ -} --- | Specialise calls to type-class overloaded functions occuring in a program.+-- | Specialise calls to type-class overloaded functions occurring in a program. specProgram :: ModGuts -> CoreM ModGuts specProgram guts@(ModGuts { mg_module = this_mod , mg_rules = local_rules@@ -2107,7 +2107,7 @@ We gather the call info for (f @T $df), and we don't want to drop it when we come across the binding for $df. So we add $df to the floats and continue. But then we have to add $c== to the floats, and so on.-These all float above the binding for 'f', and and now we can+These all float above the binding for 'f', and now we can successfully specialise 'f'. So the DictBinds in (ud_binds :: Bag DictBind) may contain
compiler/stgSyn/StgFVs.hs view
@@ -70,12 +70,12 @@ binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet) binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs) where- -- See Note [Tacking local binders]+ -- See Note [Tracking local binders] (r', rhs_fvs) = rhs env r fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs binding env body_fv (StgRec pairs) = (StgRec pairs', fvs) where- -- See Note [Tacking local binders]+ -- See Note [Tracking local binders] bndrs = map fst pairs (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs pairs' = zip bndrs rhss@@ -93,7 +93,7 @@ go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) where (scrut', scrut_fvs) = go scrut- -- See Note [Tacking local binders]+ -- See Note [Tracking local binders] (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts alt_fvs = unionDVarSets alt_fvss fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr@@ -108,7 +108,7 @@ go_bind dc bind body = (dc bind' body', fvs) where- -- See Note [Tacking local binders]+ -- See Note [Tracking local binders] env' = addLocals (boundIds bind) env (body', body_fvs) = expr env' body (bind', fvs) = binding env' body_fvs bind@@ -117,7 +117,7 @@ rhs env (StgRhsClosure _ ccs uf bndrs body) = (StgRhsClosure fvs ccs uf bndrs body', fvs) where- -- See Note [Tacking local binders]+ -- See Note [Tracking local binders] (body', body_fvs) = expr (addLocals bndrs env) body fvs = delDVarSetList body_fvs bndrs rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)@@ -125,6 +125,6 @@ alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) alt env (con, bndrs, e) = ((con, bndrs, e'), fvs) where- -- See Note [Tacking local binders]+ -- See Note [Tracking local binders] (e', rhs_fvs) = expr (addLocals bndrs env) e fvs = delDVarSetList rhs_fvs bndrs
compiler/stranal/DmdAnal.hs view
@@ -603,8 +603,8 @@ rhs_arity = idArity id rhs_dmd -- See Note [Demand analysis for join points]- -- See Note [idArity for join points] in SimplUtils- -- rhs_arity matches the join arity of the join point+ -- See Note [Invariants on join points] invariant 2b, in CoreSyn+ -- rhs_arity matches the join arity of the join point | isJoinId id = mkCallDmds rhs_arity let_dmd | otherwise@@ -726,6 +726,21 @@ let_dmd here). Another win for join points! #13543.++However, note that the strictness signature for a join point can+look a little puzzling. E.g.++ (join j x = \y. error "urk")+ (in case v of )+ ( A -> j 3 ) x+ ( B -> j 4 )+ ( C -> \y. blah )++The entire thing is in a C(S) context, so j's strictness signature+will be [A]b+meaning one absent argument, returns bottom. That seems odd because+there's a \y inside. But it's right because when consumed in a C(1)+context the RHS of the join point is indeed bottom. Note [Demand signatures are computed for a threshold demand based on idArity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/FamInst.hs view
@@ -10,7 +10,7 @@ newFamInst, -- * Injectivity- makeInjectivityErrors+ reportInjectivityErrors, reportConflictingInjectivityErrs ) where import GhcPrelude@@ -34,9 +34,9 @@ import RdrName import DataCon ( dataConName ) import Maybes-import Type import TyCoRep import TyCoFVs+import TyCoPpr ( pprWithExplicitKindsWhen ) import TcMType import Name import Panic@@ -44,6 +44,7 @@ import FV import Bag( Bag, unionBags, unitBag ) import Control.Monad+import Data.List.NonEmpty ( NonEmpty(..) ) import qualified GHC.LanguageExtensions as LangExt @@ -304,13 +305,12 @@ -- See Note [The type family instance consistency story]. checkFamInstConsistency :: [Module] -> TcM () checkFamInstConsistency directlyImpMods- = do { dflags <- getDynFlags- ; (eps, hpt) <- getEpsAndHpt+ = do { (eps, hpt) <- getEpsAndHpt ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as -- all directly imported modules must already have been loaded. modIface mod =- case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of+ case lookupIfaceByModule hpt (eps_PIT eps) mod of Nothing -> panicDoc "FamInst.checkFamInstConsistency" (ppr mod $$ pprHPT hpt) Just iface -> iface@@ -683,10 +683,13 @@ home_fie' = extendFamInstEnv home_fie fam_inst -- Check for conflicting instance decls and injectivity violations- ; no_conflict <- checkForConflicts inst_envs fam_inst- ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst+ ; ((), no_errs) <- askNoErrs $+ do { checkForConflicts inst_envs fam_inst+ ; checkForInjectivityConflicts inst_envs fam_inst+ ; checkInjectiveEquation fam_inst+ } - ; if no_conflict && injectivity_ok then+ ; if no_errs then return (home_fie', fam_inst : my_fis) else return (home_fie, my_fis) }@@ -702,7 +705,8 @@ environments (one for the EPS and one for the HPT). -} -checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool+-- | Checks to make sure no two family instances overlap.+checkForConflicts :: FamInstEnvs -> FamInst -> TcM () checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst ; traceTc "checkForConflicts" $@@ -710,64 +714,70 @@ , ppr fam_inst -- , ppr inst_envs ]- ; reportConflictInstErr fam_inst conflicts- ; return (null conflicts) }+ ; reportConflictInstErr fam_inst conflicts } +checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM ()+ -- see Note [Verifying injectivity annotation] in FamInstEnv, check 1B1.+checkForInjectivityConflicts instEnvs famInst+ | isTypeFamilyTyCon tycon -- as opposed to data family tycon+ , Injective inj <- tyConInjectivityInfo tycon+ = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in+ reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst))++ | otherwise+ = return ()++ where tycon = famInstTyCon famInst+ -- | Check whether a new open type family equation can be added without -- violating injectivity annotation supplied by the user. Returns True when -- this is possible and False if adding this equation would violate injectivity--- annotation.-checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool-checkForInjectivityConflicts instEnvs famInst+-- annotation. This looks only at the one equation; it does not look for+-- interaction between equations. Use checkForInjectivityConflicts for that.+-- Does checks (2)-(4) of Note [Verifying injectivity annotation] in FamInstEnv.+checkInjectiveEquation :: FamInst -> TcM ()+checkInjectiveEquation famInst | isTypeFamilyTyCon tycon -- type family is injective in at least one argument , Injective inj <- tyConInjectivityInfo tycon = do { dflags <- getDynFlags ; let axiom = coAxiomSingleBranch fi_ax- conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst -- see Note [Verifying injectivity annotation] in FamInstEnv- errs = makeInjectivityErrors dflags fi_ax axiom inj conflicts- ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs- ; return (null errs)+ ; reportInjectivityErrors dflags fi_ax axiom inj } -- if there was no injectivity annotation or tycon does not represent a -- type family we report no conflicts- | otherwise = return True+ | otherwise+ = return ()+ where tycon = famInstTyCon famInst fi_ax = fi_axiom famInst --- | Build a list of injectivity errors together with their source locations.-makeInjectivityErrors+-- | Report a list of injectivity errors together with their source locations.+-- Looks only at one equation; does not look for conflicts *among* equations.+reportInjectivityErrors :: DynFlags -> CoAxiom br -- ^ Type family for which we generate errors -> CoAxBranch -- ^ Currently checked equation (represented by axiom) -> [Bool] -- ^ Injectivity annotation- -> [CoAxBranch] -- ^ List of injectivity conflicts- -> [(SDoc, SrcSpan)]-makeInjectivityErrors dflags fi_ax axiom inj conflicts+ -> TcM ()+reportInjectivityErrors dflags fi_ax axiom inj = ASSERT2( any id inj, text "No injective type variables" )- let lhs = coAxBranchLHS axiom- rhs = coAxBranchRHS axiom- fam_tc = coAxiomTyCon fi_ax- are_conflicts = not $ null conflicts- (unused_inj_tvs, unused_vis, undec_inst_flag)- = unusedInjTvsInRHS dflags fam_tc lhs rhs- inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs- tf_headed = isTFHeaded rhs- bare_variables = bareTvInRHSViolated lhs rhs- wrong_bare_rhs = not $ null bare_variables+ do let lhs = coAxBranchLHS axiom+ rhs = coAxBranchRHS axiom+ fam_tc = coAxiomTyCon fi_ax+ (unused_inj_tvs, unused_vis, undec_inst_flag)+ = unusedInjTvsInRHS dflags fam_tc lhs rhs+ inj_tvs_unused = not $ isEmptyVarSet unused_inj_tvs+ tf_headed = isTFHeaded rhs+ bare_variables = bareTvInRHSViolated lhs rhs+ wrong_bare_rhs = not $ null bare_variables - err_builder herald eqns- = ( hang herald- 2 (vcat (map (pprCoAxBranchUser fam_tc) eqns))- , coAxBranchSpan (head eqns) )- errorIf p f = if p then [f err_builder axiom] else []- in errorIf are_conflicts (conflictInjInstErr conflicts )- ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs- unused_vis undec_inst_flag)- ++ errorIf tf_headed tfHeadedErr- ++ errorIf wrong_bare_rhs (bareVariableInRHSErr bare_variables)+ when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs+ unused_vis undec_inst_flag axiom+ when tf_headed $ reportTfHeadedErr fam_tc axiom+ when wrong_bare_rhs $ reportBareVariableInRHSErr fam_tc bare_variables axiom -- | Is type headed by a type family application? isTFHeaded :: Type -> Bool@@ -871,7 +881,7 @@ 1. We build VarUsages that represent the LHS (rather, the portion of the LHS that is flagged as injective); each usage on the LHS is NotPresent, because we-hvae not yet looked at the RHS.+have not yet looked at the RHS. 2. We also build a VarUsage for the RHS, done by injTyVarUsages. @@ -907,8 +917,8 @@ -> [Type] -- LHS arguments -> Type -- the RHS -> ( TyVarSet- , Bool -- True <=> one or more variable is used invisibly- , Bool) -- True <=> suggest -XUndecidableInstances+ , Bool -- True <=> one or more variable is used invisibly+ , Bool ) -- True <=> suggest -XUndecidableInstances -- See Note [Verifying injectivity annotation] in FamInstEnv. -- This function implements check (4) described there, further -- described in Note [Coverage condition for injective type families].@@ -946,51 +956,42 @@ -- Producing injectivity error messages --------------------------------------- --- | Type of functions that use error message and a list of axioms to build full--- error message (with a source location) for injective type families.-type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan)+-- | Report error message for a pair of equations violating an injectivity+-- annotation. No error message if there are no branches.+reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM ()+reportConflictingInjectivityErrs _ [] _ = return ()+reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn+ = addErrs [buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])]+ where+ herald = text "Type family equation right-hand sides overlap; this violates" $$+ text "the family's injectivity annotation:" --- | Build injecivity error herald common to all injectivity errors.-injectivityErrorHerald :: Bool -> SDoc-injectivityErrorHerald isSingular =- text "Type family equation" <> s isSingular <+> text "violate" <>- s (not isSingular) <+> text "injectivity annotation" <>- if isSingular then dot else colon- -- Above is an ugly hack. We want this: "sentence. herald:" (note the dot and- -- colon). But if herald is empty we want "sentence:" (note the colon). We- -- can't test herald for emptiness so we rely on the fact that herald is empty- -- only when isSingular is False. If herald is non empty it must end with a- -- colon.- where- s False = text "s"- s True = empty+-- | Injectivity error herald common to all injectivity errors.+injectivityErrorHerald :: SDoc+injectivityErrorHerald =+ text "Type family equation violates the family's injectivity annotation." --- | Build error message for a pair of equations violating an injectivity--- annotation.-conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch- -> (SDoc, SrcSpan)-conflictInjInstErr conflictingEqns errorBuilder tyfamEqn- | confEqn : _ <- conflictingEqns- = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn]- | otherwise- = panic "conflictInjInstErr" --- | Build error message for equation with injective type variables unused in+-- | Report error message for equation with injective type variables unused in -- the RHS. Note [Coverage condition for injective type families], step 6-unusedInjectiveVarsErr :: TyVarSet- -> Bool -- True <=> print invisible arguments- -> Bool -- True <=> suggest -XUndecidableInstances- -> InjErrorBuilder -> CoAxBranch- -> (SDoc, SrcSpan)-unusedInjectiveVarsErr tvs has_kinds undec_inst errorBuilder tyfamEqn- = let (doc, loc) = errorBuilder (injectivityErrorHerald True $$ msg)- [tyfamEqn]- in (pprWithExplicitKindsWhen has_kinds doc, loc)+reportUnusedInjectiveVarsErr :: TyCon+ -> TyVarSet+ -> Bool -- True <=> print invisible arguments+ -> Bool -- True <=> suggest -XUndecidableInstances+ -> CoAxBranch+ -> TcM ()+reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn+ = let (loc, doc) = buildInjectivityError fam_tc+ (injectivityErrorHerald $$+ herald $$+ text "In the type family equation:")+ (tyfamEqn :| [])+ in addErrAt loc (pprWithExplicitKindsWhen has_kinds doc) where- doc = sep [ what <+> text "variable" <>+ herald = sep [ what <+> text "variable" <> pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) , text "cannot be inferred from the right-hand side." ]- $$ extra+ $$ extra what | has_kinds = text "Type/kind" | otherwise = text "Type"@@ -998,28 +999,33 @@ extra | undec_inst = text "Using UndecidableInstances might help" | otherwise = empty - msg = doc $$ text "In the type family equation:"---- | Build error message for equation that has a type family call at the top+-- | Report error message for equation that has a type family call at the top -- level of RHS-tfHeadedErr :: InjErrorBuilder -> CoAxBranch- -> (SDoc, SrcSpan)-tfHeadedErr errorBuilder famInst- = errorBuilder (injectivityErrorHerald True $$- text "RHS of injective type family equation cannot" <+>- text "be a type family:") [famInst]+reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM ()+reportTfHeadedErr fam_tc branch+ = addErrs [buildInjectivityError fam_tc+ (injectivityErrorHerald $$+ text "RHS of injective type family equation cannot" <+>+ text "be a type family:")+ (branch :| [])] --- | Build error message for equation that has a bare type variable in the RHS+-- | Report error message for equation that has a bare type variable in the RHS -- but LHS pattern is not a bare type variable.-bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch- -> (SDoc, SrcSpan)-bareVariableInRHSErr tys errorBuilder famInst- = errorBuilder (injectivityErrorHerald True $$+reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM ()+reportBareVariableInRHSErr fam_tc tys branch+ = addErrs [buildInjectivityError fam_tc+ (injectivityErrorHerald $$ text "RHS of injective type family equation is a bare" <+> text "type variable" $$ text "but these LHS type and kind patterns are not bare" <+>- text "variables:" <+> pprQuotedList tys) [famInst]+ text "variables:" <+> pprQuotedList tys)+ (branch :| [])] +buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc)+buildInjectivityError fam_tc herald (eqn1 :| rest_eqns)+ = ( coAxBranchSpan eqn1+ , hang herald+ 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) ) reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () reportConflictInstErr _ []
compiler/typecheck/FunDeps.hs view
@@ -33,6 +33,7 @@ import VarSet import VarEnv import TyCoFVs+import TyCoPpr( pprWithExplicitKindsWhen ) import FV import Outputable import ErrUtils( Validity(..), allValid )
compiler/typecheck/Inst.hs view
@@ -54,6 +54,7 @@ import TcMType import Type import TyCoRep+import TyCoPpr ( debugPprType ) import TcType import HscTypes import Class( Class )
compiler/typecheck/TcAnnotations.hs view
@@ -74,6 +74,6 @@ annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod -annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc+annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc annCtxt ann = hang (text "In the annotation:") 2 (ppr ann)
compiler/typecheck/TcArrows.hs view
@@ -16,7 +16,7 @@ import GHC.Hs import TcMatches-import TcHsSyn( hsPatType )+import TcHsSyn( hsLPatType ) import TcType import TcMType import TcBinds@@ -258,7 +258,7 @@ ; let match' = L mtch_loc (Match { m_ext = noExtField , m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' })- arg_tys = map hsPatType pats'+ arg_tys = map hsLPatType pats' cmd' = HsCmdLam x (MG { mg_alts = L l [match'] , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin })
compiler/typecheck/TcBinds.hs view
@@ -241,7 +241,11 @@ mkMatch :: [ConLike] -> TyCon -> CompleteMatch mkMatch cls ty_con = CompleteMatch {- completeMatchConLikes = map conLikeName cls,+ -- foldM is a left-fold and will have accumulated the ConLikes in+ -- the reverse order. foldrM would accumulate in the correct order,+ -- but would type-check the last ConLike first, which might also be+ -- confusing from the user's perspective. Hence reverse here.+ completeMatchConLikes = reverse (map conLikeName cls), completeMatchTyCon = tyConName ty_con } doOne _ = return Nothing@@ -287,7 +291,10 @@ <+> parens (quotes (ppr tc) <+> text "resp." <+> quotes (ppr tc'))- in mapMaybeM (addLocM doOne) sigs+ -- For some reason I haven't investigated further, the signatures come in+ -- backwards wrt. declaration order. So we reverse them here, because it makes+ -- a difference for incomplete match suggestions.+ in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type@@ -298,7 +305,7 @@ where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where- f (dL->L _ name)+ f (L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds@@ -333,12 +340,12 @@ ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where- ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds]+ ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] - -- I wonder if we should do these one at at time+ -- I wonder if we should do these one at a time -- Consider ?x = 4 -- ?y = ?x + 1- tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr)+ tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ]@@ -498,7 +505,7 @@ tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds recursivePatSynErr ::- OutputableBndrId (GhcPass p) =>+ OutputableBndrId p => SrcSpan -- ^ The location of the first pattern synonym binding -- (for error reporting) -> LHsBinds (GhcPass p)@@ -509,7 +516,7 @@ 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc)- pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)+ pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> pprLoc loc tc_single :: forall thing.@@ -517,7 +524,7 @@ -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTcId, thing) tc_single _top_lvl sig_fn _prag_fn- (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) }))+ (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) ; thing <- setGblEnv tcg_env thing_inside@@ -556,7 +563,7 @@ keyd_binds = bagToList binds `zip` [0::BKey ..] key_map :: NameEnv BKey -- Which binding it comes from- key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds+ key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds , bndr <- collectHsBindBinders bind ] ------------------------@@ -678,8 +685,8 @@ (CompleteSig { sig_bndr = poly_id , sig_ctxt = ctxt , sig_loc = sig_loc })- (dL->L loc (FunBind { fun_id = (dL->L nm_loc name)- , fun_matches = matches }))+ (L loc (FunBind { fun_id = (L nm_loc name)+ , fun_matches = matches })) = setSrcSpan sig_loc $ do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id@@ -696,7 +703,7 @@ tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ tcExtendNameTyVarEnv tv_prs $ setSrcSpan loc $- tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau)+ tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) ; let prag_sigs = lookupPragEnv prag_fn name ; spec_prags <- tcSpecPrags poly_id prag_sigs@@ -704,7 +711,7 @@ ; mod <- getModule ; tick <- funBindTicks nm_loc mono_id mod prag_sigs- ; let bind' = FunBind { fun_id = cL nm_loc mono_id+ ; let bind' = FunBind { fun_id = L nm_loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc@@ -716,13 +723,13 @@ , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } - abs_bind = cL loc $+ abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = skol_tvs , abs_ev_vars = ev_vars , abs_ev_binds = [ev_binds] , abs_exports = [export]- , abs_binds = unitBag (cL loc bind')+ , abs_binds = unitBag (L loc bind') , abs_sig = True } ; return (unitBag abs_bind, [poly_id]) }@@ -733,7 +740,7 @@ funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [Tickish TcId] funBindTicks loc fun_id mod sigs- | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ]+ | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str@@ -799,7 +806,7 @@ ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports- abs_bind = cL loc $+ abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds]@@ -1091,7 +1098,7 @@ {- Note [Partial type signatures and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If /any/ of the signatures in the gropu is a partial type signature+If /any/ of the signatures in the group is a partial type signature f :: _ -> Int then we *always* use the InferGen plan, and hence tcPolyInfer. We do this even for a local binding with -XMonoLocalBinds, when@@ -1242,9 +1249,9 @@ -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen- [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name)- , fun_matches = matches- , fun_ext = fvs })]+ [ L b_loc (FunBind { fun_id = L nm_loc name+ , fun_matches = matches+ , fun_ext = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature@@ -1264,11 +1271,11 @@ -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking- tcMatchesFun (cL nm_loc name) matches exp_ty+ tcMatchesFun (L nm_loc name) matches exp_ty ; mono_id <- newLetBndr no_gen name rhs_ty- ; return (unitBag $ cL b_loc $- FunBind { fun_id = cL nm_loc mono_id,+ ; return (unitBag $ L b_loc $+ FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', fun_ext = fvs, fun_co_fn = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name@@ -1325,7 +1332,7 @@ -- CheckGen is used only for functions with a complete type signature, -- and tcPolyCheck doesn't use tcMonoBinds at all -tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name)+tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name , fun_matches = matches }) | Just (TcIdSig sig) <- sig_fn name = -- There is a type signature.@@ -1413,9 +1420,9 @@ = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))- ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id))+ ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) matches (mkCheckExpType $ idType mono_id)- ; return ( FunBind { fun_id = cL loc mono_id+ ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc@@ -1627,7 +1634,7 @@ = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) <- mapMaybe sig_fn (collectHsBindListBinders lbinds)- , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]+ , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) @@ -1643,7 +1650,7 @@ -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature one_funbind_with_sig- | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds+ | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds , Just (TcIdSig sig) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise@@ -1672,7 +1679,7 @@ fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]- bindFvs (FunBind { fun_id = (dL->L _ f)+ bindFvs (FunBind { fun_id = L _ f , fun_ext = fvs }) = let open_fvs = get_open_fvs fvs in [(f, open_fvs)]@@ -1722,7 +1729,7 @@ -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name-patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)+patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
compiler/typecheck/TcCanonical.hs view
@@ -609,7 +609,7 @@ (forall a. a ~# b) BUT this is an unboxed value! And nothing has prepared us for dictionary "functions" that are unboxed. Actually it does just-about work, but the simplier ends up with stuff like+about work, but the simplifier ends up with stuff like case (/\a. eq_sel d) of df -> ...(df @Int)... and fails to simplify that any further. And it doesn't satisfy isPredTy any more.
compiler/typecheck/TcClassDcl.hs view
@@ -78,7 +78,7 @@ (forall b. Ord b => a -> b -> b) (We could use a record decl, but that means changing more of the existing apparatus.-One step at at time!)+One step at a time!) For classes with just one superclass+method, we use a newtype decl instead:
compiler/typecheck/TcDeriv.hs view
@@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} module TcDeriv ( tcDeriving, DerivInfo(..) ) where@@ -34,6 +35,7 @@ import FamInstEnv import TcHsType import TyCoRep+import TyCoPpr ( pprTyVars ) import RnNames( extendGlobalRdrEnvRn ) import RnBinds@@ -367,7 +369,7 @@ right now, we don't have ThetaTypes for the instances that use deriving clauses (only the standalone-derived ones). -Now we can can collect the type family instances and extend the local instance+Now we can collect the type family instances and extend the local instance environment. At this point, it is safe to run simplifyInstanceContexts on the deriving-clause instance specs, which gives us the ThetaTypes for the deriving-clause instances. Now we can feed all the ThetaTypes to the@@ -383,9 +385,9 @@ Note [Why we don't pass rep_tc into deriveTyData] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into-the rep_tc by means of a lookup. And yet we have the rep_tc right here!-Why look it up again? Answer: it's just easier this way.+Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc+back into the rep_tc by means of a lookup. And yet we have the rep_tc right+here! Why look it up again? Answer: it's just easier this way. We drop some number of arguments from the end of the datatype definition in deriveTyData. The arguments are dropped from the fam_tc. This action may drop a *different* number of arguments@@ -626,16 +628,22 @@ ; (cls_tvs, deriv_ctxt, cls, inst_tys) <- tcExtendTyVarEnv via_tvs $ tcStandaloneDerivInstType ctxt deriv_ty- ; checkTc (not (null inst_tys)) derivingNullaryErr ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat tvs = via_tvs ++ cls_tvs- inst_ty = last inst_tys -- See Note [Unify kinds in deriving] ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <- case mb_deriv_strat of -- Perform an additional unification with the kind of the `via` -- type and the result of the previous kind unification.- Just (ViaStrategy via_ty) -> do+ Just (ViaStrategy via_ty)+ -- This unification must be performed on the last element of+ -- inst_tys, but we have not yet checked for this property.+ -- (This is done later in expectNonNullaryClsArgs). For now,+ -- simply do nothing if inst_tys is empty, since+ -- expectNonNullaryClsArgs will error later if this+ -- is the case.+ | Just inst_ty <- lastMaybe inst_tys+ -> do let via_kind = tcTypeKind via_ty inst_ty_kind = tcTypeKind inst_ty mb_match = tcUnifyTy inst_ty_kind via_kind@@ -667,8 +675,6 @@ , Just (ViaStrategy final_via_ty) ) _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat)- ; let cls_tys' = take (length inst_tys' - 1) inst_tys'- inst_ty' = last inst_tys' ; traceTc "Standalone deriving;" $ vcat [ text "tvs':" <+> ppr tvs' , text "mb_deriv_strat':" <+> ppr mb_deriv_strat'@@ -676,29 +682,13 @@ , text "cls:" <+> ppr cls , text "inst_tys':" <+> ppr inst_tys' ] -- C.f. TcInstDcls.tcLocalInstDecl1- ; traceTc "Standalone deriving:" $ vcat- [ text "class:" <+> ppr cls- , text "class types:" <+> ppr cls_tys'- , text "type:" <+> ppr inst_ty' ] - ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys'- inst_ty' mb_deriv_strat' msg)-- ; case tcSplitTyConApp_maybe inst_ty' of- Just (tc, tc_args)- | className cls == typeableClassName- -> do warnUselessTypeable- return Nothing-- | otherwise- -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)- tvs' cls cls_tys' tc tc_args- deriv_ctxt' mb_deriv_strat'-- _ -> -- Complain about functions, primitive types, etc,- bale_out $- text "The last argument of the instance must be a data or newtype application"- }+ ; if className cls == typeableClassName+ then do warnUselessTypeable+ return Nothing+ else Just <$> mkEqnHelp (fmap unLoc overlap_mode)+ tvs' cls inst_tys'+ deriv_ctxt' mb_deriv_strat' } deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec -- Typecheck the type in a standalone deriving declaration.@@ -853,7 +843,8 @@ ; traceTc "deriveTyData 2" $ vcat [ ppr final_tkvs ] - ; let final_tc_app = mkTyConApp tc final_tc_args+ ; let final_tc_app = mkTyConApp tc final_tc_args+ final_cls_args = final_cls_tys ++ [final_tc_app] ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c) (derivingEtaErr cls final_cls_tys final_tc_app) -- Check that@@ -871,13 +862,11 @@ -- expand any type synonyms. -- See Note [Eta-reducing type synonyms] - ; checkValidInstHead DerivClauseCtxt cls $- final_cls_tys ++ [final_tc_app]+ ; checkValidInstHead DerivClauseCtxt cls final_cls_args -- Check that we aren't deriving an instance of a magical -- type like (~) or Coercible (#14916). - ; spec <- mkEqnHelp Nothing final_tkvs- cls final_cls_tys tc final_tc_args+ ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args (InferContext Nothing) final_mb_deriv_strat ; traceTc "deriveTyData 3" (ppr spec) ; return spec }@@ -1027,7 +1016,7 @@ class Category (cat :: k -> k -> *) where newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category -This case is suprisingly tricky. To see why, let's write out what instance GHC+This case is surprisingly tricky. To see why, let's write out what instance GHC will attempt to derive (using -fprint-explicit-kinds syntax): instance Category k1 (T k2 c) where ...@@ -1153,7 +1142,6 @@ mkEqnHelp :: Maybe OverlapMode -> [TyVar] -> Class -> [Type]- -> TyCon -> [Type] -> DerivContext -- SupplyContext => context supplied (standalone deriving) -- InferContext => context inferred (deriving on data decl, or@@ -1165,35 +1153,106 @@ -- where the 'theta' is optional (that's the Maybe part) -- Assumes that this declaration is well-kinded -mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat- = do { -- Find the instance of a data family- -- Note [Looking up family instances for deriving]- fam_envs <- tcGetFamInstEnvs- ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args- -- If it's still a data family, the lookup failed; i.e no instance exists- ; when (isDataFamilyTyCon rep_tc)- (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))- ; is_boot <- tcIsHsBootOrSig- ; when is_boot $- bale_out (text "Cannot derive instances in hs-boot files"- $+$ text "Write an instance declaration instead")-- ; let deriv_env = DerivEnv- { denv_overlap_mode = overlap_mode+mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do+ is_boot <- tcIsHsBootOrSig+ when is_boot $+ bale_out (text "Cannot derive instances in hs-boot files"+ $+$ text "Write an instance declaration instead")+ runReaderT mk_eqn deriv_env+ where+ deriv_env = DerivEnv { denv_overlap_mode = overlap_mode , denv_tvs = tvs , denv_cls = cls- , denv_cls_tys = cls_tys- , denv_tc = tycon- , denv_tc_args = tc_args- , denv_rep_tc = rep_tc- , denv_rep_tc_args = rep_tc_args+ , denv_inst_tys = cls_args , denv_ctxt = deriv_ctxt , denv_strat = deriv_strat }- ; flip runReaderT deriv_env $- if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }++ bale_out msg = failWithTc $ derivingThingErr False cls cls_args deriv_strat msg++ mk_eqn :: DerivM EarlyDerivSpec+ mk_eqn = do+ DerivEnv { denv_inst_tys = cls_args+ , denv_strat = mb_strat } <- ask+ case mb_strat of+ Just StockStrategy -> do+ (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args+ dit <- expectAlgTyConApp cls_tys inst_ty+ mk_eqn_stock dit++ Just AnyclassStrategy -> mk_eqn_anyclass++ Just (ViaStrategy via_ty) -> do+ (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args+ mk_eqn_via cls_tys inst_ty via_ty++ Just NewtypeStrategy -> do+ (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args+ dit <- expectAlgTyConApp cls_tys inst_ty+ unless (isNewTyCon (dit_rep_tc dit)) $+ derivingThingFailWith False gndNonNewtypeErr+ mkNewTypeEqn True dit++ Nothing -> mk_eqn_no_strategy++-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty.+-- If so, return @(init inst_tys, last inst_tys)@.+-- Otherwise, throw an error message.+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this+-- property is important.+expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)+expectNonNullaryClsArgs inst_tys =+ maybe (derivingThingFailWith False derivingNullaryErr) pure $+ snocView inst_tys++-- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application+-- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting+-- of @cls_tys@ and the constituent pars of @inst_ty@.+-- Otherwise, throw an error message.+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this+-- property is important.+expectAlgTyConApp :: [Type] -- All but the last argument to the class in a+ -- derived instance+ -> Type -- The last argument to the class in a+ -- derived instance+ -> DerivM DerivInstTys+expectAlgTyConApp cls_tys inst_ty = do+ fam_envs <- lift tcGetFamInstEnvs+ case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of+ Nothing -> derivingThingFailWith False $+ text "The last argument of the instance must be a"+ <+> text "data or newtype application"+ Just dit -> do expectNonDataFamTyCon dit+ pure dit++-- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation+-- type constructor for a data family instance, and if not,+-- throws an error message.+-- See @Note [DerivEnv and DerivSpecMechanism]@ in "TcDerivUtils" for why this+-- property is important.+expectNonDataFamTyCon :: DerivInstTys -> DerivM ()+expectNonDataFamTyCon (DerivInstTys { dit_tc = tc+ , dit_tc_args = tc_args+ , dit_rep_tc = rep_tc }) =+ -- If it's still a data family, the lookup failed; i.e no instance exists+ when (isDataFamilyTyCon rep_tc) $+ derivingThingFailWith False $+ text "No family instance for" <+> quotes (pprTypeApp tc tc_args)++mk_deriv_inst_tys_maybe :: FamInstEnvs+ -> [Type] -> Type -> Maybe DerivInstTys+mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty =+ fmap lookup $ tcSplitTyConApp_maybe inst_ty where- bale_out msg = failWithTc (derivingThingErr False cls cls_tys- (mkTyConApp tycon tc_args) deriv_strat msg)+ lookup :: (TyCon, [Type]) -> DerivInstTys+ lookup (tc, tc_args) =+ -- Find the instance of a data family+ -- Note [Looking up family instances for deriving]+ let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args+ in DerivInstTys { dit_cls_tys = cls_tys+ , dit_tc = tc+ , dit_tc_args = tc_args+ , dit_rep_tc = rep_tc+ , dit_rep_tc_args = rep_tc_args } {- Note [Looking up family instances for deriving]@@ -1230,7 +1289,7 @@ instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S -When type familes are involved it's trickier:+When type families are involved it's trickier: data family T a b newtype instance T Int a = MkT [a] deriving( Eq, Monad )@@ -1261,34 +1320,15 @@ ************************************************************************ -} --- | Derive an instance for a data type (i.e., non-newtype).-mkDataTypeEqn :: DerivM EarlyDerivSpec-mkDataTypeEqn- = do mb_strat <- asks denv_strat- case mb_strat of- Just StockStrategy -> mk_eqn_stock- Just AnyclassStrategy -> mk_eqn_anyclass- Just (ViaStrategy ty) -> mk_eqn_via ty- -- GeneralizedNewtypeDeriving makes no sense for non-newtypes- Just NewtypeStrategy -> derivingThingFailWith False gndNonNewtypeErr- -- Lacking a user-requested deriving strategy, we will try to pick- -- between the stock or anyclass strategies- Nothing -> mk_eqn_no_mechanism- -- Once the DerivSpecMechanism is known, we can finally produce an -- EarlyDerivSpec from it. mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec mk_eqn_from_mechanism mechanism = do DerivEnv { denv_overlap_mode = overlap_mode , denv_tvs = tvs- , denv_tc = tc- , denv_tc_args = tc_args- , denv_rep_tc = rep_tc , denv_cls = cls- , denv_cls_tys = cls_tys+ , denv_inst_tys = inst_tys , denv_ctxt = deriv_ctxt } <- ask- let inst_ty = mkTyConApp tc tc_args- inst_tys = cls_tys ++ [inst_ty] doDerivInstErrorChecks1 mechanism loc <- lift getSrcSpanM dfun_name <- lift $ newDFunName cls inst_tys loc@@ -1300,7 +1340,6 @@ { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs' , ds_cls = cls, ds_tys = inst_tys'- , ds_tc = rep_tc , ds_theta = inferred_constraints , ds_overlap = overlap_mode , ds_standalone_wildcard = wildcard@@ -1311,23 +1350,24 @@ { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs , ds_cls = cls, ds_tys = inst_tys- , ds_tc = rep_tc , ds_theta = theta , ds_overlap = overlap_mode , ds_standalone_wildcard = Nothing , ds_mechanism = mechanism } -mk_eqn_stock :: DerivM EarlyDerivSpec-mk_eqn_stock- = do DerivEnv { denv_tc = tc- , denv_rep_tc = rep_tc- , denv_cls = cls- , denv_cls_tys = cls_tys- , denv_ctxt = deriv_ctxt } <- ask+mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class+ -> DerivM EarlyDerivSpec+mk_eqn_stock dit@(DerivInstTys { dit_cls_tys = cls_tys+ , dit_tc = tc+ , dit_rep_tc = rep_tc })+ = do DerivEnv { denv_cls = cls+ , denv_ctxt = deriv_ctxt } <- ask dflags <- getDynFlags case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc of- CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn+ CanDeriveStock gen_fn -> mk_eqn_from_mechanism $+ DerivSpecStock { dsm_stock_dit = dit+ , dsm_stock_gen_fn = gen_fn } StockClassError msg -> derivingThingFailWith False msg _ -> derivingThingFailWith False (nonStdErr cls) @@ -1338,60 +1378,106 @@ IsValid -> mk_eqn_from_mechanism DerivSpecAnyClass NotValid msg -> derivingThingFailWith False msg -mk_eqn_newtype :: Type -- The newtype's representation type+mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class+ -> Type -- The newtype's representation type -> DerivM EarlyDerivSpec-mk_eqn_newtype rep_ty = mk_eqn_from_mechanism (DerivSpecNewtype rep_ty)+mk_eqn_newtype dit rep_ty =+ mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit = dit+ , dsm_newtype_rep_ty = rep_ty } -mk_eqn_via :: Type -- The @via@ type+mk_eqn_via :: [Type] -- All arguments to the class besides the last+ -> Type -- The last argument to the class+ -> Type -- The @via@ type -> DerivM EarlyDerivSpec-mk_eqn_via via_ty = mk_eqn_from_mechanism (DerivSpecVia via_ty)+mk_eqn_via cls_tys inst_ty via_ty =+ mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys+ , dsm_via_inst_ty = inst_ty+ , dsm_via_ty = via_ty } -mk_eqn_no_mechanism :: DerivM EarlyDerivSpec-mk_eqn_no_mechanism- = do DerivEnv { denv_tc = tc- , denv_rep_tc = rep_tc- , denv_cls = cls- , denv_cls_tys = cls_tys- , denv_ctxt = deriv_ctxt } <- ask- dflags <- getDynFlags+-- Derive an instance without a user-requested deriving strategy. This uses+-- heuristics to determine which deriving strategy to use.+-- See Note [Deriving strategies].+mk_eqn_no_strategy :: DerivM EarlyDerivSpec+mk_eqn_no_strategy = do+ DerivEnv { denv_cls = cls+ , denv_inst_tys = cls_args } <- ask+ fam_envs <- lift tcGetFamInstEnvs - -- See Note [Deriving instances for classes themselves]- let dac_error msg- | isClassTyCon rep_tc- = quotes (ppr tc) <+> text "is a type class,"- <+> text "and can only have a derived instance"- $+$ text "if DeriveAnyClass is enabled"- | otherwise- = nonStdErr cls $$ msg+ -- First, check if the last argument is an application of a type constructor.+ -- If not, fall back to DeriveAnyClass.+ if | Just (cls_tys, inst_ty) <- snocView cls_args+ , Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty+ -> if | isNewTyCon (dit_rep_tc dit)+ -- We have a dedicated code path for newtypes (see the+ -- documentation for mkNewTypeEqn as to why this is the case)+ -> mkNewTypeEqn False dit - case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys- tc rep_tc of- -- NB: pass the *representation* tycon to- -- checkOriginativeSideConditions- NonDerivableClass msg -> derivingThingFailWith False (dac_error msg)- StockClassError msg -> derivingThingFailWith False msg- CanDeriveStock gen_fn -> mk_eqn_from_mechanism $ DerivSpecStock gen_fn- CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass+ | otherwise+ -> do -- Otherwise, our only other options are stock or anyclass.+ -- If it is stock, we must confirm that the last argument's+ -- type constructor is algebraic.+ -- See Note [DerivEnv and DerivSpecMechanism] in TcDerivUtils+ whenIsJust (hasStockDeriving cls) $ \_ ->+ expectNonDataFamTyCon dit+ mk_eqn_originative dit + | otherwise+ -> mk_eqn_anyclass+ where+ -- Use heuristics (checkOriginativeSideConditions) to determine whether+ -- stock or anyclass deriving should be used.+ mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec+ mk_eqn_originative dit@(DerivInstTys { dit_cls_tys = cls_tys+ , dit_tc = tc+ , dit_rep_tc = rep_tc }) = do+ DerivEnv { denv_cls = cls+ , denv_ctxt = deriv_ctxt } <- ask+ dflags <- getDynFlags++ -- See Note [Deriving instances for classes themselves]+ let dac_error msg+ | isClassTyCon rep_tc+ = quotes (ppr tc) <+> text "is a type class,"+ <+> text "and can only have a derived instance"+ $+$ text "if DeriveAnyClass is enabled"+ | otherwise+ = nonStdErr cls $$ msg++ case checkOriginativeSideConditions dflags deriv_ctxt cls+ cls_tys tc rep_tc of+ NonDerivableClass msg -> derivingThingFailWith False (dac_error msg)+ StockClassError msg -> derivingThingFailWith False msg+ CanDeriveStock gen_fn -> mk_eqn_from_mechanism $+ DerivSpecStock { dsm_stock_dit = dit+ , dsm_stock_gen_fn = gen_fn }+ CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass+ {- ************************************************************************ * *- GeneralizedNewtypeDeriving and DerivingVia+ Deriving instances for newtypes * * ************************************************************************ -} --- | Derive an instance for a newtype.-mkNewTypeEqn :: DerivM EarlyDerivSpec-mkNewTypeEqn+-- Derive an instance for a newtype. We put this logic into its own function+-- because+--+-- (a) When no explicit deriving strategy is requested, we have special+-- heuristics for newtypes to determine which deriving strategy should+-- actually be used. See Note [Deriving strategies].+-- (b) We make an effort to give error messages specifically tailored to+-- newtypes.+mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@+ -- deriving strategy?+ -> DerivInstTys -> DerivM EarlyDerivSpec+mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys+ , dit_tc = tycon+ , dit_rep_tc = rep_tycon+ , dit_rep_tc_args = rep_tc_args }) -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...- = do DerivEnv { denv_tc = tycon- , denv_rep_tc = rep_tycon- , denv_rep_tc_args = rep_tc_args- , denv_cls = cls- , denv_cls_tys = cls_tys- , denv_ctxt = deriv_ctxt- , denv_strat = mb_strat } <- ask+ = do DerivEnv { denv_cls = cls+ , denv_ctxt = deriv_ctxt } <- ask dflags <- getDynFlags let newtype_deriving = xopt LangExt.GeneralizedNewtypeDeriving dflags@@ -1474,10 +1560,8 @@ eta_msg = text "cannot eta-reduce the representation type enough" MASSERT( cls_tys `lengthIs` (classArity cls - 1) )- case mb_strat of- Just StockStrategy -> mk_eqn_stock- Just AnyclassStrategy -> mk_eqn_anyclass- Just NewtypeStrategy ->+ if newtype_strat+ then -- Since the user explicitly asked for GeneralizedNewtypeDeriving, -- we don't need to perform all of the checks we normally would, -- such as if the class being derived is known to produce ill-roled@@ -1485,20 +1569,15 @@ -- instance and let it error if need be. -- See Note [Determining whether newtype-deriving is appropriate] if eta_ok && newtype_deriving- then mk_eqn_newtype rep_inst_ty+ then mk_eqn_newtype dit rep_inst_ty else bale_out (cant_derive_err $$ if newtype_deriving then empty else suggest_gnd)- Just (ViaStrategy via_ty) ->- -- NB: For DerivingVia, we don't need to any eta-reduction checking,- -- since the @via@ type is already "eta-reduced".- mk_eqn_via via_ty- Nothing- | might_be_newtype_derivable+ else+ if might_be_newtype_derivable && ((newtype_deriving && not deriveAnyClass) || std_class_via_coercible cls)- -> mk_eqn_newtype rep_inst_ty- | otherwise- -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys+ then mk_eqn_newtype dit rep_inst_ty+ else case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tycon rep_tycon of StockClassError msg -- There's a particular corner case where@@ -1511,7 +1590,7 @@ -- and the previous cases won't catch it. This fixes the bug -- reported in #10598. | might_be_newtype_derivable && newtype_deriving- -> mk_eqn_newtype rep_inst_ty+ -> mk_eqn_newtype dit rep_inst_ty -- Otherwise, throw an error for a stock class | might_be_newtype_derivable && not newtype_deriving -> bale_out (msg $$ suggest_gnd)@@ -1546,7 +1625,8 @@ mk_eqn_from_mechanism DerivSpecAnyClass -- CanDeriveStock CanDeriveStock gen_fn -> mk_eqn_from_mechanism $- DerivSpecStock gen_fn+ DerivSpecStock { dsm_stock_dit = dit+ , dsm_stock_gen_fn = gen_fn } {- Note [Recursive newtypes]@@ -1753,25 +1833,19 @@ \end{itemize} -} --- Generate the InstInfo for the required instance paired with the--- *representation* tycon for that instance,+-- Generate the InstInfo for the required instance -- plus any auxiliary bindings required------ Representation tycons differ from the tycon in the instance signature in--- case of instances for indexed families.--- genInst :: DerivSpec theta -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name]) -- We must use continuation-returning style here to get the order in which we -- typecheck family instances and derived instances right. -- See Note [Staging of tcDeriving]-genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon- , ds_mechanism = mechanism, ds_tys = tys- , ds_cls = clas, ds_loc = loc+genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism+ , ds_tys = tys, ds_cls = clas, ds_loc = loc , ds_standalone_wildcard = wildcard }) = do (meth_binds, deriv_stuff, unusedNames) <- set_span_and_ctxt $- genDerivStuff mechanism loc clas rep_tycon tys tvs+ genDerivStuff mechanism loc clas tys tvs let mk_inst_info theta = set_span_and_ctxt $ do inst_spec <- newDerivClsInst theta spec doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism@@ -1809,11 +1883,15 @@ doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM () doDerivInstErrorChecks1 mechanism = case mechanism of- DerivSpecStock{} -> data_cons_in_scope_check- DerivSpecNewtype{} -> do atf_coerce_based_error_checks- data_cons_in_scope_check- DerivSpecAnyClass{} -> pure ()- DerivSpecVia{} -> atf_coerce_based_error_checks+ DerivSpecStock{dsm_stock_dit = dit}+ -> data_cons_in_scope_check dit+ DerivSpecNewtype{dsm_newtype_dit = dit}+ -> do atf_coerce_based_error_checks+ data_cons_in_scope_check dit+ DerivSpecAnyClass{}+ -> pure ()+ DerivSpecVia{}+ -> atf_coerce_based_error_checks where -- When processing a standalone deriving declaration, check that all of the -- constructors for the data type are in scope. For instance:@@ -1827,11 +1905,11 @@ -- Note that the only strategies that require this check are `stock` and -- `newtype`. Neither `anyclass` nor `via` require it as the code that they -- generate does not require using data constructors.- data_cons_in_scope_check :: DerivM ()- data_cons_in_scope_check = do+ data_cons_in_scope_check :: DerivInstTys -> DerivM ()+ data_cons_in_scope_check (DerivInstTys { dit_tc = tc+ , dit_rep_tc = rep_tc }) = do standalone <- isStandaloneDeriv when standalone $ do- DerivEnv { denv_tc = tc, denv_rep_tc = rep_tc } <- ask let bale_out msg = do err <- derivingThingErrMechanism mechanism msg lift $ failWithTc err @@ -1953,15 +2031,18 @@ lift $ failWithTc err genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class- -> TyCon -> [Type] -> [TyVar]+ -> [Type] -> [TyVar] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])-genDerivStuff mechanism loc clas tycon inst_tys tyvars+genDerivStuff mechanism loc clas inst_tys tyvars = case mechanism of -- See Note [Bindings for Generalised Newtype Deriving]- DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty+ DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+ -> gen_newtype_or_via rhs_ty -- Try a stock deriver- DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys+ DerivSpecStock { dsm_stock_dit = DerivInstTys{dit_rep_tc = rep_tc}+ , dsm_stock_gen_fn = gen_fn }+ -> gen_fn loc rep_tc inst_tys -- Try DeriveAnyClass DerivSpecAnyClass -> do@@ -1983,7 +2064,8 @@ , [] ) -- Try DerivingVia- DerivSpecVia via_ty -> gen_newtype_or_via via_ty+ DerivSpecVia{dsm_via_ty = via_ty}+ -> gen_newtype_or_via via_ty where gen_newtype_or_via ty = do (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty@@ -2167,37 +2249,30 @@ nest 2 (text "instance (...) =>" <+> pprClassPred cls (cls_tys ++ [inst_ty]))] -derivingThingErr :: Bool -> Class -> [Type] -> Type+derivingThingErr :: Bool -> Class -> [Type] -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc-derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why- = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat+derivingThingErr newtype_deriving cls cls_args mb_strat why+ = derivingThingErr' newtype_deriving cls cls_args mb_strat (maybe empty derivStrategyName mb_strat) why derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc derivingThingErrM newtype_deriving why- = do DerivEnv { denv_tc = tc- , denv_tc_args = tc_args- , denv_cls = cls- , denv_cls_tys = cls_tys- , denv_strat = mb_strat } <- ask- pure $ derivingThingErr newtype_deriving cls cls_tys- (mkTyConApp tc tc_args) mb_strat why+ = do DerivEnv { denv_cls = cls+ , denv_inst_tys = cls_args+ , denv_strat = mb_strat } <- ask+ pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc derivingThingErrMechanism mechanism why- = do DerivEnv { denv_tc = tc- , denv_tc_args = tc_args- , denv_cls = cls- , denv_cls_tys = cls_tys- , denv_strat = mb_strat } <- ask- pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys- (mkTyConApp tc tc_args) mb_strat- (derivStrategyName $ derivSpecMechanismToStrategy mechanism)- why+ = do DerivEnv { denv_cls = cls+ , denv_inst_tys = cls_args+ , denv_strat = mb_strat } <- ask+ pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_args mb_strat+ (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why -derivingThingErr' :: Bool -> Class -> [Type] -> Type+derivingThingErr' :: Bool -> Class -> [Type] -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc-derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why+derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why = sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred) <+> via_mechanism) $$ nest 2 extra) <> colon,@@ -2207,7 +2282,7 @@ extra | not strat_used, newtype_deriving = text "(even with cunning GeneralizedNewtypeDeriving)" | otherwise = empty- pred = mkClassPred cls (cls_tys ++ [inst_ty])+ pred = mkClassPred cls cls_args via_mechanism | strat_used = text "with the" <+> strat_msg <+> text "strategy" | otherwise
compiler/typecheck/TcDerivInfer.hs view
@@ -36,6 +36,7 @@ import Predicate import TcType import TyCon+import TyCoPpr (pprTyVars) import Type import TcSimplify import TcValidity (validDerivPred)@@ -72,23 +73,26 @@ -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration inferConstraints mechanism- = do { DerivEnv { denv_tvs = tvs- , denv_tc = tc- , denv_tc_args = tc_args- , denv_cls = main_cls- , denv_cls_tys = cls_tys } <- ask+ = do { DerivEnv { denv_tvs = tvs+ , denv_cls = main_cls+ , denv_inst_tys = inst_tys } <- ask ; wildcard <- isStandaloneWildcardDeriv ; let infer_constraints :: DerivM ([ThetaOrigin], [TyVar], [TcType]) infer_constraints = case mechanism of- DerivSpecStock{}- -> inferConstraintsStock+ DerivSpecStock{dsm_stock_dit = dit}+ -> inferConstraintsStock dit DerivSpecAnyClass- -> infer_constraints_simple $ inferConstraintsAnyclass- DerivSpecNewtype rep_ty- -> infer_constraints_simple $ inferConstraintsCoerceBased rep_ty- DerivSpecVia via_ty- -> infer_constraints_simple $ inferConstraintsCoerceBased via_ty+ -> infer_constraints_simple inferConstraintsAnyclass+ DerivSpecNewtype { dsm_newtype_dit =+ DerivInstTys{dit_cls_tys = cls_tys}+ , dsm_newtype_rep_ty = rep_ty }+ -> infer_constraints_simple $+ inferConstraintsCoerceBased cls_tys rep_ty+ DerivSpecVia { dsm_via_cls_tys = cls_tys+ , dsm_via_ty = via_ty }+ -> infer_constraints_simple $+ inferConstraintsCoerceBased cls_tys via_ty -- Most deriving strategies do not need to do anything special to -- the type variables and arguments to the class in the derived@@ -102,9 +106,6 @@ thetas <- infer_thetas pure (thetas, tvs, inst_tys) - inst_ty = mkTyConApp tc tc_args- inst_tys = cls_tys ++ [inst_ty]- -- Constraints arising from superclasses -- See Note [Superclasses of derived instance] cls_tvs = classTyVars main_cls@@ -147,20 +148,19 @@ -- to be well kinded, so we return @[]@/@[Type, f, g]@ for the -- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@. -- See Note [Inferring the instance context].-inferConstraintsStock :: DerivM ([ThetaOrigin], [TyVar], [TcType])-inferConstraintsStock- = do DerivEnv { denv_tvs = tvs- , denv_tc = tc- , denv_tc_args = tc_args- , denv_rep_tc = rep_tc- , denv_rep_tc_args = rep_tc_args- , denv_cls = main_cls- , denv_cls_tys = cls_tys } <- ask+inferConstraintsStock :: DerivInstTys+ -> DerivM ([ThetaOrigin], [TyVar], [TcType])+inferConstraintsStock (DerivInstTys { dit_cls_tys = cls_tys+ , dit_tc = tc+ , dit_tc_args = tc_args+ , dit_rep_tc = rep_tc+ , dit_rep_tc_args = rep_tc_args })+ = do DerivEnv { denv_tvs = tvs+ , denv_cls = main_cls+ , denv_inst_tys = inst_tys } <- ask wildcard <- isStandaloneWildcardDeriv - let inst_ty = mkTyConApp tc tc_args- inst_tys = cls_tys ++ [inst_ty]-+ let inst_ty = mkTyConApp tc tc_args tc_binders = tyConBinders rep_tc choose_level bndr | isNamedTyConBinder bndr = KindLevel@@ -339,16 +339,11 @@ -- derived instance context. inferConstraintsAnyclass :: DerivM [ThetaOrigin] inferConstraintsAnyclass- = do { DerivEnv { denv_tc = tc- , denv_tc_args = tc_args- , denv_cls = cls- , denv_cls_tys = cls_tys } <- ask+ = do { DerivEnv { denv_cls = cls+ , denv_inst_tys = inst_tys } <- ask ; wildcard <- isStandaloneWildcardDeriv - ; let inst_ty = mkTyConApp tc tc_args- inst_tys = cls_tys ++ [inst_ty]-- gen_dms = [ (sel_id, dm_ty)+ ; let gen_dms = [ (sel_id, dm_ty) | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] cls_tvs = classTyVars cls@@ -384,13 +379,12 @@ -- We would infer the following constraints ('ThetaOrigin's): -- -- > (Num Int, Coercible Age Int)-inferConstraintsCoerceBased :: Type -> DerivM [ThetaOrigin]-inferConstraintsCoerceBased rep_ty = do- DerivEnv { denv_tvs = tvs- , denv_tc = tycon- , denv_tc_args = tc_args- , denv_cls = cls- , denv_cls_tys = cls_tys } <- ask+inferConstraintsCoerceBased :: [Type] -> Type+ -> DerivM [ThetaOrigin]+inferConstraintsCoerceBased cls_tys rep_ty = do+ DerivEnv { denv_tvs = tvs+ , denv_cls = cls+ , denv_inst_tys = inst_tys } <- ask sa_wildcard <- isStandaloneWildcardDeriv let -- The following functions are polymorphic over the representation -- type, since we might either give it the underlying type of a@@ -402,8 +396,6 @@ -- rep_pred is the representation dictionary, from where -- we are going to get all the methods for the final -- dictionary- inst_ty = mkTyConApp tycon tc_args- inst_tys = cls_tys ++ [inst_ty] deriv_origin = mkDerivOrigin sa_wildcard -- Next we collect constraints for the class methods@@ -999,7 +991,7 @@ Note [Error reporting for deriving clauses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A suprisingly tricky aspect of deriving to get right is reporting sensible+A surprisingly tricky aspect of deriving to get right is reporting sensible error messages. In particular, if simplifyDeriv reaches a constraint that it cannot solve, which might include:
compiler/typecheck/TcDerivUtils.hs view
@@ -10,7 +10,7 @@ module TcDerivUtils ( DerivM, DerivEnv(..),- DerivSpec(..), pprDerivSpec,+ DerivSpec(..), pprDerivSpec, DerivInstTys(..), DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia, DerivContext(..), OriginativeDerivStatus(..),@@ -49,6 +49,7 @@ import TcType import THNames (liftClassKey) import TyCon+import TyCoPpr (pprSourceTyCon) import Type import Util import VarSet@@ -90,6 +91,7 @@ -- | Contains all of the information known about a derived instance when -- determining what its @EarlyDerivSpec@ should be.+-- See @Note [DerivEnv and DerivSpecMechanism]@. data DerivEnv = DerivEnv { denv_overlap_mode :: Maybe OverlapMode -- ^ Is this an overlapping instance?@@ -97,19 +99,8 @@ -- ^ Universally quantified type variables in the instance , denv_cls :: Class -- ^ Class for which we need to derive an instance- , denv_cls_tys :: [Type]- -- ^ Other arguments to the class except the last- , denv_tc :: TyCon- -- ^ Type constructor for which the instance is requested- -- (last arguments to the type class)- , denv_tc_args :: [Type]- -- ^ Arguments to the type constructor- , denv_rep_tc :: TyCon- -- ^ The representation tycon for 'denv_tc'- -- (for data family instances)- , denv_rep_tc_args :: [Type]- -- ^ The representation types for 'denv_tc_args'- -- (for data family instances)+ , denv_inst_tys :: [Type]+ -- ^ All arguments to to 'denv_cls' in the derived instance. , denv_ctxt :: DerivContext -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the -- context of the instance).@@ -125,22 +116,14 @@ ppr (DerivEnv { denv_overlap_mode = overlap_mode , denv_tvs = tvs , denv_cls = cls- , denv_cls_tys = cls_tys- , denv_tc = tc- , denv_tc_args = tc_args- , denv_rep_tc = rep_tc- , denv_rep_tc_args = rep_tc_args+ , denv_inst_tys = inst_tys , denv_ctxt = ctxt , denv_strat = mb_strat }) = hang (text "DerivEnv") 2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode , text "denv_tvs" <+> ppr tvs , text "denv_cls" <+> ppr cls- , text "denv_cls_tys" <+> ppr cls_tys- , text "denv_tc" <+> ppr tc- , text "denv_tc_args" <+> ppr tc_args- , text "denv_rep_tc" <+> ppr rep_tc- , text "denv_rep_tc_args" <+> ppr rep_tc_args+ , text "denv_inst_tys" <+> ppr inst_tys , text "denv_ctxt" <+> ppr ctxt , text "denv_strat" <+> ppr mb_strat ]) @@ -150,7 +133,6 @@ , ds_theta :: theta , ds_cls :: Class , ds_tys :: [Type]- , ds_tc :: TyCon , ds_overlap :: Maybe OverlapMode , ds_standalone_wildcard :: Maybe SrcSpan -- See Note [Inferring the instance context]@@ -160,10 +142,6 @@ -- df :: forall tvs. theta => C tys -- The Name is the name for the DFun we'll build -- The tyvars bind all the variables in the theta- -- For type families, the tycon in- -- in ds_tys is the *family* tycon- -- in ds_tc is the *representation* type- -- For non-family tycons, both are the same -- the theta is either the given and final theta, in standalone deriving, -- or the not-yet-simplified list of constraints together with their origin@@ -180,7 +158,7 @@ axiom :RTList a = Tree a DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]- , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }+ , ds_mechanism = DerivSpecNewtype (Tree a) } -} pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc@@ -200,41 +178,95 @@ instance Outputable theta => Outputable (DerivSpec theta) where ppr = pprDerivSpec --- What action to take in order to derive a class instance.--- See Note [Deriving strategies] in TcDeriv+-- | Information about the arguments to the class in a stock- or+-- newtype-derived instance.+-- See @Note [DerivEnv and DerivSpecMechanism]@.+data DerivInstTys = DerivInstTys+ { dit_cls_tys :: [Type]+ -- ^ Other arguments to the class except the last+ , dit_tc :: TyCon+ -- ^ Type constructor for which the instance is requested+ -- (last arguments to the type class)+ , dit_tc_args :: [Type]+ -- ^ Arguments to the type constructor+ , dit_rep_tc :: TyCon+ -- ^ The representation tycon for 'dit_tc'+ -- (for data family instances). Otherwise the same as 'dit_tc'.+ , dit_rep_tc_args :: [Type]+ -- ^ The representation types for 'dit_tc_args'+ -- (for data family instances). Otherwise the same as 'dit_tc_args'.+ }++instance Outputable DerivInstTys where+ ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args+ , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })+ = hang (text "DITTyConHead")+ 2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys+ , text "dit_tc" <+> ppr tc+ , text "dit_tc_args" <+> ppr tc_args+ , text "dit_rep_tc" <+> ppr rep_tc+ , text "dit_rep_tc_args" <+> ppr rep_tc_args ])++-- | What action to take in order to derive a class instance.+-- See @Note [DerivEnv and DerivSpecMechanism]@, as well as+-- @Note [Deriving strategies]@ in "TcDeriv". data DerivSpecMechanism- = DerivSpecStock -- "Standard" classes- (SrcSpan -> TyCon- -> [Type]- -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))- -- This function returns three things:+ -- | \"Standard\" classes+ = DerivSpecStock+ { dsm_stock_dit :: DerivInstTys+ -- ^ Information about the arguments to the class in the derived+ -- instance, including what type constructor the last argument is+ -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.+ , dsm_stock_gen_fn ::+ SrcSpan -> TyCon+ -> [Type]+ -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])+ -- ^ This function returns three things: -- -- 1. @LHsBinds GhcPs@: The derived instance's function bindings -- (e.g., @compare (T x) (T y) = compare x y@)+ -- -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived -- instance. As examples, derived 'Generic' instances require -- associated type family instances, and derived 'Eq' and 'Ord' -- instances require top-level @con2tag@ functions.- -- See Note [Auxiliary binders] in TcGenDeriv.+ -- See @Note [Auxiliary binders]@ in "TcGenDeriv".+ -- -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be -- suppressed. This is used to suppress unused warnings for record -- selectors when deriving 'Read', 'Show', or 'Generic'.- -- See Note [Deriving and unused record selectors].+ -- See @Note [Deriving and unused record selectors]@.+ } - | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving- Type -- The newtype rep type+ -- | @GeneralizedNewtypeDeriving@+ | DerivSpecNewtype+ { dsm_newtype_dit :: DerivInstTys+ -- ^ Information about the arguments to the class in the derived+ -- instance, including what type constructor the last argument is+ -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.+ , dsm_newtype_rep_ty :: Type+ -- ^ The newtype rep type.+ } - | DerivSpecAnyClass -- -XDeriveAnyClass+ -- | @DeriveAnyClass@+ | DerivSpecAnyClass - | DerivSpecVia -- -XDerivingVia- Type -- The @via@ type+ -- | @DerivingVia@+ | DerivSpecVia+ { dsm_via_cls_tys :: [Type]+ -- ^ All arguments to the class besides the last one.+ , dsm_via_inst_ty :: Type+ -- ^ The last argument to the class.+ , dsm_via_ty :: Type+ -- ^ The @via@ type+ } -- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc-derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy-derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy-derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy-derivSpecMechanismToStrategy (DerivSpecVia t) = ViaStrategy t+derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy+derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy+derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy+derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia :: DerivSpecMechanism -> Bool@@ -251,11 +283,117 @@ isDerivSpecVia _ = False instance Outputable DerivSpecMechanism where- ppr (DerivSpecStock{}) = text "DerivSpecStock"- ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t- ppr DerivSpecAnyClass = text "DerivSpecAnyClass"- ppr (DerivSpecVia t) = text "DerivSpecVia" <> colon <+> ppr t+ ppr (DerivSpecStock{dsm_stock_dit = dit})+ = hang (text "DerivSpecStock")+ 2 (vcat [ text "dsm_stock_dit" <+> ppr dit ])+ ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty })+ = hang (text "DerivSpecNewtype")+ 2 (vcat [ text "dsm_newtype_dit" <+> ppr dit+ , text "dsm_newtype_rep_ty" <+> ppr rep_ty ])+ ppr DerivSpecAnyClass = text "DerivSpecAnyClass"+ ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty+ , dsm_via_ty = via_ty })+ = hang (text "DerivSpecVia")+ 2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys+ , text "dsm_via_inst_ty" <+> ppr inst_ty+ , text "dsm_via_ty" <+> ppr via_ty ]) +{-+Note [DerivEnv and DerivSpecMechanism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+DerivEnv contains all of the bits and pieces that are common to every+deriving strategy. (See Note [Deriving strategies] in TcDeriv.) Some deriving+strategies impose stricter requirements on the types involved in the derived+instance than others, and these differences are factored out into the+DerivSpecMechanism type. Suppose that the derived instance looks like this:++ instance ... => C arg_1 ... arg_n++Each deriving strategy imposes restrictions on arg_1 through arg_n as follows:++* stock (DerivSpecStock):++ Stock deriving requires that:++ - n must be a positive number. This is checked by+ TcDeriv.expectNonNullaryClsArgs+ - arg_n must be an application of an algebraic type constructor. Here,+ "algebraic type constructor" means:++ + An ordinary data type constructor, or+ + A data family type constructor such that the arguments it is applied to+ give rise to a data family instance.++ This is checked by TcDeriv.expectAlgTyConApp.++ This extra structure is witnessed by the DerivInstTys data type, which stores+ arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor+ (dit_tc), and its arguments (dit_tc_args). If dit_tc is an ordinary data type+ constructor, then dit_rep_tc/dit_rep_tc_args are the same as+ dit_tc/dit_tc_args. If dit_tc is a data family type constructor, then+ dit_rep_tc is the representation type constructor for the data family+ instance, and dit_rep_tc_args are the arguments to the representation type+ constructor in the corresponding instance.++* newtype (DerivSpecNewtype):++ Newtype deriving imposes the same DerivInstTys requirements as stock+ deriving. This is necessary because we need to know what the underlying type+ that the newtype wraps is, and this information can only be learned by+ knowing dit_rep_tc.++* anyclass (DerivSpecAnyclass):++ DeriveAnyClass is the most permissive deriving strategy of all, as it+ essentially imposes no requirements on the derived instance. This is because+ DeriveAnyClass simply derives an empty instance, so it does not need any+ particular knowledge about the types involved. It can do several things+ that stock/newtype deriving cannot do (#13154):++ - n can be 0. That is, one is allowed to anyclass-derive an instance with+ no arguments to the class, such as in this example:++ class C+ deriving anyclass instance C++ - One can derive an instance for a type that is not headed by a type+ constructor, such as in the following example:++ class C (n :: Nat)+ deriving instance C 0+ deriving instance C 1+ ...++ - One can derive an instance for a data family with no data family instances,+ such as in the following example:++ data family Foo a+ class C a+ deriving anyclass instance C (Foo a)++* via (DerivSpecVia):++ Like newtype deriving, DerivingVia requires that n must be a positive number.+ This is because when one derives something like this:++ deriving via Foo instance C Bar++ Then the generated code must specifically mention Bar. However, in+ contrast with newtype deriving, DerivingVia does *not* require Bar to be+ an application of an algebraic type constructor. This is because the+ generated code simply defers to invoking `coerce`, which does not need to+ know anything in particular about Bar (besides that it is representationally+ equal to Foo). This allows DerivingVia to do some things that are not+ possible with newtype deriving, such as deriving instances for data families+ without data instances (#13154):++ data family Foo a+ newtype ByBar a = ByBar a+ class Baz a where ...+ instance Baz (ByBar a) where ...+ deriving via ByBar (Foo a) instance Baz (Foo a)+-}+ -- | Whether GHC is processing a @deriving@ clause or a standalone deriving -- declaration. data DerivContext@@ -920,12 +1058,9 @@ This is not restricted to Generics; any class can be derived, simply giving rise to an empty instance. -Unfortunately, it is not clear how to determine the context (when using a-deriving clause; in standalone deriving, the user provides the context).-GHC uses the same heuristic for figuring out the class context that it uses for-Eq in the case of *-kinded classes, and for Functor in the case of-* -> *-kinded classes. That may not be optimal or even wrong. But in such-cases, standalone deriving can still be used.+See Note [Gathering and simplifying constraints for DeriveAnyClass] in+TcDerivInfer for an explanation hof how the instance context is inferred for+DeriveAnyClass. Note [Check that the type variable is truly universal] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/TcEnv.hs view
@@ -509,7 +509,7 @@ tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a -- Used for binding the recurive uses of Ids in a binding--- both top-level value bindings and and nested let/where-bindings+-- both top-level value bindings and nested let/where-bindings -- Does not extend the TcBinderStack tcExtendRecIds pairs thing_inside = tc_extend_local_env NotTopLevel@@ -533,7 +533,7 @@ tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed -> [TcId] -> TcM a -> TcM a--- Used for both top-level value bindings and and nested let/where-bindings+-- Used for both top-level value bindings and nested let/where-bindings -- Adds to the TcBinderStack too tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) ids thing_inside@@ -942,11 +942,11 @@ -- Used only to improve error messages } -instance (OutputableBndrId (GhcPass a))+instance (OutputableBndrId a) => Outputable (InstInfo (GhcPass a)) where ppr = pprInstInfoDetails -pprInstInfoDetails :: (OutputableBndrId (GhcPass a))+pprInstInfoDetails :: (OutputableBndrId a) => InstInfo (GhcPass a) -> SDoc pprInstInfoDetails info = hang (pprInstanceHdr (iSpec info) <+> text "where")
compiler/typecheck/TcErrors.hs view
@@ -25,6 +25,7 @@ import RnUnbound ( unknownNameSuggestions ) import Type import TyCoRep+import TyCoPpr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE ) import Unify ( tcMatchTys ) import Module import FamInst@@ -2358,7 +2359,7 @@ mb_patsyn_prov :: Maybe SDoc mb_patsyn_prov | not lead_with_ambig- , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig+ , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig = Just (vcat [ text "In other words, a successful match on the pattern" , nest 2 $ ppr pat , text "does not provide the constraint" <+> pprParendType pred ])@@ -2487,7 +2488,7 @@ discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens]- | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig+ | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig = filterOut (discard name) givens | otherwise = givens
compiler/typecheck/TcExpr.hs view
@@ -58,13 +58,13 @@ import RdrName import TyCon import TyCoRep+import TyCoPpr import TyCoSubst (substTyWithInScope) import Type import TcEvidence import VarSet-import MkId( seqId ) import TysWiredIn-import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )+import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames import DynFlags@@ -181,17 +181,15 @@ tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar x expr') } -tcExpr (HsSCC x src lbl expr) res_ty- = do { expr' <- tcMonoExpr expr res_ty- ; return (HsSCC x src lbl expr') }--tcExpr (HsTickPragma x src info srcInfo expr) res_ty+tcExpr (HsPragE x prag expr) res_ty = do { expr' <- tcMonoExpr expr res_ty- ; return (HsTickPragma x src info srcInfo expr') }--tcExpr (HsCoreAnn x src lbl expr) res_ty- = do { expr' <- tcMonoExpr expr res_ty- ; return (HsCoreAnn x src lbl expr') }+ ; return (HsPragE x (tc_prag prag) expr') }+ where+ tc_prag :: HsPragE GhcRn -> HsPragE GhcTc+ tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann+ tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl+ tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo+ tc_prag (XHsPragE x) = noExtCon x tcExpr (HsOverLit x lit) res_ty = do { lit' <- newOverloadedLit lit res_ty@@ -334,40 +332,10 @@ * Decompose it; should be of form (arg2_ty -> res_ty), where arg2_ty might be a polytype * Use arg2_ty to typecheck arg2--Note [Typing rule for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to allow- x `seq` (# p,q #)-which suggests this type for seq:- seq :: forall (a:*) (b:Open). a -> b -> b,-with (b:Open) meaning that be can be instantiated with an unboxed-tuple. The trouble is that this might accept a partially-applied-'seq', and I'm just not certain that would work. I'm only sure it's-only going to work when it's fully applied, so it turns into- case x of _ -> (# p,q #)--So it seems more uniform to treat 'seq' as if it was a language-construct.--See also Note [seqId magic] in MkId -} tcExpr expr@(OpApp fix arg1 op arg2) res_ty | (L loc (HsVar _ (L lv op_name))) <- op- , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]- = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind- ; let arg2_exp_ty = res_ty- ; arg1' <- tcArg op arg1 arg1_ty 1- ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $- tc_poly_expr_nc arg2 arg2_exp_ty- ; arg2_ty <- readExpType arg2_exp_ty- ; op_id <- tcLookupId op_name- ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])- (HsVar noExtField (L lv op_id)))- ; return $ OpApp fix arg1' op' arg2' }-- | (L loc (HsVar _ (L lv op_name))) <- op , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferSigma arg1@@ -1160,26 +1128,11 @@ ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl) ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty } -tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty+tcApp _m_herald (L loc (HsVar _ (L _ fun_id))) args res_ty -- Special typing rule for tagToEnum# | fun_id `hasKey` tagToEnumKey , n_val_args == 1 = tcTagToEnum loc fun_id args res_ty-- -- Special typing rule for 'seq'- -- In the saturated case, behave as if seq had type- -- forall a (b::TYPE r). a -> b -> b- -- for some type r. See Note [Typing rule for seq]- | fun_id `hasKey` seqIdKey- , n_val_args == 2- = do { rep <- newFlexiTyVarTy runtimeRepTy- ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep]- seq_ty = mkSpecForAllTys [alpha,beta]- (mkTyVarTy alpha `mkVisFunTy` mkTyVarTy beta `mkVisFunTy` mkTyVarTy beta)- seq_fun = L loc (HsVar noExtField (L loc seqId))- -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b- -- where 'r' is a meta type variable- ; tcFunApp m_herald fun seq_fun seq_ty args res_ty } where n_val_args = count isHsValArg args @@ -2530,7 +2483,7 @@ exprCtxt :: LHsExpr GhcRn -> SDoc exprCtxt expr- = hang (text "In the expression:") 2 (ppr expr)+ = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name
compiler/typecheck/TcFlatten.hs view
@@ -13,6 +13,7 @@ import GhcPrelude import TcRnTypes+import TyCoPpr ( pprTyVar ) import Constraint import Predicate import TcType@@ -713,7 +714,7 @@ Bottom line: FM_Avoid is unused for now (Nov 14). Note: T5321Fun got faster when I disabled FM_Avoid- T5837 did too, but it's pathalogical anyway+ T5837 did too, but it's pathological anyway Note [Phantoms in the flattener] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1707,7 +1708,7 @@ inert fsk ~ ((fsk3, TF Int), TF Int) Because the incoming given rewrites all the inert givens, we get more and-more duplication in the inert set. But this really only happens in pathalogical+more duplication in the inert set. But this really only happens in pathological casee, so we don't care.
compiler/typecheck/TcGenDeriv.hs view
@@ -358,11 +358,11 @@ = emptyBag negate_expr = nlHsApp (nlHsVar not_RDR)- lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $+ lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)- gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $+ gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr- gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $+ gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) get_tag con = dataConTag con - fIRST_TAG@@ -381,7 +381,7 @@ mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs -- Returns a binding op a b = ... compares a and b according to op ....- mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]+ mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs dflags op) mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs@@ -597,7 +597,7 @@ occ_nm = getOccString tycon succ_enum dflags- = mk_easy_FunBind loc succ_RDR [a_Pat] $+ = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), nlHsVarApps intDataCon_RDR [ah_RDR]])@@ -607,7 +607,7 @@ nlHsIntLit 1])) pred_enum dflags- = mk_easy_FunBind loc pred_RDR [a_Pat] $+ = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]])@@ -619,7 +619,7 @@ (mkIntegralLit (-1 :: Int)))])) to_enum dflags- = mk_easy_FunBind loc toEnum_RDR [a_Pat] $+ = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [ nlHsVar a_RDR@@ -628,7 +628,7 @@ (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) enum_from dflags- = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $+ = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR dflags tycon),@@ -637,7 +637,7 @@ (nlHsVar (maxtag_RDR dflags tycon)))] enum_from_then dflags- = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $+ = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ nlHsPar (enum_from_then_to_Expr@@ -650,7 +650,7 @@ )) from_enum dflags- = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $+ = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) @@ -766,7 +766,7 @@ ] enum_range dflags- = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $+ = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $@@ -775,7 +775,7 @@ (nlHsVarApps intDataCon_RDR [bh_RDR])) enum_index dflags- = mk_easy_FunBind loc unsafeIndex_RDR+ = mkSimpleGeneratedFunBind loc unsafeIndex_RDR [noLoc (AsPat noExtField (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] (@@ -792,7 +792,7 @@ -- This produces something like `(ch >= ah) && (ch <= bh)` enum_inRange dflags- = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $+ = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( untag_Expr dflags tycon [(c_RDR, ch_RDR)] (@@ -825,7 +825,7 @@ -------------------------------------------------------------- single_con_range- = mk_easy_FunBind loc range_RDR+ = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ noLoc (mkHsComp ListComp stmts con_expr) where@@ -837,7 +837,7 @@ ---------------- single_con_index- = mk_easy_FunBind loc unsafeIndex_RDR+ = mkSimpleGeneratedFunBind loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] -- We need to reverse the order we consider the components in@@ -863,7 +863,7 @@ ------------------ single_con_inRange- = mk_easy_FunBind loc inRange_RDR+ = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] $ if con_arity == 0@@ -1380,7 +1380,7 @@ mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ gunfold- gunfold_bind = mk_easy_FunBind loc+ gunfold_bind = mkSimpleGeneratedFunBind loc gunfold_RDR [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] gunfold_rhs@@ -1409,7 +1409,7 @@ to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) ------------ dataTypeOf- dataTypeOf_bind = mk_easy_FunBind+ dataTypeOf_bind = mkSimpleGeneratedFunBind loc dataTypeOf_RDR [nlWildPat]@@ -1436,7 +1436,7 @@ | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR | otherwise = emptyBag mk_gcast dataCast_RDR gcast_RDR- = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]+ = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) @@ -2019,7 +2019,7 @@ mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches- = L loc (mkFunBind fun matches)+ = L loc (mkFunBind Generated fun matches) -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last@@ -2047,7 +2047,7 @@ -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindEC arity catch_all- fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')+ fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {}@@ -2071,7 +2071,7 @@ mkRdrFunBindSE :: Arity -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity- fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')+ fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare"
compiler/typecheck/TcHoleErrors.hs view
@@ -980,7 +980,7 @@ ; traceTc "w_givens are: " $ ppr w_givens ; rem <- runTcSDeriveds $ simpl_top w_givens -- We don't want any insoluble or simple constraints left, but- -- solved implications are ok (and neccessary for e.g. undefined)+ -- solved implications are ok (and necessary for e.g. undefined) ; traceTc "rems was:" $ ppr rem ; traceTc "}" empty ; return (isSolvedWC rem, wrp) } }
compiler/typecheck/TcHsSyn.hs view
@@ -16,7 +16,7 @@ module TcHsSyn ( -- * Extracting types from HsSyn- hsLitType, hsPatType,+ hsLitType, hsPatType, hsLPatType, -- * Other HsSyn functions mkHsDictLet, mkHsApp,@@ -59,6 +59,7 @@ import TcMType import TcEnv ( tcLookupGlobalOnly ) import TcEvidence+import TyCoPpr ( pprTyVar ) import TysPrim import TyCon import TysWiredIn@@ -97,12 +98,15 @@ -} +hsLPatType :: LPat GhcTc -> Type+hsLPatType (L _ p) = hsPatType p+ hsPatType :: Pat GhcTc -> Type-hsPatType (ParPat _ pat) = hsPatType pat+hsPatType (ParPat _ pat) = hsLPatType pat hsPatType (WildPat ty) = ty hsPatType (VarPat _ lvar) = idType (unLoc lvar)-hsPatType (BangPat _ pat) = hsPatType pat-hsPatType (LazyPat _ pat) = hsPatType pat+hsPatType (BangPat _ pat) = hsLPatType pat+hsPatType (LazyPat _ pat) = hsLPatType pat hsPatType (LitPat _ lit) = hsLitType lit hsPatType (AsPat _ var _) = idType (unLoc var) hsPatType (ViewPat ty _ _) = ty@@ -118,8 +122,7 @@ hsPatType (NPat ty _ _ _) = ty hsPatType (NPlusKPat ty _ _ _ _ _) = ty hsPatType (CoPat _ _ _ ty) = ty--- XPat wraps a Located (Pat GhcTc) in GhcTc-hsPatType (XPat lpat) = hsPatType (unLoc lpat)+hsPatType (XPat n) = noExtCon n hsPatType ConPatIn{} = panic "hsPatType: ConPatIn" hsPatType SplicePat{} = panic "hsPatType: SplicePat" @@ -262,7 +265,7 @@ So we default it to 'Any' of the right kind. All this works for both type and kind variables (indeed- the two are the same thign).+ the two are the same thing). * SkolemiseFlexi: is a special case for the LHS of RULES. See Note [Zonking the LHS of a RULE]@@ -346,7 +349,7 @@ -- immediately by creating a TypeEnv zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id-zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env)+zonkLIdOcc env = mapLoc (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt;@@ -526,7 +529,7 @@ new_binds <- mapM (wrapLocM zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env- [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds]+ [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where@@ -574,13 +577,13 @@ , var_rhs = new_expr , var_inline = inl }) } -zonk_bind env bind@(FunBind { fun_id = (dL->L loc var)+zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = ms , fun_co_fn = co_fn }) = do { new_var <- zonkIdBndr env var ; (env1, new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env1 zonkLExpr ms- ; return (bind { fun_id = cL loc new_var+ ; return (bind { fun_id = L loc new_var , fun_matches = new_ms , fun_co_fn = new_co_fn }) } @@ -607,16 +610,16 @@ where zonk_val_bind env lbind | has_sig- , (dL->L loc bind@(FunBind { fun_id = (dL->L mloc mono_id)- , fun_matches = ms- , fun_co_fn = co_fn })) <- lbind+ , (L loc bind@(FunBind { fun_id = L mloc mono_id+ , fun_matches = ms+ , fun_co_fn = co_fn })) <- lbind = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env' zonkLExpr ms- ; return $ cL loc $- bind { fun_id = cL mloc new_mono_id+ ; return $ L loc $+ bind { fun_id = L mloc new_mono_id , fun_matches = new_ms , fun_co_fn = new_co_fn } } | otherwise@@ -637,7 +640,7 @@ , abe_prags = new_prags }) zonk_export _ (XABExport nec) = noExtCon nec -zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id)+zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id , psb_args = details , psb_def = lpat , psb_dir = dir }))@@ -646,7 +649,7 @@ ; let details' = zonkPatSynDetails env1 details ; (_env2, dir') <- zonkPatSynDir env1 dir ; return $ PatSynBind x $- bind { psb_id = cL loc id'+ bind { psb_id = L loc id' , psb_args = details' , psb_def = lpat' , psb_dir = dir' } }@@ -681,9 +684,9 @@ zonkLTcSpecPrags env ps = mapM zonk_prag ps where- zonk_prag (dL->L loc (SpecPrag id co_fn inl))+ zonk_prag (L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn- ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }+ ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } {- ************************************************************************@@ -697,13 +700,13 @@ -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> MatchGroup GhcTcId (Located (body GhcTcId)) -> TcM (MatchGroup GhcTc (Located (body GhcTc)))-zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms)+zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty- ; return (MG { mg_alts = cL l ms'+ ; return (MG { mg_alts = L l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec@@ -712,14 +715,12 @@ -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> LMatch GhcTcId (Located (body GhcTcId)) -> TcM (LMatch GhcTc (Located (body GhcTc)))-zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats- , m_grhss = grhss }))+zonkMatch env zBody (L loc match@(Match { m_pats = pats+ , m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss- ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }-zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec-zonkMatch _ _ _ = panic "zonkMatch: Impossible Match"- -- due to #15884+ ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }+zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv@@ -727,7 +728,7 @@ -> GRHSs GhcTcId (Located (body GhcTcId)) -> TcM (GRHSs GhcTc (Located (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do+zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS xx guarded rhs)@@ -736,7 +737,7 @@ return (GRHS xx new_guarded new_rhs) zonk_grhs (XGRHS nec) = noExtCon nec new_grhss <- mapM (wrapLocM zonk_grhs) grhss- return (GRHSs x new_grhss (cL l new_binds))+ return (GRHSs x new_grhss (L l new_binds)) zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec {-@@ -754,9 +755,9 @@ zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar x (dL->L l id))+zonkExpr env (HsVar x (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id )- return (HsVar x (cL l (zonkIdOcc env id)))+ return (HsVar x (L l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e @@ -839,13 +840,11 @@ = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } where- zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e- ; return (cL l (Present x e')) }- zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t- ; return (cL l (Missing t')) }- zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec- zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match"- -- due to #15884+ zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e+ ; return (L l (Present x e')) }+ zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t+ ; return (L l (Missing t')) }+ zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec zonkExpr env (ExplicitSum args alt arity expr)@@ -881,15 +880,15 @@ ; return $ GRHS x guard' expr' } zonk_alt (XGRHS nec) = noExtCon nec -zonkExpr env (HsLet x (dL->L l binds) expr)+zonkExpr env (HsLet x (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr- return (HsLet x (cL l new_binds) new_expr)+ return (HsLet x (L l new_binds) new_expr) -zonkExpr env (HsDo ty do_or_lc (dL->L l stmts))+zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToTypeX env ty- return (HsDo new_ty do_or_lc (cL l new_stmts))+ return (HsDo new_ty do_or_lc (L l new_stmts)) zonkExpr env (ExplicitList ty wit exprs) = do (env1, new_wit) <- zonkWit env wit@@ -933,18 +932,9 @@ where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln -zonkExpr env (HsSCC x src lbl expr)- = do new_expr <- zonkLExpr env expr- return (HsSCC x src lbl new_expr)--zonkExpr env (HsTickPragma x src info srcInfo expr)- = do new_expr <- zonkLExpr env expr- return (HsTickPragma x src info srcInfo new_expr)---- hdaume: core annotations-zonkExpr env (HsCoreAnn x src lbl expr)+zonkExpr env (HsPragE x prag expr) = do new_expr <- zonkLExpr env expr- return (HsCoreAnn x src lbl new_expr)+ return (HsPragE x prag new_expr) -- arrow notation extensions zonkExpr env (HsProc x pat body)@@ -1050,15 +1040,15 @@ zonkWit env Nothing = return (env, Nothing) zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w -zonkCmd env (HsCmdLet x (dL->L l binds) cmd)+zonkCmd env (HsCmdLet x (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd- return (HsCmdLet x (cL l new_binds) new_cmd)+ return (HsCmdLet x (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo ty (dL->L l stmts))+zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToTypeX env ty- return (HsCmdDo new_ty (cL l new_stmts))+ return (HsCmdDo new_ty (L l new_stmts)) zonkCmd _ (XCmd nec) = noExtCon nec @@ -1241,9 +1231,9 @@ newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (dL->L l binds))+zonkStmt env _ (LetStmt x (L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds- return (env1, LetStmt x (cL l new_binds))+ return (env1, LetStmt x (L l new_binds)) zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op@@ -1260,17 +1250,18 @@ = do { (env1, new_mb_join) <- zonk_join env mb_join ; (env2, new_args) <- zonk_args env1 args ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty- ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }+ ; return ( env2+ , ApplicativeStmt new_body_ty new_args new_mb_join) } where zonk_join env Nothing = return (env, Nothing) zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - get_pat (_, ApplicativeArgOne _ pat _ _) = pat+ get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat get_pat (_, ApplicativeArgMany _ _ _ pat) = pat get_pat (_, XApplicativeArg nec) = noExtCon nec - replace_pat pat (op, ApplicativeArgOne x _ a isBody)- = (op, ApplicativeArgOne x pat a isBody)+ replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op)+ = (op, ApplicativeArgOne x pat a isBody fail_op) replace_pat pat (op, ApplicativeArgMany x a b _) = (op, ApplicativeArgMany x a b pat) replace_pat _ (_, XApplicativeArg nec) = noExtCon nec@@ -1290,9 +1281,10 @@ ; return (env2, (new_op, new_arg) : new_args) } zonk_args_rev env [] = return (env, []) - zonk_arg env (ApplicativeArgOne x pat expr isBody)+ zonk_arg env (ApplicativeArgOne x pat expr isBody fail_op) = do { new_expr <- zonkLExpr env expr- ; return (ApplicativeArgOne x pat new_expr isBody) }+ ; (_, new_fail) <- zonkSyntaxExpr env fail_op+ ; return (ApplicativeArgOne x pat new_expr isBody new_fail) } zonk_arg env (ApplicativeArgMany x stmts ret pat) = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_ret <- zonkExpr env1 ret@@ -1307,21 +1299,21 @@ = do { flds' <- mapM zonk_rbind flds ; return (HsRecFields flds' dd) } where- zonk_rbind (dL->L l fld)+ zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld)- ; return (cL l (fld { hsRecFieldLbl = new_id+ ; return (L l (fld { hsRecFieldLbl = new_id , hsRecFieldArg = new_expr })) } zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] -> TcM [LHsRecUpdField GhcTcId] zonkRecUpdFields env = mapM zonk_rbind where- zonk_rbind (dL->L l fld)+ zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld)- ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id- , hsRecFieldArg = new_expr })) }+ ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id+ , hsRecFieldArg = new_expr })) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a@@ -1355,9 +1347,9 @@ (text "In a wildcard pattern") ; return (env, WildPat ty') } -zonk_pat env (VarPat x (dL->L l v))+zonk_pat env (VarPat x (L l v)) = do { v' <- zonkIdBndr env v- ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) }+ ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) } zonk_pat env (LazyPat x pat) = do { (env', pat') <- zonkPat env pat@@ -1367,10 +1359,10 @@ = do { (env', pat') <- zonkPat env pat ; return (env', BangPat x pat') } -zonk_pat env (AsPat x (dL->L loc v) pat)+zonk_pat env (AsPat x (L loc v) pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat- ; return (env', AsPat x (cL loc v') pat') }+ ; return (env', AsPat x (L loc v') pat') } zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr@@ -1406,7 +1398,7 @@ , pat_binds = binds , pat_args = args , pat_wrap = wrapper- , pat_con = (dL->L _ con) })+ , pat_con = L _ con }) = ASSERT( all isImmutableTyVar tyvars ) do { new_tys <- mapM (zonkTcTypeToTypeX env) tys @@ -1442,7 +1434,7 @@ ; (env', pat') <- zonkPat env pat ; return (env', SigPat ty' pat' hs_ty) } -zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr)+zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr ; (env2, mb_neg') <- case mb_neg of Nothing -> return (env1, Nothing)@@ -1450,9 +1442,9 @@ ; lit' <- zonkOverLit env2 lit ; ty' <- zonkTcTypeToTypeX env2 ty- ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') }+ ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } -zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2)+zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) = do { (env1, e1') <- zonkSyntaxExpr env e1 ; (env2, e2') <- zonkSyntaxExpr env1 e2 ; n' <- zonkIdBndr env2 n@@ -1460,7 +1452,7 @@ ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToTypeX env2 ty ; return (extendIdZonkEnv1 env2 n',- NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') }+ NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } zonk_pat env (CoPat x co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn@@ -1486,8 +1478,8 @@ zonkConStuff env (RecCon (HsRecFields rpats dd)) = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)- ; let rpats' = zipWith (\(dL->L l rp) p' ->- cL l (rp { hsRecFieldArg = p' }))+ ; let rpats' = zipWith (\(L l rp) p' ->+ L l (rp { hsRecFieldArg = p' })) rpats pats' ; return (env', RecCon (HsRecFields rpats' dd)) } -- Field selectors have declared types; hence no zonking@@ -1539,13 +1531,11 @@ , rd_lhs = new_lhs , rd_rhs = new_rhs } } where- zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v)))+ zonk_tm_bndr env (L l (RuleBndr x (L loc v))) = do { (env', v') <- zonk_it env v- ; return (env', cL l (RuleBndr x (cL loc v'))) }- zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"- zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec- zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match"- -- due to #15884+ ; return (env', L l (RuleBndr x (L loc v'))) }+ zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"+ zonk_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec zonk_it env v | isId v = do { v' <- zonkIdBndr env v
compiler/typecheck/TcHsType.hs view
@@ -83,6 +83,7 @@ import TcSimplify import TcHsSyn import TyCoRep+import TyCoPpr import TcErrors ( reportAllUnsolved ) import TcType import Inst ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )@@ -351,10 +352,10 @@ tcDerivStrategy mb_lds = case mb_lds of Nothing -> boring_case Nothing- Just (dL->L loc ds) ->+ Just (L loc ds) -> setSrcSpan loc $ do (ds', tvs) <- tc_deriv_strategy ds- pure (Just (cL loc ds'), tvs)+ pure (Just (L loc ds'), tvs) where tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar])@@ -1322,7 +1323,7 @@ -- Precondition for (saturateFamApp ty kind): -- tcTypeKind ty = kind ----- If 'ty' is an unsaturated family application wtih trailing+-- If 'ty' is an unsaturated family application with trailing -- invisible arguments, instanttiate them. -- See Note [saturateFamApp] @@ -1558,7 +1559,7 @@ Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's better to reject in checkValidType. If we say that the body kind should be '*' we risk getting TWO error messages, one saying that Eq-[a] doens't have kind '*', and one saying that we need a Constraint to+[a] doesn't have kind '*', and one saying that we need a Constraint to the left of the outer (=>). How do we figure out the right body kind? Well, it's a bit of a
compiler/typecheck/TcInstDcls.hs view
@@ -2133,7 +2133,7 @@ ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where- spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)+ spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) tcSpecInst _ _ = panic "tcSpecInst"
compiler/typecheck/TcInteract.hs view
@@ -604,7 +604,7 @@ and can be reported as redundant. See Note [Tracking redundant constraints] in TcSimplify. - It transpires that using the outermost one is reponsible for an+ It transpires that using the outermost one is responsible for an 8% performance improvement in nofib cryptarithm2, compared to just rolling the dice. I didn't investigate why. @@ -1582,7 +1582,7 @@ keep_deriv ev_i | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] , (Wanted WDeriv, _) <- fr -- work item is [WD]- = True -- Keep a derived verison of the work item+ = True -- Keep a derived version of the work item | otherwise = False -- Work item is fully discharged
compiler/typecheck/TcMType.hs view
@@ -94,6 +94,7 @@ import GhcPrelude import TyCoRep+import TyCoPpr import TcType import Type import TyCon@@ -1789,7 +1790,7 @@ reverse :: forall a. [a] -> [a] So we know that the argument `f xs` must be a "list of something". But what is the "something"? We don't know until we explore the `f xs` a bit more. So we set-out what we do know at the call of `reverse` by instantiate its type with a fresh+out what we do know at the call of `reverse` by instantiating its type with a fresh meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the result, is `[alpha]`. The unification variable `alpha` stands for the as-yet-unknown type of the elements of the list.
compiler/typecheck/TcMatches.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-} module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,@@ -991,7 +992,7 @@ -- Typecheck each ApplicativeArg separately -- See Note [ApplicativeDo and constraints]- ; args' <- mapM goArg (zip3 args pat_tys exp_tys)+ ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys) -- Bring into scope all the things bound by the args, -- and typecheck the thing_inside@@ -1011,18 +1012,30 @@ ; ops' <- goOps t_i ops ; return (op' : ops') } - goArg :: (ApplicativeArg GhcRn, Type, Type)+ goArg :: Type -> (ApplicativeArg GhcRn, Type, Type) -> TcM (ApplicativeArg GhcTcId) - goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)+ goArg body_ty (ApplicativeArgOne+ { app_arg_pattern = pat+ , arg_expr = rhs+ , fail_operator = fail_op+ , ..+ }, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ return ()- ; return (ApplicativeArgOne x pat' rhs' isBody) }+ ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op body_ty - goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)+ ; return (ApplicativeArgOne+ { app_arg_pattern = pat'+ , arg_expr = rhs'+ , fail_operator = fail_op'+ , .. }+ ) }++ goArg _body_ty (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) = do { (stmts', (ret',pat')) <- tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ \res_ty -> do@@ -1033,13 +1046,12 @@ } ; return (ApplicativeArgMany x stmts' ret' pat') } - goArg (XApplicativeArg nec, _, _) = noExtCon nec+ goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]- get_arg_bndrs (ApplicativeArgOne _ pat _ _) = collectPatBinders pat- get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat+ get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat+ get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat get_arg_bndrs (XApplicativeArg nec) = noExtCon nec- {- Note [ApplicativeDo and constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/TcPat.hs view
@@ -33,7 +33,7 @@ import TcEnv import TcMType import TcValidity( arityErr )-import Type ( pprTyVars )+import TyCoPpr ( pprTyVars ) import TcType import TcUnify import TcHsType@@ -302,11 +302,11 @@ -> PatEnv -> TcM a -> TcM (LPat GhcTcId, a)-tc_lpat (dL->L span pat) pat_ty penv thing_inside+tc_lpat (L span pat) pat_ty penv thing_inside = setSrcSpan span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) thing_inside- ; return (cL span pat', res) }+ ; return (L span pat', res) } tc_lpats :: PatEnv -> [LPat GhcRn] -> [ExpSigmaType]@@ -326,11 +326,11 @@ -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside+tc_pat penv (VarPat x (L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty- ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) }+ ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } tc_pat penv (ParPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside@@ -361,7 +361,7 @@ ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside+tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id)@@ -374,7 +374,7 @@ -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty- ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty,+ ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside@@ -523,7 +523,7 @@ -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same-tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside+tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]@@ -541,7 +541,7 @@ ; res <- thing_inside ; pat_ty <- readExpType pat_ty- ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) }+ ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns]@@ -572,8 +572,8 @@ -} -- See Note [NPlusK patterns]-tc_pat penv (NPlusKPat _ (dL->L nm_loc name)- (dL->L loc lit) _ ge minus) pat_ty+tc_pat penv (NPlusKPat _ (L nm_loc name)+ (L loc lit) _ ge minus) pat_ty thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit@@ -603,7 +603,7 @@ ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' }- pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2'+ pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' ge' minus'' ; return (pat', res) } @@ -712,7 +712,7 @@ -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a)-tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside+tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of RealDataCon data_con -> tcDataConPat penv con_lname data_con@@ -725,13 +725,13 @@ -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a)-tcDataConPat penv (dL->L con_span con_name) data_con pat_ty+tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con- header = cL con_span (RealDataCon data_con)+ header = L con_span (RealDataCon data_con) -- Instantiate the constructor type variables [a->ty] -- This may involve doing a family-instance coercion,@@ -821,7 +821,7 @@ -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a)-tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside+tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn ; (subst, univ_tvs') <- newMetaTyVars univ_tvs@@ -858,7 +858,7 @@ tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside ; traceTc "checkConstraints }" (ppr ev_binds)- ; let res_pat = ConPatOut { pat_con = cL con_span $ PatSynCon pat_syn,+ ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, pat_tvs = ex_tvs', pat_dicts = prov_dicts', pat_binds = ev_binds,@@ -988,19 +988,16 @@ where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId))- tc_field (dL->L l (HsRecField (dL->L loc- (FieldOcc sel (dL->L lr rdr))) pat pun))+ tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside- ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat'+ ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' pun), res) }- tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _+ tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ = panic "tcConArgs"- tc_field _ _ _ = panic "tc_field: Impossible Match"- -- due to #15884 find_field_ty :: Name -> FieldLabelString -> TcM TcType@@ -1101,7 +1098,7 @@ Old notes about desugaring, at a time when pattern coercions were handled: -A SigPat is a type coercion and must be handled one at at time. We can't+A SigPat is a type coercion and must be handled one at a time. We can't combine them unless the type of the pattern inside is identical, and we don't bother to check for that. For example:
compiler/typecheck/TcPatSyn.hs view
@@ -81,7 +81,7 @@ recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -- See Note [Pattern synonym error recovery]-recoverPSB (PSB { psb_id = (dL->L _ name)+recoverPSB (PSB { psb_id = L _ name , psb_args = details }) = do { matcher_name <- newImplicitBinder name mkMatcherOcc ; let placeholder = AConLike $ PatSynCon $@@ -135,7 +135,7 @@ tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv)-tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details+tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name@@ -153,7 +153,7 @@ mk_named_tau arg = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) -- The mkSpecForAllTys is important (#14552), albeit- -- slightly artifical (there is no variable with this funny type).+ -- slightly artificial (there is no variable with this funny type). -- We do not want to quantify over variable (alpha::k) -- that mention the existentially-bound type variables -- ex_tvs in its kind k.@@ -307,7 +307,7 @@ So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and marginally less efficient, if the builder/martcher are not inlined. -See also Note [Lift equality constaints when quantifying] in TcType+See also Note [Lift equality constraints when quantifying] in TcType Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -341,7 +341,7 @@ tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv)-tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details+tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } TPSI{ patsig_implicit_bndrs = implicit_tvs , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta@@ -569,12 +569,12 @@ splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) splitRecordPatSyn (RecordPatSynField- { recordPatSynPatVar = (dL->L _ patVar)- , recordPatSynSelectorId = (dL->L _ selId) })+ { recordPatSynPatVar = L _ patVar+ , recordPatSynSelectorId = L _ selId }) = (patVar, selId) addPatSynCtxt :: Located Name -> TcM a -> TcM a-addPatSynCtxt (dL->L loc name) thing_inside+addPatSynCtxt (L loc name) thing_inside = setSrcSpan loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $@@ -685,7 +685,7 @@ -> TcType -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn-tcPatSynMatcher (dL->L loc name) lpat+tcPatSynMatcher (L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty@@ -726,9 +726,9 @@ else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $- cL (getLoc lpat) $+ L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $- MG{ mg_alts = cL (getLoc lpat) cases+ MG{ mg_alts = L (getLoc lpat) cases , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated }@@ -739,18 +739,18 @@ , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty , mg_origin = Generated }- match = mkMatch (mkPrefixFunRhs (cL loc name)) []+ match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc (EmptyLocalBinds noExtField)) mg :: MatchGroup GhcTc (LHsExpr GhcTc)- mg = MG{ mg_alts = cL (getLoc match) [match]+ mg = MG{ mg_alts = L (getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } ; let bind = FunBind{ fun_ext = emptyNameSet- , fun_id = cL loc matcher_id+ , fun_id = L loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper , fun_tick = [] }@@ -786,7 +786,7 @@ -> [TyVarBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool))-mkPatSynBuilderId dir (dL->L _ name)+mkPatSynBuilderId dir (L _ name) univ_bndrs req_theta ex_bndrs prov_theta arg_tys pat_ty | isUnidirectional dir@@ -812,7 +812,7 @@ tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn-tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name)+tcPatSynBuilderBind (PSB { psb_id = L loc name , psb_def = lpat , psb_dir = dir , psb_args = details })@@ -840,7 +840,7 @@ | otherwise = match_group bind = FunBind { fun_ext = placeHolderNamesTc- , fun_id = cL loc (idName builder_id)+ , fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper , fun_tick = [] }@@ -864,9 +864,9 @@ mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where- builder_args = [cL loc (VarPat noExtField (cL loc n))- | (dL->L loc n) <- args]- builder_match = mkMatch (mkPrefixFunRhs (cL loc name))+ builder_args = [L loc (VarPat noExtField (L loc n))+ | L loc n <- args]+ builder_match = mkMatch (mkPrefixFunRhs (L loc name)) builder_args body (noLoc (EmptyLocalBinds noExtField)) @@ -878,9 +878,8 @@ add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) -> MatchGroup GhcRn (LHsExpr GhcRn) add_dummy_arg mg@(MG { mg_alts =- (dL->L l [dL->L loc- match@(Match { m_pats = pats })]) })- = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] }+ (L l [L loc match@(Match { m_pats = pats })]) })+ = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec@@ -926,9 +925,9 @@ -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either MsgDoc (HsExpr GhcRn)- mkPrefixConExpr lcon@(dL->L loc _) pats+ mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats- ; return (foldl' (\x y -> HsApp noExtField (cL loc x) y)+ ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) (HsVar noExtField lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)@@ -938,7 +937,7 @@ ; return (RecordCon noExtField con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)- go (dL->L loc p) = cL loc <$> go1 p+ go (L loc p) = L loc <$> go1 p go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) go1 (ConPatIn con info)@@ -950,9 +949,9 @@ go1 (SigPat _ pat _) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat _ (dL->L l var))+ go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars- = return $ HsVar noExtField (cL l var)+ = return $ HsVar noExtField (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat@@ -969,7 +968,7 @@ (noLoc expr) } go1 (LitPat _ lit) = return $ HsLit noExtField lit- go1 (NPat _ (dL->L _ n) mb_neg _)+ go1 (NPat _ (L _ n) mb_neg _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit noExtField n)] | otherwise = return $ HsOverLit noExtField n@@ -1142,7 +1141,7 @@ = mergeMany . map goRecFd $ flds goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])- goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p+ goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) mergeMany = foldr merge empty
compiler/typecheck/TcRnDriver.hs view
@@ -163,7 +163,7 @@ -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax- parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}+ parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc <- loc = withTiming dflags (text "Renamer/typechecker"<+>brackets (ppr this_mod))@@ -186,7 +186,7 @@ pair :: (Module, SrcSpan) pair@(this_mod,_)- | Just (dL->L mod_loc mod) <- hsmodName this_module+ | Just (L mod_loc mod) <- hsmodName this_module = (mkModule this_pkg mod, mod_loc) | otherwise -- 'module M where' is omitted@@ -205,7 +205,7 @@ tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module =- (dL->L loc (HsModule maybe_mod export_ies+ (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files@@ -232,7 +232,7 @@ addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; -- TODO This is a little skeevy; maybe handle a bit more directly- let { simplifyImport (dL->L _ idecl) =+ let { simplifyImport (L _ idecl) = ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) } ; raw_sig_imports <- liftIO@@ -242,7 +242,7 @@ $ implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls))- ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc+ ; let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { ideclHiding = Just (False, noLoc [])} ; mkImport _ = panic "mkImport" }@@ -256,7 +256,7 @@ -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns let { tcg_env1 = case mod_deprec of- Just (dL->L _ txt) ->+ Just (L _ txt) -> tcg_env {tcg_warns = WarnAll txt} Nothing -> tcg_env }@@ -552,7 +552,7 @@ else do { (th_group, th_group_tail) <- findSplice th_ds ; case th_group_tail of { Nothing -> return ()- ; Just (SpliceDecl _ (dL->L loc _) _, _) ->+ ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpan loc $ addErr (text ("Declaration splices are not "@@ -588,7 +588,7 @@ { Nothing -> return (tcg_env, tcl_env, lie1) -- If there's a splice, we must carry on- ; Just (SpliceDecl _ (dL->L _ splice) _, rest_ds) ->+ ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> do { -- We need to simplify any constraints from the previous declaration -- group, or else we might reify metavariables, as in #16980.@@ -681,7 +681,7 @@ ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: HscSource -> String -> Located decl -> TcM ()-badBootDecl hsc_src what (dL->L loc _)+badBootDecl hsc_src what (L loc _) = addErrAt loc (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of@@ -874,7 +874,7 @@ -- that modifying boot_dfun, to make local_boot_fun. | otherwise- = setSrcSpan (getLoc (getName boot_dfun)) $+ = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ do { traceTc "check_cls_inst" $ vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)@@ -1747,7 +1747,7 @@ ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $- tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name)))+ tcMonoExpr (L loc (HsVar noExtField (L loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id]@@ -2057,53 +2057,53 @@ tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially-tcUserStmt (dL->L loc (BodyStmt _ expr _ _))+tcUserStmt (L loc (BodyStmt _ expr _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc- matches = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr+ matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr (noLoc emptyLocalBinds)] -- [it = expr]- the_bind = cL loc $ (mkTopFunBind FromSource- (cL loc fresh_it) matches)+ the_bind = L loc $ (mkTopFunBind FromSource+ (L loc fresh_it) matches) { fun_ext = fvs } -- Care here! In GHCi the expression might have -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr]- let_stmt = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField+ let_stmt = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e]- bind_stmt = cL loc $ BindStmt noExtField- (cL loc (VarPat noExtField (cL loc fresh_it)))+ bind_stmt = L loc $ BindStmt noExtField+ (L loc (VarPat noExtField (L loc fresh_it))) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr -- [; print it]- print_it = cL loc $ BodyStmt noExtField+ print_it = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr -- NewA- no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName+ no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName [rn_expr , nlHsVar interPrintName]) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_b = cL loc $ BodyStmt noExtField (rn_expr)+ no_it_b = L loc $ BodyStmt noExtField (rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_c = cL loc $ BodyStmt noExtField+ no_it_c = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr@@ -2203,7 +2203,7 @@ In an equation for ‘x’: x = putStrLn True -} -tcUserStmt rdr_stmt@(dL->L loc _)+tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv@@ -2214,8 +2214,8 @@ ; ghciStep <- getGhciStepIO ; let gi_stmt- | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt- = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2+ | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt+ = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 | otherwise = rn_stmt ; opt_pr_flag <- goptM Opt_PrintBindResult@@ -2237,7 +2237,7 @@ ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where- print_v = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName)+ print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) (nlHsVar v)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2594,7 +2594,7 @@ tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi-tcRnLookupRdrName hsc_env (dL->L loc rdr_name)+tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ setSrcSpan loc $ do { -- If the identifier is a constructor (begins with an
compiler/typecheck/TcRnExports.hs view
@@ -254,7 +254,7 @@ fix_faminst avail = avail -exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod+exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do ie_avails <- accumExports do_litem rdr_items let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families return (Just ie_avails, final_exports)@@ -269,7 +269,7 @@ -- See Note [Avails of associated data families] expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]- expand_tyty_gre (gre @ GRE { gre_name = me, gre_par = ParentIs p })+ expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p }) | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }] expand_tyty_gre gre = [gre] @@ -280,7 +280,7 @@ exports_from_item :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) exports_from_item (ExportAccum occs earlier_mods)- (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod)))+ (L loc ie@(IEModuleContents _ lmod@(L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M = do { warnIfFlag Opt_WarnDuplicateExports True (dupModuleExport mod) ;@@ -317,13 +317,13 @@ , ppr new_exports ]) ; return (Just ( ExportAccum occs' mods- , ( cL loc (IEModuleContents noExtField lmod)+ , ( L loc (IEModuleContents noExtField lmod) , new_exports))) } - exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie)+ exports_from_item acc@(ExportAccum occs mods) (L loc ie) | isDoc ie = do new_ie <- lookup_doc_ie ie- return (Just (acc, (cL loc new_ie, [])))+ return (Just (acc, (L loc new_ie, []))) | otherwise = do (new_ie, avail) <- lookup_ie ie@@ -334,17 +334,17 @@ occs' <- check_occs ie occs [avail] return (Just ( ExportAccum occs' mods- , (cL loc new_ie, [avail])))+ , (L loc new_ie, [avail]))) ------------- lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)- lookup_ie (IEVar _ (dL->L l rdr))+ lookup_ie (IEVar _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr- return (IEVar noExtField (cL l (replaceWrappedName rdr name)), avail)+ return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) - lookup_ie (IEThingAbs _ (dL->L l rdr))+ lookup_ie (IEThingAbs _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr- return (IEThingAbs noExtField (cL l (replaceWrappedName rdr name))+ return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n')@@ -376,18 +376,18 @@ lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] -> RnM (Located Name, [LIEWrappedName Name], [Name], [Located FieldLabel])- lookup_ie_with (dL->L l rdr) sub_rdrs+ lookup_ie_with (L l rdr) sub_rdrs = do name <- lookupGlobalOccRn $ ieWrappedName rdr (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name- then return (cL l name, [], [name], [])- else return (cL l name, non_flds+ then return (L l name, [], [name], [])+ else return (L l name, non_flds , map (ieWrappedName . unLoc) non_flds , flds) lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName -> RnM (Located Name, [Name], [FieldLabel])- lookup_ie_all ie (dL->L l rdr) =+ lookup_ie_all ie (L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr let gres = findChildren kids_env name (non_flds, flds) = classifyGREs gres@@ -401,7 +401,7 @@ else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie)- return (cL l name, non_flds, flds)+ return (L l name, non_flds, flds) ------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)@@ -530,8 +530,8 @@ case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n- ; return (Left (cL l (IEName (cL l ub))))}- FoundFL fls -> return $ Right (cL (getLoc n) fls)+ ; return (Left (L l (IEName (L l ub))))}+ FoundFL fls -> return $ Right (L (getLoc n) fls) FoundName par name -> do { checkPatSynParent spec_parent par name ; return $ Left (replaceLWrappedName n name) }@@ -778,7 +778,7 @@ text "In the" <+> text (herald ++ ":") <+> ppr exp -addExportErrCtxt :: (OutputableBndrId (GhcPass p))+addExportErrCtxt :: (OutputableBndrId p) => IE (GhcPass p) -> TcM a -> TcM a addExportErrCtxt ie = addErrCtxt exportCtxt where
compiler/typecheck/TcRnMonad.hs view
@@ -397,17 +397,14 @@ ************************************************************************ -} -initTcRnIf :: Char -- Tag for unique supply+initTcRnIf :: Char -- ^ Mask for unique supply -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a-initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside- = do { us <- mkSplitUniqSupply uniq_tag ;- ; us_var <- newIORef us ;-- ; let { env = Env { env_top = hsc_env,- env_us = us_var,+initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside+ = do { let { env = Env { env_top = hsc_env,+ env_um = uniq_mask, env_gbl = gbl_env, env_lcl = lcl_env} } @@ -595,27 +592,15 @@ newUnique :: TcRnIf gbl lcl Unique newUnique- = do { env <- getEnv ;- let { u_var = env_us env } ;- us <- readMutVar u_var ;- case takeUniqFromSupply us of { (uniq, us') -> do {- writeMutVar u_var us' ;- return $! uniq }}}- -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving- -- a chain of unevaluated supplies behind.- -- NOTE 2: we use the uniq in the supply from the MutVar directly, and- -- throw away one half of the new split supply. This is safe because this- -- is the only place we use that unique. Using the other half of the split- -- supply is safer, but slower.+ = do { env <- getEnv+ ; let mask = env_um env+ ; liftIO $! uniqFromMask mask } newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply- = do { env <- getEnv ;- let { u_var = env_us env } ;- us <- readMutVar u_var ;- case splitUniqSupply us of { (us1,us2) -> do {- writeMutVar u_var us1 ;- return us2 }}}+ = do { env <- getEnv+ ; let mask = env_um env+ ; liftIO $! mkSplitUniqSupply mask } cloneLocalName :: Name -> TcM Name -- Make a fresh Internal name with the same OccName and SrcSpan@@ -855,31 +840,28 @@ -- Don't overwrite useful info with useless: setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b-addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a+addLocM :: (a -> TcM b) -> Located a -> TcM b+addLocM fn (L loc a) = setSrcSpan loc $ fn a -wrapLocM :: (HasSrcSpan a, HasSrcSpan b) =>- (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b+wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)-wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a- ; return (cL loc b) }-wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) =>- (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c)-wrapLocFstM fn (dL->L loc a) =+wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a+ ; return (L loc b) }++wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)+wrapLocFstM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a- return (cL loc b, c)+ return (L loc b, c) -wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) =>- (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c)-wrapLocSndM fn (dL->L loc a) =+wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)+wrapLocSndM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a- return (b, cL loc c)+ return (b, L loc c) -wrapLocM_ :: HasSrcSpan a =>- (SrcSpanLess a -> TcM ()) -> a -> TcM ()-wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a)+wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()+wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) -- Reporting errors @@ -1944,12 +1926,8 @@ -- signatures, which is pretty benign forkM_maybe doc thing_inside- -- NB: Don't share the mutable env_us with the interleaved thread since env_us- -- does not get updated atomically (e.g. in newUnique and newUniqueSupply).- = do { child_us <- newUniqueSupply- ; child_env_us <- newMutVar child_us- -- see Note [Masking exceptions in forkM_maybe]- ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $+ = do { -- see Note [Masking exceptions in forkM_maybe]+ ; unsafeInterleaveM $ uninterruptibleMaskM_ $ do { traceIf (text "Starting fork {" <+> doc) ; mb_res <- tryM $ updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
compiler/typecheck/TcSMonad.hs view
@@ -140,7 +140,6 @@ import qualified TcEnv as TcM ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl ) import ClsInst( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )-import Kind import TcType import DynFlags import Type@@ -475,7 +474,7 @@ the past. But in particular, we can use it to create *recursive* dictionaries.-The simplest, degnerate case is+The simplest, degenerate case is instance C [a] => C [a] where ... If we have [W] d1 :: C [x]@@ -2860,7 +2859,7 @@ a ~ F b, forall c. b~Int => blah If we have F b ~ fsk in the flat-cache, and we push that into the nested implication, we might miss that F b can be rewritten to F Int,-and hence perhpas solve it. Moreover, the fsk from outside is+and hence perhaps solve it. Moreover, the fsk from outside is flattened out after solving the outer level, but and we don't do that flattening recursively. -}@@ -2882,7 +2881,7 @@ ; new_inerts <- TcM.readTcRef new_inert_var - -- we want to propogate the safe haskell failures+ -- we want to propagate the safe haskell failures ; let old_ic = inert_cans inerts new_ic = inert_cans new_inerts nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }@@ -2979,7 +2978,7 @@ forall b. empty => Eq [a] We solve the simple (Eq [a]), under nestTcS, and then turn our attention to the implications. It's definitely fine to use the solved dictionaries on-the inner implications, and it can make a signficant performance difference+the inner implications, and it can make a significant performance difference if you do so. -}
compiler/typecheck/TcSigs.hs view
@@ -123,7 +123,7 @@ may actually give rise to f :: forall k. forall (f::k -> *) (a:k). f a -> f a So the sig_tvs will be [k,f,a], but only f,a are scoped.- NB: the scoped ones are not necessarily the *inital* ones!+ NB: the scoped ones are not necessarily the *initial* ones! * Even aside from kind polymorphism, there may be more instantiated type variables than lexically-scoped ones. For example:@@ -766,7 +766,7 @@ where name = idName poly_id poly_ty = idType poly_id- spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)+ spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) tc_one hs_ty = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty
compiler/typecheck/TcSimplify.hs view
@@ -693,7 +693,7 @@ Why is this useful? As one example, when coverage-checking an EmptyCase expression, it's possible that the type of the scrutinee will only reduce if some local equalities are solved for. See "Wrinkle: Local equalities"-in Note [Type normalisation for EmptyCase] in Check.+in Note [Type normalisation] in Check. To accomplish its stated goal, tcNormalise first feeds the local constraints into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds
compiler/typecheck/TcSplice.hs view
@@ -431,6 +431,39 @@ -} +-- | We only want to produce warnings for TH-splices if the user requests so.+-- See Note [Warnings for TH splices].+getThSpliceOrigin :: TcM Origin+getThSpliceOrigin = do+ warn <- goptM Opt_EnableThSpliceWarnings+ if warn then return FromSource else return Generated++{- Note [Warnings for TH splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only produce warnings for TH splices when the user requests so+(-fenable-th-splice-warnings). There are multiple reasons:++ * It's not clear that the user that compiles a splice is the author of the code+ that produces the warning. Think of the situation where she just splices in+ code from a third-party library that produces incomplete pattern matches.+ In this scenario, the user isn't even able to fix that warning.+ * Gathering information for producing the warnings (pattern-match check+ warnings in particular) is costly. There's no point in doing so if the user+ is not interested in those warnings.++That's why we store Origin flags in the Haskell AST. The functions from ThToHs+take such a flag and depending on whether TH splice warnings were enabled or+not, we pass FromSource (if the user requests warnings) or Generated+(otherwise). This is implemented in getThSpliceOrigin.++For correct pattern-match warnings it's crucial that we annotate the Origin+consistently (#17270). In the future we could offer the Origin as part of the+TH AST. That would enable us to give quotes from the current module get+FromSource origin, and/or third library authors to tag certain parts of+generated code as FromSource to enable warnings. That effort is tracked in+#14838.+-}+ {- ************************************************************************ * *@@ -686,15 +719,16 @@ runQResult :: (a -> String)- -> (SrcSpan -> a -> b)+ -> (Origin -> SrcSpan -> a -> b) -> (ForeignHValue -> TcM a) -> SrcSpan -> ForeignHValue {- TH.Q a -} -> TcM b runQResult show_th f runQ expr_span hval = do { th_result <- runQ hval+ ; th_origin <- getThSpliceOrigin ; traceTc "Got TH result:" (text (show_th th_result))- ; return (f expr_span th_result) }+ ; return (f th_origin expr_span th_result) } -----------------@@ -972,7 +1006,8 @@ qAddTopDecls thds = do l <- getSrcSpanM- let either_hval = convertToHsDecls l thds+ th_origin <- getThSpliceOrigin+ let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of Left exn -> failWithTc $ hang (text "Error in a declaration passed to addTopDecls:")@@ -1255,7 +1290,8 @@ = addErrCtxt (text "In the argument of reifyInstances:" <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { loc <- getSrcSpanM- ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)+ ; th_origin <- getThSpliceOrigin+ ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) -- #9262 says to bring vars into scope, like in HsForAllTy case -- of rnHsTyKi ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty@@ -1297,10 +1333,10 @@ doc = ClassInstanceCtx bale_out msg = failWithTc msg - cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)- cvt loc th_ty = case convertToHsType loc th_ty of- Left msg -> failWithTc msg- Right ty -> return ty+ cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)+ cvt origin loc th_ty = case convertToHsType origin loc th_ty of+ Left msg -> failWithTc msg+ Right ty -> return ty {- ************************************************************************
compiler/typecheck/TcTyClsDecls.hs view
@@ -50,6 +50,7 @@ import TcOrigin import Type import TyCoRep -- for checkValidRoles+import TyCoPpr( pprTyVars, pprWithExplicitKindsWhen ) import Class import CoAxiom import TyCon@@ -453,9 +454,9 @@ B :-> TcTyCon <initial kind> (thereby overriding the B :-> TyConPE binding) and do kcLTyClDecl on each decl to get equality constraints on- all those inital kinds+ all those initial kinds - - Generalise the inital kind, making a poly-kinded TcTyCon+ - Generalise the initial kind, making a poly-kinded TcTyCon 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded TcTyCons, again overriding the promotion-error bindings.@@ -996,15 +997,15 @@ = unitNameEnv nm (APromotionErr ClassPE) `plusNameEnv` mkNameEnv [ (name, APromotionErr TyConPE)- | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ]+ | (L _ (FamilyDecl { fdLName = L _ name })) <- ats ] -mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name)+mk_prom_err_env (DataDecl { tcdLName = L _ name , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` mkNameEnv [ (con, APromotionErr RecDataConPE)- | (dL->L _ con') <- cons- , (dL->L _ con) <- getConNames con' ]+ | L _ con' <- cons+ , L _ con <- getConNames con' ] mk_prom_err_env decl = unitNameEnv (tcdName decl) (APromotionErr TyConPE)@@ -1053,7 +1054,7 @@ -- -- No family instances are passed to checkInitialKinds/inferInitialKinds getInitialKind strategy- (ClassDecl { tcdLName = dL->L _ name+ (ClassDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdATs = ats }) = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $@@ -1071,7 +1072,7 @@ InitialKindCheck _ -> check_initial_kind_assoc_fam cls getInitialKind strategy- (DataDecl { tcdLName = dL->L _ name+ (DataDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_ND = new_or_data } })@@ -1104,7 +1105,7 @@ ; return [tc] } getInitialKind strategy- (SynDecl { tcdLName = dL->L _ name+ (SynDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdRhs = rhs }) = do { let ctxt = TySynKindCtxt name@@ -1123,14 +1124,14 @@ -> FamilyDecl GhcRn -> TcM TcTyCon get_fam_decl_initial_kind mb_parent_tycon- FamilyDecl { fdLName = (dL->L _ name)+ FamilyDecl { fdLName = L _ name , fdTyVars = ktvs- , fdResultSig = (dL->L _ resultSig)+ , fdResultSig = L _ resultSig , fdInfo = info } = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of- KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki- TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki+ KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki+ TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) -- closed type families have their return kind inferred@@ -1257,7 +1258,7 @@ ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls]-kcLTyClDecl (dL->L loc decl)+kcLTyClDecl (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ do { traceTc "kcTyClDecl {" (ppr tc_name)@@ -1272,10 +1273,10 @@ -- result kind signature have already been dealt with -- by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName = (dL->L _ name)+kcTyClDecl (DataDecl { tcdLName = (L _ name) , tcdDataDefn = defn })- | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _)- , dd_ctxt = (dL->L _ [])+ | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _)+ , dd_ctxt = (L _ []) , dd_ND = new_or_data } <- defn = do { tyCon <- kcLookupTcTyCon name -- See Note [Implementation of UnliftedNewtypes] STEP 2@@ -1297,13 +1298,13 @@ ; kcConDecls new_or_data (tyConResKind tyCon) cons } -kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })+kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) = bindTyClTyVars name $ \ _ res_kind -> discardResult $ tcCheckLHsType rhs res_kind -- NB: check against the result kind that we allocated -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)+kcTyClDecl (ClassDecl { tcdLName = L _ name , tcdCtxt = ctxt, tcdSigs = sigs }) = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt@@ -1314,7 +1315,7 @@ skol_info = TyConSkol ClassFlavour name -kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name)+kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = L _ fam_tc_name , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't -- do anything here@@ -1691,13 +1692,13 @@ inside the data constructor to determine the result kind. See Note [Unlifted Newtypes and CUSKs] for more detail. -For completeness, it was also neccessary to make coerce work on+For completeness, it was also necessary to make coerce work on unlifted types, resolving #13595. -} tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])-tcTyClDecl roles_info (dL->L loc decl)+tcTyClDecl roles_info (L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things] ATyCon tc -> return (tc, wiredInDerivInfo tc decl)@@ -1734,7 +1735,7 @@ -- "type" synonym declaration tcTyClDecl1 _parent roles_info- (SynDecl { tcdLName = (dL->L _ tc_name)+ (SynDecl { tcdLName = L _ tc_name , tcdRhs = rhs }) = ASSERT( isNothing _parent ) fmap noDerivInfos $@@ -1743,7 +1744,7 @@ -- "data/newtype" declaration tcTyClDecl1 _parent roles_info- decl@(DataDecl { tcdLName = (dL->L _ tc_name)+ decl@(DataDecl { tcdLName = L _ tc_name , tcdDataDefn = defn }) = ASSERT( isNothing _parent ) bindTyClTyVars tc_name $ \ tycon_binders res_kind ->@@ -1751,7 +1752,7 @@ tycon_binders res_kind defn tcTyClDecl1 _parent roles_info- (ClassDecl { tcdLName = (dL->L _ class_name)+ (ClassDecl { tcdLName = L _ class_name , tcdCtxt = hs_ctxt , tcdMeths = meths , tcdFDs = fundeps@@ -1852,10 +1853,10 @@ ; mapM tc_at ats } where at_def_tycon :: LTyFamDefltDecl GhcRn -> Name- at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn+ at_def_tycon (L _ eqn) = tyFamInstDeclName eqn at_fam_name :: LFamilyDecl GhcRn -> Name- at_fam_name (dL->L _ decl) = unLoc (fdLName decl)+ at_fam_name (L _ decl) = unLoc (fdLName decl) at_names = mkNameSet (map at_fam_name ats) @@ -1884,7 +1885,7 @@ <+> ppr (tyFamInstDeclName (unLoc d1))) tcDefaultAssocDecl fam_tc- [dL->L loc (TyFamInstDecl { tfid_eqn =+ [L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ tc_name , feqn_bndrs = mb_expl_bndrs@@ -1982,10 +1983,11 @@ suggestion :: SDoc suggestion = text "The arguments to" <+> quotes (ppr fam_tc) <+> text "must all be distinct type variables"-tcDefaultAssocDecl _ [_]- = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x+tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x + {- Note [Type-checking default assoc decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this default declaration for an associated type@@ -2051,8 +2053,8 @@ tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info- , fdLName = tc_lname@(dL->L _ tc_name)- , fdResultSig = (dL->L _ sig)+ , fdLName = tc_lname@(L _ tc_name)+ , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info = bindTyClTyVars tc_name $ \ binders res_kind -> do@@ -2175,7 +2177,7 @@ -- therefore we can always infer the result kind if we know the result type. -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.)-tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames)))+tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags@@ -2299,11 +2301,11 @@ -- Used for the equations of a closed type family only -- Not used for data/type instances kcTyFamInstEqn tc_fam_tc- (dL->L loc (HsIB { hsib_ext = imp_vars- , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name- , feqn_bndrs = mb_expl_bndrs- , feqn_pats = hs_pats- , feqn_rhs = hs_rhs_ty }}))+ (L loc (HsIB { hsib_ext = imp_vars+ , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name+ , feqn_bndrs = mb_expl_bndrs+ , feqn_pats = hs_pats+ , feqn_rhs = hs_rhs_ty }})) = setSrcSpan loc $ do { traceTc "kcTyFamInstEqn" (vcat [ text "tc_name =" <+> ppr eqn_tc_name@@ -2329,9 +2331,8 @@ where vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec-kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec-kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884+kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec+kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec --------------------------@@ -2341,7 +2342,7 @@ -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo- (dL->L loc (HsIB { hsib_ext = imp_vars+ (L loc (HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name , feqn_bndrs = mb_expl_bndrs , feqn_pats = hs_pats@@ -2641,8 +2642,8 @@ ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool-consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True-consUseGadtSyntax _ = False+consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True+consUseGadtSyntax _ = False -- All constructors have same shape -----------------------------------@@ -2733,7 +2734,7 @@ -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in DataCon. user_tvbs = univ_tvbs ++ ex_tvbs- buildOneDataCon (dL->L _ name) = do+ buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name @@ -2761,7 +2762,7 @@ , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names)- ; let ((dL->L _ name) : _) = names+ ; let (L _ name : _) = names ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushTcLevelM_ $ -- We are going to generalise@@ -2820,7 +2821,7 @@ -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let- buildOneDataCon (dL->L _ name) = do+ buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name @@ -2874,7 +2875,7 @@ = mapM tcConArg btys where -- We need a one-to-one mapping from field_names to btys- combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f))+ combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined@@ -4039,7 +4040,7 @@ check_roles = whenIsJust role_annot_decl_maybe $- \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) ->+ \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ setSrcSpan loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations@@ -4063,11 +4064,10 @@ = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()-checkRoleAnnot _ (dL->L _ Nothing) _ = return ()-checkRoleAnnot tv (dL->L _ (Just r1)) r2+checkRoleAnnot _ (L _ Nothing) _ = return ()+checkRoleAnnot tv (L _ (Just r1)) r2 = when (r1 /= r2) $ addErrTc $ badRoleAnnot (tyVarName tv) r1 r2-checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884 -- This is a double-check on the role inference algorithm. It is only run when -- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls@@ -4354,25 +4354,21 @@ , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc-wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots))+wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) = hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d)-wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec-wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match"- -- due to #15884+wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()-illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _))+illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.")-illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec-illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match"- -- due to #15884+illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc
compiler/typecheck/TcTyDecls.hs view
@@ -225,7 +225,7 @@ mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of- Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl+ Just (L loc decl) -> ppr loc <> colon <+> ppr decl Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" where@@ -486,7 +486,7 @@ -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupRoleAnnot annots_env name of- Just (dL->L _ (RoleAnnotDecl _ _ annots))+ Just (L _ (RoleAnnotDecl _ _ annots)) | annots `lengthIs` num_exps -> map unLoc annots _ -> replicate num_exps Nothing default_roles = build_default_roles argflags role_annots@@ -828,13 +828,13 @@ tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs- = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $+ = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where- sigs = [ cL loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs- , let loc = getSrcSpan sel_id ]+ sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs+ , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]@@ -854,7 +854,7 @@ mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl- = (sel_id, cL loc sel_bind)+ = (sel_id, L loc sel_bind) where loc = getSrcSpan sel_name lbl = flLabel fl@@ -892,18 +892,18 @@ [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)- [cL loc (mk_sel_pat con)]- (cL loc (HsVar noExtField (cL loc field_var)))- mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields)+ [L loc (mk_sel_pat con)]+ (L loc (HsVar noExtField (L loc field_var)))+ mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl- = cL loc (FieldOcc sel_name- (cL loc $ mkVarUnqual lbl))+ = L loc (FieldOcc sel_name+ (L loc $ mkVarUnqual lbl)) , hsRecFieldArg- = cL loc (VarPat noExtField (cL loc field_var))+ = L loc (VarPat noExtField (L loc field_var)) , hsRecPun = False })- sel_lname = cL loc sel_name+ sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive@@ -911,10 +911,10 @@ -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt- [cL loc (WildPat noExtField)]- (mkHsApp (cL loc (HsVar noExtField- (cL loc (getName rEC_SEL_ERROR_ID))))- (cL loc (HsLit noExtField msg_lit)))]+ [L loc (WildPat noExtField)]+ (mkHsApp (L loc (HsVar noExtField+ (L loc (getName rEC_SEL_ERROR_ID))))+ (L loc (HsLit noExtField msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we
compiler/typecheck/TcUnify.hs view
@@ -42,6 +42,7 @@ import GHC.Hs import TyCoRep+import TyCoPpr( debugPprType ) import TcMType import TcRnMonad import TcType@@ -1714,7 +1715,7 @@ = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) -- Occurs check or an untouchable: just defer -- NB: occurs check isn't necessarily fatal:- -- eg tv1 occured in type family parameter+ -- eg tv1 occurred in type family parameter ; defer } ty1 = mkTyVarTy tv1
compiler/typecheck/TcValidity.hs view
@@ -29,6 +29,7 @@ import ClsInst ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) import TyCoFVs import TyCoRep+import TyCoPpr import TcType hiding ( sizeType, sizeTypes ) import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName ) import PrelNames@@ -50,7 +51,7 @@ import FunDeps import FamInstEnv ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) )-import FamInst ( makeInjectivityErrors )+import FamInst import Name import VarEnv import VarSet@@ -2031,8 +2032,8 @@ ; let conflicts = fst $ foldl' (gather_conflicts inj prev_branches cur_branch) ([], 0) prev_branches- ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)- (makeInjectivityErrors dflags ax cur_branch inj conflicts) }+ ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch+ ; reportInjectivityErrors dflags ax cur_branch inj } | otherwise = return () @@ -2573,7 +2574,7 @@ positions where the class header has no influence over the parameter. Hence the fancy footwork in pp_expected_ty - - Although the binders in the axiom are aready tidy, we must+ - Although the binders in the axiom are already tidy, we must re-tidy them to get a fresh variable name when we shadow - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the
compiler/utils/Dominators.hs view
@@ -364,11 +364,11 @@ rootM :: Dom s Node rootM = gets rootE succsM :: Node -> Dom s [Node] -succsM i = gets (IS.toList . (!i) . succE) +succsM i = gets (IS.toList . (! i) . succE) predsM :: Node -> Dom s [Node] -predsM i = gets (IS.toList . (!i) . predE) +predsM i = gets (IS.toList . (! i) . predE) bucketM :: Node -> Dom s [Node] -bucketM i = gets (IS.toList . (!i) . bucketE) +bucketM i = gets (IS.toList . (! i) . bucketE) sizeM :: Node -> Dom s Int sizeM = fetch sizeE sdnoM :: Node -> Dom s Int
compiler/utils/GraphOps.hs view
@@ -264,8 +264,8 @@ -- | Add a color preference to the graph, creating nodes if required.--- The most recently added preference is the most prefered.--- The algorithm tries to assign a node it's prefered color if possible.+-- The most recently added preference is the most preferred.+-- The algorithm tries to assign a node it's preferred color if possible. -- addPreference :: Uniquable k
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20191101+version: 0.20191201 license: BSD3 license-file: LICENSE category: Development@@ -81,7 +81,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*,- ghc-lib-parser == 0.20191101+ ghc-lib-parser == 0.20191201 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -257,7 +257,6 @@ InstEnv, InteractiveEvalTypes, Json,- Kind, KnownUniques, Language.Haskell.TH, Language.Haskell.TH.LanguageExtensions,
ghc-lib/stage0/lib/DerivedConstants.h view
@@ -208,12 +208,12 @@ #define REP_StgTSO_blocked_exceptions b64 #define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions] #define OFFSET_StgTSO_id 40-#define REP_StgTSO_id b32+#define REP_StgTSO_id b64 #define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id] #define OFFSET_StgTSO_cap 64 #define REP_StgTSO_cap b64 #define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]-#define OFFSET_StgTSO_saved_errno 44+#define OFFSET_StgTSO_saved_errno 48 #define REP_StgTSO_saved_errno b32 #define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno] #define OFFSET_StgTSO_trec 72@@ -222,7 +222,7 @@ #define OFFSET_StgTSO_flags 28 #define REP_StgTSO_flags b32 #define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]-#define OFFSET_StgTSO_dirty 48+#define OFFSET_StgTSO_dirty 52 #define REP_StgTSO_dirty b32 #define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty] #define OFFSET_StgTSO_bq 88
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -101,7 +101,7 @@ /* #undef HAVE_BFD_H */ /* Does GCC support __atomic primitives? */-#define HAVE_C11_ATOMICS $CONF_GCC_SUPPORTS__ATOMICS+#define HAVE_C11_ATOMICS 1 /* Define to 1 if you have the `clock_gettime' function. */ #define HAVE_CLOCK_GETTIME 1@@ -134,6 +134,9 @@ /* Define to 1 if you have the <dlfcn.h> header file. */ #define HAVE_DLFCN_H 1 +/* Define to 1 if you have the <elfutils/libdw.h> header file. */+/* #undef HAVE_ELFUTILS_LIBDW_H */+ /* Define to 1 if you have the <errno.h> header file. */ #define HAVE_ERRNO_H 1 @@ -532,7 +535,7 @@ /* #undef pid_t */ /* The supported LLVM version number */-#define sUPPORTED_LLVM_VERSION (7)+#define sUPPORTED_LLVM_VERSION (9) /* Define to `unsigned int' if <sys/types.h> does not define. */ /* #undef size_t */
ghc-lib/stage0/lib/ghcversion.h view
@@ -2,11 +2,11 @@ #define __GHCVERSION_H__ #if !defined(__GLASGOW_HASKELL__)-# define __GLASGOW_HASKELL__ 809+# define __GLASGOW_HASKELL__ 811 #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20191027+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20191201 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/llvm-targets view
@@ -1,22 +1,22 @@ [("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", "")) ,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))-,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))-,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))-,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))+,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))+,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux-musl", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon")) ,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))@@ -26,12 +26,12 @@ ,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux-musl", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))-,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt"))-,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt +cx16"))+,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2d16 +vfp2d16sp +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml")) ,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2d16 +vfp2d16sp +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml")) ,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64", "ppc64le", ""))-,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", ""))+,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", "+secure-plt")) ,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", "")) ,("s390x-ibm-linux", ("E-m:e-i1:8:16-i8:8:16-i64:64-f128:64-a:8:16-n32:64", "z10", "")) ,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))@@ -43,7 +43,7 @@ ,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "")) ,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))-,("armv6-unknown-freebsd", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))-,("armv7-unknown-freebsd", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))-,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))+,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ]