diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-18 23:55:14 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2018-04-27 15:38:46 +0200 |
| commit | c3823cba2147c74b2c727b5458b9e95350496988 (patch) | |
| tree | e9afa7f5fd6b1a3f2f1a2ee87d659342803e6a2d /compiler | |
| parent | 313720a453889ddd05da02f4f2c31eb3bc3734d2 (diff) | |
| download | haskell-c3823cba2147c74b2c727b5458b9e95350496988.tar.gz | |
TTG : complete for balance of hsSyn AST
Summary:
- remove PostRn/PostTc fields
- remove the HsVect In/Out distinction for Type, Class and Instance
- remove PlaceHolder in favour of NoExt
- Simplify OutputableX constraint
Updates haddock submodule
Test Plan: ./validate
Reviewers: goldfire, bgamari
Subscribers: goldfire, thomie, mpickering, carter
Differential Revision: https://phabricator.haskell.org/D4625
Diffstat (limited to 'compiler')
58 files changed, 2863 insertions, 1739 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 6372967cc0..545aacef51 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -347,15 +347,17 @@ checkSingle' locn var p = do checkGuardMatches :: HsMatchContext Name -- Match context -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs -> DsM () -checkGuardMatches hs_ctx guards@(GRHSs grhss _) = do +checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do dflags <- getDynFlags let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc match = L combinedLoc $ - Match { m_ctxt = hs_ctx + Match { m_ext = noExt + , m_ctxt = hs_ctx , m_pats = [] , m_grhss = guards } checkMatches dflags dsMatchContext [] [match] +checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches" -- | Check a matchgroup (case, functions, etc.) checkMatches :: DynFlags -> DsMatchContext @@ -416,6 +418,7 @@ checkMatches' vars matches hsLMatchToLPats :: LMatch id body -> Located [LPat id] hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats + hsLMatchToLPats (L _ (XMatch _)) = panic "checMatches'" -- | Check an empty case expression. Since there are no clauses to process, we -- only compute the uncovered set. See Note [Checking EmptyCase Expressions] @@ -780,12 +783,12 @@ translatePat fam_insts pat = case pat of False -> mkCanFailPmPat arg_ty -- list - ListPat _ ps ty Nothing -> do + ListPat (ListPatTc ty Nothing) ps -> do foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec fam_insts (map unLoc ps) -- overloaded list - ListPat x lpats elem_ty (Just (pat_ty, _to_list)) + ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats | Just e_ty <- splitListTyConApp_maybe pat_ty , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty -- elem_ty is frequently something like @@ -794,7 +797,7 @@ translatePat fam_insts pat = case pat of -- We have to ensure that the element types are exactly the same. -- Otherwise, one may give an instance IsList [Int] (more specific than -- the default IsList [a]) with a different implementation for `toList' - translatePat fam_insts (ListPat x lpats e_ty Nothing) + translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats) -- See Note [Guards and Approximation] | otherwise -> mkCanFailPmPat pat_ty @@ -939,10 +942,12 @@ translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do return (pats', guards') where extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] - extractGuards (L _ (GRHS gs _)) = map unLoc gs + extractGuards (L _ (GRHS _ gs _)) = map unLoc gs + extractGuards (L _ (XGRHS _)) = panic "translateMatch" pats = map unLoc lpats guards = map extractGuards (grhssGRHSs grhss) +translateMatch _ (L _ (XMatch _)) = panic "translateMatch" -- ----------------------------------------------------------------------- -- * Transform source guards (GuardStmt Id) to PmPats (Pattern) @@ -990,14 +995,15 @@ cantFailPattern _ = False -- | Translate a guard statement to Pattern translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec translateGuard fam_insts guard = case guard of - BodyStmt e _ _ _ -> translateBoolGuard e - LetStmt binds -> translateLet (unLoc binds) - BindStmt p e _ _ _ -> translateBind fam_insts p e + BodyStmt _ e _ _ -> translateBoolGuard e + LetStmt _ binds -> translateLet (unLoc binds) + BindStmt _ p e _ _ -> translateBind fam_insts p e LastStmt {} -> panic "translateGuard LastStmt" ParStmt {} -> panic "translateGuard ParStmt" TransStmt {} -> panic "translateGuard TransStmt" RecStmt {} -> panic "translateGuard RecStmt" ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt" + XStmtLR {} -> panic "translateGuard RecStmt" -- | Translate let-bindings translateLet :: HsLocalBinds GhcTc -> DsM PatVec diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index ab04ee472f..25b77f2cfe 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -644,6 +644,7 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches return $ mg { mg_alts = L l matches' } +addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup" addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) @@ -651,23 +652,26 @@ addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs return $ match { m_grhss = gRHSs' } +addTickMatch _ _ (XMatch _) = panic "addTickMatch" addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs guarded' (L l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds +addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs" addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) -addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do +addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickGRHSBody isOneOfMany isLambda expr) - return $ GRHS stmts' expr' + return $ GRHS x stmts' expr' +addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS" addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do @@ -697,36 +701,33 @@ addTickLStmts' isGuard lstmts res addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) -> TM (Stmt GhcTc (LHsExpr GhcTc)) -addTickStmt _isGuard (LastStmt e noret ret) = do - liftM3 LastStmt +addTickStmt _isGuard (LastStmt x e noret ret) = do + liftM3 (LastStmt x) (addTickLHsExpr e) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt pat e bind fail ty) = do - liftM5 BindStmt +addTickStmt _isGuard (BindStmt x pat e bind fail) = do + liftM4 (BindStmt x) (addTickLPat pat) (addTickLHsExprRHS e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) - (return ty) -addTickStmt isGuard (BodyStmt e bind' guard' ty) = do - liftM4 BodyStmt +addTickStmt isGuard (BodyStmt x e bind' guard') = do + liftM3 (BodyStmt x) (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) -addTickStmt _isGuard (LetStmt (L l binds)) = do - liftM (LetStmt . L l) +addTickStmt _isGuard (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do - liftM4 ParStmt +addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do + liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) - (return ty) -addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do +addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do args' <- mapM (addTickApplicativeArg isGuard) args - return (ApplicativeStmt args' mb_join body_ty) + return (ApplicativeStmt body_ty args' mb_join) addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts , trS_by = by, trS_using = using @@ -749,6 +750,8 @@ addTickStmt isGuard stmt@(RecStmt {}) ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } +addTickStmt _ (XStmtLR _) = panic "addTickStmt" + addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e @@ -759,16 +762,17 @@ addTickApplicativeArg addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where - addTickArg (ApplicativeArgOne pat expr isBody) = - ApplicativeArgOne + addTickArg (ApplicativeArgOne x pat expr isBody) = + (ApplicativeArgOne x) <$> addTickLPat pat <*> addTickLHsExpr expr <*> pure isBody - addTickArg (ApplicativeArgMany stmts ret pat) = - ApplicativeArgMany + addTickArg (ApplicativeArgMany x stmts ret pat) = + (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat + addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg" addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) @@ -896,29 +900,33 @@ addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do matches' <- mapM (liftL addTickCmdMatch) matches return $ mg { mg_alts = L l matches' } +addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup" addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = bindLocals (collectPatsBinders pats) $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } +addTickCmdMatch (XMatch _) = panic "addTickCmdMatch" addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do +addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs guarded' (L l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds +addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs" addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is -- C.f. addTickGRHS for the BinBox stuff -addTickCmdGRHS (GRHS stmts cmd) +addTickCmdGRHS (GRHS x stmts cmd) = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (addTickLHsCmd cmd) - ; return $ GRHS stmts' expr' } + ; return $ GRHS x stmts' expr' } +addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS" addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM [LStmt GhcTc (LHsCmd GhcTc)] @@ -937,26 +945,24 @@ addTickLCmdStmts' lstmts res binders = collectLStmtsBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) -addTickCmdStmt (BindStmt pat c bind fail ty) = do - liftM5 BindStmt +addTickCmdStmt (BindStmt x pat c bind fail) = do + liftM4 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c) (return bind) (return fail) - (return ty) -addTickCmdStmt (LastStmt c noret ret) = do - liftM3 LastStmt +addTickCmdStmt (LastStmt x c noret ret) = do + liftM3 (LastStmt x) (addTickLHsCmd c) (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (BodyStmt c bind' guard' ty) = do - liftM4 BodyStmt +addTickCmdStmt (BodyStmt x c bind' guard') = do + liftM3 (BodyStmt x) (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') - (return ty) -addTickCmdStmt (LetStmt (L l binds)) = do - liftM (LetStmt . L l) +addTickCmdStmt (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) @@ -967,6 +973,8 @@ addTickCmdStmt stmt@(RecStmt {}) , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTickCmdStmt ApplicativeStmt{} = panic "ToDo: addTickCmdStmt ApplicativeLastStmt" +addTickCmdStmt XStmtLR{} = + panic "addTickCmdStmt XStmtLR" -- Others should never happen in a command context. addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) @@ -1282,7 +1290,10 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (L _ (Match { m_grhss = GRHSs grhss _binds })) = length grhss + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss + matchCount (L _ (Match { m_grhss = XGRHSs _ })) + = panic "matchesOneOfMany" + matchCount (L _ (XMatch _)) = panic "matchesOneOfMany" type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 05d322680c..e8ce029b04 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -374,9 +374,9 @@ Reason -} dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) -dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) +dsRule (L loc (HsRule _ name rule_act vars lhs rhs)) = putSrcSpanDs loc $ - do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars] + do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $ @@ -413,6 +413,7 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs)) ; return (Just rule) } } } +dsRule (L _ (XRuleDecl _)) = panic "dsRule" warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () @@ -553,26 +554,22 @@ subsequent transformations could fire. -} dsVect :: LVectDecl GhcTc -> DsM CoreVect -dsVect (L loc (HsVect _ (L _ v) rhs)) +dsVect (L loc (HsVect _ _ (L _ v) rhs)) = putSrcSpanDs loc $ do { rhs' <- dsLExpr rhs ; return $ Vect v rhs' } -dsVect (L _loc (HsNoVect _ (L _ v))) +dsVect (L _loc (HsNoVect _ _ (L _ v))) = return $ NoVect v -dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) +dsVect (L _loc (HsVectType (VectTypeTc tycon rhs_tycon) isScalar)) = return $ VectType isScalar tycon' rhs_tycon where tycon' | Just ty <- coreView $ mkTyConTy tycon , (tycon', []) <- splitTyConApp ty = tycon' | otherwise = tycon -dsVect vd@(L _ (HsVectTypeIn _ _ _ _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd) -dsVect (L _loc (HsVectClassOut cls)) +dsVect (L _loc (HsVectClass cls)) = return $ VectClass (classTyCon cls) -dsVect vc@(L _ (HsVectClassIn _ _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc) -dsVect (L _loc (HsVectInstOut inst)) +dsVect (L _loc (HsVectInst inst)) = return $ VectInst (instanceDFunId inst) -dsVect vi@(L _ (HsVectInstIn _)) - = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi) +dsVect vd@(L _ (XVectDecl {})) + = pprPanic "Desugar.dsVect: unexpected 'XVectDecl'" (ppr vd) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 61dc7c5b5b..5e355f03f9 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -450,8 +450,9 @@ 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 - , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] })) + (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) let @@ -554,7 +555,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 + (HsCmdCase _ exp (MG { mg_alts = L l matches + , mg_ext = MatchGroupTc arg_tys _ , mg_origin = origin })) env_ids = do stack_id <- newSysLocalDs stack_ty @@ -602,8 +604,8 @@ dsCmd ids local_vars stack_ty res_ty core_body <- dsExpr (HsCase noExt exp (MG { mg_alts = L l matches' - , mg_arg_tys = arg_tys - , mg_res_ty = sum_ty, mg_origin = origin })) + , mg_ext = MatchGroupTc arg_tys sum_ty + , mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' @@ -758,7 +760,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do +dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do putSrcSpanDs loc $ dsNoLevPoly res_ty (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids @@ -816,7 +818,7 @@ dsCmdStmt -- ---> premap (\ ((xs)) -> (((xs1),()),(xs'))) -- (first c >>> arr snd) >>> ss -dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do +dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd core_mux <- matchEnv env_ids (mkCorePairExpr @@ -847,7 +849,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. -dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do +dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do let pat_ty = hsLPatType pat (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd let pat_vars = mkVarSet (collectPatBinders pat) @@ -898,7 +900,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do +dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input @@ -926,7 +928,8 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do dsCmdStmt ids local_vars out_ids (RecStmt { recS_stmts = stmts , recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_later_rets = later_rets, recS_rec_rets = rec_rets }) + , recS_ext = RecStmtTc { recS_later_rets = later_rets + , recS_rec_rets = rec_rets } }) env_ids = do let later_ids_set = mkVarSet later_ids @@ -1116,7 +1119,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" leavesMatch :: LMatch GhcTc (Located (body GhcTc)) -> [(Located (body GhcTc), IdSet)] -leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) })) +leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) })) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1125,7 +1128,9 @@ leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) })) [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) - | L _ (GRHS stmts body) <- grhss] + | L _ (GRHS _ stmts body) <- grhss] +leavesMatch (L _ (Match _ _ _ (XGRHSs _))) = panic "leavesMatch" +leavesMatch (L _ (XMatch _)) = panic "leavesMatch" -- Replace the leaf commands in a match @@ -1135,19 +1140,24 @@ replaceLeavesMatch -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command -> ([Located (body' GhcTc)], -- remaining leaf expressions LMatch GhcTc (Located (body' GhcTc))) -- updated match -replaceLeavesMatch _res_ty leaves (L loc match@(Match { m_grhss = GRHSs grhss binds })) +replaceLeavesMatch _res_ty leaves + (L loc match@(Match { m_grhss = GRHSs x grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', L loc (match { m_grhss = GRHSs grhss' binds })) + (leaves', L loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds })) +replaceLeavesMatch _ _ (L _ (Match _ _ _ (XGRHSs _))) + = panic "replaceLeavesMatch" +replaceLeavesMatch _ _ (L _ (XMatch _)) = panic "replaceLeavesMatch" replaceLeavesGRHS :: [Located (body' GhcTc)] -- replacement leaf expressions of that type -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command -> ([Located (body' GhcTc)], -- remaining leaf expressions LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) - = (leaves, L loc (GRHS stmts leaf)) +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) + = (leaves, L loc (GRHS x stmts leaf)) +replaceLeavesGRHS _ (L _ (XGRHS _)) = panic "replaceLeavesGRHS" replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" -- Balanced fold of a non-empty list. @@ -1202,7 +1212,7 @@ collectl (L _ pat) bndrs go (AsPat _ (L _ a) pat) = a : collectl pat bndrs go (ParPat _ pat) = collectl pat bndrs - go (ListPat _ pats _ _) = foldr collectl bndrs pats + go (ListPat _ pats) = foldr collectl bndrs pats go (PArrPat _ pats) = foldr collectl bndrs pats go (TuplePat _ pats _) = foldr collectl bndrs pats go (SumPat _ pat _ _) = collectl pat bndrs diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 6f7f66e6a4..7ee1857dfe 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -444,7 +444,7 @@ ds_expr _ (HsMultiIf res_ty alts) | otherwise = do { match_result <- liftM (foldr1 combineMatchResults) (mapM (dsGRHS IfAlt res_ty) alts) - ; checkGuardMatches IfAlt (GRHSs alts (noLoc emptyLocalBinds)) + ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds)) ; error_expr <- mkErrorExpr ; extractMatchResult match_result error_expr } where @@ -627,11 +627,12 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- constructor arguments. ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; ([discrim_var], matching_code) - <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts - , mg_arg_tys = [in_ty] - , mg_res_ty = out_ty, mg_origin = FromSource }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings + <- matchWrapper RecUpd Nothing + (MG { mg_alts = noLoc alts + , mg_ext = MatchGroupTc [in_ty] out_ty + , mg_origin = FromSource }) + -- FromSource is not strictly right, but we + -- want incomplete pattern-match warnings ; return (add_field_binds field_binds' $ bindNonRec discrim_var record_expr' matching_code) } @@ -909,21 +910,21 @@ dsDo stmts goL [] = panic "dsDo" goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (LastStmt body _ _) stmts + go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body -- The 'return' op isn't used for 'do' expressions - go _ (BodyStmt rhs then_expr _ _) stmts + go _ (BodyStmt _ rhs then_expr _) stmts = do { rhs2 <- dsLExpr rhs ; warnDiscardedDoBindings rhs (exprType rhs2) ; rest <- goL stmts ; dsSyntaxExpr then_expr [rhs2, rest] } - go _ (LetStmt binds) stmts + go _ (LetStmt _ binds) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } - go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts + go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts = do { body <- goL stmts ; rhs' <- dsLExpr rhs ; var <- selectSimpleMatchVarL pat @@ -932,15 +933,16 @@ dsDo stmts ; match_code <- handle_failure pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } - go _ (ApplicativeStmt args mb_join body_ty) stmts + go _ (ApplicativeStmt body_ty args mb_join) stmts = do { let (pats, rhss) = unzip (map (do_arg . snd) args) - do_arg (ApplicativeArgOne pat expr _) = + do_arg (ApplicativeArgOne _ pat expr _) = (pat, dsLExpr expr) - do_arg (ApplicativeArgMany stmts ret pat) = + do_arg (ApplicativeArgMany _ stmts ret pat) = (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + do_arg (XApplicativeArg _) = panic "dsDo" arg_tys = map hsLPatType pats @@ -951,8 +953,7 @@ dsDo stmts ; let fun = L noSrcSpan $ HsLam noExt $ MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats body'] - , mg_arg_tys = arg_tys - , mg_res_ty = body_ty + , mg_ext = MatchGroupTc arg_tys body_ty , mg_origin = Generated } ; fun' <- dsLExpr fun @@ -965,14 +966,15 @@ dsDo stmts go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_bind_ty = bind_ty - , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts + , recS_ext = RecStmtTc + { recS_bind_ty = bind_ty + , recS_rec_rets = rec_rets + , recS_ret_ty = body_ty} }) stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where - new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats) + new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail - bind_ty tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case @@ -984,7 +986,7 @@ dsDo stmts (MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr [mfix_pat] body] - , mg_arg_tys = [tup_ty], mg_res_ty = body_ty + , mg_ext = MatchGroupTc [tup_ty] body_ty , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats body = noLoc $ HsDo body_ty @@ -997,6 +999,7 @@ dsDo stmts go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt" + go _ (XStmtLR {}) _ = panic "dsDo XStmtLR" handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr -- In a do expression, pattern-match failure just calls diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index a23c51b943..401ed876cc 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -99,17 +99,18 @@ dsForeigns' fos = do where do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) - do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do + do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) let id' = unLoc id (bs, h, c) <- dsFImport id' co spec traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport { fd_name = L _ id, fd_co = co + do_decl (ForeignExport { fd_name = L _ id, fd_e_ext = co , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) + do_decl (XForeignDecl _) = panic "dsForeigns'" {- ************************************************************************ diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index b0470ef487..0fe4828dc3 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -57,18 +57,20 @@ dsGRHSs :: HsMatchContext Name -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty +dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty = ASSERT( notNull grhss ) do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 -- NB: nested dsLet inside matchResult ; return match_result2 } +dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs" dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) +dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty +dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS" {- ************************************************************************ @@ -98,16 +100,16 @@ matchGuards [] _ rhs _ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings -matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty +matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result) -matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do +matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result @@ -115,7 +117,7 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result @@ -126,6 +128,8 @@ matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt" matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt" matchGuards (ApplicativeStmt {} : _) _ _ _ = panic "matchGuards ApplicativeLastStmt" +matchGuards (XStmtLR {} : _) _ _ _ = + panic "matchGuards XStmtLR" isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 36c2730aff..8c9fa72e03 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -220,20 +220,20 @@ deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr deListComp [] _ = panic "deListComp" -deListComp (LastStmt body _ _ : quals) list +deListComp (LastStmt _ body _ _ : quals) list = -- Figure 7.4, SLPJ, p 135, rule C above ASSERT( null quals ) do { core_body <- dsLExpr body ; return (mkConsExpr (exprType core_body) core_body list) } -- Non-last: must be a guard -deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above +deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above core_guard <- dsLExpr guard core_rest <- deListComp quals list return (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt binds : quals) list = do +deListComp (LetStmt _ binds : quals) list = do core_rest <- deListComp quals list dsLocalBinds binds core_rest @@ -241,11 +241,11 @@ deListComp (stmt@(TransStmt {}) : quals) list = do (inner_list_expr, pat) <- dsTransStmt stmt deBindComp pat inner_list_expr quals list -deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above +deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above core_list1 <- dsLExprNoLP list1 deBindComp pat core_list1 quals core_list2 -deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list +deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs ; let (exps, qual_tys) = unzip exps_and_qual_tys @@ -266,6 +266,9 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" deListComp (ApplicativeStmt {} : _) _ = panic "deListComp ApplicativeStmt" +deListComp (XStmtLR {} : _) _ = + panic "deListComp XStmtLR" + deBindComp :: OutPat GhcTc -> CoreExpr -> [ExprStmt GhcTc] @@ -328,18 +331,18 @@ dfListComp :: Id -> Id -- 'c' and 'n' dfListComp _ _ [] = panic "dfListComp" -dfListComp c_id n_id (LastStmt body _ _ : quals) +dfListComp c_id n_id (LastStmt _ body _ _ : quals) = ASSERT( null quals ) do { core_body <- dsLExprNoLP body ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard -dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do +dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do core_guard <- dsLExpr guard core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) -dfListComp c_id n_id (LetStmt binds : quals) = do +dfListComp c_id n_id (LetStmt _ binds : quals) = do -- new in 1.3, local bindings core_rest <- dfListComp c_id n_id quals dsLocalBinds binds core_rest @@ -349,7 +352,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do -- Anyway, we bind the newly grouped list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals -dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do +dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do -- evaluate the two lists core_list1 <- dsLExpr list1 @@ -360,6 +363,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt" dfListComp _ _ (ApplicativeStmt {} : _) = panic "dfListComp ApplicativeStmt" +dfListComp _ _ (XStmtLR {} : _) = + panic "dfListComp XStmtLR" dfBindComp :: Id -> Id -- 'c' and 'n' -> (LPat GhcTc, CoreExpr) @@ -487,7 +492,7 @@ dsPArrComp :: [ExprStmt GhcTc] -> DsM CoreExpr -- Special case for parallel comprehension -dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals +dsPArrComp (ParStmt _ qss _ _ : quals) = dePArrParComp qss quals -- Special case for simple generators: -- @@ -498,7 +503,7 @@ dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals -- <<[:e' | p <- e, qs:]>> = -- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) -- -dsPArrComp (BindStmt p e _ _ _ : qs) = do +dsPArrComp (BindStmt _ p e _ _ : qs) = do filterP <- dsDPHBuiltin filterPVar ce <- dsLExprNoLP e let ety'ce = parrElemType ce @@ -529,7 +534,7 @@ dePArrComp [] _ _ = panic "dePArrComp" -- -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea -- -dePArrComp (LastStmt e' _ _ : quals) pa cea +dePArrComp (LastStmt _ e' _ _ : quals) pa cea = ASSERT( null quals ) do { mapP <- dsDPHBuiltin mapPVar ; let ty = parrElemType cea @@ -538,7 +543,7 @@ dePArrComp (LastStmt e' _ _ : quals) pa cea -- -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- -dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do +dePArrComp (BodyStmt _ b _ _ : qs) pa cea = do filterP <- dsDPHBuiltin filterPVar let ty = parrElemType cea (clam,_) <- deLambda ty pa b @@ -557,7 +562,7 @@ dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do -- in -- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) -- -dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do +dePArrComp (BindStmt _ p e _ _ : qs) pa cea = do filterP <- dsDPHBuiltin filterPVar crossMapP <- dsDPHBuiltin crossMapPVar ce <- dsLExpr e @@ -582,7 +587,7 @@ dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- -dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do +dePArrComp (LetStmt _ lds@(L _ ds) : qs) pa cea = do mapP <- dsDPHBuiltin mapPVar let xs = collectLocalBinders ds ty'cea = parrElemType cea @@ -610,6 +615,8 @@ dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt" dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" dePArrComp (ApplicativeStmt {} : _) _ _ = panic "DsListComp.dePArrComp: ApplicativeStmt" +dePArrComp (XStmtLR {} : _) _ _ = + panic "DsListComp.dePArrComp: XStmtLR" -- <<[:e' | qs | qss:]>> pa ea = -- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) @@ -690,18 +697,18 @@ dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr -dsMcStmt (LastStmt body _ ret_op) stmts +dsMcStmt (LastStmt _ body _ ret_op) stmts = ASSERT( null stmts ) do { body' <- dsLExpr body ; dsSyntaxExpr ret_op [body'] } -- [ .. | let binds, stmts ] -dsMcStmt (LetStmt binds) stmts +dsMcStmt (LetStmt _ binds) stmts = do { rest <- dsMcStmts stmts ; dsLocalBinds binds rest } -- [ .. | a <- m, stmts ] -dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts +dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts = do { rhs' <- dsLExpr rhs ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts } @@ -709,7 +716,7 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts -- -- [ .. | exp, stmts ] -- -dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts +dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts = do { exp' <- dsLExpr exp ; rest <- dsMcStmts stmts ; guard_exp' <- dsSyntaxExpr guard_exp [exp'] @@ -732,7 +739,7 @@ dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs , trS_by = by, trS_using = using , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = n_tup_ty' -- n (a,b,c) + , trS_ext = n_tup_ty' -- n (a,b,c) , trS_fmap = fmap_op, trS_form = form }) stmts_rest = do { let (from_bndrs, to_bndrs) = unzip bndrs @@ -777,7 +784,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs -- mzip :: forall a b. m a -> m b -> m (a,b) -- NB: we need a polymorphic mzip because we call it several times -dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest +dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) ; mzip_op' <- dsExpr mzip_op @@ -854,7 +861,8 @@ dsInnerMonadComp :: [ExprLStmt GhcTc] -> SyntaxExpr GhcTc -- The monomorphic "return" operator -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op - = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) + = dsMcStmts (stmts ++ + [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)]) -- The `unzip` function for `GroupStmt` in a monad comprehensions diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 976f3c3d12..6bff89774d 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -174,13 +174,15 @@ repTopDs group@(HsGroup { hs_valds = valds = notHandledL loc "Splices within declaration brackets" empty no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl) - no_warn (L loc (Warning thing _)) + no_warn (L loc (Warning _ thing _)) = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing + no_warn (L _ (XWarnDecl _)) = panic "repTopDs" no_vect (L loc decl) = notHandledL loc "Vectorisation pragmas" (ppr decl) no_doc (L loc _) = notHandledL loc "Haddock documentation" empty +repTopDs (XHsGroup _) = panic "repTopDs" hsSigTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in bindings] @@ -206,10 +208,12 @@ get_scoped_tvs (L _ signature) -- Both implicit and explicit quantified variables -- We need the implicit ones for f :: forall (a::k). blah -- here 'k' scopes too - | HsIB { hsib_vars = implicit_vars + | HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_vars } , hsib_body = hs_ty } <- sig , (explicit_vars, _) <- splitLHsForAllTy hs_ty = implicit_vars ++ map hsLTyVarName explicit_vars + get_scoped_tvs_from_sig (XHsImplicitBndrs _) + = panic "get_scoped_tvs_from_sig" {- Notes @@ -334,14 +338,17 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ; return $ Just (loc, dec) } +repTyClD (L _ (XTyClDecl _)) = panic "repTyClD" + ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRoleD (L loc (RoleAnnotDecl tycon roles)) +repRoleD (L loc (RoleAnnotDecl _ tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles ; roles2 <- coreList roleTyConName roles1 ; dec <- repRoleAnnotD tycon1 roles2 ; return (loc, dec) } +repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD" ------------------------- repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ] @@ -367,6 +374,7 @@ repDataDefn tc bndrs opt_tys ; repData cxt1 tc bndrs opt_tys ksig' cons1 derivs1 } } +repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn" repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] -> LHsType GhcRn @@ -383,11 +391,13 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn - mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs - , hsq_dependent = emptyNameSet } + mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = [] + , hsq_dependent = emptyNameSet } + , hsq_explicit = tvs } resTyVar = case resultSig of - TyVarSig bndr -> mkHsQTvs [bndr] - _ -> mkHsQTvs [] + TyVarSig _ bndr -> mkHsQTvs [bndr] + _ -> mkHsQTvs [] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> addTyClTyVarBinds resTyVar $ \_ -> case info of @@ -408,23 +418,25 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, ; repDataFamilyD tc1 bndrs kind } ; return (loc, dec) } +repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl" -- | Represent result signature of a type family repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ) -repFamilyResultSig NoSig = repNoSig -repFamilyResultSig (KindSig ki) = do { ki' <- repLTy ki - ; repKindSig ki' } -repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr - ; repTyVarSig bndr' } +repFamilyResultSig (NoSig _) = repNoSig +repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki + ; repKindSig ki' } +repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr + ; repTyVarSig bndr' } +repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig" -- | Represent result signature using a Maybe Kind. Used with data families, -- where the result signature can be either missing or a kind but never a named -- result variable. repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn -> DsM (Core (Maybe TH.KindQ)) -repFamilyResultSigToMaybeKind NoSig = +repFamilyResultSigToMaybeKind (NoSig _) = do { coreNothing kindQTyConName } -repFamilyResultSigToMaybeKind (KindSig ki) = +repFamilyResultSigToMaybeKind (KindSig _ ki) = do { ki' <- repLTy ki ; coreJust kindQTyConName ki' } repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" @@ -459,6 +471,7 @@ repAssocTyFamDefaults = mapM rep_deflt ; rhs1 <- repLTy rhs ; eqn1 <- repTySynEqn tys2 rhs1 ; repTySynInst tc1 eqn1 } + rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults" ------------------------- -- represent fundeps @@ -484,6 +497,7 @@ repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } +repInstD (L _ (XInstDecl _)) = panic "repInstD" repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds @@ -513,6 +527,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds ; wrapGenSyms ss decls2 } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty +repClsInstD (XClsInstDecl _) = panic "repClsInstD" repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat @@ -525,6 +540,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat ; return (loc, dec) } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) +repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD" repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) @@ -534,31 +550,39 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ; repTySynInst tc eqn1 } repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (HsIB { hsib_vars = var_names +repTyFamEqn (HsIB { hsib_ext = HsIBRn { hsib_vars = var_names } , hsib_body = FamEqn { feqn_pats = tys , feqn_rhs = rhs }}) - = do { let hs_tvs = HsQTvs { hsq_implicit = var_names - , hsq_explicit = [] - , hsq_dependent = emptyNameSet } -- Yuk + = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = var_names + , hsq_dependent = emptyNameSet } -- Yuk + , hsq_explicit = [] } ; addTyClTyVarBinds hs_tvs $ \ _ -> do { tys1 <- repLTys tys ; tys2 <- coreList typeQTyConName tys1 ; rhs1 <- repLTy rhs ; repTySynEqn tys2 rhs1 } } +repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn" +repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn" repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) repDataFamInstD (DataFamInstDecl { dfid_eqn = - (HsIB { hsib_vars = var_names + (HsIB { hsib_ext = HsIBRn { hsib_vars = var_names } , hsib_body = FamEqn { feqn_tycon = tc_name , feqn_pats = tys , feqn_rhs = defn }})}) = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_implicit = var_names - , hsq_explicit = [] - , hsq_dependent = emptyNameSet } -- Yuk + ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = var_names + , hsq_dependent = emptyNameSet } -- Yuk + , hsq_explicit = [] } ; addTyClTyVarBinds hs_tvs $ \ bndrs -> do { tys1 <- repList typeQTyConName repLTy tys ; repDataDefn tc bndrs (Just tys1) defn } } +repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _)) + = panic "repDataFamInstD" +repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _))) + = panic "repDataFamInstD" repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ @@ -616,7 +640,7 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) repFixD (L _ (XFixitySig _)) = panic "repFixD" repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) +repRuleD (L loc (HsRule _ n act bndrs lhs rhs)) = do { let bndr_names = concatMap ruleBndrNames bndrs ; ss <- mkGenSyms bndr_names ; rule1 <- addBinds ss $ @@ -628,28 +652,36 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ; repPragRule n' bndrs' lhs' rhs' act' } ; rule2 <- wrapGenSyms ss rule1 ; return (loc, rule2) } +repRuleD (L _ (XRuleDecl _)) = panic "repRuleD" ruleBndrNames :: LRuleBndr GhcRn -> [Name] -ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] -ruleBndrNames (L _ (RuleBndrSig n sig)) - | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig +ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig _ n sig)) + | HsWC { hswc_body = HsIB { hsib_ext = HsIBRn { hsib_vars = vars } }} <- sig = unLoc n : vars +ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) + = panic "ruleBndrNames" +ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) + = panic "ruleBndrNames" +ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames" repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) -repRuleBndr (L _ (RuleBndr n)) +repRuleBndr (L _ (RuleBndr _ n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } -repRuleBndr (L _ (RuleBndrSig n sig)) +repRuleBndr (L _ (RuleBndrSig _ n sig)) = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } +repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr" repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) +repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' ; return (loc, dec) } +repAnnD (L _ (XAnnDecl _)) = panic "repAnnD" repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) repAnnProv (ValueAnnProvenance (L _ n)) @@ -703,6 +735,9 @@ repC (L _ (ConDeclGADT { con_names = cons then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } +repC (L _ (XConDecl _)) = panic "repC" + + repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) repMbContext Nothing = repContext [] repMbContext (Just (L _ cxt)) = repContext cxt @@ -746,6 +781,7 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs where rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) rep_deriv_ty (L _ ty) = repTy ty +repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause" rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn -> DsM ([GenSymBind], [Core TH.DecQ]) @@ -812,6 +848,7 @@ rep_ty_sig mk_sig loc sig_ty nm else repTForall th_explicit_tvs th_ctxt th_ty ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } +rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig" rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) @@ -840,6 +877,7 @@ rep_patsyn_ty_sig loc sig_ty nm repTForall th_exis th_provs th_ty ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } +rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig" rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) @@ -946,11 +984,13 @@ addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) +addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs} + , hsq_explicit = exp_tvs }) thing_inside = addSimpleTyVarBinds imp_tvs $ addHsTyVarBinds exp_tvs $ thing_inside +addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds" addTyClTyVarBinds :: LHsQTyVars GhcRn -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) @@ -1008,7 +1048,7 @@ repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt repCtxt preds repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) -repHsSigType (HsIB { hsib_vars = implicit_tvs +repHsSigType (HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_tvs } , hsib_body = body }) | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body = addSimpleTyVarBinds implicit_tvs $ @@ -1019,10 +1059,12 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs ; if null explicit_tvs && null (unLoc ctxt) then return th_ty else repTForall th_explicit_tvs th_ctxt th_ty } +repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType" repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) repHsSigWcType (HsWC { hswc_body = sig1 }) = repHsSigType sig1 +repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType" -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] @@ -1308,7 +1350,8 @@ repE e = notHandled "Expression form" (ppr e) -- Building representations of auxillary structures like Match, Clause, Stmt, repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match { m_pats = [p], m_grhss = GRHSs guards (L _ wheres) })) = +repMatchTup (L _ (Match { m_pats = [p] + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1320,7 +1363,8 @@ repMatchTup (L _ (Match { m_pats = [p], m_grhss = GRHSs guards (L _ wheres) })) repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match { m_pats = ps, m_grhss = GRHSs guards (L _ wheres) })) = +repClauseTup (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1329,9 +1373,11 @@ repClauseTup (L _ (Match { m_pats = ps, m_grhss = GRHSs guards (L _ wheres) })) gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} +repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup" +repClauseTup (L _ (XMatch _)) = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) -repGuards [L _ (GRHS [] e)] +repGuards [L _ (GRHS _ [] e)] = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM repLGRHS other @@ -1341,14 +1387,15 @@ repGuards other repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) -repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2)) +repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } -repLGRHS (L _ (GRHS ss rhs)) +repLGRHS (L _ (GRHS _ ss rhs)) = do { (gs, ss') <- repLSts ss ; rhs' <- addBinds gs $ repLE rhs ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' ; return (gs, guarded) } +repLGRHS (L _ (XGRHS _)) = panic "repLGRHS" repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) repFields (HsRecFields { rec_flds = flds }) @@ -1401,7 +1448,7 @@ repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) repLSts stmts = repSts (map unLoc stmts) repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repSts (BindStmt p e _ _ _ : ss) = +repSts (BindStmt _ p e _ _ : ss) = do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -1409,17 +1456,17 @@ repSts (BindStmt p e _ _ _ : ss) = ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} -repSts (LetStmt (L _ bs) : ss) = +repSts (LetStmt _ (L _ bs) : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (BodyStmt e _ _ _ : ss) = +repSts (BodyStmt _ e _ _ : ss) = do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } -repSts (ParStmt stmt_blocks _ _ _ : ss) = +repSts (ParStmt _ stmt_blocks _ _ : ss) = do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 ss1 = concat ss_s @@ -1434,7 +1481,7 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) = ; zs1 <- coreList stmtQTyConName zs ; return (ss1, zs1) } rep_stmt_block (XParStmtBlock{}) = panic "repSts" -repSts [LastStmt e _ _] +repSts [LastStmt _ e _ _] = do { e2 <- repLE e ; z <- repNoBindSt e2 ; return ([], [z]) } @@ -1488,8 +1535,10 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts - = L _ [L _ (Match { m_pats = [] - , m_grhss = GRHSs guards (L _ wheres) })] } })) + = L _ [L _ (Match + { m_pats = [] + , m_grhss = GRHSs _ guards (L _ wheres) } + )] } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -1505,14 +1554,17 @@ rep_bind (L loc (FunBind { fun_id = fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } +rep_bind (L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind" + rep_bind (L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs guards (L _ wheres) })) + , pat_rhs = GRHSs _ guards (L _ wheres) })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } +rep_bind (L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind" rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v @@ -1525,7 +1577,6 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn - , psb_fvs = _fvs , psb_args = args , psb_def = pat , psb_dir = dir }))) @@ -1603,6 +1654,7 @@ repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } +repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir" repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] @@ -1634,8 +1686,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) repLambda (L _ (Match { m_pats = ps - , m_grhss = GRHSs [L _ (GRHS [] e)] - (L _ (EmptyLocalBinds _)) } )) + , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] + (L _ (EmptyLocalBinds _)) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -1668,10 +1720,10 @@ repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p ; repPaspat x' p1 } repP (ParPat _ p) = repLP p -repP (ListPat _ ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat x ps ty1 (Just (_,e))) = do { p <- repP (ListPat x ps ty1 Nothing) - ; e' <- repE (syn_expr e) - ; repPview e' p} +repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps) + ; e' <- repE (syn_expr e) + ; repPview e' p} repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index c4fb7e7f30..0044cbe49f 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView - = do { let ListPat _ _ elt_ty (Just (_,e)) = firstPat eqn1 + = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern @@ -305,7 +305,8 @@ getBangPat (BangPat _ pat ) = unLoc pat getBangPat _ = panic "getBangPat" getViewPat (ViewPat _ _ pat) = unLoc pat getViewPat _ = panic "getViewPat" -getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing +getOLPat (ListPat (ListPatTc ty (Just _)) pats) + = ListPat (ListPatTc ty Nothing) pats getOLPat _ = panic "getOLPat" {- @@ -441,7 +442,7 @@ tidy1 v (LazyPat _ pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat _ pats ty Nothing) +tidy1 _ (ListPat (ListPatTc ty Nothing) pats ) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) @@ -707,8 +708,7 @@ JJQC 30-Nov-1997 -} matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches - , mg_arg_tys = arg_tys - , mg_res_ty = rhs_ty + , mg_ext = MatchGroupTc arg_tys rhs_ty , mg_origin = origin }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs @@ -739,11 +739,12 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation] dsGRHSs ctxt grhss rhs_ty ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } + mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper" handleWarnings = if isGenerated origin then discardWarningsDs else id - +matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper" matchEquations :: HsMatchContext Name -> [MatchId] -> [EquationInfo] -> Type @@ -1088,7 +1089,7 @@ patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) = patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat _ _ _ (Just _)) = PgOverloadedList +patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) patGroup _ pat = pprPanic "patGroup" (ppr pat) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index c63de9ec36..f683cc8c59 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -145,14 +145,14 @@ cvtDec (TH.ValD pat body ds) | TH.VarP s <- pat = do { s' <- vNameL s ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) - ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] } + ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] } | otherwise = do { pat' <- cvtPat pat ; body' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") ds - ; returnJustL $ Hs.ValD $ - PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds') + ; returnJustL $ Hs.ValD noExt $ + PatBind { pat_lhs = pat', pat_rhs = GRHSs noExt body' (noLoc ds') , pat_ext = noExt , pat_ticks = ([],[]) } } @@ -164,12 +164,13 @@ cvtDec (TH.FunD nm cls) | otherwise = do { nm' <- vNameL nm ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls - ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' } + ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' } cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD (TypeSig noExt [nm'] (mkLHsSigWcType ty')) } + ; returnJustL $ Hs.SigD noExt + (TypeSig noExt [nm'] (mkLHsSigWcType ty')) } cvtDec (TH.InfixD fx nm) -- Fixity signatures are allowed for variables, constructors, and types @@ -177,8 +178,8 @@ cvtDec (TH.InfixD fx nm) -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. = do { nm' <- vcNameL nm - ; returnJustL (Hs.SigD (FixSig noExt - (FixitySig noExt [nm'] (cvtFixity fx)))) } + ; returnJustL (Hs.SigD noExt (FixSig noExt + (FixitySig noExt [nm'] (cvtFixity fx)))) } cvtDec (PragmaD prag) = cvtPragmaD prag @@ -186,10 +187,9 @@ cvtDec (PragmaD prag) cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs - ; returnJustL $ TyClD $ - SynDecl { tcdLName = tc', tcdTyVars = tvs' + ; returnJustL $ TyClD noExt $ + SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix - , tcdFVs = placeHolderNames , tcdRhs = rhs' } } cvtDec (DataD ctxt tc tvs ksig constrs derivs) @@ -208,31 +208,33 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing + ; let defn = HsDataDefn { dd_ext = noExt + , dd_ND = DataType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } - ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' + ; returnJustL $ TyClD noExt (DataDecl + { tcdDExt = noExt + , tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix - , tcdDataDefn = defn - , tcdDataCusk = placeHolder - , tcdFVs = placeHolderNames }) } + , tcdDataDefn = defn }) } cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing + ; let defn = HsDataDefn { dd_ext = noExt + , dd_ND = NewType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = [con'] , dd_derivs = derivs' } - ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' + ; returnJustL $ TyClD noExt (DataDecl + { tcdDExt = noExt + , tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix - , tcdDataDefn = defn - , tcdDataCusk = placeHolder - , tcdFVs = placeHolderNames }) } + , tcdDataDefn = defn }) } cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs @@ -243,13 +245,13 @@ cvtDec (ClassD ctxt cl tvs fds decs) <+> text "are not allowed:") $$ (Outputable.ppr adts')) ; at_defs <- mapM cvt_at_def ats' - ; returnJustL $ TyClD $ - ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' + ; returnJustL $ TyClD noExt $ + ClassDecl { tcdCExt = noExt + , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' , tcdMeths = binds' - , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] - , tcdFVs = placeHolderNames } + , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] } -- no docs in TH ^^ } where @@ -266,8 +268,8 @@ cvtDec (InstanceD o ctxt ty decs) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' - ; returnJustL $ InstD $ ClsInstD $ - ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty' + ; returnJustL $ InstD noExt $ ClsInstD noExt $ + ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts' @@ -285,27 +287,30 @@ cvtDec (InstanceD o ctxt ty decs) cvtDec (ForeignD ford) = do { ford' <- cvtForD ford - ; returnJustL $ ForD ford' } + ; returnJustL $ ForD noExt ford' } cvtDec (DataFamilyD tc tvs kind) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; result <- cvtMaybeKindToFamilyResultSig kind - ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl DataFamily tc' tvs' Prefix result Nothing } + ; returnJustL $ TyClD noExt $ FamDecl noExt $ + FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing } cvtDec (DataInstD ctxt tc tys ksig constrs derivs) = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing + ; let defn = HsDataDefn { dd_ext = noExt + , dd_ND = DataType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } - ; returnJustL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ - FamEqn { feqn_tycon = tc', feqn_pats = typats' + ; returnJustL $ InstD noExt $ DataFamInstD + { dfid_ext = noExt + , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ + FamEqn { feqn_ext = noExt + , feqn_tycon = tc', feqn_pats = typats' , feqn_rhs = defn , feqn_fixity = Prefix } }}} @@ -314,60 +319,67 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs) ; ksig' <- cvtKind `traverse` ksig ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing + ; let defn = HsDataDefn { dd_ext = noExt + , dd_ND = NewType, dd_cType = Nothing , dd_ctxt = ctxt' , dd_kindSig = ksig' , dd_cons = [con'], dd_derivs = derivs' } - ; returnJustL $ InstD $ DataFamInstD - { dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ - FamEqn { feqn_tycon = tc', feqn_pats = typats' + ; returnJustL $ InstD noExt $ DataFamInstD + { dfid_ext = noExt + , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ + FamEqn { feqn_ext = noExt + , feqn_tycon = tc', feqn_pats = typats' , feqn_rhs = defn , feqn_fixity = Prefix } }}} cvtDec (TySynInstD tc eqn) = do { tc' <- tconNameL tc ; L _ eqn' <- cvtTySynEqn tc' eqn - ; returnJustL $ InstD $ TyFamInstD - { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } + ; returnJustL $ InstD noExt $ TyFamInstD + { tfid_ext = noExt + , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } cvtDec (OpenTypeFamilyD head) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head - ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' } + ; returnJustL $ TyClD noExt $ FamDecl noExt $ + FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity' + } cvtDec (ClosedTypeFamilyD head eqns) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head ; eqns' <- mapM (cvtTySynEqn tc') eqns - ; returnJustL $ TyClD $ FamDecl $ - FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result' - injectivity' } + ; returnJustL $ TyClD noExt $ FamDecl noExt $ + FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix + result' injectivity' } cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameL tc ; let roles' = map (noLoc . cvtRole) roles - ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } + ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') } cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext cxt ; L loc ty' <- cvtType ty ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' - ; returnJustL $ DerivD $ - DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds + ; returnJustL $ DerivD noExt $ + DerivDecl { deriv_ext =noExt + , deriv_strategy = fmap (L loc . cvtDerivStrategy) ds , deriv_type = mkLHsSigWcType inst_ty' , deriv_overlap_mode = Nothing } } cvtDec (TH.DefaultSigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')} + ; returnJustL $ Hs.SigD noExt + $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')} cvtDec (TH.PatSynD nm args dir pat) = do { nm' <- cNameL nm ; args' <- cvtArgs args ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat - ; returnJustL $ Hs.ValD $ PatSynBind noExt $ - PSB noExt nm' placeHolderType args' pat' dir' } + ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $ + PSB noExt nm' args' pat' dir' } where cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 @@ -385,7 +397,7 @@ cvtDec (TH.PatSynD nm args dir pat) cvtDec (TH.PatSynSigD nm ty) = do { nm' <- cNameL nm ; ty' <- cvtPatSynSigTy ty - ; returnJustL $ Hs.SigD $ PatSynSig noExt [nm'] (mkLHsSigType ty') } + ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')} ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs) @@ -393,7 +405,8 @@ cvtTySynEqn tc (TySynEqn lhs rhs) = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs ; rhs' <- cvtType rhs ; returnL $ mkHsImplicitBndrs - $ FamEqn { feqn_tycon = tc + $ FamEqn { feqn_ext = noExt + , feqn_tycon = tc , feqn_pats = lhs' , feqn_fixity = Prefix , feqn_rhs = rhs' } } @@ -459,25 +472,29 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) ------------------------------------------------------------------- is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) -is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d) +is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d) is_fam_decl decl = Right decl is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) -is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d) -is_tyfam_inst decl = Right decl +is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) + = Left (L loc d) +is_tyfam_inst decl + = Right decl is_datafam_inst :: LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) -is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d) -is_datafam_inst decl = Right decl +is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) + = Left (L loc d) +is_datafam_inst decl + = Right decl is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) -is_sig (L loc (Hs.SigD sig)) = Left (L loc sig) -is_sig decl = Right decl +is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig) +is_sig decl = Right decl is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) -is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) -is_bind decl = Right decl +is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind) +is_bind decl = Right decl mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc mkBadDecMsg doc bads @@ -530,6 +547,8 @@ cvtConstr (ForallC tvs ctxt con) where all_tvs = hsQTvExplicit tvs' ++ ex_tvs + add_forall _ _ (XConDecl _) = panic "cvtConstr" + cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys @@ -568,7 +587,8 @@ cvt_id_arg (i, str, ty) = do { L li i' <- vNameL i ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField - { cd_fld_names + { cd_fld_ext = noExt + , cd_fld_names = [L li $ FieldOcc noExt (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -607,9 +627,9 @@ cvtForD (ImportF callconv safety from nm ty) mk_imp impspec = do { nm' <- vNameL nm ; ty' <- cvtType ty - ; return (ForeignImport { fd_name = nm' + ; return (ForeignImport { fd_i_ext = noExt + , fd_name = nm' , fd_sig_ty = mkLHsSigType ty' - , fd_co = noForeignImportCoercionYet , fd_fi = impspec }) } safety' = case safety of @@ -624,9 +644,9 @@ cvtForD (ExportF callconv as nm ty) (mkFastString as) (cvt_conv callconv))) (noLoc (SourceText as)) - ; return $ ForeignExport { fd_name = nm' + ; return $ ForeignExport { fd_e_ext = noExt + , fd_name = nm' , fd_sig_ty = mkLHsSigType ty' - , fd_co = noForeignExportCoercionYet , fd_fe = e } } cvt_conv :: TH.Callconv -> CCallConv @@ -652,7 +672,7 @@ cvtPragmaD (InlineP nm inline rm phases) , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ InlineSig noExt nm' ip } + ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip } cvtPragmaD (SpecialiseP nm ty inline phases) = do { nm' <- vNameL nm @@ -670,11 +690,11 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig noExt nm' [mkLHsSigType ty'] ip } + ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty - ; returnJustL $ Hs.SigD $ + ; returnJustL $ Hs.SigD noExt $ SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } cvtPragmaD (RuleP nm bndrs lhs rhs phases) @@ -683,11 +703,10 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases) ; bndrs' <- mapM cvtRuleBndr bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs - ; returnJustL $ Hs.RuleD - $ HsRules (SourceText "{-# RULES") - [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs' - lhs' placeHolderNames - rhs' placeHolderNames] + ; returnJustL $ Hs.RuleD noExt + $ HsRules noExt (SourceText "{-# RULES") + [noLoc $ HsRule noExt (noLoc (SourceText nm,nm')) act + bndrs' lhs' rhs'] } cvtPragmaD (AnnP target exp) @@ -700,8 +719,8 @@ cvtPragmaD (AnnP target exp) ValueAnnotation n -> do n' <- vcName n return (ValueAnnProvenance (noLoc n')) - ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target' - exp' + ; returnJustL $ Hs.AnnD noExt + $ HsAnnotation noExt (SourceText "{-# ANN") target' exp' } cvtPragmaD (LineP line file) @@ -711,7 +730,7 @@ cvtPragmaD (LineP line file) cvtPragmaD (CompleteP cls mty) = do { cls' <- noLoc <$> mapM cNameL cls ; mty' <- traverse tconNameL mty - ; returnJustL $ Hs.SigD + ; returnJustL $ Hs.SigD noExt $ CompleteMatchSig noExt NoSourceText cls' mty' } dfltActivation :: TH.Inline -> Activation @@ -735,11 +754,11 @@ cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) = do { n' <- vNameL n - ; return $ noLoc $ Hs.RuleBndr n' } + ; return $ noLoc $ Hs.RuleBndr noExt n' } cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameL n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' } + ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' } --------------------------------------------------- -- Declarations @@ -763,7 +782,7 @@ cvtClause ctxt (Clause ps body wheres) ; pps <- mapM wrap_conpat ps' ; g' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") wheres - ; returnL $ Hs.Match ctxt pps (GRHSs g' (noLoc ds')) } + ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) } ------------------------------------------------------------------- @@ -830,7 +849,7 @@ cvtl e = wrapL (cvt e) cvt (MultiIfE alts) | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts - ; return $ HsMultiIf placeHolderType alts' } + ; return $ HsMultiIf noExt alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms @@ -845,7 +864,7 @@ cvtl e = wrapL (cvt e) ; return (HsLit noExt l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList placeHolderType Nothing xs' + ; return $ ExplicitList noExt Nothing xs' } -- Infix expressions @@ -994,7 +1013,8 @@ cvtHsDo do_or_lc stmts ; let Just (stmts'', last') = snocView stmts' ; last'' <- case last' of - L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) + L loc (BodyStmt _ body _ _) + -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) } @@ -1010,8 +1030,9 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } 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 } + ; returnL $ LetStmt noExt (noLoc ds') } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss + ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr } where cvt_one ds = do { ds' <- cvtStmts ds ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) } @@ -1025,18 +1046,19 @@ cvtMatch ctxt (TH.Match p body decs) _ -> wrap_conpat p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs - ; returnL $ Hs.Match ctxt [lp] (GRHSs g' (noLoc decs')) } + ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) } cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs -cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] } +cvtGuard (NormalB e) = do { e' <- cvtl e + ; g' <- returnL $ GRHS noExt [] e'; return [g'] } cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs ; g' <- returnL $ mkBodyStmt ge' - ; returnL $ GRHS [g'] rhs' } + ; returnL $ GRHS noExt [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs - ; returnL $ GRHS gs' rhs' } + ; returnL $ GRHS noExt gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) @@ -1143,7 +1165,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps ; return - $ ListPat noExt ps' placeHolderType Nothing } + $ ListPat noExt ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t ; return $ SigPat (mkLHsSigWcType t') p' } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p @@ -1209,7 +1231,7 @@ cvtDerivClause :: TH.DerivClause cvtDerivClause (TH.DerivClause ds ctxt) = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt ; let ds' = fmap (L loc . cvtDerivStrategy) ds - ; returnL $ HsDerivingClause ds' ctxt' } + ; returnL $ HsDerivingClause noExt ds' ctxt' } cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy @@ -1445,18 +1467,18 @@ cvtKind = cvtTypeKind "kind" -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind -> CvtM (LFamilyResultSig GhcPs) -cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig +cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExt) cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig ki') } + ; returnL (Hs.KindSig noExt ki') } -- | Convert type family result signature. Used with both open and closed type -- families. cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs) -cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig +cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExt) cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig ki') } + ; returnL (Hs.KindSig noExt ki') } cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr - ; returnL (Hs.TyVarSig tv) } + ; returnL (Hs.TyVarSig noExt tv) } -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index ea5704c5d2..e4a6906996 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -25,7 +25,6 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder import HsExtension import HsTypes import PprCore () @@ -95,10 +94,10 @@ data HsLocalBindsLR idL idR | XHsLocalBindsLR (XXHsLocalBindsLR idL idR) -type instance XHsValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) @@ -136,7 +135,7 @@ data NHsValBindsLR idL [(RecFlag, LHsBinds idL)] [LSig GhcRn] -type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExt type instance XXValBindsLR (GhcPass pL) (GhcPass pR) = NHsValBindsLR (GhcPass pL) @@ -320,18 +319,18 @@ data NPatBindTc = NPatBindTc { pat_rhs_ty :: Type -- ^ Type of the GRHSs } deriving Data -type instance XFunBind (GhcPass pL) GhcPs = PlaceHolder +type instance XFunBind (GhcPass pL) GhcPs = NoExt type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables -type instance XPatBind GhcPs (GhcPass pR) = PlaceHolder +type instance XPatBind GhcPs (GhcPass pR) = NoExt type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc -type instance XVarBind (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XAbsBinds (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XPatSynBind (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt +type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] @@ -357,8 +356,8 @@ data ABExport p } | XABExport (XXABExport p) -type instance XABE (GhcPass p) = PlaceHolder -type instance XXABExport (GhcPass p) = PlaceHolder +type instance XABE (GhcPass p) = NoExt +type instance XXABExport (GhcPass p) = NoExt -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', @@ -370,9 +369,9 @@ type instance XXABExport (GhcPass p) = PlaceHolder -- | Pattern Synonym binding data PatSynBind idL idR - = PSB { psb_ext :: XPSB idL idR, + = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. + -- See Note [Bind free vars] psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym - psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] psb_args :: HsPatSynDetails (Located (IdP idR)), -- ^ Formal parameter names psb_def :: LPat idR, -- ^ Right-hand side @@ -380,8 +379,11 @@ data PatSynBind idL idR } | XPatSynBind (XXPatSynBind idL idR) -type instance XPSB (GhcPass idL) (GhcPass idR) = PlaceHolder -type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = PlaceHolder +type instance XPSB (GhcPass idL) GhcPs = NoExt +type instance XPSB (GhcPass idL) GhcRn = NameSet +type instance XPSB (GhcPass idL) GhcTc = NameSet + +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt {- Note [AbsBinds] @@ -765,7 +767,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars pprLHsBinds val_binds ppr_monobind (XHsBindsLR x) = ppr x -instance (OutputableBndrId p) => Outputable (ABExport p) where +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) @@ -822,13 +824,13 @@ data HsIPBinds id -- -- uses of the implicit parameters | XHsIPBinds (XXHsIPBinds id) -type instance XIPBinds GhcPs = PlaceHolder -type instance XIPBinds GhcRn = PlaceHolder +type instance XIPBinds GhcPs = NoExt +type instance XIPBinds GhcRn = NoExt type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the -- implicit parameters -type instance XXHsIPBinds (GhcPass p) = PlaceHolder +type instance XXHsIPBinds (GhcPass p) = NoExt isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool isEmptyIPBindsPR (IPBinds _ is) = null is @@ -862,8 +864,8 @@ data IPBind id (LHsExpr id) | XCIPBind (XXIPBind id) -type instance XIPBind (GhcPass p) = PlaceHolder -type instance XXIPBind (GhcPass p) = PlaceHolder +type instance XIPBind (GhcPass p) = NoExt +type instance XXIPBind (GhcPass p) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsIPBinds p) where @@ -1045,18 +1047,18 @@ data Sig pass (Maybe (Located (IdP pass))) | XSig (XXSig pass) -type instance XTypeSig (GhcPass p) = PlaceHolder -type instance XPatSynSig (GhcPass p) = PlaceHolder -type instance XClassOpSig (GhcPass p) = PlaceHolder -type instance XIdSig (GhcPass p) = PlaceHolder -type instance XFixSig (GhcPass p) = PlaceHolder -type instance XInlineSig (GhcPass p) = PlaceHolder -type instance XSpecSig (GhcPass p) = PlaceHolder -type instance XSpecInstSig (GhcPass p) = PlaceHolder -type instance XMinimalSig (GhcPass p) = PlaceHolder -type instance XSCCFunSig (GhcPass p) = PlaceHolder -type instance XCompleteMatchSig (GhcPass p) = PlaceHolder -type instance XXSig (GhcPass p) = PlaceHolder +type instance XTypeSig (GhcPass p) = NoExt +type instance XPatSynSig (GhcPass p) = NoExt +type instance XClassOpSig (GhcPass p) = NoExt +type instance XIdSig (GhcPass p) = NoExt +type instance XFixSig (GhcPass p) = NoExt +type instance XInlineSig (GhcPass p) = NoExt +type instance XSpecSig (GhcPass p) = NoExt +type instance XSpecInstSig (GhcPass p) = NoExt +type instance XMinimalSig (GhcPass p) = NoExt +type instance XSCCFunSig (GhcPass p) = NoExt +type instance XCompleteMatchSig (GhcPass p) = NoExt +type instance XXSig (GhcPass p) = NoExt -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) @@ -1065,8 +1067,8 @@ type LFixitySig pass = Located (FixitySig pass) data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity | XFixitySig (XXFixitySig pass) -type instance XFixitySig (GhcPass p) = PlaceHolder -type instance XXFixitySig (GhcPass p) = PlaceHolder +type instance XFixitySig (GhcPass p) = NoExt +type instance XXFixitySig (GhcPass p) = NoExt -- | Type checker Specialisation Pragmas -- @@ -1203,7 +1205,8 @@ ppr_sig (CompleteMatchSig _ src cs mty) opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty ppr_sig (XSig x) = ppr x -instance OutputableBndrId pass => Outputable (FixitySig pass) where +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FixitySig p) where ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 2cbdad3f70..df26b45e10 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -22,7 +22,7 @@ module HsDecls ( HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour, -- ** Class or type declarations - TyClDecl(..), LTyClDecl, + TyClDecl(..), LTyClDecl, DataDeclRn(..), TyClGroup(..), mkTyClGroup, emptyTyClGroup, tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, isClassDecl, isDataDecl, isSynDecl, tcdName, @@ -46,11 +46,12 @@ module HsDecls ( -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, RuleBndr(..),LRuleBndr, + LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..), + RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, flattenRuleDecls, pprFullRuleName, -- ** @VECTORISE@ declarations - VectDecl(..), LVectDecl, + VectDecl(..), LVectDecl,VectTypePR(..),VectTypeTc(..),VectClassPR(..), lvectDeclName, lvectInstDecl, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, @@ -59,7 +60,6 @@ module HsDecls ( SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), - noForeignImportCoercionYet, noForeignExportCoercionYet, CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl, @@ -99,7 +99,6 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PlaceHolder, placeHolder ) import HsExtension import NameSet @@ -122,7 +121,7 @@ import Data.Data hiding (TyCon,Fixity, Infix) ************************************************************************ -} -type LHsDecl id = Located (HsDecl id) +type LHsDecl p = Located (HsDecl p) -- ^ When in a list this may have -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' @@ -131,24 +130,39 @@ type LHsDecl id = Located (HsDecl id) -- For details on above see note [Api annotations] in ApiAnnotation -- | A Haskell Declaration -data HsDecl id - -- AZ:TODO:TTG HsDecl - = TyClD (TyClDecl id) -- ^ Type or Class Declaration - | InstD (InstDecl id) -- ^ Instance declaration - | DerivD (DerivDecl id) -- ^ Deriving declaration - | ValD (HsBind id) -- ^ Value declaration - | SigD (Sig id) -- ^ Signature declaration - | DefD (DefaultDecl id) -- ^ 'default' declaration - | ForD (ForeignDecl id) -- ^ Foreign declaration - | WarningD (WarnDecls id) -- ^ Warning declaration - | AnnD (AnnDecl id) -- ^ Annotation declaration - | RuleD (RuleDecls id) -- ^ Rule declaration - | VectD (VectDecl id) -- ^ Vectorise declaration - | SpliceD (SpliceDecl id) -- ^ Splice declaration - -- (Includes quasi-quotes) - | DocD (DocDecl) -- ^ Documentation comment declaration - | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration - +data HsDecl p + = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration + | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration + | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration + | ValD (XValD p) (HsBind p) -- ^ Value declaration + | SigD (XSigD p) (Sig p) -- ^ Signature declaration + | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration + | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration + | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration + | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration + | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration + | VectD (XVectD p) (VectDecl p) -- ^ Vectorise declaration + | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration + -- (Includes quasi-quotes) + | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration + | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration + | XHsDecl (XXHsDecl p) + +type instance XTyClD (GhcPass _) = NoExt +type instance XInstD (GhcPass _) = NoExt +type instance XDerivD (GhcPass _) = NoExt +type instance XValD (GhcPass _) = NoExt +type instance XSigD (GhcPass _) = NoExt +type instance XDefD (GhcPass _) = NoExt +type instance XForD (GhcPass _) = NoExt +type instance XWarningD (GhcPass _) = NoExt +type instance XAnnD (GhcPass _) = NoExt +type instance XRuleD (GhcPass _) = NoExt +type instance XVectD (GhcPass _) = NoExt +type instance XSpliceD (GhcPass _) = NoExt +type instance XDocD (GhcPass _) = NoExt +type instance XRoleAnnotD (GhcPass _) = NoExt +type instance XXHsDecl (GhcPass _) = NoExt -- NB: all top-level fixity decls are contained EITHER -- EITHER SigDs @@ -167,42 +181,48 @@ data HsDecl id -- -- A 'HsDecl' is categorised into a 'HsGroup' before being -- fed to the renamer. -data HsGroup id - -- AZ:TODO:TTG HsGroup +data HsGroup p = HsGroup { - hs_valds :: HsValBinds id, - hs_splcds :: [LSpliceDecl id], + hs_ext :: XCHsGroup p, + hs_valds :: HsValBinds p, + hs_splcds :: [LSpliceDecl p], - hs_tyclds :: [TyClGroup id], + hs_tyclds :: [TyClGroup p], -- A list of mutually-recursive groups; -- This includes `InstDecl`s as well; -- Parser generates a singleton list; -- renamer does dependency analysis - hs_derivds :: [LDerivDecl id], + hs_derivds :: [LDerivDecl p], - hs_fixds :: [LFixitySig id], + hs_fixds :: [LFixitySig p], -- Snaffled out of both top-level fixity signatures, -- and those in class declarations - hs_defds :: [LDefaultDecl id], - hs_fords :: [LForeignDecl id], - hs_warnds :: [LWarnDecls id], - hs_annds :: [LAnnDecl id], - hs_ruleds :: [LRuleDecls id], - hs_vects :: [LVectDecl id], + hs_defds :: [LDefaultDecl p], + hs_fords :: [LForeignDecl p], + hs_warnds :: [LWarnDecls p], + hs_annds :: [LAnnDecl p], + hs_ruleds :: [LRuleDecls p], + hs_vects :: [LVectDecl p], hs_docs :: [LDocDecl] - } + } + | XHsGroup (XXHsGroup p) + +type instance XCHsGroup (GhcPass _) = NoExt +type instance XXHsGroup (GhcPass _) = NoExt -emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a) + +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } hsGroupInstDecls :: HsGroup id -> [LInstDecl id] hsGroupInstDecls = (=<<) group_instds . hs_tyclds -emptyGroup = HsGroup { hs_tyclds = [], +emptyGroup = HsGroup { hs_ext = noExt, + hs_tyclds = [], hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], @@ -210,8 +230,8 @@ emptyGroup = HsGroup { hs_tyclds = [], hs_splcds = [], hs_docs = [] } -appendGroups :: HsGroup (GhcPass a) -> HsGroup (GhcPass a) - -> HsGroup (GhcPass a) +appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) + -> HsGroup (GhcPass p) appendGroups HsGroup { hs_valds = val_groups1, @@ -241,6 +261,7 @@ appendGroups hs_docs = docs2 } = HsGroup { + hs_ext = noExt, hs_valds = val_groups1 `plusHsValBinds` val_groups2, hs_splcds = spliceds1 ++ spliceds2, hs_tyclds = tyclds1 ++ tyclds2, @@ -253,22 +274,24 @@ appendGroups hs_ruleds = rulds1 ++ rulds2, hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } +appendGroups _ _ = panic "appendGroups" instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where - ppr (TyClD dcl) = ppr dcl - ppr (ValD binds) = ppr binds - ppr (DefD def) = ppr def - ppr (InstD inst) = ppr inst - ppr (DerivD deriv) = ppr deriv - ppr (ForD fd) = ppr fd - ppr (SigD sd) = ppr sd - ppr (RuleD rd) = ppr rd - ppr (VectD vect) = ppr vect - ppr (WarningD wd) = ppr wd - ppr (AnnD ad) = ppr ad - ppr (SpliceD dd) = ppr dd - ppr (DocD doc) = ppr doc - ppr (RoleAnnotD ra) = ppr ra + ppr (TyClD _ dcl) = ppr dcl + ppr (ValD _ binds) = ppr binds + ppr (DefD _ def) = ppr def + ppr (InstD _ inst) = ppr inst + ppr (DerivD _ deriv) = ppr deriv + ppr (ForD _ fd) = ppr fd + ppr (SigD _ sd) = ppr sd + ppr (RuleD _ rd) = ppr rd + ppr (VectD _ vect) = ppr vect + ppr (WarningD _ wd) = ppr wd + ppr (AnnD _ ad) = ppr ad + ppr (SpliceD _ dd) = ppr dd + ppr (DocD _ doc) = ppr doc + ppr (RoleAnnotD _ ra) = ppr ra + ppr (XHsDecl x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where ppr (HsGroup { hs_valds = val_decls, @@ -303,20 +326,26 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where vcat_mb _ [] = empty vcat_mb gap (Nothing : ds) = vcat_mb gap ds vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds + ppr (XHsGroup x) = ppr x -- | Located Splice Declaration type LSpliceDecl pass = Located (SpliceDecl pass) -- | Splice Declaration -data SpliceDecl id - -- AZ:TODO: TTG SpliceD +data SpliceDecl p = SpliceDecl -- Top level splice - (Located (HsSplice id)) + (XSpliceDecl p) + (Located (HsSplice p)) SpliceExplicitFlag + | XSpliceDecl (XXSpliceDecl p) + +type instance XSpliceDecl (GhcPass _) = NoExt +type instance XXSpliceDecl (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (SpliceDecl p) where - ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f + ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f + ppr (XSpliceDecl x) = ppr x {- ************************************************************************ @@ -462,7 +491,6 @@ type LTyClDecl pass = Located (TyClDecl pass) -- | A type or class declaration. data TyClDecl pass - -- AZ:TODO: TTG TyClDecl = -- | @type/data family T :: *->*@ -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', @@ -474,7 +502,7 @@ data TyClDecl pass -- 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation - FamDecl { tcdFam :: FamilyDecl pass } + FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } | -- | @type@ declaration -- @@ -482,13 +510,13 @@ data TyClDecl pass -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation - SynDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these -- include outer binders , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType pass -- ^ RHS of type declaration - , tcdFVs :: PostRn pass NameSet } + , tcdRhs :: LHsType pass } -- ^ RHS of type declaration | -- | @data@ declaration -- @@ -499,7 +527,8 @@ data TyClDecl pass -- 'ApiAnnotation.AnnWhere', -- For details on above see note [Api annotations] in ApiAnnotation - DataDecl { tcdLName :: Located (IdP pass) -- ^ Type constructor + DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type -- these include outer binders @@ -508,12 +537,11 @@ data TyClDecl pass -- type F a = a -> a -- Here the type decl for 'f' -- includes 'a' in its tcdTyVars - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdDataDefn :: HsDataDefn pass - , tcdDataCusk :: PostRn pass Bool -- ^ does this have a CUSK? - , tcdFVs :: PostRn pass NameSet } + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdDataDefn :: HsDataDefn pass } - | ClassDecl { tcdCtxt :: LHsContext pass, -- ^ Context... + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... tcdLName :: Located (IdP pass), -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration @@ -524,8 +552,7 @@ data TyClDecl pass tcdATs :: [LFamilyDecl pass], -- ^ Associated types; tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults - tcdDocs :: [LDocDecl], -- ^ Haddock docs - tcdFVs :: PostRn pass NameSet + tcdDocs :: [LDocDecl] -- ^ Haddock docs } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', @@ -535,7 +562,28 @@ data TyClDecl pass -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation + | XTyClDecl (XXTyClDecl pass) + +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + , tcdFVs :: NameSet } + deriving Data +type instance XFamDecl (GhcPass _) = NoExt + +type instance XSynDecl GhcPs = NoExt +type instance XSynDecl GhcRn = NameSet -- FVs +type instance XSynDecl GhcTc = NameSet -- FVs + +type instance XDataDecl GhcPs = NoExt +type instance XDataDecl GhcRn = DataDeclRn +type instance XDataDecl GhcTc = DataDeclRn + +type instance XClassDecl GhcPs = NoExt +type instance XClassDecl GhcRn = NameSet -- FVs +type instance XClassDecl GhcTc = NameSet -- FVs + +type instance XXTyClDecl (GhcPass _) = NoExt -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -563,7 +611,7 @@ isFamilyDecl _other = False -- | type family declaration isTypeFamilyDecl :: TyClDecl pass -> Bool -isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of +isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of OpenTypeFamily -> True ClosedTypeFamily {} -> True _ -> False @@ -581,7 +629,7 @@ isClosedTypeFamilyInfo _ = False -- | data family declaration isDataFamilyDecl :: TyClDecl pass -> Bool -isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True +isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True isDataFamilyDecl _other = False -- Dealing with names @@ -593,6 +641,10 @@ tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass) tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) = ln +tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _))) + = panic "tyFamInstDeclLName" +tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _)) + = panic "tyFamInstDeclLName" tyClDeclLName :: TyClDecl pass -> Located (IdP pass) tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln @@ -632,8 +684,9 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) HsParTy _ lty -> rhs_annotated lty HsKindSig {} -> True _ -> False -hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk +hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars +hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -668,6 +721,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where top_matter = text "class" <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) <+> pprFundeps (map unLoc fds) + ppr (XTyClDecl x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClGroup p) where @@ -679,6 +733,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) = ppr tyclds $$ ppr roles $$ ppr instds + ppr (XTyClGroup x) = ppr x pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p)) => Located (IdP (GhcPass p)) @@ -700,14 +755,20 @@ pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context | otherwise = hsep [ pprPrefixOcc (unLoc thing) , hsep (map (ppr.unLoc) (varl:varsr))] pp_tyvars [] = ppr thing +pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x -pprTyClDeclFlavour :: TyClDecl a -> SDoc +pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc pprTyClDeclFlavour (ClassDecl {}) = text "class" pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" +pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x}) + = ppr x pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) = ppr nd +pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) + = ppr x +pprTyClDeclFlavour (XTyClDecl x) = ppr x {- Note [Complete user-supplied kind signatures] @@ -775,13 +836,18 @@ in RnSource for more info. -- | Type or Class Group data TyClGroup pass -- See Note [TyClGroups and dependency analysis] - -- AZ:TODO: TTG TyClGroups - = TyClGroup { group_tyclds :: [LTyClDecl pass] + = TyClGroup { group_ext :: XCTyClGroup pass + , group_tyclds :: [LTyClDecl pass] , group_roles :: [LRoleAnnotDecl pass] , group_instds :: [LInstDecl pass] } + | XTyClGroup (XXTyClGroup pass) -emptyTyClGroup :: TyClGroup pass -emptyTyClGroup = TyClGroup [] [] [] +type instance XCTyClGroup (GhcPass _) = NoExt +type instance XXTyClGroup (GhcPass _) = NoExt + + +emptyTyClGroup :: TyClGroup (GhcPass p) +emptyTyClGroup = TyClGroup noExt [] [] [] tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] tyClGroupTyClDecls = concatMap group_tyclds @@ -792,9 +858,11 @@ tyClGroupInstDecls = concatMap group_instds tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] tyClGroupRoleDecls = concatMap group_roles -mkTyClGroup :: [LTyClDecl pass] -> [LInstDecl pass] -> TyClGroup pass +mkTyClGroup :: [LTyClDecl (GhcPass p)] -> [LInstDecl (GhcPass p)] + -> TyClGroup (GhcPass p) mkTyClGroup decls instds = TyClGroup - { group_tyclds = decls + { group_ext = noExt + , group_tyclds = decls , group_roles = [] , group_instds = instds } @@ -875,38 +943,46 @@ type LFamilyResultSig pass = Located (FamilyResultSig pass) -- | type Family Result Signature data FamilyResultSig pass = -- see Note [FamilyResultSig] - -- AZ:TODO: TTG FamilyResultSig - NoSig + NoSig (XNoSig pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- For details on above see note [Api annotations] in ApiAnnotation - | KindSig (LHsKind pass) + | KindSig (XCKindSig pass) (LHsKind pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP' -- For details on above see note [Api annotations] in ApiAnnotation - | TyVarSig (LHsTyVarBndr pass) + | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' + | XFamilyResultSig (XXFamilyResultSig pass) -- For details on above see note [Api annotations] in ApiAnnotation +type instance XNoSig (GhcPass _) = NoExt +type instance XCKindSig (GhcPass _) = NoExt +type instance XTyVarSig (GhcPass _) = NoExt +type instance XXFamilyResultSig (GhcPass _) = NoExt + + -- | Located type Family Declaration type LFamilyDecl pass = Located (FamilyDecl pass) -- | type Family Declaration data FamilyDecl pass = FamilyDecl - { fdInfo :: FamilyInfo pass -- type/data, closed/open + { fdExt :: XCFamilyDecl pass + , fdInfo :: FamilyInfo pass -- type/data, closed/open , fdLName :: Located (IdP pass) -- type constructor , fdTyVars :: LHsQTyVars pass -- type variables , fdFixity :: LexicalFixity -- Fixity used in the declaration , fdResultSig :: LFamilyResultSig pass -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann } + | XFamilyDecl (XXFamilyDecl pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', @@ -916,6 +992,10 @@ data FamilyDecl pass = FamilyDecl -- For details on above see note [Api annotations] in ApiAnnotation +type instance XCFamilyDecl (GhcPass _) = NoExt +type instance XXFamilyDecl (GhcPass _) = NoExt + + -- | Located Injectivity Annotation type LInjectivityAnn pass = Located (InjectivityAnn pass) @@ -954,14 +1034,14 @@ famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True -- | Does this family declaration have user-supplied return kind signature? hasReturnKindSignature :: FamilyResultSig a -> Bool -hasReturnKindSignature NoSig = False -hasReturnKindSignature (TyVarSig (L _ (UserTyVar{}))) = False -hasReturnKindSignature _ = True +hasReturnKindSignature (NoSig _) = False +hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False +hasReturnKindSignature _ = True -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig a -> Maybe (IdP a) -resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig -resultVariableName _ = Nothing +resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig +resultVariableName _ = Nothing instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (FamilyDecl p) where @@ -984,9 +1064,10 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon NotTopLevel -> empty pp_kind = case result of - NoSig -> empty - KindSig kind -> dcolon <+> ppr kind - TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr + NoSig _ -> empty + KindSig _ kind -> dcolon <+> ppr kind + TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr + XFamilyResultSig x -> ppr x pp_inj = case mb_inj of Just (L _ (InjectivityAnn lhs rhs)) -> hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] @@ -998,6 +1079,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon Nothing -> text ".." Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) _ -> (empty, empty) +pprFamilyDecl _ (XFamilyDecl x) = ppr x pprFlavour :: FamilyInfo pass -> SDoc pprFlavour DataFamily = text "data" @@ -1024,7 +1106,8 @@ data HsDataDefn pass -- The payload of a data type defn -- data/newtype T a = <constrs> -- data/newtype instance T [a] = <constrs> -- @ - HsDataDefn { dd_ND :: NewOrData, + HsDataDefn { dd_ext :: XCHsDataDefn pass, + dd_ND :: NewOrData, dd_ctxt :: LHsContext pass, -- ^ Context dd_cType :: Maybe (Located CType), dd_kindSig:: Maybe (LHsKind pass), @@ -1047,6 +1130,10 @@ data HsDataDefn pass -- The payload of a data type defn -- For details on above see note [Api annotations] in ApiAnnotation } + | XHsDataDefn (XXHsDataDefn pass) + +type instance XCHsDataDefn (GhcPass _) = NoExt +type instance XXHsDataDefn (GhcPass _) = NoExt -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] @@ -1069,7 +1156,8 @@ type LHsDerivingClause pass = Located (HsDerivingClause pass) data HsDerivingClause pass -- See Note [Deriving strategies] in TcDeriv = HsDerivingClause - { deriv_clause_strategy :: Maybe (Located DerivStrategy) + { deriv_clause_ext :: XCHsDerivingClause pass + , deriv_clause_strategy :: Maybe (Located DerivStrategy) -- ^ The user-specified strategy (if any) to use when deriving -- 'deriv_clause_tys'. , deriv_clause_tys :: Located [LHsSigType pass] @@ -1082,6 +1170,10 @@ data HsDerivingClause pass -- -- should produce a derived instance for @C [a] (T b)@. } + | XHsDerivingClause (XXHsDerivingClause pass) + +type instance XCHsDerivingClause (GhcPass _) = NoExt +type instance XXHsDerivingClause (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDerivingClause p) where @@ -1098,6 +1190,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) | isCompoundHsType ty = parens (ppr a) | otherwise = ppr a pp_dct _ = parens (interpp'SP dct) + ppr (XHsDerivingClause x) = ppr x data NewOrData = NewType -- ^ @newtype Blah ...@ @@ -1143,7 +1236,8 @@ type LConDecl pass = Located (ConDecl pass) -- | data Constructor Declaration data ConDecl pass = ConDeclGADT - { con_names :: [Located (IdP pass)] + { con_g_ext :: XConDeclGADT pass + , con_names :: [Located (IdP pass)] -- The next four fields describe the type after the '::' -- See Note [GADT abstract syntax] @@ -1162,7 +1256,8 @@ data ConDecl pass } | ConDeclH98 - { con_name :: Located (IdP pass) + { con_ext :: XConDeclH98 pass + , con_name :: Located (IdP pass) , con_forall :: Bool -- ^ True <=> explicit user-written forall -- e.g. data T a = forall b. MkT b (b->a) @@ -1175,6 +1270,11 @@ data ConDecl pass , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } + | XConDecl (XXConDecl pass) + +type instance XConDeclGADT (GhcPass _) = NoExt +type instance XConDeclH98 (GhcPass _) = NoExt +type instance XXConDecl (GhcPass _) = NoExt {- Note [GADT abstract syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1220,6 +1320,7 @@ type HsConDeclDetails pass getConNames :: ConDecl pass -> [Located (IdP pass)] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names +getConNames XConDecl {} = panic "getConNames" getConArgs :: ConDecl pass -> HsConDeclDetails pass getConArgs d = con_args d @@ -1256,6 +1357,7 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) +pp_data_defn _ (XHsDataDefn x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDataDefn p) where @@ -1305,6 +1407,8 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) ppr_arrow_chain [] = empty +pprConDecl (XConDecl x) = ppr x + ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) @@ -1444,16 +1548,21 @@ type FamInstEqn pass rhs -- See Note [Family instance declaration binders] data FamEqn pass pats rhs = FamEqn - { feqn_tycon :: Located (IdP pass) + { feqn_ext :: XCFamEqn pass pats rhs + , feqn_tycon :: Located (IdP pass) , feqn_pats :: pats , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + | XFamEqn (XXFamEqn pass pats rhs) -- For details on above see note [Api annotations] in ApiAnnotation +type instance XCFamEqn (GhcPass _) p r = NoExt +type instance XXFamEqn (GhcPass _) p r = NoExt + ----------------- Class instances ------------- -- | Located Class Instance Declaration @@ -1462,7 +1571,8 @@ type LClsInstDecl pass = Located (ClsInstDecl pass) -- | Class Instance Declaration data ClsInstDecl pass = ClsInstDecl - { cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type + { cid_ext :: XCClsInstDecl pass + , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. , cid_binds :: LHsBinds pass -- Class methods @@ -1481,6 +1591,10 @@ data ClsInstDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation + | XClsInstDecl (XXClsInstDecl pass) + +type instance XCClsInstDecl (GhcPass _) = NoExt +type instance XXClsInstDecl (GhcPass _) = NoExt ----------------- Instances of all kinds ------------- @@ -1490,11 +1604,20 @@ type LInstDecl pass = Located (InstDecl pass) -- | Instance Declaration data InstDecl pass -- Both class and family instances = ClsInstD - { cid_inst :: ClsInstDecl pass } + { cid_d_ext :: XClsInstD pass + , cid_inst :: ClsInstDecl pass } | DataFamInstD -- data family instance - { dfid_inst :: DataFamInstDecl pass } + { dfid_ext :: XDataFamInstD pass + , dfid_inst :: DataFamInstDecl pass } | TyFamInstD -- type family instance - { tfid_inst :: TyFamInstDecl pass } + { tfid_ext :: XTyFamInstD pass + , tfid_inst :: TyFamInstDecl pass } + | XInstDecl (XXInstDecl pass) + +type instance XClsInstD (GhcPass _) = NoExt +type instance XDataFamInstD (GhcPass _) = NoExt +type instance XTyFamInstD (GhcPass _) = NoExt +type instance XXInstDecl (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyFamInstDecl p) where @@ -1516,6 +1639,8 @@ ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_fixity = fixity , feqn_rhs = rhs }}) = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs +ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x +ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p)) => LTyFamDefltEqn (GhcPass p) -> SDoc @@ -1525,6 +1650,7 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon , feqn_rhs = rhs })) = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] <+> equals <+> ppr rhs +ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DataFamInstDecl p) where @@ -1544,11 +1670,22 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = -- No need to pass an explicit kind signature to -- pprFamInstLHS here, since pp_data_defn already -- pretty-prints that. See #14817. +pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x -pprDataFamInstFlavour :: DataFamInstDecl pass -> SDoc +pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) = ppr nd +pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = XHsDataDefn x}}}) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x pprFamInstLHS :: (OutputableBndrId (GhcPass p)) => Located (IdP (GhcPass p)) @@ -1593,6 +1730,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) where top_matter = text "instance" <+> ppOverlapPragma mbOverlap <+> ppr inst_ty + ppr (XClsInstDecl x) = ppr x ppDerivStrategy :: Maybe (Located DerivStrategy) -> SDoc ppDerivStrategy mb = @@ -1618,6 +1756,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl + ppr (XInstDecl x) = ppr x -- Extract the declarations of associated data types from an instance @@ -1629,6 +1768,8 @@ instDeclDataFamInsts inst_decls = map unLoc fam_insts do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] + do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts" + do_one (L _ (XInstDecl _)) = panic "instDeclDataFamInsts" {- ************************************************************************ @@ -1643,7 +1784,8 @@ type LDerivDecl pass = Located (DerivDecl pass) -- | Deriving Declaration data DerivDecl pass = DerivDecl - { deriv_type :: LHsSigWcType pass + { deriv_ext :: XCDerivDecl pass + , deriv_type :: LHsSigWcType pass -- ^ The instance type to derive. -- -- It uses an 'LHsSigWcType' because the context is allowed to be a @@ -1664,6 +1806,10 @@ data DerivDecl pass = DerivDecl -- For details on above see note [Api annotations] in ApiAnnotation } + | XDerivDecl (XXDerivDecl pass) + +type instance XCDerivDecl (GhcPass _) = NoExt +type instance XXDerivDecl (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DerivDecl p) where @@ -1675,6 +1821,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) , text "instance" , ppOverlapPragma o , ppr ty ] + ppr (XDerivDecl x) = ppr x {- ************************************************************************ @@ -1693,16 +1840,21 @@ type LDefaultDecl pass = Located (DefaultDecl pass) -- | Default Declaration data DefaultDecl pass - = DefaultDecl [LHsType pass] + = DefaultDecl (XCDefaultDecl pass) [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation + | XDefaultDecl (XXDefaultDecl pass) + +type instance XCDefaultDecl (GhcPass _) = NoExt +type instance XXDefaultDecl (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DefaultDecl p) where - ppr (DefaultDecl tys) + ppr (DefaultDecl _ tys) = text "default" <+> parens (interpp'SP tys) + ppr (XDefaultDecl x) = ppr x {- ************************************************************************ @@ -1724,15 +1876,15 @@ type LForeignDecl pass = Located (ForeignDecl pass) -- | Foreign Declaration data ForeignDecl pass = ForeignImport - { fd_name :: Located (IdP pass) -- defines this name + { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- defines this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty , fd_fi :: ForeignImport } | ForeignExport - { fd_name :: Located (IdP pass) -- uses this name + { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- uses this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_co :: PostTc pass Coercion -- rep_ty ~ sig_ty , fd_fe :: ForeignExport } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', @@ -1740,6 +1892,7 @@ data ForeignDecl pass -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation + | XForeignDecl (XXForeignDecl pass) {- In both ForeignImport and ForeignExport: @@ -1750,11 +1903,15 @@ data ForeignDecl pass such as Int and IO that we know how to make foreign calls with. -} -noForeignImportCoercionYet :: PlaceHolder -noForeignImportCoercionYet = placeHolder +type instance XForeignImport GhcPs = NoExt +type instance XForeignImport GhcRn = NoExt +type instance XForeignImport GhcTc = Coercion + +type instance XForeignExport GhcPs = NoExt +type instance XForeignExport GhcRn = NoExt +type instance XForeignExport GhcTc = Coercion -noForeignExportCoercionYet :: PlaceHolder -noForeignExportCoercionYet = placeHolder +type instance XXForeignDecl (GhcPass _) = NoExt -- Specification Of an imported external entity in dependence on the calling -- convention @@ -1809,6 +1966,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) + ppr (XForeignDecl x) = ppr x instance Outputable ForeignImport where ppr (CImport cconv safety mHeader spec (L _ srcText)) = @@ -1855,8 +2013,13 @@ type LRuleDecls pass = Located (RuleDecls pass) -- Note [Pragma source text] in BasicTypes -- | Rule Declarations -data RuleDecls pass = HsRules { rds_src :: SourceText +data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass + , rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } + | XRuleDecls (XXRuleDecls pass) + +type instance XCRuleDecls (GhcPass _) = NoExt +type instance XXRuleDecls (GhcPass _) = NoExt -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) @@ -1864,15 +2027,14 @@ type LRuleDecl pass = Located (RuleDecl pass) -- | Rule Declaration data RuleDecl pass = HsRule -- Source rule + (XHsRule pass) -- After renamer, free-vars from the LHS and RHS (Located (SourceText,RuleName)) -- Rule name -- Note [Pragma source text] in BasicTypes Activation [LRuleBndr pass] -- Forall'd vars; after typechecking this -- includes tyvars (Located (HsExpr pass)) -- LHS - (PostRn pass NameSet) -- Free-vars from the LHS (Located (HsExpr pass)) -- RHS - (PostRn pass NameSet) -- Free-vars from the RHS -- ^ -- - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', @@ -1882,6 +2044,16 @@ data RuleDecl pass -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation + | XRuleDecl (XXRuleDecl pass) + +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data + +type instance XHsRule GhcPs = NoExt +type instance XHsRule GhcRn = HsRuleRn +type instance XHsRule GhcTc = HsRuleRn + +type instance XXRuleDecl (GhcPass _) = NoExt flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls @@ -1891,38 +2063,46 @@ type LRuleBndr pass = Located (RuleBndr pass) -- | Rule Binder data RuleBndr pass - = RuleBndr (Located (IdP pass)) - | RuleBndrSig (Located (IdP pass)) (LHsSigWcType pass) + = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass) + | XRuleBndr (XXRuleBndr pass) -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation +type instance XCRuleBndr (GhcPass _) = NoExt +type instance XRuleBndrSig (GhcPass _) = NoExt +type instance XXRuleBndr (GhcPass _) = NoExt + collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] -collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecls p) where - ppr (HsRules st rules) + ppr (HsRules _ st rules) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" + ppr (XRuleDecls x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where - ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) + ppr (HsRule _ name act ns lhs rhs) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ] where pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot + ppr (XRuleDecl x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where - ppr (RuleBndr name) = ppr name - ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) + ppr (RuleBndr _ name) = ppr name + ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) + ppr (XRuleBndr x) = ppr x {- ************************************************************************ @@ -1947,6 +2127,7 @@ type LVectDecl pass = Located (VectDecl pass) -- | Vectorise Declaration data VectDecl pass = HsVect + (XHsVect pass) SourceText -- Note [Pragma source text] in BasicTypes (Located (IdP pass)) (LHsExpr pass) @@ -1955,88 +2136,104 @@ data VectDecl pass -- For details on above see note [Api annotations] in ApiAnnotation | HsNoVect + (XHsNoVect pass) SourceText -- Note [Pragma source text] in BasicTypes (Located (IdP pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectTypeIn -- pre type-checking - SourceText -- Note [Pragma source text] in BasicTypes + | HsVectType + (XHsVectType pass) Bool -- 'TRUE' => SCALAR declaration + | HsVectClass -- pre type-checking + (XHsVectClass pass) + | HsVectInst -- pre type-checking (always SCALAR) + -- !!!FIXME: should be superfluous now + (XHsVectInst pass) + | XVectDecl (XXVectDecl pass) + +-- Used for XHsVectType for parser and renamer phases +data VectTypePR pass + = VectTypePR + SourceText -- Note [Pragma source text] in BasicTypes (Located (IdP pass)) (Maybe (Located (IdP pass))) -- 'Nothing' => no right-hand side - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnEqual' - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectTypeOut -- post type-checking - Bool -- 'TRUE' => SCALAR declaration +-- Used for XHsVectType +data VectTypeTc + = VectTypeTc TyCon - (Maybe TyCon) -- 'Nothing' => no right-hand side - | HsVectClassIn -- pre type-checking - SourceText -- Note [Pragma source text] in BasicTypes + (Maybe TyCon) -- 'Nothing' => no right-hand side + deriving Data + +-- Used for XHsVectClass for parser and renamer phases +data VectClassPR pass + = VectClassPR + SourceText -- Note [Pragma source text] in BasicTypes (Located (IdP pass)) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsVectClassOut -- post type-checking - Class - | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now - (LHsSigType pass) - | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now - ClsInst - -lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name -lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon -lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectClassOut cls)) = getName cls -lvectDeclName (L _ (HsVectInstIn _)) - = panic "HsDecls.lvectDeclName: HsVectInstIn" -lvectDeclName (L _ (HsVectInstOut _)) - = panic "HsDecls.lvectDeclName: HsVectInstOut" + +type instance XHsVect (GhcPass _) = NoExt +type instance XHsNoVect (GhcPass _) = NoExt + +type instance XHsVectType GhcPs = VectTypePR GhcPs +type instance XHsVectType GhcRn = VectTypePR GhcRn +type instance XHsVectType GhcTc = VectTypeTc + +type instance XHsVectClass GhcPs = VectClassPR GhcPs +type instance XHsVectClass GhcRn = VectClassPR GhcRn +type instance XHsVectClass GhcTc = Class + +type instance XHsVectInst GhcPs = (LHsSigType GhcPs) +type instance XHsVectInst GhcRn = (LHsSigType GhcRn) +type instance XHsVectInst GhcTc = ClsInst + +type instance XXVectDecl (GhcPass _) = NoExt + + +lvectDeclName :: LVectDecl GhcTc -> Name +lvectDeclName (L _ (HsVect _ _ (L _ name) _)) = getName name +lvectDeclName (L _ (HsNoVect _ _ (L _ name))) = getName name +lvectDeclName (L _ (HsVectType (VectTypeTc tycon _) _)) = getName tycon +lvectDeclName (L _ (HsVectClass cls)) = getName cls +lvectDeclName (L _ (HsVectInst {})) + = panic "HsDecls.lvectDeclName: HsVectInst" +lvectDeclName (L _ (XVectDecl {})) + = panic "HsDecls.lvectDeclName: XVectDecl" lvectInstDecl :: LVectDecl pass -> Bool -lvectInstDecl (L _ (HsVectInstIn _)) = True -lvectInstDecl (L _ (HsVectInstOut _)) = True -lvectInstDecl _ = False +lvectInstDecl (L _ (HsVectInst {})) = True +lvectInstDecl _ = False instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (VectDecl p) where - ppr (HsVect _ v rhs) + ppr (HsVect _ _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ pprExpr (unLoc rhs) <+> text "#-}" ] - ppr (HsNoVect _ v) + ppr (HsNoVect _ _ v) = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] - ppr (HsVectTypeIn _ False t Nothing) - = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn _ False t (Just t')) - = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeIn _ True t Nothing) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeIn _ True t (Just t')) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeOut False t Nothing) - = sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeOut False t (Just t')) - = sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectTypeOut True t Nothing) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ] - ppr (HsVectTypeOut True t (Just t')) - = sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ] - ppr (HsVectClassIn _ c) - = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] - ppr (HsVectClassOut c) + ppr (HsVectType x False) + = sep [text "{-# VECTORISE type" <+> ppr x <+> text "#-}" ] + ppr (HsVectType x True) + = sep [text "{-# VECTORISE SCALAR type" <+> ppr x <+> text "#-}" ] + ppr (HsVectClass c) = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] - ppr (HsVectInstIn ty) - = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ] - ppr (HsVectInstOut i) + ppr (HsVectInst i) = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ] + ppr (XVectDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (VectTypePR p) where + ppr (VectTypePR _ n Nothing) = ppr n + ppr (VectTypePR _ n (Just t)) = sep [ppr n, text "=", ppr t] + +instance Outputable VectTypeTc where + ppr (VectTypeTc n Nothing) = ppr n + ppr (VectTypeTc n (Just t)) = sep [ppr n, text "=", ppr t] + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (VectClassPR p) where + ppr (VectClassPR _ n ) = ppr n {- ************************************************************************ @@ -2082,25 +2279,39 @@ type LWarnDecls pass = Located (WarnDecls pass) -- Note [Pragma source text] in BasicTypes -- | Warning pragma Declarations -data WarnDecls pass = Warnings { wd_src :: SourceText +data WarnDecls pass = Warnings { wd_ext :: XWarnings pass + , wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } + | XWarnDecls (XXWarnDecls pass) + +type instance XWarnings (GhcPass _) = NoExt +type instance XXWarnDecls (GhcPass _) = NoExt -- | Located Warning pragma Declaration type LWarnDecl pass = Located (WarnDecl pass) -- | Warning pragma Declaration -data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt +data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt + | XWarnDecl (XXWarnDecl pass) + +type instance XWarning (GhcPass _) = NoExt +type instance XXWarnDecl (GhcPass _) = NoExt -instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where - ppr (Warnings (SourceText src) decls) + +instance (p ~ GhcPass pass,OutputableBndr (IdP p)) + => Outputable (WarnDecls p) where + ppr (Warnings _ (SourceText src) decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" - ppr (Warnings NoSourceText _decls) = panic "WarnDecls" + ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" + ppr (XWarnDecls x) = ppr x -instance OutputableBndr (IdP pass) => Outputable (WarnDecl pass) where - ppr (Warning thing txt) +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (WarnDecl p) where + ppr (Warning _ thing txt) = hsep ( punctuate comma (map ppr thing)) <+> ppr txt + ppr (XWarnDecl x) = ppr x {- ************************************************************************ @@ -2115,6 +2326,7 @@ type LAnnDecl pass = Located (AnnDecl pass) -- | Annotation Declaration data AnnDecl pass = HsAnnotation + (XHsAnnotation pass) SourceText -- Note [Pragma source text] in BasicTypes (AnnProvenance (IdP pass)) (Located (HsExpr pass)) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', @@ -2123,10 +2335,15 @@ data AnnDecl pass = HsAnnotation -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation + | XAnnDecl (XXAnnDecl pass) + +type instance XHsAnnotation (GhcPass _) = NoExt +type instance XXAnnDecl (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where - ppr (HsAnnotation _ provenance expr) + ppr (HsAnnotation _ _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] + ppr (XAnnDecl x) = ppr x -- | Annotation Provenance data AnnProvenance name = ValueAnnProvenance (Located name) @@ -2164,20 +2381,28 @@ type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass) -- top-level declarations -- | Role Annotation Declaration data RoleAnnotDecl pass - = RoleAnnotDecl (Located (IdP pass)) -- type constructor + = RoleAnnotDecl (XCRoleAnnotDecl pass) + (Located (IdP pass)) -- type constructor [Located (Maybe Role)] -- optional annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnRole' -- For details on above see note [Api annotations] in ApiAnnotation + | XRoleAnnotDecl (XXRoleAnnotDecl pass) + +type instance XCRoleAnnotDecl (GhcPass _) = NoExt +type instance XXRoleAnnotDecl (GhcPass _) = NoExt -instance OutputableBndr (IdP pass) => Outputable (RoleAnnotDecl pass) where - ppr (RoleAnnotDecl ltycon roles) +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (RoleAnnotDecl p) where + ppr (RoleAnnotDecl _ ltycon roles) = text "type role" <+> ppr ltycon <+> hsep (map (pp_role . unLoc) roles) where pp_role Nothing = underscore pp_role (Just r) = ppr r + ppr (XRoleAnnotDecl x) = ppr x roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass) -roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name +roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name +roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName" diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 7f6d3f8461..c328cff9eb 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -21,7 +21,6 @@ module HsExpr where -- friends: import GhcPrelude -import PlaceHolder import HsDecls import HsPat import HsLit @@ -83,12 +82,6 @@ type PostTcExpr = HsExpr GhcTc -- than is convenient to keep individually. type PostTcTable = [(Name, PostTcExpr)] -noPostTcExpr :: PostTcExpr -noPostTcExpr = HsLit noExt (HsString NoSourceText (fsLit "noPostTcExpr")) - -noPostTcTable :: PostTcTable -noPostTcTable = [] - ------------------------- -- | Syntax Expression -- @@ -105,7 +98,7 @@ noPostTcTable = [] -- > (syn_arg_wraps[1] arg1) ... -- -- where the actual arguments come from elsewhere in the AST. --- This could be defined using @PostRn@ and @PostTc@ and such, but it's +-- This could be defined using @GhcPass p@ and such, but it's -- harder to get it all to work out that way. ('noSyntaxExpr' is hard to -- write, for example.) data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p @@ -741,105 +734,105 @@ data RecordUpdTc = RecordUpdTc -- --------------------------------------------------------------------- -type instance XVar (GhcPass _) = PlaceHolder -type instance XUnboundVar (GhcPass _) = PlaceHolder -type instance XConLikeOut (GhcPass _) = PlaceHolder -type instance XRecFld (GhcPass _) = PlaceHolder -type instance XOverLabel (GhcPass _) = PlaceHolder -type instance XIPVar (GhcPass _) = PlaceHolder -type instance XOverLitE (GhcPass _) = PlaceHolder -type instance XLitE (GhcPass _) = PlaceHolder -type instance XLam (GhcPass _) = PlaceHolder -type instance XLamCase (GhcPass _) = PlaceHolder -type instance XApp (GhcPass _) = PlaceHolder +type instance XVar (GhcPass _) = NoExt +type instance XUnboundVar (GhcPass _) = NoExt +type instance XConLikeOut (GhcPass _) = NoExt +type instance XRecFld (GhcPass _) = NoExt +type instance XOverLabel (GhcPass _) = NoExt +type instance XIPVar (GhcPass _) = NoExt +type instance XOverLitE (GhcPass _) = NoExt +type instance XLitE (GhcPass _) = NoExt +type instance XLam (GhcPass _) = NoExt +type instance XLamCase (GhcPass _) = NoExt +type instance XApp (GhcPass _) = NoExt type instance XAppTypeE GhcPs = LHsWcType GhcPs type instance XAppTypeE GhcRn = LHsWcType GhcRn type instance XAppTypeE GhcTc = LHsWcType GhcRn -type instance XOpApp GhcPs = PlaceHolder +type instance XOpApp GhcPs = NoExt type instance XOpApp GhcRn = Fixity type instance XOpApp GhcTc = Fixity -type instance XNegApp (GhcPass _) = PlaceHolder -type instance XPar (GhcPass _) = PlaceHolder -type instance XSectionL (GhcPass _) = PlaceHolder -type instance XSectionR (GhcPass _) = PlaceHolder -type instance XExplicitTuple (GhcPass _) = PlaceHolder +type instance XNegApp (GhcPass _) = NoExt +type instance XPar (GhcPass _) = NoExt +type instance XSectionL (GhcPass _) = NoExt +type instance XSectionR (GhcPass _) = NoExt +type instance XExplicitTuple (GhcPass _) = NoExt -type instance XExplicitSum GhcPs = PlaceHolder -type instance XExplicitSum GhcRn = PlaceHolder +type instance XExplicitSum GhcPs = NoExt +type instance XExplicitSum GhcRn = NoExt type instance XExplicitSum GhcTc = [Type] -type instance XCase (GhcPass _) = PlaceHolder -type instance XIf (GhcPass _) = PlaceHolder +type instance XCase (GhcPass _) = NoExt +type instance XIf (GhcPass _) = NoExt -type instance XMultiIf GhcPs = PlaceHolder -type instance XMultiIf GhcRn = PlaceHolder +type instance XMultiIf GhcPs = NoExt +type instance XMultiIf GhcRn = NoExt type instance XMultiIf GhcTc = Type -type instance XLet (GhcPass _) = PlaceHolder +type instance XLet (GhcPass _) = NoExt -type instance XDo GhcPs = PlaceHolder -type instance XDo GhcRn = PlaceHolder +type instance XDo GhcPs = NoExt +type instance XDo GhcRn = NoExt type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = PlaceHolder -type instance XExplicitList GhcRn = PlaceHolder +type instance XExplicitList GhcPs = NoExt +type instance XExplicitList GhcRn = NoExt type instance XExplicitList GhcTc = Type -type instance XExplicitPArr GhcPs = PlaceHolder -type instance XExplicitPArr GhcRn = PlaceHolder +type instance XExplicitPArr GhcPs = NoExt +type instance XExplicitPArr GhcRn = NoExt type instance XExplicitPArr GhcTc = Type -type instance XRecordCon GhcPs = PlaceHolder -type instance XRecordCon GhcRn = PlaceHolder +type instance XRecordCon GhcPs = NoExt +type instance XRecordCon GhcRn = NoExt type instance XRecordCon GhcTc = RecordConTc -type instance XRecordUpd GhcPs = PlaceHolder -type instance XRecordUpd GhcRn = PlaceHolder +type instance XRecordUpd GhcPs = NoExt +type instance XRecordUpd GhcRn = NoExt type instance XRecordUpd GhcTc = RecordUpdTc type instance XExprWithTySig GhcPs = (LHsSigWcType GhcPs) type instance XExprWithTySig GhcRn = (LHsSigWcType GhcRn) type instance XExprWithTySig GhcTc = (LHsSigWcType GhcRn) -type instance XArithSeq GhcPs = PlaceHolder -type instance XArithSeq GhcRn = PlaceHolder +type instance XArithSeq GhcPs = NoExt +type instance XArithSeq GhcRn = NoExt type instance XArithSeq GhcTc = PostTcExpr -type instance XPArrSeq GhcPs = PlaceHolder -type instance XPArrSeq GhcRn = PlaceHolder +type instance XPArrSeq GhcPs = NoExt +type instance XPArrSeq GhcRn = NoExt type instance XPArrSeq GhcTc = PostTcExpr -type instance XSCC (GhcPass _) = PlaceHolder -type instance XCoreAnn (GhcPass _) = PlaceHolder -type instance XBracket (GhcPass _) = PlaceHolder +type instance XSCC (GhcPass _) = NoExt +type instance XCoreAnn (GhcPass _) = NoExt +type instance XBracket (GhcPass _) = NoExt -type instance XRnBracketOut (GhcPass _) = PlaceHolder -type instance XTcBracketOut (GhcPass _) = PlaceHolder +type instance XRnBracketOut (GhcPass _) = NoExt +type instance XTcBracketOut (GhcPass _) = NoExt -type instance XSpliceE (GhcPass _) = PlaceHolder -type instance XProc (GhcPass _) = PlaceHolder +type instance XSpliceE (GhcPass _) = NoExt +type instance XProc (GhcPass _) = NoExt -type instance XStatic GhcPs = PlaceHolder +type instance XStatic GhcPs = NoExt type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = NameSet -type instance XArrApp GhcPs = PlaceHolder -type instance XArrApp GhcRn = PlaceHolder +type instance XArrApp GhcPs = NoExt +type instance XArrApp GhcRn = NoExt type instance XArrApp GhcTc = Type -type instance XArrForm (GhcPass _) = PlaceHolder -type instance XTick (GhcPass _) = PlaceHolder -type instance XBinTick (GhcPass _) = PlaceHolder -type instance XTickPragma (GhcPass _) = PlaceHolder -type instance XEWildPat (GhcPass _) = PlaceHolder -type instance XEAsPat (GhcPass _) = PlaceHolder -type instance XEViewPat (GhcPass _) = PlaceHolder -type instance XELazyPat (GhcPass _) = PlaceHolder -type instance XWrap (GhcPass _) = PlaceHolder -type instance XXExpr (GhcPass _) = PlaceHolder +type instance XArrForm (GhcPass _) = NoExt +type instance XTick (GhcPass _) = NoExt +type instance XBinTick (GhcPass _) = NoExt +type instance XTickPragma (GhcPass _) = NoExt +type instance XEWildPat (GhcPass _) = NoExt +type instance XEAsPat (GhcPass _) = NoExt +type instance XEViewPat (GhcPass _) = NoExt +type instance XELazyPat (GhcPass _) = NoExt +type instance XWrap (GhcPass _) = NoExt +type instance XXExpr (GhcPass _) = NoExt -- --------------------------------------------------------------------- @@ -860,13 +853,13 @@ data HsTupArg id | Missing (XMissing id) -- ^ The argument is missing, but this is its type | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point -type instance XPresent (GhcPass _) = PlaceHolder +type instance XPresent (GhcPass _) = NoExt -type instance XMissing GhcPs = PlaceHolder -type instance XMissing GhcRn = PlaceHolder +type instance XMissing GhcPs = NoExt +type instance XMissing GhcRn = NoExt type instance XMissing GhcTc = Type -type instance XXTupArg (GhcPass _) = PlaceHolder +type instance XXTupArg (GhcPass _) = NoExt tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True @@ -1095,13 +1088,14 @@ ppr_expr (HsIf _ _ e1 e2 e3) ppr_expr (HsMultiIf _ alts) = hang (text "if") 3 (vcat (map ppr_alt alts)) - where ppr_alt (L _ (GRHS guards expr)) = + where ppr_alt (L _ (GRHS _ guards expr)) = hang vbar 2 (ppr_one one_alt) where ppr_one [] = panic "ppr_exp HsMultiIf" ppr_one (h:t) = hang h 2 (sep t) one_alt = [ interpp'SP guards , text "->" <+> pprDeeper (ppr expr) ] + ppr_alt (L _ (XGRHS x)) = ppr x -- special case: let ... in let ... ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) @@ -1402,24 +1396,24 @@ data HsCmd id -- Then (HsCmdWrap wrap cmd) :: arg2 --> res | XCmd (XXCmd id) -- Note [Trees that Grow] extension point -type instance XCmdArrApp GhcPs = PlaceHolder -type instance XCmdArrApp GhcRn = PlaceHolder +type instance XCmdArrApp GhcPs = NoExt +type instance XCmdArrApp GhcRn = NoExt 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 XCmdArrForm (GhcPass _) = NoExt +type instance XCmdApp (GhcPass _) = NoExt +type instance XCmdLam (GhcPass _) = NoExt +type instance XCmdPar (GhcPass _) = NoExt +type instance XCmdCase (GhcPass _) = NoExt +type instance XCmdIf (GhcPass _) = NoExt +type instance XCmdLet (GhcPass _) = NoExt -type instance XCmdDo GhcPs = PlaceHolder -type instance XCmdDo GhcRn = PlaceHolder +type instance XCmdDo GhcPs = NoExt +type instance XCmdDo GhcRn = NoExt type instance XCmdDo GhcTc = Type -type instance XCmdWrap (GhcPass _) = PlaceHolder -type instance XXCmd (GhcPass _) = PlaceHolder +type instance XCmdWrap (GhcPass _) = NoExt +type instance XXCmd (GhcPass _) = NoExt -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1445,11 +1439,11 @@ data CmdTopTc Type -- return type of the command (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] -type instance XCmdTop GhcPs = PlaceHolder +type instance XCmdTop GhcPs = NoExt type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc -type instance XXCmdTop (GhcPass _) = PlaceHolder +type instance XXCmdTop (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where ppr cmd = pprCmd cmd @@ -1580,30 +1574,45 @@ 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 - , mg_res_ty :: PostTc p Type -- Type of the result, tr + = MG { mg_ext :: XMG p body -- Posr typechecker, types of args and result + , mg_alts :: Located [LMatch p body] -- The alternatives , mg_origin :: Origin } -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns + | XMatchGroup (XXMatchGroup p body) + +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + } deriving Data + +type instance XMG GhcPs b = NoExt +type instance XMG GhcRn b = NoExt +type instance XMG GhcTc b = MatchGroupTc + +type instance XXMatchGroup (GhcPass _) b = NoExt -- | Located Match 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 { + m_ext :: XCMatch p body, m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), -- See note [m_ctxt in Match] m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) } + | XMatch (XXMatch p body) + +type instance XCMatch (GhcPass _) b = NoExt +type instance XXMatch (GhcPass _) b = NoExt instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) => Outputable (Match idR body) where @@ -1653,6 +1662,7 @@ isInfixMatch match = case m_ctxt match of isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms +isEmptyMatchGroup (XMatchGroup{}) = panic "isEmptyMatchGroup" -- | Is there only one RHS in this list of matches? isSingletonMatchGroup :: [LMatch id body] -> Bool @@ -1669,9 +1679,11 @@ matchGroupArity :: MatchGroup id body -> Arity matchGroupArity (MG { mg_alts = alts }) | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) | otherwise = panic "matchGroupArity" +matchGroupArity (XMatchGroup{}) = panic "matchGroupArity" hsLMatchPats :: LMatch id body -> [LPat id] hsLMatchPats (L _ (Match { m_pats = pats })) = pats +hsLMatchPats (L _ (XMatch _)) = panic "hsLMatchPats" -- | Guarded Right-Hand Sides -- @@ -1682,21 +1694,29 @@ 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 { + grhssExt :: XCGRHSs p body, grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause } + | XGRHSs (XXGRHSs p body) + +type instance XCGRHSs (GhcPass _) b = NoExt +type instance XXGRHSs (GhcPass _) b = NoExt -- | 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 +data GRHS p body = GRHS (XCGRHS p body) + [GuardLStmt p] -- Guards + body -- Right hand side + | XGRHS (XXGRHS p body) + +type instance XCGRHS (GhcPass _) b = NoExt +type instance XXGRHS (GhcPass _) b = NoExt -- We know the list must have at least one @Match@ in it. @@ -1705,6 +1725,7 @@ pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body) pprMatches MG { mg_alts = matches } = vcat (map pprMatch (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking +pprMatches (XMatchGroup x) = ppr x -- Exported to HsBinds, which can't see the defn of HsMatchContext pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) @@ -1758,21 +1779,24 @@ pprMatch match pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body) => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc -pprGRHSs ctxt (GRHSs grhss (L _ binds)) +pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) -- Print the "where" even if the contents of the binds is empty. Only -- EmptyLocalBinds means no "where" keyword $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) +pprGRHSs _ (XGRHSs x) = ppr x pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body) => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc -pprGRHS ctxt (GRHS [] body) +pprGRHS ctxt (GRHS _ [] body) = pp_rhs ctxt body -pprGRHS ctxt (GRHS guards body) +pprGRHS ctxt (GRHS _ guards body) = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] +pprGRHS _ (XGRHS x) = ppr x + pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) @@ -1830,6 +1854,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, -- and (after the renamer) DoExpr, MDoExpr -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + (XLastStmt idL idR body) body Bool -- True <=> return was stripped by ApplicativeDo (SyntaxExpr idR) -- The return operator, used only for @@ -1841,16 +1866,16 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- 'ApiAnnotation.AnnLarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | BindStmt (LPat idL) + | BindStmt (XBindStmt idL idR body) -- Post typechecking, + -- result type of the function passed to bind; + -- that is, S in (>>=) :: Q -> (R -> S) -> T + (LPat idL) body (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts] (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - (PostTc idR Type) -- result type of the function passed to bind; - -- that is, S in (>>=) :: Q -> (R -> S) -> T - -- | 'ApplicativeStmt' represents an applicative expression built with -- <$> and <*>. It is generated by the renamer, and is desugared into the -- appropriate applicative expression by the desugarer, but it is intended @@ -1859,34 +1884,38 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- For full details, see Note [ApplicativeDo] in RnExpr -- | ApplicativeStmt + (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body [ ( SyntaxExpr idR , ApplicativeArg idL) ] -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] (Maybe (SyntaxExpr idR)) -- 'join', if necessary - (PostTc idR Type) -- Type of the body - | BodyStmt body -- See Note [BodyStmt] + | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type + -- of the RHS (used for arrows) + body -- See Note [BodyStmt] (SyntaxExpr idR) -- The (>>) operator (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp -- See notes [Monad Comprehensions] - (PostTc idR Type) -- Element type of the RHS (used for arrows) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, -- For details on above see note [Api annotations] in ApiAnnotation - | LetStmt (LHsLocalBindsLR idL idR) + | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) -- ParStmts only occur in a list/monad comprehension - | ParStmt [ParStmtBlock idL idR] + | ParStmt (XParStmt idL idR body) -- Post typecheck, + -- S in (>>=) :: Q -> (R -> S) -> T + [ParStmtBlock idL idR] (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions (SyntaxExpr idR) -- The `>>=` operator -- See notes [Monad Comprehensions] - (PostTc idR Type) -- S in (>>=) :: Q -> (R -> S) -> T -- After renaming, the ids are the binders -- bound by the stmts and used after themp | TransStmt { + trS_ext :: XTransStmt idL idR body, -- Post typecheck, + -- R in (>>=) :: Q -> (R -> S) -> T trS_form :: TransForm, trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' -- which generates the tuples to be grouped @@ -1900,7 +1929,6 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for -- the inner monad comprehensions trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator - trS_bind_arg_ty :: PostTc idR Type, -- R in (>>=) :: Q -> (R -> S) -> T trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring -- Only for 'group' forms -- Just a simple HsExpr, because it's @@ -1912,7 +1940,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- For details on above see note [Api annotations] in ApiAnnotation | RecStmt - { recS_stmts :: [LStmtLR idL idR body] + { recS_ext :: XRecStmt idL idR body + , recS_stmts :: [LStmtLR idL idR body] -- The next two fields are only valid after renaming , recS_later_ids :: [IdP idR] @@ -1931,25 +1960,60 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) , recS_bind_fn :: SyntaxExpr idR -- The bind function , recS_ret_fn :: SyntaxExpr idR -- The return function , recS_mfix_fn :: SyntaxExpr idR -- The mfix function - , recS_bind_ty :: PostTc idR Type -- S in (>>=) :: Q -> (R -> S) -> T + } + | XStmtLR (XXStmtLR idL idR body) - -- These fields are only valid after typechecking +-- Extra fields available post typechecking for RecStmt. +data RecStmtTc = + RecStmtTc + { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 - -- with recS_later_ids and recS_rec_ids, - -- and are the expressions that should be - -- returned by the recursion. - -- They may not quite be the Ids themselves, - -- because the Id may be *polymorphic*, but - -- the returned thing has to be *monomorphic*, - -- so they may be type applications - - , recS_ret_ty :: PostTc idR Type -- The type of - -- do { stmts; return (a,b,c) } + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. + -- They may not quite be the Ids themselves, + -- because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*, + -- so they may be type applications + + , recS_ret_ty :: Type -- The type of + -- do { stmts; return (a,b,c) } -- With rebindable syntax the type might not -- be quite as simple as (m (tya, tyb, tyc)). } + +type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt + +type instance XBindStmt (GhcPass _) GhcPs b = NoExt +type instance XBindStmt (GhcPass _) GhcRn b = NoExt +type instance XBindStmt (GhcPass _) GhcTc b = Type + +type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt +type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt +type instance XApplicativeStmt (GhcPass _) GhcTc b = Type + +type instance XBodyStmt (GhcPass _) GhcPs b = NoExt +type instance XBodyStmt (GhcPass _) GhcRn b = NoExt +type instance XBodyStmt (GhcPass _) GhcTc b = Type + +type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt + +type instance XParStmt (GhcPass _) GhcPs b = NoExt +type instance XParStmt (GhcPass _) GhcRn b = NoExt +type instance XParStmt (GhcPass _) GhcTc b = Type + +type instance XTransStmt (GhcPass _) GhcPs b = NoExt +type instance XTransStmt (GhcPass _) GhcRn b = NoExt +type instance XTransStmt (GhcPass _) GhcTc b = Type + +type instance XRecStmt (GhcPass _) GhcPs b = NoExt +type instance XRecStmt (GhcPass _) GhcRn b = NoExt +type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc + +type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt + data TransForm -- The 'f' below is the 'using' function, 'e' is the by function = ThenForm -- then f or then f by e (depending on trS_by) | GroupForm -- then group using f or then group by e using f (depending on trS_by) @@ -1964,12 +2028,13 @@ data ParStmtBlock idL idR (SyntaxExpr idR) -- The return operator | XParStmtBlock (XXParStmtBlock idL idR) -type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder -type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt -- | Applicative Argument data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) + (XApplicativeArgOne idL) (LPat idL) -- WildPat if it was a BodyStmt (see below) (LHsExpr idL) Bool -- True <=> was a BodyStmt @@ -1977,11 +2042,15 @@ data ApplicativeArg idL -- See Note [Applicative BodyStmt] | ApplicativeArgMany -- do { stmts; return vars } + (XApplicativeArgMany idL) [ExprLStmt idL] -- stmts (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) (LPat idL) -- (v1,...,vn) + | XApplicativeArg (XXApplicativeArg idL) --- AZ: May need to bring back idR? +type instance XApplicativeArgOne (GhcPass _) = NoExt +type instance XApplicativeArgMany (GhcPass _) = NoExt +type instance XXApplicativeArg (GhcPass _) = NoExt {- Note [The type of bind in Stmts] @@ -2164,14 +2233,14 @@ pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), Outputable body) => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc -pprStmt (LastStmt expr ret_stripped _) +pprStmt (LastStmt _ expr ret_stripped _) = whenPprDebug (text "[last]") <+> (if ret_stripped then text "return" else empty) <+> ppr expr -pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr] -pprStmt (LetStmt (L _ binds)) = hsep [text "let", pprBinds binds] -pprStmt (BodyStmt expr _ _ _) = ppr expr -pprStmt (ParStmt stmtss _ _ _) = sep (punctuate (text " | ") (map ppr stmtss)) +pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] +pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] +pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by , trS_using = using, trS_form = form }) @@ -2184,7 +2253,7 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids , text "later_ids=" <> ppr later_ids])] -pprStmt (ApplicativeStmt args mb_join _) +pprStmt (ApplicativeStmt _ args mb_join) = getPprStyle $ \style -> if userStyle style then pp_for_user @@ -2199,19 +2268,20 @@ pprStmt (ApplicativeStmt args mb_join _) -- inject a "return" which is hard when we're polymorphic in the id -- type. flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] - flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args + flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args flattenStmt stmt = [ppr stmt] flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] - flattenArg (_, ApplicativeArgOne pat expr isBody) + flattenArg (_, ApplicativeArgOne _ pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] - [ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") + [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL))] | otherwise = - [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") + [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL))] - flattenArg (_, ApplicativeArgMany stmts _ _) = + flattenArg (_, ApplicativeArgMany _ stmts _ _) = concatMap flattenStmt stmts + flattenArg (_, XApplicativeArg _) = panic "flattenArg" pp_debug = let @@ -2222,18 +2292,22 @@ pprStmt (ApplicativeStmt args mb_join _) else text "join" <+> parens ap_expr pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc - pp_arg (_, ApplicativeArgOne pat expr isBody) + pp_arg (_, ApplicativeArgOne _ pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] - ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") + ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) | otherwise = - ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") + ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt (GhcPass idL)) - pp_arg (_, ApplicativeArgMany stmts return pat) = + pp_arg (_, ApplicativeArgMany _ stmts return pat) = ppr pat <+> text "<-" <+> ppr (HsDo (panic "pprStmt") DoExpr (noLoc - (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))) + (stmts ++ + [noLoc (LastStmt noExt (noLoc return) False noSyntaxExpr)]))) + pp_arg (_, XApplicativeArg x) = ppr x + +pprStmt (XStmtLR x) = ppr x pprTransformStmt :: (OutputableBndrId (GhcPass p)) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) @@ -2273,7 +2347,7 @@ ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) pprComp :: (OutputableBndrId (GhcPass p), Outputable body) => [LStmt (GhcPass p) body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn - | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals + | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals = if null initStmts -- If there are no statements in a list comprehension besides the last -- one, we simply treat it like a normal list. This does arise @@ -2330,11 +2404,11 @@ data HsSplice id (HsSplicedThing id) -- The result of splicing | XSplice (XXSplice id) -- Note [Trees that Grow] extension point -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 +type instance XTypedSplice (GhcPass _) = NoExt +type instance XUntypedSplice (GhcPass _) = NoExt +type instance XQuasiQuote (GhcPass _) = NoExt +type instance XSpliced (GhcPass _) = NoExt +type instance XXSplice (GhcPass _) = NoExt -- | 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 @@ -2381,7 +2455,6 @@ type SplicePointName = Name -- | Pending Renamer Splice data PendingRnSplice - -- AZ:TODO: The hard-coded GhcRn feels wrong. How to force the PostRn? = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) data UntypedSpliceFlavour @@ -2393,7 +2466,7 @@ data UntypedSpliceFlavour -- | Pending Type-checker Splice data PendingTcSplice - -- AZ:TODO: The hard-coded GhcTc feels wrong. How to force the PostTc? + -- AZ:TODO: The hard-coded GhcTc feels wrong. = PendingTcSplice SplicePointName (LHsExpr GhcTc) {- @@ -2523,14 +2596,14 @@ data HsBracket p | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] | XBracket (XXBracket p) -- Note [Trees that Grow] extension point -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 +type instance XExpBr (GhcPass _) = NoExt +type instance XPatBr (GhcPass _) = NoExt +type instance XDecBrL (GhcPass _) = NoExt +type instance XDecBrG (GhcPass _) = NoExt +type instance XTypBr (GhcPass _) = NoExt +type instance XVarBr (GhcPass _) = NoExt +type instance XTExpBr (GhcPass _) = NoExt +type instance XXBracket (GhcPass _) = NoExt isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True @@ -2822,7 +2895,7 @@ pprStmtInCtxt :: (OutputableBndrId (GhcPass idL), => HsStmtContext (IdP (GhcPass idL)) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc -pprStmtInCtxt ctxt (LastStmt e _ _) +pprStmtInCtxt ctxt (LastStmt _ e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (text "In the expression:") 2 (ppr e) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index 49ae108546..109e9814e5 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -17,8 +17,8 @@ import HsExtension ( OutputableBndrId, GhcPass ) type role HsExpr nominal type role HsCmd nominal -type role MatchGroup nominal representational -type role GRHSs nominal representational +type role MatchGroup nominal nominal +type role GRHSs nominal nominal type role HsSplice nominal type role SyntaxExpr nominal data HsExpr (i :: *) diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 81ffd05d78..4545b2b0cb 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -21,17 +21,11 @@ import GhcPrelude import GHC.Exts (Constraint) import Data.Data hiding ( Fixity ) import PlaceHolder -import BasicTypes -import ConLike -import NameSet import Name import RdrName import Var -import Type ( Type ) import Outputable import SrcLoc (Located) -import Coercion -import TcEvidence {- Note [Trees that grow] @@ -58,9 +52,16 @@ haskell-src-exts ASTs as well. -} +-- | used as place holder in TTG values +data NoExt = NoExt + deriving (Data,Eq,Ord) + +instance Outputable NoExt where + ppr _ = text "NoExt" + -- | Used when constructing a term with an unused extension point. -noExt :: PlaceHolder -noExt = PlaceHolder +noExt :: NoExt +noExt = NoExt -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) @@ -76,19 +77,6 @@ type GhcRn = GhcPass 'Renamed -- Old 'Name' type param type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, type GhcTcId = GhcTc -- Old 'TcId' type param - --- | Types that are not defined until after type checking -type family PostTc x ty -- Note [Pass sensitive types] in PlaceHolder -type instance PostTc GhcPs ty = PlaceHolder -type instance PostTc GhcRn ty = PlaceHolder -type instance PostTc GhcTc ty = ty - --- | Types that are not defined until after renaming -type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder -type instance PostRn GhcPs ty = PlaceHolder -type instance PostRn GhcRn ty = ty -type instance PostRn GhcTc ty = ty - -- | Maps the "normal" id type for a given pass type family IdP p type instance IdP GhcPs = RdrName @@ -217,8 +205,300 @@ type ForallXFixitySig (c :: * -> Constraint) (x :: *) = -- ===================================================================== -- Type families for the HsDecls extension points +-- HsDecl type families +type family XTyClD x +type family XInstD x +type family XDerivD x +type family XValD x +type family XSigD x +type family XDefD x +type family XForD x +type family XWarningD x +type family XAnnD x +type family XRuleD x +type family XVectD x +type family XSpliceD x +type family XDocD x +type family XRoleAnnotD x +type family XXHsDecl x + +type ForallXHsDecl (c :: * -> Constraint) (x :: *) = + ( c (XTyClD x) + , c (XInstD x) + , c (XDerivD x) + , c (XValD x) + , c (XSigD x) + , c (XDefD x) + , c (XForD x) + , c (XWarningD x) + , c (XAnnD x) + , c (XRuleD x) + , c (XVectD x) + , c (XSpliceD x) + , c (XDocD x) + , c (XRoleAnnotD x) + , c (XXHsDecl x) + ) --- TODO +-- ------------------------------------- +-- HsGroup type families +type family XCHsGroup x +type family XXHsGroup x + +type ForallXHsGroup (c :: * -> Constraint) (x :: *) = + ( c (XCHsGroup x) + , c (XXHsGroup x) + ) + +-- ------------------------------------- +-- SpliceDecl type families +type family XSpliceDecl x +type family XXSpliceDecl x + +type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) = + ( c (XSpliceDecl x) + , c (XXSpliceDecl x) + ) + +-- ------------------------------------- +-- TyClDecl type families +type family XFamDecl x +type family XSynDecl x +type family XDataDecl x +type family XClassDecl x +type family XXTyClDecl x + +type ForallXTyClDecl (c :: * -> Constraint) (x :: *) = + ( c (XFamDecl x) + , c (XSynDecl x) + , c (XDataDecl x) + , c (XClassDecl x) + , c (XXTyClDecl x) + ) + +-- ------------------------------------- +-- TyClGroup type families +type family XCTyClGroup x +type family XXTyClGroup x + +type ForallXTyClGroup (c :: * -> Constraint) (x :: *) = + ( c (XCTyClGroup x) + , c (XXTyClGroup x) + ) + +-- ------------------------------------- +-- FamilyResultSig type families +type family XNoSig x +type family XCKindSig x -- Clashes with XKindSig above +type family XTyVarSig x +type family XXFamilyResultSig x + +type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) = + ( c (XNoSig x) + , c (XCKindSig x) + , c (XTyVarSig x) + , c (XXFamilyResultSig x) + ) + +-- ------------------------------------- +-- FamilyDecl type families +type family XCFamilyDecl x +type family XXFamilyDecl x + +type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) = + ( c (XCFamilyDecl x) + , c (XXFamilyDecl x) + ) + +-- ------------------------------------- +-- HsDataDefn type families +type family XCHsDataDefn x +type family XXHsDataDefn x + +type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) = + ( c (XCHsDataDefn x) + , c (XXHsDataDefn x) + ) + +-- ------------------------------------- +-- HsDerivingClause type families +type family XCHsDerivingClause x +type family XXHsDerivingClause x + +type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) = + ( c (XCHsDerivingClause x) + , c (XXHsDerivingClause x) + ) + +-- ------------------------------------- +-- ConDecl type families +type family XConDeclGADT x +type family XConDeclH98 x +type family XXConDecl x + +type ForallXConDecl (c :: * -> Constraint) (x :: *) = + ( c (XConDeclGADT x) + , c (XConDeclH98 x) + , c (XXConDecl x) + ) + +-- ------------------------------------- +-- FamEqn type families +type family XCFamEqn x p r +type family XXFamEqn x p r + +type ForallXFamEqn (c :: * -> Constraint) (x :: *) (p :: *) (r :: *) = + ( c (XCFamEqn x p r) + , c (XXFamEqn x p r) + ) + +-- ------------------------------------- +-- ClsInstDecl type families +type family XCClsInstDecl x +type family XXClsInstDecl x + +type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) = + ( c (XCClsInstDecl x) + , c (XXClsInstDecl x) + ) + +-- ------------------------------------- +-- ClsInstDecl type families +type family XClsInstD x +type family XDataFamInstD x +type family XTyFamInstD x +type family XXInstDecl x + +type ForallXInstDecl (c :: * -> Constraint) (x :: *) = + ( c (XClsInstD x) + , c (XDataFamInstD x) + , c (XTyFamInstD x) + , c (XXInstDecl x) + ) + +-- ------------------------------------- +-- DerivDecl type families +type family XCDerivDecl x +type family XXDerivDecl x + +type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = + ( c (XCDerivDecl x) + , c (XXDerivDecl x) + ) + +-- ------------------------------------- +-- DefaultDecl type families +type family XCDefaultDecl x +type family XXDefaultDecl x + +type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) = + ( c (XCDefaultDecl x) + , c (XXDefaultDecl x) + ) + +-- ------------------------------------- +-- DefaultDecl type families +type family XForeignImport x +type family XForeignExport x +type family XXForeignDecl x + +type ForallXForeignDecl (c :: * -> Constraint) (x :: *) = + ( c (XForeignImport x) + , c (XForeignExport x) + , c (XXForeignDecl x) + ) + +-- ------------------------------------- +-- RuleDecls type families +type family XCRuleDecls x +type family XXRuleDecls x + +type ForallXRuleDecls (c :: * -> Constraint) (x :: *) = + ( c (XCRuleDecls x) + , c (XXRuleDecls x) + ) + + +-- ------------------------------------- +-- RuleDecl type families +type family XHsRule x +type family XXRuleDecl x + +type ForallXRuleDecl (c :: * -> Constraint) (x :: *) = + ( c (XHsRule x) + , c (XXRuleDecl x) + ) + +-- ------------------------------------- +-- RuleBndr type families +type family XCRuleBndr x +type family XRuleBndrSig x +type family XXRuleBndr x + +type ForallXRuleBndr (c :: * -> Constraint) (x :: *) = + ( c (XCRuleBndr x) + , c (XRuleBndrSig x) + , c (XXRuleBndr x) + ) + +-- ------------------------------------- +-- RuleBndr type families +type family XHsVect x +type family XHsNoVect x +type family XHsVectType x +type family XHsVectClass x +type family XHsVectInst x +type family XXVectDecl x + +type ForallXVectDecl (c :: * -> Constraint) (x :: *) = + ( c (XHsVect x) + , c (XHsNoVect x) + , c (XHsVectType x) + , c (XHsVectClass x) + , c (XHsVectInst x) + , c (XXVectDecl x) + , c (XXVectDecl x) + ) + +-- ------------------------------------- +-- WarnDecls type families +type family XWarnings x +type family XXWarnDecls x + +type ForallXWarnDecls (c :: * -> Constraint) (x :: *) = + ( c (XWarnings x) + , c (XXWarnDecls x) + ) + +-- ------------------------------------- +-- AnnDecl type families +type family XWarning x +type family XXWarnDecl x + +type ForallXWarnDecl (c :: * -> Constraint) (x :: *) = + ( c (XWarning x) + , c (XXWarnDecl x) + ) + +-- ------------------------------------- +-- AnnDecl type families +type family XHsAnnotation x +type family XXAnnDecl x + +type ForallXAnnDecl (c :: * -> Constraint) (x :: *) = + ( c (XHsAnnotation x) + , c (XXAnnDecl x) + ) + +-- ------------------------------------- +-- RoleAnnotDecl type families +type family XCRoleAnnotDecl x +type family XXRoleAnnotDecl x + +type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) = + ( c (XCRoleAnnotDecl x) + , c (XXRoleAnnotDecl x) + ) -- ===================================================================== -- Type families for the HsExpr extension points @@ -398,6 +678,70 @@ type ForallXCmdTop (c :: * -> Constraint) (x :: *) = , c (XXCmdTop x) ) +-- ------------------------------------- + +type family XMG x b +type family XXMatchGroup x b + +type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XMG x b) + , c (XXMatchGroup x b) + ) + +-- ------------------------------------- + +type family XCMatch x b +type family XXMatch x b + +type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCMatch x b) + , c (XXMatch x b) + ) + +-- ------------------------------------- + +type family XCGRHSs x b +type family XXGRHSs x b + +type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCGRHSs x b) + , c (XXGRHSs x b) + ) + +-- ------------------------------------- + +type family XCGRHS x b +type family XXGRHS x b + +type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCGRHS x b) + , c (XXGRHS x b) + ) + +-- ------------------------------------- + +type family XLastStmt x x' b +type family XBindStmt x x' b +type family XApplicativeStmt x x' b +type family XBodyStmt x x' b +type family XLetStmt x x' b +type family XParStmt x x' b +type family XTransStmt x x' b +type family XRecStmt x x' b +type family XXStmtLR x x' b + +type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) = + ( c (XLastStmt x x' b) + , c (XBindStmt x x' b) + , c (XApplicativeStmt x x' b) + , c (XBodyStmt x x' b) + , c (XLetStmt x x' b) + , c (XParStmt x x' b) + , c (XTransStmt x x' b) + , c (XRecStmt x x' b) + , c (XXStmtLR x x' b) + ) + -- --------------------------------------------------------------------- type family XCmdArrApp x @@ -436,6 +780,18 @@ type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = , c (XXParStmtBlock x x') ) +-- --------------------------------------------------------------------- + +type family XApplicativeArgOne x +type family XApplicativeArgMany x +type family XXApplicativeArg x + +type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) = + ( c (XApplicativeArgOne x) + , c (XApplicativeArgMany x) + , c (XXApplicativeArg x) + ) + -- ===================================================================== -- Type families for the HsImpExp extension points @@ -536,6 +892,36 @@ type ForallXPat (c :: * -> Constraint) (x :: *) = -- ===================================================================== -- Type families for the HsTypes type families +type family XHsQTvs x +type family XXLHsQTyVars x + +type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) = + ( c (XHsQTvs x) + , c (XXLHsQTyVars x) + ) + +-- ------------------------------------- + +type family XHsIB x b +type family XXHsImplicitBndrs x b + +type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XHsIB x b) + , c (XXHsImplicitBndrs x b) + ) + +-- ------------------------------------- + +type family XHsWC x b +type family XXHsWildCardBndrs x b + +type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XHsWC x b) + , c (XXHsWildCardBndrs x b) + ) + +-- ------------------------------------- + type family XForAllTy x type family XQualTy x type family XTyVar x @@ -616,6 +1002,16 @@ type ForallXAppType (c :: * -> Constraint) (x :: *) = -- --------------------------------------------------------------------- +type family XConDeclField x +type family XXConDeclField x + +type ForallXConDeclField (c :: * -> Constraint) (x :: *) = + ( c (XConDeclField x) + , c (XXConDeclField x) + ) + +-- --------------------------------------------------------------------- + type family XFieldOcc x type family XXFieldOcc x @@ -626,6 +1022,44 @@ type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = -- ===================================================================== +-- Type families for the HsImpExp type families + +type family XCImportDecl x +type family XXImportDecl x + +type ForallXImportDecl (c :: * -> Constraint) (x :: *) = + ( c (XCImportDecl x) + , c (XXImportDecl x) + ) + +-- ------------------------------------- + +type family XIEVar x +type family XIEThingAbs x +type family XIEThingAll x +type family XIEThingWith x +type family XIEModuleContents x +type family XIEGroup x +type family XIEDoc x +type family XIEDocNamed x +type family XXIE x + +type ForallXIE (c :: * -> Constraint) (x :: *) = + ( c (XIEVar x) + , c (XIEThingAbs x) + , c (XIEThingAll x) + , c (XIEThingWith x) + , c (XIEModuleContents x) + , c (XIEGroup x) + , c (XIEDoc x) + , c (XIEDocNamed x) + , c (XXIE x) + ) + +-- ------------------------------------- + + +-- ===================================================================== -- End of Type family definitions -- ===================================================================== @@ -661,29 +1095,34 @@ type ConvertIdX a b = -- ---------------------------------------------------------------------- +-- Note [OutputableX] +-- ~~~~~~~~~~~~~~~~~~ +-- +-- is required because the type family resolution +-- process cannot determine that all cases are handled for a `GhcPass p` +-- case where the cases are listed separately. +-- +-- So +-- +-- type instance XXHsIPBinds (GhcPass p) = NoExt +-- +-- will correctly deduce Outputable for (GhcPass p), but +-- +-- type instance XIPBinds GhcPs = NoExt +-- type instance XIPBinds GhcRn = NoExt +-- type instance XIPBinds GhcTc = TcEvBinds +-- +-- will not. + + -- | Provide a summary constraint that gives all am Outputable constraint to -- extension points needing one -type OutputableX p = - ( Outputable (XXPat p) - , Outputable (XXPat GhcRn) - - , Outputable (XSigPat p) +type OutputableX p = -- See Note [OutputableX] + ( + Outputable (XSigPat p) , Outputable (XSigPat GhcRn) - , Outputable (XXLit p) - - , Outputable (XXOverLit p) - - , Outputable (XXType p) - - , Outputable (XXABExport p) - , Outputable (XIPBinds p) - , Outputable (XXHsIPBinds p) - , Outputable (XXIPBind p) - , Outputable (XXIPBind GhcRn) - , Outputable (XXSig p) - , Outputable (XXFixitySig p) , Outputable (XExprWithTySig p) , Outputable (XExprWithTySig GhcRn) @@ -691,95 +1130,19 @@ type OutputableX p = , Outputable (XAppTypeE p) , Outputable (XAppTypeE GhcRn) - -- , Outputable (XXParStmtBlock (GhcPass idL) idR) - ) --- TODO: Should OutputableX be included in OutputableBndrId? - --- ---------------------------------------------------------------------- - --- -type DataId p = - ( Data p - - , ForallXHsLit Data p - , ForallXPat Data p - - -- 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 - , ForallXTyVarBndr Data p - , ForallXAppType Data p - , ForallXFieldOcc Data p - , ForallXAmbiguousFieldOcc Data p - - , ForallXExpr Data p - , ForallXTupArg Data p - , ForallXSplice Data p - , ForallXBracket Data p - , ForallXCmdTop Data p - , ForallXCmd Data p - , ForallXABExport Data p - , ForallXHsIPBinds Data p - , ForallXIPBind Data p - , ForallXSig Data p - , ForallXFixitySig Data p - - , Data (NameOrRdrName (IdP p)) - - , Data (IdP p) - , Data (PostRn p (IdP p)) - , Data (PostRn p (Located Name)) - , Data (PostRn p Bool) - , Data (PostRn p Fixity) - , Data (PostRn p NameSet) - , Data (PostRn p [Name]) - - , Data (PostTc p (IdP p)) - , Data (PostTc p Coercion) - , Data (PostTc p ConLike) - , Data (PostTc p HsWrapper) - , Data (PostTc p Type) - , Data (PostTc p [ConLike]) - , Data (PostTc p [Type]) - ) - -type DataIdLR pL pR = - ( DataId pL - , DataId pR - - , ForallXHsLocalBindsLR Data pL pR - , ForallXHsLocalBindsLR Data pL pL - , ForallXHsLocalBindsLR Data pR pR - - , ForallXValBindsLR Data pL pR - , ForallXValBindsLR Data pL pL - , ForallXValBindsLR Data pR pR + , Outputable (XHsVectType p) + , Outputable (XHsVectType GhcRn) - , ForallXHsBindsLR Data pL pR - , ForallXHsBindsLR Data pL pL - , ForallXHsBindsLR Data pR pR + , Outputable (XHsVectClass p) + , Outputable (XHsVectClass GhcRn) - , ForallXPatSynBind Data pL pR - , ForallXPatSynBind Data pL pL - , ForallXPatSynBind Data pR pR - -- , ForallXPatSynBind Data GhcPs GhcRn - -- , ForallXPatSynBind Data GhcRn GhcRn + , Outputable (XHsVectInst p) + , Outputable (XHsVectInst GhcRn) - , ForallXParStmtBlock Data pL pR - , ForallXParStmtBlock Data pL pL - , ForallXParStmtBlock Data pR pR - - , ForallXParStmtBlock Data GhcRn GhcRn ) +-- TODO: Should OutputableX be included in OutputableBndrId? + +-- ---------------------------------------------------------------------- -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @id@ and the 'NameOrRdrName' type for it diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index 2930b51ee2..6f38ba31c7 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -9,6 +9,7 @@ HsImpExp: Abstract syntax: imports, exports, interfaces {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder @@ -50,8 +51,9 @@ type LImportDecl name = Located (ImportDecl name) -- | Import Declaration -- -- A single Haskell @import@ declaration. -data ImportDecl name +data ImportDecl pass = ImportDecl { + ideclExt :: XCImportDecl pass, ideclSourceSrc :: SourceText, -- Note [Pragma source text] in BasicTypes ideclName :: Located ModuleName, -- ^ Module name. @@ -61,9 +63,10 @@ data ImportDecl name ideclQualified :: Bool, -- ^ True => qualified ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) ideclAs :: Maybe (Located ModuleName), -- ^ as Module - ideclHiding :: Maybe (Bool, Located [LIE name]) + ideclHiding :: Maybe (Bool, Located [LIE pass]) -- ^ (True => hiding, names) } + | XImportDecl (XXImportDecl pass) -- ^ -- 'ApiAnnotation.AnnKeywordId's -- @@ -80,10 +83,13 @@ data ImportDecl name -- to location in ideclHiding -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (ImportDecl name) -simpleImportDecl :: ModuleName -> ImportDecl name +type instance XCImportDecl (GhcPass _) = NoExt +type instance XXImportDecl (GhcPass _) = NoExt + +simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) simpleImportDecl mn = ImportDecl { + ideclExt = noExt, ideclSourceSrc = NoSourceText, ideclName = noLoc mn, ideclPkgQual = Nothing, @@ -95,7 +101,8 @@ simpleImportDecl mn = ImportDecl { ideclHiding = Nothing } -instance (OutputableBndrId pass) => Outputable (ImportDecl pass) where +instance (p ~ GhcPass pass,OutputableBndrId p) + => Outputable (ImportDecl p) where ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe @@ -132,6 +139,7 @@ instance (OutputableBndrId pass) => Outputable (ImportDecl pass) where ppr_ies [] = text "()" ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' + ppr (XImportDecl x) = ppr x {- ************************************************************************ @@ -166,11 +174,11 @@ type LIE name = Located (IE name) -- For details on above see note [Api annotations] in ApiAnnotation -- | Imported or exported entity. -data IE name - = IEVar (LIEWrappedName (IdP name)) +data IE pass + = IEVar (XIEVar pass) (LIEWrappedName (IdP pass)) -- ^ Imported or Exported Variable - | IEThingAbs (LIEWrappedName (IdP name)) + | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass)) -- ^ Imported or exported Thing with Absent list -- -- The thing is a Class/Type (can't tell) @@ -179,7 +187,7 @@ data IE name -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in HsExpr - | IEThingAll (LIEWrappedName (IdP name)) + | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass)) -- ^ Imported or exported Thing with All imported or exported -- -- The thing is a Class/Type and the All refers to methods/constructors @@ -191,10 +199,11 @@ data IE name -- For details on above see note [Api annotations] in ApiAnnotation -- See Note [Located RdrNames] in HsExpr - | IEThingWith (LIEWrappedName (IdP name)) + | IEThingWith (XIEThingWith pass) + (LIEWrappedName (IdP pass)) IEWildcard - [LIEWrappedName (IdP name)] - [Located (FieldLbl (IdP name))] + [LIEWrappedName (IdP pass)] + [Located (FieldLbl (IdP pass))] -- ^ Imported or exported Thing With given imported or exported -- -- The thing is a Class/Type and the imported or exported things are @@ -205,7 +214,7 @@ data IE name -- 'ApiAnnotation.AnnType' -- For details on above see note [Api annotations] in ApiAnnotation - | IEModuleContents (Located ModuleName) + | IEModuleContents (XIEModuleContents pass) (Located ModuleName) -- ^ Imported or exported module contents -- -- (Export Only) @@ -213,12 +222,20 @@ data IE name -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' -- For details on above see note [Api annotations] in ApiAnnotation - | IEGroup Int HsDocString -- ^ Doc section heading - | IEDoc HsDocString -- ^ Some documentation - | IEDocNamed String -- ^ Reference to named doc - -- deriving (Eq, Data) -deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) -deriving instance (DataId name) => Data (IE name) + | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading + | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation + | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc + | XIE (XXIE pass) + +type instance XIEVar (GhcPass _) = NoExt +type instance XIEThingAbs (GhcPass _) = NoExt +type instance XIEThingAll (GhcPass _) = NoExt +type instance XIEThingWith (GhcPass _) = NoExt +type instance XIEModuleContents (GhcPass _) = NoExt +type instance XIEGroup (GhcPass _) = NoExt +type instance XIEDoc (GhcPass _) = NoExt +type instance XIEDocNamed (GhcPass _) = NoExt +type instance XXIE (GhcPass _) = NoExt -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) @@ -241,22 +258,23 @@ See Note [Representing fields in AvailInfo] in Avail for more details. -} ieName :: IE pass -> IdP pass -ieName (IEVar (L _ n)) = ieWrappedName n -ieName (IEThingAbs (L _ n)) = ieWrappedName n -ieName (IEThingWith (L _ n) _ _ _) = ieWrappedName n -ieName (IEThingAll (L _ n)) = ieWrappedName n +ieName (IEVar _ (L _ n)) = ieWrappedName n +ieName (IEThingAbs _ (L _ n)) = ieWrappedName n +ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n +ieName (IEThingAll _ (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" ieNames :: IE pass -> [IdP pass] -ieNames (IEVar (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAbs (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAll (L _ n) ) = [ieWrappedName n] -ieNames (IEThingWith (L _ n) _ ns _) = ieWrappedName n +ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns -ieNames (IEModuleContents _ ) = [] -ieNames (IEGroup _ _ ) = [] -ieNames (IEDoc _ ) = [] -ieNames (IEDocNamed _ ) = [] +ieNames (IEModuleContents {}) = [] +ieNames (IEGroup {}) = [] +ieNames (IEDoc {}) = [] +ieNames (IEDocNamed {}) = [] +ieNames (XIE {}) = panic "ieNames" ieWrappedName :: IEWrappedName name -> name ieWrappedName (IEName (L _ n)) = n @@ -274,11 +292,11 @@ replaceWrappedName (IEType (L l _)) n = IEType (L l n) replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') -instance (OutputableBndrId pass) => Outputable (IE pass) where - ppr (IEVar var) = ppr (unLoc var) - ppr (IEThingAbs thing) = ppr (unLoc thing) - ppr (IEThingAll thing) = hcat [ppr (unLoc thing), text "(..)"] - ppr (IEThingWith thing wc withs flds) +instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where + ppr (IEVar _ var) = ppr (unLoc var) + ppr (IEThingAbs _ thing) = ppr (unLoc thing) + ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] + ppr (IEThingWith _ thing wc withs flds) = ppr (unLoc thing) <> parens (fsep (punctuate comma (ppWiths ++ map (ppr . flLabel . unLoc) flds))) @@ -290,11 +308,12 @@ instance (OutputableBndrId pass) => Outputable (IE pass) where IEWildcard pos -> let (bs, as) = splitAt pos (map (ppr . unLoc) withs) in bs ++ [text ".."] ++ as - ppr (IEModuleContents mod') + ppr (IEModuleContents _ mod') = text "module" <+> ppr mod' - ppr (IEGroup n _) = text ("<IEGroup: " ++ show n ++ ">") - ppr (IEDoc doc) = ppr doc - ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">") + ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">") + ppr (IEDoc _ doc) = ppr doc + ppr (IEDocNamed _ string) = text ("<IEDocNamed: " ++ string ++ ">") + ppr (XIE x) = ppr x instance (HasOccName name) => HasOccName (IEWrappedName name) where occName w = occName (ieWrappedName w) diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs index 1059cb1e0e..5833e17ff1 100644 --- a/compiler/hsSyn/HsInstances.hs +++ b/compiler/hsSyn/HsInstances.hs @@ -16,6 +16,7 @@ module HsInstances where import Data.Data hiding ( Fixity ) +import GhcPrelude import HsExtension import HsBinds import HsDecls @@ -23,6 +24,7 @@ import HsExpr import HsLit import HsTypes import HsPat +import HsImpExp -- --------------------------------------------------------------------- -- Data derivations from HsSyn ----------------------------------------- @@ -212,6 +214,11 @@ deriving instance Data (VectDecl GhcPs) deriving instance Data (VectDecl GhcRn) deriving instance Data (VectDecl GhcTc) +deriving instance Data (VectTypePR GhcPs) +deriving instance Data (VectTypePR GhcRn) +deriving instance Data (VectClassPR GhcPs) +deriving instance Data (VectClassPR GhcRn) + -- deriving instance (DataId p) => Data (WarnDecls p) deriving instance Data (WarnDecls GhcPs) deriving instance Data (WarnDecls GhcRn) @@ -286,6 +293,8 @@ deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) +deriving instance Data RecStmtTc + -- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) deriving instance Data (ParStmtBlock GhcPs GhcPs) deriving instance Data (ParStmtBlock GhcPs GhcRn) @@ -343,6 +352,8 @@ deriving instance Data (Pat GhcPs) deriving instance Data (Pat GhcRn) deriving instance Data (Pat GhcTc) +deriving instance Data ListPatTc + -- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) deriving instance (Data body) => Data (HsRecFields GhcPs body) deriving instance (Data body) => Data (HsRecFields GhcRn body) @@ -376,11 +387,6 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) --- deriving instance (DataId p) => Data (HsWildCardInfo p) -deriving instance Data (HsWildCardInfo GhcPs) -deriving instance Data (HsWildCardInfo GhcRn) -deriving instance Data (HsWildCardInfo GhcTc) - -- deriving instance (DataIdLR p p) => Data (HsAppType p) deriving instance Data (HsAppType GhcPs) deriving instance Data (HsAppType GhcRn) @@ -402,4 +408,19 @@ deriving instance Data (AmbiguousFieldOcc GhcRn) deriving instance Data (AmbiguousFieldOcc GhcTc) +-- deriving instance (DataId name) => Data (ImportDecl name) +deriving instance Data (ImportDecl GhcPs) +deriving instance Data (ImportDecl GhcRn) +deriving instance Data (ImportDecl GhcTc) + +-- deriving instance (DataId name) => Data (IE name) +deriving instance Data (IE GhcPs) +deriving instance Data (IE GhcRn) +deriving instance Data (IE GhcTc) + +-- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) +deriving instance Eq (IE GhcPs) +deriving instance Eq (IE GhcRn) +deriving instance Eq (IE GhcTc) + -- --------------------------------------------------------------------- diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 1a38296e5d..9a184b7afa 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -27,7 +27,6 @@ import Type ( Type ) import Outputable import FastString import HsExtension -import PlaceHolder import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -83,16 +82,16 @@ type instance XHsChar (GhcPass _) = SourceText type instance XHsCharPrim (GhcPass _) = SourceText type instance XHsString (GhcPass _) = SourceText type instance XHsStringPrim (GhcPass _) = SourceText -type instance XHsInt (GhcPass _) = PlaceHolder +type instance XHsInt (GhcPass _) = NoExt type instance XHsIntPrim (GhcPass _) = SourceText type instance XHsWordPrim (GhcPass _) = SourceText type instance XHsInt64Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText type instance XHsInteger (GhcPass _) = SourceText -type instance XHsRat (GhcPass _) = PlaceHolder -type instance XHsFloatPrim (GhcPass _) = PlaceHolder -type instance XHsDoublePrim (GhcPass _) = PlaceHolder -type instance XXLit (GhcPass _) = PlaceHolder +type instance XHsRat (GhcPass _) = NoExt +type instance XHsFloatPrim (GhcPass _) = NoExt +type instance XHsDoublePrim (GhcPass _) = NoExt +type instance XXLit (GhcPass _) = NoExt instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 @@ -126,11 +125,11 @@ data OverLitTc ol_type :: Type } deriving Data -type instance XOverLit GhcPs = PlaceHolder +type instance XOverLit GhcPs = NoExt type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] type instance XOverLit GhcTc = OverLitTc -type instance XXOverLit (GhcPass _) = PlaceHolder +type instance XXOverLit (GhcPass _) = NoExt -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 5732c3d512..d589882de3 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -18,6 +18,7 @@ module HsPat ( Pat(..), InPat, OutPat, LPat, + ListPatTc(..), HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', @@ -50,7 +51,6 @@ import HsExtension import HsTypes import TcEvidence import BasicTypes -import PlaceHolder -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn @@ -117,8 +117,6 @@ data Pat p ------------ Lists, tuples, arrays --------------- | ListPat (XListPat p) [LPat p] - (PostTc p Type) -- The type of the elements - (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax -- For OverloadedLists a Just (ty,fn) gives -- overall type of the pattern, and the toList -- function to convert the scrutinee to a list value @@ -282,54 +280,61 @@ data Pat p -- --------------------------------------------------------------------- -type instance XWildPat GhcPs = PlaceHolder -type instance XWildPat GhcRn = PlaceHolder +data ListPatTc + = ListPatTc + Type -- The type of the elements + (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax + +type instance XWildPat GhcPs = NoExt +type instance XWildPat GhcRn = NoExt type instance XWildPat GhcTc = Type -type instance XVarPat (GhcPass _) = PlaceHolder -type instance XLazyPat (GhcPass _) = PlaceHolder -type instance XAsPat (GhcPass _) = PlaceHolder -type instance XParPat (GhcPass _) = PlaceHolder -type instance XBangPat (GhcPass _) = PlaceHolder +type instance XVarPat (GhcPass _) = NoExt +type instance XLazyPat (GhcPass _) = NoExt +type instance XAsPat (GhcPass _) = NoExt +type instance XParPat (GhcPass _) = NoExt +type instance XBangPat (GhcPass _) = NoExt -- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap -- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for -- `SyntaxExpr` -type instance XListPat (GhcPass _) = PlaceHolder +type instance XListPat GhcPs = NoExt +type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) +type instance XListPat GhcTc = ListPatTc -type instance XTuplePat GhcPs = PlaceHolder -type instance XTuplePat GhcRn = PlaceHolder +type instance XTuplePat GhcPs = NoExt +type instance XTuplePat GhcRn = NoExt type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = PlaceHolder -type instance XSumPat GhcRn = PlaceHolder +type instance XSumPat GhcPs = NoExt +type instance XSumPat GhcRn = NoExt type instance XSumPat GhcTc = [Type] -type instance XPArrPat GhcPs = PlaceHolder -type instance XPArrPat GhcRn = PlaceHolder +type instance XPArrPat GhcPs = NoExt +type instance XPArrPat GhcRn = NoExt type instance XPArrPat GhcTc = Type -type instance XViewPat GhcPs = PlaceHolder -type instance XViewPat GhcRn = PlaceHolder +type instance XViewPat GhcPs = NoExt +type instance XViewPat GhcRn = NoExt type instance XViewPat GhcTc = Type -type instance XSplicePat (GhcPass _) = PlaceHolder -type instance XLitPat (GhcPass _) = PlaceHolder +type instance XSplicePat (GhcPass _) = NoExt +type instance XLitPat (GhcPass _) = NoExt -type instance XNPat GhcPs = PlaceHolder -type instance XNPat GhcRn = PlaceHolder +type instance XNPat GhcPs = NoExt +type instance XNPat GhcRn = NoExt type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = PlaceHolder -type instance XNPlusKPat GhcRn = PlaceHolder +type instance XNPlusKPat GhcPs = NoExt +type instance XNPlusKPat GhcRn = NoExt type instance XNPlusKPat GhcTc = Type type instance XSigPat GhcPs = (LHsSigWcType GhcPs) type instance XSigPat GhcRn = (LHsSigWcType GhcRn) type instance XSigPat GhcTc = Type -type instance XCoPat (GhcPass _) = PlaceHolder -type instance XXPat (GhcPass _) = PlaceHolder +type instance XCoPat (GhcPass _) = NoExt +type instance XXPat (GhcPass _) = NoExt -- --------------------------------------------------------------------- @@ -436,11 +441,11 @@ data HsRecField' id arg = HsRecField { -- -- The parsed HsRecUpdField corresponding to the record update will have: -- --- hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName +-- hsRecFieldLbl = Unambiguous "x" NoExt :: AmbiguousFieldOcc RdrName -- -- After the renamer, this will become: -- --- hsRecFieldLbl = Ambiguous "x" PlaceHolder :: AmbiguousFieldOcc Name +-- hsRecFieldLbl = Ambiguous "x" NoExt :: AmbiguousFieldOcc Name -- -- (note that the Unambiguous constructor is not type-correct here). -- The typechecker will determine the particular selector: @@ -528,7 +533,7 @@ pprPat (CoPat _ co pat _) = pprHsWrapper co (\parens then pprParendPat pat else pprPat pat) pprPat (SigPat ty pat) = ppr pat <+> dcolon <+> ppr ty -pprPat (ListPat _ pats _ _) = brackets (interpp'SP pats) +pprPat (ListPat _ pats) = brackets (interpp'SP pats) pprPat (PArrPat _ pats) = paBrackets (interpp'SP pats) pprPat (TuplePat _ pats bx) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) @@ -596,7 +601,7 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat PlaceHolder (HsCharPrim src c)] [] + [noLoc $ LitPat NoExt (HsCharPrim src c)] [] {- ************************************************************************ @@ -808,7 +813,7 @@ isCompoundConPat (RecCon {}) = False -- if so, surrounds @p@ with a 'ParPat'. Otherwise, it simply returns @p@. parenthesizeCompoundPat :: LPat (GhcPass p) -> LPat (GhcPass p) parenthesizeCompoundPat lp@(L loc p) - | isCompoundPat p = L loc (ParPat PlaceHolder lp) + | isCompoundPat p = L loc (ParPat NoExt lp) | otherwise = lp {- @@ -829,7 +834,7 @@ collectEvVarsPat pat = AsPat _ _ p -> collectEvVarsLPat p ParPat _ p -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p - ListPat _ ps _ _ -> unionManyBags $ map collectEvVarsLPat ps + ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps SumPat _ p _ _ -> collectEvVarsLPat p PArrPat _ ps -> unionManyBags $ map collectEvVarsLPat ps diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 6d8a6608fb..e0a8e0b6a0 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -19,8 +19,8 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, HsTyVarBndr(..), LHsTyVarBndr, - LHsQTyVars(..), - HsImplicitBndrs(..), + LHsQTyVars(..), HsQTvsRn(..), + HsImplicitBndrs(..), HsIBRn(..), HsWildCardBndrs(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), @@ -73,7 +73,6 @@ import GhcPrelude import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import PlaceHolder ( PlaceHolder(..), placeHolder ) import HsExtension import HsLit () -- for instances @@ -256,33 +255,43 @@ type LHsTyVarBndr pass = Located (HsTyVarBndr pass) -- | Located Haskell Quantified Type Variables data LHsQTyVars pass -- See Note [HsType binders] - = HsQTvs { hsq_implicit :: PostRn pass [Name] - -- Implicit (dependent) variables + = HsQTvs { hsq_ext :: XHsQTvs pass , hsq_explicit :: [LHsTyVarBndr pass] -- Explicit variables, written by the user -- See Note [HsForAllTy tyvar binders] + } + | XLHsQTyVars (XXLHsQTyVars pass) + +data HsQTvsRn + = HsQTvsRn + { hsq_implicit :: [Name] + -- Implicit (dependent) variables - , hsq_dependent :: PostRn pass NameSet + , hsq_dependent :: NameSet -- Which members of hsq_explicit are dependent; that is, -- mentioned in the kind of a later hsq_explicit, -- or mentioned in a kind in the scope of this HsQTvs -- See Note [Dependent LHsQTyVars] in TcHsType - } + } deriving Data + +type instance XHsQTvs GhcPs = NoExt +type instance XHsQTvs GhcRn = HsQTvsRn +type instance XHsQTvs GhcTc = HsQTvsRn +type instance XXLHsQTyVars (GhcPass _) = NoExt mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs -mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs - , hsq_dependent = placeHolder } +mkHsQTvs tvs = HsQTvs { hsq_ext = noExt, hsq_explicit = tvs } hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] hsQTvExplicit = hsq_explicit emptyLHsQTvs :: LHsQTyVars GhcRn -emptyLHsQTvs = HsQTvs [] [] emptyNameSet +emptyLHsQTvs = HsQTvs (HsQTvsRn [] emptyNameSet) [] isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool -isEmptyLHsQTvs (HsQTvs [] [] _) = True +isEmptyLHsQTvs (HsQTvs (HsQTvsRn [] _) []) = True isEmptyLHsQTvs _ = False ------------------------------------------------ @@ -293,26 +302,44 @@ isEmptyLHsQTvs _ = False -- | Haskell Implicit Binders data HsImplicitBndrs pass thing -- See Note [HsType binders] - = HsIB { hsib_vars :: PostRn pass [Name] -- Implicitly-bound kind & type vars - , hsib_body :: thing -- Main payload (type or list of types) - , hsib_closed :: PostRn pass Bool -- Taking the hsib_vars into account, - -- is the payload closed? Used in - -- TcHsType.decideKindGeneralisationPlan + = HsIB { hsib_ext :: XHsIB pass thing + , hsib_body :: thing -- Main payload (type or list of types) } + | XHsImplicitBndrs (XXHsImplicitBndrs pass thing) + +data HsIBRn + = HsIBRn { hsib_vars :: [Name] -- Implicitly-bound kind & type vars + , hsib_closed :: Bool -- Taking the hsib_vars into account, + -- is the payload closed? Used in + -- TcHsType.decideKindGeneralisationPlan + } deriving Data + +type instance XHsIB GhcPs _ = NoExt +type instance XHsIB GhcRn _ = HsIBRn +type instance XHsIB GhcTc _ = HsIBRn + +type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt -- | Haskell Wildcard Binders data HsWildCardBndrs pass thing -- See Note [HsType binders] -- See Note [The wildcard story for types] - = HsWC { hswc_wcs :: PostRn pass [Name] - -- Wild cards, both named and anonymous + = HsWC { hswc_ext :: XHsWC pass thing -- after the renamer + -- Wild cards, both named and anonymous , hswc_body :: thing -- Main payload (type or list of types) -- If there is an extra-constraints wildcard, -- it's still there in the hsc_body. } + | XHsWildCardBndrs (XXHsWildCardBndrs pass thing) + +type instance XHsWC GhcPs b = NoExt +type instance XHsWC GhcRn b = [Name] +type instance XHsWC GhcTc b = [Name] + +type instance XXHsWildCardBndrs (GhcPass _) b = NoExt -- | Located Haskell Signature Type type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only @@ -327,6 +354,7 @@ type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both hsImplicitBody :: HsImplicitBndrs pass thing -> thing hsImplicitBody (HsIB { hsib_body = body }) = body +hsImplicitBody (XHsImplicitBndrs _) = panic "hsImplicitBody" hsSigType :: LHsSigType pass -> LHsType pass hsSigType = hsImplicitBody @@ -359,24 +387,24 @@ 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 } +mkHsImplicitBndrs x = HsIB { hsib_ext = noExt + , hsib_body = x } mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x - , hswc_wcs = placeHolder } + , hswc_ext = noExt } -- Add empty binders. This is a bit suspicious; what if -- the wrapped thing had free type variables? mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing -mkEmptyImplicitBndrs x = HsIB { hsib_body = x - , hsib_vars = [] - , hsib_closed = False } +mkEmptyImplicitBndrs x = HsIB { hsib_ext = HsIBRn + { hsib_vars = [] + , hsib_closed = False } + , hsib_body = x } mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x - , hswc_wcs = [] } + , hswc_ext = [] } -------------------------------------------------- @@ -417,9 +445,9 @@ data HsTyVarBndr pass | XTyVarBndr (XXTyVarBndr pass) -type instance XUserTyVar (GhcPass _) = PlaceHolder -type instance XKindedTyVar (GhcPass _) = PlaceHolder -type instance XXTyVarBndr (GhcPass _) = PlaceHolder +type instance XUserTyVar (GhcPass _) = NoExt +type instance XKindedTyVar (GhcPass _) = NoExt +type instance XXTyVarBndr (GhcPass _) = NoExt -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr pass -> Bool @@ -615,6 +643,8 @@ data HsType pass | HsWildCardTy (XWildCardTy pass) -- A type wildcard -- See Note [The wildcard story for types] + -- A anonymous wild card ('_'). A fresh Name is generated for + -- each individual anonymous wildcard during renaming -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation @@ -632,43 +662,43 @@ data NewHsTypeX instance Outputable NewHsTypeX where ppr (NHsCoreTy ty) = ppr ty -type instance XForAllTy (GhcPass _) = PlaceHolder -type instance XQualTy (GhcPass _) = PlaceHolder -type instance XTyVar (GhcPass _) = PlaceHolder -type instance XAppsTy (GhcPass _) = PlaceHolder -type instance XAppTy (GhcPass _) = PlaceHolder -type instance XFunTy (GhcPass _) = PlaceHolder -type instance XListTy (GhcPass _) = PlaceHolder -type instance XPArrTy (GhcPass _) = PlaceHolder -type instance XTupleTy (GhcPass _) = PlaceHolder -type instance XSumTy (GhcPass _) = PlaceHolder -type instance XOpTy (GhcPass _) = PlaceHolder -type instance XParTy (GhcPass _) = PlaceHolder -type instance XIParamTy (GhcPass _) = PlaceHolder -type instance XEqTy (GhcPass _) = PlaceHolder -type instance XKindSig (GhcPass _) = PlaceHolder - -type instance XSpliceTy GhcPs = PlaceHolder -type instance XSpliceTy GhcRn = PlaceHolder +type instance XForAllTy (GhcPass _) = NoExt +type instance XQualTy (GhcPass _) = NoExt +type instance XTyVar (GhcPass _) = NoExt +type instance XAppsTy (GhcPass _) = NoExt +type instance XAppTy (GhcPass _) = NoExt +type instance XFunTy (GhcPass _) = NoExt +type instance XListTy (GhcPass _) = NoExt +type instance XPArrTy (GhcPass _) = NoExt +type instance XTupleTy (GhcPass _) = NoExt +type instance XSumTy (GhcPass _) = NoExt +type instance XOpTy (GhcPass _) = NoExt +type instance XParTy (GhcPass _) = NoExt +type instance XIParamTy (GhcPass _) = NoExt +type instance XEqTy (GhcPass _) = NoExt +type instance XKindSig (GhcPass _) = NoExt + +type instance XSpliceTy GhcPs = NoExt +type instance XSpliceTy GhcRn = NoExt type instance XSpliceTy GhcTc = Kind -type instance XDocTy (GhcPass _) = PlaceHolder -type instance XBangTy (GhcPass _) = PlaceHolder -type instance XRecTy (GhcPass _) = PlaceHolder +type instance XDocTy (GhcPass _) = NoExt +type instance XBangTy (GhcPass _) = NoExt +type instance XRecTy (GhcPass _) = NoExt -type instance XExplicitListTy GhcPs = PlaceHolder -type instance XExplicitListTy GhcRn = PlaceHolder +type instance XExplicitListTy GhcPs = NoExt +type instance XExplicitListTy GhcRn = NoExt type instance XExplicitListTy GhcTc = Kind -type instance XExplicitTupleTy GhcPs = PlaceHolder -type instance XExplicitTupleTy GhcRn = PlaceHolder +type instance XExplicitTupleTy GhcPs = NoExt +type instance XExplicitTupleTy GhcRn = NoExt type instance XExplicitTupleTy GhcTc = [Kind] -type instance XTyLit (GhcPass _) = PlaceHolder +type instance XTyLit (GhcPass _) = NoExt -type instance XWildCardTy GhcPs = PlaceHolder -type instance XWildCardTy GhcRn = HsWildCardInfo GhcRn -type instance XWildCardTy GhcTc = HsWildCardInfo GhcTc +type instance XWildCardTy GhcPs = NoExt +type instance XWildCardTy GhcRn = HsWildCardInfo +type instance XWildCardTy GhcTc = HsWildCardInfo type instance XXType (GhcPass _) = NewHsTypeX @@ -681,9 +711,9 @@ data HsTyLit | HsStrTy SourceText FastString deriving Data --- AZ: fold this into the XWildCardTy completely, removing the type -newtype HsWildCardInfo pass -- See Note [The wildcard story for types] - = AnonWildCard (PostRn pass (Located Name)) +newtype HsWildCardInfo -- See Note [The wildcard story for types] + = AnonWildCard (Located Name) + deriving Data -- A anonymous wild card ('_'). A fresh Name is generated for -- each individual anonymous wildcard during renaming @@ -700,9 +730,9 @@ data HsAppType pass | XAppType (XXAppType pass) -type instance XAppInfix (GhcPass _) = PlaceHolder -type instance XAppPrefix (GhcPass _) = PlaceHolder -type instance XXAppType (GhcPass _) = PlaceHolder +type instance XAppInfix (GhcPass _) = NoExt +type instance XAppPrefix (GhcPass _) = NoExt +type instance XXAppType (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsAppType p) where @@ -840,17 +870,23 @@ type LConDeclField pass = Located (ConDeclField pass) -- | Constructor Declaration Field data ConDeclField pass -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_names :: [LFieldOcc pass], + = ConDeclField { cd_fld_ext :: XConDeclField pass, + cd_fld_names :: [LFieldOcc pass], -- ^ See Note [ConDeclField passs] cd_fld_type :: LBangType pass, cd_fld_doc :: Maybe LHsDocString } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation + | XConDeclField (XXConDeclField pass) + +type instance XConDeclField (GhcPass _) = NoExt +type instance XXConDeclField (GhcPass _) = NoExt instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDeclField p) where - ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty + ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty + ppr (XConDeclField x) = ppr x -- HsConDetails is used for patterns/expressions *and* for data type -- declarations @@ -899,19 +935,23 @@ hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] -- - the named wildcars; see Note [Scoping of named wildcards] -- because they scope in the same way hsWcScopedTvs sig_ty - | HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty - , HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1 + | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty + , HsIB { hsib_ext = HsIBRn { hsib_vars = vars} + , hsib_body = sig_ty2 } <- sig_ty1 = case sig_ty2 of L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ map hsLTyVarName tvs -- include kind variables only if the type is headed by forall -- (this is consistent with GHC 7 behaviour) _ -> nwcs +hsWcScopedTvs (HsWC _ (XHsImplicitBndrs _)) = panic "hsWcScopedTvs" +hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs" hsScopedTvs :: LHsSigType GhcRn -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType hsScopedTvs sig_ty - | HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty + | HsIB { hsib_ext = HsIBRn { hsib_vars = vars } + , hsib_body = sig_ty2 } <- sig_ty , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2 = vars ++ map hsLTyVarName tvs | otherwise @@ -945,8 +985,10 @@ hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] -- All variables -hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) +hsAllLTyVarNames (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kvs } + , hsq_explicit = tvs }) = kvs ++ map hsLTyVarName tvs +hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames" hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass) hsLTyVarLocName = fmap hsTyVarName @@ -967,14 +1009,14 @@ hsLTyVarBndrToType = fmap cvt -- Works on *type* variable only, no kind vars. hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs +hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes" --------------------- -wildCardName :: HsWildCardInfo GhcRn -> Name +wildCardName :: HsWildCardInfo -> Name wildCardName (AnonWildCard (L _ n)) = n -- Two wild cards are the same when they have the same location -sameWildCard :: Located (HsWildCardInfo pass) - -> Located (HsWildCardInfo pass) -> Bool +sameWildCard :: Located HsWildCardInfo -> Located HsWildCardInfo -> Bool sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 ignoreParens :: LHsType pass -> LHsType pass @@ -1012,7 +1054,7 @@ mkHsAppsTy :: [LHsAppType GhcPs] -> HsType GhcPs -- In the common case of a singleton non-operator, -- avoid the clutter of wrapping in a HsAppsTy mkHsAppsTy [L _ (HsAppPrefix _ (L _ ty))] = ty -mkHsAppsTy app_tys = HsAppsTy PlaceHolder app_tys +mkHsAppsTy app_tys = HsAppsTy NoExt app_tys {- ************************************************************************ @@ -1139,12 +1181,13 @@ splitLHsQualTy body = (noLoc [], body) splitLHsInstDeclTy :: LHsSigType GhcRn -> ([Name], LHsContext GhcRn, LHsType GhcRn) -- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy (HsIB { hsib_vars = itkvs +splitLHsInstDeclTy (HsIB { hsib_ext = HsIBRn { hsib_vars = itkvs } , hsib_body = inst_ty }) | (tvs, cxt, body_ty) <- splitLHsSigmaTy inst_ty = (itkvs ++ map hsLTyVarName tvs, cxt, body_ty) -- Return implicitly bound type and kind vars -- For an instance decl, all of them are in scope +splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy" getLHsInstDeclHead :: LHsSigType pass -> LHsType pass getLHsInstDeclHead inst_ty @@ -1175,8 +1218,8 @@ type LFieldOcc pass = Located (FieldOcc pass) -- Represents an *occurrence* of an unambiguous field. We store -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. -data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass - , rdrNameFieldOcc :: Located RdrName +data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass + , rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in HsExpr } @@ -1185,17 +1228,17 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass deriving instance (p ~ GhcPass pass, Eq (XFieldOcc p)) => Eq (FieldOcc p) deriving instance (p ~ GhcPass pass, Ord (XFieldOcc p)) => Ord (FieldOcc p) -type instance XFieldOcc GhcPs = PlaceHolder +type instance XFieldOcc GhcPs = NoExt type instance XFieldOcc GhcRn = Name type instance XFieldOcc GhcTc = Id -type instance XXFieldOcc (GhcPass _) = PlaceHolder +type instance XXFieldOcc (GhcPass _) = NoExt instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc placeHolder rdr +mkFieldOcc rdr = FieldOcc noExt rdr -- | Ambiguous Field Occurrence @@ -1215,15 +1258,15 @@ data AmbiguousFieldOcc pass | Ambiguous (XAmbiguous pass) (Located RdrName) | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) -type instance XUnambiguous GhcPs = PlaceHolder +type instance XUnambiguous GhcPs = NoExt type instance XUnambiguous GhcRn = Name type instance XUnambiguous GhcTc = Id -type instance XAmbiguous GhcPs = PlaceHolder -type instance XAmbiguous GhcRn = PlaceHolder +type instance XAmbiguous GhcPs = NoExt +type instance XAmbiguous GhcRn = NoExt type instance XAmbiguous GhcTc = Id -type instance XXAmbiguousFieldOcc (GhcPass _) = PlaceHolder +type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where ppr = ppr . rdrNameAmbiguousFieldOcc @@ -1273,6 +1316,7 @@ instance Outputable HsTyLit where instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (LHsQTyVars p) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs + ppr (XLHsQTyVars x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsTyVarBndr p) where @@ -1280,13 +1324,17 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] ppr (XTyVarBndr n) = ppr n -instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where +instance (p ~ GhcPass pass,Outputable thing) + => Outputable (HsImplicitBndrs p thing) where ppr (HsIB { hsib_body = ty }) = ppr ty + ppr (XHsImplicitBndrs x) = ppr x -instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where +instance (p ~ GhcPass pass,Outputable thing) + => Outputable (HsWildCardBndrs p thing) where ppr (HsWC { hswc_body = ty }) = ppr ty + ppr (XHsWildCardBndrs x) = ppr x -instance Outputable (HsWildCardInfo pass) where +instance Outputable HsWildCardInfo where ppr (AnonWildCard _) = char '_' pprAnonWildCard :: SDoc @@ -1357,6 +1405,7 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })) = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + ppr_fld (L _ (XConDeclField x)) = ppr x ppr_names [n] = ppr n ppr_names ns = sep (punctuate comma (map ppr ns)) @@ -1486,5 +1535,5 @@ isCompoundHsType _ = False -- returns @ty@. parenthesizeCompoundHsType :: LHsType (GhcPass p) -> LHsType (GhcPass p) parenthesizeCompoundHsType ty@(L loc _) - | isCompoundHsType ty = L loc (HsParTy PlaceHolder ty) + | isCompoundHsType ty = L loc (HsParTy NoExt ty) | otherwise = ty diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 90e1ddbbe6..fc918e30bb 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -63,14 +63,12 @@ module HsUtils( mkLastStmt, emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, + unitRecStmtTc, -- Template Haskell mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice, mkHsQuasiQuote, unqualQuasiQuote, - -- Flags - noRebindableInfo, - -- Collecting binders isUnliftedHsBind, isBangedHsBind, @@ -148,7 +146,7 @@ mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs = L loc $ - Match { m_ctxt = ctxt, m_pats = pats + Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats , m_grhss = unguardedGRHSs rhs } where loc = case pats of @@ -158,17 +156,17 @@ mkSimpleMatch ctxt pats rhs unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p))) unguardedGRHSs rhs@(L loc _) - = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds) + = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds) -unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))] -unguardedRHS loc rhs = [L loc (GRHS [] rhs)] +unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) + -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] +unguardedRHS loc rhs = [L loc (GRHS noExt [] rhs)] -mkMatchGroup :: (PostTc name Type ~ PlaceHolder) +mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt) => Origin -> [LMatch name (Located (body name))] -> MatchGroup name (Located (body name)) -mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches - , mg_arg_tys = [] - , mg_res_ty = placeHolderType +mkMatchGroup origin matches = MG { mg_ext = noExt + , mg_alts = mkLocatedList matches , mg_origin = origin } mkLocatedList :: [Located a] -> Located [Located a] @@ -246,26 +244,25 @@ mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs mkLastStmt :: Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkBodyStmt :: Located (bodyR GhcPs) - -> StmtLR idL GhcPs (Located (bodyR GhcPs)) -mkBindStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder) + -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) +mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) + (Located (bodyR (GhcPass idR))) ~ NoExt) => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) -emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR +emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR -mkRecStmt :: [LStmtLR idL GhcPs bodyR] -> StmtLR idL GhcPs bodyR +mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR] + -> StmtLR (GhcPass idL) GhcPs bodyR mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr mkHsFractional f = OverLit noExt (HsFractional f) noExpr mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr -noRebindableInfo :: PlaceHolder -noRebindableInfo = placeHolder -- Just another placeholder; - mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where @@ -279,55 +276,58 @@ mkNPat lit neg = NPat noExt lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) -mkTransformByStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) -mkGroupUsingStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) -mkGroupByUsingStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder) - => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) - -> LHsExpr (GhcPass idR) - -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) - -emptyTransStmt :: (PostTc (GhcPass idR) Type ~ PlaceHolder) - => StmtLR idL (GhcPass idR) (LHsExpr (GhcPass idR)) -emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" +mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) + +emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt = TransStmt { trS_ext = noExt + , 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_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 } mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkLastStmt body = LastStmt body False noSyntaxExpr -mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType -mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr placeHolder -mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy +mkLastStmt body = LastStmt noExt body False noSyntaxExpr +mkBodyStmt body + = BodyStmt noExt body noSyntaxExpr noSyntaxExpr +mkBindStmt pat body + = BindStmt noExt pat body noSyntaxExpr noSyntaxExpr +mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr -- don't use placeHolderTypeTc above, because that panics during zonking emptyRecStmt' :: forall idL idR body. - PostTc (GhcPass idR) Type -> StmtLR (GhcPass idL) (GhcPass idR) body + XRecStmt (GhcPass idL) (GhcPass idR) body + -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal = RecStmt { recS_stmts = [], recS_later_ids = [] , recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr , recS_mfix_fn = noSyntaxExpr - , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal - , recS_later_rets = [] - , recS_rec_rets = [], recS_ret_ty = tyVal } - -emptyRecStmt = emptyRecStmt' placeHolderType -emptyRecStmtName = emptyRecStmt' placeHolderType -emptyRecStmtId = emptyRecStmt' unitTy -- a panic might trigger during zonking + , recS_bind_fn = noSyntaxExpr + , recS_ext = tyVal } + +unitRecStmtTc :: RecStmtTc +unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy + , recS_later_rets = [] + , recS_rec_rets = [] + , recS_ret_ty = unitTy } + +emptyRecStmt = emptyRecStmt' noExt +emptyRecStmtName = emptyRecStmt' noExt +emptyRecStmtId = emptyRecStmt' unitRecStmtTc + -- a panic might trigger during zonking mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- @@ -659,14 +659,14 @@ typeToLHsType ty go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) go (LitTy (NumTyLit n)) - = noLoc $ HsTyLit PlaceHolder (HsNumTy NoSourceText n) + = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n) go (LitTy (StrTyLit s)) - = noLoc $ HsTyLit PlaceHolder (HsStrTy NoSourceText s) + = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s) go ty@(TyConApp tc args) | any isInvisibleTyConBinder (tyConBinders tc) -- We must produce an explicit kind signature here to make certain -- programs kind-check. See Note [Kind signatures in typeToLHsType]. - = noLoc $ HsKindSig PlaceHolder lhs_ty (go (typeKind ty)) + = noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty)) | otherwise = lhs_ty where lhs_ty = nlHsTyConApp (getRdrName tc) (map go args') @@ -820,13 +820,12 @@ mkPatSynBind name details lpat dir = PatSynBind noExt psb , psb_id = name , psb_args = details , psb_def = lpat - , psb_dir = dir - , psb_fvs = placeHolderNames } + , psb_dir = dir } -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. isInfixFunBind :: HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind _ _ (MG matches _ _ _) _ _) +isInfixFunBind (FunBind _ _ (MG _ matches _) _ _) = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False @@ -851,9 +850,10 @@ mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> Located (HsLocalBinds (GhcPass p)) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr lbinds - = noLoc (Match { m_ctxt = ctxt + = noLoc (Match { m_ext = noExt + , m_ctxt = ctxt , m_pats = map paren pats - , m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds }) + , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds }) where paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp) | otherwise = lp @@ -1019,15 +1019,16 @@ collectLStmtBinders = collectStmtBinders . unLoc collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat -collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds -collectStmtBinders (BodyStmt {}) = [] -collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders +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 (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss collectStmtBinders ApplicativeStmt{} = [] +collectStmtBinders XStmtLR{} = panic "collectStmtBinders" ----------------- Patterns -------------------------- @@ -1050,7 +1051,7 @@ collect_lpat (L _ pat) bndrs go (ViewPat _ _ pat) = collect_lpat pat bndrs go (ParPat _ pat) = collect_lpat pat bndrs - go (ListPat _ pats _ _) = foldr collect_lpat bndrs pats + go (ListPat _ pats) = foldr collect_lpat bndrs pats go (PArrPat _ pats) = foldr collect_lpat bndrs pats go (TuplePat _ pats _) = foldr collect_lpat bndrs pats go (SumPat _ pat _ _) = collect_lpat pat bndrs @@ -1103,6 +1104,7 @@ hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) = collectHsValBinders val_decls ++ hsTyClForeignBinders tycl_decls foreign_decls +hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders" hsTyClForeignBinders :: [TyClGroup GhcRn] -> [LForeignDecl GhcRn] @@ -1133,6 +1135,8 @@ hsLTyClDeclBinders :: Located (TyClDecl pass) hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } })) = ([L loc name], []) +hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl _ })) + = panic "hsLTyClDeclBinders" hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], []) hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name , tcdSigs = sigs, tcdATs = ats })) @@ -1143,6 +1147,7 @@ hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn +hsLTyClDeclBinders (L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders" ------------------- hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] @@ -1172,13 +1177,17 @@ getPatSynBinds binds , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- -hsLInstDeclBinders :: LInstDecl pass - -> ([Located (IdP pass)], [LFieldOcc pass]) +hsLInstDeclBinders :: LInstDecl (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) = foldMap (hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty +hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl {}))) + = panic "hsLInstDeclBinders" +hsLInstDeclBinders (L _ (XInstDecl _)) + = panic "hsLInstDeclBinders" ------------------- -- the SrcLoc returned are for the whole declarations, not just the names @@ -1188,6 +1197,11 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = defn }}}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders +hsDataFamInstBinders (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = XFamEqn _}}) + = panic "hsDataFamInstBinders" +hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) + = panic "hsDataFamInstBinders" ------------------- -- the SrcLoc returned are for the whole declarations, not just the names @@ -1195,6 +1209,7 @@ hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] +hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" ------------------- type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] @@ -1228,6 +1243,8 @@ hsConDeclsBinders cons (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs + L _ (XConDecl _) -> panic "hsConDeclsBinders" + get_flds :: Seen pass -> HsConDeclDetails pass -> (Seen pass, [LFieldOcc pass]) get_flds remSeen (RecCon flds) @@ -1282,17 +1299,19 @@ lStmtsImplicits = hs_lstmts hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) -> NameSet - hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat - hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args) - where do_arg (_, ApplicativeArgOne pat _ _) = lPatImplicits pat - do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts - 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 + hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat + hs_stmt (ApplicativeStmt _ args _) = unionNameSets (map do_arg args) + where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat + do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts + do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits" + 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 (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + hs_stmt (XStmtLR {}) = panic "lStmtsImplicits" hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds {}) = emptyNameSet @@ -1323,7 +1342,7 @@ lPatImplicits = hs_lpat hs_pat (AsPat _ _ pat) = hs_lpat pat hs_pat (ViewPat _ _ pat) = hs_lpat pat hs_pat (ParPat _ pat) = hs_lpat pat - hs_pat (ListPat _ pats _ _) = hs_lpats pats + hs_pat (ListPat _ pats) = hs_lpats pats hs_pat (PArrPat _ pats) = hs_lpats pats hs_pat (TuplePat _ pats _) = hs_lpats pats diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 9d99c9a3cb..244243a82f 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -6,15 +6,11 @@ module PlaceHolder where -import GhcPrelude ( Eq(..), Ord(..) ) - -import Outputable hiding ( (<>) ) import Name import NameSet import RdrName import Var -import Data.Data hiding ( Fixity ) {- @@ -28,26 +24,11 @@ import Data.Data hiding ( Fixity ) -- NB: These are intentionally open, allowing API consumers (like Haddock) -- to declare new instances --- | used as place holder in PostTc and PostRn values -data PlaceHolder = PlaceHolder - deriving (Data,Eq,Ord) - -instance Outputable PlaceHolder where - ppr _ = text "PlaceHolder" - -placeHolder :: PlaceHolder -placeHolder = PlaceHolder - -placeHolderType :: PlaceHolder -placeHolderType = PlaceHolder - -placeHolderNames :: PlaceHolder -placeHolderNames = PlaceHolder - placeHolderNamesTc :: NameSet placeHolderNamesTc = emptyNameSet {- +TODO:AZ: remove this, and check if we still need all the UndecidableInstances Note [Pass sensitive types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 3158335435..76f67b25db 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -122,7 +122,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = L loc $ ImportDecl { ideclSourceSrc = NoSourceText, + = L loc $ ImportDecl { ideclExt = noExt, + ideclSourceSrc = NoSourceText, ideclName = L loc pRELUDE_NAME, ideclPkgQual = Nothing, ideclSource = False, diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index b55267d5e3..223886a1fc 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -909,10 +909,11 @@ hscCheckSafeImports tcg_env = do -> return tcg_env' warns dflags rules = listToBag $ map (warnRules dflags) rules - warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = + warnRules dflags (L loc (HsRule _ n _ _ _ _)) = mkPlainWarnMsg dflags loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" + warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports" -- | Validate that safe imported modules are actually safe. For modules in the -- HomePackage (the package the module we are compiling in resides) this just @@ -1715,7 +1716,7 @@ hscParseExpr expr = do hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (BodyStmt expr _ _ _)) -> return expr + Just (L _ (BodyStmt _ expr _ _)) -> return expr _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan (text "not an expression:" <+> quotes (text expr)) diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 23e5c9289a..ce59ca1877 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -70,18 +70,18 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) - = count_sigs [d | SigD d <- decls] + = count_sigs [d | SigD _ d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo - tycl_decls = [d | TyClD d <- decls] + tycl_decls = [d | TyClD _ d <- decls] (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = countTyClDecls tycl_decls - inst_decls = [d | InstD d <- decls] + inst_decls = [d | InstD _ d <- decls] inst_ds = length inst_decls default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls - val_decls = [d | ValD d <- decls] + val_decls = [d | ValD _ d <- decls] real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } n_exports = length real_exports @@ -120,6 +120,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual , ideclAs = as, ideclHiding = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + import_info (L _ (XImportDecl _)) = panic "import_info" safe_info = qual_info qual_info False = 0 qual_info True = 1 @@ -155,6 +156,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ss, is, length ats, length adts) where methods = map unLoc $ bagToList inst_meths + inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info" + inst_info (XInstDecl _) = panic "inst_info" -- TODO: use Sum monoid addpr :: (Int,Int,Int) -> Int diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index db6f7f86ac..163bb8de3f 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -810,7 +810,7 @@ isDecl dflags stmt = do case parseThing Parser.parseDeclaration dflags stmt of Lexer.POk _ thing -> case unLoc thing of - SpliceD _ -> False + SpliceD _ _ -> False _ -> True Lexer.PFailed _ _ _ -> False @@ -870,7 +870,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do -- create a new binding. let expr_fs = fsLit "_compileParsedExpr" expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt . L loc . (HsValBinds noExt) $ + let_stmt = L loc . LetStmt noExt . L loc . (HsValBinds noExt) $ ValBinds noExt (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 085140c174..a7c875e39e 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -851,9 +851,9 @@ expdoclist :: { OrdList (LIE GhcPs) } | {- empty -} { nilOL } exp_doc :: { OrdList (LIE GhcPs) } - : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) } - | docnamed { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) } - | docnext { unitOL (sL1 $1 (IEDoc (unLoc $1))) } + : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup noExt n doc)) } + | docnamed { unitOL (sL1 $1 (IEDocNamed noExt ((fst . unLoc) $1))) } + | docnext { unitOL (sL1 $1 (IEDoc noExt (unLoc $1))) } -- No longer allow things like [] and (,,,) to be exported @@ -861,9 +861,9 @@ exp_doc :: { OrdList (LIE GhcPs) } export :: { OrdList (LIE GhcPs) } : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } - | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2)) + | 'module' modid {% amsu (sLL $1 $> (IEModuleContents noExt $2)) [mj AnnModule $1] } - | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2)))) + | 'pattern' qcon {% amsu (sLL $1 $> (IEVar noExt (sLL $1 $> (IEPattern $2)))) [mj AnnPattern $1] } export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } @@ -940,7 +940,8 @@ importdecls_semi importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec {% ams (L (comb4 $1 $6 (snd $7) $8) $ - ImportDecl { ideclSourceSrc = snd $ fst $2 + ImportDecl { ideclExt = noExt + , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 , ideclQualified = snd $4, ideclImplicit = False @@ -1023,48 +1024,48 @@ topdecls_semi :: { OrdList (LHsDecl GhcPs) } | {- empty -} { nilOL } topdecl :: { LHsDecl GhcPs } - : cl_decl { sL1 $1 (TyClD (unLoc $1)) } - | ty_decl { sL1 $1 (TyClD (unLoc $1)) } - | inst_decl { sL1 $1 (InstD (unLoc $1)) } - | stand_alone_deriving { sLL $1 $> (DerivD (unLoc $1)) } - | role_annot { sL1 $1 (RoleAnnotD (unLoc $1)) } - | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD (DefaultDecl $3))) + : cl_decl { sL1 $1 (TyClD noExt (unLoc $1)) } + | ty_decl { sL1 $1 (TyClD noExt (unLoc $1)) } + | inst_decl { sL1 $1 (InstD noExt (unLoc $1)) } + | stand_alone_deriving { sLL $1 $> (DerivD noExt (unLoc $1)) } + | role_annot { sL1 $1 (RoleAnnotD noExt (unLoc $1)) } + | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD noExt (DefaultDecl noExt $3))) [mj AnnDefault $1 ,mop $2,mcp $4] } | 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2)) (mj AnnForeign $1:(fst $ unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2))) + | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getDEPRECATED_PRAGs $1) (fromOL $2))) [mo $1,mc $3] } - | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2))) + | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD noExt (Warnings noExt (getWARNING_PRAGs $1) (fromOL $2))) [mo $1,mc $3] } - | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2))) + | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD noExt (HsRules noExt (getRULES_PRAGs $1) (fromOL $2))) [mo $1,mc $3] } - | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4)) + | '{-# VECTORISE' qvar '=' exp '#-}' {% ams (sLL $1 $> $ VectD noExt (HsVect noExt (getVECT_PRAGs $1) $2 $4)) [mo $1,mj AnnEqual $3 ,mc $5] } - | '{-# NOVECTORISE' qvar '#-}' {% ams (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2)) + | '{-# NOVECTORISE' qvar '#-}' {% ams (sLL $1 $> $ VectD noExt (HsNoVect noExt (getNOVECT_PRAGs $1) $2)) [mo $1,mc $3] } | '{-# VECTORISE' 'type' gtycon '#-}' {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing)) + VectD noExt (HsVectType (VectTypePR (getVECT_PRAGs $1) $3 Nothing) False)) [mo $1,mj AnnType $2,mc $4] } | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing)) + VectD noExt (HsVectType (VectTypePR (getVECT_SCALAR_PRAGs $1) $3 Nothing) True)) [mo $1,mj AnnType $2,mc $4] } | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5))) + VectD noExt (HsVectType (VectTypePR (getVECT_PRAGs $1) $3 (Just $5)) False)) [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' {% ams (sLL $1 $> $ - VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5))) + VectD noExt (HsVectType (VectTypePR (getVECT_SCALAR_PRAGs $1) $3 (Just $5)) True)) [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] } | '{-# VECTORISE' 'class' gtycon '#-}' - {% ams (sLL $1 $> $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3)) + {% ams (sLL $1 $> $ VectD noExt (HsVectClass (VectClassPR (getVECT_PRAGs $1) $3))) [mo $1,mj AnnClass $2,mc $4] } | annotation { $1 } | decl_no_th { $1 } @@ -1136,12 +1137,13 @@ ty_decl :: { LTyClDecl GhcPs } inst_decl :: { LInstDecl GhcPs } : 'instance' overlap_pragma inst_type where_inst {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) - ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds + ; let cid = ClsInstDecl { cid_ext = noExt + , cid_poly_ty = $3, cid_binds = binds , cid_sigs = mkClassOpSigs sigs , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid })) + ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) (mj AnnInstance $1 : (fst $ unLoc $4)) } } -- type instance declarations @@ -1345,22 +1347,22 @@ opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) } | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) } opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } - : { noLoc ([] , noLoc NoSig )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} + : { noLoc ([] , noLoc (NoSig noExt) )} + | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExt $2))} opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } - : { noLoc ([] , noLoc NoSig )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig $2))} - | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig $2))} + : { noLoc ([] , noLoc (NoSig noExt) )} + | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExt $2))} + | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExt $2))} opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs , Maybe (LInjectivityAnn GhcPs)))} - : { noLoc ([], (noLoc NoSig, Nothing)) } + : { noLoc ([], (noLoc (NoSig noExt), Nothing)) } | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] - , (sLL $2 $> (KindSig $2), Nothing)) } + , (sLL $2 $> (KindSig noExt $2), Nothing)) } | '=' tv_bndr '|' injectivity_cond { sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] - , (sLL $1 $2 (TyVarSig $2), Just $4))} + , (sLL $1 $2 (TyVarSig noExt $2), Just $4))} -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -1396,7 +1398,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs } {% do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr $5) } ; ams (sLL $1 (hsSigType $>) - (DerivDecl (mkHsWildCardBndrs $5) $2 $4)) + (DerivDecl noExt (mkHsWildCardBndrs $5) $2 $4)) [mj AnnDeriving $1, mj AnnInstance $3] } } ----------------------------------------------------------------------------- @@ -1427,20 +1429,20 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 } pattern_synonym_decl :: { LHsDecl GhcPs } : 'pattern' pattern_synonym_lhs '=' pat {% let (name, args,as ) = $2 in - ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 + ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 ImplicitBidirectional) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) } | 'pattern' pattern_synonym_lhs '<-' pat {% let (name, args, as) = $2 in - ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional) + ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 Unidirectional) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) } | 'pattern' pattern_synonym_lhs '<-' pat where_decls {% do { let (name, args, as) = $2 ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) - ; ams (sLL $1 $> . ValD $ + ; ams (sLL $1 $> . ValD noExt $ mkPatSynBind name args $4 (ExplicitBidirectional mg)) (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) ) }} @@ -1485,7 +1487,7 @@ decl_cls : at_decl_cls { $1 } {% do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> quotes (ppr $2) - ; ams (sLL $1 $> $ SigD $ ClassOpSig noExt True [v] $ mkLHsSigType $4) + ; ams (sLL $1 $> $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType $4) [mj AnnDefault $1,mu AnnDcolon $3] } } decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed @@ -1523,7 +1525,7 @@ where_cls :: { Located ([AddAnn] -- Declarations in instance bodies -- decl_inst :: { Located (OrdList (LHsDecl GhcPs)) } -decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) } +decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD noExt (unLoc $1)))) } | decl { sLL $1 $> (unitOL $1) } decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed @@ -1621,10 +1623,9 @@ rules :: { OrdList (LRuleDecl GhcPs) } rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_forall infixexp '=' exp - {%ams (sLL $1 $> $ (HsRule (L (gl $1) (getSTRINGs $1,getSTRING $1)) + {%ams (sLL $1 $> $ (HsRule noExt (L (gl $1) (getSTRINGs $1,getSTRING $1)) ((snd $2) `orElse` AlwaysActive) - (snd $3) $4 placeHolderNames $6 - placeHolderNames)) + (snd $3) $4 $6)) (mj AnnEqual $5 : (fst $2) ++ (fst $3)) } -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas @@ -1650,8 +1651,8 @@ rule_var_list :: { [LRuleBndr GhcPs] } | rule_var rule_var_list { $1 : $2 } rule_var :: { LRuleBndr GhcPs } - : varid { sLL $1 $> (RuleBndr $1) } - | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 + : varid { sLL $1 $> (RuleBndr noExt $1) } + | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig noExt $2 (mkLHsSigWcType $4))) [mop $1,mu AnnDcolon $3,mcp $5] } @@ -1669,7 +1670,7 @@ warnings :: { OrdList (LWarnDecl GhcPs) } -- SUP: TEMPORARY HACK, not checking for `module Foo' warning :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) + {% amsu (sLL $1 $> (Warning noExt (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } deprecations :: { OrdList (LWarnDecl GhcPs) } @@ -1684,7 +1685,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) + {% amsu (sLL $1 $> $ (Warning noExt (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located StringLiteral]) } @@ -1701,17 +1702,17 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } ----------------------------------------------------------------------------- -- Annotations annotation :: { LHsDecl GhcPs } - : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + : '{-# ANN' name_var aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (ValueAnnProvenance $2) $3)) [mo $1,mc $4] } - | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + | '{-# ANN' 'type' tycon aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) (TypeAnnProvenance $3) $4)) [mo $1,mj AnnType $2,mc $5] } - | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD $ HsAnnotation + | '{-# ANN' 'module' aexp '#-}' {% ams (sLL $1 $> (AnnD noExt $ HsAnnotation noExt (getANN_PRAGs $1) ModuleAnnProvenance $3)) [mo $1,mj AnnModule $2,mc $4] } @@ -2219,7 +2220,7 @@ fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev {% ams (L (comb2 $2 $4) - (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) + (ConDeclField noExt (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2237,18 +2238,18 @@ derivings :: { HsDeriving GhcPs } deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_strategy qtycondoc {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc + in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc [mkLHsSigType $3]) [mj AnnDeriving $1] } | 'deriving' deriv_strategy '(' ')' {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc []) + in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc []) [mj AnnDeriving $1,mop $3,mcp $4] } | 'deriving' deriv_strategy '(' deriv_types ')' {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause $2 $ L full_loc $4) + in ams (L full_loc $ HsDerivingClause noExt $2 $ L full_loc $4) [mj AnnDeriving $1,mop $3,mcp $5] } -- Glasgow extension: allow partial -- applications in derivings @@ -2279,7 +2280,7 @@ There's an awkward overlap with a type signature. Consider -} docdecl :: { LHsDecl GhcPs } - : docdecld { sL1 $1 (DocD (unLoc $1)) } + : docdecld { sL1 $1 (DocD noExt (unLoc $1)) } docdecld :: { LDocDecl } : docnext { sL1 $1 (DocCommentNext (unLoc $1)) } @@ -2304,7 +2305,7 @@ decl_no_th :: { LHsDecl GhcPs } ams (L lh ()) [] >> return () } ; _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; - return $! (sL l $ ValD r) } } + return $! (sL l $ ValD noExt r) } } | infixexp_top opt_sig rhs {% do { (ann,r) <- checkValDef empty NoSrcStrict $1 (snd $2) $3; let { l = comb2 $1 $> }; @@ -2317,7 +2318,7 @@ decl_no_th :: { LHsDecl GhcPs } (PatBind _ (L lh _lhs) _rhs _) -> ams (L lh ()) (fst $2) >> return () } ; _ <- ams (L l ()) (ann ++ (fst $ unLoc $3)); - return $! (sL l $ ValD r) } } + return $! (sL l $ ValD noExt r) } } | pattern_synonym_decl { $1 } | docdecl { $1 } @@ -2332,10 +2333,10 @@ decl :: { LHsDecl GhcPs } rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) ((mj AnnEqual $1 : (fst $ unLoc $3)) - ,GRHSs (unguardedRHS (comb3 $1 $2 $3) $2) + ,GRHSs noExt (unguardedRHS (comb3 $1 $2 $3) $2) (snd $ unLoc $3)) } | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 - ,GRHSs (reverse (unLoc $1)) + ,GRHSs noExt (reverse (unLoc $1)) (snd $ unLoc $2)) } gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } @@ -2343,7 +2344,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } | gdrh { sL1 $1 [$1] } gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } - : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) + : '|' guardquals '=' exp {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mj AnnEqual $3] } sigdecl :: { LHsDecl GhcPs } @@ -2352,69 +2353,69 @@ sigdecl :: { LHsDecl GhcPs } infixexp_top '::' sigtypedoc {% do v <- checkValSigLhs $1 ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD $ + ; return (sLL $1 $> $ SigD noExt $ TypeSig noExt [v] (mkLHsSigWcType $3)) } | var ',' sig_vars '::' sigtypedoc {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3)) (mkLHsSigWcType $5) ; addAnnotation (gl $1) AnnComma (gl $2) - ; ams ( sLL $1 $> $ SigD sig ) + ; ams ( sLL $1 $> $ SigD noExt sig ) [mu AnnDcolon $4] } } | infix prec ops - {% ams (sLL $1 $> $ SigD + {% ams (sLL $1 $> $ SigD noExt (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3) (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) [mj AnnInfix $1,mj AnnVal $2] } - | pattern_synonym_sig { sLL $1 $> . SigD . unLoc $ $1 } + | pattern_synonym_sig { sLL $1 $> . SigD noExt . unLoc $ $1 } | '{-# COMPLETE' con_list opt_tyconsig '#-}' {% let (dcolon, tc) = $3 in ams (sLL $1 $> - (SigD (CompleteMatchSig noExt (getCOMPLETE_PRAGs $1) $2 tc))) + (SigD noExt (CompleteMatchSig noExt (getCOMPLETE_PRAGs $1) $2 tc))) ([ mo $1 ] ++ dcolon ++ [mc $4]) } -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvar '#-}' - {% ams ((sLL $1 $> $ SigD (InlineSig noExt $3 + {% ams ((sLL $1 $> $ SigD noExt (InlineSig noExt $3 (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) (snd $2))))) ((mo $1:fst $2) ++ [mc $4]) } | '{-# SCC' qvar '#-}' - {% ams (sLL $1 $> (SigD (SCCFunSig noExt (getSCC_PRAGs $1) $2 Nothing))) + {% ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 Nothing))) [mo $1, mc $3] } | '{-# SCC' qvar STRING '#-}' {% do { scc <- getSCC $3 ; let str_lit = StringLiteral (getSTRINGs $3) scc - ; ams (sLL $1 $> (SigD (SCCFunSig noExt (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) + ; ams (sLL $1 $> (SigD noExt (SCCFunSig noExt (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) [mo $1, mc $4] } } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' {% ams ( let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) (NoUserInline, FunLike) (snd $2) - in sLL $1 $> $ SigD (SpecSig noExt $3 (fromOL $5) inl_prag)) + in sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5) inl_prag)) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - {% ams (sLL $1 $> $ SigD (SpecSig noExt $3 (fromOL $5) + {% ams (sLL $1 $> $ SigD noExt (SpecSig noExt $3 (fromOL $5) (mkInlinePragma (getSPEC_INLINE_PRAGs $1) (getSPEC_INLINE $1) (snd $2)))) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE' 'instance' inst_type '#-}' {% ams (sLL $1 $> - $ SigD (SpecInstSig noExt (getSPEC_PRAGs $1) $3)) + $ SigD noExt (SpecInstSig noExt (getSPEC_PRAGs $1) $3)) [mo $1,mj AnnInstance $2,mc $4] } -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}' - {% ams (sLL $1 $> $ SigD (MinimalSig noExt (getMINIMAL_PRAGs $1) $2)) + {% ams (sLL $1 $> $ SigD noExt (MinimalSig noExt (getMINIMAL_PRAGs $1) $2)) [mo $1,mc $3] } activation :: { ([AddAnn],Maybe Activation) } @@ -2549,7 +2550,8 @@ aexp :: { LHsExpr GhcPs } | '\\' apat apats '->' exp {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_ctxt = LambdaExpr + [sLL $1 $> $ Match { m_ext = noExt + , m_ctxt = LambdaExpr , m_pats = $2:$3 , m_grhss = unguardedGRHSs $5 }])) [mj AnnLam $1, mu AnnRarrow $4] } @@ -2606,7 +2608,7 @@ aexp2 :: { LHsExpr GhcPs } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) --- (getSTRING $1) placeHolderType) } +-- (getSTRING $1) noExt) } | INTEGER { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) } | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) } @@ -2782,9 +2784,9 @@ 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 noExt qs [] noSyntaxExpr | + qss -> sL1 $1 [sL1 $1 $ ParStmt noExt [ParStmtBlock noExt qs [] noSyntaxExpr | qs <- qss] - noExpr noSyntaxExpr placeHolderType] + noExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@ -2896,14 +2898,15 @@ alts1 :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } | alt { sL1 $1 ([],[$1]) } alt :: { LMatch GhcPs (LHsExpr GhcPs) } - : pat alt_rhs {%ams (sLL $1 $> (Match { m_ctxt = CaseAlt - , m_pats = [$1] - , m_grhss = snd $ unLoc $2 })) + : pat alt_rhs {%ams (sLL $1 $> (Match { m_ext = noExt + , m_ctxt = CaseAlt + , m_pats = [$1] + , m_grhss = snd $ unLoc $2 })) (fst $ unLoc $2)} alt_rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, - GRHSs (unLoc $1) (snd $ unLoc $2)) } + GRHSs noExt (unLoc $1) (snd $ unLoc $2)) } ralt :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } : '->' exp {% ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) @@ -2923,7 +2926,7 @@ ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } : '|' guardquals '->' exp - {% ams (sL (comb2 $1 $>) $ GRHS (unLoc $2) $4) + {% ams (sL (comb2 $1 $>) $ GRHS noExt (unLoc $2) $4) [mj AnnVbar $1,mu AnnRarrow $3] } -- 'pat' recognises a pattern, including one with a bang at the top @@ -3003,7 +3006,7 @@ qual :: { LStmt GhcPs (LHsExpr GhcPs) } : bindpat '<-' exp {% ams (sLL $1 $> $ mkBindStmt $1 $3) [mu AnnLarrow $2] } | exp { sL1 $1 $ mkBodyStmt $1 } - | 'let' binds {% ams (sLL $1 $>$ LetStmt (snd $ unLoc $2)) + | 'let' binds {% ams (sLL $1 $>$ LetStmt noExt (snd $ unLoc $2)) (mj AnnLet $1:(fst $ unLoc $2)) } ----------------------------------------------------------------------------- diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index f3500014d1..b887440389 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -130,11 +130,11 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) -- *** See Note [The Naming story] in HsDecls **** -mkTyClD :: LTyClDecl n -> LHsDecl n -mkTyClD (L loc d) = L loc (TyClD d) +mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkTyClD (L loc d) = L loc (TyClD noExt d) -mkInstD :: LInstDecl n -> LHsDecl n -mkInstD (L loc d) = L loc (InstD d) +mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkInstD (L loc d) = L loc (InstD noExt d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -149,13 +149,14 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams ; at_defs <- mapM (eitherToP . mkATDefault) at_insts - ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars + ; return (L loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt + , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity , tcdFDs = snd (unLoc fds) , tcdSigs = mkClassOpSigs sigs , tcdMeths = binds - , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs - , tcdFVs = placeHolderNames })) } + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } mkATDefault :: LTyFamInstDecl GhcPs -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs) @@ -169,10 +170,13 @@ mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = rhs } <- e = do { tvs <- checkTyVars (text "default") equalsDots tc pats - ; return (L loc (FamEqn { feqn_tycon = tc + ; return (L loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc , feqn_pats = tvs , feqn_fixity = fixity , feqn_rhs = rhs })) } +mkATDefault (L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" +mkATDefault (L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" mkTyData :: SrcSpan -> NewOrData @@ -187,11 +191,10 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, + ; return (L loc (DataDecl { tcdDExt = noExt, + tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, - tcdDataDefn = defn, - tcdDataCusk = placeHolder, - tcdFVs = placeHolderNames })) } + tcdDataDefn = defn })) } mkDataDefn :: NewOrData -> Maybe (Located CType) @@ -203,7 +206,8 @@ mkDataDefn :: NewOrData mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt - ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + ; return (HsDataDefn { dd_ext = noExt + , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = cxt , dd_cons = data_cons , dd_kindSig = ksig @@ -218,9 +222,10 @@ mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams - ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars + ; return (L loc (SynDecl { tcdSExt = noExt + , tcdLName = tc, tcdTyVars = tyvars , tcdFixity = fixity - , tcdRhs = rhs, tcdFVs = placeHolderNames })) } + , tcdRhs = rhs })) } mkTyFamInstEqn :: LHsType GhcPs -> LHsType GhcPs @@ -228,7 +233,8 @@ mkTyFamInstEqn :: LHsType GhcPs mkTyFamInstEqn lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; return (mkHsImplicitBndrs - (FamEqn { feqn_tycon = tc + (FamEqn { feqn_ext = noExt + , feqn_tycon = tc , feqn_pats = tparams , feqn_fixity = fixity , feqn_rhs = rhs }), @@ -246,17 +252,18 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_ = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataFamInstD (DataFamInstDecl (mkHsImplicitBndrs - (FamEqn { feqn_tycon = tc - , feqn_pats = tparams + ; return (L loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs + (FamEqn { feqn_ext = noExt + , feqn_tycon = tc + , feqn_pats = tparams , feqn_fixity = fixity - , feqn_rhs = defn }))))) } + , feqn_rhs = defn }))))) } mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst loc eqn - = return (L loc (TyFamInstD (TyFamInstDecl eqn))) + = return (L loc (TyFamInstD noExt (TyFamInstDecl eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs @@ -268,7 +275,9 @@ mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams - ; return (L loc (FamDecl (FamilyDecl{ fdInfo = info, fdLName = tc + ; return (L loc (FamDecl noExt (FamilyDecl + { fdExt = noExt + , fdInfo = info, fdLName = tc , fdTyVars = tyvars , fdFixity = fixity , fdResultSig = ksig @@ -291,13 +300,14 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(L loc expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) + = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) + = SpliceD noExt (SpliceDecl noExt (L loc splice) ExplicitSplice) | otherwise - = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) + = SpliceD noExt (SpliceDecl noExt (L loc (mkUntypedSplice NoParens lexpr)) + ImplicitSplice) mkRoleAnnotDecl :: SrcSpan -> Located RdrName -- type being annotated @@ -305,7 +315,7 @@ mkRoleAnnotDecl :: SrcSpan -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles - ; return $ L loc $ RoleAnnotDecl tycon roles' } + ; return $ L loc $ RoleAnnotDecl noExt tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type @@ -343,10 +353,10 @@ cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] cvTopDecls decls = go (fromOL decls) where go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] - go [] = [] - go (L l (ValD b) : ds) = L l' (ValD b') : go ds' + go [] = [] + go (L l (ValD x b) : ds) = L l' (ValD x b') : go ds' where (L l' b', ds') = getMonoBind (L l b) ds - go (d : ds) = d : go ds + go (d : ds) = d : go ds -- Declaration list may only contain value bindings and signatures. cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) @@ -364,7 +374,7 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs) cvBindsAndSigs fb = go (fromOL fb) where go [] = return (emptyBag, [], [], [], [], []) - go (L l (ValD b) : ds) + go (L l (ValD _ b) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } where @@ -372,17 +382,17 @@ cvBindsAndSigs fb = go (fromOL fb) go (L l decl : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds ; case decl of - SigD s + SigD _ s -> return (bs, L l s : ss, ts, tfis, dfis, docs) - TyClD (FamDecl t) + TyClD _ (FamDecl _ t) -> return (bs, ss, L l t : ts, tfis, dfis, docs) - InstD (TyFamInstD { tfid_inst = tfi }) + InstD _ (TyFamInstD { tfid_inst = tfi }) -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) - InstD (DataFamInstD { dfid_inst = dfi }) + InstD _ (DataFamInstD { dfid_inst = dfi }) -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) - DocD d + DocD _ d -> return (bs, ss, ts, tfis, dfis, L l d : docs) - SpliceD d + SpliceD _ d -> parseErrorSDoc l $ hang (text "Declaration splices are allowed only" <+> text "at the top level:") @@ -414,12 +424,12 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), = go mtchs1 loc1 binds [] where go mtchs loc - (L loc2 (ValD (FunBind { fun_id = L _ f2, - fun_matches - = MG { mg_alts = L _ mtchs2 } })) : binds) _ + (L loc2 (ValD _ (FunBind { fun_id = L _ f2, + fun_matches + = MG { mg_alts = L _ mtchs2 } })) : binds) _ | f1 == f2 = go (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] - go mtchs loc (doc_decl@(L loc2 (DocD _)) : binds) doc_decls + go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls = let doc_decls' = doc_decl : doc_decls in go mtchs (combineSrcSpans loc loc2) binds doc_decls' go mtchs loc binds doc_decls @@ -437,6 +447,7 @@ has_args ((L _ (Match { m_pats = args })) : _) = not (null args) -- no arguments. This is necessary now that variable bindings -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). +has_args ((L _ (XMatch _)) : _) = panic "has_args" {- ********************************************************************** @@ -561,18 +572,21 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = ; when (null matches) (wrongNumberErr loc) ; return $ mkMatchGroup FromSource matches } where - fromDecl (L loc decl@(ValD (PatBind _ + fromDecl (L loc decl@(ValD _ (PatBind _ pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of - PrefixCon pats -> return $ Match { m_ctxt = ctxt, m_pats = pats + PrefixCon pats -> return $ Match { m_ext = noExt + , m_ctxt = ctxt, m_pats = pats , m_grhss = rhs } where ctxt = FunRhs { mc_fun = ln, mc_fixity = Prefix, mc_strictness = NoSrcStrict } - InfixCon p1 p2 -> return $ Match { m_ctxt = ctxt, m_pats = [p1, p2] + InfixCon p1 p2 -> return $ Match { m_ext = noExt + , m_ctxt = ctxt + , m_pats = [p1, p2] , m_grhss = rhs } where ctxt = FunRhs { mc_fun = ln, mc_fixity = Infix, mc_strictness = NoSrcStrict } @@ -607,7 +621,8 @@ mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] -> ConDecl GhcPs mkConDeclH98 name mb_forall mb_cxt args - = ConDeclH98 { con_name = name + = ConDeclH98 { con_ext = noExt + , con_name = name , con_forall = isJust mb_forall , con_ex_tvs = mb_forall `orElse` [] , con_mb_cxt = mb_cxt @@ -618,7 +633,8 @@ mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -- Always a HsForAllTy -> ConDecl GhcPs mkGadtDecl names ty - = ConDeclGADT { con_names = names + = ConDeclGADT { con_g_ext = noExt + , con_names = names , con_forall = isLHsForAllTy ty , con_qvars = mkHsQTvs tvs , con_mb_cxt = mcxt @@ -752,9 +768,9 @@ checkTyVars pp_what equals_or_where tc tparms -- Check that the name space is correct! chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) - | isRdrTyVar tv = return (L l (KindedTyVar PlaceHolder (L lv tv) k)) + | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k)) chk (L l (HsTyVar _ _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar PlaceHolder (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv))) chk t@(L loc _) = Left (loc, vcat [ text "Unexpected type" <+> quotes (ppr t) @@ -998,7 +1014,7 @@ checkAPat msg loc e0 = do HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt)) ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es - return (ListPat noExt ps placeHolderType Nothing) + return (ListPat noExt ps) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es return (PArrPat noExt ps) @@ -1081,7 +1097,8 @@ checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann return (ann, makeFunBind fun - [L match_span (Match { m_ctxt = FunRhs { mc_fun = fun + [L match_span (Match { m_ext = noExt + , m_ctxt = FunRhs { mc_fun = fun , mc_fixity = is_infix , mc_strictness = strictness } , m_pats = ps @@ -1348,39 +1365,44 @@ checkCmdLStmt :: ExprLStmt GhcPs -> P (CmdLStmt GhcPs) checkCmdLStmt = locMap checkCmdStmt checkCmdStmt :: SrcSpan -> ExprStmt GhcPs -> P (CmdStmt GhcPs) -checkCmdStmt _ (LastStmt e s r) = - checkCommand e >>= (\c -> return $ LastStmt c s r) -checkCmdStmt _ (BindStmt pat e b f t) = - checkCommand e >>= (\c -> return $ BindStmt pat c b f t) -checkCmdStmt _ (BodyStmt e t g ty) = - checkCommand e >>= (\c -> return $ BodyStmt c t g ty) -checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds +checkCmdStmt _ (LastStmt x e s r) = + checkCommand e >>= (\c -> return $ LastStmt x c s r) +checkCmdStmt _ (BindStmt x pat e b f) = + checkCommand e >>= (\c -> return $ BindStmt x pat c b f) +checkCmdStmt _ (BodyStmt x e t g) = + checkCommand e >>= (\c -> return $ BodyStmt x c t g) +checkCmdStmt _ (LetStmt x bnds) = return $ LetStmt x bnds checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do ss <- mapM checkCmdLStmt stmts - return $ stmt { recS_stmts = ss } + return $ stmt { recS_ext = noExt, recS_stmts = ss } +checkCmdStmt _ (XStmtLR _) = panic "checkCmdStmt" checkCmdStmt l stmt = cmdStmtFail l stmt checkCmdMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> P (MatchGroup GhcPs (LHsCmd GhcPs)) checkCmdMatchGroup mg@(MG { mg_alts = L l ms }) = do ms' <- mapM (locMap $ const convert) ms - return $ mg { mg_alts = L l ms' } + return $ mg { mg_ext = noExt, mg_alts = L l ms' } where convert match@(Match { m_grhss = grhss }) = do grhss' <- checkCmdGRHSs grhss - return $ match { m_grhss = grhss'} + return $ match { m_ext = noExt, m_grhss = grhss'} + convert (XMatch _) = panic "checkCmdMatchGroup.XMatch" +checkCmdMatchGroup (XMatchGroup {}) = panic "checkCmdMatchGroup" checkCmdGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> P (GRHSs GhcPs (LHsCmd GhcPs)) -checkCmdGRHSs (GRHSs grhss binds) = do +checkCmdGRHSs (GRHSs x grhss binds) = do grhss' <- mapM checkCmdGRHS grhss - return $ GRHSs grhss' binds + return $ GRHSs x grhss' binds +checkCmdGRHSs (XGRHSs _) = panic "checkCmdGRHSs" checkCmdGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> P (LGRHS GhcPs (LHsCmd GhcPs)) checkCmdGRHS = locMap $ const convert where - convert (GRHS stmts e) = do + convert (GRHS x stmts e) = do c <- checkCommand e -- cmdStmts <- mapM checkCmdLStmt stmts - return $ GRHS {- cmdStmts -} stmts c + return $ GRHS x {- cmdStmts -} stmts c + convert (XGRHS _) = panic "checkCmdGRHS" cmdFail :: SrcSpan -> HsExpr GhcPs -> P a @@ -1486,10 +1508,10 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = funcTarget = CFunction (StaticTarget esrc entity' Nothing True) importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) - returnSpec spec = return $ ForD $ ForeignImport - { fd_name = v + returnSpec spec = return $ ForD noExt $ ForeignImport + { fd_i_ext = noExt + , fd_name = v , fd_sig_ty = ty - , fd_co = noForeignImportCoercionYet , fd_fi = spec } @@ -1559,9 +1581,8 @@ mkExport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) - = return $ ForD $ - ForeignExport { fd_name = v, fd_sig_ty = ty - , fd_co = noForeignExportCoercionYet + = return $ ForD noExt $ + ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) (L le esrc) } where @@ -1594,11 +1615,11 @@ mkModuleImpExp (L l specname) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs . L l <$> nameT - ImpExpAll -> IEThingAll . L l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) []) + -> return $ IEVar noExt (L l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExt . L l <$> nameT + ImpExpAll -> IEThingAll noExt . L l <$> nameT + ImpExpList xs -> + (\newName -> IEThingWith noExt (L l newName) NoIEWildcard (wrapped xs) []) <$> nameT ImpExpAllWith xs -> do allowed <- extension patternSynonymsEnabled @@ -1608,7 +1629,8 @@ mkModuleImpExp (L l specname) subs = pos = maybe NoIEWildcard IEWildcard (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs - in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT + in (\newName + -> IEThingWith noExt (L l newName) pos ies []) <$> nameT else parseErrorSDoc l (text "Illegal export form (use PatternSynonyms to enable)") where @@ -1645,7 +1667,7 @@ mkTypeImpExp name = checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) checkImportSpec ie@(L _ specs) = - case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of + case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of [] -> return ie (l:_) -> importSpecError l where diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 4ce3a58539..d7790ca419 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -299,7 +299,7 @@ rnValBindsRHS ctxt (ValBinds _ mbinds sigs) ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus - ; let patsyn_fvs = foldr (unionNameSet . psb_fvs) emptyNameSet $ + ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ getPatSynBinds anal_binds -- The uses in binds_w_dus for PatSynBinds do not include -- variables used in the patsyn builders; see @@ -705,11 +705,10 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name -- As well as dependency analysis, we need these for the -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - bind' = bind{ psb_ext = noExt - , psb_args = details' + bind' = bind{ psb_args = details' , psb_def = pat' , psb_dir = dir' - , psb_fvs = fvs' } + , psb_ext = fvs' } selector_names = case details' of RecCon names -> map (unLoc . recordPatSynSelectorId) names @@ -1155,6 +1154,7 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin new_ms, ms_fvs) } +rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup" rnMatch :: Outputable (body GhcPs) => HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) @@ -1174,8 +1174,9 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) -> mf { mc_fun = L lf funid } _ -> ctxt - ; return (Match { m_ctxt = mf', m_pats = pats' + ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats' , m_grhss = grhss'}, grhss_fvs ) }} +rnMatch' _ _ (XMatch _) = panic "rnMatch'" emptyCaseErr :: HsMatchContext Name -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) @@ -1198,10 +1199,11 @@ rnGRHSs :: HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> GRHSs GhcPs (Located (body GhcPs)) -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) -rnGRHSs ctxt rnBody (GRHSs grhss (L l binds)) +rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) = rnLocalBindsAndThen binds $ \ binds' _ -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss - return (GRHSs grhss' (L l binds'), fvGRHSs) + return (GRHSs noExt grhss' (L l binds'), fvGRHSs) +rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs" rnGRHS :: HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) @@ -1213,7 +1215,7 @@ rnGRHS' :: HsMatchContext Name -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> GRHS GhcPs (Located (body GhcPs)) -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) -rnGRHS' ctxt rnBody (GRHS guards rhs) +rnGRHS' ctxt rnBody (GRHS _ guards rhs) = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> rnBody rhs @@ -1221,14 +1223,15 @@ rnGRHS' ctxt rnBody (GRHS guards rhs) ; unless (pattern_guards_allowed || is_standard_guard guards') (addWarn NoReason (nonStdGuardErr guards')) - ; return (GRHS guards' rhs', fvs) } + ; return (GRHS noExt guards' rhs', fvs) } where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [] = True - is_standard_guard [L _ (BodyStmt _ _ _ _)] = True - is_standard_guard _ = False + is_standard_guard [] = True + is_standard_guard [L _ (BodyStmt {})] = True + is_standard_guard _ = False +rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'" {- ********************************************************* diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 4fe4102891..8478ab0322 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -594,16 +594,20 @@ methodNamesMatch (MG { mg_alts = L _ ms }) = plusFVs (map do_one ms) where do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss + do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch" +methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch" ------------------------------------------------- -- gaw 2004 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars -methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) +methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) +methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs" ------------------------------------------------- methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds -methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs +methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs +methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS" --------------------------------------------------- methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars @@ -614,17 +618,18 @@ methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars -methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd -methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd -methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd +methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName -methodNamesStmt (LetStmt {}) = emptyFVs -methodNamesStmt (ParStmt {}) = emptyFVs -methodNamesStmt (TransStmt {}) = emptyFVs -methodNamesStmt ApplicativeStmt{} = emptyFVs +methodNamesStmt (LetStmt {}) = emptyFVs +methodNamesStmt (ParStmt {}) = emptyFVs +methodNamesStmt (TransStmt {}) = emptyFVs +methodNamesStmt ApplicativeStmt{} = emptyFVs -- ParStmt and TransStmt can't occur in commands, but it's not -- convenient to error here so we just do what's convenient +methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt" {- ************************************************************************ @@ -823,14 +828,14 @@ rnStmt :: Outputable (body GhcPs) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside +rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName ; (thing, fvs3) <- thing_inside [] - ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs3) } + ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside +rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside = do { (body', fv_expr) <- rnBody body ; (then_op, fvs1) <- lookupStmtName ctxt thenMName ; (guard_op, fvs2) <- if isListCompExpr ctxt @@ -840,11 +845,10 @@ rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside [] - ; return (([(L loc (BodyStmt body' - then_op guard_op placeHolderType), fv_expr)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } + ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside +rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside = do { (body', fv_expr) <- rnBody body -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName @@ -866,17 +870,18 @@ 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 noExt pat' body' bind_op fail_op) , fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside +rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') - ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } } + ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing) + , fvs) } } rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName @@ -908,12 +913,12 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } -rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside +rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside - ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing) + ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form @@ -946,15 +951,18 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for -- See Note [TransStmt binder map] in HsExpr ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) - ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map + ; return (([(L loc (TransStmt { trS_ext = noExt + , 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_fmap = fmap_op }), fvs2)], thing), all_fvs) } rnStmt _ _ (L _ ApplicativeStmt{}) _ = panic "rnStmt: ApplicativeStmt" +rnStmt _ _ (L _ XStmtLR{}) _ = + panic "rnStmt: XStmtLR" + rnParallelStmts :: forall thing. HsStmtContext Name -> SyntaxExpr GhcRn -> [ParStmtBlock GhcPs GhcPs] @@ -1099,7 +1107,7 @@ rnRecStmtsAndThen rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> + (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig _ s)) -> (L loc s) : acc _ -> acc) acc sigs @@ -1114,25 +1122,24 @@ rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv -- so we don't bother to compute it accurately in the other cases -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] -rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) - = return [(L loc (BodyStmt body a b c), emptyFVs)] +rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) + = return [(L loc (BodyStmt noExt body a b), emptyFVs)] -rn_rec_stmt_lhs _ (L loc (LastStmt body noret a)) - = return [(L loc (LastStmt body noret a), emptyFVs)] +rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a)) + = return [(L loc (LastStmt noExt body noret a), emptyFVs)] -rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t)) +rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt pat' body a b t), - fv_pat)] + return [(L loc (BindStmt noExt pat' body a b), fv_pat)] -rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds {})))) +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds x binds)))) +rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt (L l (HsValBinds x binds'))), + return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))), -- Warning: this is bogus; see function invariant emptyFVs )] @@ -1150,10 +1157,12 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (EmptyLocalBinds _)))) +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (XHsLocalBindsLR _)))) +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _)))) = panic "rn_rec_stmt LetStmt XHsLocalBindsLR" +rn_rec_stmt_lhs _ (L _ (XStmtLR _)) + = panic "rn_rec_stmt XStmtLR" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv -> [LStmt GhcPs body] @@ -1178,19 +1187,19 @@ rn_rec_stmt :: (Outputable (body GhcPs)) => -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _) +rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _) = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupSyntaxName returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, - L loc (LastStmt body' noret ret_op))] } + L loc (LastStmt noExt body' noret ret_op))] } -rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _) +rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _) = do { (body', fvs) <- rnBody body ; (then_op, fvs1) <- lookupSyntaxName thenMName ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] } + L loc (BodyStmt noExt body' then_op noSyntaxExpr))] } -rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat) +rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat) = do { (body', fv_expr) <- rnBody body ; (bind_op, fvs1) <- lookupSyntaxName bindMName @@ -1202,17 +1211,17 @@ 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 noExt pat' body' bind_op fail_op))] } -rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds {}))), _) +rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds x binds'))), _) +rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' -- fixities and unused are handled above in rnRecStmtsAndThen ; let fvs = allUses du_binds ; return [(duDefs du_binds, fvs, emptyNameSet, - L loc (LetStmt (L l (HsValBinds x binds'))))] } + L loc (LetStmt noExt (L l (HsValBinds x binds'))))] } -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) @@ -1224,15 +1233,18 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ (L _ (LetStmt (L _ (XHsLocalBindsLR _))), _) +rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _) = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR" -rn_rec_stmt _ _ (L _ (LetStmt (L _ (EmptyLocalBinds _))), _) +rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) +rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _) + = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt) + rn_rec_stmts :: Outputable (body GhcPs) => (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] @@ -1664,16 +1676,16 @@ stmtTreeToStmts -- In the spec, but we do it here rather than in the desugarer, -- because we need the typechecker to typecheck the <$> form rather than -- the bind form, which would give rise to a Monad constraint. -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_)) +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _)) tail _tail_fvs | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail -- See Note [ApplicativeDo and strict patterns] - = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs False] False tail' -stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt rhs _ _ _),_)) + = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail' +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_)) tail _tail_fvs | (False,tail') <- needJoin monad_names tail = mkApplicativeStmt ctxt - [ApplicativeArgOne nlWildPatName rhs True] False tail' + [ApplicativeArgOne noExt nlWildPatName rhs True] False tail' stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = return (s : tail, emptyNameSet) @@ -1691,10 +1703,10 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' return (stmts, unionNameSets (fvs:fvss)) where - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) = - return (ApplicativeArgOne pat exp False, emptyFVs) - stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt exp _ _ _), _)) = - return (ApplicativeArgOne nlWildPatName exp True, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _)) + = return (ApplicativeArgOne noExt pat exp False, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) = + return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs) stmtTreeArg ctxt tail_fvs tree = do let stmts = flattenStmtTree tree pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) @@ -1710,7 +1722,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do | otherwise -> do (ret,fvs) <- lookupStmtNamePoly ctxt returnMName return (HsApp noExt (noLoc ret) tup, fvs) - return ( ApplicativeArgMany stmts' mb_ret pat + return ( ApplicativeArgMany noExt stmts' mb_ret pat , fvs1 `plusFV` fvs2) @@ -1764,7 +1776,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) pvars = mkNameSet (collectStmtBinders (unLoc stmt)) isStrictPatternBind :: ExprLStmt GhcRn -> Bool - isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat + isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat isStrictPatternBind _ = False {- @@ -1852,9 +1864,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- strict patterns though; splitSegments expects that if we return Just -- then we have actually done some splitting. Otherwise it will go into -- an infinite loop (#14163). - go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest) + go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest) | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) - = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep) + = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep) bndrs' rest where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) -- If we encounter a LetStmt that doesn't depend on a BindStmt in this @@ -1862,9 +1874,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- grouping more BindStmts. -- TODO: perhaps we shouldn't do this if there are any strict bindings, -- because we might be moving evaluation earlier. - go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest) + go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest) | isEmptyNameSet (bndrs `intersectNameSet` fvs) - = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest + = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest go _ [] _ _ = Nothing go _ [_] _ _ = Nothing go lets indep _ stmts = Just (reverse lets, reverse indep, stmts) @@ -1897,10 +1909,9 @@ mkApplicativeStmt ctxt args need_join body_stmts ; return (Just join_op, fvs) } else return (Nothing, emptyNameSet) - ; let applicative_stmt = noLoc $ ApplicativeStmt + ; let applicative_stmt = noLoc $ ApplicativeStmt noExt (zip (fmap_op : repeat ap_op) args) mb_join - placeHolderType ; return ( applicative_stmt : body_stmts , fvs1 `plusFV` fvs2 `plusFV` fvs3) } @@ -1910,9 +1921,9 @@ needJoin :: MonadNames -> [ExprLStmt GhcRn] -> (Bool, [ExprLStmt GhcRn]) needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg -needJoin monad_names [L loc (LastStmt e _ t)] +needJoin monad_names [L loc (LastStmt _ e _ t)] | Just arg <- isReturnApp monad_names e = - (False, [L loc (LastStmt arg True t)]) + (False, [L loc (LastStmt noExt arg True t)]) needJoin _monad_names stmts = (True, stmts) -- | @Just e@, if the expression is @return e@ or @return $ e@, @@ -1974,7 +1985,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) where check_do -- Expect BodyStmt, and change it to LastStmt = case stmt of - BodyStmt e _ _ _ -> return (L loc (mkLastStmt e)) + BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a -- LastStmt directly (unlike the parser) _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } @@ -2011,6 +2022,7 @@ pprStmtCat (LetStmt {}) = text "let" pprStmtCat (RecStmt {}) = text "rec" pprStmtCat (ParStmt {}) = text "parallel" pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" +pprStmtCat (XStmtLR {}) = panic "pprStmtCat: XStmtLR" ------------ emptyInvalid :: Validity -- Payload is the empty document @@ -2047,8 +2059,8 @@ okPatGuardStmt stmt ------------- okParStmt dflags ctxt stmt = case stmt of - LetStmt (L _ (HsIPBinds {})) -> emptyInvalid - _ -> okStmt dflags ctxt stmt + LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid + _ -> okStmt dflags ctxt stmt ---------------- okDoStmt dflags ctxt stmt @@ -2077,6 +2089,7 @@ okCompStmt dflags _ stmt RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ApplicativeStmt {} -> emptyInvalid + XStmtLR{} -> panic "okCompStmt" ---------------- okPArrStmt dflags _ stmt @@ -2091,6 +2104,7 @@ okPArrStmt dflags _ stmt RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ApplicativeStmt {} -> emptyInvalid + XStmtLR{} -> panic "okPArrStmt" --------- checkTupleSection :: [LHsTupArg GhcPs] -> RnM () diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 5458469c44..60f87fcd1f 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -261,7 +261,9 @@ Running generateModules from Trac #14693 with DEPTH=16, WIDTH=30 finishes in rnImportDecl :: Module -> LImportDecl GhcPs -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod - (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg + (L loc decl@(ImportDecl { ideclExt = noExt + , ideclName = loc_imp_mod_name + , ideclPkgQual = mb_pkg , ideclSource = want_boot, ideclSafe = mod_safe , ideclQualified = qual_only, ideclImplicit = implicit , ideclAs = as_mod, ideclHiding = imp_details })) @@ -370,10 +372,11 @@ rnImportDecl this_mod _ -> return () ) - let new_imp_decl = L loc (decl { ideclSafe = mod_safe' + let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe' , ideclHiding = new_imp_details }) return (new_imp_decl, gbl_env, imports, mi_hpc iface) +rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl" -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. @@ -723,10 +726,10 @@ getLocalNonValBinders fixity_env new_assoc _ (L _ (TyFamInstD {})) = return ([], []) -- type instances don't bind new names - new_assoc overload_ok (L _ (DataFamInstD d)) + new_assoc overload_ok (L _ (DataFamInstD _ d)) = do { (avail, flds) <- new_di overload_ok Nothing d ; return ([avail], flds) } - new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty + new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty , cid_datafam_insts = adts }))) | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr @@ -736,6 +739,8 @@ getLocalNonValBinders fixity_env | otherwise = return ([], []) -- Do not crash on ill-formed instances -- Eg instance !Show Int Trac #3811c + new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc" + new_assoc _ (L _ (XInstDecl _)) = panic "new_assoc" new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) @@ -749,10 +754,12 @@ getLocalNonValBinders fixity_env -- main_name is not bound here! fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) } + new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di" new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d +getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders" newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" @@ -935,12 +942,12 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) lookup_ie ie = handle_bad_import $ do case ie of - IEVar (L l n) -> do + IEVar _ (L l n) -> do (name, avail, _) <- lookup_name $ ieWrappedName n - return ([(IEVar (L l (replaceWrappedName n name)), + return ([(IEVar noExt (L l (replaceWrappedName n name)), trimAvail avail name)], []) - IEThingAll (L l tc) -> do + IEThingAll _ (L l tc) -> do (name, avail, mb_parent) <- lookup_name $ ieWrappedName tc let warns = case avail of Avail {} -- e.g. f(..) @@ -956,7 +963,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) | otherwise -> [] - renamed_ie = IEThingAll (L l (replaceWrappedName tc name)) + renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name)) sub_avails = case avail of Avail {} -> [] AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)] @@ -966,7 +973,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns) -- associated type - IEThingAbs (L l tc') + IEThingAbs _ (L l tc') | want_hiding -- hiding ( C ) -- Here the 'C' can be a data constructor -- *or* a type/class, or even both @@ -982,7 +989,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) return ([mkIEThingAbs tc' l nameAvail] , []) - IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs -> + IEThingWith _ (L l rdr_tc) wc rdr_ns' rdr_fs -> ASSERT2(null rdr_fs, ppr rdr_fs) do (name, AvailTC _ ns subflds, mb_parent) <- lookup_name (ieWrappedName rdr_tc) @@ -1000,8 +1007,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) case mb_parent of -- non-associated ty/cls Nothing - -> return ([(IEThingWith (L l name') wc childnames' - childflds, + -> return ([(IEThingWith noExt (L l name') wc childnames' + childflds, AvailTC name (name:map unLoc childnames) (map unLoc childflds))], []) where name' = replaceWrappedName rdr_tc name @@ -1009,10 +1016,10 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -- childnames' = postrn_ies childnames -- associated ty Just parent - -> return ([(IEThingWith (L l name') wc childnames' + -> return ([(IEThingWith noExt (L l name') wc childnames' childflds, AvailTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith (L l name') wc childnames' + (IEThingWith noExt (L l name') wc childnames' childflds, AvailTC parent [name] [])], []) @@ -1025,9 +1032,10 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where mkIEThingAbs tc l (n, av, Nothing ) - = (IEThingAbs (L l (replaceWrappedName tc n)), trimAvail av n) + = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n) mkIEThingAbs tc l (n, _, Just parent) - = (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] []) + = (IEThingAbs noExt (L l (replaceWrappedName tc n)) + , AvailTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of BadImport | want_hiding -> return ([], [BadImportW]) @@ -1071,8 +1079,8 @@ gresFromIE decl_spec (L loc ie, avail) = gresFromAvail prov_fn avail where is_explicit = case ie of - IEThingAll (L _ name) -> \n -> n == ieWrappedName name - _ -> \_ -> True + IEThingAll _ (L _ name) -> \n -> n == ieWrappedName name + _ -> \_ -> True prov_fn name = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) where @@ -1328,13 +1336,13 @@ findImportUsage imports used_gres _other -> emptyNameSet -- No explicit import list => no unused-name list add_unused :: IE GhcRn -> NameSet -> NameSet - add_unused (IEVar (L _ n)) acc + add_unused (IEVar _ (L _ n)) acc = add_unused_name (ieWrappedName n) acc - add_unused (IEThingAbs (L _ n)) acc + add_unused (IEThingAbs _ (L _ n)) acc = add_unused_name (ieWrappedName n) acc - add_unused (IEThingAll (L _ n)) acc + add_unused (IEThingAll _ (L _ n)) acc = add_unused_all (ieWrappedName n) acc - add_unused (IEThingWith (L _ p) wc ns fs) acc = + add_unused (IEThingWith _ (L _ p) wc ns fs) acc = add_wc_all (add_unused_with (ieWrappedName p) xs acc) where xs = map (ieWrappedName . unLoc) ns ++ map (flSelector . unLoc) fs @@ -1358,6 +1366,7 @@ findImportUsage imports used_gres -- If you use 'signum' from Num, then the user may well have -- imported Num(signum). We don't want to complain that -- Num is not itself mentioned. Hence the two cases in add_unused_with. + unused_decl (L _ (XImportDecl _)) = panic "unused_decl" extendImportMap :: GlobalRdrElt -> ImportMap -> ImportMap -- For each of a list of used GREs, find all the import decls that brought @@ -1478,25 +1487,25 @@ printMinimalImports imports_w_usage -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. to_ie _ (Avail n) - = [IEVar (to_ie_post_rn $ noLoc n)] + = [IEVar noExt (to_ie_post_rn $ noLoc n)] to_ie _ (AvailTC n [m] []) - | n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)] + | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)] to_ie iface (AvailTC n ns fs) = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface , x == n , x `elem` xs -- Note [Partial export] ] of - [xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)] + [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)] | otherwise -> - [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard + [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) (map noLoc fs)] -- Note [Overloaded field import] _other | all_non_overloaded fs - -> map (IEVar . to_ie_post_rn_var . noLoc) $ ns + -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns ++ map flSelector fs | otherwise -> - [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard + [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) (map noLoc fs)] where @@ -1637,10 +1646,10 @@ dodgyMsg kind tc ie quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", text "but it has none" ] -dodgyMsgInsert :: forall p . IdP p -> IE p -dodgyMsgInsert tc = IEThingAll ii +dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) +dodgyMsgInsert tc = IEThingAll noExt ii where - ii :: LIEWrappedName (IdP p) + ii :: LIEWrappedName (IdP (GhcPass p)) ii = noLoc (IEName $ noLoc tc) diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 320a34b4bf..8f7c2e2309 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -471,19 +471,17 @@ rnPatAndThen mk (ConPatIn con stuff) -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. = case unLoc con == nameRdrName (dataConName nilDataCon) of True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists - ; if ol_flag then rnPatAndThen mk (ListPat noExt [] - placeHolderType Nothing) + ; if ol_flag then rnPatAndThen mk (ListPat noExt []) else rnConPatAndThen mk con stuff} False -> rnConPatAndThen mk con stuff -rnPatAndThen mk (ListPat x pats _ _) +rnPatAndThen mk (ListPat _ pats) = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists ; pats' <- rnLPatsAndThen mk pats ; case opt_OverloadedLists of True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName - ; return (ListPat x pats' placeHolderType - (Just (placeHolderType, to_list_name)))} - False -> return (ListPat x pats' placeHolderType Nothing) } + ; return (ListPat (Just to_list_name) pats')} + False -> return (ListPat Nothing pats') } rnPatAndThen mk (PArrPat x pats) = do { pats' <- rnLPatsAndThen mk pats diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index d242ac08c6..065e72f202 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -198,7 +198,8 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, last_tcg_env <- getGblEnv ; -- (I) Compute the results and return - let {rn_group = HsGroup { hs_valds = rn_val_decls, + let {rn_group = HsGroup { hs_ext = noExt, + hs_valds = rn_val_decls, hs_splcds = rn_splice_decls, hs_tyclds = rn_tycl_decls, hs_derivds = rn_deriv_decls, @@ -230,6 +231,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, traceRn "finish Dus" (ppr src_dus ) ; return (final_tcg_env, rn_group) }}}} +rnSrcDecls (XHsGroup _) = panic "rnSrcDecls" addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv -- This function could be defined lower down in the module hierarchy, @@ -292,15 +294,16 @@ rnSrcWarnDecls bndr_set decls' sig_ctxt = TopSigCtxt bndr_set - rn_deprec (Warning rdr_names txt) + rn_deprec (Warning _ rdr_names txt) -- ensures that the names are defined locally = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) rdr_names ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } + rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls" what = text "deprecation" - warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns) + warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] @@ -325,13 +328,14 @@ dupWarnDecl (L loc _) rdr_name -} rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) -rnAnnDecl ann@(HsAnnotation s provenance expr) +rnAnnDecl ann@(HsAnnotation _ s provenance expr) = addErrCtxt (annCtxt ann) $ do { (provenance', provenance_fvs) <- rnAnnProvenance provenance ; (expr', expr_fvs) <- setStage (Splice Untyped) $ rnLExpr expr - ; return (HsAnnotation s provenance' expr', + ; return (HsAnnotation noExt s provenance' expr', provenance_fvs `plusFV` expr_fvs) } +rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl" rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) @@ -348,11 +352,12 @@ rnAnnProvenance provenance = do -} rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) -rnDefaultDecl (DefaultDecl tys) +rnDefaultDecl (DefaultDecl _ tys) = do { (tys', fvs) <- rnLHsTypes doc_str tys - ; return (DefaultDecl tys', fvs) } + ; return (DefaultDecl noExt tys', fvs) } where doc_str = DefaultDeclCtx +rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl" {- ********************************************************* @@ -372,21 +377,23 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) ; let unitId = thisPackage $ hsc_dflags topEnv spec' = patchForeignImport unitId spec - ; return (ForeignImport { fd_name = name', fd_sig_ty = ty' - , fd_co = noForeignImportCoercionYet + ; return (ForeignImport { fd_i_ext = noExt + , fd_name = name', fd_sig_ty = ty' , fd_fi = spec' }, fvs) } rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) = do { name' <- lookupLocatedOccRn name ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty - ; return (ForeignExport { fd_name = name', fd_sig_ty = ty' - , fd_co = noForeignExportCoercionYet + ; return (ForeignExport { fd_e_ext = noExt + , fd_name = name', fd_sig_ty = ty' , fd_fe = spec } , fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module +rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl" + -- | For Windows DLLs we need to know what packages imported symbols are from -- to generate correct calls. Imported symbols are tagged with the current -- package, so if they get inlined across a package boundry we'll still @@ -420,17 +427,19 @@ patchCCallTarget unitId callTarget = rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi - ; return (TyFamInstD { tfid_inst = tfi' }, fvs) } + ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) } rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi - ; return (DataFamInstD { dfid_inst = dfi' }, fvs) } + ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) } rnSrcInstDecl (ClsInstD { cid_inst = cid }) = do { traceRn "rnSrcIstDecl {" (ppr cid) ; (cid', fvs) <- rnClsInstDecl cid ; traceRn "rnSrcIstDecl end }" empty - ; return (ClsInstD { cid_inst = cid' }, fvs) } + ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) } + +rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl" -- | Warn about non-canonical typeclass instance declarations -- @@ -577,7 +586,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- binding, and return @Just rhsName@ if this is the case isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} - | GRHSs [L _ (GRHS [] body)] lbinds <- grhss + | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss , L _ (EmptyLocalBinds _) <- lbinds , L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName isAliasMG _ = Nothing @@ -660,7 +669,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; let all_fvs = meth_fvs `plusFV` more_fvs `plusFV` inst_fvs - ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds' + ; return (ClsInstDecl { cid_ext = noExt + , cid_poly_ty = inst_ty', cid_binds = mbinds' , cid_sigs = uprags', cid_tyfam_insts = ats' , cid_overlap_mode = oflag , cid_datafam_insts = adts' }, @@ -675,6 +685,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- the instance context after renaming. This is a bit -- strange, but should not matter (and it would be more work -- to remove the context). +rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl" rnFamInstEqn :: HsDocContext -> Maybe (Name, [Name]) -- Nothing => not associated @@ -758,14 +769,17 @@ rnFamInstEqn doc mb_cls rhs_kvars all_fvs = fvs `addOneFV` unLoc tycon' -- type instance => use, hence addOneFV - ; return (HsIB { hsib_vars = all_ibs - , hsib_closed = True + ; return (HsIB { hsib_ext = HsIBRn { hsib_vars = all_ibs + , hsib_closed = True } , hsib_body - = FamEqn { feqn_tycon = tycon' + = FamEqn { feqn_ext = noExt + , feqn_tycon = tycon' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = payload' } }, all_fvs) } +rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn" +rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn" rnTyFamInstDecl :: Maybe (Name, [Name]) -> TyFamInstDecl GhcPs @@ -781,6 +795,8 @@ rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_rhs = rhs }}) = do { rhs_kvs <- extractHsTyRdrTyVarsKindVars rhs ; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn } +rnTyFamInstEqn _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn" +rnTyFamInstEqn _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn" rnTyFamDefltEqn :: Name -> TyFamDefltEqn GhcPs @@ -793,12 +809,14 @@ rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ -> do { tycon' <- lookupFamInstName (Just cls) tycon ; (rhs', fvs) <- rnLHsType ctx rhs - ; return (FamEqn { feqn_tycon = tycon' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tycon' , feqn_pats = tyvars' , feqn_fixity = fixity , feqn_rhs = rhs' }, fvs) } } where ctx = TyFamilyCtx tycon +rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn" rnDataFamInstDecl :: Maybe (Name, [Name]) -> DataFamInstDecl GhcPs @@ -810,6 +828,10 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = ; (eqn', fvs) <- rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } +rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _))) + = panic "rnDataFamInstDecl" +rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _)) + = panic "rnDataFamInstDecl" -- Renaming of the associated types in instances. @@ -937,14 +959,15 @@ Here 'k' is in scope in the kind signature, just like 'x'. -} rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) -rnSrcDerivDecl (DerivDecl ty deriv_strat overlap) +rnSrcDerivDecl (DerivDecl _ ty deriv_strat overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $ illegalDerivStrategyErr $ fmap unLoc deriv_strat ; (ty', fvs) <- rnHsSigWcType DerivDeclCtx ty - ; return (DerivDecl ty' deriv_strat overlap, fvs) } + ; return (DerivDecl noExt ty' deriv_strat overlap, fvs) } +rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl" standaloneDerivErr :: SDoc standaloneDerivErr @@ -960,12 +983,13 @@ standaloneDerivErr -} rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) -rnHsRuleDecls (HsRules src rules) +rnHsRuleDecls (HsRules _ src rules) = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules - ; return (HsRules src rn_rules,fvs) } + ; return (HsRules noExt src rn_rules,fvs) } +rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls" rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) -rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) +rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs) = do { let rdr_names_w_loc = map get_var vars ; checkDupRdrNames rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc @@ -974,11 +998,14 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) do { (lhs', fv_lhs') <- rnLExpr lhs ; (rhs', fv_rhs') <- rnLExpr rhs ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' - ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars' + lhs' rhs', fv_lhs' `plusFV` fv_rhs') } } where - get_var (L _ (RuleBndrSig v _)) = v - get_var (L _ (RuleBndr v)) = v + get_var (L _ (RuleBndrSig _ v _)) = v + get_var (L _ (RuleBndr _ v)) = v + get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl" +rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl" bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name] -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) @@ -989,14 +1016,14 @@ bindHsRuleVars rule_name vars names thing_inside where doc = RuleCtx rule_name - go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside + go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> - thing_inside (L l (RuleBndr (L loc n)) : vars') + thing_inside (L l (RuleBndr noExt (L loc n)) : vars') - go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside + go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside = rnHsSigWcTypeScoped doc bsig $ \ bsig' -> go vars ns $ \ vars' -> - thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars') + thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) @@ -1090,44 +1117,41 @@ badRuleLhsErr name lhs bad_e rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars) -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser. -rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _ _))) +rnHsVectDecl (HsVect _ s var rhs@(L _ (HsVar _ _))) = do { var' <- lookupLocatedOccRn var ; (rhs', fv_rhs) <- rnLExpr rhs - ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var') + ; return (HsVect noExt s var' rhs', fv_rhs `addOneFV` unLoc var') } -rnHsVectDecl (HsVect _ _var _rhs) +rnHsVectDecl (HsVect _ _ _var _rhs) = failWith $ vcat [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma" , text "must be an identifier" ] -rnHsVectDecl (HsNoVect s var) +rnHsVectDecl (HsNoVect _ s var) = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names - ; return (HsNoVect s var', unitFV (unLoc var')) + ; return (HsNoVect noExt s var', unitFV (unLoc var')) } -rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing) +rnHsVectDecl (HsVectType (VectTypePR s tycon Nothing) isScalar) = do { tycon' <- lookupLocatedOccRn tycon - ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon')) + ; return ( HsVectType (VectTypePR s tycon' Nothing) isScalar + , unitFV (unLoc tycon')) } -rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon)) +rnHsVectDecl (HsVectType (VectTypePR s tycon (Just rhs_tycon)) isScalar) = do { tycon' <- lookupLocatedOccRn tycon ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon - ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon') + ; return ( HsVectType (VectTypePR s tycon' (Just rhs_tycon')) isScalar , mkFVs [unLoc tycon', unLoc rhs_tycon']) } -rnHsVectDecl (HsVectTypeOut _ _ _) - = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'" -rnHsVectDecl (HsVectClassIn s cls) +rnHsVectDecl (HsVectClass (VectClassPR s cls)) = do { cls' <- lookupLocatedOccRn cls - ; return (HsVectClassIn s cls', unitFV (unLoc cls')) + ; return (HsVectClass (VectClassPR s cls'), unitFV (unLoc cls')) } -rnHsVectDecl (HsVectClassOut _) - = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" -rnHsVectDecl (HsVectInstIn instTy) +rnHsVectDecl (HsVectInst instTy) = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy - ; return (HsVectInstIn instTy', fvs) + ; return (HsVectInst instTy', fvs) } -rnHsVectDecl (HsVectInstOut _) - = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" +rnHsVectDecl (XVectDecl {}) + = panic "RnSource.rnHsVectDecl: Unexpected 'XVectDecl'" {- ************************************************************** * * @@ -1291,7 +1315,8 @@ rnTyClDecls tycl_ds first_group | null init_inst_ds = [] - | otherwise = [TyClGroup { group_tyclds = [] + | otherwise = [TyClGroup { group_ext = noExt + , group_tyclds = [] , group_roles = [] , group_instds = init_inst_ds }] @@ -1322,7 +1347,8 @@ rnTyClDecls tycl_ds bndrs = map (tcdName . unLoc) tycl_ds (inst_ds, inst_map') = getInsts bndrs inst_map (roles, role_env') = getRoleAnnots bndrs role_env - group = TyClGroup { group_tyclds = tycl_ds + group = TyClGroup { group_ext = noExt + , group_tyclds = tycl_ds , group_roles = roles , group_instds = inst_ds } @@ -1382,13 +1408,14 @@ rnRoleAnnots tc_names role_annots ; mapM_ dupRoleAnnotErr dup_annots ; mapM (wrapLocM rn_role_annot1) no_dups } where - rn_role_annot1 (RoleAnnotDecl tycon roles) + rn_role_annot1 (RoleAnnotDecl _ tycon roles) = do { -- the name is an *occurrence*, but look it up only in the -- decls defined in this group (see #10263) tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) (text "role annotation") tycon - ; return $ RoleAnnotDecl tycon' roles } + ; return $ RoleAnnotDecl noExt tycon' roles } + rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots" dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list @@ -1506,7 +1533,7 @@ rnTyClDecl :: TyClDecl GhcPs -- in a class decl rnTyClDecl (FamDecl { tcdFam = decl }) = do { (decl', fvs) <- rnFamDecl Nothing decl - ; return (FamDecl decl', fvs) } + ; return (FamDecl noExt decl', fvs) } rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs }) @@ -1518,7 +1545,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, do { (rhs', fvs) <- rnTySyn doc rhs ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdFixity = fixity - , tcdRhs = rhs', tcdFVs = fvs }, fvs) } } + , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } -- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl @@ -1537,8 +1564,8 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdFixity = fixity - , tcdDataDefn = defn', tcdDataCusk = cusk - , tcdFVs = fvs }, fvs) } } + , tcdDataDefn = defn' + , tcdDExt = DataDeclRn cusk fvs }, fvs) } } rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars, tcdFixity = fixity, @@ -1599,11 +1626,13 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs', tcdFVs = all_fvs }, + tcdDocs = docs', tcdCExt = all_fvs }, all_fvs ) } where cls_doc = ClassDeclCtx lcls +rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl" + -- "type" and "type instance" declarations rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnTySyn doc rhs = rnLHsType doc rhs @@ -1634,7 +1663,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType + ; return ( HsDataDefn { dd_ext = noExt + , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = context', dd_kindSig = m_sig' , dd_cons = condecls' , dd_derivs = derivs' } @@ -1651,18 +1681,23 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds ; return (L loc ds', fvs) } +rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn" rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause deriv_strats_ok doc - (L loc (HsDerivingClause { deriv_clause_strategy = dcs + (L loc (HsDerivingClause { deriv_clause_ext = noExt + , deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct })) = do { failIfTc (isJust dcs && not deriv_strats_ok) $ illegalDerivStrategyErr $ fmap unLoc dcs ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct - ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs + ; return ( L loc (HsDerivingClause { deriv_clause_ext = noExt + , deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct' }) , fvs ) } +rnLHsDerivingClause _ _ (L _ (XHsDerivingClause _)) + = panic "rnLHsDerivingClause" badGadtStupidTheta :: HsDocContext -> SDoc badGadtStupidTheta _ @@ -1698,7 +1733,8 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars injectivity ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } ; (info', fv2) <- rn_info info - ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' + ; return (FamilyDecl { fdExt = noExt + , fdLName = tycon', fdTyVars = tyvars' , fdFixity = fixity , fdInfo = info', fdResultSig = res_sig' , fdInjectivityAnn = injectivity' } @@ -1715,16 +1751,17 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars = return (ClosedTypeFamily Nothing, emptyFVs) rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) rn_info DataFamily = return (DataFamily, emptyFVs) +rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl" rnFamResultSig :: HsDocContext -> FamilyResultSig GhcPs -> RnM (FamilyResultSig GhcRn, FreeVars) -rnFamResultSig _ NoSig - = return (NoSig, emptyFVs) -rnFamResultSig doc (KindSig kind) +rnFamResultSig _ (NoSig _) + = return (NoSig noExt, emptyFVs) +rnFamResultSig doc (KindSig _ kind) = do { (rndKind, ftvs) <- rnLHsKind doc kind - ; return (KindSig rndKind, ftvs) } -rnFamResultSig doc (TyVarSig tvbndr) + ; return (KindSig noExt rndKind, ftvs) } +rnFamResultSig doc (TyVarSig _ tvbndr) = do { -- `TyVarSig` tells us that user named the result of a type family by -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to -- be sure that the supplied result name is not identical to an @@ -1745,7 +1782,8 @@ rnFamResultSig doc (TyVarSig tvbndr) ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for -- scoping checks that are irrelevant here tvbndr $ \ tvbndr' -> - return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) } + return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) } +rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig" -- Note [Renaming injectivity annotation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1786,7 +1824,7 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -> LFamilyResultSig GhcRn -- ^ Result signature -> LInjectivityAnn GhcPs -- ^ Injectivity annotation -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) (L srcSpan (InjectivityAnn injFrom injTo)) = do { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) @@ -1897,7 +1935,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs [ text "ex_tvs:" <+> ppr ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) - ; return (decl { con_name = new_name, con_ex_tvs = new_ex_tvs + ; return (decl { con_ext = noExt + , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args , con_doc = mb_doc' }, all_fvs) }} @@ -1945,17 +1984,21 @@ rnConDecl decl@(ConDeclGADT { con_names = names -- See Note [GADT abstract syntax] in HsDecls (PrefixCon arg_tys, final_res_ty) - new_qtvs = HsQTvs { hsq_implicit = implicit_tkvs - , hsq_explicit = explicit_tkvs - , hsq_dependent = emptyNameSet } + new_qtvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = implicit_tkvs + , hsq_dependent = emptyNameSet } + , hsq_explicit = explicit_tkvs } ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) - ; return (decl { con_names = new_names + ; return (decl { con_g_ext = noExt, con_names = new_names , con_qvars = new_qtvs, con_mb_cxt = new_cxt , con_args = args', con_res_ty = res_ty' , con_doc = mb_doc' }, all_fvs) } } +rnConDecl (XConDecl _) = panic "rnConDecl" + + rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) -> RnM (Maybe (LHsContext GhcRn), FreeVars) rnMbContext _ Nothing = return (Nothing, emptyFVs) @@ -2081,12 +2124,12 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split -add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds = do { (ds', _) <- rnTopSpliceDecls qq ; addl gp (ds' ++ ds) } -add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds +add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds = do { -- We've found a top-level splice. If it is an *implicit* one -- (i.e. a naked top level expression) case flag of @@ -2101,7 +2144,7 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds $$ text "or top-level declaration expected." -- Class declarations: pull out the fixity signatures to the top -add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds | isClassDecl d = let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds @@ -2109,69 +2152,81 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds -- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig _ f)) ds +add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds = addl (gp {hs_fixds = L l f : ts}) ds -add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds +add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds = addl (gp {hs_valds = add_sig (L l d) ts}) ds -- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds +add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds = addl (gp { hs_valds = add_bind (L l d) ts }) ds -- Role annotations: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds +add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds -- NB instance declarations go into TyClGroups. We throw them into the first -- group, just as we do for the TyClD case. The renamer will go on to group -- and order them later. -add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds +add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds -- The rest are routine -add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds +add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds = addl (gp { hs_derivds = L l d : ts }) ds -add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds = addl (gp { hs_defds = L l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds = addl (gp { hs_fords = L l d : ts }) ds -add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds = addl (gp { hs_warnds = L l d : ts }) ds -add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds = addl (gp { hs_annds = L l d : ts }) ds -add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds = addl (gp { hs_ruleds = L l d : ts }) ds -add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds +add gp@(HsGroup {hs_vects = ts}) l (VectD _ d) ds = addl (gp { hs_vects = L l d : ts }) ds -add gp l (DocD d) ds +add gp l (DocD _ d) ds = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds - -add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a] -add_tycld d [] = [TyClGroup { group_tyclds = [d] - , group_roles = [] +add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add" +add (HsGroup {}) _ (XHsDecl _) _ = panic "RnSource.add" +add (XHsGroup _) _ _ _ = panic "RnSource.add" + +add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_tycld d [] = [TyClGroup { group_ext = noExt + , group_tyclds = [d] + , group_roles = [] , group_instds = [] } ] add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) = ds { group_tyclds = d : tyclds } : dss +add_tycld _ (XTyClGroup _: _) = panic "add_tycld" -add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a] -add_instd d [] = [TyClGroup { group_tyclds = [] - , group_roles = [] +add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_instd d [] = [TyClGroup { group_ext = noExt + , group_tyclds = [] + , group_roles = [] , group_instds = [d] } ] add_instd d (ds@(TyClGroup { group_instds = instds }):dss) = ds { group_instds = d : instds } : dss +add_instd _ (XTyClGroup _: _) = panic "add_instd" -add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a] -add_role_annot d [] = [TyClGroup { group_tyclds = [] - , group_roles = [d] +add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_role_annot d [] = [TyClGroup { group_ext = noExt + , group_tyclds = [] + , group_roles = [d] , group_instds = [] } ] add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest +add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot" add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index fc7240ef44..19bf763f63 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -620,13 +620,15 @@ rnSplicePat splice ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnSpliceDecl (SpliceDecl (L loc splice) flg) +rnSpliceDecl (SpliceDecl _ (L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where pend_decl_splice rn_splice - = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg) + = ( makePending UntypedDeclSplice rn_splice + , SpliceDecl noExt (L loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) +rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl" rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index c4ab448e61..b51a178e82 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -127,18 +127,23 @@ rn_hs_sig_wc_type always_bind_free_tvs ctxt bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty) ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars -> do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' } + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' } ib_ty' = mk_implicit_bndrs vars hs_ty' fvs1 ; (res, fvs2) <- thing_inside sig_ty' ; return (res, fvs1 `plusFV` fvs2) } } +rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _ + = panic "rn_hs_sig_wc_type" +rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _ + = panic "rn_hs_sig_wc_type" rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) = do { free_vars <- extractFilteredRdrTyVars hs_ty ; (_, nwc_rdrs) <- partition_nwcs free_vars ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty - ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' } + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } ; return (sig_ty', fvs) } +rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType" rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs -> RnM ([Name], LHsType GhcRn, FreeVars) @@ -297,6 +302,7 @@ rnHsSigType ctx (HsIB { hsib_body = hs_ty }) ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars -> do { (body', fvs) <- rnLHsType ctx hs_ty ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } } +rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType" rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables -- E.g. f :: forall a. a->b @@ -353,9 +359,10 @@ mk_implicit_bndrs :: [Name] -- implicitly bound -> FreeVars -- FreeVars of payload -> HsImplicitBndrs GhcRn a mk_implicit_bndrs vars body fvs - = HsIB { hsib_vars = vars - , hsib_body = body - , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) } + = HsIB { hsib_ext = HsIBRn + { hsib_vars = vars + , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) } + , hsib_body = body } @@ -834,7 +841,7 @@ wildCardsAllowed env HsTypeCtx {} -> True _ -> False -rnAnonWildCard :: RnM (HsWildCardInfo GhcRn) +rnAnonWildCard :: RnM HsWildCardInfo rnAnonWildCard = do { loc <- getSrcSpanM ; uniq <- newUnique @@ -948,9 +955,10 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs -> do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) ; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs - ; thing_inside (HsQTvs { hsq_implicit = implicit_kv_nms - , hsq_explicit = rn_bndrs - , hsq_dependent = mkNameSet dep_bndr_nms }) + ; thing_inside (HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = implicit_kv_nms + , hsq_dependent = mkNameSet dep_bndr_nms } + , hsq_explicit = rn_bndrs }) all_bound_on_lhs } } where @@ -1204,11 +1212,12 @@ rnConDeclFields ctxt fls fields rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (L l (ConDeclField names ty haddock_doc)) +rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } + ; return (L l (ConDeclField noExt new_names new_ty new_haddock_doc) + , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr) @@ -1216,6 +1225,7 @@ rnField fl_env env (L l (ConDeclField names ty haddock_doc)) lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl lookupField (XFieldOcc{}) = panic "rnField" +rnField _ _ (L _ (XConDeclField _)) = panic "rnField" {- ************************************************************************ @@ -1452,6 +1462,7 @@ checkPrecMatch op (MG { mg_alts = L _ ms }) -- but the second eqn has no args (an error, but not discovered -- until the type checker). So we don't want to crash on the -- second eqn. +checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch" checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do @@ -1756,8 +1767,8 @@ rmDupsInRdrTyVars (FKTV kis tys) extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName] extractRdrKindSigVars (L _ resultSig) - | KindSig k <- resultSig = kindRdrNameFromSig k - | TyVarSig (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k + | KindSig _ k <- resultSig = kindRdrNameFromSig k + | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k | otherwise = return [] where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k @@ -1788,6 +1799,8 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig = extract_hs_tv_bndrs ex_tvs acc =<< extract_mlctxt ctxt =<< extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV + extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars" +extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars" extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 07d72a105a..60872f749e 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -51,7 +51,7 @@ tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation] tcAnnotations' anns = mapM tcAnnotation anns tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation -tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do +tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do -- Work out what the full target of this annotation was mod <- getModule let target = annProvenanceToTarget mod provenance @@ -65,6 +65,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do where safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ] +tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation" annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 318e4c683b..96adf46db8 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -254,28 +254,31 @@ tc_cmd env tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - ; let match' = L mtch_loc (Match { m_ctxt = LambdaExpr, m_pats = pats' + ; let match' = L mtch_loc (Match { m_ext = noExt + , m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) arg_tys = map hsLPatType pats' cmd' = HsCmdLam x (MG { mg_alts = L l [match'] - , mg_arg_tys = arg_tys - , mg_res_ty = res_ty, mg_origin = origin }) + , mg_ext = MatchGroupTc arg_tys res_ty + , mg_origin = origin }) ; return (mkHsCmdWrap (mkWpCastN co) cmd') } where n_pats = length pats match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt - tc_grhss (GRHSs grhss (L l binds)) stk_ty res_ty + tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs grhss' (L l binds')) } + ; return (GRHSs x grhss' (L l binds')) } + tc_grhss (XGRHSs _) _ _ = panic "tc_grhss" - tc_grhs stk_ty res_ty (GRHS guards body) + tc_grhs stk_ty res_ty (GRHS x guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ \ res_ty -> tcCmd env body (stk_ty, checkingExpType "tc_grhs" res_ty) - ; return (GRHS guards' rhs') } + ; return (GRHS x guards' rhs') } + tc_grhs _ _ (XGRHS _) = panic "tc_grhs" ------------------------------------------- -- Do notation @@ -354,17 +357,17 @@ matchExpectedCmdArgs n ty -- (b) no rebindable syntax tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker -tcArrDoStmt env _ (LastStmt rhs noret _) res_ty thing_inside +tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside = do { rhs' <- tcCmd env rhs (unitTy, res_ty) ; thing <- thing_inside (panic "tcArrDoStmt") - ; return (LastStmt rhs' noret noSyntaxExpr, thing) } + ; return (LastStmt x rhs' noret noSyntaxExpr, thing) } -tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside +tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside = do { (rhs', elt_ty) <- tc_arr_rhs env rhs ; thing <- thing_inside res_ty - ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) } -tcArrDoStmt env ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside +tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_arr_rhs env rhs ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ thing_inside res_ty @@ -396,10 +399,11 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (emptyRecStmtId { recS_stmts = stmts' , recS_later_ids = later_ids - , recS_later_rets = later_rets , recS_rec_ids = rec_ids - , recS_rec_rets = rec_rets - , recS_ret_ty = res_ty }, thing) + , recS_ext = unitRecStmtTc + { recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = res_ty} }, thing) }} tcArrDoStmt _ _ stmt _ _ diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 5355cc9dbf..980185c0fe 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1243,20 +1243,20 @@ tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId) -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single -- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType' -- from the vectoriser here. -tcVect (HsVect s name rhs) +tcVect (HsVect _ s name rhs) = addErrCtxt (vectCtxt name) $ do { var <- wrapLocM tcLookupId name ; let L rhs_loc (HsVar noExt (L lv rhs_var_name)) = rhs ; rhs_id <- tcLookupId rhs_var_name - ; return $ HsVect s var (L rhs_loc (HsVar noExt (L lv rhs_id))) + ; return $ HsVect noExt s var (L rhs_loc (HsVar noExt (L lv rhs_id))) } -tcVect (HsNoVect s name) +tcVect (HsNoVect _ s name) = addErrCtxt (vectCtxt name) $ do { var <- wrapLocM tcLookupId name - ; return $ HsNoVect s var + ; return $ HsNoVect noExt s var } -tcVect (HsVectTypeIn _ isScalar lname rhs_name) +tcVect (HsVectType (VectTypePR _ lname rhs_name) isScalar) = addErrCtxt (vectCtxt lname) $ do { tycon <- tcLookupLocatedTyCon lname ; checkTc ( not isScalar -- either we have a non-SCALAR declaration @@ -1266,25 +1266,21 @@ tcVect (HsVectTypeIn _ isScalar lname rhs_name) scalarTyConMustBeNullary ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name - ; return $ HsVectTypeOut isScalar tycon rhs_tycon + ; return $ HsVectType (VectTypeTc tycon rhs_tycon) isScalar } -tcVect (HsVectTypeOut _ _ _) - = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'" -tcVect (HsVectClassIn _ lname) +tcVect (HsVectClass (VectClassPR _ lname)) = addErrCtxt (vectCtxt lname) $ do { cls <- tcLookupLocatedClass lname - ; return $ HsVectClassOut cls + ; return $ HsVectClass cls } -tcVect (HsVectClassOut _) - = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'" -tcVect (HsVectInstIn linstTy) +tcVect (HsVectInst linstTy) = addErrCtxt (vectCtxt linstTy) $ do { (cls, tys) <- tcHsVectInst linstTy ; inst <- tcLookupInstance cls tys - ; return $ HsVectInstOut inst + ; return $ HsVectInst inst } -tcVect (HsVectInstOut _) - = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'" +tcVect (XVectDecl {}) + = panic "TcBinds.tcVect: Unexpected 'XVectDecl'" vectCtxt :: Outputable thing => thing -> SDoc vectCtxt thing = text "When checking the vectorisation declaration for" <+> ppr thing diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index 8ab13fa44c..d79c9f366d 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -42,10 +42,10 @@ tcDefaults [] -- one group, only for the next group to ignore them and install -- defaultDefaultTys -tcDefaults [L _ (DefaultDecl [])] +tcDefaults [L _ (DefaultDecl _ [])] = return (Just []) -- Default declaration specifying no types -tcDefaults [L locn (DefaultDecl mono_tys)] +tcDefaults [L locn (DefaultDecl _ mono_tys)] = setSrcSpan locn $ addErrCtxt defaultDeclCtxt $ do { ovl_str <- xoptM LangExt.OverloadedStrings @@ -63,9 +63,10 @@ tcDefaults [L locn (DefaultDecl mono_tys)] ; return (Just tau_tys) } -tcDefaults decls@(L locn (DefaultDecl _) : _) +tcDefaults decls@(L locn (DefaultDecl _ _) : _) = setSrcSpan locn $ failWithTc (dupDefaultDeclErr decls) +tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults" tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type @@ -93,11 +94,14 @@ defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc -dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) +dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) = hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) where - pp (L locn (DefaultDecl _)) = text "here was another default declaration" <+> ppr locn + pp (L locn (DefaultDecl _ _)) + = text "here was another default declaration" <+> ppr locn + pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr" +dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr" dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" badDefaultTy :: Type -> [Class] -> SDoc diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 610fe5d6b1..b6a8185526 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -607,7 +607,7 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) -- -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays. -deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode)) +deriveStandalone (L loc (DerivDecl _ deriv_ty deriv_strat' overlap_mode)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) @@ -649,6 +649,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode)) bale_out $ text "The last argument of the instance must be a data or newtype application" } +deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone" -- Typecheck the type in a standalone deriving declaration. -- @@ -673,20 +674,21 @@ tcStandaloneDerivInstType :: LHsSigWcType GhcRn -> TcM ([TyVar], DerivContext, Class, [Type]) tcStandaloneDerivInstType - (HsWC { hswc_body = deriv_ty@(HsIB { hsib_vars = vars - , hsib_closed = closed + (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = HsIBRn + { hsib_vars = vars + , hsib_closed = closed } , hsib_body = deriv_ty_body })}) | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body , L _ [wc_pred] <- theta , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred = do (deriv_tvs, _deriv_theta, deriv_cls, deriv_inst_tys) <- tc_hs_cls_inst_ty $ - HsIB { hsib_vars = vars - , hsib_closed = closed + HsIB { hsib_ext = HsIBRn { hsib_vars = vars + , hsib_closed = closed } , hsib_body = L (getLoc deriv_ty_body) $ HsForAllTy { hst_bndrs = tvs - , hst_xforall = PlaceHolder + , hst_xforall = noExt , hst_body = rho }} pure (deriv_tvs, InferContext (Just wc_span), deriv_cls, deriv_inst_tys) | otherwise @@ -695,6 +697,10 @@ tcStandaloneDerivInstType pure (deriv_tvs, SupplyContext deriv_theta, deriv_cls, deriv_inst_tys) where tc_hs_cls_inst_ty = tcHsClsInstType TcType.InstDeclCtxt +tcStandaloneDerivInstType (HsWC _ (XHsImplicitBndrs _)) + = panic "tcStandaloneDerivInstType" +tcStandaloneDerivInstType (XHsWildCardBndrs _) + = panic "tcStandaloneDerivInstType" warnUselessTypeable :: TcM () warnUselessTypeable diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index d3cbdb0f3c..0eec439b8c 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -641,11 +641,18 @@ tcAddDataFamConPlaceholders inst_decls thing_inside get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } })) = concatMap (get_fi_cons . unLoc) fids + get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons" + get_cons (L _ (XInstDecl _)) = panic "get_cons" get_fi_cons :: DataFamInstDecl GhcRn -> [Name] get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}}) = map unLoc $ concatMap (getConNames . unLoc) cons + get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = XHsDataDefn _ }}}) + = panic "get_fi_cons" + get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons" + get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons" tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 878d050f82..aac880fa16 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1983,6 +1983,7 @@ too_many_args fun args where pp (HsValArg e) = ppr e pp (HsTypeArg (HsWC { hswc_body = L _ t })) = pprHsType t + pp (HsTypeArg (XHsWildCardBndrs _)) = panic "too_many_args" {- diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index bbe9f38109..f7ec465026 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -263,7 +263,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty -- we need HsType Id hence the undefined ; let fi_decl = ForeignImport { fd_name = L nloc id , fd_sig_ty = undefined - , fd_co = mkSymCo norm_co + , fd_i_ext = mkSymCo norm_co , fd_fi = imp_decl' } ; return (id, L dloc fi_decl, gres) } tcFImport d = pprPanic "tcFImport" (ppr d) @@ -409,7 +409,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe return ( mkVarBind id rhs , ForeignExport { fd_name = L loc id , fd_sig_ty = undefined - , fd_co = norm_co, fd_fe = spec' } + , fd_e_ext = norm_co, fd_fe = spec' } , gres) tcFExport d = pprPanic "tcFExport" (ppr d) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 5be0087834..b7b06dddae 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -99,8 +99,8 @@ hsPatType (LazyPat _ pat) = hsLPatType pat hsPatType (LitPat _ lit) = hsLitType lit hsPatType (AsPat _ var _) = idType (unLoc var) hsPatType (ViewPat ty _ _) = ty -hsPatType (ListPat _ _ ty Nothing) = mkListTy ty -hsPatType (ListPat _ _ _ (Just (ty,_))) = ty +hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty +hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty hsPatType (PArrPat ty _) = mkPArrTy ty hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys hsPatType (SumPat tys _ _ _ ) = mkSumTy tys @@ -591,13 +591,16 @@ zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> MatchGroup GhcTcId (Located (body GhcTcId)) -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys - , mg_res_ty = res_ty, mg_origin = origin }) +zonkMatchGroup env zBody (MG { mg_alts = L l ms + , mg_ext = MatchGroupTc arg_tys res_ty + , mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypeToTypes env arg_tys ; res_ty' <- zonkTcTypeToType env res_ty - ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys' - , mg_res_ty = res_ty', mg_origin = origin }) } + ; return (MG { mg_alts = L l ms' + , mg_ext = MatchGroupTc arg_tys' res_ty' + , mg_origin = origin }) } +zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup" zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) @@ -607,6 +610,7 @@ zonkMatch env zBody (L loc match@(Match { m_pats = pats, m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } +zonkMatch _ _ (L _ (XMatch _)) = panic "zonkMatch" ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv @@ -614,15 +618,17 @@ zonkGRHSs :: ZonkEnv -> GRHSs GhcTcId (Located (body GhcTcId)) -> TcM (GRHSs GhcTc (Located (body GhcTc))) -zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do +zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds let - zonk_grhs (GRHS guarded rhs) + zonk_grhs (GRHS xx guarded rhs) = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded new_rhs <- zBody env2 rhs - return (GRHS new_guarded new_rhs) + return (GRHS xx new_guarded new_rhs) + zonk_grhs (XGRHS _) = panic "zonkGRHSs" new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs new_grhss (L l new_binds)) + return (GRHSs x new_grhss (L l new_binds)) +zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs" {- ************************************************************************ @@ -754,10 +760,11 @@ zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts ; ty' <- zonkTcTypeToType env ty ; return $ HsMultiIf ty' alts' } - where zonk_alt (GRHS guard expr) + where zonk_alt (GRHS x guard expr) = do { (env', guard') <- zonkStmts env zonkLExpr guard ; expr' <- zonkLExpr env' expr - ; return $ GRHS guard' expr' } + ; return $ GRHS x guard' expr' } + zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf" zonkExpr env (HsLet x (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds @@ -1040,7 +1047,7 @@ zonkStmt :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> Stmt GhcTcId (Located (body GhcTcId)) -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) -zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) +zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) = 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 @@ -1048,7 +1055,8 @@ zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) , 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) } + ; return (env2 + , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} where zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts @@ -1059,9 +1067,12 @@ zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) 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 - , recS_bind_fn = bind_id, recS_bind_ty = bind_ty - , recS_later_rets = later_rets, recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty }) + , recS_bind_fn = bind_id + , recS_ext = + RecStmtTc { recS_bind_ty = bind_ty + , recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty} }) = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id @@ -1079,26 +1090,28 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_ RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_bind_ty = new_bind_ty - , recS_later_rets = new_later_rets - , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } + , recS_ext = RecStmtTc + { recS_bind_ty = new_bind_ty + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets + , recS_ret_ty = new_ret_ty } }) } -zonkStmt env zBody (BodyStmt body then_op guard_op ty) +zonkStmt env zBody (BodyStmt ty body then_op guard_op) = do (env1, new_then_op) <- zonkSyntaxExpr env then_op (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op new_body <- zBody env2 body new_ty <- zonkTcTypeToType env2 ty - return (env2, BodyStmt new_body new_then_op new_guard_op new_ty) + return (env2, BodyStmt new_ty new_body new_then_op new_guard_op) -zonkStmt env zBody (LastStmt body noret ret_op) +zonkStmt env zBody (LastStmt x body noret ret_op) = do (env1, new_ret) <- zonkSyntaxExpr env ret_op new_body <- zBody env1 body - return (env, LastStmt new_body noret new_ret) + return (env, LastStmt x new_body noret new_ret) zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap , trS_by = by, trS_form = form, trS_using = using , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = bind_arg_ty + , trS_ext = bind_arg_ty , trS_fmap = liftM_op }) = do { ; (env1, bind_op') <- zonkSyntaxExpr env bind_op @@ -1114,7 +1127,7 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' , trS_by = by', trS_form = form, trS_using = using' , trS_ret = return_op', trS_bind = bind_op' - , trS_bind_arg_ty = bind_arg_ty' + , trS_ext = bind_arg_ty' , trS_fmap = liftM_op' }) } where zonkBinderMapEntry env (oldBinder, newBinder) = do @@ -1122,36 +1135,39 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt (L l binds)) +zonkStmt env _ (LetStmt x (L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt (L l new_binds)) + return (env1, LetStmt x (L l new_binds)) -zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty) +zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op ; new_bind_ty <- zonkTcTypeToType env1 bind_ty ; new_body <- zBody env1 body ; (env2, new_pat) <- zonkPat env1 pat ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op - ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) } + ; return ( env2 + , BindStmt new_bind_ty new_pat new_body new_bind new_fail) } -- Scopes: join > ops (in reverse order) > pats (in forward order) -- > rest of stmts -zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty) +zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) = do { (env1, new_mb_join) <- zonk_join env mb_join ; (env2, new_args) <- zonk_args env1 args ; new_body_ty <- zonkTcTypeToType env2 body_ty - ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) } + ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) } where zonk_join env Nothing = return (env, Nothing) zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - get_pat (_, ApplicativeArgOne pat _ _) = pat - get_pat (_, ApplicativeArgMany _ _ pat) = pat + get_pat (_, ApplicativeArgOne _ pat _ _) = pat + get_pat (_, ApplicativeArgMany _ _ _ pat) = pat + get_pat (_, XApplicativeArg _) = panic "zonkStmt" - replace_pat pat (op, ApplicativeArgOne _ a isBody) - = (op, ApplicativeArgOne pat a isBody) - replace_pat pat (op, ApplicativeArgMany a b _) - = (op, ApplicativeArgMany a b pat) + replace_pat pat (op, ApplicativeArgOne x _ a isBody) + = (op, ApplicativeArgOne x pat a isBody) + replace_pat pat (op, ApplicativeArgMany x a b _) + = (op, ApplicativeArgMany x a b pat) + replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt" zonk_args env args = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) @@ -1168,13 +1184,16 @@ zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty) ; return (env2, (new_op, new_arg) : new_args) } zonk_args_rev env [] = return (env, []) - zonk_arg env (ApplicativeArgOne pat expr isBody) + zonk_arg env (ApplicativeArgOne x pat expr isBody) = do { new_expr <- zonkLExpr env expr - ; return (ApplicativeArgOne pat new_expr isBody) } - zonk_arg env (ApplicativeArgMany stmts ret pat) + ; return (ApplicativeArgOne x pat new_expr isBody) } + zonk_arg env (ApplicativeArgMany x stmts ret pat) = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_ret <- zonkExpr env1 ret - ; return (ApplicativeArgMany new_stmts new_ret pat) } + ; return (ApplicativeArgMany x new_stmts new_ret pat) } + zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg" + +zonkStmt _ _ (XStmtLR _) = panic "zonkStmt" ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId) @@ -1253,17 +1272,17 @@ zonk_pat env (ViewPat ty expr pat) ; ty' <- zonkTcTypeToType env ty ; return (env', ViewPat ty' expr' pat') } -zonk_pat env (ListPat x pats ty Nothing) +zonk_pat env (ListPat (ListPatTc ty Nothing) pats) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', ListPat x pats' ty' Nothing) } + ; return (env', ListPat (ListPatTc ty' Nothing) pats') } -zonk_pat env (ListPat x pats ty (Just (ty2,wit))) +zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) = do { (env', wit') <- zonkSyntaxExpr env wit ; ty2' <- zonkTcTypeToType env' ty2 ; ty' <- zonkTcTypeToType env' ty ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat x pats' ty' (Just (ty2',wit'))) } + ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') } zonk_pat env (PArrPat ty pats) = do { ty' <- zonkTcTypeToType env ty @@ -1388,9 +1407,10 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId] zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc) -zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec }) +zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co + , fd_fe = spec }) = return (ForeignExport { fd_name = zonkLIdOcc env i - , fd_sig_ty = undefined, fd_co = co + , fd_sig_ty = undefined, fd_e_ext = co , fd_fe = spec }) zonkForeignExport _ for_imp = return for_imp -- Foreign imports don't need zonking @@ -1399,7 +1419,7 @@ zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc] zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc) -zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) +zonkRule env (HsRule fvs name act (vars{-::[RuleBndr TcId]-}) lhs rhs) = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars ; let env_lhs = setZonkType env_inside zonkTvSkolemising @@ -1408,12 +1428,13 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) ; new_lhs <- zonkLExpr env_lhs lhs ; new_rhs <- zonkLExpr env_inside rhs - ; return (HsRule name act new_bndrs new_lhs fv_lhs new_rhs fv_rhs) } + ; return (HsRule fvs name act new_bndrs new_lhs new_rhs ) } where - zonk_bndr env (L l (RuleBndr (L loc v))) + zonk_bndr env (L l (RuleBndr x (L loc v))) = do { (env', v') <- zonk_it env v - ; return (env', L l (RuleBndr (L loc v'))) } + ; return (env', L l (RuleBndr x (L loc v'))) } zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig" + zonk_bndr _ (L _ (XRuleBndr {})) = panic "zonk_bndr XRuleBndr" zonk_it env v | isId v = do { v' <- zonkIdBndr env v @@ -1423,29 +1444,28 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) -- DV: used to be return (env,v) but that is plain -- wrong because we may need to go inside the kind -- of v and zonk there! +zonkRule _ (XRuleDecl _) = panic "zonkRule" zonkVects :: ZonkEnv -> [LVectDecl GhcTcId] -> TcM [LVectDecl GhcTc] zonkVects env = mapM (wrapLocM (zonkVect env)) zonkVect :: ZonkEnv -> VectDecl GhcTcId -> TcM (VectDecl GhcTc) -zonkVect env (HsVect s v e) +zonkVect env (HsVect x s v e) = do { v' <- wrapLocM (zonkIdBndr env) v ; e' <- zonkLExpr env e - ; return $ HsVect s v' e' + ; return $ HsVect x s v' e' } -zonkVect env (HsNoVect s v) +zonkVect env (HsNoVect x s v) = do { v' <- wrapLocM (zonkIdBndr env) v - ; return $ HsNoVect s v' + ; return $ HsNoVect x s v' } -zonkVect _env (HsVectTypeOut s t rt) - = return $ HsVectTypeOut s t rt -zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn" -zonkVect _env (HsVectClassOut c) - = return $ HsVectClassOut c -zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn" -zonkVect _env (HsVectInstOut i) - = return $ HsVectInstOut i -zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" +zonkVect _env (HsVectType (VectTypeTc t rt) s) + = return $ HsVectType (VectTypeTc t rt) s +zonkVect _env (HsVectClass c) + = return $ HsVectClass c +zonkVect _env (HsVectInst i) + = return $ HsVectInst i +zonkVect _ (XVectDecl _) = panic "TcHsSyn.zonkVect: XVectDecl" {- ************************************************************************ diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 6874a740db..3bee41f878 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -194,11 +194,12 @@ tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) kcHsSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM () kcHsSigType skol_info names (HsIB { hsib_body = hs_ty - , hsib_vars = sig_vars }) + , hsib_ext = HsIBRn { hsib_vars = sig_vars }}) = addSigCtxt (funsSigCtxt names) hs_ty $ discardResult $ tcImplicitTKBndrs skol_info sig_vars $ tc_lhs_type typeLevelMode hs_ty liftedTypeKind +kcHsSigType _ _ (XHsImplicitBndrs _) = panic "kcHsSigType" tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking; this must be done outside @@ -236,7 +237,8 @@ tc_hs_sig_type_and_gen :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type -- and then kind-generalizes. -- This will never emit constraints, as it uses solveEqualities interally. -- No validity checking, but it does zonk en route to generalization -tc_hs_sig_type_and_gen skol_info (HsIB { hsib_vars = sig_vars +tc_hs_sig_type_and_gen skol_info (HsIB { hsib_ext + = HsIBRn { hsib_vars = sig_vars } , hsib_body = hs_ty }) kind = do { (tkvs, ty) <- solveEqualities $ tcImplicitTKBndrs skol_info sig_vars $ @@ -250,13 +252,14 @@ tc_hs_sig_type_and_gen skol_info (HsIB { hsib_vars = sig_vars ; ty1 <- zonkPromoteTypeInKnot $ mkSpecForAllTys tkvs ty ; kvs <- kindGeneralize ty1 ; zonkSigType (mkInvForAllTys kvs ty1) } +tc_hs_sig_type_and_gen _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen" tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn -> Kind -> TcM Type -- Kind-check/desugar a 'LHsSigType', but does not solve -- the equalities that arise from doing so; instead it may -- emit kind-equality constraints into the monad -- Zonking, but no validity checking -tc_hs_sig_type skol_info (HsIB { hsib_vars = sig_vars +tc_hs_sig_type skol_info (HsIB { hsib_ext = HsIBRn { hsib_vars = sig_vars } , hsib_body = hs_ty }) kind = do { (tkvs, ty) <- tcImplicitTKBndrs skol_info sig_vars $ tc_lhs_type typeLevelMode hs_ty kind @@ -264,6 +267,7 @@ tc_hs_sig_type skol_info (HsIB { hsib_vars = sig_vars -- need to promote any remaining metavariables; test case: -- dependent/should_fail/T14066e. ; zonkPromoteType (mkSpecForAllTys tkvs ty) } +tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type" ----------------- tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) @@ -316,7 +320,7 @@ tcHsVectInst ty tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type -- See Note [Recipe for checking a signature] in TcHsType tcHsTypeApp wc_ty kind - | HsWC { hswc_wcs = sig_wcs, hswc_body = hs_ty } <- wc_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty = do { ty <- tcWildCardBindersX newWildTyVar Nothing sig_wcs $ \ _ -> tcCheckLHsType hs_ty kind ; ty <- zonkPromoteType ty @@ -325,6 +329,7 @@ tcHsTypeApp wc_ty kind -- NB: we don't call emitWildcardHoleConstraints here, because -- we want any holes in visible type applications to be used -- without fuss. No errors, warnings, extensions, etc. +tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp" {- ************************************************************************ @@ -371,12 +376,15 @@ tcLHsTypeUnsaturated ty = addTypeCtxt ty (tc_infer_lhs_type mode ty) -- or if NoMonoLocalBinds is set. Otherwise, nope. -- See Note [Kind generalisation plan] decideKindGeneralisationPlan :: LHsSigType GhcRn -> TcM Bool -decideKindGeneralisationPlan sig_ty@(HsIB { hsib_closed = closed }) +decideKindGeneralisationPlan sig_ty@(HsIB { hsib_ext + = HsIBRn { hsib_closed = closed } }) = do { mono_locals <- xoptM LangExt.MonoLocalBinds ; let should_gen = not mono_locals || closed ; traceTc "decideKindGeneralisationPlan" (ppr sig_ty $$ text "should gen?" <+> ppr should_gen) ; return should_gen } +decideKindGeneralisationPlan(XHsImplicitBndrs _) + = panic "decideKindGeneralisationPlan" {- Note [Kind generalisation plan] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -791,7 +799,7 @@ tc_hs_type _ (HsWildCardTy wc) exp_kind tc_hs_type _ ty@(HsAppsTy {}) _ = pprPanic "tc_hs_tyep HsAppsTy" (ppr ty) -tcWildCardOcc :: HsWildCardInfo GhcRn -> Kind -> TcM TcType +tcWildCardOcc :: HsWildCardInfo -> Kind -> TcM TcType tcWildCardOcc wc_info exp_kind = do { wc_tv <- tcLookupTyVar (wildCardName wc_info) -- The wildcard's kind should be an un-filled-in meta tyvar @@ -1560,8 +1568,9 @@ kcLHsQTyVars :: Name -- ^ of the thing being checked -> TcM (Kind, r) -- ^ The result kind, possibly with other info -> TcM (TcTyCon, r) -- ^ A suitably-kinded TcTyCon kcLHsQTyVars name flav cusk - user_tyvars@(HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs - , hsq_dependent = dep_names }) thing_inside + user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns + , hsq_dependent = dep_names } + , hsq_explicit = hs_tvs }) thing_inside | cusk = do { typeintype <- xoptM LangExt.TypeInType ; let m_kind @@ -1684,7 +1693,7 @@ kcLHsQTyVars name flav cusk 2 (vcat (map pp_tv other_tvs)) ] } where pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - +kcLHsQTyVars _ _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars" kcLHsTyVarBndrs :: Bool -- True <=> bump the TcLevel when bringing vars into scope -> Bool -- True <=> Default un-annotated tyvar @@ -2322,8 +2331,9 @@ tcHsPartialSigType , TcType ) -- Tau part -- See Note [Recipe for checking a signature] tcHsPartialSigType ctxt sig_ty - | HsWC { hswc_wcs = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_vars = implicit_hs_tvs, hsib_body = hs_ty } <- ib_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty + , HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_hs_tvs } + , hsib_body = hs_ty } <- ib_ty , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty = addSigCtxt ctxt hs_ty $ do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) @@ -2371,6 +2381,8 @@ tcHsPartialSigType ctxt sig_ty ; return (wcs, wcx, tv_names, all_tvs, theta, tau) } where skol_info = SigTypeSkol ctxt +tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType" +tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType" tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) tcPartialContext hs_theta @@ -2443,8 +2455,9 @@ tcHsPatSigType :: UserTypeCtxt -- This may emit constraints -- See Note [Recipe for checking a signature] tcHsPatSigType ctxt sig_ty - | HsWC { hswc_wcs = sig_wcs, hswc_body = ib_ty } <- sig_ty - , HsIB { hsib_vars = sig_vars, hsib_body = hs_ty } <- ib_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty + , HsIB { hsib_ext = HsIBRn { hsib_vars = sig_vars} + , hsib_body = hs_ty } <- ib_ty = addSigCtxt ctxt hs_ty $ do { sig_tkvs <- mapM new_implicit_tv sig_vars ; (wcs, sig_ty) @@ -2480,6 +2493,8 @@ tcHsPatSigType ctxt sig_ty -- But if it's a SigTyVar, it might have been unified -- with an existing in-scope skolem, so we must zonk -- here. See Note [Pattern signature binders] +tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType" +tcHsPatSigType _ (XHsWildCardBndrs _) = panic "tcHsPatSigType" tcPatSig :: Bool -- True <=> pattern binding -> LHsSigWcType GhcRn diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index fb2e3452e9..c3193789b1 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -463,6 +463,8 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl) ; return (insts, fam_insts, deriv_infos) } +tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl" + tcClsInstDecl :: LClsInstDecl GhcRn -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) -- The returned DerivInfos are for any associated data families @@ -517,7 +519,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts , deriv_infos ) } - +tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl" doClsInstErrorChecks :: InstInfo GhcRn -> TcM () doClsInstErrorChecks inst_info @@ -630,8 +632,9 @@ tcDataFamInstDecl :: Maybe ClsInstInfo -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) -- "newtype instance" and "data instance" tcDataFamInstDecl mb_clsinfo - (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_vars = tv_names - , hsib_body = + (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext + = HsIBRn { hsib_vars = tv_names } + , hsib_body = FamEqn { feqn_pats = pats , feqn_tycon = fam_tc_name , feqn_fixity = fixity @@ -755,6 +758,16 @@ tcDataFamInstDecl mb_clsinfo pp_hs_pats = pprFamInstLHS fam_tc_name pats fixity (unLoc ctxt) m_ksig +tcDataFamInstDecl _ + (L _ (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = XHsDataDefn _ }}})) + = panic "tcDataFamInstDecl" +tcDataFamInstDecl _ (L _ (DataFamInstDecl (XHsImplicitBndrs _))) + = panic "tcDataFamInstDecl" +tcDataFamInstDecl _ (L _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) + = panic "tcDataFamInstDecl" + + {- ********************************************************************* * * Type-checking instance declarations, pass 2 diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 2375abf2b1..1ab91bd170 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -220,9 +220,9 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches ; pat_tys <- mapM readExpType pat_tys ; rhs_ty <- readExpType rhs_ty ; return (MG { mg_alts = L l matches' - , mg_arg_tys = pat_tys - , mg_res_ty = rhs_ty + , mg_ext = MatchGroupTc pat_tys rhs_ty , mg_origin = origin }) } +tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches" ------------- tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body @@ -239,8 +239,10 @@ tcMatch ctxt pat_tys rhs_ty match = add_match_ctxt match $ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tcGRHSs ctxt grhss rhs_ty - ; return (Match { m_ctxt = mc_what ctxt, m_pats = pats' + ; return (Match { m_ext = noExt + , m_ctxt = mc_what ctxt, m_pats = pats' , m_grhss = grhss' }) } + tc_match _ _ _ (XMatch _) = panic "tcMatch" -- For (\x -> e), tcExpr has already said "In the expression \x->e" -- so we don't want to add "In the lambda abstraction \x->e" @@ -259,24 +261,26 @@ tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType -- We used to force it to be a monotype when there was more than one guard -- but we don't need to do that any more -tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty +tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss - ; return (GRHSs grhss' (L l binds')) } + ; return (GRHSs noExt grhss' (L l binds')) } +tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs" ------------- tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) -> TcM (GRHS GhcTcId (Located (body GhcTcId))) -tcGRHS ctxt res_ty (GRHS guards rhs) +tcGRHS ctxt res_ty (GRHS _ guards rhs) = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ mc_body ctxt rhs - ; return (GRHS guards' rhs') } + ; return (GRHS noExt guards' rhs') } where stmt_ctxt = PatGuard (mc_what ctxt) +tcGRHS _ _ (XGRHS _) = panic "tcGRHS" {- ************************************************************************ @@ -372,11 +376,11 @@ tcStmtsAndThen _ _ [] res_ty thing_inside ; return ([], thing) } -- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt (L l binds)) : stmts) +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) res_ty thing_inside = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt (L l binds')) : stmts', thing) } + ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } -- Don't set the error context for an ApplicativeStmt. It ought to be -- possible to do this with a popErrCtxt in the tcStmt case for @@ -405,12 +409,12 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside --------------------------------------------------- tcGuardStmt :: TcExprStmtChecker -tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside +tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside = do { guard' <- tcMonoExpr guard (mkCheckExpType boolTy) ; thing <- thing_inside res_ty - ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } + ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } -tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside +tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferSigmaNC rhs -- Stmt has a context already ; (pat', thing) <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) @@ -439,13 +443,13 @@ tcGuardStmt _ stmt _ _ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) -> TcExprStmtChecker -tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside +tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside = do { body' <- tcMonoExprNC body elt_ty ; thing <- thing_inside (panic "tcLcStmt: thing_inside") - ; return (LastStmt body' noret noSyntaxExpr, thing) } + ; return (LastStmt x body' noret noSyntaxExpr, thing) } -- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside +tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty]) ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ @@ -453,15 +457,15 @@ tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside ; return (mkTcBindStmt pat' rhs', thing) } -- A boolean guard -tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside +tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside = do { rhs' <- tcMonoExpr rhs (mkCheckExpType boolTy) ; thing <- thing_inside elt_ty - ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } + ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } -- ParStmt: See notes with tcMcStmt -tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside +tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) } + ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } where -- loop :: [([LStmt GhcRn], [GhcRn])] -- -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing) @@ -537,7 +541,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_ret = noSyntaxExpr , trS_bind = noSyntaxExpr , trS_fmap = noExpr - , trS_bind_arg_ty = unitTy + , trS_ext = unitTy , trS_form = form }, thing) } tcLcStmt _ _ stmt _ _ @@ -551,13 +555,13 @@ tcLcStmt _ _ stmt _ _ tcMcStmt :: TcExprStmtChecker -tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside +tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside = do { (body', return_op') <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $ \ [a_ty] -> tcMonoExprNC body (mkCheckExpType a_ty) ; thing <- thing_inside (panic "tcMcStmt: thing_inside") - ; return (LastStmt body' noret return_op', thing) } + ; return (LastStmt x body' noret return_op', thing) } -- Generators for monad comprehensions ( pat <- rhs ) -- @@ -565,7 +569,7 @@ tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside -- q :: a -- -tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside +tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty = do { ((rhs', pat', thing, new_res_ty), bind_op') <- tcSyntaxOp MCompOrigin bind_op @@ -580,13 +584,13 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty - ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) } + ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } -- Boolean expressions. -- -- [ body | stmts, expr ] -> expr :: m Bool -- -tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside +tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside = do { -- Deal with rebindable syntax: -- guard_op :: test_ty -> rhs_ty -- then_op :: rhs_ty -> new_res_ty -> res_ty @@ -601,7 +605,7 @@ tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside tcMonoExpr rhs (mkCheckExpType test_ty) ; thing <- thing_inside (mkCheckExpType new_res_ty) ; return (thing, rhs', rhs_ty, guard_op') } - ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) } + ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } -- Grouping statements -- @@ -716,7 +720,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' , trS_by = by', trS_using = final_using , trS_ret = return_op', trS_bind = bind_op' - , trS_bind_arg_ty = n_app tup_ty + , trS_ext = n_app tup_ty , trS_fmap = fmap_op', trS_form = form }, thing) } -- A parallel set of comprehensions @@ -748,7 +752,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call -- -> m (st1, (st2, st3)) -- -tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside +tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind ; m_ty <- newFlexiTyVarTy star_star_kind @@ -777,7 +781,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside tup_tys bndr_stmts_s ; return (stuff, inner_res_ty) } - ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) } + ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys @@ -819,12 +823,12 @@ tcMcStmt _ stmt _ _ tcDoStmt :: TcExprStmtChecker -tcDoStmt _ (LastStmt body noret _) res_ty thing_inside +tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside = do { body' <- tcMonoExprNC body res_ty ; thing <- thing_inside (panic "tcDoStmt: thing_inside") - ; return (LastStmt body' noret noSyntaxExpr, thing) } + ; return (LastStmt x body' noret noSyntaxExpr, thing) } -tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside +tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside = do { -- Deal with rebindable syntax: -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty -- This level of generality is needed for using do-notation @@ -842,9 +846,9 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty - ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) } + ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) } -tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside +tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $ thing_inside . mkCheckExpType ; ((pairs', body_ty, thing), mb_join') <- case mb_join of @@ -854,9 +858,9 @@ tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $ \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty)) - ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) } + ; return (ApplicativeStmt body_ty pairs' mb_join', thing) } -tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside +tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty ; ((rhs', rhs_ty, thing), then_op') @@ -865,7 +869,7 @@ tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty) ; thing <- thing_inside (mkCheckExpType new_res_ty) ; return (rhs', rhs_ty, thing) } - ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } + ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op @@ -911,9 +915,11 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_bind_ty = new_res_ty - , recS_later_rets = [], recS_rec_rets = tup_rets - , recS_ret_ty = stmts_ty }, thing) + , recS_ext = RecStmtTc + { recS_bind_ty = new_res_ty + , recS_later_rets = [] + , recS_rec_rets = tup_rets + , recS_ret_ty = stmts_ty} }, thing) }} tcDoStmt _ stmt _ _ @@ -1056,15 +1062,15 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside goArg :: (ApplicativeArg GhcRn, Type, Type) -> TcM (ApplicativeArg GhcTcId) - goArg (ApplicativeArgOne pat rhs isBody, pat_ty, exp_ty) + goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs)) $ do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty) ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $ return () - ; return (ApplicativeArgOne pat' rhs' isBody) } + ; return (ApplicativeArgOne x pat' rhs' isBody) } - goArg (ApplicativeArgMany stmts ret pat, pat_ty, exp_ty) + goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty) = do { (stmts', (ret',pat')) <- tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $ \res_ty -> do @@ -1073,11 +1079,14 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside return () ; return (ret', pat') } - ; return (ApplicativeArgMany stmts' ret' pat') } + ; return (ApplicativeArgMany x stmts' ret' pat') } + + goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts" get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] - get_arg_bndrs (ApplicativeArgOne pat _ _) = collectPatBinders pat - get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgOne _ pat _ _) = collectPatBinders pat + get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat + get_arg_bndrs (XApplicativeArg _) = panic "tcApplicativeStmts" {- Note [ApplicativeDo and constraints] @@ -1134,3 +1143,5 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) args_in_match :: LMatch GhcRn body -> Int args_in_match (L _ (Match { m_pats = pats })) = length pats + args_in_match (L _ (XMatch _)) = panic "checkArgs" +checkArgs _ (XMatchGroup{}) = panic "checkArgs" diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 4a825c29c1..249b01fc7b 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -421,15 +421,16 @@ tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside ------------------------ -- Lists, tuples, arrays -tc_pat penv (ListPat x pats _ Nothing) pat_ty thing_inside +tc_pat penv (ListPat Nothing pats) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (ListPat x pats' elt_ty Nothing) pat_ty, res) + ; return (mkHsWrapPat coi + (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) } -tc_pat penv (ListPat x pats _ (Just (_,e))) pat_ty thing_inside +tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside = do { tau_pat_ty <- expTypeToType pat_ty ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] @@ -438,7 +439,7 @@ tc_pat penv (ListPat x pats _ (Just (_,e))) pat_ty thing_inside do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; return (pats', res, elt_ty) } - ; return (ListPat x pats' elt_ty (Just (tau_pat_ty,e')), res) + ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res) } tc_pat penv (PArrPat _ pats ) pat_ty thing_inside diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index a759716d71..d3f5c6822a 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -674,16 +674,14 @@ tcPatSynMatcher (L loc name) lpat L (getLoc lpat) $ HsCase noExt (nlHsVar scrutinee) $ MG{ mg_alts = L (getLoc lpat) cases - , mg_arg_tys = [pat_ty] - , mg_res_ty = res_ty + , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated } body' = noLoc $ HsLam noExt $ MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr args body] - , mg_arg_tys = [pat_ty, cont_ty, fail_ty] - , mg_res_ty = res_ty + , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty , mg_origin = Generated } match = mkMatch (mkPrefixFunRhs (L loc name)) [] @@ -692,8 +690,7 @@ tcPatSynMatcher (L loc name) lpat (noLoc (EmptyLocalBinds noExt)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (getLoc match) [match] - , mg_arg_tys = [] - , mg_res_ty = res_ty + , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } @@ -898,7 +895,7 @@ tcPatToExpr name args pat = go pat go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat go1 (PArrPat _ pats) = do { exprs <- mapM go pats ; return $ ExplicitPArr noExt exprs } - go1 p@(ListPat _ pats _ty reb) + go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats ; return $ ExplicitList noExt Nothing exprs } | otherwise = notInvertibleListPat p @@ -1064,7 +1061,7 @@ tcCollectEx pat = go pat go1 (AsPat _ _ p) = go p go1 (ParPat _ p) = go p go1 (BangPat _ p) = go p - go1 (ListPat _ ps _ _) = mergeMany . map go $ ps + go1 (ListPat _ ps) = mergeMany . map go $ ps go1 (TuplePat _ ps _) = mergeMany . map go $ ps go1 (SumPat _ p _ _) = go p go1 (PArrPat _ ps) = mergeMany . map go $ ps diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 70348d3b59..81cba29040 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -509,9 +509,10 @@ tc_rn_src_decls ds else do { (th_group, th_group_tail) <- findSplice th_ds ; case th_group_tail of { Nothing -> return () ; - ; Just (SpliceDecl (L loc _) _, _) + ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpan loc $ addErr (text "Declaration splices are not permitted inside top-level declarations added with addTopDecls") + ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls" } ; -- Rename TH-generated top-level declarations @@ -538,7 +539,7 @@ tc_rn_src_decls ds { Nothing -> return (tcg_env, tcl_env) -- If there's a splice, we must carry on - ; Just (SpliceDecl (L loc splice) _, rest_ds) -> + ; Just (SpliceDecl _ (L loc splice) _, rest_ds) -> do { recordTopLevelSpliceLoc loc -- Rename the splice expression, and get its supporting decls @@ -549,6 +550,7 @@ tc_rn_src_decls ds ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ tc_rn_src_decls (spliced_decls ++ rest_ds) } + ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls" } } @@ -583,7 +585,8 @@ tcRnHsBootDecls hsc_src decls -- Check for illegal declarations ; case group_tail of - Just (SpliceDecl d _, _) -> badBootDecl hsc_src "splice" d + Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d + Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls" Nothing -> return () ; mapM_ (badBootDecl hsc_src "foreign") for_decls ; mapM_ (badBootDecl hsc_src "default") def_decls @@ -1978,7 +1981,7 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (BodyStmt expr _ _ _)) +tcUserStmt (L loc (BodyStmt _ expr _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO @@ -1995,36 +1998,38 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds noExt + let_stmt = L loc $ LetStmt noExt $ noLoc $ HsValBinds noExt $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e] - bind_stmt = L loc $ BindStmt + bind_stmt = L loc $ BindStmt noExt (L loc (VarPat noExt (L loc fresh_it))) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr - placeHolder -- [; print it] - print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) + print_it = L loc $ BodyStmt noExt + (nlHsApp (nlHsVar interPrintName) + (nlHsVar fresh_it)) (mkRnSyntaxExpr thenIOName) - noSyntaxExpr placeHolderType + noSyntaxExpr -- NewA - no_it_a = L loc $ BodyStmt (nlHsApps bindIOName + no_it_a = L loc $ BodyStmt noExt (nlHsApps bindIOName [rn_expr , nlHsVar interPrintName]) (mkRnSyntaxExpr thenIOName) - noSyntaxExpr placeHolderType + noSyntaxExpr - no_it_b = L loc $ BodyStmt (rn_expr) + no_it_b = L loc $ BodyStmt noExt (rn_expr) (mkRnSyntaxExpr thenIOName) - noSyntaxExpr placeHolderType + noSyntaxExpr - no_it_c = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr placeHolderType + no_it_c = L loc $ BodyStmt noExt + (nlHsApp (nlHsVar interPrintName) rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr -- See Note [GHCi Plans] @@ -2080,8 +2085,8 @@ tcUserStmt rdr_stmt@(L loc _) ; ghciStep <- getGhciStepIO ; let gi_stmt - | (L loc (BindStmt pat expr op1 op2 ty)) <- rn_stmt - = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2 ty + | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 | otherwise = rn_stmt ; opt_pr_flag <- goptM Opt_PrintBindResult @@ -2103,9 +2108,9 @@ tcUserStmt rdr_stmt@(L loc _) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where - print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + print_v = L loc $ BodyStmt noExt (nlHsApp (nlHsVar printName) + (nlHsVar v)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - placeHolderType {- Note [GHCi Plans] @@ -2297,7 +2302,7 @@ tcRnType :: HscEnv tcRnType hsc_env normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] - do { (HsWC { hswc_wcs = wcs, hswc_body = rn_type }, _fvs) + do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs) <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type) -- The type can have wild cards, but no implicit -- generalisation; e.g. :kind (T _) diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index be2b9343ef..abca980cdf 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -135,8 +135,8 @@ tcRnExports explicit_mod exports | explicit_mod = exports | ghcLink dflags == LinkInMemory = Nothing | otherwise - = Just (noLoc [noLoc - (IEVar (noLoc (IEName $ noLoc main_RDR_Unqual)))]) + = Just (noLoc [noLoc (IEVar noExt + (noLoc (IEName $ noLoc main_RDR_Unqual)))]) -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope @@ -225,9 +225,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod exports_from_item :: ExportAccum -> LIE GhcPs -> RnM ExportAccum exports_from_item acc@(ExportAccum ie_avails occs) - (L loc (IEModuleContents (L lm mod))) - | let earlier_mods = [ mod - | ((L _ (IEModuleContents (L _ mod))), _) <- ie_avails ] + (L loc (IEModuleContents _ (L lm mod))) + | let earlier_mods + = [ mod + | ((L _ (IEModuleContents _ (L _ mod))), _) <- ie_avails ] , mod `elem` earlier_mods -- Duplicate export of M = do { warnIfFlag Opt_WarnDuplicateExports True (dupModuleExport mod) ; @@ -250,7 +251,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod ; traceRn "efa" (ppr mod $$ ppr all_gres) ; addUsedGREs all_gres - ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names fls + ; occs' <- check_occs (IEModuleContents noExt (noLoc mod)) occs + names fls -- This check_occs not only finds conflicts -- between this item and others, but also -- internally within this item. That is, if @@ -261,8 +263,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod (vcat [ ppr mod , ppr new_exports ]) - ; return (ExportAccum (((L loc (IEModuleContents (L lm mod))), new_exports) : ie_avails) - occs') } + ; return (ExportAccum (((L loc (IEModuleContents noExt (L lm mod))) + , new_exports) : ie_avails) occs') } exports_from_item acc@(ExportAccum lie_avails occs) (L loc ie) | isDoc ie @@ -283,23 +285,24 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod ------------- lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar (L l rdr)) + lookup_ie (IEVar _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar (L l (replaceWrappedName rdr name)), avail) + return (IEVar noExt (L l (replaceWrappedName rdr name)), avail) - lookup_ie (IEThingAbs (L l rdr)) + lookup_ie (IEThingAbs _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs (L l (replaceWrappedName rdr name)), avail) + return (IEThingAbs noExt (L l (replaceWrappedName rdr name)) + , avail) - lookup_ie ie@(IEThingAll n') + lookup_ie ie@(IEThingAll _ n') = do (n, avail, flds) <- lookup_ie_all ie n' let name = unLoc n - return (IEThingAll (replaceLWrappedName n' (unLoc n)) + return (IEThingAll noExt (replaceLWrappedName n' (unLoc n)) , AvailTC name (name:avail) flds) - lookup_ie ie@(IEThingWith l wc sub_rdrs _) + lookup_ie ie@(IEThingWith _ l wc sub_rdrs _) = do (lname, subs, avails, flds) <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs @@ -308,7 +311,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod NoIEWildcard -> return (lname, [], []) IEWildcard _ -> lookup_ie_all ie l let name = unLoc lname - return (IEThingWith (replaceLWrappedName l name) wc subs + return (IEThingWith noExt (replaceLWrappedName l name) wc subs (flds ++ (map noLoc all_flds)), AvailTC name (name : avails ++ all_avail) (map unLoc flds ++ all_flds)) @@ -349,11 +352,11 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod ------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) - lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc - return (IEGroup lev rn_doc) - lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc - return (IEDoc rn_doc) - lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str) + lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc + return (IEGroup noExt lev rn_doc) + lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc + return (IEDoc noExt rn_doc) + lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExt str) lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier -- In an export item M.T(A,B,C), we want to treat the uses of @@ -374,9 +377,9 @@ classifyGRE gre = case gre_par gre of n = gre_name gre isDoc :: IE GhcPs -> Bool -isDoc (IEDoc _) = True -isDoc (IEDocNamed _) = True -isDoc (IEGroup _ _) = True +isDoc (IEDoc {}) = True +isDoc (IEDocNamed {}) = True +isDoc (IEGroup {}) = True isDoc _ = False -- Renaming and typechecking of exports happens after everything else has @@ -649,8 +652,8 @@ dupExport_ok n ie1 ie2 = not ( single ie1 || single ie2 || (explicit_in ie1 && explicit_in ie2) ) where - explicit_in (IEModuleContents _) = False -- module M - explicit_in (IEThingAll r) + explicit_in (IEModuleContents {}) = False -- module M + explicit_in (IEThingAll _ r) = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) explicit_in _ = True @@ -693,7 +696,8 @@ exportErrCtxt herald exp = text "In the" <+> text (herald ++ ":") <+> ppr exp -addExportErrCtxt :: (OutputableBndrId s) => IE s -> TcM a -> TcM a +addExportErrCtxt :: (OutputableBndrId (GhcPass p)) + => IE (GhcPass p) -> TcM a -> TcM a addExportErrCtxt ie = addErrCtxt exportCtxt where exportCtxt = text "In the export:" <+> ppr ie diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index f13726c56d..781c6bada4 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3536,14 +3536,17 @@ matchesCtOrigin (MG { mg_alts = alts }) | otherwise = Shouldn'tHappenOrigin "multi-way match" +matchesCtOrigin (XMatchGroup{}) = panic "matchesCtOrigin" -- | Extract a suitable CtOrigin from guarded RHSs grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss +grhssCtOrigin (XGRHSs _) = panic "grhssCtOrigin" -- | Extract a suitable CtOrigin from a list of guarded RHSs lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin -lGRHSCtOrigin [L _ (GRHS _ (L _ e))] = exprCtOrigin e +lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e +lGRHSCtOrigin [L _ (XGRHS _)] = panic "lGRHSCtOrigin" lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" pprCtLoc :: CtLoc -> SDoc diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 75e4025ac2..1a55e4a553 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -58,12 +58,13 @@ tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId] tcRules decls = mapM (wrapLocM tcRuleDecls) decls tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId) -tcRuleDecls (HsRules src decls) +tcRuleDecls (HsRules _ src decls) = do { tc_decls <- mapM (wrapLocM tcRule) decls - ; return (HsRules src tc_decls) } + ; return (HsRules noExt src tc_decls) } +tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls" tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId) -tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) +tcRule (HsRule (HsRuleRn fv_lhs fv_rhs) name act hs_bndrs lhs rhs) = addErrCtxt (ruleCtxt $ snd $ unLoc name) $ do { traceTc "---- Rule ------" (pprFullRuleName name) @@ -131,19 +132,20 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) lhs_evs rhs_wanted ; emitImplications (lhs_implic `unionBags` rhs_implic) - ; return (HsRule name act - (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids)) - (mkHsDictLet lhs_binds lhs') fv_lhs - (mkHsDictLet rhs_binds rhs') fv_rhs) } + ; return (HsRule (HsRuleRn fv_lhs fv_rhs)name act + (map (noLoc . RuleBndr noExt . noLoc) (qtkvs ++ tpl_ids)) + (mkHsDictLet lhs_binds lhs') + (mkHsDictLet rhs_binds rhs')) } +tcRule (XRuleDecl _) = panic "tcRule" tcRuleBndrs :: [LRuleBndr GhcRn] -> TcM [Var] tcRuleBndrs [] = return [] -tcRuleBndrs (L _ (RuleBndr (L _ name)) : rule_bndrs) +tcRuleBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) = do { ty <- newOpenFlexiTyVarTy ; vars <- tcRuleBndrs rule_bndrs ; return (mkLocalId name ty : vars) } -tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) +tcRuleBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a @@ -156,6 +158,7 @@ tcRuleBndrs (L _ (RuleBndrSig (L _ name) rn_ty) : rule_bndrs) ; vars <- tcExtendTyVarEnv2 tvs $ tcRuleBndrs rule_bndrs ; return (map snd tvs ++ id : vars) } +tcRuleBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleBndrs" ruleCtxt :: FastString -> SDoc ruleCtxt name = text "When checking the transformation rule" <+> diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 8624735169..13b5e7ad48 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -251,7 +251,8 @@ completeSigFromId ctxt id isCompleteHsSig :: LHsSigWcType GhcRn -> Bool -- ^ If there are no wildcards, return a LHsSigType -isCompleteHsSig (HsWC { hswc_wcs = wcs }) = null wcs +isCompleteHsSig (HsWC { hswc_ext = wcs }) = null wcs +isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig" {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -302,7 +303,7 @@ tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo -- See Note [Pattern synonym signatures] -- See Note [Recipe for checking a signature] in TcHsType tcPatSynSig name sig_ty - | HsIB { hsib_vars = implicit_hs_tvs + | HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_hs_tvs } , hsib_body = hs_ty } <- sig_ty , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTy hs_ty , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1 @@ -383,6 +384,7 @@ tcPatSynSig name sig_ty mkSpecForAllTys ex $ mkFunTys prov $ body +tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig" ppr_tvs :: [TyVar] -> SDoc ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 81cc474d32..2738929aa5 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -898,13 +898,13 @@ instance TH.Quasi TcM where updTcRef th_topdecls_var (\topds -> ds ++ topds) where checkTopDecl :: HsDecl GhcPs -> TcM () - checkTopDecl (ValD binds) + checkTopDecl (ValD _ binds) = mapM_ bindName (collectHsBindBinders binds) - checkTopDecl (SigD _) + checkTopDecl (SigD _ _) = return () - checkTopDecl (AnnD _) + checkTopDecl (AnnD _ _) = return () - checkTopDecl (ForD (ForeignImport { fd_name = L _ name })) + checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl _ = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 4363cd3f5c..8cd583c311 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -185,6 +185,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds ; (gbl_env, inst_info, datafam_deriv_info) <- tcInstDecls1 instds ; return (gbl_env, inst_info, datafam_deriv_info) } } } +tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup" tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon] tcTyClDecls tyclds role_annots @@ -501,6 +502,7 @@ kcTyClGroup decls -> FamilyDecl GhcRn -> TcM TcTyCon generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name }) = generalise kind_env name + generaliseFamDecl _ (XFamilyDecl _) = panic "generaliseFamDecl" pp_res tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) @@ -615,6 +617,9 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name HsKindSig _ _ k -> Just k _ -> Nothing +getInitialKind (DataDecl _ (L _ _) _ _ (XHsDataDefn _)) = panic "getInitialKind" +getInitialKind (XTyClDecl _) = panic "getInitialKind" + --------------------------------- getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class -> [LFamilyDecl GhcRn] @@ -633,13 +638,13 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name = do { (tycon, _) <- kcLHsQTyVars name flav cusk ktvs $ do { res_k <- case resultSig of - KindSig ki -> tcLHsKindSig ctxt ki - TyVarSig (L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki - _ -- open type families have * return kind by default - | tcFlavourIsOpen flav -> return liftedTypeKind - -- closed type families have their return kind inferred - -- by default - | otherwise -> newMetaKindVar + KindSig _ ki -> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki + _ -- open type families have * return kind by default + | tcFlavourIsOpen flav -> return liftedTypeKind + -- closed type families have their return kind inferred + -- by default + | otherwise -> newMetaKindVar ; return (res_k, ()) } ; return (mkTcTyConEnv tycon) } where @@ -649,6 +654,7 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name OpenTypeFamily -> OpenTypeFamilyFlavour (isJust mb_cusk) ClosedTypeFamily _ -> ClosedTypeFamilyFlavour ctxt = TyFamResKindCtxt name +getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind" ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () @@ -703,8 +709,8 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty kc_sig _ = return () -kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name - , fdInfo = fd_info })) +kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = L _ fam_tc_name + , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't -- do anything here = case fd_info of @@ -712,6 +718,9 @@ kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name do { fam_tc <- kcLookupTcTyCon fam_tc_name ; mapM_ (kcTyFamInstEqn fam_tc) eqns } _ -> return () +kcTyClDecl (FamDecl _ (XFamilyDecl _)) = panic "kcTyClDecl" +kcTyClDecl (DataDecl _ (L _ _) _ _ (XHsDataDefn _)) = panic "kcTyClDecl" +kcTyClDecl (XTyClDecl _) = panic "kcTyClDecl" ------------------- kcConDecl :: ConDecl GhcRn -> TcM () @@ -728,7 +737,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs kcConDecl (ConDeclGADT { con_names = names , con_qvars = qtvs, con_mb_cxt = cxt , con_args = args, con_res_ty = res_ty }) - | HsQTvs { hsq_implicit = implicit_tkv_nms + | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms } , hsq_explicit = explicit_tkv_nms } <- qtvs = -- Even though the data constructor's type is closed, we -- must still kind-check the type, because that may influence @@ -745,6 +754,8 @@ kcConDecl (ConDeclGADT { con_names = names ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args) ; _ <- tcHsOpenType res_ty ; return () } +kcConDecl (XConDecl _) = panic "kcConDecl" +kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl" {- Note [Recursion and promoting data constructors] @@ -967,6 +978,8 @@ tcTyClDecl1 _parent roles_info ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; ; return (tvs1', tvs2') } +tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1" + tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_name) , fdResultSig = L _ sig, fdTyVars = user_tyvars @@ -1059,7 +1072,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na ; return fam_tc } } | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker - +tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1" -- | Maybe return a list of Bools that say whether a type family was declared -- injective in the corresponding type arguments. Length of the list is equal to @@ -1183,6 +1196,7 @@ tcDataDefn roles_info DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) +tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn" {- ************************************************************************ @@ -1252,7 +1266,8 @@ tcDefaultAssocDecl _ (d1:_:_) tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name , feqn_pats = hs_tvs , feqn_rhs = rhs })] - | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs + | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_vars} + , hsq_explicit = exp_vars } <- hs_tvs = -- See Note [Type-checking default assoc decls] setSrcSpan loc $ tcAddFamInstCtxt (text "default type instance") tc_name $ @@ -1300,6 +1315,9 @@ tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = L _ tc_name -- We check for well-formedness and validity later, -- in checkValidClass } +tcDefaultAssocDecl _ [L _ (XFamEqn _)] = panic "tcDefaultAssocDecl" +tcDefaultAssocDecl _ [L _ (FamEqn _ (L _ _) (XLHsQTyVars _) _ _)] + = panic "tcDefaultAssocDecl" {- Note [Type-checking default assoc decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1325,7 +1343,7 @@ proper tcMatchTys here.) -} ------------------------- kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () kcTyFamInstEqn tc_fam_tc - (L loc (HsIB { hsib_vars = tv_names + (L loc (HsIB { hsib_ext = HsIBRn { hsib_vars = tv_names } , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name , feqn_pats = pats , feqn_rhs = hs_ty }})) @@ -1345,6 +1363,8 @@ kcTyFamInstEqn tc_fam_tc where fam_name = tyConName tc_fam_tc vis_arity = length (tyConVisibleTyVars tc_fam_tc) +kcTyFamInstEqn _ (L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn" +kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn" -- Infer the kind of the type on the RHS of a type family eqn. Then use -- this kind to check the kind of the LHS of the equation. This is useful @@ -1376,7 +1396,7 @@ tcTyFamInstEqn :: TcTyCon -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn -- Needs to be here, not in TcInstDcls, because closed families -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (HsIB { hsib_vars = tv_names + (L loc (HsIB { hsib_ext = HsIBRn { hsib_vars = tv_names } , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name , feqn_pats = pats , feqn_rhs = hs_ty }})) @@ -1395,6 +1415,8 @@ tcTyFamInstEqn fam_tc mb_clsinfo ; return (mkCoAxBranch tvs' [] pats' rhs_ty' (map (const Nominal) tvs') loc) } +tcTyFamInstEqn _ _ (L _ (XHsImplicitBndrs _)) = panic "tcTyFamInstEqn" +tcTyFamInstEqn _ _ (L _ (HsIB _ (XFamEqn _))) = panic "tcTyFamInstEqn" kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars -- (associated types only) @@ -1457,6 +1479,12 @@ kcDataDefn mb_kind_env where bogus_ty = pprPanic "kcDataDefn" (ppr fam_name <+> ppr pats) pp_fam_app = pprFamInstLHS fam_name pats fixity (unLoc ctxt) mb_kind +kcDataDefn _ (DataFamInstDecl (XHsImplicitBndrs _)) _ + = panic "kcDataDefn" +kcDataDefn _ (DataFamInstDecl (HsIB _ (FamEqn _ _ _ _ (XHsDataDefn _)))) _ + = panic "kcDataDefn" +kcDataDefn _ (DataFamInstDecl (HsIB _ (XFamEqn _))) _ + = panic "kcDataDefn" {- Kind check type patterns and kind annotate the embedded type variables. @@ -1867,7 +1895,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl , con_qvars = qtvs , con_mb_cxt = cxt, con_args = hs_args , con_res_ty = res_ty }) - | HsQTvs { hsq_implicit = implicit_tkv_nms + | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms } , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) @@ -1938,6 +1966,9 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl ; traceTc "tcConDecl 2" (ppr names) ; mapM buildOneDataCon names } +tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) + = panic "tcConDecl" +tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl" -- | Produce the telescope of kind variables that this datacon is -- implicitly quantified over. Incoming type need not be zonked. @@ -3188,7 +3219,7 @@ checkValidRoleAnnots role_annots tc check_roles = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ the_role_annots)) -> + \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ setSrcSpan loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations @@ -3314,6 +3345,8 @@ tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_body = eqn }}) = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") (unLoc (feqn_tycon eqn)) +tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _)) + = panic "tcMkDataFamInstCtxt" tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a tcAddDataFamInstCtxt decl @@ -3519,18 +3552,20 @@ badRoleAnnot var annot inferred , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ annots)) +wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) = hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) +wrongNumberOfRoles _ (L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles" illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl tycon _)) +illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") +illegalRoleAnnotDecl (L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl" needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 57bd21c67c..da8221d72b 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -481,7 +481,7 @@ initialRoleEnv1 hsc_src annots_env tc -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupRoleAnnot annots_env name of - Just (L _ (RoleAnnotDecl _ annots)) + Just (L _ (RoleAnnotDecl _ _ annots)) | annots `lengthIs` num_exps -> map unLoc annots _ -> replicate num_exps Nothing default_roles = build_default_roles argflags role_annots |