diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2019-03-19 21:47:55 (GMT) |
|---|---|---|
| committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2019-03-19 21:47:57 (GMT) |
| commit | 2d9e36d51f76445ea7f459b6c454750110a65df0 (patch) | |
| tree | c0e30d020ef2a238cc428dd49c4238c872372076 | |
| parent | 6113d0d4540af7853c71e9f42a41c3b0bab386fd (diff) | |
| download | ghc-wip/T15247.zip ghc-wip/T15247.tar.gz ghc-wip/T15247.tar.bz2 | |
WIP: NoExtCon (#15247)wip/T15247
[ci skip]
52 files changed, 486 insertions, 441 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index db3a501..4ced312 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -360,7 +360,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do , 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 @@ -1302,7 +1302,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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index d140829..a86cec8 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -326,7 +326,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 @@ -639,7 +639,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 @@ -649,7 +649,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)) @@ -658,7 +658,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)) @@ -669,7 +669,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)) @@ -677,7 +677,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 @@ -756,7 +756,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 @@ -778,7 +778,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) @@ -787,7 +787,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) = @@ -840,7 +840,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 @@ -896,7 +896,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) @@ -906,14 +906,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 @@ -923,7 +923,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 @@ -932,7 +932,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)] @@ -979,8 +979,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) @@ -1293,9 +1293,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) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 128722d..2c0b413 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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 () diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index cf94a5e..d2de1d2 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -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) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 89ca815..17ffb24 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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 @@ -758,7 +758,7 @@ ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" -ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" +ds_expr _ (XExpr nec) = noExtCon nec ------------------------------ @@ -931,7 +931,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 @@ -988,7 +988,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 diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 95a5e4a..321818d 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -113,7 +113,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 {- ************************************************************************ diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 277ea00..5adc661 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -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@ diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index f376ef0..a8320af 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -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 @@ -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) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 5de954a..1d5afea 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -84,7 +84,7 @@ dsBracket brack splices do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket" + do_brack (XBracket nec) = noExtCon nec {- -------------- Examples -------------------- @@ -178,7 +178,7 @@ repTopDs group@(HsGroup { hs_valds = valds no_warn _ = panic "repTopDs" no_doc (dL->L loc _) = notHandledL loc "Haddock documentation" empty -repTopDs (XHsGroup _) = panic "repTopDs" +repTopDs (XHsGroup nec) = noExtCon nec hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings] @@ -208,8 +208,8 @@ get_scoped_tvs (dL->L _ signature) , hsib_body = hs_ty } <- sig , (explicit_vars, _) <- splitLHsForAllTy hs_ty = implicit_vars ++ hsLTyVarNames explicit_vars - get_scoped_tvs_from_sig (XHsImplicitBndrs _) - = panic "get_scoped_tvs_from_sig" + get_scoped_tvs_from_sig (XHsImplicitBndrs nec) + = noExtCon nec {- Notes @@ -374,7 +374,7 @@ repDataDefn tc opts ; repData cxt1 tc opts ksig' cons1 derivs1 } } -repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn" +repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] -> LHsType GhcRn @@ -425,7 +425,7 @@ repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki ; repKindSig ki' } repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr ; repTyVarSig bndr' } -repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig" +repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named @@ -538,7 +538,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds ; wrapGenSyms ss decls2 } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty -repClsInstD (XClsInstDecl _) = panic "repClsInstD" +repClsInstD (XClsInstDecl nec) = noExtCon nec repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat @@ -583,8 +583,8 @@ repTyFamEqn (HsIB { hsib_ext = var_names where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] checkTys tys@(HsValArg _:HsValArg _:_) = return tys checkTys _ = panic "repTyFamEqn:checkTys" -repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn" -repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn" +repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec +repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ) repTyArgs f [] = f @@ -623,10 +623,10 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn = checkTys tys@(HsValArg _: HsValArg _: _) = return tys checkTys _ = panic "repDataFamInstD:checkTys" -repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _)) - = panic "repDataFamInstD" -repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _))) - = panic "repDataFamInstD" +repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec +repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) + = noExtCon nec repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ @@ -721,7 +721,7 @@ ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) = panic "ruleBndrNames" ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) = panic "ruleBndrNames" -ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames" +ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884 repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) @@ -914,7 +914,7 @@ rep_ty_sig mk_sig loc sig_ty nm else repTForall th_explicit_tvs th_ctxt th_ty ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } -rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig" +rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) @@ -943,7 +943,7 @@ rep_patsyn_ty_sig loc sig_ty nm repTForall th_exis th_provs th_ty ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } -rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig" +rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) @@ -1051,7 +1051,7 @@ addTyVarBinds (HsQTvs { hsq_ext = imp_tvs = addSimpleTyVarBinds imp_tvs $ addHsTyVarBinds exp_tvs $ thing_inside -addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds" +addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec addTyClTyVarBinds :: LHsQTyVars GhcRn -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) @@ -1122,12 +1122,12 @@ repHsSigType (HsIB { hsib_ext = implicit_tvs ; if null explicit_tvs && null (unLoc ctxt) then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } -repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType" +repHsSigType (XHsImplicitBndrs nec) = noExtCon nec repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1 -repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType" +repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] @@ -1252,7 +1252,7 @@ repSplice (HsUntypedSplice _ _ n _) = rep_splice n repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e) -repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e) +repSplice (XSplice nec) = noExtCon nec rep_splice :: Name -> DsM (Core a) rep_splice splice_name @@ -1440,7 +1440,7 @@ repClauseTup (dL->L _ (Match { m_pats = ps gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup" +repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec repClauseTup _ = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) @@ -1547,7 +1547,7 @@ repSts (ParStmt _ stmt_blocks _ _ : ss) = do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs ; return (ss1, zs1) } - rep_stmt_block (XParStmtBlock{}) = panic "repSts" + rep_stmt_block (XParStmtBlock nec) = noExtCon nec repSts [LastStmt _ e _ _] = do { e2 <- repLE e ; z <- repNoBindSt e2 @@ -1657,7 +1657,7 @@ rep_bind (dL->L loc (FunBind { fun_id = fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind" +rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec rep_bind (dL->L loc (PatBind { pat_lhs = pat , pat_rhs = GRHSs _ guards (dL->L _ wheres) })) @@ -1667,7 +1667,7 @@ rep_bind (dL->L loc (PatBind { pat_lhs = pat ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind" +rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v @@ -1717,9 +1717,9 @@ rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec -rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _))) - = panic "rep_bind: XPatSynBind" -rep_bind (dL->L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR" +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 @@ -1760,7 +1760,7 @@ repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } -repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir" +repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] @@ -2629,7 +2629,7 @@ repOverloadedLiteral (OverLit { ol_val = val}) -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used -repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral" +repOverloadedLiteral (XOverLit nec) = noExtCon nec mk_lit :: OverLitVal -> DsM (HsLit GhcRn) mk_lit (HsIntegral i) = mk_integer (il_value i) diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index 4a5e890..efea624 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -136,7 +136,8 @@ 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 :: (XXHsImplicitBndrs name (LHsType name) ~ NoExtCon) + => InstDecl name -> SrcSpan getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) DataFamInstD _ (DataFamInstDecl diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index c0572984..7a24658 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -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 diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index d99ae7e..b518d79 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 2ab2acb..749e104 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -1172,7 +1172,7 @@ instance ToHie (LTyClDecl GhcRn) where -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn) go (FamEqn a var bndrs pat b rhs) = FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs - go (XFamEqn NoExt) = XFamEqn NoExt + go (XFamEqn nec) = noExtCon nec XTyClDecl _ -> [] instance ToHie (LFamilyDecl GhcRn) where diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 77ffebe..72d672d 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -595,7 +595,7 @@ cvtConstr (ForallC tvs ctxt con) where all_tvs = hsQTvExplicit tvs' ++ ex_tvs - add_forall _ _ (XConDecl _) = panic "cvtConstr" + add_forall _ _ (XConDecl nec) = noExtCon nec cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 8e3448d..3948d3d 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -96,7 +96,7 @@ data HsLocalBindsLR idL idR type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExt type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExt type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt -type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) @@ -329,7 +329,7 @@ type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt -type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] @@ -356,7 +356,7 @@ data ABExport p | XABExport (XXABExport p) type instance XABE (GhcPass p) = NoExt -type instance XXABExport (GhcPass p) = NoExt +type instance XXABExport (GhcPass p) = NoExtCon -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', @@ -382,7 +382,7 @@ type instance XPSB (GhcPass idL) GhcPs = NoExt type instance XPSB (GhcPass idL) GhcRn = NameSet type instance XPSB (GhcPass idL) GhcTc = NameSet -type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon {- Note [AbsBinds] @@ -829,7 +829,7 @@ type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the -- implicit parameters -type instance XXHsIPBinds (GhcPass p) = NoExt +type instance XXHsIPBinds (GhcPass p) = NoExtCon isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool isEmptyIPBindsPR (IPBinds _ is) = null is @@ -864,7 +864,7 @@ data IPBind id | XIPBind (XXIPBind id) type instance XCIPBind (GhcPass p) = NoExt -type instance XXIPBind (GhcPass p) = NoExt +type instance XXIPBind (GhcPass p) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsIPBinds p) where @@ -1057,7 +1057,7 @@ type instance XSpecInstSig (GhcPass p) = NoExt type instance XMinimalSig (GhcPass p) = NoExt type instance XSCCFunSig (GhcPass p) = NoExt type instance XCompleteMatchSig (GhcPass p) = NoExt -type instance XXSig (GhcPass p) = NoExt +type instance XXSig (GhcPass p) = NoExtCon -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) @@ -1067,7 +1067,7 @@ data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity | XFixitySig (XXFixitySig pass) type instance XFixitySig (GhcPass p) = NoExt -type instance XXFixitySig (GhcPass p) = NoExt +type instance XXFixitySig (GhcPass p) = NoExtCon -- | Type checker Specialisation Pragmas -- diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index d4742f5..69ca093 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -159,7 +159,7 @@ type instance XRuleD (GhcPass _) = NoExt type instance XSpliceD (GhcPass _) = NoExt type instance XDocD (GhcPass _) = NoExt type instance XRoleAnnotD (GhcPass _) = NoExt -type instance XXHsDecl (GhcPass _) = NoExt +type instance XXHsDecl (GhcPass _) = NoExtCon -- NB: all top-level fixity decls are contained EITHER -- EITHER SigDs @@ -207,7 +207,7 @@ data HsGroup p | XHsGroup (XXHsGroup p) type instance XCHsGroup (GhcPass _) = NoExt -type instance XXHsGroup (GhcPass _) = NoExt +type instance XXHsGroup (GhcPass _) = NoExtCon emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) @@ -330,7 +330,7 @@ data SpliceDecl p | XSpliceDecl (XXSpliceDecl p) type instance XSpliceDecl (GhcPass _) = NoExt -type instance XXSpliceDecl (GhcPass _) = NoExt +type instance XXSpliceDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (SpliceDecl p) where @@ -588,7 +588,7 @@ type instance XClassDecl GhcPs = NoExt type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs -type instance XXTyClDecl (GhcPass _) = NoExt +type instance XXTyClDecl (GhcPass _) = NoExtCon -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -639,17 +639,21 @@ isDataFamilyDecl _other = False -- Dealing with names -tyFamInstDeclName :: TyFamInstDecl pass -> (IdP pass) +tyFamInstDeclName :: ( XXFamEqn pass (HsTyPats pass) (LHsType pass) ~ NoExtCon + , XXHsImplicitBndrs pass (FamEqn pass (HsTyPats pass) (LHsType pass)) ~ NoExtCon ) + => TyFamInstDecl pass -> IdP pass tyFamInstDeclName = unLoc . tyFamInstDeclLName -tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass) +tyFamInstDeclLName :: ( XXFamEqn pass (HsTyPats pass) (LHsType pass) ~ NoExtCon + , XXHsImplicitBndrs pass (FamEqn pass (HsTyPats pass) (LHsType pass)) ~ NoExtCon ) + => TyFamInstDecl pass -> Located (IdP pass) tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) = ln -tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _))) - = panic "tyFamInstDeclLName" -tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _)) - = panic "tyFamInstDeclLName" +tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec))) + = noExtCon nec +tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec tyClDeclLName :: TyClDecl pass -> Located (IdP pass) tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln @@ -693,7 +697,7 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) _ -> False hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" +hsDeclHasCusk (XTyClDecl nec) = noExtCon nec -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -899,7 +903,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis] | XTyClGroup (XXTyClGroup pass) type instance XCTyClGroup (GhcPass _) = NoExt -type instance XXTyClGroup (GhcPass _) = NoExt +type instance XXTyClGroup (GhcPass _) = NoExtCon emptyTyClGroup :: TyClGroup (GhcPass p) @@ -1022,7 +1026,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig] type instance XNoSig (GhcPass _) = NoExt type instance XCKindSig (GhcPass _) = NoExt type instance XTyVarSig (GhcPass _) = NoExt -type instance XXFamilyResultSig (GhcPass _) = NoExt +type instance XXFamilyResultSig (GhcPass _) = NoExtCon -- | Located type Family Declaration @@ -1050,7 +1054,7 @@ data FamilyDecl pass = FamilyDecl -- For details on above see note [Api annotations] in ApiAnnotation type instance XCFamilyDecl (GhcPass _) = NoExt -type instance XXFamilyDecl (GhcPass _) = NoExt +type instance XXFamilyDecl (GhcPass _) = NoExtCon -- | Located Injectivity Annotation @@ -1082,7 +1086,7 @@ data FamilyInfo pass -- See Note [CUSKs: complete user-supplied kind signatures] famDeclHasCusk :: Bool -- ^ True <=> this is an associated type family, -- and the parent class has /no/ CUSK - -> FamilyDecl pass + -> FamilyDecl (GhcPass pass) -> Bool famDeclHasCusk assoc_with_no_cusk (FamilyDecl { fdInfo = fam_info @@ -1095,7 +1099,7 @@ famDeclHasCusk assoc_with_no_cusk -- Un-associated open type/data families have CUSKs -- Associated type families have CUSKs iff the parent class does -famDeclHasCusk _ (XFamilyDecl {}) = panic "famDeclHasCusk" +famDeclHasCusk _ (XFamilyDecl nec) = noExtCon nec -- | Does this family declaration have user-supplied return kind signature? hasReturnKindSignature :: FamilyResultSig a -> Bool @@ -1104,7 +1108,8 @@ hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False hasReturnKindSignature _ = True -- | Maybe return name of the result type variable -resultVariableName :: FamilyResultSig a -> Maybe (IdP a) +resultVariableName :: (XXTyVarBndr a ~ NoExtCon) + => FamilyResultSig a -> Maybe (IdP a) resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing @@ -1198,7 +1203,7 @@ data HsDataDefn pass -- The payload of a data type defn | XHsDataDefn (XXHsDataDefn pass) type instance XCHsDataDefn (GhcPass _) = NoExt -type instance XXHsDataDefn (GhcPass _) = NoExt +type instance XXHsDataDefn (GhcPass _) = NoExtCon -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] @@ -1238,7 +1243,7 @@ data HsDerivingClause pass | XHsDerivingClause (XXHsDerivingClause pass) type instance XCHsDerivingClause (GhcPass _) = NoExt -type instance XXHsDerivingClause (GhcPass _) = NoExt +type instance XXHsDerivingClause (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDerivingClause p) where @@ -1349,7 +1354,7 @@ data ConDecl pass type instance XConDeclGADT (GhcPass _) = NoExt type instance XConDeclH98 (GhcPass _) = NoExt -type instance XXConDecl (GhcPass _) = NoExt +type instance XXConDecl (GhcPass _) = NoExtCon {- Note [GADT abstract syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1392,10 +1397,11 @@ There's a wrinkle in ConDeclGADT type HsConDeclDetails pass = HsConDetails (LBangType pass) (Located [LConDeclField pass]) -getConNames :: ConDecl pass -> [Located (IdP pass)] +getConNames :: (XXConDecl pass ~ NoExtCon) + => ConDecl pass -> [Located (IdP pass)] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -getConNames XConDecl {} = panic "getConNames" +getConNames (XConDecl nec) = noExtCon nec getConArgs :: ConDecl pass -> HsConDeclDetails pass getConArgs d = con_args d @@ -1642,7 +1648,7 @@ data FamEqn pass pats rhs -- For details on above see note [Api annotations] in ApiAnnotation type instance XCFamEqn (GhcPass _) p r = NoExt -type instance XXFamEqn (GhcPass _) p r = NoExt +type instance XXFamEqn (GhcPass _) p r = NoExtCon ----------------- Class instances ------------- @@ -1675,7 +1681,7 @@ data ClsInstDecl pass | XClsInstDecl (XXClsInstDecl pass) type instance XCClsInstDecl (GhcPass _) = NoExt -type instance XXClsInstDecl (GhcPass _) = NoExt +type instance XXClsInstDecl (GhcPass _) = NoExtCon ----------------- Instances of all kinds ------------- @@ -1698,7 +1704,7 @@ data InstDecl pass -- Both class and family instances type instance XClsInstD (GhcPass _) = NoExt type instance XDataFamInstD (GhcPass _) = NoExt type instance XTyFamInstD (GhcPass _) = NoExt -type instance XXInstDecl (GhcPass _) = NoExt +type instance XXInstDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyFamInstDecl p) where @@ -1840,7 +1846,9 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where -- Extract the declarations of associated data types from an instance -instDeclDataFamInsts :: [LInstDecl pass] -> [DataFamInstDecl pass] +instDeclDataFamInsts :: ( XXClsInstDecl pass ~ NoExtCon + , XXInstDecl pass ~ NoExtCon ) + => [LInstDecl pass] -> [DataFamInstDecl pass] instDeclDataFamInsts inst_decls = concatMap do_one inst_decls where @@ -1848,8 +1856,8 @@ instDeclDataFamInsts inst_decls = map unLoc fam_insts do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] - do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts" - do_one (L _ (XInstDecl _)) = panic "instDeclDataFamInsts" + do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec + do_one (L _ (XInstDecl nec)) = noExtCon nec {- ************************************************************************ @@ -1889,7 +1897,7 @@ data DerivDecl pass = DerivDecl | XDerivDecl (XXDerivDecl pass) type instance XCDerivDecl (GhcPass _) = NoExt -type instance XXDerivDecl (GhcPass _) = NoExt +type instance XXDerivDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DerivDecl p) where @@ -1972,7 +1980,7 @@ data DefaultDecl pass | XDefaultDecl (XXDefaultDecl pass) type instance XCDefaultDecl (GhcPass _) = NoExt -type instance XXDefaultDecl (GhcPass _) = NoExt +type instance XXDefaultDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DefaultDecl p) where @@ -2035,7 +2043,7 @@ type instance XForeignExport GhcPs = NoExt type instance XForeignExport GhcRn = NoExt type instance XForeignExport GhcTc = Coercion -type instance XXForeignDecl (GhcPass _) = NoExt +type instance XXForeignDecl (GhcPass _) = NoExtCon -- Specification Of an imported external entity in dependence on the calling -- convention @@ -2143,7 +2151,7 @@ data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass | XRuleDecls (XXRuleDecls pass) type instance XCRuleDecls (GhcPass _) = NoExt -type instance XXRuleDecls (GhcPass _) = NoExt +type instance XXRuleDecls (GhcPass _) = NoExtCon -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) @@ -2180,7 +2188,7 @@ type instance XHsRule GhcPs = NoExt type instance XHsRule GhcRn = HsRuleRn type instance XHsRule GhcTc = HsRuleRn -type instance XXRuleDecl (GhcPass _) = NoExt +type instance XXRuleDecl (GhcPass _) = NoExtCon flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls @@ -2201,7 +2209,7 @@ data RuleBndr pass type instance XCRuleBndr (GhcPass _) = NoExt type instance XRuleBndrSig (GhcPass _) = NoExt -type instance XXRuleBndr (GhcPass _) = NoExt +type instance XXRuleBndr (GhcPass _) = NoExtCon collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] @@ -2290,7 +2298,7 @@ data WarnDecls pass = Warnings { wd_ext :: XWarnings pass | XWarnDecls (XXWarnDecls pass) type instance XWarnings (GhcPass _) = NoExt -type instance XXWarnDecls (GhcPass _) = NoExt +type instance XXWarnDecls (GhcPass _) = NoExtCon -- | Located Warning pragma Declaration type LWarnDecl pass = Located (WarnDecl pass) @@ -2300,7 +2308,7 @@ data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt | XWarnDecl (XXWarnDecl pass) type instance XWarning (GhcPass _) = NoExt -type instance XXWarnDecl (GhcPass _) = NoExt +type instance XXWarnDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass,OutputableBndr (IdP p)) @@ -2342,7 +2350,7 @@ data AnnDecl pass = HsAnnotation | XAnnDecl (XXAnnDecl pass) type instance XHsAnnotation (GhcPass _) = NoExt -type instance XXAnnDecl (GhcPass _) = NoExt +type instance XXAnnDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where ppr (HsAnnotation _ _ provenance expr) @@ -2395,7 +2403,7 @@ data RoleAnnotDecl pass | XRoleAnnotDecl (XXRoleAnnotDecl pass) type instance XCRoleAnnotDecl (GhcPass _) = NoExt -type instance XXRoleAnnotDecl (GhcPass _) = NoExt +type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndr (IdP p)) => Outputable (RoleAnnotDecl p) where @@ -2407,6 +2415,7 @@ instance (p ~ GhcPass pass, OutputableBndr (IdP p)) pp_role (Just r) = ppr r ppr (XRoleAnnotDecl x) = ppr x -roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass) +roleAnnotDeclName :: (XXRoleAnnotDecl pass ~ NoExtCon) + => RoleAnnotDecl pass -> IdP pass roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name -roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName" +roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index bd63150..f72c126 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -771,7 +771,7 @@ type instance XEAsPat (GhcPass _) = NoExt type instance XEViewPat (GhcPass _) = NoExt type instance XELazyPat (GhcPass _) = NoExt type instance XWrap (GhcPass _) = NoExt -type instance XXExpr (GhcPass _) = NoExt +type instance XXExpr (GhcPass _) = NoExtCon -- --------------------------------------------------------------------- @@ -798,7 +798,7 @@ type instance XMissing GhcPs = NoExt type instance XMissing GhcRn = NoExt type instance XMissing GhcTc = Type -type instance XXTupArg (GhcPass _) = NoExt +type instance XXTupArg (GhcPass _) = NoExtCon tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True @@ -1366,7 +1366,7 @@ type instance XCmdDo GhcRn = NoExt type instance XCmdDo GhcTc = Type type instance XCmdWrap (GhcPass _) = NoExt -type instance XXCmd (GhcPass _) = NoExt +type instance XXCmd (GhcPass _) = NoExtCon -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1396,7 +1396,7 @@ type instance XCmdTop GhcPs = NoExt type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc -type instance XXCmdTop (GhcPass _) = NoExt +type instance XXCmdTop (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where ppr cmd = pprCmd cmd @@ -1546,7 +1546,7 @@ type instance XMG GhcPs b = NoExt type instance XMG GhcRn b = NoExt type instance XMG GhcTc b = MatchGroupTc -type instance XXMatchGroup (GhcPass _) b = NoExt +type instance XXMatchGroup (GhcPass _) b = NoExtCon -- | Located Match type LMatch id body = Located (Match id body) @@ -1565,7 +1565,7 @@ data Match p body | XMatch (XXMatch p body) type instance XCMatch (GhcPass _) b = NoExt -type instance XXMatch (GhcPass _) b = NoExt +type instance XXMatch (GhcPass _) b = NoExtCon instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) => Outputable (Match idR body) where @@ -1613,9 +1613,10 @@ isInfixMatch match = case m_ctxt match of FunRhs {mc_fixity = Infix} -> True _ -> False -isEmptyMatchGroup :: MatchGroup id body -> Bool +isEmptyMatchGroup :: (XXMatchGroup id body ~ NoExtCon) + => MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms -isEmptyMatchGroup (XMatchGroup{}) = panic "isEmptyMatchGroup" +isEmptyMatchGroup (XMatchGroup nec) = noExtCon nec -- | Is there only one RHS in this list of matches? isSingletonMatchGroup :: [LMatch id body] -> Bool @@ -1626,17 +1627,20 @@ isSingletonMatchGroup matches | otherwise = False -matchGroupArity :: MatchGroup id body -> Arity +matchGroupArity :: ( XXMatch id body ~ NoExtCon + , XXMatchGroup id body ~ NoExtCon ) + => MatchGroup id body -> Arity -- Precondition: MatchGroup is non-empty -- This is called before type checking, when mg_arg_tys is not set matchGroupArity (MG { mg_alts = alts }) | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) | otherwise = panic "matchGroupArity" -matchGroupArity (XMatchGroup{}) = panic "matchGroupArity" +matchGroupArity (XMatchGroup nec) = noExtCon nec -hsLMatchPats :: LMatch id body -> [LPat id] +hsLMatchPats :: (XXMatch id body ~ NoExtCon) + => LMatch id body -> [LPat id] hsLMatchPats (L _ (Match { m_pats = pats })) = pats -hsLMatchPats (L _ (XMatch _)) = panic "hsLMatchPats" +hsLMatchPats (L _ (XMatch nec)) = noExtCon nec -- | Guarded Right-Hand Sides -- @@ -1657,7 +1661,7 @@ data GRHSs p body | XGRHSs (XXGRHSs p body) type instance XCGRHSs (GhcPass _) b = NoExt -type instance XXGRHSs (GhcPass _) b = NoExt +type instance XXGRHSs (GhcPass _) b = NoExtCon -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) @@ -1669,7 +1673,7 @@ data GRHS p body = GRHS (XCGRHS p body) | XGRHS (XXGRHS p body) type instance XCGRHS (GhcPass _) b = NoExt -type instance XXGRHS (GhcPass _) b = NoExt +type instance XXGRHS (GhcPass _) b = NoExtCon -- We know the list must have at least one @Match@ in it. @@ -1966,7 +1970,7 @@ type instance XRecStmt (GhcPass _) GhcPs b = NoExt type instance XRecStmt (GhcPass _) GhcRn b = NoExt type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc -type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt +type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon data TransForm -- The 'f' below is the 'using' function, 'e' is the by function = ThenForm -- then f or then f by e (depending on trS_by) @@ -1983,7 +1987,7 @@ data ParStmtBlock idL idR | XParStmtBlock (XXParStmtBlock idL idR) type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt -type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon -- | Applicative Argument data ApplicativeArg idL @@ -2004,7 +2008,7 @@ data ApplicativeArg idL type instance XApplicativeArgOne (GhcPass _) = NoExt type instance XApplicativeArgMany (GhcPass _) = NoExt -type instance XXApplicativeArg (GhcPass _) = NoExt +type instance XXApplicativeArg (GhcPass _) = NoExtCon {- Note [The type of bind in Stmts] @@ -2235,7 +2239,7 @@ pprStmt (ApplicativeStmt _ args mb_join) :: ExprStmt (GhcPass idL))] flattenArg (_, ApplicativeArgMany _ stmts _ _) = concatMap flattenStmt stmts - flattenArg (_, XApplicativeArg _) = panic "flattenArg" + flattenArg (_, XApplicativeArg nec) = noExtCon nec pp_debug = let @@ -2363,7 +2367,7 @@ type instance XTypedSplice (GhcPass _) = NoExt type instance XUntypedSplice (GhcPass _) = NoExt type instance XQuasiQuote (GhcPass _) = NoExt type instance XSpliced (GhcPass _) = NoExt -type instance XXSplice (GhcPass _) = NoExt +type instance XXSplice (GhcPass _) = NoExtCon -- | A splice can appear with various decorations wrapped around it. This data -- type captures explicitly how it was originally written, for use in the pretty @@ -2573,7 +2577,7 @@ type instance XDecBrG (GhcPass _) = NoExt type instance XTypBr (GhcPass _) = NoExt type instance XVarBr (GhcPass _) = NoExt type instance XTExpBr (GhcPass _) = NoExt -type instance XXBracket (GhcPass _) = NoExt +type instance XXBracket (GhcPass _) = NoExtCon isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 9a017c2..134704e 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -64,6 +66,17 @@ instance Outputable NoExt where noExt :: NoExt noExt = NoExt +-- | TODO RGS: Docs +data NoExtCon + deriving (Data,Eq,Ord) + +instance Outputable NoExtCon where + ppr = noExtCon + +-- | TODO RGS: Docs +noExtCon :: NoExtCon -> a +noExtCon x = case x of {} + -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) @@ -1080,7 +1093,7 @@ type ConvertIdX a b = -- -- So -- --- type instance XXHsIPBinds (GhcPass p) = NoExt +-- type instance XXHsIPBinds (GhcPass p) = NoExtCon -- -- will correctly deduce Outputable for (GhcPass p), but -- diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index d97be4b..e2cf525 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -85,7 +85,7 @@ data ImportDecl pass -- For details on above see note [Api annotations] in ApiAnnotation type instance XCImportDecl (GhcPass _) = NoExt -type instance XXImportDecl (GhcPass _) = NoExt +type instance XXImportDecl (GhcPass _) = NoExtCon simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) simpleImportDecl mn = ImportDecl { @@ -235,7 +235,7 @@ type instance XIEModuleContents (GhcPass _) = NoExt type instance XIEGroup (GhcPass _) = NoExt type instance XIEDoc (GhcPass _) = NoExt type instance XIEDocNamed (GhcPass _) = NoExt -type instance XXIE (GhcPass _) = NoExt +type instance XXIE (GhcPass _) = NoExtCon -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) @@ -257,14 +257,14 @@ gives rise to See Note [Representing fields in AvailInfo] in Avail for more details. -} -ieName :: IE pass -> IdP pass +ieName :: (XXIE pass ~ NoExtCon) => IE pass -> IdP pass ieName (IEVar _ (L _ n)) = ieWrappedName n ieName (IEThingAbs _ (L _ n)) = ieWrappedName n ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n ieName (IEThingAll _ (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" -ieNames :: IE pass -> [IdP pass] +ieNames :: (XXIE pass ~ NoExtCon) => IE pass -> [IdP pass] ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] @@ -274,7 +274,7 @@ ieNames (IEModuleContents {}) = [] ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] -ieNames (XIE {}) = panic "ieNames" +ieNames (XIE nec) = noExtCon nec ieWrappedName :: IEWrappedName name -> name ieWrappedName (IEName (L _ n)) = n diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index d1411bd..5baa091 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -91,7 +91,7 @@ type instance XHsInteger (GhcPass _) = SourceText type instance XHsRat (GhcPass _) = NoExt type instance XHsFloatPrim (GhcPass _) = NoExt type instance XHsDoublePrim (GhcPass _) = NoExt -type instance XXLit (GhcPass _) = NoExt +type instance XXLit (GhcPass _) = NoExtCon instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 @@ -129,7 +129,7 @@ type instance XOverLit GhcPs = NoExt type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] type instance XOverLit GhcTc = OverLitTc -type instance XXOverLit (GhcPass _) = NoExt +type instance XXOverLit (GhcPass _) = NoExtCon -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -147,7 +147,7 @@ negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit (OverLitTc _ ty) _ _) = ty -overLitType XOverLit{} = panic "overLitType" +overLitType (XOverLit nec) = noExtCon nec -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 9bb73c3..0649ee3 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -329,7 +329,7 @@ type instance XHsQTvs GhcPs = NoExt type instance XHsQTvs GhcRn = HsQTvsRn type instance XHsQTvs GhcTc = HsQTvsRn -type instance XXLHsQTyVars (GhcPass _) = NoExt +type instance XXLHsQTyVars (GhcPass _) = NoExtCon mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_ext = noExt, hsq_explicit = tvs } @@ -367,7 +367,7 @@ type instance XHsIB GhcPs _ = NoExt type instance XHsIB GhcRn _ = [Name] type instance XHsIB GhcTc _ = [Name] -type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt +type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon -- | Haskell Wildcard Binders data HsWildCardBndrs pass thing @@ -389,7 +389,7 @@ type instance XHsWC GhcPs b = NoExt type instance XHsWC GhcRn b = [Name] type instance XHsWC GhcTc b = [Name] -type instance XXHsWildCardBndrs (GhcPass _) b = NoExt +type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon -- | Located Haskell Signature Type type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only @@ -402,11 +402,13 @@ type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both -- See Note [Representing type signatures] -hsImplicitBody :: HsImplicitBndrs pass thing -> thing +hsImplicitBody :: (XXHsImplicitBndrs pass thing ~ NoExtCon) + => HsImplicitBndrs pass thing -> thing hsImplicitBody (HsIB { hsib_body = body }) = body -hsImplicitBody (XHsImplicitBndrs _) = panic "hsImplicitBody" +hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec -hsSigType :: LHsSigType pass -> LHsType pass +hsSigType :: (XXHsImplicitBndrs pass (LHsType pass) ~ NoExtCon) + => LHsSigType pass -> LHsType pass hsSigType = hsImplicitBody hsSigWcType :: LHsSigWcType pass -> LHsType pass @@ -495,16 +497,18 @@ data HsTyVarBndr pass type instance XUserTyVar (GhcPass _) = NoExt type instance XKindedTyVar (GhcPass _) = NoExt -type instance XXTyVarBndr (GhcPass _) = NoExt +type instance XXTyVarBndr (GhcPass _) = NoExtCon -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? -isHsKindedTyVar :: HsTyVarBndr pass -> Bool +isHsKindedTyVar :: (XXTyVarBndr pass ~ NoExtCon) + => HsTyVarBndr pass -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True -isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar" +isHsKindedTyVar (XTyVarBndr nec) = noExtCon nec -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? -hsTvbAllKinded :: LHsQTyVars pass -> Bool +hsTvbAllKinded :: (XXTyVarBndr pass ~ NoExtCon) + => LHsQTyVars pass -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -- | Haskell Type @@ -882,7 +886,7 @@ data ConDeclField pass -- Record fields have Haddoc docs on them | XConDeclField (XXConDeclField pass) type instance XConDeclField (GhcPass _) = NoExt -type instance XXConDeclField (GhcPass _) = NoExt +type instance XXConDeclField (GhcPass _) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDeclField p) where @@ -945,8 +949,8 @@ hsWcScopedTvs sig_ty -- include kind variables only if the type is headed by forall -- (this is consistent with GHC 7 behaviour) _ -> nwcs -hsWcScopedTvs (HsWC _ (XHsImplicitBndrs _)) = panic "hsWcScopedTvs" -hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs" +hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec +hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec hsScopedTvs :: LHsSigType GhcRn -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType @@ -972,18 +976,22 @@ I don't know if this is a good idea, but there it is. -} --------------------- -hsTyVarName :: HsTyVarBndr pass -> IdP pass +hsTyVarName :: (XXTyVarBndr pass ~ NoExtCon) + => HsTyVarBndr pass -> IdP pass hsTyVarName (UserTyVar _ (L _ n)) = n hsTyVarName (KindedTyVar _ (L _ n) _) = n -hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName" +hsTyVarName (XTyVarBndr nec) = noExtCon nec -hsLTyVarName :: LHsTyVarBndr pass -> IdP pass +hsLTyVarName :: (XXTyVarBndr pass ~ NoExtCon) + => LHsTyVarBndr pass -> IdP pass hsLTyVarName = hsTyVarName . unLoc -hsLTyVarNames :: [LHsTyVarBndr pass] -> [IdP pass] +hsLTyVarNames :: (XXTyVarBndr pass ~ NoExtCon) + => [LHsTyVarBndr pass] -> [IdP pass] hsLTyVarNames = map hsLTyVarName -hsExplicitLTyVarNames :: LHsQTyVars pass -> [IdP pass] +hsExplicitLTyVarNames :: (XXTyVarBndr pass ~ NoExtCon) + => LHsQTyVars pass -> [IdP pass] -- Explicit variables only hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) @@ -992,12 +1000,14 @@ hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] hsAllLTyVarNames (HsQTvs { hsq_ext = kvs , hsq_explicit = tvs }) = kvs ++ hsLTyVarNames tvs -hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames" +hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec -hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass) +hsLTyVarLocName :: (XXTyVarBndr pass ~ NoExtCon) + => LHsTyVarBndr pass -> Located (IdP pass) hsLTyVarLocName = onHasSrcSpan hsTyVarName -hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] +hsLTyVarLocNames :: (XXTyVarBndr pass ~ NoExtCon) + => LHsQTyVars pass -> [Located (IdP pass)] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. @@ -1007,13 +1017,13 @@ hsLTyVarBndrToType = onHasSrcSpan cvt cvt (KindedTyVar _ (L name_loc n) kind) = HsKindSig noExt (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind - cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType" + cvt (XTyVarBndr nec) = noExtCon nec -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs -hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes" +hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec --------------------- ignoreParens :: LHsType pass -> LHsType pass @@ -1253,9 +1263,10 @@ splitLHsInstDeclTy (HsIB { hsib_ext = itkvs = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty) -- Return implicitly bound type and kind vars -- For an instance decl, all of them are in scope -splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy" +splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec -getLHsInstDeclHead :: LHsSigType pass -> LHsType pass +getLHsInstDeclHead :: (XXHsImplicitBndrs pass (LHsType pass) ~ NoExtCon) + => LHsSigType pass -> LHsType pass getLHsInstDeclHead inst_ty | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty) = body_ty @@ -1298,7 +1309,7 @@ type instance XCFieldOcc GhcPs = NoExt type instance XCFieldOcc GhcRn = Name type instance XCFieldOcc GhcTc = Id -type instance XXFieldOcc (GhcPass _) = NoExt +type instance XXFieldOcc (GhcPass _) = NoExtCon instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc @@ -1332,7 +1343,7 @@ type instance XAmbiguous GhcPs = NoExt type instance XAmbiguous GhcRn = NoExt type instance XAmbiguous GhcTc = Id -type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt +type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where ppr = ppr . rdrNameAmbiguousFieldOcc @@ -1347,23 +1358,23 @@ mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "rdrNameAmbiguousFieldOcc" +rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec) + = noExtCon nec selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id selectorAmbiguousFieldOcc (Unambiguous sel _) = sel selectorAmbiguousFieldOcc (Ambiguous sel _) = sel -selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _) - = panic "selectorAmbiguousFieldOcc" +selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec) + = noExtCon nec unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc" +unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr -ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" +ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec {- ************************************************************************ diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index fa8ec14..51a60af 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -1047,7 +1047,7 @@ collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat collectArgBinders _ = [] -collectStmtBinders XStmtLR{} = panic "collectStmtBinders" +collectStmtBinders (XStmtLR nec) = noExtCon nec ----------------- Patterns -------------------------- @@ -1123,7 +1123,7 @@ hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) = collectHsValBinders val_decls ++ hsTyClForeignBinders tycl_decls foreign_decls -hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders" +hsGroupBinders (XHsGroup nec) = noExtCon nec hsTyClForeignBinders :: [TyClGroup GhcRn] -> [LForeignDecl GhcRn] @@ -1141,7 +1141,9 @@ hsTyClForeignBinders tycl_decls foreign_decls getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- -hsLTyClDeclBinders :: Located (TyClDecl pass) +hsLTyClDeclBinders :: ( XXConDecl pass ~ NoExtCon, XXHsDataDefn pass ~ NoExtCon + , XXFamilyDecl pass ~ NoExtCon, XXTyClDecl pass ~ NoExtCon ) + => Located (TyClDecl pass) -> ([Located (IdP pass)], [LFieldOcc pass]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component @@ -1155,8 +1157,8 @@ hsLTyClDeclBinders :: Located (TyClDecl pass) hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl { fdLName = (dL->L _ name) } })) = ([cL loc name], []) -hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ })) - = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) + = noExtCon nec hsLTyClDeclBinders (dL->L loc (SynDecl { tcdLName = (dL->L _ name) })) = ([cL loc name], []) @@ -1174,7 +1176,7 @@ hsLTyClDeclBinders (dL->L loc (ClassDecl hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) , tcdDataDefn = defn })) = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn -hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" -- due to #15884 @@ -1217,40 +1219,44 @@ hsLInstDeclBinders (dL->L _ (ClsInstD hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty -hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {}))) - = panic "hsLInstDeclBinders" -hsLInstDeclBinders (dL->L _ (XInstDecl _)) - = panic "hsLInstDeclBinders" +hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) + = noExtCon nec +hsLInstDeclBinders (dL->L _ (XInstDecl nec)) + = noExtCon nec hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" -- due to #15884 ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl pass - -> ([Located (IdP pass)], [LFieldOcc pass]) +hsDataFamInstBinders :: ( XXConDecl pass ~ NoExtCon, XXHsDataDefn pass ~ NoExtCon + , XXFamEqn pass (HsTyPats pass) (HsDataDefn pass) ~ NoExtCon + , XXHsImplicitBndrs pass (FamEqn pass (HsTyPats pass) (HsDataDefn pass)) ~ NoExtCon ) + => DataFamInstDecl pass -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders hsDataFamInstBinders (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = XFamEqn _}}) - = panic "hsDataFamInstBinders" -hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) - = panic "hsDataFamInstBinders" + { dfid_eqn = HsIB { hsib_body = XFamEqn nec}}) + = noExtCon nec +hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) +hsDataDefnBinders :: (XXConDecl pass ~ NoExtCon, XXHsDataDefn pass ~ NoExtCon) + => HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] -hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" +hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec ------------------- type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] -- Filters out ones that have already been seen -hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) +hsConDeclsBinders :: forall pass. (XXConDecl pass ~ NoExtCon) + => [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful @@ -1279,7 +1285,7 @@ hsConDeclsBinders cons (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs - XConDecl _ -> panic "hsConDeclsBinders" + XConDecl nec -> noExtCon nec get_flds :: Seen pass -> HsConDeclDetails pass -> (Seen pass, [LFieldOcc pass]) @@ -1348,7 +1354,7 @@ lStmtsImplicits = hs_lstmts hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts - do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits" + do_arg (_, XApplicativeArg nec) = noExtCon nec hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = [] hs_stmt (LastStmt {}) = [] @@ -1356,7 +1362,7 @@ lStmtsImplicits = hs_lstmts , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss - hs_stmt (XStmtLR {}) = panic "lStmtsImplicits" + hs_stmt (XStmtLR nec) = noExtCon nec hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds {}) = [] diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 16c8db9..7c81ad0 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} +{-# LANGUAGE BangPatterns, CPP, GADTs, MagicHash, NondecreasingIndentation #-} {-# OPTIONS_GHC -fprof-auto-top #-} ------------------------------------------------------------------------------- @@ -949,11 +949,12 @@ hscCheckSafeImports tcg_env = do -> return tcg_env' warns dflags rules = listToBag $ map (warnRules dflags) rules + warnRules dflags (L loc (HsRule { rd_name = n })) = mkPlainWarnMsg dflags loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" - warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports" + warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec -- | Validate that safe imported modules are actually safe. For modules in the -- HomePackage (the package the module we are compiling in resides) this just diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 44edb82..94c4056 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -122,7 +122,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) import_info (dL->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 _)) = panic "import_info" + import_info (dL->L _ (XImportDecl nec)) = noExtCon nec import_info _ = panic " import_info: Impossible Match" -- due to #15884 @@ -162,8 +162,8 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) ss, is, length ats, length adts) where methods = map unLoc $ bagToList inst_meths - inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info" - inst_info (XInstDecl _) = panic "inst_info" + inst_info (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec + inst_info (XInstDecl nec) = noExtCon nec -- TODO: use Sum monoid addpr :: (Int,Int,Int) -> Int diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 2fd47ac..d95e826 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -214,8 +214,8 @@ mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) , feqn_fixity = fixity , feqn_rhs = rhs }) ; pure (f, addAnnsAt loc anns) } -mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" -mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" +mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec +mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec mkATDefault _ = panic "mkATDefault: Impossible Match" -- due to #15884 @@ -505,7 +505,7 @@ has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). -has_args ((dL->L _ (XMatch _)) : _) = panic "has_args" +has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 {- ********************************************************************** @@ -2381,8 +2381,8 @@ mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) = HsRecField (L loc (Unambiguous noExt rdr)) arg pun -mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc _)) _ _) - = panic "mk_rec_upd_field" +mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _) + = noExtCon nec mk_rec_upd_field (HsRecField _ _ _) = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 22f2cf3..51e9d72 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -215,19 +215,19 @@ rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds return (thing, fvs_thing `plusFV` fv_binds) -rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen" +rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) rnIPBinds (IPBinds _ ip_binds ) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds return (IPBinds noExt ip_binds', plusFVs fvs_s) -rnIPBinds (XHsIPBinds _) = panic "rnIPBinds" +rnIPBinds (XHsIPBinds nec) = noExtCon nec rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) rnIPBind (IPBind _ ~(Left n) expr) = do (expr',fvExpr) <- rnLExpr expr return (IPBind noExt (Left n) expr', fvExpr) -rnIPBind (XIPBind _) = panic "rnIPBind" +rnIPBind (XIPBind nec) = noExtCon nec {- ************************************************************************ @@ -629,7 +629,7 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls add_one_sig env (L loc (FixitySig _ names fixity)) = foldlM add_one env [ (loc,name_loc,name,fixity) | L name_loc name <- names ] - add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv" + add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec add_one env (loc, name_loc, name,fixity) = do { -- this fixity decl is a duplicate iff @@ -740,7 +740,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name = hang (text "Illegal pattern synonym declaration") 2 (text "Use -XPatternSynonyms to enable this extension") -rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind" +rnPatSynBind _ (XPatSynBind nec) = noExtCon nec {- Note [Renaming pattern synonym variables] @@ -1043,7 +1043,7 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) text "A COMPLETE pragma must mention at least one data constructor" $$ text "or pattern synonym defined in the same module." -renameSig _ (XSig _) = panic "renameSig" +renameSig _ (XSig nec) = noExtCon nec {- Note [Orphan COMPLETE pragmas] @@ -1070,7 +1070,7 @@ complexity of supporting them properly doesn't seem worthwhile. ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) -okHsSig :: HsSigCtxt -> LSig a -> Bool +okHsSig :: (XXSig a ~ NoExtCon) => HsSigCtxt -> LSig a -> Bool okHsSig ctxt (L _ sig) = case (sig, ctxt) of (ClassOpSig {}, ClsDeclCtxt {}) -> True @@ -1111,7 +1111,7 @@ okHsSig ctxt (L _ sig) (CompleteMatchSig {}, TopSigCtxt {} ) -> True (CompleteMatchSig {}, _) -> False - (XSig _, _) -> panic "okHsSig" + (XSig nec, _) -> noExtCon nec ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] @@ -1167,7 +1167,7 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin new_ms, ms_fvs) } -rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup" +rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec rnMatch :: Outputable (body GhcPs) => HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) @@ -1189,7 +1189,7 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) _ -> ctxt ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats' , m_grhss = grhss'}, grhss_fvs ) }} -rnMatch' _ _ (XMatch _) = panic "rnMatch'" +rnMatch' _ _ (XMatch nec) = noExtCon nec emptyCaseErr :: HsMatchContext Name -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) @@ -1216,7 +1216,7 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) = rnLocalBindsAndThen binds $ \ binds' _ -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss return (GRHSs noExt grhss' (L l binds'), fvGRHSs) -rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs" +rnGRHSs _ _ (XGRHSs nec) = noExtCon nec rnGRHS :: HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) @@ -1244,7 +1244,7 @@ rnGRHS' ctxt rnBody (GRHS _ guards rhs) is_standard_guard [] = True is_standard_guard [L _ (BodyStmt {})] = True is_standard_guard _ = False -rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'" +rnGRHS' _ _ (XGRHS nec) = noExtCon nec {- ********************************************************* @@ -1268,7 +1268,7 @@ rnSrcFixityDecl sig_ctxt = rn_decl rn_decl (FixitySig _ fnames fixity) = do names <- concatMapM lookup_one fnames return (FixitySig noExt names fixity) - rn_decl (XFixitySig _) = panic "rnSrcFixityDecl" + rn_decl (XFixitySig nec) = noExtCon nec lookup_one :: Located RdrName -> RnM [Located Name] lookup_one (L name_loc rdr_name) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index b74b557..4ac0107 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -289,7 +289,7 @@ rnExpr (ExplicitTuple x tup_args boxity) ; return (L l (Present x e'), fvs) } rnTupArg (L l (Missing _)) = return (L l (Missing noExt) , emptyFVs) - rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg" + rnTupArg (L _ (XTupArg nec)) = noExtCon nec rnExpr (ExplicitSum x alt arity expr) = do { (expr', fvs) <- rnLExpr expr @@ -462,7 +462,7 @@ rnCmdTop = wrapLocFstM rnCmdTop' ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', fvCmd `plusFV` cmd_fvs) } - rnCmdTop' (XCmdTop{}) = panic "rnCmdTop" + rnCmdTop' (XCmdTop nec) = noExtCon nec rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd @@ -536,7 +536,7 @@ rnCmd (HsCmdDo x (L l stmts)) ; return ( HsCmdDo x (L l stmts'), fvs ) } rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) -rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd) +rnCmd (XCmd nec) = noExtCon nec --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -568,7 +568,7 @@ methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName -methodNamesCmd (XCmd {}) = panic "methodNamesCmd" +methodNamesCmd (XCmd nec) = noExtCon nec --methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient @@ -581,20 +581,20 @@ methodNamesMatch (MG { mg_alts = L _ ms }) = plusFVs (map do_one ms) where do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss - do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch" -methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch" + do_one (L _ (XMatch nec)) = noExtCon nec +methodNamesMatch (XMatchGroup nec) = noExtCon nec ------------------------------------------------- -- gaw 2004 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) -methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs" +methodNamesGRHSs (XGRHSs nec) = noExtCon nec ------------------------------------------------- methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs -methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS" +methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec --------------------------------------------------- methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars @@ -616,7 +616,7 @@ methodNamesStmt (TransStmt {}) = emptyFVs methodNamesStmt ApplicativeStmt{} = emptyFVs -- ParStmt and TransStmt can't occur in commands, but it's not -- convenient to error here so we just do what's convenient -methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt" +methodNamesStmt (XStmtLR nec) = noExtCon nec {- ************************************************************************ @@ -946,8 +946,8 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for rnStmt _ _ (L _ ApplicativeStmt{}) _ = panic "rnStmt: ApplicativeStmt" -rnStmt _ _ (L _ XStmtLR{}) _ = - panic "rnStmt: XStmtLR" +rnStmt _ _ (L _ (XStmtLR nec)) _ = + noExtCon nec rnParallelStmts :: forall thing. HsStmtContext Name -> SyntaxExpr GhcRn @@ -978,7 +978,7 @@ rnParallelStmts ctxt return_op segs thing_inside ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } - rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts" + rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" @@ -1147,10 +1147,10 @@ rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _)))) - = panic "rn_rec_stmt LetStmt XHsLocalBindsLR" -rn_rec_stmt_lhs _ (L _ (XStmtLR _)) - = panic "rn_rec_stmt XStmtLR" +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec)))) + = noExtCon nec +rn_rec_stmt_lhs _ (L _ (XStmtLR nec)) + = noExtCon nec rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv -> [LStmt GhcPs body] @@ -1218,8 +1218,8 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _) - = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR" +rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _) + = noExtCon nec rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" @@ -1227,8 +1227,8 @@ rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _) - = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt) +rn_rec_stmt _ _ (L _ (XStmtLR nec), _) + = noExtCon nec rn_rec_stmts :: Outputable (body GhcPs) => (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) @@ -1996,7 +1996,7 @@ checkStmt ctxt (L _ stmt) msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") , text "in" <+> pprAStmtContext ctxt ] -pprStmtCat :: Stmt a body -> SDoc +pprStmtCat :: (XXStmtLR a a body ~ NoExtCon) => Stmt a body -> SDoc pprStmtCat (TransStmt {}) = text "transform" pprStmtCat (LastStmt {}) = text "return expression" pprStmtCat (BodyStmt {}) = text "body" @@ -2005,7 +2005,7 @@ pprStmtCat (LetStmt {}) = text "let" pprStmtCat (RecStmt {}) = text "rec" pprStmtCat (ParStmt {}) = text "parallel" pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" -pprStmtCat (XStmtLR {}) = panic "pprStmtCat: XStmtLR" +pprStmtCat (XStmtLR nec) = noExtCon nec ------------ emptyInvalid :: Validity -- Payload is the empty document @@ -2071,7 +2071,7 @@ okCompStmt dflags _ stmt RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ApplicativeStmt {} -> emptyInvalid - XStmtLR{} -> panic "okCompStmt" + XStmtLR nec -> noExtCon nec --------- checkTupleSection :: [LHsTupArg GhcPs] -> RnM () diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index 1fa81c8..665d877 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -211,4 +211,4 @@ lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr) format_ambig (elt, fix) = hang (ppr fix) 2 (pprNameProvenance elt) -lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn" +lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index ba0b5f3..96ec034 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -378,7 +378,7 @@ rnImportDecl this_mod , ideclHiding = new_imp_details }) return (new_imp_decl, gbl_env, imports, mi_hpc iface) -rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl" +rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. @@ -721,7 +721,7 @@ getLocalNonValBinders fixity_env = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr) - find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders" + find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec new_assoc :: Bool -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) @@ -757,8 +757,8 @@ getLocalNonValBinders fixity_env (avails, fldss) <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts pure (avails, concat fldss) - new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc" - new_assoc _ (L _ (XInstDecl _)) = panic "new_assoc" + new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec + new_assoc _ (L _ (XInstDecl nec)) = noExtCon nec new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) @@ -772,16 +772,16 @@ getLocalNonValBinders fixity_env -- main_name is not bound here! fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) } - new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di" + new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d -getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders" +getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector" +newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) = do { selName <- newTopSrcBinder $ L loc $ field ; return $ qualFieldLbl { flSelector = selName } } @@ -1392,7 +1392,7 @@ findImportUsage imports used_gres -- If you use 'signum' from Num, then the user may well have -- imported Num(signum). We don't want to complain that -- Num is not itself mentioned. Hence the two cases in add_unused_with. - unused_decl (L _ (XImportDecl _)) = panic "unused_decl" + unused_decl (L _ (XImportDecl nec)) = noExtCon nec {- Note [The ImportMap] diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 5181b7f..fae2031 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -230,7 +230,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, traceRn "finish Dus" (ppr src_dus ) ; return (final_tcg_env, rn_group) }}}} -rnSrcDecls (XHsGroup _) = panic "rnSrcDecls" +rnSrcDecls (XHsGroup nec) = noExtCon nec addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv -- This function could be defined lower down in the module hierarchy, @@ -298,7 +298,7 @@ rnSrcWarnDecls bndr_set decls' = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) rdr_names ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } - rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls" + rn_deprec (XWarnDecl nec) = noExtCon nec what = text "deprecation" @@ -334,7 +334,7 @@ rnAnnDecl ann@(HsAnnotation _ s provenance expr) rnLExpr expr ; return (HsAnnotation noExt s provenance' expr', provenance_fvs `plusFV` expr_fvs) } -rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl" +rnAnnDecl (XAnnDecl nec) = noExtCon nec rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) @@ -356,7 +356,7 @@ rnDefaultDecl (DefaultDecl _ tys) ; return (DefaultDecl noExt tys', fvs) } where doc_str = DefaultDeclCtx -rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl" +rnDefaultDecl (XDefaultDecl nec) = noExtCon nec {- ********************************************************* @@ -391,7 +391,7 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) -- we add it to the free-variable list. It might, for example, -- be imported from another module -rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl" +rnHsForeignDecl (XForeignDecl nec) = noExtCon nec -- | For Windows DLLs we need to know what packages imported symbols are from -- to generate correct calls. Imported symbols are tagged with the current @@ -438,7 +438,7 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid }) ; traceRn "rnSrcIstDecl end }" empty ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) } -rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl" +rnSrcInstDecl (XInstDecl nec) = noExtCon nec -- | Warn about non-canonical typeclass instance declarations -- @@ -706,7 +706,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- the instance context after renaming. This is a bit -- strange, but should not matter (and it would be more work -- to remove the context). -rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl" +rnClsInstDecl (XClsInstDecl nec) = noExtCon nec rnFamInstEqn :: HsDocContext -> Maybe (Name, [Name]) -- Nothing => not associated @@ -793,8 +793,8 @@ rnFamInstEqn doc mb_cls rhs_kvars , feqn_fixity = fixity , feqn_rhs = payload' } }, all_fvs) } -rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn" -rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn" +rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec +rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec rnTyFamInstDecl :: Maybe (Name, [Name]) -- Just (cls,tvs) => associated, -- and gives class and tyvars of @@ -830,8 +830,8 @@ rnTyFamInstEqn mb_cls ctf_info withHsDocContext (TyFamilyCtx fam_rdr_name) $ wrongTyFamName fam_name tycon' ; pure (eqn', fvs) } -rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn" -rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn" +rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec +rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec rnTyFamDefltEqn :: Name -> TyFamDefltEqn GhcPs @@ -854,7 +854,7 @@ rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon , feqn_rhs = rhs' }, fvs) } } where ctx = TyFamilyCtx tycon -rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn" +rnTyFamDefltEqn _ (XFamEqn nec) = noExtCon nec rnDataFamInstDecl :: Maybe (Name, [Name]) -> DataFamInstDecl GhcPs @@ -866,10 +866,10 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = ; (eqn', fvs) <- rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } -rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _))) - = panic "rnDataFamInstDecl" -rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _)) - = panic "rnDataFamInstDecl" +rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec))) + = noExtCon nec +rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec -- Renaming of the associated types in instances. @@ -1024,7 +1024,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap) ; return (DerivDecl noExt ty' mds' overlap, fvs) } where loc = getLoc $ hsib_body $ hswc_body ty -rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl" +rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec standaloneDerivErr :: SDoc standaloneDerivErr @@ -1046,7 +1046,7 @@ rnHsRuleDecls (HsRules { rds_src = src ; return (HsRules { rds_ext = noExt , rds_src = src , rds_rules = rn_rules }, fvs) } -rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls" +rnHsRuleDecls (XRuleDecls nec) = noExtCon nec rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) rnHsRuleDecl (HsRule { rd_name = rule_name @@ -1075,9 +1075,9 @@ rnHsRuleDecl (HsRule { rd_name = rule_name where get_var (RuleBndrSig _ v _) = v get_var (RuleBndr _ v) = v - get_var (XRuleBndr _) = panic "rnHsRuleDecl" + get_var (XRuleBndr nec) = noExtCon nec in_rule = text "in the rule" <+> pprFullRuleName rule_name -rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl" +rnHsRuleDecl (XRuleDecl nec) = noExtCon nec bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs -> [LRuleBndr GhcPs] -> [Name] @@ -1452,7 +1452,7 @@ rnRoleAnnots tc_names role_annots (text "role annotation") tycon ; return $ RoleAnnotDecl noExt tycon' roles } - rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots" + rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list @@ -1670,7 +1670,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, where cls_doc = ClassDeclCtx lcls -rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl" +rnTyClDecl (XTyClDecl nec) = noExtCon nec -- "type" and "type instance" declarations rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) @@ -1720,7 +1720,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds ; return (cL loc ds', fvs) } -rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn" +rnDataDefn _ (XHsDataDefn nec) = noExtCon nec warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan @@ -1766,9 +1766,9 @@ rnLHsDerivingClause doc rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) = rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $ rnHsSigType doc deriv_ty - rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty" -rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause _)) - = panic "rnLHsDerivingClause" + rn_deriv_ty _ _ (XHsImplicitBndrs nec) = noExtCon nec +rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec)) + = noExtCon nec rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" -- due to #15884 @@ -1934,7 +1934,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars = return (ClosedTypeFamily Nothing, emptyFVs) rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs) rn_info _ DataFamily = return (DataFamily, emptyFVs) -rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl" +rnFamDecl _ (XFamilyDecl nec) = noExtCon nec rnFamResultSig :: HsDocContext -> FamilyResultSig GhcPs @@ -1966,7 +1966,7 @@ rnFamResultSig doc (TyVarSig _ tvbndr) -- scoping checks that are irrelevant here tvbndr $ \ tvbndr' -> return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) } -rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig" +rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec -- Note [Renaming injectivity annotation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2176,7 +2176,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names , con_doc = mb_doc' }, all_fvs) } } -rnConDecl (XConDecl _) = panic "rnConDecl" +rnConDecl (XConDecl nec) = noExtCon nec rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) @@ -2371,9 +2371,9 @@ add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds = addl (gp { hs_ruleds = cL l d : ts }) ds add gp l (DocD _ d) ds = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds -add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add" -add (HsGroup {}) _ (XHsDecl _) _ = panic "RnSource.add" -add (XHsGroup _) _ _ _ = panic "RnSource.add" +add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec +add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec +add (XHsGroup nec) _ _ _ = noExtCon nec add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] @@ -2385,7 +2385,7 @@ add_tycld d [] = [TyClGroup { group_ext = noExt ] add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) = ds { group_tyclds = d : tyclds } : dss -add_tycld _ (XTyClGroup _: _) = panic "add_tycld" +add_tycld _ (XTyClGroup nec: _) = noExtCon nec add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] @@ -2397,7 +2397,7 @@ add_instd d [] = [TyClGroup { group_ext = noExt ] add_instd d (ds@(TyClGroup { group_instds = instds }):dss) = ds { group_instds = d : instds } : dss -add_instd _ (XTyClGroup _: _) = panic "add_instd" +add_instd _ (XTyClGroup nec: _) = noExtCon nec add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] @@ -2409,7 +2409,7 @@ add_role_annot d [] = [TyClGroup { group_ext = noExt ] add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest -add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot" +add_role_annot _ (XTyClGroup nec: _) = noExtCon nec add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 1d5c68f..ac27fce 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -180,7 +180,7 @@ rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e ; return (TExpBr x e', fvs) } -rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket" +rn_bracket _ (XBracket nec) = noExtCon nec quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body @@ -303,7 +303,7 @@ runRnSplice flavour run_meta ppr_res splice HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice) - XSplice {} -> pprPanic "runRnSplice" (ppr splice) + XSplice nec -> noExtCon nec -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name @@ -352,8 +352,8 @@ makePending _ splice@(HsSpliced {}) = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSplicedT {}) = pprPanic "makePending" (ppr splice) -makePending _ splice@(XSplice {}) - = pprPanic "makePending" (ppr splice) +makePending _ (XSplice nec) + = noExtCon nec ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString @@ -407,7 +407,7 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice) -rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice) +rnSplice (XSplice nec) = noExtCon nec --------------------- rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) @@ -638,8 +638,8 @@ rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg) = ( makePending UntypedDeclSplice rn_splice , SpliceDecl noExt (cL loc rn_splice) flg) - run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) -rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl" + run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) +rnSpliceDecl (XSpliceDecl nec) = noExtCon nec rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 755ed20..f308647 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -137,10 +137,10 @@ rn_hs_sig_wc_type scoping ctxt , hsib_body = hs_ty' } ; (res, fvs2) <- thing_inside sig_ty' ; return (res, fvs1 `plusFV` fvs2) } } -rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _ - = panic "rn_hs_sig_wc_type" -rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _ - = panic "rn_hs_sig_wc_type" +rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _ + = noExtCon nec +rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _ + = noExtCon nec rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) @@ -149,7 +149,7 @@ rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } ; return (sig_ty', fvs) } -rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType" +rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs -> RnM ([Name], LHsType GhcRn, FreeVars) @@ -307,7 +307,7 @@ rnHsSigType ctx (HsIB { hsib_body = hs_ty }) ; return ( HsIB { hsib_ext = vars , hsib_body = body' } , fvs ) } } -rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType" +rnHsSigType _ (XHsImplicitBndrs nec) = noExtCon nec rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables -- E.g. f :: forall a. a->b @@ -997,7 +997,7 @@ bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind)) $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr" +bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match" -- due to #15884 @@ -1048,8 +1048,8 @@ rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc)) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl - lookupField (XFieldOcc{}) = panic "rnField" -rnField _ _ (dL->L _ (XConDeclField _)) = panic "rnField" + lookupField (XFieldOcc nec) = noExtCon nec +rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec rnField _ _ _ = panic "rnField: Impossible Match" -- due to #15884 @@ -1293,7 +1293,7 @@ checkPrecMatch op (MG { mg_alts = (dL->L _ ms) }) -- but the second eqn has no args (an error, but not discovered -- until the type checker). So we don't want to crash on the -- second eqn. -checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch" +checkPrecMatch _ (XMatchGroup nec) = noExtCon nec checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do @@ -1674,7 +1674,7 @@ extractRdrKindSigVars (dL->L _ resultSig) extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) = maybe [] extractHsTyRdrTyVars ksig -extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars" +extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec extract_lctxt :: LHsContext GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 89e5569..dfe0331 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -529,7 +529,7 @@ newOverloadedLit = newNonTrivialOverloadedLit orig lit res_ty where orig = LiteralOrigin lit -newOverloadedLit XOverLit{} _ = panic "newOverloadedLit" +newOverloadedLit (XOverLit nec) _ = noExtCon nec -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in TcUnify diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 050c5db..76bffc5 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -66,7 +66,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do where safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] -tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation" +tcAnnotation (L _ (XAnnDecl nec)) = noExtCon nec annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 763684b..d38010c 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -126,7 +126,7 @@ tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) do { cmd' <- tcCmd env cmd cmd_ty ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } -tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop" +tcCmdTop _ (L _ (XCmdTop nec)) _ = noExtCon nec ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) @@ -271,14 +271,14 @@ tc_cmd env = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss ; return (GRHSs x grhss' (L l binds')) } - tc_grhss (XGRHSs _) _ _ = panic "tc_grhss" + tc_grhss (XGRHSs nec) _ _ = noExtCon nec tc_grhs stk_ty res_ty (GRHS x guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ \ res_ty -> tcCmd env body (stk_ty, checkingExpType "tc_grhs" res_ty) ; return (GRHS x guards' rhs') } - tc_grhs _ _ (XGRHS _) = panic "tc_grhs" + tc_grhs _ _ (XGRHS nec) = noExtCon nec ------------------------------------------- -- Do notation @@ -323,7 +323,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } -tc_cmd _ (XCmd {}) _ = panic "tc_cmd" +tc_cmd _ (XCmd nec) _ = noExtCon nec ----------------------------------------------------------------- -- Base case for illegal commands diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 9cdc939..e7f6258 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -361,15 +361,15 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; let d = toDict ipClass p ty `fmap` expr' ; return (ip_id, (IPBind noExt (Right ip_id) d)) } tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" - tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind" + tc_ip_bind _ (XIPBind nec) = noExtCon nec -- Coerces a `t` into a dictionry for `IP "x" t`. -- co : t -> IP "x" t toDict ipClass x ty = mkHsWrap $ mkWpCastR $ wrapIP $ mkClassPred ipClass [x,ty] -tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds" -tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds" +tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec +tcLocalBinds (XHsLocalBindsLR nec) _ = noExtCon nec {- Note [Implicit parameter untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index d091e9c..926eca1 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -66,7 +66,7 @@ tcDefaults [L locn (DefaultDecl _ mono_tys)] tcDefaults decls@(L locn (DefaultDecl _ _) : _) = setSrcSpan locn $ failWithTc (dupDefaultDeclErr decls) -tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults" +tcDefaults (L _ (XDefaultDecl nec):_) = noExtCon nec tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type @@ -100,8 +100,8 @@ dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) where pp (L locn (DefaultDecl _ _)) = text "here was another default declaration" <+> ppr locn - pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr" -dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr" + pp (L _ (XDefaultDecl nec)) = noExtCon nec +dupDefaultDeclErr (L _ (XDefaultDecl nec) : _) = noExtCon nec dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" badDefaultTy :: Type -> [Class] -> SDoc diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 736f44e..7f3c9d5 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -691,7 +691,7 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode)) bale_out $ text "The last argument of the instance must be a data or newtype application" } -deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone" +deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec -- Typecheck the type in a standalone deriving declaration. -- @@ -736,10 +736,10 @@ tcStandaloneDerivInstType ctxt let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty pure (tvs, SupplyContext theta, cls, inst_tys) -tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _)) - = panic "tcStandaloneDerivInstType" -tcStandaloneDerivInstType _ (XHsWildCardBndrs _) - = panic "tcStandaloneDerivInstType" +tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs nec)) + = noExtCon nec +tcStandaloneDerivInstType _ (XHsWildCardBndrs nec) + = noExtCon nec warnUselessTypeable :: TcM () warnUselessTypeable diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index f0be9a8..533f137 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -706,18 +706,18 @@ tcAddDataFamConPlaceholders inst_decls thing_inside get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) = concatMap (get_fi_cons . unLoc) fids - get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons" - get_cons (L _ (XInstDecl _)) = panic "get_cons" + get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec + get_cons (L _ (XInstDecl nec)) = noExtCon nec get_fi_cons :: DataFamInstDecl GhcRn -> [Name] get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) = map unLoc $ concatMap (getConNames . unLoc) cons get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = XHsDataDefn _ }}}) - = panic "get_fi_cons" - get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons" - get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons" + FamEqn { feqn_rhs = XHsDataDefn nec }}}) + = noExtCon nec + get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec + get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 4d813b0..b7a4a42 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1425,7 +1425,7 @@ tcTupArgs args tys go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty ; return (L l (Present x expr')) } - go (L _ (XTupArg{}), _) = panic "tcTupArgs" + go (L _ (XTupArg nec), _) = noExtCon nec --------------------------- -- See TcType.SyntaxOpType also for commentary @@ -1742,7 +1742,7 @@ tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) res_ty } -tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId" +tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec ------------------------ tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) @@ -1751,7 +1751,7 @@ tcInferRecSelId (Unambiguous sel (L _ lbl)) ; return (expr', ty) } tcInferRecSelId (Ambiguous _ lbl) = ambiguousSelector lbl -tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId" +tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) @@ -1976,7 +1976,7 @@ too_many_args fun args where pp (HsValArg e) = ppr e pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t - pp (HsTypeArg _ (XHsWildCardBndrs _)) = panic "too_many_args" + pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec pp (HsArgPar _) = empty @@ -2451,7 +2451,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs ; return Nothing } where field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField" +tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 52783e7..b1b31fd 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -135,7 +135,7 @@ hsLitType (HsInteger _ _ ty) = ty hsLitType (HsRat _ _ ty) = ty hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy -hsLitType (XLit p) = pprPanic "hsLitType" (ppr p) +hsLitType (XLit nec) = noExtCon nec -- Overloaded literals. Here mainly because it uses isIntTy etc @@ -389,7 +389,7 @@ zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) zonkFieldOcc env (FieldOcc sel lbl) = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel -zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc" +zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) zonkEvBndrsX = mapAccumLM zonkEvBndrX @@ -532,12 +532,12 @@ zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do = do n' <- mapIPNameTc (zonkIdBndr env) n e' <- zonkLExpr env e return (IPBind x n' e') - zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind" + zonk_ip_bind (XIPBind nec) = noExtCon nec -zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _)) - = panic "zonkLocalBinds" -- Not in typechecker output -zonkLocalBinds _ (XHsLocalBindsLR _) - = panic "zonkLocalBinds" -- Not in typechecker output +zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec)) + = noExtCon nec +zonkLocalBinds _ (XHsLocalBindsLR nec) + = noExtCon nec --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) @@ -633,7 +633,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_poly = new_poly_id , abe_mono = zonkIdOcc env mono_id , abe_prags = new_prags }) - zonk_export _ (XABExport _) = panic "zonk_bind: XABExport" + zonk_export _ (XABExport nec) = noExtCon nec zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) , psb_args = details @@ -649,8 +649,8 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) , psb_def = lpat' , psb_dir = dir' } } -zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind" -zonk_bind _ (XHsBindsLR _) = panic "zonk_bind" +zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec +zonk_bind _ (XHsBindsLR nec) = noExtCon nec zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails (Located TcId) @@ -704,7 +704,7 @@ zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms) ; return (MG { mg_alts = cL l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } -zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup" +zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) @@ -715,7 +715,7 @@ zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats = 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 _)) = panic "zonkMatch" +zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" -- due to #15884 @@ -732,10 +732,10 @@ zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded new_rhs <- zBody env2 rhs return (GRHS xx new_guarded new_rhs) - zonk_grhs (XGRHS _) = panic "zonkGRHSs" + zonk_grhs (XGRHS nec) = noExtCon nec new_grhss <- mapM (wrapLocM zonk_grhs) grhss return (GRHSs x new_grhss (cL l new_binds)) -zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs" +zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec {- ************************************************************************ @@ -841,7 +841,7 @@ zonkExpr env (ExplicitTuple x tup_args boxed) ; 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{})) = panic "zonkExpr.XTupArg" + zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" -- due to #15884 @@ -877,7 +877,7 @@ zonkExpr env (HsMultiIf ty alts) = do { (env', guard') <- zonkStmts env zonkLExpr guard ; expr' <- zonkLExpr env' expr ; return $ GRHS x guard' expr' } - zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf" + zonk_alt (XGRHS nec) = noExtCon nec zonkExpr env (HsLet x (dL->L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds @@ -1057,7 +1057,7 @@ zonkCmd env (HsCmdDo ty (dL->L l stmts)) new_ty <- zonkTcTypeToTypeX env ty return (HsCmdDo new_ty (cL l new_stmts)) -zonkCmd _ (XCmd{}) = panic "zonkCmd" +zonkCmd _ (XCmd nec) = noExtCon nec @@ -1077,7 +1077,7 @@ zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) -- rules for arrows return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) -zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top" +zonk_cmd_top _ (XCmdTop nec) = noExtCon nec ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) @@ -1110,7 +1110,7 @@ zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) ; e' <- zonkExpr env e ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } -zonkOverLit _ XOverLit{} = panic "zonkOverLit" +zonkOverLit _ (XOverLit nec) = noExtCon nec ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc) @@ -1166,7 +1166,7 @@ zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) ; (env3, new_return) <- zonkSyntaxExpr env2 return_op ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) new_return) } - zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt" + zonk_branch _ (XParStmtBlock nec) = noExtCon nec zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id @@ -1264,13 +1264,13 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) get_pat (_, ApplicativeArgOne _ pat _ _) = pat get_pat (_, ApplicativeArgMany _ _ _ pat) = pat - get_pat (_, XApplicativeArg _) = panic "zonkStmt" + get_pat (_, XApplicativeArg nec) = noExtCon nec replace_pat pat (op, ApplicativeArgOne x _ a isBody) = (op, ApplicativeArgOne x pat a isBody) replace_pat pat (op, ApplicativeArgMany x a b _) = (op, ApplicativeArgMany x a b pat) - replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt" + replace_pat _ (_, XApplicativeArg nec) = noExtCon nec zonk_args env args = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) @@ -1294,9 +1294,9 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_ret <- zonkExpr env1 ret ; return (ApplicativeArgMany x new_stmts new_ret pat) } - zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg" + zonk_arg _ (XApplicativeArg nec) = noExtCon nec -zonkStmt _ _ (XStmtLR _) = panic "zonkStmt" +zonkStmt _ _ (XStmtLR nec) = noExtCon nec ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) @@ -1540,7 +1540,7 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} = 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 {})) = panic "zonk_tm_bndr XRuleBndr" + zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" -- due to #15884 @@ -1552,7 +1552,7 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} -- DV: used to be return (env,v) but that is plain -- wrong because we may need to go inside the kind -- of v and zonk there! -zonkRule _ (XRuleDecl _) = panic "zonkRule" +zonkRule _ (XRuleDecl nec) = noExtCon nec {- ************************************************************************ diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 489a35c..18fd249 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -195,7 +195,7 @@ kcHsSigType names (HsIB { hsib_body = hs_ty bindImplicitTKBndrs_Skol sig_vars $ tc_lhs_type typeLevelMode hs_ty liftedTypeKind -kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType" +kcHsSigType _ (XHsImplicitBndrs nec) = noExtCon nec tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking @@ -254,7 +254,7 @@ tc_hs_sig_type skol_info hs_sig_type ctxt_kind ; return (mkInvForAllTys kvs ty1) } -tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type" +tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type -- tcTopLHsType is used for kind-checking top-level HsType where @@ -279,7 +279,7 @@ tcTopLHsType hs_sig_type ctxt_kind ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) ; return final_ty} -tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType" +tcTopLHsType (XHsImplicitBndrs nec) _ = noExtCon nec ----------------- tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind])) @@ -381,7 +381,7 @@ tcHsTypeApp wc_ty kind ; ty <- zonkPromoteType ty ; checkValidType TypeAppCtxt ty ; return ty } -tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp" +tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec {- Note [Wildcards in visible type application] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1847,7 +1847,7 @@ kcLHsQTyVars_Cusk name flav ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind -kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars" +kcLHsQTyVars_Cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec ------------------------------ kcLHsQTyVars_NonCusk name flav @@ -1895,7 +1895,7 @@ kcLHsQTyVars_NonCusk name flav ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind -kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars" +kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars nec) _ = noExtCon nec {- Note [No polymorphic recursion] @@ -2140,7 +2140,7 @@ tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; new_tv tv_nm kind } -tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr" +tcHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec ----------------- tcHsQTyVarBndr :: ContextKind @@ -2173,7 +2173,7 @@ tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm) -- Used for error messages only -tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr" +tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec -------------------------------------- @@ -2530,8 +2530,8 @@ tcHsPartialSigType ctxt sig_ty ; traceTc "tcHsPartialSigType" (ppr all_tvs) ; return (wcs, wcx, tv_names, all_tvs, theta, tau) } -tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType" -tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType" +tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec +tcHsPartialSigType _ (XHsWildCardBndrs nec) = noExtCon nec tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) tcPartialContext hs_theta @@ -2641,8 +2641,8 @@ tcHsPatSigType ctxt sig_ty -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) ; return (name, tv) } -tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType" -tcHsPatSigType _ (XHsWildCardBndrs _) = panic "tcHsPatSigType" +tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec +tcHsPatSigType _ (XHsWildCardBndrs nec) = noExtCon nec tcPatSig :: Bool -- True <=> pattern binding -> LHsSigWcType GhcRn diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 9642756..b362cf7 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -461,7 +461,7 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) ; return (insts, fam_insts, deriv_infos) } -tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl" +tcLocalInstDecl (L _ (XInstDecl nec)) = noExtCon nec tcClsInstDecl :: LClsInstDecl GhcRn -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) @@ -539,7 +539,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds . dfid_eqn . unLoc) adts) -tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl" +tcClsInstDecl (L _ (XClsInstDecl nec)) = noExtCon nec {- ************************************************************************ diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 48410e0..1a19849 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -222,7 +222,7 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) } -tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches" +tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec ------------- tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body @@ -242,7 +242,7 @@ tcMatch ctxt pat_tys rhs_ty match ; return (Match { m_ext = noExt , m_ctxt = mc_what ctxt, m_pats = pats' , m_grhss = grhss' }) } - tc_match _ _ _ (XMatch _) = panic "tcMatch" + tc_match _ _ _ (XMatch nec) = noExtCon nec -- For (\x -> e), tcExpr has already said "In the expression \x->e" -- so we don't want to add "In the lambda abstraction \x->e" @@ -267,7 +267,7 @@ tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss ; return (GRHSs noExt grhss' (L l binds')) } -tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs" +tcGRHSs _ (XGRHSs nec) _ = noExtCon nec ------------- tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) @@ -280,7 +280,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs) ; return (GRHS noExt guards' rhs') } where stmt_ctxt = PatGuard (mc_what ctxt) -tcGRHS _ _ (XGRHS _) = panic "tcGRHS" +tcGRHS _ _ (XGRHS nec) = noExtCon nec {- ************************************************************************ @@ -470,7 +470,7 @@ tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside ; (pairs', thing) <- loop pairs ; return (ids, pairs', thing) } ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } - loop (XParStmtBlock{}:_) = panic "tcLcStmt" + loop (XParStmtBlock nec:_) = noExtCon nec tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap @@ -1072,12 +1072,12 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside } ; return (ApplicativeArgMany x stmts' ret' pat') } - goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts" + goArg (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 (XApplicativeArg _) = panic "tcApplicativeStmts" + get_arg_bndrs (XApplicativeArg nec) = noExtCon nec {- Note [ApplicativeDo and constraints] @@ -1134,5 +1134,5 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) args_in_match :: LMatch GhcRn body -> Int args_in_match (L _ (Match { m_pats = pats })) = length pats - args_in_match (L _ (XMatch _)) = panic "checkArgs" -checkArgs _ (XMatchGroup{}) = panic "checkArgs" + args_in_match (L _ (XMatch nec)) = noExtCon nec +checkArgs _ (XMatchGroup nec) = noExtCon nec diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 5dcee99..4c73b4c 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -102,7 +102,7 @@ recoverPSB (PSB { psb_id = (dL->L _ name) matcher_id = mkLocalId matcher_name $ mkSpecForAllTys [alphaTyVar] alphaTy -recoverPSB (XPatSynBind {}) = panic "recoverPSB" +recoverPSB (XPatSynBind nec) = noExtCon nec {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -187,7 +187,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details , mkTyVarTys ex_tvs, prov_theta, prov_evs) (map nlHsVar args, map idType args) pat_ty rec_fields } } -tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl" +tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec mkProvEvidence :: EvId -> Maybe (PredType, EvTerm) -- See Note [Equality evidence in pattern synonyms] @@ -434,7 +434,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details -- Why do we need tcSubType here? -- See Note [Pattern synonyms and higher rank types] ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl" +tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec {- [Pattern synonyms and higher rank types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -882,7 +882,7 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg -tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind" +tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 60ff333..6f6566c 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -552,7 +552,7 @@ tc_rn_src_decls ds ("Declaration splices are not " ++ "permitted inside top-level " ++ "declarations added with addTopDecls")) - ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls" + ; Just (XSpliceDecl nec, _) -> noExtCon nec } -- Rename TH-generated top-level declarations ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env @@ -595,7 +595,7 @@ tc_rn_src_decls ds ; return (tcg_env, tcl_env, lie1 `andWC` lie2) } - ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls" + ; Just (XSpliceDecl nec, _) -> noExtCon nec } } @@ -632,8 +632,8 @@ tcRnHsBootDecls hsc_src decls -- Check for illegal declarations ; case group_tail of Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d - Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls" - Nothing -> return () + Just (XSpliceDecl nec, _) -> noExtCon nec + Nothing -> return () ; mapM_ (badBootDecl hsc_src "foreign") for_decls ; mapM_ (badBootDecl hsc_src "default") def_decls ; mapM_ (badBootDecl hsc_src "rule") rule_decls diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index bfedaf2..dbf1d5c 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1020,7 +1020,7 @@ splice. In particular it is not set when the splice is renamed or typechecked. 'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert the finalizer (see Note [Delaying modFinalizers in untyped splices]), and 'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to -set 'RunSplice' when renaming or typechecking the splice, where 'Splice', +set 'RunSplice' when renaming or typechecking the splice, where 'Splice', 'Brack' or 'Comp' are used instead. -} @@ -3667,7 +3667,7 @@ exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" -exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" +exprCtOrigin (XExpr nec) = noExtCon nec -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin @@ -3678,17 +3678,17 @@ matchesCtOrigin (MG { mg_alts = alts }) | otherwise = Shouldn'tHappenOrigin "multi-way match" -matchesCtOrigin (XMatchGroup{}) = panic "matchesCtOrigin" +matchesCtOrigin (XMatchGroup nec) = noExtCon nec -- | Extract a suitable CtOrigin from guarded RHSs grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss -grhssCtOrigin (XGRHSs _) = panic "grhssCtOrigin" +grhssCtOrigin (XGRHSs nec) = noExtCon nec -- | Extract a suitable CtOrigin from a list of guarded RHSs lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e -lGRHSCtOrigin [L _ (XGRHS _)] = panic "lGRHSCtOrigin" +lGRHSCtOrigin [L _ (XGRHS nec)] = noExtCon nec lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" pprCtLoc :: CtLoc -> SDoc diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index f1d5495..9b4c38c 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -69,7 +69,7 @@ tcRuleDecls (HsRules { rds_src = src ; return $ HsRules { rds_ext = noExt , rds_src = src , rds_rules = tc_decls } } -tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls" +tcRuleDecls (XRuleDecls nec) = noExtCon nec tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) tcRule (HsRule { rd_ext = ext @@ -144,7 +144,7 @@ tcRule (HsRule { rd_ext = ext , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (all_qtkvs ++ tpl_ids) , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } -tcRule (XRuleDecl _) = panic "tcRule" +tcRule (XRuleDecl nec) = noExtCon nec generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn @@ -203,7 +203,7 @@ tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ tcRuleTmBndrs rule_bndrs ; return (map snd tvs ++ tyvars, id : tmvars) } -tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs" +tcRuleTmBndrs (L _ (XRuleBndr nec) : _) = noExtCon nec ruleCtxt :: FastString -> SDoc ruleCtxt name = text "When checking the transformation rule" <+> diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 5d8d92a..7f0ff2c 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -258,8 +258,8 @@ isCompleteHsSig :: LHsSigWcType GhcRn -> Bool isCompleteHsSig (HsWC { hswc_ext = wcs , hswc_body = HsIB { hsib_body = hs_ty } }) = null wcs && no_anon_wc hs_ty -isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig" -isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig" +isCompleteHsSig (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec +isCompleteHsSig (XHsWildCardBndrs nec) = noExtCon nec no_anon_wc :: LHsType GhcRn -> Bool no_anon_wc lty = go lty @@ -300,7 +300,7 @@ no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs where go (UserTyVar _ _) = True go (KindedTyVar _ _ ki) = no_anon_wc ki - go (XTyVarBndr{}) = panic "no_anon_wc_bndrs" + go (XTyVarBndr nec) = noExtCon nec {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -465,7 +465,7 @@ tcPatSynSig name sig_ty mkSpecForAllTys ex $ mkPhiTy prov $ body -tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig" +tcPatSynSig _ (XHsImplicitBndrs nec) = noExtCon nec ppr_tvs :: [TyVar] -> SDoc ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index c495a72..b60a057 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -206,9 +206,9 @@ tcBrackTy (ExpBr {}) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) tcBrackTy (TypBr {}) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec] tcBrackTy (PatBr {}) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) -tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL" -tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr" -tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket" +tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL" +tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr" +tcBrackTy (XBracket nec) = noExtCon nec --------------- tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 1ac12b0..ad66355 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -185,7 +185,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds ; setGblEnv gbl_env $ tcInstDecls1 instds } -tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup" +tcTyClGroup (XTyClGroup nec) = noExtCon nec tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon] tcTyClDecls tyclds role_annots @@ -1031,8 +1031,8 @@ getInitialKind cusk (SynDecl { tcdLName = dL->L _ name HsKindSig _ _ k -> Just k _ -> Nothing -getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind" -getInitialKind _ (XTyClDecl _) = panic "getInitialKind" +getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec +getInitialKind _ (XTyClDecl nec) = noExtCon nec --------------------------------- getFamDeclInitialKinds @@ -1071,7 +1071,7 @@ getFamDeclInitialKind parent_cusk mb_parent_tycon ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) ClosedTypeFamilyFlavour ctxt = TyFamResKindCtxt name -getFamDeclInitialKind _ _ (XFamilyDecl _) = panic "getFamDeclInitialKind" +getFamDeclInitialKind _ _ (XFamilyDecl nec) = noExtCon nec ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () @@ -1132,9 +1132,9 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) do { fam_tc <- kcLookupTcTyCon fam_tc_name ; mapM_ (kcTyFamInstEqn fam_tc) eqns } _ -> return () -kcTyClDecl (FamDecl _ (XFamilyDecl _)) = panic "kcTyClDecl" -kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "kcTyClDecl" -kcTyClDecl (XTyClDecl _) = panic "kcTyClDecl" +kcTyClDecl (FamDecl _ (XFamilyDecl nec)) = noExtCon nec +kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec +kcTyClDecl (XTyClDecl nec) = noExtCon nec ------------------- kcConDecl :: ConDecl GhcRn -> TcM () @@ -1172,8 +1172,8 @@ kcConDecl (ConDeclGADT { con_names = names ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) ; _ <- tcHsOpenType res_ty ; return () } -kcConDecl (XConDecl _) = panic "kcConDecl" -kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl" +kcConDecl (XConDecl nec) = noExtCon nec +kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) = noExtCon nec {- Note [Recursion and promoting data constructors] @@ -1369,7 +1369,7 @@ tcTyClDecl1 _parent roles_info meths fundeps sigs ats at_defs ; return (classTyCon clas) } -tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1" +tcTyClDecl1 _ _ (XTyClDecl nec) = noExtCon nec {- ********************************************************************* @@ -1532,9 +1532,9 @@ tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = L _ tc_name -- We check for well-formedness and validity later, -- in checkValidClass } -tcDefaultAssocDecl _ [dL->L _ (XFamEqn _)] = panic "tcDefaultAssocDecl" -tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars _) _ _)] - = panic "tcDefaultAssocDecl" +tcDefaultAssocDecl _ [dL->L _ (XFamEqn nec)] = noExtCon nec +tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars nec) _ _)] + = noExtCon nec tcDefaultAssocDecl _ [_] = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 @@ -1666,7 +1666,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info ; return fam_tc } } | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker -tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1" +tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec -- | Maybe return a list of Bools that say whether a type family was declared -- injective in the corresponding type arguments. Length of the list is equal to @@ -1794,7 +1794,7 @@ tcDataDefn roles_info DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) -tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn" +tcDataDefn _ _ _ _ (XHsDataDefn nec) = noExtCon nec ------------------------- @@ -1832,8 +1832,8 @@ kcTyFamInstEqn tc_fam_tc where vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn" -kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn" +kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec +kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884 @@ -2354,9 +2354,9 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl ; traceTc "tcConDecl 2" (ppr names) ; mapM buildOneDataCon names } -tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) - = panic "tcConDecl" -tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl" +tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) + = noExtCon nec +tcConDecl _ _ _ _ (XConDecl nec) = noExtCon nec tcConIsInfixH98 :: Name -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) @@ -3669,8 +3669,8 @@ tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_body = eqn }}) = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") (unLoc (feqn_tycon eqn)) -tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _)) - = panic "tcMkDataFamInstCtxt" +tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a tcAddDataFamInstCtxt decl @@ -3867,7 +3867,7 @@ wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots)) text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) -wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles" +wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match" -- due to #15884 @@ -3878,7 +3878,7 @@ illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _)) setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl" +illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match" -- due to #15884 diff --git a/utils/haddock b/utils/haddock -Subproject 65bbdfb6dc1b08f893187e1847985aad4505fcd +Subproject da08b1634b581cabab3c1a4799d64a2281fbcb8 |