diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2017-11-09 23:20:19 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2017-11-11 23:16:39 +0200 |
| commit | e3ec2e7ae94524ebd111963faf34b84d942265b4 (patch) | |
| tree | 022bca155b29cf0d1c40b25537bc238eec829db8 | |
| parent | 86c50a16e6a17349a7662067232236e38e46ba42 (diff) | |
| download | haskell-e3ec2e7ae94524ebd111963faf34b84d942265b4.tar.gz | |
WIP on combined Step 1 and 3 for Trees That Grow, HsExpr
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow
Trees that grow extension points are added for
- HsExpr
Updates haddock submodule
Test Plan: ./validate
Reviewers: bgamari, goldfire
Subscribers: rwbarton, thomie, shayan-najd, mpickering
Differential Revision: https://phabricator.haskell.org/D4177
47 files changed, 1451 insertions, 1081 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 1eb6aa430d..ae1de7716d 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -675,12 +675,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon) -- | A fake guard pattern (True <- _) used to represent cases we cannot handle fake_pat :: Pattern fake_pat = PmGrd { pm_grd_pv = [truePattern] - , pm_grd_expr = PmExprOther EWildPat } + , pm_grd_expr = PmExprOther (EWildPat noExt) } {-# INLINE fake_pat #-} -- | Check whether a guard pattern is generated by the checker (unhandled) isFakeGuard :: [Pattern] -> PmExpr -> Bool -isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat) +isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _)) | c == trueDataCon = True | otherwise = False isFakeGuard _pats _e = False @@ -760,7 +760,7 @@ translatePat fam_insts pat = case pat of case all cantFailPattern ps of True -> do (xp,xe) <- mkPmId2Forms arg_ty - let g = mkGuard ps (HsApp lexpr xe) + let g = mkGuard ps (HsApp noExt lexpr xe) return [xp,g] False -> mkCanFailPmPat arg_ty @@ -1217,7 +1217,7 @@ mkPmId ty = getUniqueM >>= \unique -> mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc) mkPmId2Forms ty = do x <- mkPmId ty - return (PmVar x, noLoc (HsVar (noLoc x))) + return (PmVar x, noLoc (HsVar noExt (noLoc x))) -- ---------------------------------------------------------------------------- -- * Converting between Value Abstractions, Patterns and PmExpr diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 87914976df..44d95910a3 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -459,15 +459,15 @@ addTickLHsExprNever (L pos e0) = do -- general heuristic: expressions which do not denote values are good -- break points isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (HsApp {}) = True -isGoodBreakExpr (HsAppTypeOut {}) = True -isGoodBreakExpr (OpApp {}) = True -isGoodBreakExpr _other = False +isGoodBreakExpr (HsApp {}) = True +isGoodBreakExpr (HsAppType {}) = True +isGoodBreakExpr (OpApp {}) = True +isGoodBreakExpr _other = False isCallSite :: HsExpr GhcTc -> Bool -isCallSite HsApp{} = True -isCallSite HsAppTypeOut{} = True -isCallSite OpApp{} = True +isCallSite HsApp{} = True +isCallSite HsAppType{} = True +isCallSite OpApp{} = True isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) @@ -489,55 +489,58 @@ addBinTickLHsExpr boxLabel (L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e -addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" -addTickHsExpr e@(HsConLikeOut con) +addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e +addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" +addTickHsExpr e@(HsConLikeOut _ con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e -addTickHsExpr e@(HsIPVar _) = return e -addTickHsExpr e@(HsOverLit _) = return e -addTickHsExpr e@(HsOverLabel{}) = return e -addTickHsExpr e@(HsLit _) = return e -addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup) -addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs) -addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e) - (return ty) - -addTickHsExpr (OpApp e1 e2 fix e3) = +addTickHsExpr e@(HsIPVar {}) = return e +addTickHsExpr e@(HsOverLit {}) = return e +addTickHsExpr e@(HsOverLabel{}) = return e +addTickHsExpr e@(HsLit {}) = return e +addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x) + (addTickMatchGroup True matchgroup) +addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) + (addTickMatchGroup True mgs) +addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty) + (addTickLHsExprNever e) + + +addTickHsExpr (OpApp fix e1 e2 e3) = liftM4 OpApp + (return fix) (addTickLHsExpr e1) (addTickLHsExprNever e2) - (return fix) (addTickLHsExpr e3) -addTickHsExpr (NegApp e neg) = - liftM2 NegApp +addTickHsExpr (NegApp x e neg) = + liftM2 (NegApp x) (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar e) = - liftM HsPar (addTickLHsExprEvalInner e) -addTickHsExpr (SectionL e1 e2) = - liftM2 SectionL +addTickHsExpr (HsPar x e) = + liftM (HsPar x) (addTickLHsExprEvalInner e) +addTickHsExpr (SectionL x e1 e2) = + liftM2 (SectionL x) (addTickLHsExpr e1) (addTickLHsExprNever e2) -addTickHsExpr (SectionR e1 e2) = - liftM2 SectionR +addTickHsExpr (SectionR x e1 e2) = + liftM2 (SectionR x) (addTickLHsExprNever e1) (addTickLHsExpr e2) -addTickHsExpr (ExplicitTuple es boxity) = - liftM2 ExplicitTuple +addTickHsExpr (ExplicitTuple x es boxity) = + liftM2 (ExplicitTuple x) (mapM addTickTupArg es) (return boxity) -addTickHsExpr (ExplicitSum tag arity e ty) = do +addTickHsExpr (ExplicitSum ty tag arity e) = do e' <- addTickLHsExpr e - return (ExplicitSum tag arity e' ty) -addTickHsExpr (HsCase e mgs) = - liftM2 HsCase + return (ExplicitSum ty tag arity e') +addTickHsExpr (HsCase x e mgs) = + liftM2 (HsCase x) (addTickLHsExpr e) -- not an EvalInner; e might not necessarily -- be evaluated. (addTickMatchGroup False mgs) -addTickHsExpr (HsIf cnd e1 e2 e3) = - liftM3 (HsIf cnd) +addTickHsExpr (HsIf x cnd e1 e2 e3) = + liftM3 (HsIf x cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3) @@ -545,14 +548,14 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet (L l binds) e) = +addTickHsExpr (HsLet x (L l binds) e) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet . L l) + liftM2 (HsLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) -addTickHsExpr (HsDo cxt (L l stmts) srcloc) +addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo cxt (L l stmts') srcloc) } + ; return (HsDo srcloc cxt (L l stmts')) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -582,12 +585,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) ; flds' <- mapM addTickHsRecField flds ; return (expr { rupd_expr = e', rupd_flds = flds' }) } -addTickHsExpr (ExprWithTySig e ty) = +addTickHsExpr (ExprWithTySig ty e) = liftM2 ExprWithTySig - (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures (return ty) -addTickHsExpr (ArithSeq ty wit arith_seq) = + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures +addTickHsExpr (ArithSeq ty wit arith_seq) = liftM3 ArithSeq (return ty) (addTickWit wit) @@ -597,26 +600,26 @@ addTickHsExpr (ArithSeq ty wit arith_seq) = return (Just fl') -- We might encounter existing ticks (multiple Coverage passes) -addTickHsExpr (HsTick t e) = - liftM (HsTick t) (addTickLHsExprNever e) -addTickHsExpr (HsBinTick t0 t1 e) = - liftM (HsBinTick t0 t1) (addTickLHsExprNever e) +addTickHsExpr (HsTick x t e) = + liftM (HsTick x t) (addTickLHsExprNever e) +addTickHsExpr (HsBinTick x t0 t1 e) = + liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do +addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 -addTickHsExpr (PArrSeq ty arith_seq) = +addTickHsExpr (PArrSeq ty arith_seq) = liftM2 PArrSeq (return ty) (addTickArithSeqInfo arith_seq) -addTickHsExpr (HsSCC src nm e) = - liftM3 HsSCC +addTickHsExpr (HsSCC x src nm e) = + liftM3 (HsSCC x) (return src) (return nm) (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn src nm e) = - liftM3 HsCoreAnn +addTickHsExpr (HsCoreAnn x src nm e) = + liftM3 (HsCoreAnn x) (return src) (return nm) (addTickLHsExpr e) @@ -624,20 +627,15 @@ addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e addTickHsExpr e@(HsSpliceE {}) = return e -addTickHsExpr (HsProc pat cmdtop) = - liftM2 HsProc +addTickHsExpr (HsProc x pat cmdtop) = + liftM2 (HsProc x) (addTickLPat pat) (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (HsWrap w e) = - liftM2 HsWrap +addTickHsExpr (HsWrap x w e) = + liftM2 (HsWrap x) (return w) (addTickHsExpr e) -- Explicitly no tick on inside -addTickHsExpr (ExprWithTySigOut e ty) = - liftM2 ExprWithTySigOut - (addTickLHsExprNever e) -- No need to tick the inner expression - (return ty) -- for expressions with signatures - -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) @@ -762,8 +760,8 @@ addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e | otherwise = addTickLHsExprRHS e addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) - -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc) + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) addTickApplicativeArg isGuard (op, arg) = liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where @@ -1169,7 +1167,7 @@ allocTickBox boxLabel countEntries topOnly pos m = (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L pos (HsTick tickish (L pos e))) + return (L pos (HsTick noExt tickish (L pos e))) ) (do e <- m return (L pos e) @@ -1255,13 +1253,14 @@ mkBinTickBoxHpc boxLabel pos e = c = tickBoxCount st mes = mixEntries st in - ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e - -- notice that F and T are reversed, - -- because we are building the list in - -- reverse... - , noFVs - , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} - ) + ( L pos $ HsTick noExt (HpcTick (this_mod env) c) + $ L pos $ HsBinTick noExt (c+1) (c+2) e + -- notice that F and T are reversed, + -- because we are building the list in + -- reverse... + , noFVs + , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} + ) mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 2007065f51..c9c0a089c7 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -575,10 +575,12 @@ dsCmd ids local_vars stack_ty res_ty left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName let - left_id = HsConLikeOut (RealDataCon left_con) - right_id = HsConLikeOut (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e + left_id = HsConLikeOut noExt (RealDataCon left_con) + right_id = HsConLikeOut noExt (RealDataCon right_con) + left_expr ty1 ty2 e = noLoc $ HsApp noExt + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLoc $ HsApp noExt + (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. @@ -597,9 +599,10 @@ dsCmd ids local_vars stack_ty res_ty (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' - , mg_arg_tys = arg_tys - , mg_res_ty = sum_ty, mg_origin = origin })) + 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 })) -- Note that we replace the HsCase result type by sum_ty, -- which is the type of matches' diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index ef2be8e3da..42c84557b7 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -250,17 +250,18 @@ dsExpr = ds_expr False ds_expr :: Bool -- are we directly inside an HsWrap? -- See Wrinkle in Note [Detecting forced eta expansion] -> HsExpr GhcTc -> DsM CoreExpr -ds_expr _ (HsPar e) = dsLExpr e -ds_expr _ (ExprWithTySigOut e _) = dsLExpr e -ds_expr w (HsVar (L _ var)) = dsHsVar w var +ds_expr _ (HsPar _ e) = dsLExpr e +ds_expr _ (ExprWithTySig _ e) = dsLExpr e +ds_expr w (HsVar _ (L _ var)) = dsHsVar w var ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them -ds_expr w (HsConLikeOut con) = dsConLike w con -ds_expr _ (HsIPVar _) = panic "dsExpr: HsIPVar" +ds_expr w (HsConLikeOut _ con) = dsConLike w con +ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel" -ds_expr _ (HsLit lit) = dsLit (convertLit lit) -ds_expr _ (HsOverLit lit) = dsOverLit lit +ds_expr _ (HsLit _ lit) = dsLit (convertLit lit) +ds_expr _ (HsOverLit _ lit) = dsOverLit lit +ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" -ds_expr _ (HsWrap co_fn e) +ds_expr _ (HsWrap _ co_fn e) = do { e' <- ds_expr True e ; wrap' <- dsHsWrapper co_fn ; dflags <- getDynFlags @@ -270,7 +271,7 @@ ds_expr _ (HsWrap co_fn e) ; warnAboutIdentities dflags e' wrapped_ty ; return wrapped_e } -ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i }))) +ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) = do { expr' <- putSrcSpanDs loc $ do { dflags <- getDynFlags @@ -279,23 +280,23 @@ ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i }))) ; dsOverLit' dflags lit } ; dsSyntaxExpr neg_expr [expr'] } -ds_expr _ (NegApp expr neg_expr) +ds_expr _ (NegApp _ expr neg_expr) = do { expr' <- dsLExpr expr ; dsSyntaxExpr neg_expr [expr'] } -ds_expr _ (HsLam a_Match) +ds_expr _ (HsLam _ a_Match) = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match -ds_expr _ (HsLamCase matches) +ds_expr _ (HsLamCase _ matches) = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches ; return $ Lam discrim_var matching_code } -ds_expr _ e@(HsApp fun arg) +ds_expr _ e@(HsApp _ fun arg) = do { fun' <- dsLExpr fun ; dsWhenNoErrs (dsLExprNoLP arg) (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } -ds_expr _ (HsAppTypeOut e _) +ds_expr _ (HsAppType _ e) -- ignore type arguments here; they're in the wrappers instead at this point = dsLExpr e @@ -339,19 +340,19 @@ If \tr{expr} is actually just a variable, say, then the simplifier will sort it out. -} -ds_expr _ e@(OpApp e1 op _ e2) +ds_expr _ e@(OpApp _ e1 op e2) = -- for the type of y, we need the type of op's 2nd argument do { op' <- dsLExpr op ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } -ds_expr _ (SectionL expr op) -- Desugar (e !) to ((!) e) +ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e) = do { op' <- dsLExpr op ; dsWhenNoErrs (dsLExprNoLP expr) (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') } -- dsLExpr (SectionR op expr) -- \ x -> op x expr -ds_expr _ e@(SectionR op expr) = do +ds_expr _ e@(SectionR _ op expr) = do core_op <- dsLExpr op -- for the type of x, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) @@ -362,7 +363,7 @@ ds_expr _ e@(SectionR op expr) = do Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id])) -ds_expr _ (ExplicitTuple tup_args boxity) +ds_expr _ (ExplicitTuple _ tup_args boxity) = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. @@ -379,14 +380,14 @@ ds_expr _ (ExplicitTuple tup_args boxity) (\(lam_vars, args) -> mkCoreLams lam_vars $ mkCoreTupBoxity boxity args) } -ds_expr _ (ExplicitSum alt arity expr types) +ds_expr _ (ExplicitSum types alt arity expr) = do { dsWhenNoErrs (dsLExprNoLP expr) (\core_expr -> mkCoreConApps (sumDataCon alt arity) (map (Type . getRuntimeRep) types ++ map Type types ++ [core_expr]) ) } -ds_expr _ (HsSCC _ cc expr@(L loc _)) = do +ds_expr _ (HsSCC _ _ cc expr@(L loc _)) = do dflags <- getDynFlags if gopt Opt_SccProfilingOn dflags then do @@ -397,31 +398,31 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do <$> dsLExpr expr else dsLExpr expr -ds_expr _ (HsCoreAnn _ _ expr) +ds_expr _ (HsCoreAnn _ _ _ expr) = dsLExpr expr -ds_expr _ (HsCase discrim matches) +ds_expr _ (HsCase _ discrim matches) = do { core_discrim <- dsLExpr discrim ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches ; return (bindNonRec discrim_var core_discrim matching_code) } -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -ds_expr _ (HsLet binds body) = do +ds_expr _ (HsLet _ binds body) = do body' <- dsLExpr body dsLocalBinds binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -ds_expr _ (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty -ds_expr _ (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) -ds_expr _ (HsDo DoExpr (L _ stmts) _) = dsDo stmts -ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts -ds_expr _ (HsDo MDoExpr (L _ stmts) _) = dsDo stmts -ds_expr _ (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts - -ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr) +ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty +ds_expr _ (HsDo _ PArrComp (L _ stmts)) = dsPArrComp (map unLoc stmts) +ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts + +ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr @@ -454,7 +455,7 @@ ds_expr _ (ExplicitList elt_ty wit xs) -- We desugar [:x1, ..., xn:] as -- singletonP x1 +:+ ... +:+ singletonP xn -- -ds_expr _ (ExplicitPArr ty []) = do +ds_expr _ (ExplicitPArr ty []) = do emptyP <- dsDPHBuiltin emptyPVar return (Var emptyP `App` Type ty) ds_expr _ (ExplicitPArr ty xs) = do @@ -536,8 +537,9 @@ We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. -} -ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds - , rcon_con_like = con_like }) +ds_expr _ (RecordCon { rcon_flds = rbinds + , rcon_ext = RecordConTc { rcon_con_expr = con_expr + , rcon_con_like = con_like }}) = do { con_expr' <- dsExpr con_expr ; let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -596,9 +598,11 @@ So we need to cast (T a Int) to (T a b). Sigh. -} ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields - , rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap } ) + , rupd_ext = RecordUpdTc + { rupd_cons = cons_to_upd + , rupd_in_tys = in_inst_tys + , rupd_out_tys = out_inst_tys + , rupd_wrap = dict_req_wrap }} ) | null fields = dsLExpr record_expr | otherwise @@ -662,7 +666,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con) + inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con) -- Reconstruct with the WrapId so that unpacking happens -- The order here is because of the order in `TcPatSyn`. wrap = mkWpEvVarApps theta_vars <.> @@ -714,16 +718,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- Template Haskell stuff -ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" -ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps -ds_expr _ (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) +ds_expr _ (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut" +ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps +ds_expr _ (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) -- Arrow notation extension -ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd +ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd -- Hpc Support -ds_expr _ (HsTick tickish e) = do +ds_expr _ (HsTick _ tickish e) = do e' <- dsLExpr e return (Tick tickish e') @@ -734,20 +738,19 @@ ds_expr _ (HsTick tickish e) = do -- (did you go here: YES or NO), but will effect accurate -- tick counting. -ds_expr _ (HsBinTick ixT ixF e) = do +ds_expr _ (HsBinTick _ ixT ixF e) = do e2 <- dsLExpr e do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } -ds_expr _ (HsTickPragma _ _ _ expr) = do +ds_expr _ (HsTickPragma _ _ _ _ expr) = do dflags <- getDynFlags if gopt Opt_Hpc dflags then panic "dsExpr:HsTickPragma" else dsLExpr expr -- HsSyn constructs that just shouldn't be here: -ds_expr _ (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsArrApp {}) = panic "dsExpr:HsArrApp" ds_expr _ (HsArrForm {}) = panic "dsExpr:HsArrForm" @@ -755,7 +758,6 @@ ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat" ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat" ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat" ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat" -ds_expr _ (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" @@ -934,9 +936,9 @@ dsDo stmts ; rhss' <- sequence rhss - ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty + ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts) - ; let fun = L noSrcSpan $ HsLam $ + ; let fun = L noSrcSpan $ HsLam noExt $ MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats body'] , mg_arg_tys = arg_tys @@ -968,15 +970,15 @@ dsDo stmts later_pats = rec_tup_pats rets = map noLoc rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam + mfix_arg = noLoc $ HsLam noExt (MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr [mfix_pat] body] , mg_arg_tys = [tup_ty], mg_res_ty = body_ty , mg_origin = Generated }) mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty + body = noLoc $ HsDo body_ty + DoExpr (noLoc (rec_stmts ++ [ret_stmt])) ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, @@ -1138,9 +1140,9 @@ we're not directly in an HsWrap, reject. checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () checkForcedEtaExpansion expr ty | Just var <- case expr of - HsVar (L _ var) -> Just var - HsConLikeOut (RealDataCon dc) -> Just (dataConWrapId dc) - _ -> Nothing + HsVar _ (L _ var) -> Just var + HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) + _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty , not (null bad_tys) = levPolyPrimopErr var ty bad_tys diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index d521f537e5..4296630ba6 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -136,24 +136,25 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId - = Just return +isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey + || v `hasKey` getUnique trueDataConId + = Just return -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (L _ (HsTick tickish e)) +isTrueLHsExpr (L _ (HsConLikeOut _ con)) + | con `hasKey` getUnique trueDataCon = Just return +isTrueLHsExpr (L _ (HsTick _ tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (L _ (HsBinTick ixT _ e)) +isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e +isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e isTrueLHsExpr _ = Nothing {- diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d946516a70..10bb241efc 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1127,7 +1127,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) -repE (HsVar (L _ x)) = +repE (HsVar _ (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x @@ -1135,46 +1135,46 @@ repE (HsVar (L _ x)) = Just (DsBound y) -> repVarOrCon x (coreVar y) Just (DsSplice e) -> do { e' <- dsExpr e ; return (MkC e') } } -repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) -repE (HsOverLabel _ s) = repOverLabel s +repE e@(HsIPVar {}) = notHandled "Implicit parameters" (ppr e) +repE (HsOverLabel _ _ s) = repOverLabel s -repE e@(HsRecFld f) = case f of - Unambiguous x _ -> repE (HsVar (noLoc x)) +repE e@(HsRecFld _ f) = case f of + Unambiguous x _ -> repE (HsVar noExt (noLoc x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e) -- Remember, we're desugaring renamer output here, so -- HsOverlit can definitely occur -repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } -repE (HsLit l) = do { a <- repLiteral l; repLit a } -repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m -repE (HsLamCase (MG { mg_alts = L _ ms })) +repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } +repE (HsLit _ l) = do { a <- repLiteral l; repLit a } +repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = L _ ms })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms } -repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType e t) = do { a <- repLE e +repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} +repE (HsAppType t e) = do { a <- repLE e ; s <- repLTy (hswc_body t) ; repAppType a s } -repE (OpApp e1 op _ e2) = +repE (OpApp _ e1 op e2) = do { arg1 <- repLE e1; arg2 <- repLE e2; the_op <- repLE op ; repInfixApp arg1 the_op arg2 } -repE (NegApp x _) = do +repE (NegApp _ x _) = do a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a -repE (HsPar x) = repLE x -repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } -repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase e (MG { mg_alts = L _ ms })) +repE (HsPar _ x) = repLE x +repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase _ e (MG { mg_alts = L _ ms })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2 ; repCaseE arg core_ms2 } -repE (HsIf _ x y z) = do +repE (HsIf _ _ x y z) = do a <- repLE x b <- repLE y c <- repLE z @@ -1183,13 +1183,13 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs +repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo ctxt (L _ sts) _) +repE e@(HsDo _ ctxt (L _ sts)) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); @@ -1205,13 +1205,13 @@ repE e@(HsDo ctxt (L _ sts) _) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) -repE e@(ExplicitTuple es boxed) +repE e@(ExplicitTuple _ es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs } | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es] ; repUnboxedTup xs } -repE (ExplicitSum alt arity e _) +repE (ExplicitSum _ alt arity e) = do { e1 <- repLE e ; repUnboxedSum e1 alt arity } @@ -1224,7 +1224,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) fs <- repUpdFields flds; repRecUpd x fs } -repE (ExprWithTySig e ty) +repE (ExprWithTySig ty e) = do { e1 <- repLE e ; t1 <- repHsSigWcType ty ; repSigExp e1 t1 } @@ -1246,9 +1246,9 @@ repE (ArithSeq _ _ aseq) = ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE splice) = repSplice splice +repE (HsSpliceE _ splice) = repSplice splice repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC -repE (HsUnboundVar uv) = do +repE (HsUnboundVar _ uv) = do occ <- occNameLit (unboundVarOcc uv) sname <- repNameS occ repUnboundVar sname @@ -1257,7 +1257,6 @@ repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) -repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e) repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 0c260cc513..e95ac2f440 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -977,18 +977,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar (L _ e)) e' = exp e e' - exp e (HsPar (L _ e')) = exp e e' + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers - exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' - exp (HsVar i) (HsVar i') = i == i' - exp (HsConLikeOut c) (HsConLikeOut c') = c == c' + exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' + exp (HsVar _ i) (HsVar _ i') = i == i' + exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' -- the instance for IPName derives using the id, so this works if the -- above does - exp (HsIPVar i) (HsIPVar i') = i == i' - exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x' - exp (HsOverLit l) (HsOverLit l') = + exp (HsIPVar _ i) (HsIPVar _ i') = i == i' + exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' + exp (HsOverLit _ l) (HsOverLit _ l') = -- Overloaded lits are equal if they have the same type -- and the data is the same. -- this is coarser than comparing the SyntaxExpr's in l and l', @@ -996,20 +996,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- because these expressions get written as a bunch of different variables -- (presumably to improve sharing) eqType (overLitType l) (overLitType l') && l == l' - exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' + exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? - exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + exp (OpApp _ l o ri) (OpApp _ l' o' ri') = lexp l l' && lexp o o' && lexp ri ri' - exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n' - exp (SectionL e1 e2) (SectionL e1' e2') = + exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' + exp (SectionL _ e1 e2) (SectionL _ e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (SectionR e1 e2) (SectionR e1' e2') = + exp (SectionR _ e1 e2) (SectionR _ e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = + exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = eq_list tup_arg es1 es2 - exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e' - exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = + exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' + exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' -- Enhancement: could implement equality for more expressions diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 0af58e9728..c7bff64ff3 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -241,10 +241,10 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- See if the expression is an Integral literal -- Remember to look through automatically-added tick-boxes! (Trac #8384) -getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit getLHsIntegralLit _ = Nothing getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index aa1bc814c5..437732da30 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -236,32 +236,32 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e hsExprToPmExpr :: HsExpr GhcTc -> PmExpr -hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) -hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) -hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) -hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) +hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x)) +hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c) +hsExprToPmExpr (HsOverLit _ olit) = PmExprLit (PmOLit False olit) +hsExprToPmExpr (HsLit _ lit) = PmExprLit (PmSLit lit) -hsExprToPmExpr e@(NegApp _ neg_e) +hsExprToPmExpr e@(NegApp _ _ neg_e) | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e = PmExprLit (PmOLit True ol) | otherwise = PmExprOther e -hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e +hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e -hsExprToPmExpr e@(ExplicitTuple ps boxity) +hsExprToPmExpr e@(ExplicitTuple _ ps boxity) | all tupArgPresent ps = mkPmExprData tuple_con tuple_args | otherwise = PmExprOther e where tuple_con = tupleDataCon boxity (length ps) tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ] -hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems) +hsExprToPmExpr e@(ExplicitList _ mb_ol elems) | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) | otherwise = PmExprOther e {- overloaded list: No PmExprApp -} where cons x xs = mkPmExprData consDataCon [x,xs] nil = mkPmExprData nilDataCon [] -hsExprToPmExpr (ExplicitPArr _elem_ty elems) +hsExprToPmExpr (ExplicitPArr _ elems) = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems) @@ -272,16 +272,15 @@ hsExprToPmExpr (ExplicitPArr _elem_ty elems) -- con <- dsLookupDataCon (unLoc c) -- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds) -- return (PmExprCon con args) -hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e - -hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e -hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e -hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e -hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e +hsExprToPmExpr e@(RecordCon {}) = PmExprOther e + +hsExprToPmExpr (HsTick _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 119f31afa0..c64ea53b1a 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -774,77 +774,87 @@ cvtClause ctxt (Clause ps body wheres) cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapL (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } + cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') } cvt (LitE l) - | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } - | otherwise = do { l' <- cvtLit l; return $ HsLit l' } + | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit noExt l' } + | otherwise = do { l' <- cvtLit l; return $ HsLit noExt l' } cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} + ; return $ HsApp noExt (mkLHsPar x') + (mkLHsPar y')} cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp (mkLHsPar x') (mkLHsPar y')} + ; return $ HsApp noExt (mkLHsPar x') + (mkLHsPar y')} cvt (AppTypeE e t) = do { e' <- cvtl e ; t' <- cvtType t ; tp <- wrap_apps t' - ; return $ HsAppType e' $ mkHsWildCardBndrs tp } + ; return $ HsAppType (mkHsWildCardBndrs tp) e' } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing -- oddities that can result from zero-argument -- lambda expressions. See #13856. cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; return $ HsLam (mkMatchGroup FromSource + ; return $ HsLam noExt (mkMatchGroup FromSource [mkSimpleMatch LambdaExpr ps' e'])} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms - ; return $ HsLamCase (mkMatchGroup FromSource ms') + ; return $ HsLamCase noExt + (mkMatchGroup FromSource ms') } - cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } + cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' } -- Note [Dropping constructors] -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple (map (noLoc . Present) es') - Boxed } + ; return $ ExplicitTuple noExt + (map (noLoc . Present) es') Boxed } cvt (UnboxedTupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple + ; return $ ExplicitTuple noExt (map (noLoc . Present) es') Unboxed } cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e ; unboxedSumChecks alt arity - ; return $ ExplicitSum - alt arity e' placeHolderType } + ; return $ ExplicitSum noExt + alt arity e'} cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ HsIf (Just noSyntaxExpr) x' y' z' } + ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' } 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 (noLoc ds') e' } + ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms - ; return $ HsCase e' (mkMatchGroup FromSource ms') } + ; return $ HsCase noExt e' + (mkMatchGroup FromSource ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss - cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd + ; return $ ArithSeq noExt Nothing dd' } cvt (ListE xs) - | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } + | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) + ; 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 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; wrapParL HsPar $ - OpApp (mkLHsPar x') s' undefined (mkLHsPar y') } + ; wrapParL (HsPar noExt) $ + OpApp noExt (mkLHsPar x') s' + (mkLHsPar y') } -- Parenthesise both arguments and result, -- to ensure this operator application does -- does not get re-associated -- See Note [Operator association] cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y - ; wrapParL HsPar $ SectionR s' y' } + ; wrapParL (HsPar noExt) + $ SectionR noExt s' y' } -- See Note [Sections in HsSyn] in HsExpr cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s - ; wrapParL HsPar $ SectionL x' s' } + ; wrapParL (HsPar noExt) + $ SectionL noExt x' s' } - cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' } + cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s + ; return $ HsPar noExt s' } -- Can I indicate this is an infix thing? -- Note [Dropping constructors] @@ -854,9 +864,9 @@ cvtl e = wrapL (cvt e) _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t - ; return $ ExprWithTySig e' (mkLHsSigWcType t') } + ; return $ ExprWithTySig (mkLHsSigWcType t') e' } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } @@ -865,9 +875,9 @@ cvtl e = wrapL (cvt e) <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) flds ; return $ mkRdrRecordUpd e' flds' } - cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e - cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) } + cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e + cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') } + cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) } {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -958,7 +968,7 @@ cvtOpApp x op1 (UInfixE y op2 z) cvtOpApp x op y = do { op' <- cvtl op ; y' <- cvtl y - ; return (OpApp x op' undefined y') } + ; return (OpApp noExt x op' y') } ------------------------------------- -- Do notation and statements @@ -975,7 +985,7 @@ cvtHsDo do_or_lc stmts L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType } + ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) } where bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 82e7f27b46..6fd4d0ec14 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -12,6 +12,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -21,6 +22,7 @@ module HsExpr where -- friends: import GhcPrelude +import PlaceHolder import HsDecls import HsPat import HsLit @@ -83,7 +85,7 @@ type PostTcExpr = HsExpr GhcTc type PostTcTable = [(Name, PostTcExpr)] noPostTcExpr :: PostTcExpr -noPostTcExpr = HsLit (HsString noSourceText (fsLit "noPostTcExpr")) +noPostTcExpr = HsLit noExt (HsString noSourceText (fsLit "noPostTcExpr")) noPostTcTable :: PostTcTable noPostTcTable = [] @@ -114,13 +116,13 @@ deriving instance (DataIdLR p p) => Data (SyntaxExpr p) -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: SourceTextX p => HsExpr p -noExpr = HsLit (HsString (sourceText "noExpr") (fsLit "noExpr")) +noExpr :: SourceTextX (GhcPass p) => HsExpr (GhcPass p) +noExpr = HsLit noExt (HsString (sourceText "noExpr") (fsLit "noExpr")) -noSyntaxExpr :: SourceTextX p => SyntaxExpr p +noSyntaxExpr :: SourceTextX (GhcPass p) => SyntaxExpr (GhcPass p) -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString noSourceText (fsLit "noSyntaxExpr")) , syn_arg_wraps = [] , syn_res_wrap = WpHole } @@ -128,7 +130,7 @@ noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString noSourceText -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name +mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar noExt $ noLoc name , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- don't care about filling in syn_arg_wraps because we're clearly @@ -279,11 +281,13 @@ information to use is the GlobalRdrEnv itself. -- | A Haskell expression. data HsExpr p - = HsVar (Located (IdP p)) -- ^ Variable + = HsVar (XVar p) + (Located (IdP p)) -- ^ Variable -- See Note [Located RdrNames] - | HsUnboundVar UnboundVar -- ^ Unbound variable; also used for "holes" + | HsUnboundVar (XUnboundVar p) + UnboundVar -- ^ Unbound variable; also used for "holes" -- (_ or _x). -- Turned from HsVar to HsUnboundVar by the -- renamer, when it finds an out-of-scope @@ -291,24 +295,31 @@ data HsExpr p -- Turned into HsVar by type checker, to support -- deferred type errors. - | HsConLikeOut ConLike -- ^ After typechecker only; must be different + | HsConLikeOut (XConLikeOut p) + ConLike -- ^ After typechecker only; must be different -- HsVar for pretty printing - | HsRecFld (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector + | HsRecFld (XRecFld p) + (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector -- Not in use after typechecking - | HsOverLabel (Maybe (IdP p)) FastString + | HsOverLabel (XOverLabel p) + (Maybe (IdP p)) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the -- in-scope 'fromLabel'. -- NB: Not in use after typechecking - | HsIPVar HsIPName -- ^ Implicit parameter (not in use after typechecking) - | HsOverLit (HsOverLit p) -- ^ Overloaded literals + | HsIPVar (XIPVar p) + HsIPName -- ^ Implicit parameter (not in use after typechecking) + | HsOverLit (XOverLitE p) + (HsOverLit p) -- ^ Overloaded literals - | HsLit (HsLit p) -- ^ Simple (non-overloaded) literals + | HsLit (XLitE p) + (HsLit p) -- ^ Simple (non-overloaded) literals - | HsLam (MatchGroup p (LHsExpr p)) + | HsLam (XLam p) + (MatchGroup p (LHsExpr p)) -- ^ Lambda abstraction. Currently always a single match -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', @@ -316,7 +327,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation - | HsLamCase (MatchGroup p (LHsExpr p)) -- ^ Lambda-case + | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', @@ -324,28 +335,24 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation - | HsApp (LHsExpr p) (LHsExpr p) -- ^ Application + | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application - | HsAppType (LHsExpr p) (LHsWcType p) -- ^ Visible type application + | HsAppType (XAppTypeE p) (LHsExpr p) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y -- NB: Has wildcards, but no implicit quantification -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', - -- TODO:AZ: Sort out Name - | HsAppTypeOut (LHsExpr p) (LHsWcType GhcRn) -- just for pretty-printing - - -- | Operator applications: -- NB Bracketed ops such as (+) come out as Vars. -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (LHsExpr p) -- left operand + | OpApp (XOpApp p) + (LHsExpr p) -- left operand (LHsExpr p) -- operator - (PostRn p Fixity) -- Renamer adds fixity; bottom until then (LHsExpr p) -- right operand -- | Negation operator. Contains the negated expression and the name @@ -354,18 +361,22 @@ data HsExpr p -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' -- For details on above see note [Api annotations] in ApiAnnotation - | NegApp (LHsExpr p) + | NegApp (XNegApp p) + (LHsExpr p) (SyntaxExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPar (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + | HsPar (XPar p) + (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - | SectionL (LHsExpr p) -- operand; see Note [Sections in HsSyn] + | SectionL (XSectionL p) + (LHsExpr p) -- operand; see Note [Sections in HsSyn] (LHsExpr p) -- operator - | SectionR (LHsExpr p) -- operator; see Note [Sections in HsSyn] + | SectionR (XSectionR p) + (LHsExpr p) -- operator; see Note [Sections in HsSyn] (LHsExpr p) -- operand -- | Used for explicit tuples and sections thereof @@ -375,6 +386,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitTuple + (XExplicitTuple p) [LHsTupArg p] Boxity @@ -386,17 +398,18 @@ data HsExpr p -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before -- the expression, (arity - alternative) after it | ExplicitSum + (XExplicitSum p) ConTag -- Alternative (one-based) Arity -- Sum arity (LHsExpr p) - (PostTc p [Type]) -- the type arguments -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCase (LHsExpr p) + | HsCase (XCase p) + (LHsExpr p) (MatchGroup p (LHsExpr p)) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', @@ -405,7 +418,8 @@ data HsExpr p -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (Maybe (SyntaxExpr p)) -- cond function + | HsIf (XIf p) + (Maybe (SyntaxExpr p)) -- cond function -- Nothing => use the built-in 'if' -- See Note [Rebindable if] (LHsExpr p) -- predicate @@ -418,7 +432,7 @@ data HsExpr p -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation - | HsMultiIf (PostTc p Type) [LGRHS p (LHsExpr p)] + | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] -- | let(rec) -- @@ -427,7 +441,8 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (LHsLocalBinds p) + | HsLet (XLet p) + (LHsLocalBinds p) (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', @@ -436,11 +451,11 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + | HsDo (XDo p) -- Type of the whole expression + (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant (Located [ExprLStmt p]) -- "do":one or more stmts - (PostTc p Type) -- Type of the whole expression -- | Syntactic list: [a,b,c,...] -- @@ -449,7 +464,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitList - (PostTc p Type) -- Gives type of components of list + (XExplicitList p) -- Gives type of components of list (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromListN witness [LHsExpr p] @@ -463,7 +478,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitPArr - (PostTc p Type) -- type of elements of the parallel array + (XExplicitPArr p) -- type of elements of the parallel array [LHsExpr p] -- | Record construction @@ -473,11 +488,9 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | RecordCon - { rcon_con_name :: Located (IdP p) -- The constructor name; + { rcon_ext :: XRecordCon p + , rcon_con_name :: Located (IdP p) -- The constructor name; -- not used after type checking - , rcon_con_like :: PostTc p ConLike - -- The data constructor or pattern synonym - , rcon_con_expr :: PostTcExpr -- Instantiated constructor function , rcon_flds :: HsRecordBinds p } -- The fields -- | Record update @@ -487,18 +500,9 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | RecordUpd - { rupd_expr :: LHsExpr p + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p , rupd_flds :: [LHsRecUpdField p] - , rupd_cons :: PostTc p [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: PostTc p [Type] -- Argument types of *input* record type - , rupd_out_tys :: PostTc p [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: PostTc p HsWrapper -- See note [Record Update HsWrapper] } -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon @@ -509,14 +513,10 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExprWithTySig - (LHsExpr p) - (LHsSigWcType p) - - | ExprWithTySigOut -- Post typechecking - (LHsExpr p) - (LHsSigWcType GhcRn) -- Retain the signature, + (XExprWithTySig p) -- Retain the signature, -- as HsSigType Name, for -- round-tripping purposes + (LHsExpr p) -- | Arithmetic sequence -- @@ -526,7 +526,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ArithSeq - PostTcExpr + (XArithSeq p) (Maybe (SyntaxExpr p)) -- For OverloadedLists, the fromList witness (ArithSeqInfo p) @@ -542,7 +542,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | PArrSeq - PostTcExpr + (XPArrSeq p) (ArithSeqInfo p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# SCC'@, @@ -550,7 +550,8 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsSCC SourceText -- Note [Pragma source text] in BasicTypes + | HsSCC (XSCC p) + SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- "set cost centre" SCC pragma (LHsExpr p) -- expr whose cost is to be measured @@ -558,7 +559,8 @@ data HsExpr p -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreAnn SourceText -- Note [Pragma source text] in BasicTypes + | HsCoreAnn (XCoreAnn p) + SourceText -- Note [Pragma source text] in BasicTypes StringLiteral -- hdaume: core annotation (LHsExpr p) @@ -570,15 +572,17 @@ data HsExpr p -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' -- For details on above see note [Api annotations] in ApiAnnotation - | HsBracket (HsBracket p) + | HsBracket (XBracket p) (HsBracket p) -- See Note [Pending Splices] | HsRnBracketOut + (XRnBracketOut p) (HsBracket GhcRn) -- Output of the renamer is the *original* renamed -- expression, plus [PendingRnSplice] -- _renamed_ splices to be type checked | HsTcBracketOut + (XTcBracketOut p) (HsBracket GhcRn) -- Output of the type checker is the *original* -- renamed expression, plus [PendingTcSplice] -- _typechecked_ splices to be @@ -588,7 +592,7 @@ data HsExpr p -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceE (HsSplice p) + | HsSpliceE (XSpliceE p) (HsSplice p) ----------------------------------------------------------- -- Arrow notation extension @@ -599,7 +603,8 @@ data HsExpr p -- 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | HsProc (LPat p) -- arrow abstraction, proc + | HsProc (XProc p) + (LPat p) -- arrow abstraction, proc (LHsCmdTop p) -- body of the abstraction -- always has an empty stack @@ -608,7 +613,7 @@ data HsExpr p -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (PostRn p NameSet) -- Free variables of the body + | HsStatic (XStatic p) -- Free variables of the body (LHsExpr p) -- Body --------------------------------------- @@ -622,10 +627,10 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsArrApp -- Arrow tail, or arrow application (f -< arg) + (XArrApp p) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t (LHsExpr p) -- arrow expression, f (LHsExpr p) -- input expression, arg - (PostTc p Type) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t HsArrAppType -- higher-order (-<<) or first-order (-<) Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) @@ -635,6 +640,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XArrForm p) (LHsExpr p) -- the operator -- after type-checking, a type abstraction to be -- applied to the type of the local environment tuple @@ -646,10 +652,12 @@ data HsExpr p -- Haskell program coverage (Hpc) Support | HsTick + (XTick p) (Tickish (IdP p)) (LHsExpr p) -- sub-expression | HsBinTick + (XBinTick p) Int -- module-local tick number for True Int -- module-local tick number for False (LHsExpr p) -- sub-expression @@ -665,6 +673,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsTickPragma -- A pragma introduced tick + (XTickPragma p) SourceText -- Note [Pragma source text] in BasicTypes (StringLiteral,(Int,Int),(Int,Int)) -- external span for this tick @@ -677,24 +686,26 @@ data HsExpr p -- These constructors only appear temporarily in the parser. -- The renamer translates them into the Right Thing. - | EWildPat -- wildcard + | EWildPat (XEWildPat p) -- wildcard -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (Located (IdP p)) -- as pattern + | EAsPat (XEAsPat p) + (Located (IdP p)) -- as pattern (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | EViewPat (LHsExpr p) -- view pattern + | EViewPat (XEViewPat p) + (LHsExpr p) -- view pattern (LHsExpr p) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | ELazyPat (LHsExpr p) -- ~ pattern + | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern --------------------------------------- @@ -703,11 +714,140 @@ data HsExpr p -- See Note [Detecting forced eta expansion] in DsExpr. This invariant -- is maintained by HsUtils.mkHsWrap. - | HsWrap HsWrapper -- TRANSLATION + | HsWrap (XWrap p) + HsWrapper -- TRANSLATION (HsExpr p) + | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor + deriving instance (DataIdLR p p) => Data (HsExpr p) +-- | Extra data fields for a 'RecordCon', added by the type checker +data RecordConTc = RecordConTc + { rcon_con_like :: ConLike -- The data constructor or pattern synonym + , rcon_con_expr :: PostTcExpr -- Instantiated constructor function + } deriving Data + + +-- | Extra data fields for a 'RecordUpd', added by the type checker +data RecordUpdTc = RecordUpdTc + { rupd_cons :: [ConLike] + -- Filled in by the type checker to the + -- _non-empty_ list of DataCons that have + -- all the upd'd fields + + , rupd_in_tys :: [Type] -- Argument types of *input* record type + , rupd_out_tys :: [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] + } deriving Data + +-- --------------------------------------------------------------------- +type instance XVarPat (GhcPass _) = PlaceHolder + +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 XAppTypeE GhcPs = LHsWcType GhcPs +type instance XAppTypeE GhcRn = LHsWcType GhcRn +type instance XAppTypeE GhcTc = LHsWcType GhcRn + +type instance XOpApp GhcPs = PlaceHolder +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 XExplicitSum GhcPs = PlaceHolder +type instance XExplicitSum GhcRn = PlaceHolder +type instance XExplicitSum GhcTc = [Type] + +type instance XCase (GhcPass _) = PlaceHolder +type instance XIf (GhcPass _) = PlaceHolder + +type instance XMultiIf GhcPs = PlaceHolder +type instance XMultiIf GhcRn = PlaceHolder +type instance XMultiIf GhcTc = Type + +type instance XLet (GhcPass _) = PlaceHolder + +type instance XDo GhcPs = PlaceHolder +type instance XDo GhcRn = PlaceHolder +type instance XDo GhcTc = Type + +type instance XExplicitList GhcPs = PlaceHolder +type instance XExplicitList GhcRn = PlaceHolder +type instance XExplicitList GhcTc = Type + +type instance XExplicitPArr GhcPs = PlaceHolder +type instance XExplicitPArr GhcRn = PlaceHolder +type instance XExplicitPArr GhcTc = Type + +type instance XRecordCon GhcPs = PlaceHolder +type instance XRecordCon GhcRn = PlaceHolder +type instance XRecordCon GhcTc = RecordConTc + +type instance XRecordUpd GhcPs = PlaceHolder +type instance XRecordUpd GhcRn = PlaceHolder +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 GhcTc = PostTcExpr + +type instance XPArrSeq GhcPs = PlaceHolder +type instance XPArrSeq GhcRn = PlaceHolder +type instance XPArrSeq GhcTc = PostTcExpr + +type instance XSCC (GhcPass _) = PlaceHolder +type instance XCoreAnn (GhcPass _) = PlaceHolder +type instance XBracket (GhcPass _) = PlaceHolder + +type instance XRnBracketOut (GhcPass _) = PlaceHolder +type instance XTcBracketOut (GhcPass _) = PlaceHolder + +type instance XSpliceE (GhcPass _) = PlaceHolder +type instance XProc (GhcPass _) = PlaceHolder + +type instance XStatic GhcPs = PlaceHolder +type instance XStatic GhcRn = NameSet +type instance XStatic GhcTc = NameSet + +type instance XArrApp GhcPs = PlaceHolder +type instance XArrApp GhcRn = PlaceHolder +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 + +-- --------------------------------------------------------------------- + -- | Located Haskell Tuple Argument -- -- 'HsTupArg' is used for tuple sections @@ -821,12 +961,11 @@ isQuietHsExpr :: HsExpr id -> Bool -- Parentheses do display something, but it gives little info and -- if we go deeper when we go inside them then we get ugly things -- like (...) -isQuietHsExpr (HsPar _) = True +isQuietHsExpr (HsPar {}) = True -- applications don't display anything themselves -isQuietHsExpr (HsApp _ _) = True -isQuietHsExpr (HsAppType _ _) = True -isQuietHsExpr (HsAppTypeOut _ _) = True -isQuietHsExpr (OpApp _ _ _ _) = True +isQuietHsExpr (HsApp {}) = True +isQuietHsExpr (HsAppType {}) = True +isQuietHsExpr (OpApp {}) = True isQuietHsExpr _ = False pprBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), @@ -841,38 +980,37 @@ ppr_lexpr e = ppr_expr (unLoc e) ppr_expr :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc -ppr_expr (HsVar (L _ v)) = pprPrefixOcc v -ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) -ppr_expr (HsConLikeOut c) = pprPrefixOcc c -ppr_expr (HsIPVar v) = ppr v -ppr_expr (HsOverLabel _ l)= char '#' <> ppr l -ppr_expr (HsLit lit) = ppr lit -ppr_expr (HsOverLit lit) = ppr lit -ppr_expr (HsPar e) = parens (ppr_lexpr e) - -ppr_expr (HsCoreAnn stc (StringLiteral sta s) e) +ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v +ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) +ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c +ppr_expr (HsIPVar _ v) = ppr v +ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l +ppr_expr (HsLit _ lit) = ppr lit +ppr_expr (HsOverLit _ lit) = ppr lit +ppr_expr (HsPar _ e) = parens (ppr_lexpr e) + +ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) = vcat [pprWithSourceText stc (text "{-# CORE") <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" , ppr_lexpr e] ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] -ppr_expr e@(HsAppTypeOut {}) = ppr_apps e [] -ppr_expr (OpApp e1 op _ e2) +ppr_expr (OpApp _ e1 op e2) | Just pp_op <- should_print_infix (unLoc op) = pp_infixly pp_op | otherwise = pp_prefixly where - should_print_infix (HsVar (L _ v)) = Just (pprInfixOcc v) - should_print_infix (HsConLikeOut c)= Just (pprInfixOcc (conLikeName c)) - should_print_infix (HsRecFld f) = Just (pprInfixOcc f) - should_print_infix (HsUnboundVar h@TrueExprHole{}) + should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v) + should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) + should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f) + should_print_infix (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) - should_print_infix EWildPat = Just (text "`_`") - should_print_infix (HsWrap _ e) = should_print_infix e + should_print_infix (EWildPat _) = Just (text "`_`") + should_print_infix (HsWrap _ _ e) = should_print_infix e should_print_infix _ = Nothing pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens @@ -884,33 +1022,35 @@ ppr_expr (OpApp e1 op _ e2) pp_infixly pp_op = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) -ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e +ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr e -ppr_expr (SectionL expr op) +ppr_expr (SectionL _ expr op) = case unLoc op of - HsVar (L _ v) -> pp_infixly v - HsConLikeOut c -> pp_infixly (conLikeName c) - _ -> pp_prefixly + HsVar _ (L _ v) -> pp_infixly v + HsConLikeOut _ c -> pp_infixly_n (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, text "x_ )"]) - pp_infixly v = (sep [pp_expr, pprInfixOcc v]) + pp_infixly_n v = (sep [pp_expr, pprInfixOcc v]) + pp_infixly v = (sep [pp_expr, pprInfixOcc v]) -ppr_expr (SectionR op expr) +ppr_expr (SectionR _ op expr) = case unLoc op of - HsVar (L _ v) -> pp_infixly v - HsConLikeOut c -> pp_infixly (conLikeName c) - _ -> pp_prefixly + HsVar _ (L _ v) -> pp_infixly v + HsConLikeOut _ c -> pp_infixly_n (conLikeName c) + _ -> pp_prefixly where pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) 4 (pp_expr <> rparen) - pp_infixly v = sep [pprInfixOcc v, pp_expr] + pp_infixly v = sep [pprInfixOcc v, pp_expr] + pp_infixly_n v = sep [pprInfixOcc v, pp_expr] -ppr_expr (ExplicitTuple exprs boxity) +ppr_expr (ExplicitTuple _ exprs boxity) = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) where ppr_tup_args [] = [] @@ -921,26 +1061,26 @@ ppr_expr (ExplicitTuple exprs boxity) punc (Missing {} : _) = comma punc [] = empty -ppr_expr (ExplicitSum alt arity expr _) +ppr_expr (ExplicitSum _ alt arity expr) = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" where ppr_bars n = hsep (replicate n (char '|')) -ppr_expr (HsLam matches) +ppr_expr (HsLam _ matches) = pprMatches matches -ppr_expr (HsLamCase matches) +ppr_expr (HsLamCase _ matches) = sep [ sep [text "\\case"], nest 2 (pprMatches matches) ] -ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] })) +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], nest 2 (pprMatches matches) <+> char '}'] -ppr_expr (HsCase expr matches) +ppr_expr (HsCase _ expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] -ppr_expr (HsIf _ e1 e2 e3) +ppr_expr (HsIf _ _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], nest 4 (ppr e2), text "else", @@ -957,15 +1097,15 @@ ppr_expr (HsMultiIf _ alts) , text "->" <+> pprDeeper (ppr expr) ] -- special case: let ... in let ... -ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _))) +ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lexpr expr] -ppr_expr (HsLet (L _ binds) expr) +ppr_expr (HsLet _ (L _ binds) expr) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr expr)] -ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts +ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) @@ -979,49 +1119,46 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) -ppr_expr (ExprWithTySig expr sig) - = hang (nest 2 (ppr_lexpr expr) <+> dcolon) - 4 (ppr sig) -ppr_expr (ExprWithTySigOut expr sig) +ppr_expr (ExprWithTySig sig expr) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (PArrSeq _ info) = paBrackets (ppr info) +ppr_expr (PArrSeq _ info) = paBrackets (ppr info) -ppr_expr EWildPat = char '_' -ppr_expr (ELazyPat e) = char '~' <> ppr e -ppr_expr (EAsPat v e) = ppr v <> char '@' <> ppr e -ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e +ppr_expr (EWildPat _) = char '_' +ppr_expr (ELazyPat _ e) = char '~' <> ppr e +ppr_expr (EAsPat _ v e) = ppr v <> char '@' <> ppr e +ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e -ppr_expr (HsSCC st (StringLiteral stl lbl) expr) +ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) = sep [ pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes. <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", ppr expr ] -ppr_expr (HsWrap co_fn e) +ppr_expr (HsWrap _ co_fn e) = pprHsWrapper co_fn (\parens -> if parens then pprExpr e else pprExpr e) -ppr_expr (HsSpliceE s) = pprSplice s -ppr_expr (HsBracket b) = pprHsBracket b -ppr_expr (HsRnBracketOut e []) = ppr e -ppr_expr (HsRnBracketOut e ps) = ppr e $$ text "pending(rn)" <+> ppr ps -ppr_expr (HsTcBracketOut e []) = ppr e -ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps +ppr_expr (HsSpliceE _ s) = pprSplice s +ppr_expr (HsBracket _ b) = pprHsBracket b +ppr_expr (HsRnBracketOut _ e []) = ppr e +ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps +ppr_expr (HsTcBracketOut _ e []) = ppr e +ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps -ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) +ppr_expr (HsProc _ pat (L _ (HsCmdTop cmd _ _ _))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] -ppr_expr (HsTick tickish exp) +ppr_expr (HsTick _ tickish exp) = pprTicks (ppr exp) $ ppr tickish <+> ppr_lexpr exp -ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) +ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) = pprTicks (ppr exp) $ hcat [text "bintick<", ppr tickIdTrue, @@ -1029,7 +1166,7 @@ ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) ppr tickIdFalse, text ">(", ppr exp, text ")"] -ppr_expr (HsTickPragma _ externalSrcLoc _ exp) +ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) = pprTicks (ppr exp) $ hcat [text "tickpragma<", pprExternalSrcLoc externalSrcLoc, @@ -1037,23 +1174,24 @@ ppr_expr (HsTickPragma _ externalSrcLoc _ exp) ppr exp, text ")"] -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) +ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) +ppr_expr (HsArrApp _ arrow arg HsFirstOrderApp False) = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) +ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp True) = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) +ppr_expr (HsArrApp _ arrow arg HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) +ppr_expr (HsArrForm _ (L _ (HsVar _ (L _ v))) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm (L _ (HsConLikeOut c)) (Just _) [arg1, arg2]) +ppr_expr (HsArrForm _ (L _ (HsConLikeOut _ c)) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc (conLikeName c), pprCmdArg (unLoc arg2)]] -ppr_expr (HsArrForm op _ args) +ppr_expr (HsArrForm _ op _ args) = hang (text "(|" <+> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_expr (HsRecFld f) = ppr f +ppr_expr (HsRecFld _ f) = ppr f +ppr_expr (XExpr x) = ppr x -- We must tiresomely make the "id" parameter to the LHsWcType existential -- because it's different in the HsAppType case and the HsAppTypeOut case @@ -1062,21 +1200,23 @@ data LHsWcTypeX = forall p. ( SourceTextX (GhcPass p) , OutputableBndrId (GhcPass p)) => LHsWcTypeX (LHsWcType (GhcPass p)) -ppr_apps :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) +ppr_apps :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX] + -- -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX] + -> [Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p))] -> SDoc -ppr_apps (HsApp (L _ fun) arg) args +ppr_apps (HsApp _ (L _ fun) arg) args = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType (L _ fun) arg) args - = ppr_apps fun (Right (LHsWcTypeX arg) : args) -ppr_apps (HsAppTypeOut (L _ fun) arg) args - = ppr_apps fun (Right (LHsWcTypeX arg) : args) +ppr_apps (HsAppType arg (L _ fun)) args + = ppr_apps fun (Right arg : args) ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args)) where + -- pp :: Either (LHsExpr (GhcPass p)) (XAppTypeE (GhcPass p)) -> SDoc pp (Left arg) = ppr arg - pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - = char '@' <> pprHsType arg + -- pp (Right (HsWC { hswc_body = L _ arg })) + -- = char '@' <> pprHsType arg + pp (Right arg) + = char '@' <> ppr arg pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) @@ -1132,13 +1272,13 @@ hsExprNeedsParens (HsPar {}) = False hsExprNeedsParens (HsBracket {}) = False hsExprNeedsParens (HsRnBracketOut {}) = False hsExprNeedsParens (HsTcBracketOut {}) = False -hsExprNeedsParens (HsDo sc _ _) +hsExprNeedsParens (HsDo _ sc _) | isListCompExpr sc = False hsExprNeedsParens (HsRecFld{}) = False hsExprNeedsParens (RecordCon{}) = False hsExprNeedsParens (HsSpliceE{}) = False hsExprNeedsParens (RecordUpd{}) = False -hsExprNeedsParens (HsWrap _ e) = hsExprNeedsParens e +hsExprNeedsParens (HsWrap _ _ e) = hsExprNeedsParens e hsExprNeedsParens _ = True @@ -1151,8 +1291,8 @@ isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e -isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e +isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr _ = False @@ -1353,16 +1493,16 @@ ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) ppr_cmd (HsCmdArrForm op _ _ args) @@ -1697,7 +1837,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- | ApplicativeStmt [ ( SyntaxExpr idR - , ApplicativeArg idL idR) ] + , ApplicativeArg idL) ] -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] (Maybe (SyntaxExpr idR)) -- 'join', if necessary (PostTc idR Type) -- Type of the body @@ -1803,7 +1943,7 @@ data ParStmtBlock idL idR deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR) -- | Applicative Argument -data ApplicativeArg idL idR +data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) (LPat idL) -- WildPat if it was a BodyStmt (see below) (LHsExpr idL) @@ -1815,7 +1955,7 @@ data ApplicativeArg idL idR [ExprLStmt idL] -- stmts (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) (LPat idL) -- (v1,...,vn) -deriving instance (DataIdLR idL idR) => Data (ApplicativeArg idL idR) +deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL) {- Note [The type of bind in Stmts] @@ -2031,10 +2171,10 @@ pprStmt (ApplicativeStmt args mb_join _) -- ppr directly rather than transforming here, because we need to -- 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 stmt = [ppr stmt] + flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] [ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") @@ -2053,6 +2193,7 @@ pprStmt (ApplicativeStmt args mb_join _) then ap_expr else text "join" <+> parens ap_expr + pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg (_, ApplicativeArgOne pat expr isBody) | isBody = -- See Note [Applicative BodyStmt] ppr (BodyStmt expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") @@ -2063,9 +2204,8 @@ pprStmt (ApplicativeStmt args mb_join _) pp_arg (_, ApplicativeArgMany stmts return pat) = ppr pat <+> text "<-" <+> - ppr (HsDo DoExpr (noLoc - (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) - (error "pprStmt")) + ppr (HsDo (panic "pprStmt") DoExpr (noLoc + (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)]))) pprTransformStmt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index b641670108..fb689c56d2 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -154,9 +154,6 @@ type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)= , c (XXValBindsLR x x') ) - - - -- We define a type family for each HsLit extension point. This is based on -- prepending 'X' to the constructor name, for ease of reference. type family XHsChar x @@ -306,6 +303,112 @@ type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = ) -- --------------------------------------------------------------------- +-- Type families for the HsExpr type families + +type family XVar x +type family XUnboundVar x +type family XConLikeOut x +type family XRecFld x +type family XOverLabel x +type family XIPVar x +type family XOverLitE x +type family XLitE x +type family XLam x +type family XLamCase x +type family XApp x +type family XAppTypeE x +type family XOpApp x +type family XNegApp x +type family XPar x +type family XSectionL x +type family XSectionR x +type family XExplicitTuple x +type family XExplicitSum x +type family XCase x +type family XIf x +type family XMultiIf x +type family XLet x +type family XDo x +type family XExplicitList x +type family XExplicitPArr x +type family XRecordCon x +type family XRecordUpd x +type family XExprWithTySig x +type family XArithSeq x +type family XPArrSeq x +type family XSCC x +type family XCoreAnn x +type family XBracket x +type family XRnBracketOut x +type family XTcBracketOut x +type family XSpliceE x +type family XProc x +type family XStatic x +type family XArrApp x +type family XArrForm x +type family XTick x +type family XBinTick x +type family XTickPragma x +type family XEWildPat x +type family XEAsPat x +type family XEViewPat x +type family XELazyPat x +type family XWrap x +type family XXExpr x + +type ForallXExpr (c :: * -> Constraint) (x :: *) = + ( c (XVar x) + , c (XUnboundVar x) + , c (XConLikeOut x) + , c (XRecFld x) + , c (XOverLabel x) + , c (XIPVar x) + , c (XOverLitE x) + , c (XLitE x) + , c (XLam x) + , c (XLamCase x) + , c (XApp x) + , c (XAppTypeE x) + , c (XOpApp x) + , c (XNegApp x) + , c (XPar x) + , c (XSectionL x) + , c (XSectionR x) + , c (XExplicitTuple x) + , c (XExplicitSum x) + , c (XCase x) + , c (XIf x) + , c (XMultiIf x) + , c (XLet x) + , c (XDo x) + , c (XExplicitList x) + , c (XExplicitPArr x) + , c (XRecordCon x) + , c (XRecordUpd x) + , c (XExprWithTySig x) + , c (XArithSeq x) + , c (XPArrSeq x) + , c (XSCC x) + , c (XCoreAnn x) + , c (XBracket x) + , c (XRnBracketOut x) + , c (XTcBracketOut x) + , c (XSpliceE x) + , c (XProc x) + , c (XStatic x) + , c (XArrApp x) + , c (XArrForm x) + , c (XTick x) + , c (XBinTick x) + , c (XTickPragma x) + , c (XEWildPat x) + , c (XEAsPat x) + , c (XEViewPat x) + , c (XELazyPat x) + , c (XWrap x) + , c (XXExpr x) + ) +-- --------------------------------------------------------------------- -- | The 'SourceText' fields have been moved into the extension fields, thus -- placing a requirement in the extension field to contain a 'SourceText' so @@ -383,11 +486,21 @@ type ConvertIdX a b = type OutputableX p = ( Outputable (XXPat p) , Outputable (XXPat GhcRn) + , Outputable (XSigPat p) , Outputable (XSigPat GhcRn) + , Outputable (XXLit p) + , Outputable (XXOverLit p) + , Outputable (XXType p) + + , Outputable (XExprWithTySig p) + , Outputable (XExprWithTySig GhcRn) + + , Outputable (XAppTypeE p) + , Outputable (XAppTypeE GhcRn) ) -- TODO: Should OutputableX be included in OutputableBndrId? @@ -405,6 +518,7 @@ type DataId p = , ForallXPat Data (GhcPass 'Renamed) -- , ForallXPat Data (GhcPass 'Typechecked) , ForallXType Data (GhcPass 'Renamed) + , ForallXExpr Data (GhcPass 'Renamed) , ForallXOverLit Data p , ForallXType Data p @@ -413,6 +527,8 @@ type DataId p = , ForallXFieldOcc Data p , ForallXAmbiguousFieldOcc Data p + , ForallXExpr Data p + , Data (NameOrRdrName (IdP p)) , Data (IdP p) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index e837f522cf..71f932c2e6 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -19,7 +19,6 @@ module HsPat ( Pat(..), InPat, OutPat, LPat, - ListPatTc(..), HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', @@ -282,15 +281,6 @@ data Pat p (XXPat p) deriving instance (DataIdLR p p) => Data (Pat p) --- | The typechecker-specific information for a 'ListPat' -data ListPatTc = - ListPatTc Type -- The type of the elements - (Maybe (Type, SyntaxExpr GhcTc)) -- 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 - deriving Data - -- --------------------------------------------------------------------- type instance XWildPat GhcPs = PlaceHolder diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index f839e4f386..edd5da674c 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -140,8 +140,8 @@ from their components, compared with the nl* functions below which just attach noSrcSpan to everything. -} -mkHsPar :: LHsExpr id -> LHsExpr id -mkHsPar e = L (getLoc e) (HsPar e) +mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsPar e = L (getLoc e) (HsPar noExt e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id)) -> [LPat id] -> Located (body id) @@ -174,20 +174,21 @@ mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms -mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) +mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2) -mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name -mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t) +mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn +mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType t e) -mkHsAppTypes :: LHsExpr name -> [LHsWcType name] -> LHsExpr name +mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl mkHsAppType +-- AZ:TODO this can go, in favour of mkHsAppType. ? mkHsAppTypeOut :: LHsExpr GhcTc -> LHsWcType GhcRn -> LHsExpr GhcTc -mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t) +mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppType t e) mkHsLam :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExt matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats body] @@ -202,17 +203,19 @@ mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr -nlHsTyApp :: IdP name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) +nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) +nlHsTyApp fun_id tys + = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id))) -nlHsTyApps :: IdP name -> [Type] -> [LHsExpr name] -> LHsExpr name +nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- -mkLHsPar :: LHsExpr name -> LHsExpr name +mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -- Wrap in parens if hsExprNeedsParens says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' -mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le) +mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar noExt le) | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) @@ -237,17 +240,19 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs -mkLastStmt :: SourceTextX idR - => Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkLastStmt :: SourceTextX (GhcPass idR) + => Located (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR idL GhcPs (Located (bodyR GhcPs)) -mkBindStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => LPat idL -> Located (bodyR idR) - -> StmtLR idL idR (Located (bodyR idR)) +mkBindStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => 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 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 @@ -260,33 +265,42 @@ mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr noRebindableInfo :: PlaceHolder noRebindableInfo = PlaceHolder -- Just another placeholder; -mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList stmts) placeHolderType +mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = L (getLoc expr) $ mkLastStmt expr -mkHsIf :: SourceTextX p => LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p -mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b +mkHsIf :: SourceTextX (GhcPass p) + => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) + -> HsExpr (GhcPass p) +mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b mkNPat lit neg = NPat noExt lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkTransformByStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkGroupUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) -mkGroupByUsingStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR - -> StmtLR idL idR (LHsExpr idL) - -emptyTransStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) - => StmtLR idL idR (LHsExpr idR) +mkTransformStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) +mkTransformByStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) +mkGroupUsingStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) +mkGroupByUsingStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => [ExprLStmt (GhcPass idL)] -> LHsExpr (GhcPass idR) + -> LHsExpr (GhcPass idR) + -> StmtLR (GhcPass idL) (GhcPass idR) (LHsExpr (GhcPass idL)) + +emptyTransStmt :: (SourceTextX (GhcPass idR), + PostTc (GhcPass idR) Type ~ PlaceHolder) + => StmtLR idL (GhcPass idR) (LHsExpr (GhcPass idR)) emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noExpr @@ -304,8 +318,8 @@ mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy -- don't use placeHolderTypeTc above, because that panics during zonking -emptyRecStmt' :: forall idL idR body. SourceTextX idR => - PostTc idR Type -> StmtLR idL idR body +emptyRecStmt' :: forall idL idR body. SourceTextX (GhcPass idR) => + PostTc (GhcPass idR) Type -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal = RecStmt { recS_stmts = [], recS_later_ids = [] @@ -324,9 +338,8 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. -mkHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> HsExpr id -mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) - (error "mkOpApp:fixity") e2 +mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) @@ -335,10 +348,11 @@ mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e) +mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e) mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) +mkHsSpliceTE hasParen e + = HsSpliceE noExt (HsTypedSplice hasParen unqualSplice e) mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs mkHsSpliceTy hasParen e = HsSpliceTy noExt @@ -379,18 +393,18 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v)) ************************************************************************ -} -nlHsVar :: IdP id -> LHsExpr id -nlHsVar n = noLoc (HsVar (noLoc n)) +nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) +nlHsVar n = noLoc (HsVar noExt (noLoc n)) -- NB: Only for LHsExpr **Id** nlHsDataCon :: DataCon -> LHsExpr GhcTc -nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) +nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con)) -nlHsLit :: HsLit p -> LHsExpr p -nlHsLit n = noLoc (HsLit n) +nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) +nlHsLit n = noLoc (HsLit noExt n) nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLoc (HsLit (HsInt noExt (mkIntegralLit n))) +nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n))) nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) nlVarPat n = noLoc (VarPat noExt (noLoc n)) @@ -398,10 +412,11 @@ nlVarPat n = noLoc (VarPat noExt (noLoc n)) nlLitPat :: HsLit GhcPs -> LPat GhcPs nlLitPat l = noLoc (LitPat noExt l) -nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsApp f x = noLoc (HsApp f (mkLHsPar x)) +nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x)) -nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id +nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) nlHsSyntaxApps (SyntaxExpr { syn_expr = fun , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) args @@ -413,13 +428,14 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr = fun = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) -nlHsApps :: IdP id -> [LHsExpr id] -> LHsExpr id +nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs -nlHsVarApps :: IdP id -> [IdP id] -> LHsExpr id -nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) +nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsVarApps f xs = noLoc (foldl mk (HsVar noExt (noLoc f)) + (map ((HsVar noExt) . noLoc) xs)) where - mk f a = HsApp (noLoc f) (noLoc a) + mk f a = HsApp noExt (noLoc f) (noLoc a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) @@ -457,26 +473,28 @@ nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) -nlHsOpApp :: LHsExpr id -> IdP id -> LHsExpr id -> LHsExpr id +nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -nlHsPar :: LHsExpr id -> LHsExpr id -nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs -nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) -nlHsPar e = noLoc (HsPar e) +nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar noExt e) -- Note [Rebindable nlHsIf] -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf Nothing cond true false) +nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false) -nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) -nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) +nlHsCase expr matches + = noLoc (HsCase noExt expr (mkMatchGroup Generated matches)) +nlList exprs = noLoc (ExplicitList noExt Nothing exprs) nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) @@ -496,12 +514,12 @@ Tuples. All these functions are *pre-typechecker* because they lack types on the tuple. -} -mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a +mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] = e -mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed +mkLHsTupleExpr es = noLoc $ ExplicitTuple noExt (map (noLoc . Present) es) Boxed -mkLHsVarTuple :: [IdP a] -> LHsExpr a +mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs @@ -516,10 +534,10 @@ mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExt lpats Boxed -- The Big equivalents for the source tuple expressions -mkBigLHsVarTup :: [IdP id] -> LHsExpr id +mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) -mkBigLHsTup :: [LHsExpr id] -> LHsExpr id +mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) mkBigLHsTup = mkChunkified mkLHsTupleExpr -- The Big equivalents for the source tuple patterns @@ -665,25 +683,25 @@ typeToLHsType ty * * ********************************************************************* -} -mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id +mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -- Avoid (HsWrap co (HsWrap co' _)). -- See Note [Detecting forced eta expansion] in DsExpr -mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id +mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn (HsWrap co_fn' e) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn e = HsWrap co_fn e +mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn e = HsWrap noExt co_fn e mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr id -> HsExpr id + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr id -> HsExpr id + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e -mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id +mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 55778d9adf..19b4af017d 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -36,12 +36,6 @@ data PlaceHolder = PlaceHolder instance Outputable PlaceHolder where ppr _ = text "PlaceHolder" -placeHolderKind :: PlaceHolder -placeHolderKind = PlaceHolder - -placeHolderFixity :: PlaceHolder -placeHolderFixity = PlaceHolder - placeHolderType :: PlaceHolder placeHolderType = PlaceHolder diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index e4ea11bc64..1012c25b28 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -895,7 +895,7 @@ dynCompileExpr expr = do parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName) + to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce# hval :: Dynamic) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 6c278045b9..2fa94340e8 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1899,7 +1899,7 @@ atype :: { LHsType GhcPs } | quasiquote { sL1 $1 (HsSpliceTy noExt (unLoc $1)) } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } - | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar $ + | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy HasDollar $ sL1 $1 $ HsVar noExt $ (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1)))) [mj AnnThIdSplice $1] } -- see Note [Promotion] for the followings @@ -2202,7 +2202,7 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) + | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2) -- Turn it all into an expression so that -- checkPattern can check that bangs are enabled ; l = comb2 $1 $> }; @@ -2355,47 +2355,47 @@ quasiquote :: { Located (HsSplice GhcPs) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr GhcPs } - : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3)) + : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig (mkLHsSigWcType $3) $1) [mu AnnDcolon $2] } - | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType + | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 HsFirstOrderApp True) [mu Annlarrowtail $2] } - | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType + | infixexp '>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 HsFirstOrderApp False) [mu Annrarrowtail $2] } - | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType + | infixexp '-<<' exp {% ams (sLL $1 $> $ HsArrApp noExt $1 $3 HsHigherOrderApp True) [mu AnnLarrowtail $2] } - | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp $3 $1 placeHolderType + | infixexp '>>-' exp {% ams (sLL $1 $> $ HsArrApp noExt $3 $1 HsHigherOrderApp False) [mu AnnRarrowtail $2] } | infixexp { $1 } infixexp :: { LHsExpr GhcPs } : exp10 { $1 } - | infixexp qop exp10 {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) + | infixexp qop exp10 {% ams (sLL $1 $> (OpApp noExt $1 $2 $3)) [mj AnnVal $2] } -- AnnVal annotation for NPlusKPat, which discards the operator infixexp_top :: { LHsExpr GhcPs } : exp10_top { $1 } | infixexp_top qop exp10_top - {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) + {% ams (sLL $1 $> (OpApp noExt $1 $2 $3)) [mj AnnVal $2] } exp10_top :: { LHsExpr GhcPs } : '\\' apat apats '->' exp - {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource + {% ams (sLL $1 $> $ HsLam noExt (mkMatchGroup FromSource [sLL $1 $> $ Match { m_ctxt = LambdaExpr , m_pats = $2:$3 , m_grhss = unguardedGRHSs $5 }])) [mj AnnLam $1, mu AnnRarrow $4] } - | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) + | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet noExt (snd $ unLoc $2) $4) (mj AnnLet $1:mj AnnIn $3 :(fst $ unLoc $2)) } | '\\' 'lcase' altslist - {% ams (sLL $1 $> $ HsLamCase + {% ams (sLL $1 $> $ HsLamCase noExt (mkMatchGroup FromSource (snd $ unLoc $3))) (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } | 'if' exp optSemi 'then' exp optSemi 'else' exp @@ -2406,15 +2406,14 @@ exp10_top :: { LHsExpr GhcPs } :(map (\l -> mj AnnSemi l) (fst $3)) ++(map (\l -> mj AnnSemi l) (fst $6))) } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> - ams (sLL $1 $> $ HsMultiIf - placeHolderType + ams (sLL $1 $> $ HsMultiIf noExt (reverse $ snd $ unLoc $2)) (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup + | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase noExt $2 (mkMatchGroup FromSource (snd $ unLoc $4))) (mj AnnCase $1:mj AnnOf $3 :(fst $ unLoc $4)) } - | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr) + | '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr) [mj AnnMinus $1] } | 'do' stmtlist {% ams (L (comb2 $1 $2) @@ -2424,19 +2423,19 @@ exp10_top :: { LHsExpr GhcPs } (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } - | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1) - (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma noExt (snd $ fst $ fst $ unLoc $1) + (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ fst $ unLoc $1) } | 'proc' aexp '->' exp {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> - ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType + ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop cmd placeHolderType placeHolderType [])) -- TODO: is LL right here? [mj AnnProc $1,mu AnnRarrow $3] } - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4) + | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn noExt (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation @@ -2444,7 +2443,7 @@ exp10_top :: { LHsExpr GhcPs } exp10 :: { LHsExpr GhcPs } : exp10_top { $1 } - | scc_annot exp {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) + | scc_annot exp {% ams (sLL $1 $> $ HsSCC noExt (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ unLoc $1) } optSemi :: { ([Located a],Bool) } @@ -2487,19 +2486,19 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In } fexp :: { LHsExpr GhcPs } - : fexp aexp { sLL $1 $> $ HsApp $1 $2 } - | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) + : fexp aexp { sLL $1 $> $ HsApp noExt $1 $2 } + | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType (mkHsWildCardBndrs $3) $1) [mj AnnAt $2] } - | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2) + | 'static' aexp {% ams (sLL $1 $> $ HsStatic noExt $2) [mj AnnStatic $1] } | aexp { $1 } aexp :: { LHsExpr GhcPs } - : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] } + : qvar '@' aexp {% ams (sLL $1 $> $ EAsPat noExt $1 $3) [mj AnnAt $2] } -- If you change the parsing, make sure to understand -- Note [Lexing type applications] in Lexer.x - | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] } + | '~' aexp {% ams (sLL $1 $> $ ELazyPat noExt $2) [mj AnnTilde $1] } | aexp1 { $1 } aexp1 :: { LHsExpr GhcPs } @@ -2510,27 +2509,27 @@ aexp1 :: { LHsExpr GhcPs } | aexp2 { $1 } aexp2 :: { LHsExpr GhcPs } - : qvar { sL1 $1 (HsVar $! $1) } - | qcon { sL1 $1 (HsVar $! $1) } - | ipvar { sL1 $1 (HsIPVar $! unLoc $1) } - | overloaded_label { sL1 $1 (HsOverLabel Nothing $! unLoc $1) } - | literal { sL1 $1 (HsLit $! unLoc $1) } + : qvar { sL1 $1 (HsVar noExt $! $1) } + | qcon { sL1 $1 (HsVar noExt $! $1) } + | ipvar { sL1 $1 (HsIPVar noExt $! unLoc $1) } + | overloaded_label { sL1 $1 (HsOverLabel noExt Nothing $! unLoc $1) } + | literal { sL1 $1 (HsLit noExt $! unLoc $1) } -- 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) } - | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) ) } - | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) ) } + | INTEGER { sL (getLoc $1) (HsOverLit noExt $! mkHsIntegral (getINTEGER $1) ) } + | RATIONAL { sL (getLoc $1) (HsOverLit noExt $! mkHsFractional (getRATIONAL $1) ) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. - | '(' texp ')' {% ams (sLL $1 $> (HsPar $2)) [mop $1,mcp $3] } + | '(' texp ')' {% ams (sLL $1 $> (HsPar noExt $2)) [mop $1,mcp $3] } | '(' tup_exprs ')' {% do { e <- mkSumOrTuple Boxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mop $1:fst $2) ++ [mcp $3]) } } - | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple [L (gl $2) + | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2) (Present $2)] Unboxed)) [mo $1,mc $3] } | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) @@ -2538,42 +2537,42 @@ aexp2 :: { LHsExpr GhcPs } | '[' list ']' {% ams (sLL $1 $> (snd $2)) (mos $1:mcs $3:(fst $2)) } | '[:' parr ':]' {% ams (sLL $1 $> (snd $2)) (mo $1:mc $3:(fst $2)) } - | '_' { sL1 $1 EWildPat } + | '_' { sL1 $1 $ EWildPat noExt } -- Template Haskell Extension | splice_exp { $1 } - | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) + | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr $2)) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) + | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] } + | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr $2)) [mo $1,mu AnnCloseQ $3] } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> - ams (sLL $1 $> $ HsBracket (PatBr p)) + ams (sLL $1 $> $ HsBracket noExt (PatBr p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2))) + | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { sL1 $1 (HsSpliceE (unLoc $1)) } + | quasiquote { sL1 $1 (HsSpliceE noExt (unLoc $1)) } -- arrow notation extension - | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm $2 + | '(|' aexp2 cmdargs '|)' {% ams (sLL $1 $> $ HsArrForm noExt $2 Nothing (reverse $3)) [mu AnnOpenB $1,mu AnnCloseB $4] } splice_exp :: { LHsExpr GhcPs } : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE HasDollar - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE HasDollar - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar noExt (sL1 $1 (mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2) @@ -2617,11 +2616,11 @@ texp :: { LHsExpr GhcPs } -- Then when converting expr to pattern we unravel it again -- Meanwhile, the renamer checks that real sections appear -- inside parens. - | infixexp qop { sLL $1 $> $ SectionL $1 $2 } - | qopm infixexp { sLL $1 $> $ SectionR $1 $2 } + | infixexp qop { sLL $1 $> $ SectionL noExt $1 $2 } + | qopm infixexp { sLL $1 $> $ SectionR noExt $1 $2 } -- View patterns get parenthesized above - | exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mu AnnRarrow $2] } + | exp '->' texp {% ams (sLL $1 $> $ EViewPat noExt $1 $3) [mu AnnRarrow $2] } -- Always at least one comma or bar. tup_exprs :: { ([AddAnn],SumOrTuple) } @@ -2660,19 +2659,18 @@ tup_tail :: { [LHsTupArg GhcPs] } -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. list :: { ([AddAnn],HsExpr GhcPs) } - : texp { ([],ExplicitList placeHolderType Nothing [$1]) } - | lexps { ([],ExplicitList placeHolderType Nothing - (reverse (unLoc $1))) } + : texp { ([],ExplicitList noExt Nothing [$1]) } + | lexps { ([],ExplicitList noExt Nothing (reverse (unLoc $1))) } | texp '..' { ([mj AnnDotdot $2], - ArithSeq noPostTcExpr Nothing (From $1)) } + ArithSeq noExt Nothing (From $1)) } | texp ',' exp '..' { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noPostTcExpr Nothing + ArithSeq noExt Nothing (FromThen $1 $3)) } | texp '..' exp { ([mj AnnDotdot $2], - ArithSeq noPostTcExpr Nothing + ArithSeq noExt Nothing (FromTo $1 $3)) } | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4], - ArithSeq noPostTcExpr Nothing + ArithSeq noExt Nothing (FromThenTo $1 $3 $5)) } | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> @@ -2752,15 +2750,14 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs -- constructor in the list case). parr :: { ([AddAnn],HsExpr GhcPs) } - : { ([],ExplicitPArr placeHolderType []) } - | texp { ([],ExplicitPArr placeHolderType [$1]) } - | lexps { ([],ExplicitPArr placeHolderType - (reverse (unLoc $1))) } + : { ([],ExplicitPArr noExt []) } + | texp { ([],ExplicitPArr noExt [$1]) } + | lexps { ([],ExplicitPArr noExt (reverse (unLoc $1))) } | texp '..' exp { ([mj AnnDotdot $2] - ,PArrSeq noPostTcExpr (FromTo $1 $3)) } + ,PArrSeq noExt (FromTo $1 $3)) } | texp ',' exp '..' exp { ([mj AnnComma $2,mj AnnDotdot $4] - ,PArrSeq noPostTcExpr (FromThenTo $1 $3 $5)) } + ,PArrSeq noExt (FromThenTo $1 $3 $5)) } | texp '|' flattenedpquals { ([mj AnnVbar $2],mkHsComp PArrComp (unLoc $3) $1) } @@ -2846,8 +2843,8 @@ gdpat :: { LGRHS GhcPs (LHsExpr GhcPs) } -- we parse them right when bang-patterns are off pat :: { LPat GhcPs } pat : exp {% checkPattern empty $1 } - | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR noExt + (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } bindpat :: { LPat GhcPs } @@ -2855,14 +2852,14 @@ bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% amms (checkPattern (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (SectionR noExt (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apat :: { LPat GhcPs } apat : aexp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty - (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (SectionR noExt + (sL1 $1 (HsVar noExt (sL1 $1 bang_RDR))) $2))) [mj AnnBang $1] } apats :: { [LPat GhcPs] } @@ -3174,15 +3171,15 @@ varop :: { Located RdrName } ,mj AnnBackquote $3] } qop :: { LHsExpr GhcPs } -- used in sections - : qvarop { sL1 $1 $ HsVar $1 } - | qconop { sL1 $1 $ HsVar $1 } - | '`' '_' '`' {% ams (sLL $1 $> EWildPat) + : qvarop { sL1 $1 $ HsVar noExt $1 } + | qconop { sL1 $1 $ HsVar noExt $1 } + | '`' '_' '`' {% ams (sLL $1 $> (EWildPat noExt)) [mj AnnBackquote $1,mj AnnVal $2 ,mj AnnBackquote $3] } qopm :: { LHsExpr GhcPs } -- used in sections - : qvaropm { sL1 $1 $ HsVar $1 } - | qconop { sL1 $1 $ HsVar $1 } + : qvaropm { sL1 $1 $ HsVar noExt $1 } + | qconop { sL1 $1 $ HsVar noExt $1 } qvarop :: { Located RdrName } : qvarsym { $1 } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index a74a46abcd..d44be79f64 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -286,10 +286,10 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(L loc expr) - | HsSpliceE splice@(HsUntypedSplice {}) <- expr + | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) - | HsSpliceE splice@(HsQuasiQuote {}) <- expr + | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) | otherwise @@ -817,7 +817,7 @@ checkLPat msg e@(L l _) = checkPat msg l e [] checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] -> P (LPat GhcPs) -checkPat _ loc (L l e@(HsVar (L _ c))) args +checkPat _ loc (L l e@(HsVar _ (L _ c))) args | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) | not (null args) && patIsRec c = patFail (text "Perhaps you intended to use RecursiveDo") l e @@ -827,7 +827,7 @@ checkPat msg loc e args -- OK to let this happen even if bang-patterns | Just (e', args') <- splitBang e = do { args'' <- checkPatterns msg args' ; checkPat msg loc e' (args'' ++ args) } -checkPat msg loc (L _ (HsApp f e)) args +checkPat msg loc (L _ (HsApp _ f e)) args = do p <- checkLPat msg e checkPat msg loc f (p : args) checkPat msg loc (L _ e) [] @@ -841,21 +841,21 @@ checkAPat msg loc e0 = do pState <- getPState let opts = options pState case e0 of - EWildPat -> return (WildPat placeHolderType) - HsVar x -> return (VarPat noExt x) - HsLit (HsStringPrim _ _) -- (#13260) + EWildPat _ -> return (WildPat placeHolderType) + HsVar _ x -> return (VarPat noExt x) + HsLit _ (HsStringPrim _ _) -- (#13260) -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) - HsLit l -> return (LitPat noExt l) + HsLit _ l -> return (LitPat noExt l) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - HsOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) - NegApp (L l (HsOverLit pos_lit)) _ + HsOverLit _ pos_lit -> return (mkNPat (L loc pos_lit) Nothing) + NegApp _ (L l (HsOverLit _ pos_lit)) _ -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) - SectionR (L lb (HsVar (L _ bang))) e -- (! x) + SectionR _ (L lb (HsVar _ (L _ bang))) e -- (! x) | bang == bang_RDR -> do { bang_on <- extension bangPatEnabled ; if bang_on then do { e' <- checkLPat msg e @@ -863,54 +863,54 @@ checkAPat msg loc e0 = do ; return (BangPat noExt e') } else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) } - ELazyPat e -> checkLPat msg e >>= (return . (LazyPat noExt)) - EAsPat n e -> checkLPat msg e >>= (return . (AsPat noExt) n) + ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt)) + EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n) -- view pattern is well-formed if the pattern is - EViewPat expr patE -> checkLPat msg patE >>= + EViewPat _ expr patE -> checkLPat msg patE >>= (return . (\p -> ViewPat noExt expr p)) - ExprWithTySig e t -> do e <- checkLPat msg e - return (SigPat t e) + ExprWithTySig t e -> do e <- checkLPat msg e + return (SigPat t e) -- n+k patterns - OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ - (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + OpApp _ (L nloc (HsVar _ (L _ n))) (L _ (HsVar _ (L _ plus))) + (L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) (L lloc lit)) - OpApp l op _fix r -> do l <- checkLPat msg l - r <- checkLPat msg r - case op of - L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c) - -> return (ConPatIn (L cl c) (InfixCon l r)) - _ -> patFail msg loc e0 + OpApp _ l op r -> do l <- checkLPat msg l + r <- checkLPat msg r + case op of + L cl (HsVar _ (L _ c)) | isDataOcc (rdrNameOcc c) + -> return (ConPatIn (L cl c) (InfixCon l r)) + _ -> patFail msg loc e0 - HsPar e -> checkLPat msg e >>= (return . (ParPat noExt)) + HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt)) ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es return (ListPat noExt ps placeHolderType Nothing) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es return (PArrPat noExt ps) - ExplicitTuple es b + ExplicitTuple _ es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | L _ (Present e) <- es] return (TuplePat noExt ps b) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) - ExplicitSum alt arity expr _ -> do + ExplicitSum _ alt arity expr -> do p <- checkLPat msg expr return (SumPat noExt p alt arity) RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } -> do fs <- mapM (checkPatField msg) fs return (ConPatIn c (RecCon (HsRecFields fs dd))) - HsSpliceE s | not (isTypedSplice s) + HsSpliceE _ s | not (isTypedSplice s) -> return (SplicePat noExt s) _ -> patFail msg loc e0 placeHolderPunRhs :: LHsExpr GhcPs -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when debugging -placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR)) +placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR)) plus_RDR, bang_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack @@ -944,7 +944,7 @@ checkValDef :: SDoc checkValDef msg _strictness lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = checkPatBind msg (L (combineLocs lhs sig) - (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss + (ExprWithTySig (mkLHsSigWcType sig) lhs)) grhss checkValDef msg strictness lhs Nothing g@(L l (_,grhss)) = do { mb_fun <- isFunLhs lhs @@ -997,7 +997,7 @@ checkPatBind msg lhs (L _ (_,grhss)) ([],[])) } checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (L _ (HsVar lrdr@(L _ v))) +checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr @@ -1019,9 +1019,9 @@ checkValSigLhs lhs@(L l _) -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like s (L _ (HsVar (L _ v))) = v == s - looks_like s (L _ (HsApp lhs _)) = looks_like s lhs - looks_like _ _ = False + looks_like s (L _ (HsVar _ (L _ v))) = v == s + looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs + looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") default_RDR = mkUnqual varName (fsLit "default") @@ -1054,13 +1054,13 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr -- not be any OpApps inside the e's splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) -- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) - | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) +splitBang (L _ (OpApp _ l_arg bang@(L _ (HsVar _ (L _ op))) r_arg)) + | op == bang_RDR = Just (l_arg, L l' (SectionR noExt bang arg1) : argns) where l' = combineLocs bang arg1 (arg1,argns) = split_bang r_arg [] - split_bang (L _ (HsApp f e)) es = split_bang f (e:es) - split_bang e es = (e,es) + split_bang (L _ (HsApp _ f e)) es = split_bang f (e:es) + split_bang e es = (e,es) splitBang _ = Nothing isFunLhs :: LHsExpr GhcPs @@ -1079,14 +1079,15 @@ isFunLhs :: LHsExpr GhcPs isFunLhs e = go e [] [] where - go (L loc (HsVar (L _ f))) es ann - | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) - go (L _ (HsApp f e)) es ann = go f (e:es) ann - go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (L loc (HsVar _ (L _ f))) es ann + | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) + go (L _ (HsApp _ f e)) es ann = go f (e:es) ann + go (L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) -- Things of the form `!x` are also FunBinds -- See Note [FunBind vs PatBind] - go (L _ (SectionR (L _ (HsVar (L _ bang))) (L l (HsVar (L _ var))))) [] ann + go (L _ (SectionR _ (L _ (HsVar _ (L _ bang))) (L l (HsVar _ (L _ var))))) + [] ann | bang == bang_RDR , not (isRdrDataCon var) = return (Just (L l var, Prefix, [], ann)) @@ -1103,7 +1104,7 @@ isFunLhs e = go e [] [] -- ToDo: what about this? -- x + 1 `op` y = ... - go e@(L loc (OpApp l (L loc' (HsVar (L _ op))) fix r)) es ann + go e@(L loc (OpApp _ l (L loc' (HsVar _ (L _ op))) r)) es ann | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) ann @@ -1117,7 +1118,8 @@ isFunLhs e = go e [] [] Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = L loc (OpApp k (L loc' (HsVar (L loc' op))) fix r) + op_app = L loc (OpApp noExt k + (L loc' (HsVar noExt (L loc' op))) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1198,28 +1200,29 @@ locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) locMap f (L l a) = f l a >>= (\b -> return $ L l b) checkCmd :: SrcSpan -> HsExpr GhcPs -> P (HsCmd GhcPs) -checkCmd _ (HsArrApp e1 e2 ptt haat b) = - return $ HsCmdArrApp e1 e2 ptt haat b -checkCmd _ (HsArrForm e mf args) = +checkCmd _ (HsArrApp _ e1 e2 haat b) = + return $ HsCmdArrApp e1 e2 noExt haat b +checkCmd _ (HsArrForm _ e mf args) = return $ HsCmdArrForm e Prefix mf args -checkCmd _ (HsApp e1 e2) = +checkCmd _ (HsApp _ e1 e2) = checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) -checkCmd _ (HsLam mg) = +checkCmd _ (HsLam _ mg) = checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') -checkCmd _ (HsPar e) = +checkCmd _ (HsPar _ e) = checkCommand e >>= (\c -> return $ HsCmdPar c) -checkCmd _ (HsCase e mg) = +checkCmd _ (HsCase _ e mg) = checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') -checkCmd _ (HsIf cf ep et ee) = do +checkCmd _ (HsIf _ cf ep et ee) = do pt <- checkCommand et pe <- checkCommand ee return $ HsCmdIf cf ep pt pe -checkCmd _ (HsLet lb e) = +checkCmd _ (HsLet _ lb e) = checkCommand e >>= (\c -> return $ HsCmdLet lb c) -checkCmd _ (HsDo DoExpr (L l stmts) ty) = - mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo (L l ss) ty) +checkCmd _ (HsDo _ DoExpr (L l stmts)) = + mapM checkCmdLStmt stmts >>= + (\ss -> return $ HsCmdDo (L l ss) placeHolderType) -checkCmd _ (OpApp eLeft op _fixity eRight) = do +checkCmd _ (OpApp _ eLeft op eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight @@ -1289,7 +1292,7 @@ mkRecConstrOrUpdate -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Bool) -> P (HsExpr GhcPs) -mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd) +mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) | isRdrDataCon c = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) @@ -1298,15 +1301,13 @@ mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs mkRdrRecordUpd exp flds - = RecordUpd { rupd_expr = exp - , rupd_flds = flds - , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder - , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } + = RecordUpd { rupd_ext = noExt + , rupd_expr = exp + , rupd_flds = flds } mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds - = RecordCon { rcon_con_name = con, rcon_flds = flds - , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } + = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds } mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } @@ -1568,11 +1569,11 @@ data SumOrTuple mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) -- Tuple -mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple es boxity) +mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) -- Sum mkSumOrTuple Unboxed _ (Sum alt arity e) = - return (ExplicitSum alt arity e PlaceHolder) + return (ExplicitSum noExt alt arity e) mkSumOrTuple Boxed l (Sum alt arity (L _ e)) = parseErrorSDoc l (hang (text "Boxed sums not supported:") 2 (ppr_boxed_sum alt arity e)) where diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index dbc3baf887..c51b741944 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1557,10 +1557,10 @@ lookupSyntaxNames :: [Name] -- Standard names lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then - return (map (HsVar . noLoc) std_names, emptyFVs) + return (map (HsVar noExt . noLoc) std_names, emptyFVs) else do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } } + ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } } -- Error messages diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 64348a33fd..2d4ec89cc7 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -95,7 +95,7 @@ finishHsVar (L l name) = do { this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalName name - ; return (HsVar (L l name), unitFV name) } + ; return (HsVar noExt (L l name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v @@ -107,13 +107,13 @@ rnUnboundVar v ; uv <- if startsWithUnderscore occ then return (TrueExprHole occ) else OutOfScope occ <$> getGlobalRdrEnv - ; return (HsUnboundVar uv, emptyFVs) } + ; return (HsUnboundVar noExt uv, emptyFVs) } else -- Fail immediately (qualified name) do { n <- reportUnboundName v - ; return (HsVar (noLoc n), emptyFVs) } } + ; return (HsVar noExt (noLoc n), emptyFVs) } } -rnExpr (HsVar (L l v)) +rnExpr (HsVar _ (L l v)) = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v ; case mb_name of { @@ -121,57 +121,57 @@ rnExpr (HsVar (L l v)) Just (Left name) | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly - -> rnExpr (ExplicitList placeHolderType Nothing []) + -> rnExpr (ExplicitList noExt Nothing []) | otherwise -> finishHsVar (L l name) ; Just (Right [s]) -> - return ( HsRecFld (Unambiguous s (L l v) ), unitFV s) ; + return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ; Just (Right fs@(_:_:_)) -> - return ( HsRecFld (Ambiguous noExt (L l v)) + return ( HsRecFld noExt (Ambiguous noExt (L l v)) , mkFVs fs); Just (Right []) -> panic "runExpr/HsVar" } } -rnExpr (HsIPVar v) - = return (HsIPVar v, emptyFVs) +rnExpr (HsIPVar x v) + = return (HsIPVar x v, emptyFVs) -rnExpr (HsOverLabel _ v) +rnExpr (HsOverLabel x _ v) = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) - ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) } - else return (HsOverLabel Nothing v, emptyFVs) } + ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } + else return (HsOverLabel x Nothing v, emptyFVs) } -rnExpr (HsLit lit@(HsString src s)) +rnExpr (HsLit x lit@(HsString src s)) = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings ; if opt_OverloadedStrings then - rnExpr (HsOverLit (mkHsIsString src s)) + rnExpr (HsOverLit x (mkHsIsString src s)) else do { ; rnLit lit - ; return (HsLit (convertLit lit), emptyFVs) } } + ; return (HsLit x (convertLit lit), emptyFVs) } } -rnExpr (HsLit lit) +rnExpr (HsLit x lit) = do { rnLit lit - ; return (HsLit (convertLit lit), emptyFVs) } + ; return (HsLit x(convertLit lit), emptyFVs) } -rnExpr (HsOverLit lit) +rnExpr (HsOverLit x lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] ; case mb_neg of - Nothing -> return (HsOverLit lit', fvs) - Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit')) + Nothing -> return (HsOverLit x lit', fvs) + Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) , fvs ) } -rnExpr (HsApp fun arg) +rnExpr (HsApp x fun arg) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnLExpr arg - ; return (HsApp fun' arg', fvFun `plusFV` fvArg) } + ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType fun arg) +rnExpr (HsAppType arg fun) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) } + ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) } -rnExpr (OpApp e1 op _ e2) +rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 ; (e2', fv_e2) <- rnLExpr e2 ; (op', fv_op) <- rnLExpr op @@ -182,15 +182,15 @@ rnExpr (OpApp e1 op _ e2) -- more, so I've removed the test. Adding HsPars in TcGenDeriv -- should prevent bad things happening. ; fixity <- case op' of - L _ (HsVar (L _ n)) -> lookupFixityRn n - L _ (HsRecFld f) -> lookupFieldFixityRn f + L _ (HsVar _ (L _ n)) -> lookupFixityRn n + L _ (HsRecFld _ f) -> lookupFieldFixityRn f _ -> return (Fixity NoSourceText minPrecedence InfixL) -- c.f. lookupFixity for unbound ; final_e <- mkOpAppRn e1' op' fixity e2' ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } -rnExpr (NegApp e _) +rnExpr (NegApp _ e _) = do { (e', fv_e) <- rnLExpr e ; (neg_name, fv_neg) <- lookupSyntaxName negateName ; final_e <- mkNegAppRn e' neg_name @@ -200,24 +200,24 @@ rnExpr (NegApp e _) -- Template Haskell extensions -- Don't ifdef-GHCI them because we want to fail gracefully -- (not with an rnExpr crash) in a stage-1 compiler. -rnExpr e@(HsBracket br_body) = rnBracket e br_body +rnExpr e@(HsBracket _ br_body) = rnBracket e br_body -rnExpr (HsSpliceE splice) = rnSpliceExpr splice +rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice --------------------------------------------- -- Sections -- See Note [Parsing sections] in Parser.y -rnExpr (HsPar (L loc (section@(SectionL {})))) +rnExpr (HsPar x (L loc (section@(SectionL {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + ; return (HsPar x (L loc section'), fvs) } -rnExpr (HsPar (L loc (section@(SectionR {})))) +rnExpr (HsPar x (L loc (section@(SectionR {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + ; return (HsPar x (L loc section'), fvs) } -rnExpr (HsPar e) +rnExpr (HsPar x e) = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar e', fvs_e) } + ; return (HsPar x e', fvs_e) } rnExpr expr@(SectionL {}) = do { addErr (sectionErr expr); rnSection expr } @@ -225,71 +225,71 @@ rnExpr expr@(SectionR {}) = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- -rnExpr (HsCoreAnn src ann expr) +rnExpr (HsCoreAnn x src ann expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn src ann expr', fvs_expr) } + ; return (HsCoreAnn x src ann expr', fvs_expr) } -rnExpr (HsSCC src lbl expr) +rnExpr (HsSCC x src lbl expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC src lbl expr', fvs_expr) } -rnExpr (HsTickPragma src info srcInfo expr) + ; return (HsSCC x src lbl expr', fvs_expr) } +rnExpr (HsTickPragma x src info srcInfo expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma src info srcInfo expr', fvs_expr) } + ; return (HsTickPragma x src info srcInfo expr', fvs_expr) } -rnExpr (HsLam matches) +rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches - ; return (HsLam matches', fvMatch) } + ; return (HsLam x matches', fvMatch) } -rnExpr (HsLamCase matches) +rnExpr (HsLamCase x matches) = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsLamCase matches', fvs_ms) } + ; return (HsLamCase x matches', fvs_ms) } -rnExpr (HsCase expr matches) +rnExpr (HsCase x expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet (L l binds) expr) +rnExpr (HsLet x (L l binds) expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet (L l binds') expr', fvExpr) } + ; return (HsLet x (L l binds') expr', fvExpr) } -rnExpr (HsDo do_or_lc (L l stmts) _) +rnExpr (HsDo x do_or_lc (L l stmts)) = do { ((stmts', _), fvs) <- rnStmtsWithPostProcessing do_or_lc rnLExpr postProcessStmtsForApplicativeDo stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) } + ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } -rnExpr (ExplicitList _ _ exps) +rnExpr (ExplicitList x _ exps) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (exps', fvs) <- rnExprs exps ; if opt_OverloadedLists then do { ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList placeHolderType (Just from_list_n_name) exps' + ; return (ExplicitList x (Just from_list_n_name) exps' , fvs `plusFV` fvs') } else - return (ExplicitList placeHolderType Nothing exps', fvs) } + return (ExplicitList x Nothing exps', fvs) } -rnExpr (ExplicitPArr _ exps) +rnExpr (ExplicitPArr x exps) = do { (exps', fvs) <- rnExprs exps - ; return (ExplicitPArr placeHolderType exps', fvs) } + ; return (ExplicitPArr x exps', fvs) } -rnExpr (ExplicitTuple tup_args boxity) +rnExpr (ExplicitTuple x tup_args boxity) = do { checkTupleSection tup_args ; checkTupSize (length tup_args) ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args - ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) } + ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } where rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e ; return (L l (Present e'), fvs) } rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) , emptyFVs) -rnExpr (ExplicitSum alt arity expr _) +rnExpr (ExplicitSum x alt arity expr) = do { (expr', fvs) <- rnLExpr expr - ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) } + ; return (ExplicitSum x alt arity expr', fvs) } rnExpr (RecordCon { rcon_con_name = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) @@ -297,53 +297,53 @@ rnExpr (RecordCon { rcon_con_name = con_id ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } - ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds' - , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } + ; return (RecordCon { rcon_ext = noExt + , rcon_con_name = con_lname, rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where - mk_hs_var l n = HsVar (L l n) + mk_hs_var l n = HsVar noExt (L l n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) = do { (expr', fvExpr) <- rnLExpr expr ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds' - , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder - , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } + ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr' + , rupd_flds = rbinds' } , fvExpr `plusFV` fvRbinds) } -rnExpr (ExprWithTySig expr pty) +rnExpr (ExprWithTySig pty expr) = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr - ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } + ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) } -rnExpr (HsIf _ p b1 b2) +rnExpr (HsIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLExpr b1 ; (b2', fvB2) <- rnLExpr b2 ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } -rnExpr (HsMultiIf _ty alts) +rnExpr (HsMultiIf x alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts -- ; return (HsMultiIf ty alts', fvs) } - ; return (HsMultiIf placeHolderType alts', fvs) } + ; return (HsMultiIf x alts', fvs) } -rnExpr (ArithSeq _ _ seq) +rnExpr (ArithSeq x _ seq) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq ; if opt_OverloadedLists then do { ; (from_list_name, fvs') <- lookupSyntaxName fromListName - ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } + ; return (ArithSeq x (Just from_list_name) new_seq + , fvs `plusFV` fvs') } else - return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } + return (ArithSeq x Nothing new_seq, fvs) } -rnExpr (PArrSeq _ seq) +rnExpr (PArrSeq x seq) = do { (new_seq, fvs) <- rnArithSeq seq - ; return (PArrSeq noPostTcExpr new_seq, fvs) } + ; return (PArrSeq x new_seq, fvs) } {- These three are pattern syntax appearing in expressions. @@ -351,7 +351,7 @@ Since all the symbols are reservedops we can simply reject them. We return a (bogus) EWildPat in each case. -} -rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole +rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole rnExpr e@(EAsPat {}) = do { opt_TypeApplications <- xoptM LangExt.TypeApplications ; let msg | opt_TypeApplications @@ -406,11 +406,11 @@ rnExpr e@(HsStatic _ expr) = do ************************************************************************ -} -rnExpr (HsProc pat body) +rnExpr (HsProc x pat body) = newArrowScope $ rnPat ProcExpr pat $ \ pat' -> do { (body',fvBody) <- rnCmdTop body - ; return (HsProc pat' body', fvBody) } + ; return (HsProc x pat' body', fvBody) } -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. rnExpr e@(HsArrApp {}) = arrowFail e @@ -419,8 +419,8 @@ rnExpr e@(HsArrForm {}) = arrowFail e rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap -hsHoleExpr :: HsExpr id -hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_")) +hsHoleExpr :: HsExpr (GhcPass id) +hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) arrowFail e @@ -433,17 +433,17 @@ arrowFail e ---------------------- -- See Note [Parsing sections] in Parser.y rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -rnSection section@(SectionR op expr) +rnSection section@(SectionR x op expr) = do { (op', fvs_op) <- rnLExpr op ; (expr', fvs_expr) <- rnLExpr expr ; checkSectionPrec InfixR section op' expr' - ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } + ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } -rnSection section@(SectionL expr op) +rnSection section@(SectionL x expr op) = do { (expr', fvs_expr) <- rnLExpr expr ; (op', fvs_op) <- rnLExpr op ; checkSectionPrec InfixL section op' expr' - ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } + ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } rnSection other = pprPanic "rnSection" (ppr other) @@ -499,7 +499,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- infix form rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) - ; let L _ (HsVar (L _ op_name)) = op' + ; let L _ (HsVar _ (L _ op_name)) = op' ; (arg1',fv_arg1) <- rnCmdTop arg1 ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity @@ -999,12 +999,12 @@ lookupStmtNamePoly ctxt name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar (noLoc fm), unitFV fm) } + ; return (HsVar noExt (noLoc fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where - not_rebindable = return (HsVar (noLoc name), emptyFVs) + not_rebindable = return (HsVar noExt (noLoc name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp/PArrComp are never rebindable @@ -1699,7 +1699,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do return (unLoc tup, emptyNameSet) | otherwise -> do (ret,fvs) <- lookupStmtNamePoly ctxt returnMName - return (HsApp (noLoc ret) tup, fvs) + return (HsApp noExt (noLoc ret) tup, fvs) return ( ApplicativeArgMany stmts' mb_ret pat , fvs1 `plusFV` fvs2) @@ -1874,8 +1874,8 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt :: HsStmtContext Name - -> [ApplicativeArg GhcRn GhcRn] -- ^ The args - -> Bool -- ^ True <=> need a join + -> [ApplicativeArg GhcRn] -- ^ The args + -> Bool -- ^ True <=> need a join -> [ExprLStmt GhcRn] -- ^ The body statements -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts @@ -1910,15 +1910,15 @@ needJoin _monad_names stmts = (True, stmts) isReturnApp :: MonadNames -> LHsExpr GhcRn -> Maybe (LHsExpr GhcRn) -isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr +isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr isReturnApp monad_names (L _ e) = case e of - OpApp l op _ r | is_return l, is_dollar op -> Just r - HsApp f arg | is_return f -> Just arg + OpApp _ l op r | is_return l, is_dollar op -> Just r + HsApp _ f arg | is_return f -> Just arg _otherwise -> Nothing where - is_var f (L _ (HsPar e)) = is_var f e - is_var f (L _ (HsAppType e _)) = is_var f e - is_var f (L _ (HsVar (L _ r))) = f r + is_var f (L _ (HsPar _ e)) = is_var f e + is_var f (L _ (HsAppType _ e)) = is_var f e + is_var f (L _ (HsVar _ (L _ r))) = f r -- TODO: I don't know how to get this right for rebindable syntax is_var _ _ = False @@ -2100,7 +2100,7 @@ patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", nest 4 (ppr e)] $$ explanation) - ; return (EWildPat, emptyFVs) } + ; return (EWildPat noExt, emptyFVs) } badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index beedf2ab66..1057cd2dbe 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -772,7 +772,7 @@ rnHsRecUpdFields flds then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (HsVar (L loc arg_rdr))) } + ; return (L loc (HsVar noExt (L loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -890,8 +890,8 @@ rnOverLit origLit ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) <- lookupSyntaxName std_name ; let rebindable = case from_thing_name of - HsVar (L _ v) -> v /= std_name - _ -> panic "rnOverLit" + HsVar _ (L _ v) -> v /= std_name + _ -> panic "rnOverLit" ; let lit' = lit { ol_witness = from_thing_name , ol_ext = rebindable } ; if isNegativeZeroOverLit lit' diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 7d69c87db2..0ca811424e 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -582,7 +582,7 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} | GRHSs [L _ (GRHS [] body)] lbinds <- grhss , L _ EmptyLocalBinds <- lbinds - , L _ (HsVar (L _ rhsName)) <- body = Just rhsName + , L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different @@ -1039,10 +1039,11 @@ validRuleLhs foralls lhs where checkl (L _ e) = check e - check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 - check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType e _) = checkl e - check (HsVar (L _ v)) | v `notElem` foralls = Nothing + check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 + `mplus` checkl_e e2 + check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 + check (HsAppType _ e) = checkl e + check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing check other = Just other -- Failure -- Check an argument @@ -1078,7 +1079,7 @@ badRuleLhsErr name lhs bad_e text "LHS must be of form (f e1 .. en) where f is not forall'd" where err = case bad_e of - HsUnboundVar uv -> text "Not in scope:" <+> ppr uv + HsUnboundVar _ uv -> text "Not in scope:" <+> ppr uv _ -> text "Illegal expression:" <+> ppr bad_e {- @@ -1092,7 +1093,7 @@ 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') diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index c681f1f42d..d18657b55e 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -102,7 +102,7 @@ rnBracket e br_body ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rn_bracket cur_stage br_body - ; return (HsBracket body', fvs_e) } + ; return (HsBracket noExt body', fvs_e) } False -> do { traceRn "Renaming untyped TH bracket" empty ; ps_var <- newMutVar [] @@ -110,7 +110,7 @@ rnBracket e br_body setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ rn_bracket cur_stage br_body ; pendings <- readMutVar ps_var - ; return (HsRnBracketOut body' pendings, fvs_e) } + ; return (HsRnBracketOut noExt body' pendings, fvs_e) } } rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) @@ -349,13 +349,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote - = L q_span $ HsApp (L q_span $ - HsApp (L q_span (HsVar (L q_span quote_selector))) + = L q_span $ HsApp noExt (L q_span $ + HsApp noExt (L q_span (HsVar noExt (L q_span quote_selector))) quoterExpr) quoteExpr where - quoterExpr = L q_span $! HsVar $! (L q_span quoter) - quoteExpr = L q_span $! HsLit $! HsString NoSourceText quote + quoterExpr = L q_span $! HsVar noExt $! (L q_span quoter) + quoteExpr = L q_span $! HsLit noExt $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -401,7 +401,7 @@ rnSpliceExpr splice where pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) pend_expr_splice rn_splice - = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice) + = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice) run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice rn_splice @@ -414,7 +414,7 @@ rnSpliceExpr splice , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) } + ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) } | otherwise -- Run it here, see Note [Running splices in the Renamer] = do { traceRn "rnSpliceExpr: untyped expression splice" empty @@ -422,7 +422,7 @@ rnSpliceExpr splice runRnSplice UntypedExpSplice runMetaE ppr rn_splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsPar $ HsSpliceE + ; return ( HsPar noExt $ HsSpliceE noExt . HsSpliced (ThModFinalizers mod_finalizers) . HsSplicedExpr <$> lexpr3 diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 8366684b53..14ef4f42a3 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1245,38 +1245,38 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 +mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (OpApp e1 op2 fix2 e2) + return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp e11 op1 fix1 (L loc' new_e)) + return (OpApp fix1 e11 op1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 +mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) - return (OpApp e1 op2 fix2 e2) + return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp (L loc' new_e) neg_name) + return (NegApp noExt (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) - return (OpApp e1 op1 fix1 e2) + return (OpApp fix1 e1 op1 e2) where (_, associate_right) = compareFixity fix1 negateFixity @@ -1286,7 +1286,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) - return (OpApp e1 op fix e2) + return (OpApp fix e1 op e2) ---------------------------- @@ -1306,16 +1306,16 @@ instance Outputable OpName where get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar -get_op (L _ (HsVar (L _ n))) = NormalOp n -get_op (L _ (HsUnboundVar uv)) = UnboundOp uv -get_op (L _ (HsRecFld fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) +get_op (L _ (HsVar _ (L _ n))) = NormalOp n +get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operand. So we just check that the right operand is OK right_op_ok :: Fixity -> HsExpr GhcRn -> Bool -right_op_ok fix1 (OpApp _ _ fix2 _) +right_op_ok fix1 (OpApp fix2 _ _ _) = not error_please && associate_right where (error_please, associate_right) = compareFixity fix1 fix2 @@ -1324,14 +1324,15 @@ right_op_ok _ _ -- Parser initially makes negation bind more tightly than any other operator -- And "deriving" code should respect this (use HsPar if not) -mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) +mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) + -> RnM (HsExpr (GhcPass id)) mkNegAppRn neg_arg neg_name = ASSERT( not_op_app (unLoc neg_arg) ) - return (NegApp neg_arg neg_name) + return (NegApp noExt neg_arg neg_name) not_op_app :: HsExpr id -> Bool -not_op_app (OpApp _ _ _ _) = False -not_op_app _ = True +not_op_app (OpApp {}) = False +not_op_app _ = True --------------------------- mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged @@ -1436,8 +1437,8 @@ checkSectionPrec :: FixityDirection -> HsExpr GhcPs -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () checkSectionPrec direction section op arg = case unLoc arg of - OpApp _ op' fix _ -> go_for_it (get_op op') fix - NegApp _ _ -> go_for_it NegateOp negateFixity + OpApp fix _ op' _ -> go_for_it (get_op op') fix + NegApp _ _ _ -> go_for_it NegateOp negateFixity _ -> return () where op_name = get_op op diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index d0ff4c7f45..9675fdda22 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -97,7 +97,7 @@ newMethodFromName origin name inst_ty ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) instCall origin [inst_ty] theta - ; return (mkHsWrap wrap (HsVar (noLoc id))) } + ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) } {- ************************************************************************ @@ -559,7 +559,7 @@ newNonTrivialOverloadedLit :: CtOrigin -> ExpRhoType -> TcM (HsOverLit GhcTcId) newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name) + lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) , ol_ext = rebindable }) res_ty = do { hs_lit <- mkOverLit val ; let lit_ty = hsLitType hs_lit @@ -626,7 +626,7 @@ tcSyntaxName :: CtOrigin -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in HsExpr -tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm)) +tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) | std_nm == user_nm = do rhs <- newMethodFromName orig std_nm ty return (std_nm, rhs) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index f9f47806fe..515eb4df35 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1178,9 +1178,9 @@ tcVect :: VectDecl GhcRn -> TcM (VectDecl GhcTcId) tcVect (HsVect s name rhs) = addErrCtxt (vectCtxt name) $ do { var <- wrapLocM tcLookupId name - ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs + ; 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 (L lv rhs_id))) + ; return $ HsVect s var (L rhs_loc (HsVar noExt (L lv rhs_id))) } tcVect (HsNoVect s name) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 014e97625e..b1a473c457 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -167,43 +167,43 @@ NB: The res_ty is always deeply skolemised. -} tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) -tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty -tcExpr e@(HsUnboundVar uv) res_ty = tcUnboundId e uv res_ty +tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty +tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty -tcExpr e@(HsLit lit) res_ty +tcExpr e@(HsLit x lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult e (HsLit (convertLit lit)) lit_ty res_ty } + ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar expr') } +tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar x expr') } -tcExpr (HsSCC src lbl expr) res_ty +tcExpr (HsSCC x src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC src lbl expr') } + ; return (HsSCC x src lbl expr') } -tcExpr (HsTickPragma src info srcInfo expr) res_ty +tcExpr (HsTickPragma x src info srcInfo expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma src info srcInfo expr') } + ; return (HsTickPragma x src info srcInfo expr') } -tcExpr (HsCoreAnn src lbl expr) res_ty +tcExpr (HsCoreAnn x src lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn src lbl expr') } + ; return (HsCoreAnn x src lbl expr') } -tcExpr (HsOverLit lit) res_ty +tcExpr (HsOverLit x lit) res_ty = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit lit') } + ; return (HsOverLit x lit') } -tcExpr (NegApp expr neg_expr) res_ty +tcExpr (NegApp x expr neg_expr) res_ty = do { (expr', neg_expr') <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ \[arg_ty] -> tcMonoExpr expr (mkCheckExpType arg_ty) - ; return (NegApp expr' neg_expr') } + ; return (NegApp x expr' neg_expr') } -tcExpr e@(HsIPVar x) res_ty +tcExpr e@(HsIPVar _ x) res_ty = do { {- Implicit parameters must have a *tau-type* not a type scheme. We enforce this by creating a fresh type variable as its type. (Because res_ty may not @@ -212,15 +212,16 @@ tcExpr e@(HsIPVar x) res_ty ; let ip_name = mkStrLitTy (hsIPNameFS x) ; ipClass <- tcLookupClass ipClassName ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var))) - ip_ty res_ty } + ; tcWrapResult e + (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var))) + ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x -tcExpr e@(HsOverLabel mb_fromLabel l) res_ty +tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty = do { -- See Note [Type-checking overloaded labels] loc <- getSrcSpanM ; case mb_fromLabel of @@ -230,7 +231,8 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty ; let pred = mkClassPred isLabelClass [lbl, alpha] ; loc <- getSrcSpanM ; var <- emitWantedEvVar origin pred - ; tcWrapResult e (fromDict pred (HsVar (L loc var))) + ; tcWrapResult e + (fromDict pred (HsVar noExt (L loc var))) alpha res_ty } } where -- Coerces a dictionary for `IsLabel "x" t` into `t`, @@ -240,12 +242,13 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty lbl = mkStrLitTy l applyFromLabel loc fromLabel = - L loc (HsVar (L loc fromLabel)) `HsAppType` - mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))) + HsAppType + (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l)))) + (L loc (HsVar noExt (L loc fromLabel))) -tcExpr (HsLam match) res_ty +tcExpr (HsLam x match) res_ty = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam match')) } + ; return (mkHsWrap wrap (HsLam x match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } herald = sep [ text "The lambda expression" <+> @@ -254,23 +257,23 @@ tcExpr (HsLam match) res_ty -- The pprSetDepth makes the abstraction print briefly text "has"] -tcExpr e@(HsLamCase matches) res_ty +tcExpr e@(HsLamCase x matches) res_ty = do { (matches', wrap) <- tcMatchLambda msg match_ctxt matches res_ty -- The laziness annotation is because we don't want to fail here -- if there are multiple arguments - ; return (mkHsWrap wrap $ HsLamCase matches') } + ; return (mkHsWrap wrap $ HsLamCase x matches') } where msg = sep [ text "The function" <+> quotes (ppr e) , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr e@(ExprWithTySig expr sig_ty) res_ty +tcExpr e@(ExprWithTySig sig_ty expr) res_ty = do { let loc = getLoc (hsSigWcType sig_ty) ; sig_info <- checkNoErrs $ -- Avoid error cascade tcUserTypeSig loc sig_ty Nothing ; (expr', poly_ty) <- tcExprSig expr sig_info - ; let expr'' = ExprWithTySigOut expr' sig_ty + ; let expr'' = ExprWithTySig sig_ty expr' ; tcWrapResult e expr'' poly_ty res_ty } {- @@ -349,8 +352,8 @@ construct. See also Note [seqId magic] in MkId -} -tcExpr expr@(OpApp arg1 op fix arg2) res_ty - | (L loc (HsVar (L lv op_name))) <- op +tcExpr expr@(OpApp fix arg1 op arg2) res_ty + | (L loc (HsVar _ (L lv op_name))) <- op , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind ; let arg2_exp_ty = res_ty @@ -360,10 +363,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; arg2_ty <- readExpType arg2_exp_ty ; op_id <- tcLookupId op_name ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty]) - (HsVar (L lv op_id))) - ; return $ OpApp arg1' op' fix arg2' } + (HsVar noExt (L lv op_id))) + ; return $ OpApp fix arg1' op' arg2' } - | (L loc (HsVar (L lv op_name))) <- op + | (L loc (HsVar _ (L lv op_name))) <- op , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferSigma arg1 @@ -401,7 +404,7 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty , arg2_sigma , res_ty]) - (HsVar (L lv op_id))) + (HsVar noExt (L lv op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) -- wrap_res :: op_res_ty "->" res_ty @@ -412,15 +415,15 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty <.> wrap_arg1 doc = text "When looking at the argument to ($)" - ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix arg2') } + ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') } - | (L loc (HsRecFld (Ambiguous _ lbl))) <- op + | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op , Just sig_ty <- obviousSig (unLoc arg1) -- See Note [Disambiguating record fields] = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; let op' = L loc (HsRecFld (Unambiguous sel_name lbl)) - ; tcExpr (OpApp arg1 op' fix arg2) res_ty + ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl)) + ; tcExpr (OpApp fix arg1 op' arg2) res_ty } | otherwise @@ -428,12 +431,12 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; (wrap, op', [HsValArg arg1', HsValArg arg2']) <- tcApp (Just $ mk_op_msg op) op [HsValArg arg1, HsValArg arg2] res_ty - ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') } + ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') } -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr -tcExpr expr@(SectionR op arg2) res_ty +tcExpr expr@(SectionR x op arg2) res_ty = do { (op', op_ty) <- tcInferFun op ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty @@ -441,14 +444,14 @@ tcExpr expr@(SectionR op arg2) res_ty (mkFunTy arg1_ty op_res_ty) res_ty ; arg2' <- tcArg op arg2 arg2_ty 2 ; return ( mkHsWrap wrap_res $ - SectionR (mkLHsWrap wrap_fun op') arg2' ) } + SectionR x (mkLHsWrap wrap_fun op') arg2' ) } where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks -- come out right; they are driven by the OccurrenceOf CtOrigin -- See Trac #13285 -tcExpr expr@(SectionL arg1 op) res_ty +tcExpr expr@(SectionL x arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op ; dflags <- getDynFlags -- Note [Left sections] ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 @@ -461,14 +464,14 @@ tcExpr expr@(SectionL arg1 op) res_ty (mkFunTys arg_tys op_res_ty) res_ty ; arg1' <- tcArg op arg1 arg1_ty 1 ; return ( mkHsWrap wrap_res $ - SectionL arg1' (mkLHsWrap wrap_fn op') ) } + SectionL x arg1' (mkLHsWrap wrap_fn op') ) } where fn_orig = lexprCtOrigin op -- It's important to use the origin of 'op', so that call-stacks -- come out right; they are driven by the OccurrenceOf CtOrigin -- See Trac #13285 -tcExpr expr@(ExplicitTuple tup_args boxity) res_ty +tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty | all tupArgPresent tup_args = do { let arity = length tup_args tup_tc = tupleTyCon boxity arity @@ -480,7 +483,7 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys ; tup_args1 <- tcTupArgs tup_args arg_tys' - ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) @@ -500,16 +503,16 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) } -tcExpr (ExplicitSum alt arity expr _) res_ty +tcExpr (ExplicitSum _ alt arity expr) res_ty = do { let sum_tc = sumTyCon arity ; res_ty <- expTypeToType res_ty ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty ; -- Drop levity vars, we don't care about them here let arg_tys' = drop arity arg_tys ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1)) - ; return $ mkHsWrapCo coi (ExplicitSum alt arity expr' arg_tys') } + ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } tcExpr (ExplicitList _ witness exprs) res_ty = case witness of @@ -547,12 +550,12 @@ tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty ************************************************************************ -} -tcExpr (HsLet (L l binds) expr) res_ty +tcExpr (HsLet x (L l binds) expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet (L l binds') expr') } + ; return (HsLet x (L l binds') expr') } -tcExpr (HsCase scrut matches) res_ty +tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example @@ -566,12 +569,12 @@ tcExpr (HsCase scrut matches) res_ty ; traceTc "HsCase" (ppr scrut_ty) ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - ; return (HsCase scrut' matches') } + ; return (HsCase x scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' +tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; res_ty <- tauifyExpType res_ty -- Just like Note [Case branches must never infer a non-tau type] @@ -579,9 +582,9 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf Nothing pred' b1' b2') } + ; return (HsIf x Nothing pred' b1' b2') } -tcExpr (HsIf (Just fun) pred b1 b2) res_ty +tcExpr (HsIf x (Just fun) pred b1 b2) res_ty = do { ((pred', b1', b2'), fun') <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ \ [pred_ty, b1_ty, b2_ty] -> @@ -589,7 +592,7 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty ; b1' <- tcPolyExpr b1 b1_ty ; b2' <- tcPolyExpr b2 b2_ty ; return (pred', b1', b2') } - ; return (HsIf (Just fun') pred' b1' b2') } + ; return (HsIf x (Just fun') pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty = do { res_ty <- if isSingleton alts @@ -603,13 +606,13 @@ tcExpr (HsMultiIf _ alts) res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } -tcExpr (HsDo do_or_lc stmts _) res_ty +tcExpr (HsDo _ do_or_lc stmts) res_ty = do { expr' <- tcDoStmts do_or_lc stmts res_ty ; return expr' } -tcExpr (HsProc pat cmd) res_ty +tcExpr (HsProc x pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc pat' cmd') } + ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. -- See Note [Grand plan for static forms] in StaticPtrTable for an overview. @@ -650,7 +653,8 @@ tcExpr (HsStatic fvs expr) res_ty ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr) + ; return $ mkHsWrapCo co $ HsApp noExt + (L loc $ mkHsWrap wrap fromStaticPtr) (L loc (HsStatic fvs expr')) } @@ -684,9 +688,10 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name ; rbinds' <- tcRecordBinds con_like arg_tys rbinds ; return $ mkHsWrap res_wrap $ - RecordCon { rcon_con_name = L loc con_id - , rcon_con_expr = mkHsWrap con_wrap con_expr - , rcon_con_like = con_like + RecordCon { rcon_ext = RecordConTc + { rcon_con_like = con_like + , rcon_con_expr = mkHsWrap con_wrap con_expr } + , rcon_con_name = L loc con_id , rcon_flds = rbinds' } } } {- @@ -971,12 +976,16 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Phew! ; return $ mkHsWrap wrap_res $ - RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') + RecordUpd { rupd_expr + = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') , rupd_flds = rbinds' - , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } } + , rupd_ext = RecordUpdTc + { rupd_cons = relevant_cons + , rupd_in_tys = scrut_inst_tys + , rupd_out_tys = result_inst_tys + , rupd_wrap = req_wrap }} } -tcExpr e@(HsRecFld f) res_ty +tcExpr e@(HsRecFld _ f) res_ty = tcCheckRecSelId e f res_ty {- @@ -1013,10 +1022,9 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) (idName enumFromThenToP) elt_ty -- !!!FIXME: chak ; return $ - mkHsWrapCo coi $ - PArrSeq eft (FromThenTo expr1' expr2' expr3') } + mkHsWrapCo coi $ PArrSeq eft (FromThenTo expr1' expr2' expr3') } -tcExpr (PArrSeq _ _) _ +tcExpr (PArrSeq {}) _ = panic "TcExpr.tcExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer shouldn't have -- let it through @@ -1033,15 +1041,15 @@ tcExpr (PArrSeq _ _) _ -- Here we get rid of it and add the finalizers to the global environment. -- -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr))) +tcExpr (HsSpliceE _ (HsSpliced mod_finalizers (HsSplicedExpr expr))) res_ty = do addModFinalizersWithLclEnv mod_finalizers tcExpr expr res_ty -tcExpr (HsSpliceE splice) res_ty +tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty -tcExpr e@(HsBracket brack) res_ty +tcExpr e@(HsBracket _ brack) res_ty = tcTypedBracket e brack res_ty -tcExpr e@(HsRnBracketOut brack ps) res_ty +tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty {- @@ -1158,11 +1166,11 @@ tcApp m_herald orig_fun orig_args res_ty where go :: LHsExpr GhcRn -> [LHsExprArgIn] -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut]) - go (L _ (HsPar e)) args = go e args - go (L _ (HsApp e1 e2)) args = go e1 (HsValArg e2:args) - go (L _ (HsAppType e t)) args = go e (HsTypeArg t:args) + go (L _ (HsPar _ e)) args = go e args + go (L _ (HsApp _ e1 e2)) args = go e1 (HsValArg e2:args) + go (L _ (HsAppType t e)) args = go e (HsTypeArg t:args) - go (L loc (HsVar (L _ fun))) args + go (L loc (HsVar _ (L _ fun))) args | fun `hasKey` tagToEnumKey , count isHsValArg args == 1 = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty @@ -1173,11 +1181,11 @@ tcApp m_herald orig_fun orig_args res_ty = do { (wrap, expr, args) <- tcSeq loc fun args res_ty ; return (wrap, expr, args) } - go (L loc (HsRecFld (Ambiguous _ lbl))) args@(HsValArg (L _ arg) : _) + go (L loc (HsRecFld _ (Ambiguous _ lbl))) args@(HsValArg (L _ arg) : _) | Just sig_ty <- obviousSig arg = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty ; sel_name <- disambiguateSelector lbl sig_tc_ty - ; go (L loc (HsRecFld (Unambiguous sel_name lbl))) args } + ; go (L loc (HsRecFld noExt (Unambiguous sel_name lbl))) args } -- See Note [Visible type application for the empty list constructor] go (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg] @@ -1247,12 +1255,12 @@ which is better than before. ---------------- tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType) -- Infer type of a function -tcInferFun (L loc (HsVar (L _ name))) +tcInferFun (L loc (HsVar _ (L _ name))) = do { (fun, ty) <- setSrcSpan loc (tcInferId name) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } -tcInferFun (L loc (HsRecFld f)) +tcInferFun (L loc (HsRecFld _ f)) = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } @@ -1408,7 +1416,7 @@ tcSyntaxOpGen :: CtOrigin -> SyntaxOpType -> ([TcSigmaType] -> TcM a) -> TcM (a, SyntaxExpr GhcTcId) -tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) }) +tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar _ (L _ op) }) arg_tys res_ty thing_inside = do { (expr, sigma) <- tcInferId op ; (result, expr_wrap, arg_wraps, res_wrap) @@ -1681,13 +1689,14 @@ tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOf name) (HsVar (noLoc name)) expr actual_res_ty res_ty } + ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr + actual_res_ty res_ty } tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId) tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty = do { (expr, actual_res_ty) <- tcInferRecSelId f - ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $ + ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $ tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty } tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of @@ -1733,7 +1742,7 @@ tc_infer_assert assert_name = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho) + ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho) } tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType) @@ -1759,12 +1768,12 @@ tc_infer_id lbl id_name _ -> failWithTc $ ppr thing <+> text "used where a value identifier was expected" } where - return_id id = return (HsVar (noLoc id), idType id) + return_id id = return (HsVar noExt (noLoc id), idType id) return_data_con con -- For data constructors, must perform the stupid-theta check | null stupid_theta - = return (HsConLikeOut (RealDataCon con), con_ty) + = return (HsConLikeOut noExt (RealDataCon con), con_ty) | otherwise -- See Note [Instantiating stupid theta] @@ -1775,7 +1784,8 @@ tc_infer_id lbl id_name rho' = substTy subst rho ; wrap <- instCall (OccurrenceOf id_name) tys' theta' ; addDataConStupidTheta con tys' - ; return (mkHsWrap wrap (HsConLikeOut (RealDataCon con)), rho') } + ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con)) + , rho') } where con_ty = dataConUserType con @@ -1807,7 +1817,8 @@ tcUnboundId rn_expr unbound res_ty , ctev_loc = loc} , cc_hole = ExprHole unbound } ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar (noLoc ev)) ty res_ty } + ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev)) + ty res_ty } {- @@ -1889,7 +1900,7 @@ tcSeq loc fun_name args res_ty ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty) ; arg2' <- tcMonoExpr arg2 arg2_exp_ty ; res_ty <- readExpType res_ty -- by now, it's surely filled in - ; let fun' = L loc (mkHsWrap ty_args (HsVar (L loc fun))) + ; let fun' = L loc (mkHsWrap ty_args (HsVar noExt (L loc fun))) ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty ; return (idHsWrapper, fun', [HsValArg arg1', HsValArg arg2']) } @@ -1931,7 +1942,7 @@ tcTagToEnum loc fun_name args res_ty (mk_error ty' doc2) ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) + ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun))) rep_ty = mkTyConApp rep_tc rep_args ; return (mkWpCastR (mkTcSymCo coi), fun', [HsValArg arg']) } @@ -2009,7 +2020,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) ; lift <- if isStringTy id_ty then do { sid <- tcLookupId THNames.liftStringName -- See Note [Lifting strings] - ; return (HsVar (noLoc sid)) } + ; return (HsVar noExt (noLoc sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE @@ -2325,8 +2336,8 @@ lookupParents rdr -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig _ ty) = Just ty -obviousSig (HsPar p) = obviousSig (unLoc p) +obviousSig (ExprWithTySig ty _) = Just ty +obviousSig (HsPar _ p) = obviousSig (unLoc p) obviousSig _ = Nothing diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 714008a5a6..9140de69f7 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -447,7 +447,7 @@ gen_Ord_binds loc tycon = do , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con - tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag))) + tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K @@ -1700,12 +1700,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty pp_lhs = ppr (mkTyConApp fam_tc rep_lhs_tys) nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (e `HsAppType` hs_ty) +nlHsAppType e s = noLoc (HsAppType hs_ty e) where hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s) nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty) +nlExprWithTySig e s = noLoc (ExprWithTySig hs_ty e) where hs_ty = mkLHsSigWcType (typeToLHsType s) @@ -2093,8 +2093,8 @@ illegal_toEnum_tag tp maxtag = (nlHsLit (mkHsString ")")))))) parenify :: LHsExpr GhcPs -> LHsExpr GhcPs -parenify e@(L _ (HsVar _)) = e -parenify e = mkHsPar e +parenify e@(L _ (HsVar _ _)) = e +parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 955b7986ab..5544a912a3 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -130,9 +130,9 @@ hsLitType (XLit p) = pprPanic "hsLitType" (ppr p) shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) shortCutLit dflags (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt noExt int)) + | isIntTy ty && inIntRange dflags i = Just (HsLit noExt (HsInt noExt int)) | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit (HsInteger src i ty)) + | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty)) | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, @@ -146,11 +146,11 @@ shortCutLit _ (HsFractional f) ty | otherwise = Nothing shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit (HsString src s)) + | isStringTy ty = Just (HsLit noExt (HsString src s)) | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp (nlHsDataCon con) (nlHsLit lit) +mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name @@ -607,115 +607,115 @@ zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar (L l id)) +zonkExpr env (HsVar x (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar (L l (zonkIdOcc env id))) + return (HsVar x (L l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e -zonkExpr _ (HsIPVar id) - = return (HsIPVar id) +zonkExpr _ (HsIPVar x id) + = return (HsIPVar x id) zonkExpr _ e@HsOverLabel{} = return e -zonkExpr env (HsLit (HsRat e f ty)) +zonkExpr env (HsLit x (HsRat e f ty)) = do new_ty <- zonkTcTypeToType env ty - return (HsLit (HsRat e f new_ty)) + return (HsLit x (HsRat e f new_ty)) -zonkExpr _ (HsLit lit) - = return (HsLit lit) +zonkExpr _ (HsLit x lit) + = return (HsLit x lit) -zonkExpr env (HsOverLit lit) +zonkExpr env (HsOverLit x lit) = do { lit' <- zonkOverLit env lit - ; return (HsOverLit lit') } + ; return (HsOverLit x lit') } -zonkExpr env (HsLam matches) +zonkExpr env (HsLam x matches) = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLam new_matches) + return (HsLam x new_matches) -zonkExpr env (HsLamCase matches) +zonkExpr env (HsLamCase x matches) = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase new_matches) + return (HsLamCase x new_matches) -zonkExpr env (HsApp e1 e2) +zonkExpr env (HsApp x e1 e2) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 - return (HsApp new_e1 new_e2) + return (HsApp x new_e1 new_e2) -zonkExpr env (HsAppTypeOut e t) +zonkExpr env (HsAppType t e) = do new_e <- zonkLExpr env e - return (HsAppTypeOut new_e t) + return (HsAppType t new_e) -- NB: the type is an HsType; can't zonk that! -zonkExpr _ e@(HsRnBracketOut _ _) +zonkExpr _ e@(HsRnBracketOut _ _ _) = pprPanic "zonkExpr: HsRnBracketOut" (ppr e) -zonkExpr env (HsTcBracketOut body bs) +zonkExpr env (HsTcBracketOut x body bs) = do bs' <- mapM zonk_b bs - return (HsTcBracketOut body bs') + return (HsTcBracketOut x body bs') where zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e return (PendingTcSplice n e') -zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen - return (HsSpliceE s) +zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen + return (HsSpliceE x s) -zonkExpr env (OpApp e1 op fixity e2) +zonkExpr env (OpApp fixity e1 op e2) = do new_e1 <- zonkLExpr env e1 new_op <- zonkLExpr env op new_e2 <- zonkLExpr env e2 - return (OpApp new_e1 new_op fixity new_e2) + return (OpApp fixity new_e1 new_op new_e2) -zonkExpr env (NegApp expr op) +zonkExpr env (NegApp x expr op) = do (env', new_op) <- zonkSyntaxExpr env op new_expr <- zonkLExpr env' expr - return (NegApp new_expr new_op) + return (NegApp x new_expr new_op) -zonkExpr env (HsPar e) +zonkExpr env (HsPar x e) = do new_e <- zonkLExpr env e - return (HsPar new_e) + return (HsPar x new_e) -zonkExpr env (SectionL expr op) +zonkExpr env (SectionL x expr op) = do new_expr <- zonkLExpr env expr new_op <- zonkLExpr env op - return (SectionL new_expr new_op) + return (SectionL x new_expr new_op) -zonkExpr env (SectionR op expr) +zonkExpr env (SectionR x op expr) = do new_op <- zonkLExpr env op new_expr <- zonkLExpr env expr - return (SectionR new_op new_expr) + return (SectionR x new_op new_expr) -zonkExpr env (ExplicitTuple tup_args boxed) +zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args - ; return (ExplicitTuple new_tup_args boxed) } + ; return (ExplicitTuple x new_tup_args boxed) } where zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e ; return (L l (Present e')) } zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t ; return (L l (Missing t')) } -zonkExpr env (ExplicitSum alt arity expr args) +zonkExpr env (ExplicitSum args alt arity expr) = do new_args <- mapM (zonkTcTypeToType env) args new_expr <- zonkLExpr env expr - return (ExplicitSum alt arity new_expr new_args) + return (ExplicitSum new_args alt arity new_expr) -zonkExpr env (HsCase expr ms) +zonkExpr env (HsCase x expr ms) = do new_expr <- zonkLExpr env expr new_ms <- zonkMatchGroup env zonkLExpr ms - return (HsCase new_expr new_ms) + return (HsCase x new_expr new_ms) -zonkExpr env (HsIf Nothing e1 e2 e3) +zonkExpr env (HsIf x Nothing e1 e2 e3) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 new_e3 <- zonkLExpr env e3 - return (HsIf Nothing new_e1 new_e2 new_e3) + return (HsIf x Nothing new_e1 new_e2 new_e3) -zonkExpr env (HsIf (Just fun) e1 e2 e3) +zonkExpr env (HsIf x (Just fun) e1 e2 e3) = do (env1, new_fun) <- zonkSyntaxExpr env fun new_e1 <- zonkLExpr env1 e1 new_e2 <- zonkLExpr env1 e2 new_e3 <- zonkLExpr env1 e3 - return (HsIf (Just new_fun) new_e1 new_e2 new_e3) + return (HsIf x (Just new_fun) new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts @@ -726,15 +726,15 @@ zonkExpr env (HsMultiIf ty alts) ; expr' <- zonkLExpr env' expr ; return $ GRHS guard' expr' } -zonkExpr env (HsLet (L l binds) expr) +zonkExpr env (HsLet x (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet (L l new_binds) new_expr) + return (HsLet x (L l new_binds) new_expr) -zonkExpr env (HsDo do_or_lc (L l stmts) ty) +zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToType env ty - return (HsDo do_or_lc (L l new_stmts) new_ty) + return (HsDo new_ty do_or_lc (L l new_stmts)) zonkExpr env (ExplicitList ty wit exprs) = do (env1, new_wit) <- zonkWit env wit @@ -749,27 +749,31 @@ zonkExpr env (ExplicitPArr ty exprs) new_exprs <- zonkLExprs env exprs return (ExplicitPArr new_ty new_exprs) -zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env con_expr +zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_con_expr = new_con_expr + ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } , rcon_flds = new_rbinds }) } -zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds - , rupd_cons = cons, rupd_in_tys = in_tys - , rupd_out_tys = out_tys, rupd_wrap = req_wrap }) +zonkExpr env (RecordUpd { rupd_flds = rbinds + , rupd_expr = expr + , rupd_ext = RecordUpdTc + { rupd_cons = cons, rupd_in_tys = in_tys + , rupd_out_tys = out_tys, rupd_wrap = req_wrap }}) = do { new_expr <- zonkLExpr env expr ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys ; new_rbinds <- zonkRecUpdFields env rbinds ; (_, new_recwrap) <- zonkCoFn env req_wrap ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds - , rupd_cons = cons, rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) } + , rupd_ext = RecordUpdTc + { rupd_cons = cons, rupd_in_tys = new_in_tys + , rupd_out_tys = new_out_tys + , rupd_wrap = new_recwrap }}) } -zonkExpr env (ExprWithTySigOut e ty) +zonkExpr env (ExprWithTySig ty e) = do { e' <- zonkLExpr env e - ; return (ExprWithTySigOut e' ty) } + ; return (ExprWithTySig ty e') } zonkExpr env (ArithSeq expr wit info) = do (env1, new_wit) <- zonkWit env wit @@ -784,33 +788,33 @@ zonkExpr env (PArrSeq expr info) new_info <- zonkArithSeq env info return (PArrSeq new_expr new_info) -zonkExpr env (HsSCC src lbl expr) +zonkExpr env (HsSCC x src lbl expr) = do new_expr <- zonkLExpr env expr - return (HsSCC src lbl new_expr) + return (HsSCC x src lbl new_expr) -zonkExpr env (HsTickPragma src info srcInfo expr) +zonkExpr env (HsTickPragma x src info srcInfo expr) = do new_expr <- zonkLExpr env expr - return (HsTickPragma src info srcInfo new_expr) + return (HsTickPragma x src info srcInfo new_expr) -- hdaume: core annotations -zonkExpr env (HsCoreAnn src lbl expr) +zonkExpr env (HsCoreAnn x src lbl expr) = do new_expr <- zonkLExpr env expr - return (HsCoreAnn src lbl new_expr) + return (HsCoreAnn x src lbl new_expr) -- arrow notation extensions -zonkExpr env (HsProc pat body) +zonkExpr env (HsProc x pat body) = do { (env1, new_pat) <- zonkPat env pat ; new_body <- zonkCmdTop env1 body - ; return (HsProc new_pat new_body) } + ; return (HsProc x new_pat new_body) } -- StaticPointers extension zonkExpr env (HsStatic fvs expr) = HsStatic fvs <$> zonkLExpr env expr -zonkExpr env (HsWrap co_fn expr) +zonkExpr env (HsWrap x co_fn expr) = do (env1, new_co_fn) <- zonkCoFn env co_fn new_expr <- zonkExpr env1 expr - return (HsWrap new_co_fn new_expr) + return (HsWrap x new_co_fn new_expr) zonkExpr _ e@(HsUnboundVar {}) = return e diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 3dbe02d6da..f88a11619a 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -870,14 +870,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- con_app_scs = MkD ty1 ty2 sc1 sc2 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 con_app_tys = mkHsWrap (mkWpTyApps inst_tys) - (HsConLikeOut (RealDataCon dict_constr)) + (HsConLikeOut noExt (RealDataCon dict_constr)) -- NB: We *can* have covars in inst_tys, in the case of -- promoted GADT constructors. con_app_args = foldl app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id) + app_to_meth fun meth_id = HsApp noExt (L loc fun) + (L loc (wrapId arg_wrapper meth_id)) inst_tv_tys = mkTyVarTys inst_tyvars arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys @@ -940,8 +941,8 @@ addDFunPrags dfun_id sc_meth_ids [dict_con] = tyConDataCons clas_tc is_newtype = isNewTyCon clas_tc -wrapId :: HsWrapper -> IdP id -> HsExpr id -wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id)) +wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id) +wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1334,12 +1335,12 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys mkLHsWrap lam_wrapper (error_rhs dflags) ; return (meth_id, meth_bind, Nothing) } where - error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) + error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit (HsStringPrim noSourceText + error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim noSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) error_string dflags = showSDoc dflags @@ -1605,9 +1606,8 @@ mkDefMethBind clas inst_tys sel_id dm_name ; return (bind, inline_prags) } where mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs - $ nlHsParTy - $ noLoc $ XHsType $ NHsCoreTy ty)) + mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy + $ noLoc $ XHsType $ NHsCoreTy ty) fun) -- NB: use visible type application -- See Note [Default methods in instances] diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index d938de0e22..1dbafbbb88 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -296,7 +296,7 @@ tcDoStmts ListComp (L l stmts) res_ty ; let list_ty = mkListTy elt_ty ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) } + ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } tcDoStmts PArrComp (L l stmts) res_ty = do { res_ty <- expTypeToType res_ty @@ -304,22 +304,22 @@ tcDoStmts PArrComp (L l stmts) res_ty ; let parr_ty = mkPArrTy elt_ty ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts (mkCheckExpType elt_ty) - ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) } + ; return $ mkHsWrapCo co (HsDo parr_ty PArrComp (L l stmts')) } tcDoStmts DoExpr (L l stmts) res_ty = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty ; res_ty <- readExpType res_ty - ; return (HsDo DoExpr (L l stmts') res_ty) } + ; return (HsDo res_ty DoExpr (L l stmts')) } tcDoStmts MDoExpr (L l stmts) res_ty = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty ; res_ty <- readExpType res_ty - ; return (HsDo MDoExpr (L l stmts') res_ty) } + ; return (HsDo res_ty MDoExpr (L l stmts')) } tcDoStmts MonadComp (L l stmts) res_ty = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty ; res_ty <- readExpType res_ty - ; return (HsDo MonadComp (L l stmts') res_ty) } + ; return (HsDo res_ty MonadComp (L l stmts')) } tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) @@ -1011,10 +1011,10 @@ join :: tn -> res_ty tcApplicativeStmts :: HsStmtContext Name - -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn GhcRn)] + -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] -> ExpRhoType -- rhs_ty -> (TcRhoType -> TcM t) -- thing_inside - -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId GhcTcId)], Type, t) + -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t) tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind @@ -1052,8 +1052,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside ; ops' <- goOps t_i ops ; return (op' : ops') } - goArg :: (ApplicativeArg GhcRn GhcRn, Type, Type) - -> TcM (ApplicativeArg GhcTcId GhcTcId) + goArg :: (ApplicativeArg GhcRn, Type, Type) -> TcM (ApplicativeArg GhcTcId) goArg (ApplicativeArgOne pat rhs isBody, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ @@ -1074,7 +1073,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside } ; return (ApplicativeArgMany stmts' ret' pat') } - get_arg_bndrs :: ApplicativeArg GhcTcId GhcTcId -> [Id] + get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id] get_arg_bndrs (ApplicativeArgOne pat _ _) = collectPatBinders pat get_arg_bndrs (ApplicativeArgMany _ _ pat) = collectPatBinders pat diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index c4f7b918f3..0f64e9c2a5 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -474,14 +474,14 @@ tcPatSynMatcher (L loc name) lpat mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ - HsCase (nlHsVar scrutinee) $ + HsCase noExt (nlHsVar scrutinee) $ MG{ mg_alts = L (getLoc lpat) cases , mg_arg_tys = [pat_ty] , mg_res_ty = res_ty , mg_origin = Generated } body' = noLoc $ - HsLam $ + HsLam noExt $ MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr args body] , mg_arg_tys = [pat_ty, cont_ty, fail_ty] @@ -630,7 +630,7 @@ tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure tcPatSynBuilderOcc ps | Just (builder_id, add_void_arg) <- builder - , let builder_expr = HsConLikeOut (PatSynCon ps) + , let builder_expr = HsConLikeOut noExt (PatSynCon ps) builder_ty = idType builder_id = return $ if add_void_arg @@ -669,14 +669,14 @@ tcPatToExpr name args pat = go pat -> Either MsgDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; return (foldl (\x y -> HsApp (L loc x) y) - (HsVar lcon) exprs) } + ; return (foldl (\x y -> HsApp noExt (L loc x) y) + (HsVar noExt lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) -> Either MsgDoc (HsExpr GhcRn) mkRecordConExpr con fields = do { exprFields <- mapM go fields - ; return (RecordCon con PlaceHolder noPostTcExpr exprFields) } + ; return (RecordCon noExt con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p @@ -693,26 +693,28 @@ tcPatToExpr name args pat = go pat go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar (L l var) + = return $ HsVar noExt (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ pat) = fmap HsPar $ go pat + go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat go1 (PArrPat _ pats) = do { exprs <- mapM go pats - ; return $ ExplicitPArr PlaceHolder exprs } + ; return $ ExplicitPArr noExt exprs } go1 p@(ListPat _ pats _ty reb) | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList PlaceHolder Nothing exprs } + ; return $ ExplicitList noExt Nothing exprs } | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats - ; return $ ExplicitTuple + ; return $ ExplicitTuple noExt (map (noLoc . Present) exprs) box } go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) - ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder + ; return $ ExplicitSum noExt alt arity + (noLoc expr) } - go1 (LitPat _ lit) = return $ HsLit lit + go1 (LitPat _ lit) = return $ HsLit noExt lit go1 (NPat _ (L _ n) mb_neg _) - | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)] - | otherwise = return $ HsOverLit n + | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg + [noLoc (HsOverLit noExt n)] + | otherwise = return $ HsOverLit noExt n go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" go1 (SplicePat _ (HsSpliced _ (HsSplicedPat pat))) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index c403794e9e..6c04a6751b 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1678,7 +1678,7 @@ check_main dflags tcg_env explicit_mod_hdr ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar (L loc main_name))) + tcMonoExpr (L loc (HsVar noExt (L loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id] @@ -2124,7 +2124,8 @@ tcGhciStmts stmts -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; + (noLoc $ ExplicitList unitTy Nothing + (map mk_item ids)) ; mk_item id = let ty_args = [idType id, unitTy] in nlHsApp (nlHsTyApp unsafeCoerceId (map getRuntimeRep ty_args ++ ty_args)) @@ -2132,7 +2133,7 @@ tcGhciStmts stmts stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmtCtxt (noLoc stmts) io_ret_ty)) + noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts))) } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) @@ -2151,7 +2152,7 @@ getGhciStepIO = do stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) - return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy) + return (noLoc $ ExprWithTySig stepTy (nlHsVar ghciStepIoMName)) isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) isGHCiMonad hsc_env ty diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 08c8dab008..f2309c8b9e 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3380,58 +3380,57 @@ lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin -exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name -exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv) -exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" -exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) -exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l -exprCtOrigin (HsIPVar ip) = IPOccOrigin ip -exprCtOrigin (HsOverLit lit) = LiteralOrigin lit -exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" -exprCtOrigin (HsLam matches) = matchesCtOrigin matches -exprCtOrigin (HsLamCase ms) = matchesCtOrigin ms -exprCtOrigin (HsApp e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppType e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut" -exprCtOrigin (OpApp _ op _ _) = lexprCtOrigin op -exprCtOrigin (NegApp e _) = lexprCtOrigin e -exprCtOrigin (HsPar e) = lexprCtOrigin e -exprCtOrigin (SectionL _ _) = SectionOrigin -exprCtOrigin (SectionR _ _) = SectionOrigin -exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" -exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" -exprCtOrigin (HsCase _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) -exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" -exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ e) = lexprCtOrigin e -exprCtOrigin (HsDo _ _ _) = DoOrigin -exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" -exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array" -exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" -exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin -exprCtOrigin (ExprWithTySigOut {}) = panic "exprCtOrigin ExprWithTySigOut" -exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" -exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence" -exprCtOrigin (HsSCC _ _ e) = lexprCtOrigin e -exprCtOrigin (HsCoreAnn _ _ e) = lexprCtOrigin e -exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" +exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name +exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf (unboundVarOcc uv) +exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" +exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) +exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l +exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip +exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit +exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" +exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches +exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms +exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (HsAppType _ e1) = lexprCtOrigin e1 +exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op +exprCtOrigin (NegApp _ e _) = lexprCtOrigin e +exprCtOrigin (HsPar _ e) = lexprCtOrigin e +exprCtOrigin (SectionL _ _ _) = SectionOrigin +exprCtOrigin (SectionR _ _ _) = SectionOrigin +exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" +exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" +exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches +exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) +exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" +exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs +exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e +exprCtOrigin (HsDo {}) = DoOrigin +exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" +exprCtOrigin (ExplicitPArr {}) = Shouldn'tHappenOrigin "parallel array" +exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" +exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" +exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin +exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" +exprCtOrigin (PArrSeq {}) = Shouldn'tHappenOrigin "parallel array sequence" +exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" -exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" -exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" -exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp" -exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm" -exprCtOrigin (HsTick _ e) = lexprCtOrigin e -exprCtOrigin (HsBinTick _ _ e) = lexprCtOrigin e -exprCtOrigin (HsTickPragma _ _ _ e) = lexprCtOrigin e -exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat" +exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsArrApp {}) = panic "exprCtOrigin HsArrApp" +exprCtOrigin (HsArrForm {}) = panic "exprCtOrigin HsArrForm" +exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e +exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e +exprCtOrigin (EWildPat {}) = panic "exprCtOrigin EWildPat" exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" +exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 45e18e69fe..195af1a8db 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -182,7 +182,7 @@ tcTypedBracket rn_expr brack@(TExpBr expr) res_ty ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") rn_expr (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) - (noLoc (HsTcBracketOut brack ps')))) + (noLoc (HsTcBracketOut noExt brack ps')))) meta_ty res_ty } tcTypedBracket _ other_brack _ = pprPanic "tcTypedBracket" (ppr other_brack) @@ -194,7 +194,7 @@ tcUntypedBracket rn_expr brack ps res_ty ; meta_ty <- tcBrackTy brack ; traceTc "tc_bracket done untyped" (ppr meta_ty) ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket") - rn_expr (HsTcBracketOut brack ps') meta_ty res_ty } + rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty } --------------- tcBrackTy :: HsBracket GhcRn -> TcM TcType @@ -582,8 +582,9 @@ runAnnotation target expr = do ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] ; let specialised_to_annotation_wrapper_expr = L loc (mkHsWrap wrapper - (HsVar (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) } + (HsVar noExt (L loc to_annotation_wrapper_id))) + ; return (L loc (HsApp noExt + specialised_to_annotation_wrapper_expr expr')) } -- Run the appropriately wrapped expression to get the value of -- the annotation and its dictionaries. The return value is of diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 207943a18f..710c0552c6 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -882,7 +882,7 @@ mkOneRecordSelector all_cons idDetails fl | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) [L loc (mk_sel_pat con)] - (L loc (HsVar (L loc field_var))) + (L loc (HsVar noExt (L loc field_var))) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField @@ -900,9 +900,9 @@ mkOneRecordSelector all_cons idDetails fl deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt [L loc (WildPat placeHolderType)] - (mkHsApp (L loc (HsVar + (mkHsApp (L loc (HsVar noExt (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit msg_lit)))] + (L loc (HsLit noExt msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 01c8505562..0fccffa229 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1514,7 +1514,7 @@ defineMacro overwrite s = do body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) `mkHsApp` (nlHsPar expr) tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) - new_expr = L (getLoc expr) $ ExprWithTySig body tySig + new_expr = L (getLoc expr) $ ExprWithTySig tySig body hv <- GHC.compileParsedExprRemote new_expr let newCmd = Command { cmdName = macro_name @@ -1578,7 +1578,7 @@ getGhciStepIO = do ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar (getRdrName ghciStepIoMName) tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM) - return $ noLoc $ ExprWithTySig body tySig + return $ noLoc $ ExprWithTySig tySig body ----------------------------------------------------------------------------- -- :check diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 4ecc078909..bd555916a2 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -321,11 +321,11 @@ processAllTypeCheckedModule tcm = do return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe where mid :: Maybe Id - mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i - | otherwise = Nothing + mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i + | otherwise = Nothing - unwrapVar (HsWrap _ var) = var - unwrapVar e' = e' + unwrapVar (HsWrap _ _ var) = var + unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs index 3a8a29abd4..149658a231 100644 --- a/testsuite/tests/ghc-api/annotations/parseTree.hs +++ b/testsuite/tests/ghc-api/annotations/parseTree.hs @@ -51,8 +51,10 @@ testOneFile libdir fileName = do gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)] - doLHsTupArg (L l arg@(Present _)) = [(l,"p",ExplicitTuple [L l arg] Boxed)] - doLHsTupArg (L l arg@(Missing _)) = [(l,"m",ExplicitTuple [L l arg] Boxed)] + doLHsTupArg (L l arg@(Present _)) + = [(l,"p",ExplicitTuple noExt [L l arg] Boxed)] + doLHsTupArg (L l arg@(Missing _)) + = [(l,"m",ExplicitTuple noExt [L l arg] Boxed)] showAnns anns = "[\n" ++ (intercalate "\n" diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs index b89911d6c7..4089d4a88a 100644 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ b/testsuite/tests/ghc-api/annotations/stringSource.hs @@ -80,9 +80,9 @@ testOneFile libdir fileName = do doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])] - doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] - doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] - doHsExpr (HsTickPragma src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])] + doHsExpr (HsCoreAnn _ src ss _) = [("co",[conv (noLoc ss)])] + doHsExpr (HsSCC _ src ss _) = [("sc",[conv (noLoc ss)])] + doHsExpr (HsTickPragma _ src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])] doHsExpr _ = [] conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs index 4b8119459b..40d23b5712 100644 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -67,7 +67,7 @@ testOneFile libdir fileName = do doRuleDecl (HsRule _ _ _ _ _ _ _) = [] doHsExpr :: HsExpr GhcPs -> [(String,[String])] - doHsExpr (HsTickPragma src (_,_,_) ss _) = [("tp",[show ss])] + doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])] doHsExpr _ = [] doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 79248ab30a..b80ab62507 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -249,13 +249,16 @@ [] ({ DumpParsedAst.hs:11:8-23 } (HsApp + (PlaceHolder) ({ DumpParsedAst.hs:11:8-15 } (HsVar + (PlaceHolder) ({ DumpParsedAst.hs:11:8-15 } (Unqual {OccName: putStrLn})))) ({ DumpParsedAst.hs:11:17-23 } (HsLit + (PlaceHolder) (HsString (SourceText "\"hello\"") diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index f0892c99b8..fbc30626fa 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -29,12 +29,15 @@ [] ({ DumpRenamedAst.hs:18:8-23 } (HsApp + (PlaceHolder) ({ DumpRenamedAst.hs:18:8-15 } (HsVar + (PlaceHolder) ({ DumpRenamedAst.hs:18:8-15 } {Name: System.IO.putStrLn}))) ({ DumpRenamedAst.hs:18:17-23 } (HsLit + (PlaceHolder) (HsString (SourceText "\"hello\"") diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index e0d810d4b4..b888067af1 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -7,47 +7,63 @@ {Var: DumpTypecheckedAst.$tcPeano} ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) {HsWord{64}Prim (14073232900889011755) (NoSourceText)})))) ({ <no location info> } (HsLit + (PlaceHolder) {HsWord{64}Prim (2739668351064589274) (NoSourceText)})))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$trModule}))))) ({ <no location info> } (HsPar + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) (HsStringPrim (NoSourceText) "Peano"))))))))) ({ <no location info> } (HsLit + (PlaceHolder) {HsInt{64}Prim (0) (SourceText "0")})))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: GHC.Types.krep$*}))))) (False))) @@ -56,47 +72,63 @@ {Var: DumpTypecheckedAst.$tc'Zero} ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) {HsWord{64}Prim (13760111476013868540) (NoSourceText)})))) ({ <no location info> } (HsLit + (PlaceHolder) {HsWord{64}Prim (12314848029315386153) (NoSourceText)})))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$trModule}))))) ({ <no location info> } (HsPar + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) (HsStringPrim (NoSourceText) "'Zero"))))))))) ({ <no location info> } (HsLit + (PlaceHolder) {HsInt{64}Prim (0) (SourceText "0")})))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: $krep}))))) (False))) @@ -105,47 +137,63 @@ {Var: DumpTypecheckedAst.$tc'Succ} ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) {HsWord{64}Prim (1143980031331647856) (NoSourceText)})))) ({ <no location info> } (HsLit + (PlaceHolder) {HsWord{64}Prim (14802086722010293686) (NoSourceText)})))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$trModule}))))) ({ <no location info> } (HsPar + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) (HsStringPrim (NoSourceText) "'Succ"))))))))) ({ <no location info> } (HsLit + (PlaceHolder) {HsInt{64}Prim (0) (SourceText "0")})))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: $krep}))))) (False))) @@ -154,17 +202,22 @@ {Var: $krep} ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: $krep}))))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: $krep}))))) (False))) @@ -173,22 +226,28 @@ {Var: $krep} ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsVar + (PlaceHolder) ({ <no location info> } {Var: DumpTypecheckedAst.$tcPeano}))))) ({ <no location info> } (HsWrap + (PlaceHolder) (WpTyApp (TyConApp ({abstract:TyCon}) [])) (HsConLikeOut + (PlaceHolder) ({abstract:ConLike})))))) (False))) ,({ <no location info> } @@ -196,32 +255,43 @@ {Var: DumpTypecheckedAst.$trModule} ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsPar + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) (HsStringPrim (NoSourceText) "main"))))))))) ({ <no location info> } (HsPar + (PlaceHolder) ({ <no location info> } (HsApp + (PlaceHolder) ({ <no location info> } (HsConLikeOut + (PlaceHolder) ({abstract:ConLike}))) ({ <no location info> } (HsLit + (PlaceHolder) (HsStringPrim (NoSourceText) "DumpTypecheckedAst"))))))))) @@ -258,12 +328,15 @@ [] ({ DumpTypecheckedAst.hs:11:8-23 } (HsApp + (PlaceHolder) ({ DumpTypecheckedAst.hs:11:8-15 } (HsVar + (PlaceHolder) ({ <no location info> } {Var: putStrLn}))) ({ DumpTypecheckedAst.hs:11:17-23 } (HsLit + (PlaceHolder) (HsString (SourceText "\"hello\"") diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index bb6f5c02f6..402d170b58 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -144,7 +144,7 @@ test('haddock.compiler', [extra_files(['../../../../compiler/stage2/haddock.t']), unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 65807004616, 10) + [(wordsize(64), 89414230688, 10) # 2012-08-14: 26070600504 (amd64/Linux) # 2012-08-29: 26353100288 (amd64/Linux, new CG) # 2012-09-18: 26882813032 (amd64/Linux) @@ -167,6 +167,7 @@ test('haddock.compiler', # 2017-06-06: 55990521024 (amd64/Linux) Don't pass on -dcore-lint in Haddock.mk # 2017-07-12: 51592019560 (amd64/Linux) Use getNameToInstancesIndex # 2017-11-07: 65807004616 (amd64/Linux) Trees that grow + # 2017-11-12: 89414230688 (amd64/Linux) Trees that grow HsExpr ,(platform('i386-unknown-mingw32'), 367546388, 10) # 2012-10-30: 13773051312 (x86/Windows) diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs index 40d5a90d78..9cf060937e 100644 --- a/testsuite/tests/quasiquotation/T7918.hs +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -29,7 +29,7 @@ traverse a = gmapM traverse a where showVar :: Maybe (HsExpr GhcTc) -> Traverse () - showVar (Just (HsVar (L _ v))) = + showVar (Just (HsVar _ (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showVar _ = return () diff --git a/utils/haddock b/utils/haddock -Subproject 73a26af844ac50b8bec39de11d64452a6286b00 +Subproject 9f054dc365379c66668de6719840918190ae6e4 |