Commit 6a03d77b authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Use an empty data type in TTG extension constructors (#15247)

To avoid having to `panic` any time a TTG extension constructor is
consumed, this MR introduces an uninhabited 'NoExtCon' type and uses
that in every extension constructor's type family instance where it
is appropriate. This also introduces a 'noExtCon' function which
eliminates a 'NoExtCon', much like 'Data.Void.absurd' eliminates
a 'Void'.

I also renamed the existing `NoExt` type to `NoExtField` to better
distinguish it from `NoExtCon`. Unsurprisingly, there is a lot of
code churn resulting from this.

Bumps the Haddock submodule. Fixes #15247.
parent 5af815f2
Pipeline #8121 failed with stages
in 51 seconds
......@@ -375,12 +375,12 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc
match = cL combinedLoc $
Match { m_ext = noExt
Match { m_ext = noExtField
, m_ctxt = hs_ctx
, m_pats = []
, m_grhss = guards }
checkMatches dflags dsMatchContext [] [match]
checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"
checkGuardMatches _ (XGRHSs nec) = noExtCon nec
-- | Check a matchgroup (case, functions, etc.)
checkMatches :: DynFlags -> DsMatchContext
......@@ -1008,7 +1008,7 @@ translatePat fam_insts pat = case pat of
case res of
True -> do
(xp,xe) <- mkPmId2Forms arg_ty
g <- mkGuard ps (HsApp noExt lexpr xe)
g <- mkGuard ps (HsApp noExtField lexpr xe)
return [xp,g]
False -> mkCanFailPmPat arg_ty
......@@ -1066,7 +1066,7 @@ translatePat fam_insts pat = case pat of
, isStringTy ty ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
translatePatVec fam_insts
(map (LitPat noExt . HsChar src) (unpackFS s))
(map (LitPat noExtField . HsChar src) (unpackFS s))
| otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]
-- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
......@@ -1074,7 +1074,7 @@ translatePat fam_insts pat = case pat of
| HsString src s <- lit ->
foldr (mkListPatVec charTy) [nilPattern charTy] <$>
translatePatVec fam_insts
(map (LitPat noExt . HsChar src) (unpackFS s))
(map (LitPat noExtField . HsChar src) (unpackFS s))
| otherwise -> return [mkLitPattern lit]
TuplePat tys ps boxity -> do
......@@ -1312,7 +1312,7 @@ translateGuard fam_insts guard = case guard of
TransStmt {} -> panic "translateGuard TransStmt"
RecStmt {} -> panic "translateGuard RecStmt"
ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
XStmtLR {} -> panic "translateGuard RecStmt"
XStmtLR nec -> noExtCon nec
-- | Translate let-bindings
translateLet :: HsLocalBinds GhcTc -> DsM PatVec
......@@ -1713,7 +1713,7 @@ mkPmId ty = getUniqueM >>= \unique ->
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do
x <- mkPmId ty
return (PmVar x, noLoc (HsVar noExt (noLoc x)))
return (PmVar x, noLoc (HsVar noExtField (noLoc x)))
-- ----------------------------------------------------------------------------
-- * Converting between Value Abstractions, Patterns and PmExpr
......
......@@ -327,7 +327,7 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do
where
-- a binding is a simple pattern binding if it is a funbind with
-- zero patterns
isSimplePatBind :: HsBind a -> Bool
isSimplePatBind :: HsBind GhcTc -> Bool
isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-- TODO: Revisit this
......@@ -640,7 +640,7 @@ 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 _)) = panic "addTickTupArg"
addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec
addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884
......@@ -650,7 +650,7 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ mg { mg_alts = cL l matches' }
addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"
addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
......@@ -659,7 +659,7 @@ addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ match { m_grhss = gRHSs' }
addTickMatch _ _ (XMatch _) = panic "addTickMatch"
addTickMatch _ _ (XMatch nec) = noExtCon nec
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
......@@ -670,7 +670,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do
return $ GRHSs x guarded' (cL l local_binds')
where
binders = collectLocalBinders local_binds
addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"
addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
......@@ -678,7 +678,7 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr)
return $ GRHS x stmts' expr'
addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"
addTickGRHS _ _ (XGRHS nec) = noExtCon nec
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do
......@@ -757,7 +757,7 @@ addTickStmt isGuard stmt@(RecStmt {})
; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTickStmt _ (XStmtLR _) = panic "addTickStmt"
addTickStmt _ (XStmtLR nec) = noExtCon nec
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
......@@ -779,7 +779,7 @@ addTickApplicativeArg isGuard (op, arg) =
<$> addTickLStmts isGuard stmts
<*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
<*> addTickLPat pat
addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"
addTickArg (XApplicativeArg nec) = noExtCon nec
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
......@@ -788,7 +788,7 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds x binds) =
......@@ -841,7 +841,7 @@ addTickHsCmdTop (HsCmdTop x cmd) =
liftM2 HsCmdTop
(return x)
(addTickLHsCmd cmd)
addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
addTickHsCmdTop (XCmdTop nec) = noExtCon nec
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (dL->L pos c0) = do
......@@ -897,7 +897,7 @@ addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
addTickHsCmd (HsCmdWrap x w cmd)
= liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e)
addTickHsCmd (XCmd nec) = noExtCon nec
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
......@@ -907,14 +907,14 @@ addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ mg { mg_alts = cL l matches' }
addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"
addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ match { m_grhss = gRHSs' }
addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"
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
......@@ -924,7 +924,7 @@ addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do
return $ GRHSs x guarded' (cL l local_binds')
where
binders = collectLocalBinders local_binds
addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"
addTickCmdGRHSs (XGRHSs nec) = noExtCon nec
addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
-- The *guards* are *not* Cmds, although the body is
......@@ -933,7 +933,7 @@ addTickCmdGRHS (GRHS x stmts cmd)
= do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
stmts (addTickLHsCmd cmd)
; return $ GRHS x stmts' expr' }
addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS"
addTickCmdGRHS (XGRHS nec) = noExtCon nec
addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
-> TM [LStmt GhcTc (LHsCmd GhcTc)]
......@@ -980,8 +980,8 @@ addTickCmdStmt stmt@(RecStmt {})
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTickCmdStmt ApplicativeStmt{} =
panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
addTickCmdStmt XStmtLR{} =
panic "addTickCmdStmt XStmtLR"
addTickCmdStmt (XStmtLR nec) =
noExtCon nec
-- Others should never happen in a command context.
addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
......@@ -1175,7 +1175,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
(fvs, e) <- getFreeVars m
env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
return (cL pos (HsTick noExt tickish (cL pos e)))
return (cL pos (HsTick noExtField tickish (cL pos e)))
) (do
e <- m
return (cL pos e)
......@@ -1262,8 +1262,8 @@ mkBinTickBoxHpc boxLabel pos e =
c = tickBoxCount st
mes = mixEntries st
in
( cL pos $ HsTick noExt (HpcTick (this_mod env) c)
$ cL pos $ HsBinTick noExt (c+1) (c+2) e
( cL pos $ HsTick noExtField (HpcTick (this_mod env) c)
$ cL pos $ HsBinTick noExtField (c+1) (c+2) e
-- notice that F and T are reversed,
-- because we are building the list in
-- reverse...
......@@ -1292,9 +1292,9 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))
= length grhss
matchCount (dL->L _ (Match { m_grhss = XGRHSs _ }))
= panic "matchesOneOfMany"
matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany"
matchCount (dL->L _ (Match { m_grhss = XGRHSs nec }))
= noExtCon nec
matchCount (dL->L _ (XMatch nec)) = noExtCon nec
matchCount _ = panic "matchCount: Impossible Match" -- due to #15884
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
......
......@@ -412,7 +412,7 @@ dsRule (dL->L loc (HsRule { rd_name = name
; return (Just rule)
} } }
dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"
dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec
dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
......
......@@ -592,11 +592,11 @@ dsCmd ids local_vars stack_ty res_ty
left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName
let
left_id = HsConLikeOut noExt (RealDataCon left_con)
right_id = HsConLikeOut noExt (RealDataCon right_con)
left_expr ty1 ty2 e = noLoc $ HsApp noExt
left_id = HsConLikeOut noExtField (RealDataCon left_con)
right_id = HsConLikeOut noExtField (RealDataCon right_con)
left_expr ty1 ty2 e = noLoc $ HsApp noExtField
(noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
right_expr ty1 ty2 e = noLoc $ HsApp noExt
right_expr ty1 ty2 e = noLoc $ HsApp noExtField
(noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
......@@ -616,7 +616,7 @@ dsCmd ids local_vars stack_ty res_ty
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase noExt exp
core_body <- dsExpr (HsCase noExtField exp
(MG { mg_alts = cL l matches'
, mg_ext = MatchGroupTc arg_tys sum_ty
, mg_origin = origin }))
......@@ -1167,7 +1167,7 @@ replaceLeavesMatch _res_ty leaves
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
(leaves', cL loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))
(leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))
replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
replaceLeavesGRHS
......
......@@ -198,7 +198,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
dsHsBind _ (XHsBindsLR nec) = noExtCon nec
-----------------------
......@@ -258,7 +258,7 @@ dsAbsBinds dflags tyvars dicts exports
; return (makeCorePair dflags global
(isDefaultMethod prags)
0 (core_wrap (Var local))) }
mk_bind (XABExport _) = panic "dsAbsBinds"
mk_bind (XABExport nec) = noExtCon nec
; main_binds <- mapM mk_bind exports
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
......@@ -303,7 +303,7 @@ dsAbsBinds dflags tyvars dicts exports
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
; return ((global', rhs) : fromOL spec_binds) }
mk_bind (XABExport _) = panic "dsAbsBinds"
mk_bind (XABExport nec) = noExtCon nec
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
......@@ -351,7 +351,7 @@ dsAbsBinds dflags tyvars dicts exports
mk_export local =
do global <- newSysLocalDs
(exprType (mkLams tyvars (mkLams dicts (Var local))))
return (ABE { abe_ext = noExt
return (ABE { abe_ext = noExtField
, abe_poly = global
, abe_mono = local
, abe_wrap = WpHole
......
......@@ -98,7 +98,7 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
ds_ip_bind _ _ = panic "dsIPBinds"
dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
dsIPBinds (XHsIPBinds nec) _ = noExtCon nec
-------------------------
-- caller sets location
......@@ -451,7 +451,7 @@ ds_expr _ (HsMultiIf res_ty alts)
| otherwise
= do { match_result <- liftM (foldr1 combineMatchResults)
(mapM (dsGRHS IfAlt res_ty) alts)
; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))
; checkGuardMatches IfAlt (GRHSs noExtField alts (noLoc emptyLocalBinds))
; error_expr <- mkErrorExpr
; extractMatchResult match_result error_expr }
where
......@@ -663,7 +663,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
mk_val_arg fl pat_arg_id
= nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con)
-- Reconstruct with the WrapId so that unpacking happens
wrap = mkWpEvVarApps theta_vars <.>
dict_req_wrap <.>
......@@ -754,7 +754,7 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
ds_expr _ (XExpr {}) = panic "dsExpr: XExpr"
ds_expr _ (XExpr nec) = noExtCon nec
------------------------------
......@@ -927,7 +927,7 @@ dsDo stmts
(pat, dsLExpr expr)
do_arg (ApplicativeArgMany _ stmts ret pat) =
(pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
do_arg (XApplicativeArg _) = panic "dsDo"
do_arg (XApplicativeArg nec) = noExtCon nec
arg_tys = map hsLPatType pats
......@@ -935,7 +935,7 @@ dsDo stmts
; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
; let fun = cL noSrcSpan $ HsLam noExt $
; let fun = cL noSrcSpan $ HsLam noExtField $
MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
body']
, mg_ext = MatchGroupTc arg_tys body_ty
......@@ -967,13 +967,13 @@ dsDo stmts
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
mfix_arg = noLoc $ HsLam noExt
mfix_arg = noLoc $ HsLam noExtField
(MG { mg_alts = noLoc [mkSimpleMatch
LambdaExpr
[mfix_pat] body]
, mg_ext = MatchGroupTc [tup_ty] body_ty
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
body = noLoc $ HsDo body_ty
DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
......@@ -984,7 +984,7 @@ dsDo stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
go _ (XStmtLR {}) _ = panic "dsDo XStmtLR"
go _ (XStmtLR nec) _ = noExtCon nec
handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
......
......@@ -112,7 +112,7 @@ dsForeigns' fos = do
(dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
do_decl (XForeignDecl _) = panic "dsForeigns'"
do_decl (XForeignDecl nec) = noExtCon nec
{-
************************************************************************
......
......@@ -64,13 +64,13 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
-- NB: nested dsLet inside matchResult
; return match_result2 }
dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"
dsGRHSs _ (XGRHSs nec) _ = noExtCon nec
dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"
dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec
dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
{-
......@@ -138,8 +138,8 @@ matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
matchGuards (ApplicativeStmt {} : _) _ _ _ =
panic "matchGuards ApplicativeLastStmt"
matchGuards (XStmtLR {} : _) _ _ _ =
panic "matchGuards XStmtLR"
matchGuards (XStmtLR nec : _) _ _ _ =
noExtCon nec
{-
Should {\em fail} if @e@ returns @D@
......
......@@ -91,7 +91,7 @@ dsInnerListComp (ParStmtBlock _ stmts bndrs _)
; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
; return (expr, bndrs_tuple_type) }
dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
dsInnerListComp (XParStmtBlock nec) = noExtCon nec
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
......@@ -107,7 +107,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
(expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
(expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts
from_bndrs noSyntaxExpr)
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
......@@ -267,8 +267,8 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
deListComp (ApplicativeStmt {} : _) _ =
panic "deListComp ApplicativeStmt"
deListComp (XStmtLR {} : _) _ =
panic "deListComp XStmtLR"
deListComp (XStmtLR nec : _) _ =
noExtCon nec
deBindComp :: OutPat GhcTc
-> CoreExpr
......@@ -364,8 +364,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
dfListComp _ _ (ApplicativeStmt {} : _) =
panic "dfListComp ApplicativeStmt"
dfListComp _ _ (XStmtLR {} : _) =
panic "dfListComp XStmtLR"
dfListComp _ _ (XStmtLR nec : _) =
noExtCon nec
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat GhcTc, CoreExpr)
......@@ -596,7 +596,7 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
ds_inner (ParStmtBlock _ stmts bndrs return_op)
= do { exp <- dsInnerMonadComp stmts bndrs return_op
; return (exp, mkBigCoreVarTupTy bndrs) }
ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
ds_inner (XParStmtBlock nec) = noExtCon nec
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
......@@ -655,7 +655,7 @@ dsInnerMonadComp :: [ExprLStmt GhcTc]
-> DsM CoreExpr
dsInnerMonadComp stmts bndrs ret_op
= dsMcStmts (stmts ++
[noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)])
[noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) False ret_op)])
-- The `unzip` function for `GroupStmt` in a monad comprehensions
......
This diff is collapsed.
......@@ -955,7 +955,7 @@ decideBangHood dflags lpat
ParPat x p -> cL l (ParPat x (go p))
LazyPat _ lp' -> lp'
BangPat _ _ -> lp
_ -> cL l (BangPat noExt lp)
_ -> cL l (BangPat noExtField lp)
-- | Unconditionally make a 'Pat' strict.
addBang :: LPat GhcTc -- ^ Original pattern
......@@ -965,10 +965,10 @@ addBang = go
go lp@(dL->L l p)
= case p of
ParPat x p -> cL l (ParPat x (go p))
LazyPat _ lp' -> cL l (BangPat noExt lp')
LazyPat _ lp' -> cL l (BangPat noExtField lp')
-- Should we bring the extension value over?
BangPat _ _ -> lp
_ -> cL l (BangPat noExt lp)
_ -> cL l (BangPat noExtField lp)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
......
......@@ -137,7 +137,7 @@ sigNameNoLoc _ = []
-- Extract the source location where an instance is defined. This is used
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
getInstLoc :: InstDecl name -> SrcSpan
getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
getInstLoc = \case
ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
DataFamInstD _ (DataFamInstDecl
......@@ -234,10 +234,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
where
decls = docs ++ defs ++ sigs ++ ats
docs = mkDecls tcdDocs (DocD noExt) class_
defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
sigs = mkDecls tcdSigs (SigD noExt) class_
ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
docs = mkDecls tcdDocs (DocD noExtField) class_
defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
sigs = mkDecls tcdSigs (SigD noExtField) class_
ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
-- | Extract function argument docs from inside top-level decls.
declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
......@@ -280,14 +280,14 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
ungroup group_ =
mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++
mkDecls hs_derivds (DerivD noExt) group_ ++
mkDecls hs_defds (DefD noExt) group_ ++
mkDecls hs_fords (ForD noExt) group_ ++
mkDecls hs_docs (DocD noExt) group_ ++
mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++
mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++
mkDecls (valbinds . hs_valds) (ValD noExt) group_
mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++
mkDecls hs_derivds (DerivD noExtField) group_ ++
mkDecls hs_defds (DefD noExtField) group_ ++
mkDecls hs_fords (ForD noExtField) group_ ++
mkDecls hs_docs (DocD noExtField) group_ ++
mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++
mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
mkDecls (valbinds . hs_valds) (ValD noExtField) group_
where
typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs
typesigs ValBinds{} = error "expected XValBindsLR"
......
......@@ -501,9 +501,9 @@ tidy_bang_pat v o _ (SigPat _ (dL->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 noExt p)))
= tidy1 v o (AsPat x v' (cL l (BangPat noExtField p)))
tidy_bang_pat v o l (CoPat x w p t)
= tidy1 v o (CoPat x w (BangPat noExt (cL l p)) t)
= tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t)
-- Discard bang around strict pattern
tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
......@@ -538,7 +538,7 @@ tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))
--
-- NB: SigPatIn, ConPatIn should not happen
tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExt (cL l p))
tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p))
-------------------
push_bang_into_newtype_arg :: SrcSpan
......@@ -549,16 +549,16 @@ push_bang_into_newtype_arg :: SrcSpan
-- 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 noExt arg)]
PrefixCon [cL l (BangPat noExtField arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
| HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
= ASSERT( null flds)
RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg
= cL l (BangPat noExt arg) })] })
= cL 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 noExt (noLoc (WildPat ty)))]
= PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
......@@ -752,13 +752,13 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
; return (EqnInfo { eqn_pats = upats
, eqn_orig = FromSource
, eqn_rhs = match_result }) }
mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper"
mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec
mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884
handleWarnings = if isGenerated origin
then discardWarningsDs
else id
matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"
matchWrapper _ _ (XMatchGroup nec) = noExtCon nec
matchEquations :: HsMatchContext Name
-> [MatchId] -> [EquationInfo] -> Type
......
......@@ -95,7 +95,7 @@ dsLit l = do
HsString _ str -> mkStringExprFS str
HsInteger _ i _ -> mkIntegerExpr i
HsInt _ i -> return (mkIntExpr dflags (il_value i))
XLit x -> pprPanic "dsLit" (ppr x)
XLit nec -> noExtCon nec
HsRat _ (FL _ _ val) ty -> do
num <- mkIntegerExpr (numerator val)
denom <- mkIntegerExpr (denominator val)
......@@ -116,7 +116,7 @@ dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
case shortCutLit dflags val ty of
Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut]
_ -> dsExpr witness
dsOverLit XOverLit{} = panic "dsOverLit"
dsOverLit (XOverLit nec) = noExtCon nec
{-
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -337,7 +337,7 @@ tidyLitPat (HsString src s)
(mkNilPat charTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
tidyLitPat lit = LitPat noExt lit
tidyLitPat lit = LitPat noExtField lit
----------------
tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
......@@ -373,7 +373,7 @@ tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
mk_con_pat con lit
= unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])
= unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
......
......@@ -283,7 +283,7 @@ type family ProtectedSig a where
ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
GhcRn
(Shielded (LHsType GhcRn)))
ProtectedSig GhcTc = NoExt
ProtectedSig GhcTc = NoExtField
class ProtectSig a where
protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
......@@ -295,7 +295,7 @@ instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
instance ProtectSig GhcTc where
protectSig _ _ = NoExt
protectSig _ _ = noExtField
instance ProtectSig GhcRn where
protectSig sc (HsWC a (HsIB b sig)) =
......@@ -368,10 +368,10 @@ instance (ToHie a) => ToHie (Bag a) where
instance (ToHie a) => ToHie (Maybe a) where
toHie = maybe (pure []) toHie
instance ToHie (Context (Located NoExt)) where
instance ToHie (Context (Located NoExtField)) where
toHie _ = pure []
instance ToHie (TScoped NoExt) where
instance ToHie (TScoped NoExtField) where