diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-02 10:33:49 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-08 17:08:16 +0200 |
| commit | 5b132838e86d0fc4ad647a80c7b889fbcf3cafa7 (patch) | |
| tree | e8040ef11c1eaa163c773f24bd3accd4f0a9788a | |
| parent | 4e038c9aac531ffb2c17b9178137612c0a846af6 (diff) | |
| download | haskell-wip/restore-ttg.tar.gz | |
Restore TTG Path 3wip/restore-ttg
Originally 47ad6578ea460999b53eb4293c3a3b3017a56d65
36 files changed, 640 insertions, 429 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index f889ba893b..1f84114726 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -632,9 +632,10 @@ addTickHsExpr (HsWrap x w e) = addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present e')) } +addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present x e')) } addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) +addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg" addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) @@ -770,11 +771,12 @@ addTickApplicativeArg isGuard (op, arg) = addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) -addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = - liftM3 ParStmtBlock +addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = + liftM3 (ParStmtBlock x) (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr) +addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders" addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds binds) = @@ -820,12 +822,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) -addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = - liftM4 HsCmdTop +addTickHsCmdTop (HsCmdTop x cmd) = + liftM2 HsCmdTop + (return x) (addTickLHsCmd cmd) - (return tys) - (return ty) - (return syntaxtable) +addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop" addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (L pos c0) = do @@ -833,10 +834,10 @@ addTickLHsCmd (L pos c0) = do return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam matchgroup) = - liftM HsCmdLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp c e) = - liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e) +addTickHsCmd (HsCmdLam x matchgroup) = + liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp x c e) = + liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) {- addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp @@ -845,41 +846,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) = (return fix) (addTickLHsCmd c3) -} -addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e) -addTickHsCmd (HsCmdCase e mgs) = - liftM2 HsCmdCase +addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) +addTickHsCmd (HsCmdCase x e mgs) = + liftM2 (HsCmdCase x) (addTickLHsExpr e) (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdIf cnd e1 c2 c3) = - liftM3 (HsCmdIf cnd) +addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = + liftM3 (HsCmdIf x cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet (L l binds) c) = +addTickHsCmd (HsCmdLet x (L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet . L l) + liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsCmdDo (L l stmts) srcloc) +addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo (L l stmts') srcloc) } + ; return (HsCmdDo srcloc (L l stmts')) } -addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = +addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = liftM5 HsCmdArrApp + (return arr_ty) (addTickLHsExpr e1) (addTickLHsExpr e2) (return ty1) - (return arr_ty) (return lr) -addTickHsCmd (HsCmdArrForm e f fix cmdtop) = - liftM4 HsCmdArrForm +addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = + liftM4 (HsCmdArrForm x) (addTickLHsExpr e) (return f) (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -addTickHsCmd (HsCmdWrap w cmd) - = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd) +addTickHsCmd (HsCmdWrap x w cmd) + = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) + +addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index c9c0a089c7..61dc7c5b5b 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -313,7 +313,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd @@ -328,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) +dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr" {- Translation of a command judgement of the form @@ -363,7 +364,7 @@ dsCmd :: DsCmdEnv -- arrow combinators -- ---> premap (\ ((xs), _stk) -> arg) fun dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) + (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -388,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty -- ---> premap (\ ((xs), _stk) -> (fun, arg)) app dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) + (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -416,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd -dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do core_arg <- dsLExpr arg let arg_ty = exprType core_arg @@ -449,7 +450,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats = pats + (HsCmdLam _ (MG { mg_alts = L _ [L _ (Match { m_pats = pats , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) @@ -479,7 +480,7 @@ dsCmd ids local_vars stack_ty res_ty return (do_premap ids in_ty in_ty' res_ty select_code core_body, free_vars `udfmMinusUFM` getUniqSet pat_vars) -dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids -- D, xs |- e :: Bool @@ -492,7 +493,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids -- if e then Left ((xs1),stk) else Right ((xs2),stk)) -- (c1 ||| c2) -dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) +dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) env_ids = do core_cond <- dsLExpr cond (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd @@ -553,8 +554,8 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys - , mg_origin = origin })) + (HsCmdCase _ exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys + , mg_origin = origin })) env_ids = do stack_id <- newSysLocalDs stack_ty @@ -616,7 +617,8 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) + env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -641,7 +643,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) + env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty (text "In the do-command:" <+> ppr do_block) @@ -661,14 +664,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e -- ----------------------------------- -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do +dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionDVarSets fv_sets) -dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids core_wrap <- dsHsWrapper wrap return (core_wrap core_cmd, env_ids') @@ -685,7 +688,8 @@ dsTrimCmdArg -> LHsCmdTop GhcTc -- command argument to desugar -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free -dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do +dsTrimCmdArg local_vars env_ids + (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd stack_id <- newSysLocalDs stack_ty @@ -696,6 +700,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do arg_code = if env_ids' == env_ids then core_cmd else do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd return (mkLets meth_binds arg_code, free_vars) +dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg" -- Given D; xs |-a c : stk --> t, builds c with xs fed back. -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index f058e9ba73..0eb5c0e376 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -370,11 +370,12 @@ ds_expr _ (ExplicitTuple _ tup_args boxity) -- another lambda in the desugaring. = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present expr)) + go (lam_vars, args) (L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr ; return (lam_vars, core_expr : args) } + go _ (L _ (XTupArg {})) = panic "ds_expr" ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 7ca85eb3f5..36c2730aff 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -82,7 +82,7 @@ dsListComp lquals res_ty = do -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) -dsInnerListComp (ParStmtBlock stmts bndrs _) +dsInnerListComp (ParStmtBlock _ stmts bndrs _) = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs list_ty = mkListTy bndrs_tuple_type @@ -90,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _) ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) } +dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp" -- 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 @@ -105,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts + from_bndrs noSyntaxExpr) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments @@ -253,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) quals list } where - bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs] + bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above pat = mkBigLHsPatTupId pats @@ -623,13 +625,15 @@ dePArrParComp qss quals = do deParStmt [] = -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" - deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement + deParStmt (ParStmtBlock _ qs xs _:qss) = do -- first statement let res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) parStmts qss (mkLHsVarPatTup xs) cqs + deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp" --- parStmts [] pa cea = return (pa, cea) - parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed) + parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do + -- subsequent statements (zip'ed) zipP <- dsDPHBuiltin zipPVar let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea @@ -638,6 +642,7 @@ dePArrParComp qss quals = do let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] parStmts qss pa' cea' + parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp" -- generate Core corresponding to `\p -> e' -- @@ -777,7 +782,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest ; mzip_op' <- dsExpr mzip_op ; let -- The pattern variables - pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks] + pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] -- Pattern with tuples of variables -- [v1,v2,v3] => (v1, (v2, v3)) pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats @@ -788,9 +793,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } where - ds_inner (ParStmtBlock stmts bndrs return_op) + ds_inner (ParStmtBlock _ stmts bndrs return_op) = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) } + ds_inner (XParStmtBlock{}) = panic "dsMcStmt" dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 75b150c9f2..fd8da266ae 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -77,13 +77,14 @@ dsBracket brack splices where new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] - do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } - do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } - 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 (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 } + 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" {- -------------- Examples -------------------- @@ -1140,10 +1141,11 @@ repRole (L _ Nothing) = rep2 inferRName [] repSplice :: HsSplice GhcRn -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ n _) = rep_splice n -repSplice (HsUntypedSplice _ n _) = rep_splice n -repSplice (HsQuasiQuote n _ _ _) = rep_splice n -repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e) +repSplice (HsTypedSplice _ _ n _) = rep_splice n +repSplice (HsUntypedSplice _ _ n _) = rep_splice n +repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n +repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) +repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e) rep_splice :: Name -> DsM (Core a) rep_splice splice_name @@ -1248,9 +1250,9 @@ repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple _ es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) - | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs } - | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es] - ; repUnboxedTup xs } + | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs } + | otherwise = do { xs <- repLEs [e | L _ (Present _ e) <- es] + ; repUnboxedTup xs } repE (ExplicitSum _ alt arity e) = do { e1 <- repLE e @@ -1425,10 +1427,11 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) = where rep_stmt_block :: ParStmtBlock GhcRn GhcRn -> DsM ([GenSymBind], Core [TH.StmtQ]) - rep_stmt_block (ParStmtBlock stmts _ _) = + rep_stmt_block (ParStmtBlock _ stmts _ _) = do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs ; return (ss1, zs1) } + rep_stmt_block (XParStmtBlock{}) = panic "repSts" repSts [LastStmt e _ _] = do { e2 <- repLE e ; z <- repNoBindSt e2 diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 626d0a9c4e..c4fb7e7f30 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -1031,8 +1031,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 wrap res_wrap1 res_wrap2 --------- - tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2 - tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 + tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 437732da30..f008a31d4b 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -252,7 +252,7 @@ hsExprToPmExpr e@(ExplicitTuple _ ps boxity) | otherwise = PmExprOther e where tuple_con = tupleDataCon boxity (length ps) - tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ] + tuple_args = [ lhsExprToPmExpr e | L _ (Present _ e) <- ps ] hsExprToPmExpr e@(ExplicitList _ mb_ol elems) | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 5d39be95dd..57feb9ad6a 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -214,7 +214,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = PlaceHolder + , tcdDataCusk = placeHolder , tcdFVs = placeHolderNames }) } cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) @@ -230,7 +230,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = PlaceHolder + , tcdDataCusk = placeHolder , tcdFVs = placeHolderNames }) } cvtDec (ClassD ctxt cl tvs fds decs) @@ -814,10 +814,12 @@ cvtl e = wrapL (cvt e) -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es ; return $ ExplicitTuple noExt - (map (noLoc . Present) es') Boxed } + (map (noLoc . (Present noExt)) es') + Boxed } cvt (UnboxedTupE es) = do { es' <- mapM cvtl es ; return $ ExplicitTuple noExt - (map (noLoc . Present) es') Unboxed } + (map (noLoc . (Present noExt)) es') + Unboxed } cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e ; unboxedSumChecks alt arity ; return $ ExplicitSum noExt @@ -1009,8 +1011,9 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds ; returnL $ LetStmt (noLoc ds') } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType } - where - cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } + where + cvt_one ds = do { ds' <- cvtStmts ds + ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) } cvtMatch :: HsMatchContext RdrName -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -1133,7 +1136,7 @@ cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p ; return $ AsPat noExt s' p' } -cvtp TH.WildP = return $ WildPat placeHolderType +cvtp TH.WildP = return $ WildPat noExt cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index dc1a0e9341..5fa0a62687 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -121,47 +121,13 @@ deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR) -- --------------------------------------------------------------------- -- Deal with ValBindsOut +-- TODO: make this the only type for ValBinds data NHsValBindsLR idL = NValBinds [(RecFlag, LHsBinds idL)] [LSig GhcRn] deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL) -{- --- The ValBindsIn pattern exists so we can use the COMPLETE pragma for these --- patterns -pattern - ValBindsIn :: - (XValBinds idL idR) -> - (LHsBindsLR idL idR) -> - [LSig idR] -> - HsValBindsLR idL idR -pattern - ValBindsOut :: - [(RecFlag, LHsBinds idL)] -> - [LSig GhcRn] -> - HsValBindsLR idL idR - -pattern - ValBindsIn x b s - = ValBinds x b s -pattern - ValBindsOut a b - = XValBindsLR (NValBindsOut a b) - -{-# - COMPLETE - ValBindsIn, - ValBindsOut - #-} --} - --- This is not extensible using the parameterised GhcPass namespace --- type instance --- XValBinds (GhcPass pass) (GhcPass pass') = NoFieldExt --- type instance --- XNewValBindsLR (GhcPass pass) (GhcPass pass') --- = NewHsValBindsLR (GhcPass pass) (GhcPass pass') type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder type instance XXValBindsLR (GhcPass pL) (GhcPass pR) = NHsValBindsLR (GhcPass pL) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 0ee284f192..54314a9048 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -99,7 +99,7 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PlaceHolder(..) ) +import PlaceHolder ( PlaceHolder, placeHolder ) import HsExtension import NameSet @@ -1770,10 +1770,10 @@ deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass) -} noForeignImportCoercionYet :: PlaceHolder -noForeignImportCoercionYet = PlaceHolder +noForeignImportCoercionYet = placeHolder noForeignExportCoercionYet :: PlaceHolder -noForeignExportCoercionYet = PlaceHolder +noForeignExportCoercionYet = placeHolder -- Specification Of an imported external entity in dependence on the calling -- convention diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 521b31eb56..92797faf40 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -743,7 +743,6 @@ data RecordUpdTc = RecordUpdTc } deriving Data -- --------------------------------------------------------------------- -type instance XVarPat (GhcPass _) = PlaceHolder type instance XVar (GhcPass _) = PlaceHolder type instance XUnboundVar (GhcPass _) = PlaceHolder @@ -860,13 +859,23 @@ type LHsTupArg id = Located (HsTupArg id) -- | Haskell Tuple Argument data HsTupArg id - = Present (LHsExpr id) -- ^ The argument - | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type + = Present (XPresent id) (LHsExpr id) -- ^ The argument + | Missing (XMissing id) -- ^ The argument is missing, but this is its type + | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point deriving instance (DataIdLR id id) => Data (HsTupArg id) +type instance XPresent (GhcPass _) = PlaceHolder + +type instance XMissing GhcPs = PlaceHolder +type instance XMissing GhcRn = PlaceHolder +type instance XMissing GhcTc = Type + +type instance XXTupArg (GhcPass _) = PlaceHolder + tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True tupArgPresent (L _ (Missing {})) = False +tupArgPresent (L _ (XTupArg {})) = False {- Note [Parens in HsSyn] @@ -1054,11 +1063,13 @@ ppr_expr (ExplicitTuple _ exprs boxity) = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) where ppr_tup_args [] = [] - ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es - ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es punc (Present {} : _) = comma <> space punc (Missing {} : _) = comma + punc (XTupArg {} : _) = comma <> space punc [] = empty ppr_expr (ExplicitSum _ alt arity expr) @@ -1149,8 +1160,10 @@ ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps ppr_expr (HsTcBracketOut _ e []) = ppr e ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps -ppr_expr (HsProc _ pat (L _ (HsCmdTop cmd _ _ _))) +ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] +ppr_expr (HsProc _ pat (L _ (XCmdTop x))) + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x] ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] @@ -1306,10 +1319,10 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (XCmdArrApp id) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t (LHsExpr id) -- arrow expression, f (LHsExpr id) -- input expression, arg - (PostTc id Type) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t HsArrAppType -- higher-order (-<<) or first-order (-<) Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) @@ -1319,6 +1332,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XCmdArrForm id) (LHsExpr id) -- The operator. -- After type-checking, a type abstraction to be -- applied to the type of the local environment tuple @@ -1328,22 +1342,26 @@ data HsCmd id -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands - | HsCmdApp (LHsCmd id) + | HsCmdApp (XCmdApp id) + (LHsCmd id) (LHsExpr id) - | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa + | HsCmdLam (XCmdLam id) + (MatchGroup id (LHsCmd id)) -- kappa -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdPar (LHsCmd id) -- parenthesised command + | HsCmdPar (XCmdPar id) + (LHsCmd id) -- parenthesised command -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdCase (LHsExpr id) + | HsCmdCase (XCmdCase id) + (LHsExpr id) (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, @@ -1351,7 +1369,8 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function + | HsCmdIf (XCmdIf id) + (Maybe (SyntaxExpr id)) -- cond function (LHsExpr id) -- predicate (LHsCmd id) -- then part (LHsCmd id) -- else part @@ -1362,7 +1381,8 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdLet (LHsLocalBinds id) -- let(rec) + | HsCmdLet (XCmdLet id) + (LHsLocalBinds id) -- let(rec) (LHsCmd id) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', -- 'ApiAnnotation.AnnOpen' @'{'@, @@ -1370,8 +1390,8 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdDo (Located [CmdLStmt id]) - (PostTc id Type) -- Type of the whole expression + | HsCmdDo (XCmdDo id) -- Type of the whole expression + (Located [CmdLStmt id]) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnVbar', @@ -1379,12 +1399,33 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdWrap HsWrapper + | HsCmdWrap (XCmdWrap id) + HsWrapper (HsCmd id) -- If cmd :: arg1 --> res -- wrap :: arg1 "->" arg2 -- Then (HsCmdWrap wrap cmd) :: arg2 --> res + | XCmd (XXCmd id) -- Note [Trees that Grow] extension point deriving instance (DataIdLR id id) => Data (HsCmd id) +type instance XCmdArrApp GhcPs = PlaceHolder +type instance XCmdArrApp GhcRn = PlaceHolder +type instance XCmdArrApp GhcTc = Type + +type instance XCmdArrForm (GhcPass _) = PlaceHolder +type instance XCmdApp (GhcPass _) = PlaceHolder +type instance XCmdLam (GhcPass _) = PlaceHolder +type instance XCmdPar (GhcPass _) = PlaceHolder +type instance XCmdCase (GhcPass _) = PlaceHolder +type instance XCmdIf (GhcPass _) = PlaceHolder +type instance XCmdLet (GhcPass _) = PlaceHolder + +type instance XCmdDo GhcPs = PlaceHolder +type instance XCmdDo GhcRn = PlaceHolder +type instance XCmdDo GhcTc = Type + +type instance XCmdWrap (GhcPass _) = PlaceHolder +type instance XXCmd (GhcPass _) = PlaceHolder + -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp deriving Data @@ -1400,12 +1441,23 @@ type LHsCmdTop p = Located (HsCmdTop p) -- | Haskell Top-level Command data HsCmdTop p - = HsCmdTop (LHsCmd p) - (PostTc p Type) -- Nested tuple of inputs on the command's stack - (PostTc p Type) -- return type of the command - (CmdSyntaxTable p) -- See Note [CmdSyntaxTable] + = HsCmdTop (XCmdTop p) + (LHsCmd p) + | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point deriving instance (DataIdLR p p) => Data (HsCmdTop p) +data CmdTopTc + = CmdTopTc Type -- Nested tuple of inputs on the command's stack + Type -- return type of the command + (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + deriving Data + +type instance XCmdTop GhcPs = PlaceHolder +type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] +type instance XCmdTop GhcTc = CmdTopTc + +type instance XXCmdTop (GhcPass _) = PlaceHolder + instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where ppr cmd = pprCmd cmd @@ -1423,9 +1475,9 @@ isQuietHsCmd :: HsCmd id -> Bool -- Parentheses do display something, but it gives little info and -- if we go deeper when we go inside them then we get ugly things -- like (...) -isQuietHsCmd (HsCmdPar _) = True +isQuietHsCmd (HsCmdPar {}) = True -- applications don't display anything themselves -isQuietHsCmd (HsCmdApp _ _) = True +isQuietHsCmd (HsCmdApp {}) = True isQuietHsCmd _ = False ----------------------- @@ -1433,69 +1485,71 @@ ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc -ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) +ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) -ppr_cmd (HsCmdApp c e) +ppr_cmd (HsCmdApp _ c e) = let (fun, args) = collect_args c [e] in hang (ppr_lcmd fun) 2 (sep (map ppr args)) where - collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) + collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) -ppr_cmd (HsCmdLam matches) +ppr_cmd (HsCmdLam _ matches) = pprMatches matches -ppr_cmd (HsCmdCase expr matches) +ppr_cmd (HsCmdCase _ expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] -ppr_cmd (HsCmdIf _ e ct ce) +ppr_cmd (HsCmdIf _ _ e ct ce) = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], nest 4 (ppr ct), text "else", nest 4 (ppr ce)] -- special case: let ... in let ... -ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _))) +ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lcmd cmd] -ppr_cmd (HsCmdLet (L _ binds) cmd) +ppr_cmd (HsCmdLet _ (L _ binds) cmd) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr cmd)] -ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts +ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts -ppr_cmd (HsCmdWrap w cmd) +ppr_cmd (HsCmdWrap _ w cmd) = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) -ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm op _ _ args) +ppr_cmd (HsCmdArrForm _ op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") +ppr_cmd (XCmd x) = ppr x pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc -pprCmdArg (HsCmdTop cmd _ _ _) +pprCmdArg (HsCmdTop _ cmd) = ppr_lcmd cmd +pprCmdArg (XCmdTop x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where ppr = pprCmdArg @@ -1533,6 +1587,7 @@ a function defined by pattern matching must have the same number of patterns in each equation. -} +-- AZ:TODO complete TTG on this, once DataId etc is resolved data MatchGroup p body = MG { mg_alts :: Located [LMatch p body] -- The alternatives , mg_arg_tys :: [PostTc p Type] -- Types of the arguments, t1..tn @@ -1548,6 +1603,7 @@ type LMatch id body = Located (Match id body) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a -- list +-- AZ:TODO complete TTG on this, once DataId etc is resolved -- For details on above see note [Api annotations] in ApiAnnotation data Match p body = Match { @@ -1635,6 +1691,7 @@ hsLMatchPats (L _ (Match { m_pats = pats })) = pats -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' +-- AZ:TODO complete TTG on this, once DataId etc is resolved -- For details on above see note [Api annotations] in ApiAnnotation data GRHSs p body = GRHSs { @@ -1646,6 +1703,7 @@ deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body) -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) +-- AZ:TODO complete TTG on this, once DataId etc is resolved -- | Guarded Right Hand Side. data GRHS id body = GRHS [GuardLStmt id] -- Guards body -- Right hand side @@ -1913,11 +1971,16 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by functio -- | Parenthesised Statement Block data ParStmtBlock idL idR = ParStmtBlock + (XParStmtBlock idL idR) [ExprLStmt idL] [IdP idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator + | XParStmtBlock (XXParStmtBlock idL idR) deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR) +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder + -- | Applicative Argument data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) @@ -2100,9 +2163,11 @@ Bool flag that is True when the original statement was a BodyStmt, so that we can pretty-print it correctly. -} -instance (Outputable (StmtLR idL idL (LHsExpr idL))) +instance (Outputable (StmtLR idL idL (LHsExpr idL)), + Outputable (XXParStmtBlock idL idR)) => Outputable (ParStmtBlock idL idR) where - ppr (ParStmtBlock stmts _ _) = interpp'SP stmts + ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts + ppr (XParStmtBlock x) = ppr x instance (idL ~ GhcPass pl,idR ~ GhcPass pr, OutputableBndrId idL, OutputableBndrId idR, @@ -2251,30 +2316,42 @@ pprQuals quals = interpp'SP quals -- | Haskell Splice data HsSplice id = HsTypedSplice -- $$z or $$(f 4) + (XTypedSplice id) SpliceDecoration -- Whether $$( ) variant found, for pretty printing (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsUntypedSplice -- $z or $(f 4) + (XUntypedSplice id) SpliceDecoration -- Whether $( ) variant found, for pretty printing (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice + (XQuasiQuote id) (IdP id) -- Splice point (IdP id) -- Quoter SrcSpan -- The span of the enclosed string FastString -- The enclosed string + -- AZ:TODO: use XSplice instead of HsSpliced | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in -- RnSplice. -- This is the result of splicing a splice. It is produced by -- the renamer and consumed by the typechecker. It lives only -- between the two. + (XSpliced id) ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing + | XSplice (XXSplice id) -- Note [Trees that Grow] extension point deriving instance (DataIdLR id id) => Data (HsSplice id) +type instance XTypedSplice (GhcPass _) = PlaceHolder +type instance XUntypedSplice (GhcPass _) = PlaceHolder +type instance XQuasiQuote (GhcPass _) = PlaceHolder +type instance XSpliced (GhcPass _) = PlaceHolder +type instance XXSplice (GhcPass _) = PlaceHolder + -- | 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 -- printer. @@ -2423,24 +2500,25 @@ pprSpliceDecl e ImplicitSplice = ppr_splice_decl e ppr_splice_decl :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc -ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty +ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc -pprSplice (HsTypedSplice HasParens n e) +pprSplice (HsTypedSplice _ HasParens n e) = ppr_splice (text "$$(") n e (text ")") -pprSplice (HsTypedSplice HasDollar n e) +pprSplice (HsTypedSplice _ HasDollar n e) = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice NoParens n e) +pprSplice (HsTypedSplice _ NoParens n e) = ppr_splice empty n e empty -pprSplice (HsUntypedSplice HasParens n e) +pprSplice (HsUntypedSplice _ HasParens n e) = ppr_splice (text "$(") n e (text ")") -pprSplice (HsUntypedSplice HasDollar n e) +pprSplice (HsUntypedSplice _ HasDollar n e) = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice NoParens n e) +pprSplice (HsUntypedSplice _ NoParens n e) = ppr_splice empty n e empty -pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ thing) = ppr thing +pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ _ thing) = ppr thing +pprSplice (XSplice x) = ppr x ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> @@ -2453,16 +2531,27 @@ ppr_splice herald n e trail = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail -- | Haskell Bracket -data HsBracket p = ExpBr (LHsExpr p) -- [| expr |] - | PatBr (LPat p) -- [p| pat |] - | DecBrL [LHsDecl p] -- [d| decls |]; result of parser - | DecBrG (HsGroup p) -- [d| decls |]; result of renamer - | TypBr (LHsType p) -- [t| type |] - | VarBr Bool (IdP p) -- True: 'x, False: ''T - -- (The Bool flag is used only in pprHsBracket) - | TExpBr (LHsExpr p) -- [|| expr ||] +data HsBracket p + = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] + | PatBr (XPatBr p) (LPat p) -- [p| pat |] + | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser + | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer + | TypBr (XTypBr p) (LHsType p) -- [t| type |] + | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) + | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] + | XBracket (XXBracket p) -- Note [Trees that Grow] extension point deriving instance (DataIdLR p p) => Data (HsBracket p) +type instance XExpBr (GhcPass _) = PlaceHolder +type instance XPatBr (GhcPass _) = PlaceHolder +type instance XDecBrL (GhcPass _) = PlaceHolder +type instance XDecBrG (GhcPass _) = PlaceHolder +type instance XTypBr (GhcPass _) = PlaceHolder +type instance XVarBr (GhcPass _) = PlaceHolder +type instance XTExpBr (GhcPass _) = PlaceHolder +type instance XXBracket (GhcPass _) = PlaceHolder + isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False @@ -2473,16 +2562,17 @@ instance (p ~ GhcPass pass, OutputableBndrId p) pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc -pprHsBracket (ExpBr e) = thBrackets empty (ppr e) -pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) -pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) -pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr True n) +pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) +pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr _ True n) = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr False n) +pprHsBracket (VarBr _ False n) = text "''" <> pprPrefixOcc n -pprHsBracket (TExpBr e) = thTyBrackets (ppr e) +pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) +pprHsBracket (XBracket e) = ppr e thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> @@ -2516,6 +2606,7 @@ data ArithSeqInfo id (LHsExpr id) (LHsExpr id) deriving instance (DataIdLR id id) => Data (ArithSeqInfo id) +-- AZ: Sould ArithSeqInfo have a TTG extension? instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ArithSeqInfo p) where diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index a1b7d2a79a..779ecc53e4 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -144,11 +144,11 @@ type ForallXPat (c :: * -> Constraint) (x :: *) = ) -- --------------------------------------------------------------------- -- ValBindsLR type families - + type family XValBinds x x' type family XXValBindsLR x x' - -type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)= + +type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = ( c (XValBinds x x') , c (XXValBindsLR x x') ) @@ -191,7 +191,7 @@ type ForallXHsLit (c :: * -> Constraint) (x :: *) = type family XOverLit x type family XXOverLit x - + type ForallXOverLit (c :: * -> Constraint) (x :: *) = ( c (XOverLit x) , c (XXOverLit x) @@ -407,6 +407,104 @@ type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = ) -- ---------------------------------------------------------------------- + +type family XPresent x +type family XMissing x +type family XXTupArg x + +type ForallXTupArg (c :: * -> Constraint) (x :: *) = + ( c (XPresent x) + , c (XMissing x) + , c (XXTupArg x) + ) + +-- --------------------------------------------------------------------- + +type family XTypedSplice x +type family XUntypedSplice x +type family XQuasiQuote x +type family XSpliced x +type family XXSplice x + +type ForallXSplice (c :: * -> Constraint) (x :: *) = + ( c (XTypedSplice x) + , c (XUntypedSplice x) + , c (XQuasiQuote x) + , c (XSpliced x) + , c (XXSplice x) + ) + +-- --------------------------------------------------------------------- + +type family XExpBr x +type family XPatBr x +type family XDecBrL x +type family XDecBrG x +type family XTypBr x +type family XVarBr x +type family XTExpBr x +type family XXBracket x + +type ForallXBracket (c :: * -> Constraint) (x :: *) = + ( c (XExpBr x) + , c (XPatBr x) + , c (XDecBrL x) + , c (XDecBrG x) + , c (XTypBr x) + , c (XVarBr x) + , c (XTExpBr x) + , c (XXBracket x) + ) + +-- --------------------------------------------------------------------- + +type family XCmdTop x +type family XXCmdTop x + +type ForallXCmdTop (c :: * -> Constraint) (x :: *) = + ( c (XCmdTop x) + , c (XXCmdTop x) + ) + +-- --------------------------------------------------------------------- + +type family XCmdArrApp x +type family XCmdArrForm x +type family XCmdApp x +type family XCmdLam x +type family XCmdPar x +type family XCmdCase x +type family XCmdIf x +type family XCmdLet x +type family XCmdDo x +type family XCmdWrap x +type family XXCmd x + +type ForallXCmd (c :: * -> Constraint) (x :: *) = + ( c (XCmdArrApp x) + , c (XCmdArrForm x) + , c (XCmdApp x) + , c (XCmdLam x) + , c (XCmdPar x) + , c (XCmdCase x) + , c (XCmdIf x) + , c (XCmdLet x) + , c (XCmdDo x) + , c (XCmdWrap x) + , c (XXCmd x) + ) + +-- --------------------------------------------------------------------- + +type family XParStmtBlock x x' +type family XXParStmtBlock x x' + +type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XParStmtBlock x x') + , c (XXParStmtBlock x x') + ) + +-- ---------------------------------------------------------------------- -- | Conversion of annotations from one type index to another. This is required -- where the AST is converted from one pass to another, and the extension values -- need to be brought along if possible. So for example a 'SourceText' is @@ -458,6 +556,8 @@ type OutputableX p = , Outputable (XAppTypeE p) , Outputable (XAppTypeE GhcRn) + + -- , Outputable (XXParStmtBlock (GhcPass idL) idR) ) -- TODO: Should OutputableX be included in OutputableBndrId? @@ -470,12 +570,15 @@ type DataId p = , ForallXHsLit Data p , ForallXPat Data p - -- AZ: The following ForAllXXXX shoulbe be unnecessary? Driven by ValBindsOut - -- , ForallXPat Data (GhcPass 'Parsed) - , ForallXPat Data (GhcPass 'Renamed) - -- , ForallXPat Data (GhcPass 'Typechecked) - , ForallXType Data (GhcPass 'Renamed) - , ForallXExpr Data (GhcPass 'Renamed) + -- Th following GhcRn constraints should go away once TTG is fully implemented + , ForallXPat Data GhcRn + , ForallXType Data GhcRn + , ForallXExpr Data GhcRn + , ForallXTupArg Data GhcRn + , ForallXSplice Data GhcRn + , ForallXBracket Data GhcRn + , ForallXCmdTop Data GhcRn + , ForallXCmd Data GhcRn , ForallXOverLit Data p , ForallXType Data p @@ -484,7 +587,12 @@ type DataId p = , ForallXFieldOcc Data p , ForallXAmbiguousFieldOcc Data p - , ForallXExpr Data p + , ForallXExpr Data p + , ForallXTupArg Data p + , ForallXSplice Data p + , ForallXBracket Data p + , ForallXCmdTop Data p + , ForallXCmd Data p , Data (NameOrRdrName (IdP p)) @@ -511,6 +619,11 @@ type DataIdLR pL pR = , ForallXValBindsLR Data pL pR , ForallXValBindsLR Data pL pL , ForallXValBindsLR Data pR pR + + , ForallXParStmtBlock Data pL pR + , ForallXParStmtBlock Data pL pL + , ForallXParStmtBlock Data pR pR + , ForallXParStmtBlock Data GhcRn GhcRn ) -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 9dfd80d69c..8ffde32b5a 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -15,7 +15,6 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} module HsPat ( Pat(..), InPat, OutPat, LPat, diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 7e7f559474..5be6ddb26e 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -73,7 +73,7 @@ import GhcPrelude import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import PlaceHolder ( PlaceHolder(..) ) +import PlaceHolder ( PlaceHolder(..), placeHolder ) import HsExtension import HsLit () -- for instances @@ -273,8 +273,8 @@ data LHsQTyVars pass -- See Note [HsType binders] deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass) mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs -mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs - , hsq_dependent = PlaceHolder } +mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs + , hsq_dependent = placeHolder } hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] hsQTvExplicit = hsq_explicit @@ -364,12 +364,12 @@ the explicitly forall'd tyvar 'a' is bound by the HsForAllTy mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing mkHsImplicitBndrs x = HsIB { hsib_body = x - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder } + , hsib_vars = placeHolder + , hsib_closed = placeHolder } mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x - , hswc_wcs = PlaceHolder } + , hswc_wcs = placeHolder } -- Add empty binders. This is a bit suspicious; what if -- the wrapped thing had free type variables? @@ -1205,7 +1205,7 @@ instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc PlaceHolder rdr +mkFieldOcc rdr = FieldOcc placeHolder rdr -- | Ambiguous Field Occurrence diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index ff2bd6e8aa..aa40ad65fa 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -50,7 +50,7 @@ module HsUtils( -- Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, - nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat, + nlWildPatName, nlTuplePat, mkParPat, nlParPat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types @@ -220,7 +220,7 @@ mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar noExt le) | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat PlaceHolder lp) +mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat noExt lp) | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) @@ -262,7 +262,7 @@ mkHsFractional f = OverLit noExt (HsFractional f) noExpr mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr noRebindableInfo :: PlaceHolder -noRebindableInfo = PlaceHolder -- Just another placeholder; +noRebindableInfo = placeHolder -- Just another placeholder; mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) @@ -298,7 +298,7 @@ emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noExpr , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr - , trS_bind_arg_ty = PlaceHolder + , trS_bind_arg_ty = placeHolder , trS_fmap = noExpr } mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } @@ -307,7 +307,7 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s mkLastStmt body = LastStmt body False noSyntaxExpr mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType -mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder +mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr placeHolder mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy -- don't use placeHolderTypeTc above, because that panics during zonking @@ -338,21 +338,22 @@ unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e +mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e) mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs mkHsSpliceTE hasParen e - = HsSpliceE noExt (HsTypedSplice hasParen unqualSplice e) + = HsSpliceE noExt (HsTypedSplice noExt hasParen unqualSplice e) mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs mkHsSpliceTy hasParen e = HsSpliceTy noExt - (HsUntypedSplice hasParen unqualSplice e) + (HsUntypedSplice noExt hasParen unqualSplice e) mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs -mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote +mkHsQuasiQuote quoter span quote + = HsQuasiQuote noExt unqualSplice quoter span quote unqualQuasiQuote :: RdrName unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) @@ -456,13 +457,10 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat))) nlWildPat :: LPat GhcPs -nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking +nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking nlWildPatName :: LPat GhcRn -nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking - -nlWildPatId :: LPat GhcTc -nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking +nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs @@ -512,7 +510,8 @@ types on the tuple. mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] = e -mkLHsTupleExpr es = noLoc $ ExplicitTuple noExt (map (noLoc . Present) es) Boxed +mkLHsTupleExpr es + = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) @@ -521,7 +520,7 @@ nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs nlTuplePat pats box = noLoc (TuplePat noExt pats box) missingTupArg :: HsTupArg GhcPs -missingTupArg = Missing placeHolderType +missingTupArg = Missing noExt mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed @@ -756,11 +755,11 @@ mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) -mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id +mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap w cmd + | otherwise = HsCmdWrap noExt w cmd -mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id +mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) @@ -1016,8 +1015,8 @@ collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders - $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders + $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss collectStmtBinders ApplicativeStmt{} = [] @@ -1057,7 +1056,7 @@ collect_lpat (L _ pat) bndrs go (SigPat _ pat) = collect_lpat pat bndrs - go (SplicePat _ (HsSpliced _ (HsSplicedPat pat))) + go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go pat go (SplicePat _ _) = bndrs go (CoPat _ _ pat _) = go pat @@ -1281,7 +1280,8 @@ lStmtsImplicits = hs_lstmts hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = emptyNameSet hs_stmt (LastStmt {}) = emptyNameSet - hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] + hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs + , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 19b4af017d..9d99c9a3cb 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -8,7 +8,6 @@ module PlaceHolder where import GhcPrelude ( Eq(..), Ord(..) ) -import Type ( Type ) import Outputable hiding ( (<>) ) import Name import NameSet @@ -36,21 +35,18 @@ data PlaceHolder = PlaceHolder instance Outputable PlaceHolder where ppr _ = text "PlaceHolder" +placeHolder :: PlaceHolder +placeHolder = PlaceHolder + placeHolderType :: PlaceHolder placeHolderType = PlaceHolder -placeHolderTypeTc :: Type -placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType" - placeHolderNames :: PlaceHolder placeHolderNames = PlaceHolder placeHolderNamesTc :: NameSet placeHolderNamesTc = emptyNameSet -placeHolderHsWrapper :: PlaceHolder -placeHolderHsWrapper = PlaceHolder - {- Note [Pass sensitive types] diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 3a3c7d206c..bbb75176bc 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2567,8 +2567,7 @@ aexp :: { LHsExpr GhcPs } | 'proc' aexp '->' exp {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> - ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop cmd placeHolderType - placeHolderType [])) + ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd)) -- TODO: is LL right here? [mj AnnProc $1,mu AnnRarrow $3] } @@ -2603,7 +2602,7 @@ aexp2 :: { LHsExpr GhcPs } ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2) - (Present $2)] Unboxed)) + (Present noExt $2)] Unboxed)) [mo $1,mc $3] } | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } } @@ -2615,20 +2614,20 @@ aexp2 :: { LHsExpr GhcPs } -- Template Haskell Extension | splice_exp { $1 } - | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr $2)) + | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr $2)) + | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr $2)) [mo $1,mu AnnCloseQ $3] } + | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> - ams (sLL $1 $> $ HsBracket noExt (PatBr p)) + ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL (snd $2))) + | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) } @@ -2657,8 +2656,7 @@ cmdargs :: { [LHsCmdTop GhcPs] } acmd :: { LHsCmdTop GhcPs } : aexp2 {% checkCommand $1 >>= \ cmd -> - return (sL1 $1 $ HsCmdTop cmd - placeHolderType placeHolderType []) } + return (sL1 $1 $ HsCmdTop noExt cmd) } cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 @@ -2699,7 +2697,7 @@ texp :: { LHsExpr GhcPs } tup_exprs :: { ([AddAnn],SumOrTuple) } : texp commas_tup_tail {% do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } } + ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } } | texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } @@ -2722,8 +2720,8 @@ commas_tup_tail : commas tup_tail -- Always follows a comma tup_tail :: { [LHsTupArg GhcPs] } : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> - return ((L (gl $1) (Present $1)) : snd $2) } - | texp { [L (gl $1) (Present $1)] } + return ((L (gl $1) (Present noExt $1)) : snd $2) } + | texp { [L (gl $1) (Present noExt $1)] } | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- @@ -2766,7 +2764,7 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | + qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock noExt qs [] noSyntaxExpr | qs <- qss] noExpr noSyntaxExpr placeHolderType] -- We actually found some actual parallel lists so diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index ef1a29bed6..68d152e62e 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -189,7 +189,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, - tcdDataCusk = PlaceHolder, + tcdDataCusk = placeHolder, tcdFVs = placeHolderNames })) } mkDataDefn :: NewOrData @@ -950,7 +950,7 @@ checkAPat msg loc e0 = do pState <- getPState let opts = options pState case e0 of - EWildPat _ -> return (WildPat placeHolderType) + EWildPat _ -> return (WildPat noExt) HsVar _ x -> return (VarPat noExt x) HsLit _ (HsStringPrim _ _) -- (#13260) -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) @@ -1001,7 +1001,7 @@ checkAPat msg loc e0 = do ExplicitTuple _ es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) - [e | L _ (Present e) <- es] + [e | L _ (Present _ e) <- es] return (TuplePat noExt ps b) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) @@ -1310,34 +1310,34 @@ locMap f (L l a) = f l a >>= (\b -> return $ L l b) checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs) checkCmd _ (HsArrApp _ e1 e2 haat b) = - return $ HsCmdArrApp e1 e2 noExt haat b + return $ HsCmdArrApp noExt e1 e2 haat b checkCmd _ (HsArrForm _ e mf args) = - return $ HsCmdArrForm e Prefix mf args + return $ HsCmdArrForm noExt e Prefix mf args checkCmd _ (HsApp _ e1 e2) = - checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) + checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2) checkCmd _ (HsLam _ mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg') checkCmd _ (HsPar _ e) = - checkCommand e >>= (\c -> return $ HsCmdPar c) + checkCommand e >>= (\c -> return $ HsCmdPar noExt c) checkCmd _ (HsCase _ e mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg') checkCmd _ (HsIf _ cf ep et ee) = do pt <- checkCommand et pe <- checkCommand ee - return $ HsCmdIf cf ep pt pe + return $ HsCmdIf noExt cf ep pt pe checkCmd _ (HsLet _ lb e) = - checkCommand e >>= (\c -> return $ HsCmdLet lb c) + checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c) checkCmd _ (HsDo _ DoExpr (L l stmts)) = mapM checkCmdLStmt stmts >>= - (\ss -> return $ HsCmdDo (L l ss) placeHolderType) + (\ss -> return $ HsCmdDo noExt (L l ss) ) checkCmd _ (OpApp _ eLeft op eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight - let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] - arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] - return $ HsCmdArrForm op Infix Nothing [arg1, arg2] + let arg1 = L (getLoc c1) $ HsCmdTop noExt c1 + arg2 = L (getLoc c2) $ HsCmdTop noExt c2 + return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2] checkCmd l e = cmdFail l e diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 9deb49ec3e..ec2b09f80d 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -282,10 +282,11 @@ rnExpr (ExplicitTuple x tup_args boxity) ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } where - rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e - ; return (L l (Present e'), fvs) } - rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) + rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e + ; return (L l (Present x e'), fvs) } + rnTupArg (L l (Missing _)) = return (L l (Missing noExt) , emptyFVs) + rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg" rnExpr (ExplicitSum x alt arity expr) = do { (expr', fvs) <- rnLExpr expr @@ -465,26 +466,26 @@ rnCmdArgs (arg:args) rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where - rnCmdTop' (HsCmdTop cmd _ _ _) + rnCmdTop' (HsCmdTop _ cmd) = do { (cmd', fvCmd) <- rnLCmd cmd ; let cmd_names = [arrAName, composeAName, firstAName] ++ nameSetElemsStable (methodNamesCmd (unLoc cmd')) -- Generate the rebindable syntax for the monad ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - ; return (HsCmdTop cmd' placeHolderType placeHolderType - (cmd_names `zip` cmd_names'), + ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', fvCmd `plusFV` cmd_fvs) } + rnCmdTop' (XCmdTop{}) = panic "rnCmdTop" rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) -rnCmd (HsCmdArrApp arrow arg _ ho rtl) +rnCmd (HsCmdArrApp x arrow arg ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + ; return (HsCmdArrApp x arrow' arg' ho rtl, fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of @@ -497,7 +498,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- inside 'arrow'. In the higher-order case (-<<), they are. -- infix form -rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) +rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) ; let L _ (HsVar _ (L _ op_name)) = op' ; (arg1',fv_arg1) <- rnCmdTop arg1 @@ -507,47 +508,48 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) ; final_e <- mkOpFormRn arg1' op' fixity arg2' ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } -rnCmd (HsCmdArrForm op f fixity cmds) +rnCmd (HsCmdArrForm x op f fixity cmds) = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) } + ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } -rnCmd (HsCmdApp fun arg) +rnCmd (HsCmdApp x fun arg) = do { (fun',fvFun) <- rnLCmd fun ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } + ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam matches) +rnCmd (HsCmdLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam matches', fvMatch) } + ; return (HsCmdLam x matches', fvMatch) } -rnCmd (HsCmdPar e) +rnCmd (HsCmdPar x e) = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar e', fvs_e) } + ; return (HsCmdPar x e', fvs_e) } -rnCmd (HsCmdCase expr matches) +rnCmd (HsCmdCase x expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdIf _ p b1 b2) +rnCmd (HsCmdIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 ; (b2', fvB2) <- rnLCmd b2 ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet (L l binds) cmd) +rnCmd (HsCmdLet x (L l binds) cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet (L l binds') cmd', fvExpr) } + ; return (HsCmdLet x (L l binds') cmd', fvExpr) } -rnCmd (HsCmdDo (L l stmts) _) +rnCmd (HsCmdDo x (L l stmts)) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) } + ; return ( HsCmdDo x (L l stmts'), fvs ) } rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) +rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -559,26 +561,28 @@ methodNamesLCmd = methodNamesCmd . unLoc methodNamesCmd :: HsCmd GhcRn -> CmdNeeds -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) = emptyFVs -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd +methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd -methodNamesCmd (HsCmdPar c) = methodNamesLCmd c +methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdIf _ _ c1 c2) +methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts -methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c -methodNamesCmd (HsCmdLam match) = methodNamesMatch match +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match -methodNamesCmd (HsCmdCase _ matches) +methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName +methodNamesCmd (XCmd {}) = panic "methodNamesCmd" + --methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient -- to error here so we just do what's convenient. @@ -862,7 +866,7 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder) + ; return (( [( L loc (BindStmt pat' body' bind_op fail_op placeHolder) , fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} @@ -945,7 +949,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map , trS_by = by', trS_using = using', trS_form = form , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = PlaceHolder + , trS_bind_arg_ty = placeHolder , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } rnStmt _ _ (L _ ApplicativeStmt{}) _ = @@ -970,7 +974,7 @@ rnParallelStmts ctxt return_op segs thing_inside ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } - rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) + rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do @@ -978,8 +982,9 @@ rnParallelStmts ctxt return_op segs thing_inside ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } - ; let seg' = ParStmtBlock stmts' used_bndrs return_op + ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } + rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts" cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" @@ -1195,7 +1200,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat) ; let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] } + L loc (BindStmt pat' body' bind_op fail_op placeHolder))] } rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) = failWith (badIpBinds (text "an mdo expression") binds) diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index bf24068e8e..320a34b4bf 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -385,7 +385,7 @@ rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) -rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) +rnPatAndThen _ (WildPat _) = return (WildPat noExt) rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (ParPat x pat') } rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat @@ -500,8 +500,8 @@ rnPatAndThen mk (SumPat x pat alt arity) } -- If a splice has been run already, just rename the result. -rnPatAndThen mk (SplicePat x (HsSpliced mfs (HsSplicedPat pat))) - = SplicePat x . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat +rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat))) + = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat rnPatAndThen mk (SplicePat _ splice) = do { eith <- liftCpsFV $ rnSplicePat splice diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index d18657b55e..fc7240ef44 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -114,7 +114,7 @@ rnBracket e br_body } rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) -rn_bracket outer_stage br@(VarBr flg rdr_name) +rn_bracket outer_stage br@(VarBr x flg rdr_name) = do { name <- lookupOccRn rdr_name ; this_mod <- getModule @@ -136,17 +136,18 @@ rn_bracket outer_stage br@(VarBr flg rdr_name) (quotedNameStageErr br) } } } - ; return (VarBr flg name, unitFV name) } + ; return (VarBr x flg name, unitFV name) } -rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr e', fvs) } +rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr x e', fvs) } -rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) +rn_bracket _ (PatBr x p) + = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) -rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr t', fvs) } +rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr x t', fvs) } -rn_bracket _ (DecBrL decls) +rn_bracket _ (DecBrL x decls) = do { group <- groupDecls decls ; gbl_env <- getGblEnv ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } @@ -158,7 +159,7 @@ rn_bracket _ (DecBrL decls) -- Discard the tcg_env; it contains only extra info about fixity ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))) - ; return (DecBrG group', duUses (tcg_dus tcg_env)) } + ; return (DecBrG x group', duUses (tcg_dus tcg_env)) } where groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls decls @@ -172,10 +173,12 @@ rn_bracket _ (DecBrL decls) } }} -rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" +rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" -rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (TExpBr e', fvs) } +rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr x e', fvs) } + +rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket" quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body @@ -293,10 +296,11 @@ runRnSplice flavour run_meta ppr_res splice = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) ; let the_expr = case splice' of - HsUntypedSplice _ _ e -> e - HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str - HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) - HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + HsUntypedSplice _ _ _ e -> e + HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str + HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) + HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + XSplice {} -> pprPanic "runRnSplice" (ppr splice) -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name @@ -334,14 +338,16 @@ runRnSplice flavour run_meta ppr_res splice makePending :: UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice -makePending flavour (HsUntypedSplice _ n e) +makePending flavour (HsUntypedSplice _ _ n e) = PendingRnSplice flavour n e -makePending flavour (HsQuasiQuote n quoter q_span quote) +makePending flavour (HsQuasiQuote _ n quoter q_span quote) = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) makePending _ splice@(HsTypedSplice {}) = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSpliced {}) = pprPanic "makePending" (ppr splice) +makePending _ splice@(XSplice {}) + = pprPanic "makePending" (ppr splice) ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString @@ -365,21 +371,21 @@ mkQuasiQuoteExpr flavour quoter q_span quote --------------------- rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all -rnSplice (HsTypedSplice hasParen splice_name expr) +rnSplice (HsTypedSplice x hasParen splice_name expr) = do { checkTH expr "Template Haskell typed splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr - ; return (HsTypedSplice hasParen n' expr', fvs) } + ; return (HsTypedSplice x hasParen n' expr', fvs) } -rnSplice (HsUntypedSplice hasParen splice_name expr) +rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { checkTH expr "Template Haskell untyped splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr - ; return (HsUntypedSplice hasParen n' expr', fvs) } + ; return (HsUntypedSplice x hasParen n' expr', fvs) } -rnSplice (HsQuasiQuote splice_name quoter q_loc quote) +rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { checkTH quoter "Template Haskell quasi-quote" ; loc <- getSrcSpanM ; splice_name' <- newLocalBndrRn (L loc splice_name) @@ -390,9 +396,11 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote) ; when (nameIsLocalOrFrom this_mod quoter') $ checkThLocalName quoter' - ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') } + ; return (HsQuasiQuote x splice_name' quoter' q_loc quote + , unitFV quoter') } rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) +rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice) --------------------- rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) @@ -423,7 +431,7 @@ rnSpliceExpr splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) -- See Note [Delaying modFinalizers in untyped splices]. ; return ( HsPar noExt $ HsSpliceE noExt - . HsSpliced (ThModFinalizers mod_finalizers) + . HsSpliced noExt (ThModFinalizers mod_finalizers) . HsSplicedExpr <$> lexpr3 , fvs) @@ -537,7 +545,7 @@ rnSpliceType splice -- checkNoErrs: see Note [Renamer errors] -- See Note [Delaying modFinalizers in untyped splices]. ; return ( HsParTy noExt $ HsSpliceTy noExt - . HsSpliced (ThModFinalizers mod_finalizers) + . HsSpliced noExt (ThModFinalizers mod_finalizers) . HsSplicedTy <$> hs_ty3 , fvs @@ -602,9 +610,9 @@ rnSplicePat splice runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices]. ; return ( Left $ ParPat noExt $ (SplicePat noExt) - . HsSpliced (ThModFinalizers mod_finalizers) - . HsSplicedPat <$> - pat + . HsSpliced noExt (ThModFinalizers mod_finalizers) + . HsSplicedPat <$> + pat , emptyFVs ) } -- Wrap the result of the quasi-quoter in parens so that we don't @@ -687,6 +695,7 @@ spliceCtxt splice HsTypedSplice {} -> text "typed splice:" HsQuasiQuote {} -> text "quasi-quotation:" HsSpliced {} -> text "spliced expression:" + XSplice {} -> text "spliced expression:" -- | The splice data to be logged data SpliceInfo diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 3eeabad1d6..0aada39bd4 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1128,7 +1128,7 @@ collectAnonWildCards lty = go lty `mappend` go ty HsQualTy { hst_ctxt = L _ ctxt , hst_body = ty } -> gos ctxt `mappend` go ty - HsSpliceTy _ (HsSpliced _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty HsSpliceTy{} -> mempty HsTyLit{} -> mempty HsTyVar{} -> mempty @@ -1353,25 +1353,24 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1) - [a11,a12])) _ _ _)) +mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1) + [a11,a12])))) op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsCmdArrForm op2 f (Just fix2) [a1, a2]) + return (HsCmdArrForm x op2 f (Just fix2) [a1, a2]) | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsCmdArrForm op1 f (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) - placeHolderType placeHolderType [])]) + return (HsCmdArrForm noExt op1 f (Just fix1) + [a11, L loc (HsCmdTop [] (L loc new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2]) + = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2]) -------------------------------------- diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 96750f7260..318e4c683b 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -121,11 +121,13 @@ tcCmdTop :: CmdEnv -> CmdType -> TcM (LHsCmdTop GhcTcId) -tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) +tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) = setSrcSpan loc $ do { cmd' <- tcCmd env cmd cmd_ty ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } + ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } +tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop" + ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) -- The main recursive function @@ -135,35 +137,35 @@ tcCmd env (L loc cmd) res_ty ; return (L loc cmd') } tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId) -tc_cmd env (HsCmdPar cmd) res_ty +tc_cmd env (HsCmdPar x cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar cmd') } + ; return (HsCmdPar x cmd') } -tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty +tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan body_loc $ tc_cmd env body res_ty - ; return (HsCmdLet (L l binds') (L body_loc body')) } + ; return (HsCmdLet x (L l binds') (L body_loc body')) } -tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) +tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do (scrut', scrut_ty) <- tcInferRho scrut matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) - return (HsCmdCase scrut' matches') + return (HsCmdCase x scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' ; tcCmd env body (stk, res_ty') } -tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' +tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf Nothing pred' b1' b2') + ; return (HsCmdIf x Nothing pred' b1' b2') } -tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if +tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if = do { pred_ty <- newOpenFlexiTyVarTy -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not @@ -179,7 +181,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf (Just fun') pred' b1' b2') + ; return (HsCmdIf x (Just fun') pred' b1' b2') } ------------------------------------------- @@ -198,7 +200,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- -- (plus -<< requires ArrowApply) -tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) +tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; let fun_ty = mkCmdArrTy env arg_ty res_ty @@ -206,7 +208,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } + ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } where -- Before type-checking f, use the environment of the enclosing -- proc for the (-<) case. @@ -225,12 +227,12 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) -- ----------------------------- -- D;G |-a cmd exp : stk --> res -tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdApp fun' arg') } + ; return (HsCmdApp x fun' arg') } ------------------------------------------- -- Lambda @@ -240,9 +242,9 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) -- D;G |-a (\x.cmd) : (t,stk) --> res tc_cmd env - (HsCmdLam (MG { mg_alts = L l [L mtch_loc + (HsCmdLam x (MG { mg_alts = L l [L mtch_loc (match@(Match { m_pats = pats, m_grhss = grhss }))], - mg_origin = origin })) + mg_origin = origin })) (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match) $ do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk @@ -255,8 +257,9 @@ tc_cmd env ; let match' = L mtch_loc (Match { m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) arg_tys = map hsLPatType pats' - cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys - , mg_res_ty = res_ty, mg_origin = origin }) + cmd' = HsCmdLam x (MG { mg_alts = L l [match'] + , mg_arg_tys = arg_tys + , mg_res_ty = res_ty, mg_origin = origin }) ; return (mkHsCmdWrap (mkWpCastN co) cmd') } where n_pats = length pats @@ -277,10 +280,10 @@ tc_cmd env ------------------------------------------- -- Do notation -tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) +tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) } + ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } ----------------------------------------------------------------- @@ -297,7 +300,7 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) -- ---------------------------------------------- -- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' @@ -305,7 +308,7 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcPolyExpr expr e_ty - ; return (HsCmdArrForm expr' f fixity cmd_args') } + ; return (HsCmdArrForm x expr' f fixity cmd_args') } where tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) @@ -317,6 +320,8 @@ tc_cmd env cmd@(HsCmdArrForm 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" + ----------------------------------------------------------------- -- Base case for illegal commands -- This is where expressions that aren't commands get rejected diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index dc1f192154..878d050f82 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1041,7 +1041,7 @@ tcExpr (PArrSeq {}) _ -- Here we get rid of it and add the finalizers to the global environment. -- -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tcExpr (HsSpliceE _ (HsSpliced mod_finalizers (HsSplicedExpr expr))) +tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) res_ty = do addModFinalizersWithLclEnv mod_finalizers tcExpr expr res_ty @@ -1408,8 +1408,9 @@ tcTupArgs args tys = ASSERT( equalLength args tys ) mapM go (args `zip` tys) where go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) - go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (L l (Present expr')) } + 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" --------------------------- -- See TcType.SyntaxOpType also for commentary diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 89dcb66e27..14b19efa26 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -701,10 +701,11 @@ zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } where - zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e - ; return (L l (Present e')) } + zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e + ; return (L l (Present x e')) } zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t ; return (L l (Missing t')) } + zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg" zonkExpr env (ExplicitSum args alt arity expr) = do new_args <- mapM (zonkTcTypeToType env) args @@ -873,60 +874,60 @@ zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd -zonkCmd env (HsCmdWrap w cmd) +zonkCmd env (HsCmdWrap x w cmd) = do { (env1, w') <- zonkCoFn env w ; cmd' <- zonkCmd env1 cmd - ; return (HsCmdWrap w' cmd') } -zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) + ; return (HsCmdWrap x w' cmd') } +zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 new_ty <- zonkTcTypeToType env ty - return (HsCmdArrApp new_e1 new_e2 new_ty ho rl) + return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) -zonkCmd env (HsCmdArrForm op f fixity args) +zonkCmd env (HsCmdArrForm x op f fixity args) = do new_op <- zonkLExpr env op new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm new_op f fixity new_args) + return (HsCmdArrForm x new_op f fixity new_args) -zonkCmd env (HsCmdApp c e) +zonkCmd env (HsCmdApp x c e) = do new_c <- zonkLCmd env c new_e <- zonkLExpr env e - return (HsCmdApp new_c new_e) + return (HsCmdApp x new_c new_e) -zonkCmd env (HsCmdLam matches) +zonkCmd env (HsCmdLam x matches) = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam new_matches) + return (HsCmdLam x new_matches) -zonkCmd env (HsCmdPar c) +zonkCmd env (HsCmdPar x c) = do new_c <- zonkLCmd env c - return (HsCmdPar new_c) + return (HsCmdPar x new_c) -zonkCmd env (HsCmdCase expr ms) +zonkCmd env (HsCmdCase x expr ms) = do new_expr <- zonkLExpr env expr new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase new_expr new_ms) + return (HsCmdCase x new_expr new_ms) -zonkCmd env (HsCmdIf eCond ePred cThen cElse) +zonkCmd env (HsCmdIf x eCond ePred cThen cElse) = do { (env1, new_eCond) <- zonkWit env eCond ; new_ePred <- zonkLExpr env1 ePred ; new_cThen <- zonkLCmd env1 cThen ; new_cElse <- zonkLCmd env1 cElse - ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } + ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w -zonkCmd env (HsCmdLet (L l binds) cmd) +zonkCmd env (HsCmdLet x (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet (L l new_binds) new_cmd) + return (HsCmdLet x (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo (L l stmts) ty) +zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToType env ty - return (HsCmdDo (L l new_stmts) new_ty) - + return (HsCmdDo new_ty (L l new_stmts)) +zonkCmd _ (XCmd{}) = panic "zonkCmd" @@ -934,7 +935,7 @@ zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc) -zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) +zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) = do new_cmd <- zonkLCmd env cmd new_stack_tys <- zonkTcTypeToType env stack_tys new_ty <- zonkTcTypeToType env ty @@ -945,7 +946,8 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) -- but indeed it should always be lifted due to the typing -- rules for arrows - return (HsCmdTop new_cmd new_stack_tys new_ty new_ids) + return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) +zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top" ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) @@ -1022,15 +1024,18 @@ zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op ; new_bind_ty <- zonkTcTypeToType env1 bind_ty ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs - ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] + ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs + , b <- bs] env2 = extendIdZonkEnvRec env1 new_binders ; new_mzip <- zonkExpr env2 mzip_op ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) } where - zonk_branch env1 (ParStmtBlock stmts bndrs return_op) + zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts ; (env3, new_return) <- zonkSyntaxExpr env2 return_op - ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) } + ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) + new_return) } + zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt" 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 diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 6da48b53af..056e13485c 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -555,7 +555,7 @@ tc_infer_hs_type mode (HsKindSig _ ty sig) -- splices or not. -- -- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ (HsSplicedTy ty))) +tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) = tc_infer_hs_type mode ty tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty @@ -617,7 +617,7 @@ tc_hs_type _ ty@(HsRecTy {}) _ -- while capturing the local environment. -- -- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy _ (HsSpliced mod_finalizers (HsSplicedTy ty))) +tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) exp_kind = do addModFinalizersWithLclEnv mod_finalizers tc_hs_type mode ty exp_kind @@ -1906,8 +1906,7 @@ tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) = tcHsTyVarName new_tv Nothing tv tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; tcHsTyVarName new_tv (Just kind) tv_nm } - - tc_hs_tv (XTyVarBndr{}) = panic "tc_hs_tv" +tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr" newWildTyVar :: Name -> TcM TcTyVar -- ^ New unification variable for a wildcard diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index bb3a0880f0..2375abf2b1 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -468,13 +468,14 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside loop [] = do { thing <- thing_inside elt_ty ; return ([], thing) } -- matching in the branches - loop (ParStmtBlock stmts names _ : pairs) + loop (ParStmtBlock x stmts names _ : pairs) = do { (stmts', (ids, pairs', thing)) <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> do { ids <- tcLookupLocalIds names ; (pairs', thing) <- loop pairs ; return (ids, pairs', thing) } - ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) } + ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } + loop (XParStmtBlock{}:_) = panic "tcLcStmt" tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap @@ -761,7 +762,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside -- type dummies since we don't know all binder types yet ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) - [ names | ParStmtBlock _ names _ <- bndr_stmts_s ] + [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] -- Typecheck bind: ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] @@ -791,7 +792,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside -- matching in the branches loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) - (ParStmtBlock stmts names return_op : pairs) + (ParStmtBlock x stmts names return_op : pairs) = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in ; (stmts', (ids, return_op', pairs', thing)) <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ @@ -804,7 +805,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside \ _ -> return () ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs ; return (ids, return_op', pairs', thing) } - ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) } + ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } loop _ _ _ _ = panic "tcMcStmt.loop" tcMcStmt _ stmt _ _ diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 593c349f2e..4a825c29c1 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -613,7 +613,7 @@ tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty -- Here we get rid of it and add the finalizers to the global environment. -- -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tc_pat penv (SplicePat _ (HsSpliced mod_finalizers (HsSplicedPat pat))) +tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat))) pat_ty thing_inside = do addModFinalizersWithLclEnv mod_finalizers tc_pat penv pat pat_ty thing_inside diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index a14c52f98b..a4d796692f 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -901,7 +901,8 @@ tcPatToExpr name args pat = go pat | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExt - (map (noLoc . Present) exprs) box } + (map (noLoc . (Present noExt)) exprs) + box } go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) ; return $ ExplicitSum noExt alt arity (noLoc expr) @@ -913,7 +914,7 @@ tcPatToExpr name args pat = go pat | otherwise = return $ HsOverLit noExt n go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" - go1 (SplicePat _ (HsSpliced _ (HsSplicedPat pat))) + go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go1 pat go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" @@ -928,6 +929,7 @@ tcPatToExpr name args pat = go pat go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p + go1 p@(SplicePat _ (XSplice {})) = notInvertible p notInvertible p = Left (not_invertible_msg p) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 482655bbfa..76827fed0b 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -2003,7 +2003,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr - PlaceHolder + placeHolder -- [; print it] print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 0fc9dc2eb4..81cc474d32 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -162,7 +162,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -- See Note [How brackets and nested splices are handled] -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTypedBracket rn_expr brack@(TExpBr expr) res_ty +tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty = addErrCtxt (quotationCtxtDoc brack) $ do { cur_stage <- getStage ; ps_ref <- newMutVar [] @@ -199,13 +199,15 @@ tcUntypedBracket rn_expr brack ps res_ty --------------- tcBrackTy :: HsBracket GhcRn -> TcM TcType -tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) -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 (VarBr {}) = tcMetaTy nameTyConName + -- Result type is Var (not Q-monadic) +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" --------------- tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice @@ -433,7 +435,7 @@ When a variable is used, we compare ************************************************************************ -} -tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty +tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty = addErrCtxt (spliceCtxtDoc splice) $ setSrcSpan (getLoc expr) $ do { stage <- getStage diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 82a0daf4c2..0435dda331 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1510,7 +1510,7 @@ kcFamTyPats tc_fam_tc tv_names arg_pats kind_checker = discardResult $ kcImplicitTKBndrs tv_names Nothing $ do { let loc = nameSrcSpan name - lhs_fun = L loc (HsTyVar NotPromoted (L loc name)) + lhs_fun = L loc (HsTyVar noExt NotPromoted (L loc name)) -- lhs_fun is for error messages only no_fun = pprPanic "kcFamTyPats" (ppr name) fun_kind = tyConKind tc_fam_tc diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 03a5c2165d..3a06af6b3a 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -899,7 +899,7 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat placeHolderType)] + [L loc (WildPat noExt)] (mkHsApp (L loc (HsVar noExt (L loc (getName rEC_SEL_ERROR_ID)))) (L loc (HsLit noExt msg_lit)))] diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs index 149658a231..b04be775c3 100644 --- a/testsuite/tests/ghc-api/annotations/parseTree.hs +++ b/testsuite/tests/ghc-api/annotations/parseTree.hs @@ -51,9 +51,9 @@ testOneFile libdir fileName = do gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)] - doLHsTupArg (L l arg@(Present _)) + doLHsTupArg (L l arg@(Present {})) = [(l,"p",ExplicitTuple noExt [L l arg] Boxed)] - doLHsTupArg (L l arg@(Missing _)) + doLHsTupArg (L l arg@(Missing {})) = [(l,"m",ExplicitTuple noExt [L l arg] Boxed)] diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 112890fa68..21d9e18245 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -151,7 +151,7 @@ test('haddock.compiler', ,stats_num_field('bytes allocated', [(platform('x86_64-unknown-mingw32'), 56775301896, 10), # 2017-12-24: 56775301896 (x64/Windows) - (wordsize(64), 51592019560, 10) + (wordsize(64), 91115212032, 10) # 2012-08-14: 26070600504 (amd64/Linux) # 2012-08-29: 26353100288 (amd64/Linux, new CG) # 2012-09-18: 26882813032 (amd64/Linux) @@ -173,8 +173,7 @@ test('haddock.compiler', # 2017-06-05: 65378619232 (amd64/Linux) Desugar modules compiled with -fno-code # 2017-06-06: 55990521024 (amd64/Linux) Don't pass on -dcore-lint in Haddock.mk # 2017-07-12: 51592019560 (amd64/Linux) Use getNameToInstancesIndex - # 2017-11-07: 65807004616 (amd64/Linux) Trees that grow - # 2017-11-12: 89414230688 (amd64/Linux) Trees that grow HsExpr + # 2018-04-08: 91115212032 (amd64/Linux) Trees that grow ,(platform('i386-unknown-mingw32'), 367546388, 10) # 2012-10-30: 13773051312 (x86/Windows) diff --git a/utils/haddock b/utils/haddock -Subproject 73fa32d2a0f9867fc6aa85f9995b02607507578 +Subproject bb764039b8c866af6f3cf830a25a08cdf052697 |