diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2017-11-22 21:28:58 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2017-11-22 21:28:58 +0200 |
| commit | 468d7819ab0d7848c3c7910b40d0102efca43590 (patch) | |
| tree | 3592272ddbf0954e493907373faea59807e61352 | |
| parent | abdb5559b74af003a6d85f32695c034ff739f508 (diff) | |
| download | haskell-468d7819ab0d7848c3c7910b40d0102efca43590.tar.gz | |
Revert "Revert "trees that grow" work"
Continuing work on a long-running branch
This reverts commit 314bc31489f1f4cd69e913c3b1e33236b2bdf553.
71 files changed, 4398 insertions, 3070 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index d49a5c3ab8..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 @@ -723,25 +723,25 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit } translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec translatePat fam_insts pat = case pat of - WildPat ty -> mkPmVars [ty] - VarPat id -> return [PmVar (unLoc id)] - ParPat p -> translatePat fam_insts (unLoc p) - LazyPat _ -> mkPmVars [hsPatType pat] -- like a variable + WildPat ty -> mkPmVars [ty] + VarPat _ id -> return [PmVar (unLoc id)] + ParPat _ p -> translatePat fam_insts (unLoc p) + LazyPat _ _ -> mkPmVars [hsPatType pat] -- like a variable -- ignore strictness annotations for now - BangPat p -> translatePat fam_insts (unLoc p) + BangPat _ p -> translatePat fam_insts (unLoc p) - AsPat lid p -> do + AsPat _ lid p -> do -- Note [Translating As Patterns] ps <- translatePat fam_insts (unLoc p) let [e] = map vaToPmExpr (coercePatVec ps) g = PmGrd [PmVar (unLoc lid)] e return (ps ++ [g]) - SigPatOut p _ty -> translatePat fam_insts (unLoc p) + SigPat _ty p -> translatePat fam_insts (unLoc p) -- See Note [Translate CoPats] - CoPat wrapper p ty + CoPat _ wrapper p ty | isIdHsWrapper wrapper -> translatePat fam_insts p | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts p | otherwise -> do @@ -751,26 +751,26 @@ translatePat fam_insts pat = case pat of return [xp,g] -- (n + k) ===> x (True <- x >= k) (n <- x-k) - NPlusKPat (L _ _n) _k1 _k2 _ge _minus ty -> mkCanFailPmPat ty + NPlusKPat ty (L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty -- (fun -> pat) ===> x (pat <- fun x) - ViewPat lexpr lpat arg_ty -> do + ViewPat arg_ty lexpr lpat -> do ps <- translatePat fam_insts (unLoc lpat) -- See Note [Guards and Approximation] 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 -- list - ListPat ps ty Nothing -> do + ListPat _ ps ty Nothing -> do foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec fam_insts (map unLoc ps) -- overloaded list - ListPat lpats elem_ty (Just (pat_ty, _to_list)) + ListPat x lpats elem_ty (Just (pat_ty, _to_list)) | Just e_ty <- splitListTyConApp_maybe pat_ty , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty -- elem_ty is frequently something like @@ -779,7 +779,7 @@ translatePat fam_insts pat = case pat of -- We have to ensure that the element types are exactly the same. -- Otherwise, one may give an instance IsList [Int] (more specific than -- the default IsList [a]) with a different implementation for `toList' - translatePat fam_insts (ListPat lpats e_ty Nothing) + translatePat fam_insts (ListPat x lpats e_ty Nothing) -- See Note [Guards and Approximation] | otherwise -> mkCanFailPmPat pat_ty @@ -799,26 +799,27 @@ translatePat fam_insts pat = case pat of , pm_con_dicts = dicts , pm_con_args = args }] - NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty + NPat ty (L _ ol) mb_neg _eq -> translateNPat fam_insts ol mb_neg ty - LitPat lit + LitPat _ lit -- If it is a string then convert it to a list of characters | HsString src s <- lit -> foldr (mkListPatVec charTy) [nilPattern charTy] <$> - translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s)) + translatePatVec fam_insts + (map (LitPat noExt . HsChar src) (unpackFS s)) | otherwise -> return [mkLitPattern lit] - PArrPat ps ty -> do + PArrPat ty ps -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let fake_con = RealDataCon (parrFakeCon (length ps)) return [vanillaConPattern fake_con [ty] (concat tidy_ps)] - TuplePat ps boxity tys -> do + TuplePat tys ps boxity -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) return [vanillaConPattern tuple_con tys (concat tidy_ps)] - SumPat p alt arity ty -> do + SumPat ty p alt arity -> do tidy_p <- translatePat fam_insts (unLoc p) let sum_con = RealDataCon (sumDataCon alt arity) return [vanillaConPattern sum_con ty tidy_p] @@ -827,23 +828,23 @@ translatePat fam_insts pat = case pat of -- Not supposed to happen ConPatIn {} -> panic "Check.translatePat: ConPatIn" SplicePat {} -> panic "Check.translatePat: SplicePat" - SigPatIn {} -> panic "Check.translatePat: SigPatIn" + XPat {} -> panic "Check.translatePat: XPat" -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs) translateNPat :: FamInstEnvs -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> Type -> DsM PatVec -translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty +translateNPat fam_insts (OverLit (OverLitTc False ty) val _ ) mb_neg outer_ty | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg - = translatePat fam_insts (LitPat (HsString src s)) + = translatePat fam_insts (LitPat noExt (HsString src s)) | not type_change, isIntTy ty, HsIntegral i <- val = translatePat fam_insts - (LitPat $ case mb_neg of - Nothing -> HsInt def i - Just _ -> HsInt def (negateIntegralLit i)) + (LitPat noExt $ case mb_neg of + Nothing -> HsInt noExt i + Just _ -> HsInt noExt (negateIntegralLit i)) | not type_change, isWordTy ty, HsIntegral i <- val = translatePat fam_insts - (LitPat $ case mb_neg of + (LitPat noExt $ case mb_neg of Nothing -> HsWordPrim (il_text i) (il_value i) Just _ -> let ni = negateIntegralLit i in HsWordPrim (il_text ni) (il_value ni)) @@ -1216,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 862e564aed..5bdff0fe67 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,27 +627,23 @@ 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) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present e')) } +addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present x e')) } addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) +addTickTupArg (L _ (XTupArg _)) = panic "addTickTupArg" addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) @@ -762,8 +761,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 @@ -780,11 +779,12 @@ addTickApplicativeArg isGuard (op, arg) = addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) -addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = - liftM3 ParStmtBlock +addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = + liftM3 (ParStmtBlock x) (addTickLStmts isGuard stmts) (return ids) (addTickSyntaxExpr hpcSrcSpan returnExpr) +addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders" addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) addTickHsLocalBinds (HsValBinds binds) = @@ -795,15 +795,17 @@ addTickHsLocalBinds (HsIPBinds binds) = (addTickHsIPBinds binds) addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds -addTickHsValBinds :: HsValBindsLR GhcTc a -> TM (HsValBindsLR GhcTc b) -addTickHsValBinds (ValBindsOut binds sigs) = - liftM2 ValBindsOut +addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) + -> TM (HsValBindsLR GhcTc (GhcPass b)) +addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do + b <- liftM2 NValBinds (mapM (\ (rec,binds') -> liftM2 (,) (return rec) (addTickLHsBinds binds')) binds) (return sigs) + return $ XValBindsLR b addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) @@ -828,12 +830,11 @@ addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) -addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = - liftM4 HsCmdTop +addTickHsCmdTop (HsCmdTop x cmd) = + liftM2 HsCmdTop + (return x) (addTickLHsCmd cmd) - (return tys) - (return ty) - (return syntaxtable) +addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop" addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) addTickLHsCmd (L pos c0) = do @@ -841,10 +842,10 @@ addTickLHsCmd (L pos c0) = do return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam matchgroup) = - liftM HsCmdLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp c e) = - liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e) +addTickHsCmd (HsCmdLam x matchgroup) = + liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp x c e) = + liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) {- addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp @@ -853,41 +854,43 @@ addTickHsCmd (OpApp e1 c2 fix c3) = (return fix) (addTickLHsCmd c3) -} -addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e) -addTickHsCmd (HsCmdCase e mgs) = - liftM2 HsCmdCase +addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e) +addTickHsCmd (HsCmdCase x e mgs) = + liftM2 (HsCmdCase x) (addTickLHsExpr e) (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdIf cnd e1 c2 c3) = - liftM3 (HsCmdIf cnd) +addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = + liftM3 (HsCmdIf x cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet (L l binds) c) = +addTickHsCmd (HsCmdLet x (L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet . L l) + liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsCmdDo (L l stmts) srcloc) +addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo (L l stmts') srcloc) } + ; return (HsCmdDo srcloc (L l stmts')) } -addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = +addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = liftM5 HsCmdArrApp + (return arr_ty) (addTickLHsExpr e1) (addTickLHsExpr e2) (return ty1) - (return arr_ty) (return lr) -addTickHsCmd (HsCmdArrForm e f fix cmdtop) = - liftM4 HsCmdArrForm +addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = + liftM4 (HsCmdArrForm x) (addTickLHsExpr e) (return f) (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -addTickHsCmd (HsCmdWrap w cmd) - = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd) +addTickHsCmd (HsCmdWrap x w cmd) + = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) + +addTickHsCmd e@(XCmd {}) = pprPanic "addTickHsCmd" (ppr e) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) @@ -1167,7 +1170,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) @@ -1253,13 +1256,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 24d7d8a61c..61dc7c5b5b 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -313,7 +313,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd @@ -328,6 +328,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) +dsProcExpr _ (L _ XCmdTop{}) = panic "dsProcExpr" {- Translation of a command judgement of the form @@ -363,7 +364,7 @@ dsCmd :: DsCmdEnv -- arrow combinators -- ---> premap (\ ((xs), _stk) -> arg) fun dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) + (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -388,7 +389,7 @@ dsCmd ids local_vars stack_ty res_ty -- ---> premap (\ ((xs), _stk) -> (fun, arg)) app dsCmd ids local_vars stack_ty res_ty - (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) + (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -416,7 +417,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd -dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do core_arg <- dsLExpr arg let arg_ty = exprType core_arg @@ -449,7 +450,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd dsCmd ids local_vars stack_ty res_ty - (HsCmdLam (MG { mg_alts = L _ [L _ (Match { m_pats = pats + (HsCmdLam _ (MG { mg_alts = L _ [L _ (Match { m_pats = pats , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) @@ -479,7 +480,7 @@ dsCmd ids local_vars stack_ty res_ty return (do_premap ids in_ty in_ty' res_ty select_code core_body, free_vars `udfmMinusUFM` getUniqSet pat_vars) -dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids -- D, xs |- e :: Bool @@ -492,7 +493,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids -- if e then Left ((xs1),stk) else Right ((xs2),stk)) -- (c1 ||| c2) -dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) +dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) env_ids = do core_cond <- dsLExpr cond (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd @@ -553,8 +554,8 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys - , mg_origin = origin })) + (HsCmdCase _ exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys + , mg_origin = origin })) env_ids = do stack_id <- newSysLocalDs stack_ty @@ -575,10 +576,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 +600,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' @@ -613,7 +617,8 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) + env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -638,7 +643,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) + env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty (text "In the do-command:" <+> ppr do_block) @@ -658,14 +664,14 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) e -- ----------------------------------- -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do +dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionDVarSets fv_sets) -dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids core_wrap <- dsHsWrapper wrap return (core_wrap core_cmd, env_ids') @@ -682,7 +688,8 @@ dsTrimCmdArg -> LHsCmdTop GhcTc -- command argument to desugar -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free -dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do +dsTrimCmdArg local_vars env_ids + (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd stack_id <- newSysLocalDs stack_ty @@ -693,6 +700,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do arg_code = if env_ids' == env_ids then core_cmd else do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd return (mkLets meth_binds arg_code, free_vars) +dsTrimCmdArg _ _ (L _ XCmdTop{}) = panic "dsTrimCmdArg" -- Given D; xs |-a c : stk --> t, builds c with xs fed back. -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk)) @@ -1187,31 +1195,31 @@ collectl :: LPat GhcTc -> [Id] -> [Id] collectl (L _ pat) bndrs = go pat where - go (VarPat (L _ var)) = var : bndrs + go (VarPat _ (L _ var)) = var : bndrs go (WildPat _) = bndrs - go (LazyPat pat) = collectl pat bndrs - go (BangPat pat) = collectl pat bndrs - go (AsPat (L _ a) pat) = a : collectl pat bndrs - go (ParPat pat) = collectl pat bndrs + go (LazyPat _ pat) = collectl pat bndrs + go (BangPat _ pat) = collectl pat bndrs + go (AsPat _ (L _ a) pat) = a : collectl pat bndrs + go (ParPat _ pat) = collectl pat bndrs - go (ListPat pats _ _) = foldr collectl bndrs pats - go (PArrPat pats _) = foldr collectl bndrs pats - go (TuplePat pats _ _) = foldr collectl bndrs pats - go (SumPat pat _ _ _) = collectl pat bndrs + go (ListPat _ pats _ _) = foldr collectl bndrs pats + go (PArrPat _ pats) = foldr collectl bndrs pats + go (TuplePat _ pats _) = foldr collectl bndrs pats + go (SumPat _ pat _ _) = collectl pat bndrs go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps, pat_binds=ds}) = collectEvBinders ds ++ foldr collectl bndrs (hsConPatArgs ps) - go (LitPat _) = bndrs + go (LitPat _ _) = bndrs go (NPat {}) = bndrs - go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs + go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs - go (SigPatIn pat _) = collectl pat bndrs - go (SigPatOut pat _) = collectl pat bndrs - go (CoPat _ pat _) = collectl (noLoc pat) bndrs - go (ViewPat _ pat _) = collectl pat bndrs + go (SigPat _ pat) = collectl pat bndrs + go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs + go (ViewPat _ _ pat) = collectl pat bndrs go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) + go p@(XPat {}) = pprPanic "collectl/go" (ppr p) collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 635a9c6137..bba301c7ac 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -78,8 +78,9 @@ dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body ------------------------- -- caller sets location dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds -dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" +dsValBinds (XValBindsLR (NValBinds binds _)) body + = foldrM ds_val_bind body binds +dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" ------------------------- dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr @@ -249,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 @@ -269,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 @@ -278,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 @@ -338,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) @@ -361,31 +363,32 @@ 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. = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present expr)) + go (lam_vars, args) (L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr ; return (lam_vars, core_expr : args) } + go _ (L _ (XTupArg {})) = panic "ds_expr" ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args)) -- The reverse is because foldM goes left-to-right (\(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 @@ -396,31 +399,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 @@ -453,7 +456,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 @@ -535,8 +538,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') @@ -595,9 +599,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 @@ -661,7 +667,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 <.> @@ -713,16 +719,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') @@ -733,20 +739,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" @@ -754,7 +759,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" @@ -933,9 +937,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 @@ -967,15 +971,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 $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo - DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty + mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats + 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, @@ -1137,9 +1141,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/DsListComp.hs b/compiler/deSugar/DsListComp.hs index fea637fafe..860c1baa14 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -82,7 +82,7 @@ dsListComp lquals res_ty = do -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type) -dsInnerListComp (ParStmtBlock stmts bndrs _) +dsInnerListComp (ParStmtBlock _ stmts bndrs _) = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs list_ty = mkListTy bndrs_tuple_type @@ -90,6 +90,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _) ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) } +dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp" -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed @@ -105,7 +106,8 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr) + (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts + from_bndrs noSyntaxExpr) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments @@ -253,7 +255,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) quals list } where - bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs] + bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above pat = mkBigLHsPatTupId pats @@ -623,13 +625,15 @@ dePArrParComp qss quals = do deParStmt [] = -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" - deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement + deParStmt (ParStmtBlock _ qs xs _:qss) = do -- first statement let res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) parStmts qss (mkLHsVarPatTup xs) cqs + deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp" --- parStmts [] pa cea = return (pa, cea) - parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed) + parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do + -- subsequent statements (zip'ed) zipP <- dsDPHBuiltin zipPVar let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea @@ -638,6 +642,7 @@ dePArrParComp qss quals = do let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] parStmts qss pa' cea' + parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp" -- generate Core corresponding to `\p -> e' -- @@ -777,7 +782,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest ; mzip_op' <- dsExpr mzip_op ; let -- The pattern variables - pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ bs _ <- blocks] + pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] -- Pattern with tuples of variables -- [v1,v2,v3] => (v1, (v2, v3)) pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats @@ -788,9 +793,10 @@ dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest } where - ds_inner (ParStmtBlock stmts bndrs return_op) + ds_inner (ParStmtBlock _ stmts bndrs return_op) = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) } + ds_inner (XParStmtBlock{}) = panic "dsMcStmt" dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2a181e8d16..c910fbf15b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -77,13 +77,14 @@ dsBracket brack splices where new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] - do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } - do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } - do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" - do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" + do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket" {- -------------- Examples -------------------- @@ -198,8 +199,8 @@ hsSigTvBinders binds get_scoped_tvs _ = [] sigs = case binds of - ValBindsIn _ sigs -> sigs - ValBindsOut _ sigs -> sigs + ValBinds _ _ sigs -> sigs + XValBindsLR (NValBinds _ sigs) -> sigs {- Notes @@ -695,7 +696,7 @@ repBangTy ty = do rep2 bangTypeName [b, t] where (su', ss', ty') = case ty of - L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty) + L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty) _ -> (NoSrcUnpack, NoSrcStrict, ty) ------------------------------------------------------- @@ -917,18 +918,20 @@ addTyClTyVarBinds tvs m -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) -repTyVarBndrWithKind (L _ (UserTyVar _)) nm +repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm = repLTy ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind" -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) -repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm - ; ki' <- repLTy ki - ; repKindedTV nm' ki' } +repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm + ; repPlainTV nm' } +repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm + ; ki' <- repLTy ki + ; repKindedTV nm' ki' } +repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr" -- represent a type context -- @@ -1000,7 +1003,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty -repTy (HsTyVar _ (L _ n)) +repTy (HsTyVar _ _ (L _ n)) | isLiftedTypeKindTyConName n = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | isTvOcc occ = do tv1 <- lookupOcc n @@ -1013,47 +1016,47 @@ repTy (HsTyVar _ (L _ n)) where occ = nameOccName n -repTy (HsAppTy f a) = do +repTy (HsAppTy _ f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsFunTy f a) = do +repTy (HsFunTy _ f a) = do f1 <- repLTy f a1 <- repLTy a tcon <- repArrowTyCon repTapps tcon [f1, a1] -repTy (HsListTy t) = do +repTy (HsListTy _ t) = do t1 <- repLTy t tcon <- repListTyCon repTapp tcon t1 -repTy (HsPArrTy t) = do +repTy (HsPArrTy _ t) = do t1 <- repLTy t - tcon <- repTy (HsTyVar NotPromoted + tcon <- repTy (HsTyVar noExt NotPromoted (noLoc (tyConName parrTyCon))) repTapp tcon t1 -repTy (HsTupleTy HsUnboxedTuple tys) = do +repTy (HsTupleTy _ HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys +repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsSumTy tys) = do tys1 <- repLTys tys +repTy (HsSumTy _ tys) = do tys1 <- repLTys tys tcon <- repUnboxedSumTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) +repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) -repTy (HsParTy t) = repLTy t -repTy (HsEqTy t1 t2) = do +repTy (HsParTy _ t) = repLTy t +repTy (HsEqTy _ t1 t2) = do t1' <- repLTy t1 t2' <- repLTy t2 eq <- repTequality repTapps eq [t1', t2'] -repTy (HsKindSig t k) = do +repTy (HsKindSig _ t k) = do t1 <- repLTy t k1 <- repLTy k repTSig t1 k1 -repTy (HsSpliceTy splice _) = repSplice splice +repTy (HsSpliceTy _ splice) = repSplice splice repTy (HsExplicitListTy _ _ tys) = do tys1 <- repLTys tys repTPromotedList tys1 @@ -1061,9 +1064,9 @@ repTy (HsExplicitTupleTy _ tys) = do tys1 <- repLTys tys tcon <- repPromotedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsTyLit lit) = do - lit' <- repTyLit lit - repTLit lit' +repTy (HsTyLit _ lit) = do + lit' <- repTyLit lit + repTLit lit' repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard repTy ty = notHandled "Exotic form of type" (ppr ty) @@ -1097,10 +1100,11 @@ repRole (L _ Nothing) = rep2 inferRName [] repSplice :: HsSplice GhcRn -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ n _) = rep_splice n -repSplice (HsUntypedSplice _ n _) = rep_splice n -repSplice (HsQuasiQuote n _ _ _) = rep_splice n -repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e) +repSplice (HsTypedSplice _ _ n _) = rep_splice n +repSplice (HsUntypedSplice _ _ n _) = rep_splice n +repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n +repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) +repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e) rep_splice :: Name -> DsM (Core a) rep_splice splice_name @@ -1125,7 +1129,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 @@ -1133,45 +1137,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 @@ -1180,13 +1185,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); @@ -1202,13 +1207,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 } + | 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 } @@ -1221,7 +1226,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 } @@ -1243,9 +1248,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 @@ -1254,7 +1259,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) ----------------------------------------------------------------------------- @@ -1318,7 +1322,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld where rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of - Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name) + Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } _ -> notHandled "Ambiguous record updates" (ppr fld) @@ -1382,10 +1386,11 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) = where rep_stmt_block :: ParStmtBlock GhcRn GhcRn -> DsM ([GenSymBind], Core [TH.StmtQ]) - rep_stmt_block (ParStmtBlock stmts _ _) = + rep_stmt_block (ParStmtBlock _ stmts _ _) = do { (ss1, zs) <- repSts (map unLoc stmts) ; zs1 <- coreList stmtQTyConName zs ; return (ss1, zs1) } + rep_stmt_block (XParStmtBlock{}) = panic "repSts" repSts [LastStmt e _ _] = do { e2 <- repLE e ; z <- repNoBindSt e2 @@ -1420,12 +1425,12 @@ repBinds (HsValBinds decs) rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are already in the meta-env -rep_val_binds (ValBindsOut binds sigs) +rep_val_binds (XValBindsLR (NValBinds binds sigs)) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_val_binds (ValBindsIn _ _) - = panic "rep_val_binds: ValBindsIn" +rep_val_binds (ValBinds _ _ _) + = panic "rep_val_binds: ValBinds" rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds @@ -1611,19 +1616,23 @@ repLP :: LPat GhcRn -> DsM (Core TH.PatQ) repLP (L _ p) = repP p repP :: Pat GhcRn -> DsM (Core TH.PatQ) -repP (WildPat _) = repPwild -repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } -repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } -repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } -repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } -repP (ParPat p) = repLP p -repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p} -repP (TuplePat ps boxed _) +repP (WildPat _) = repPwild +repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' } +repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } +repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } +repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p + ; repPaspat x' p1 } +repP (ParPat _ p) = repLP p +repP (ListPat _ ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat x ps ty1 (Just (_,e))) = do { p <- repP (ListPat x ps ty1 Nothing) + ; e' <- repE (syn_expr e) + ; repPview e' p} +repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } -repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity } +repP (SumPat _ p alt arity) = do { p1 <- repLP p + ; repPunboxedSum p1 alt arity } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of @@ -1640,13 +1649,13 @@ repP (ConPatIn dc details) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } -repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } -repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } -repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) -repP (SigPatIn p t) = do { p' <- repLP p - ; t' <- repLTy (hsSigWcType t) - ; repPsig p' t' } -repP (SplicePat splice) = repSplice splice +repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } +repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) +repP (SigPat t p) = do { p' <- repLP p + ; t' <- repLTy (hsSigWcType t) + ; repPsig p' t' } +repP (SplicePat _ splice) = repSplice splice repP other = notHandled "Exotic pattern" (ppr other) @@ -2197,7 +2206,7 @@ repConstr (RecCon (L _ ips)) resTy cons rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) - rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n) + rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } @@ -2357,7 +2366,7 @@ mk_integer i = do integer_ty <- lookupType integerTyConName mk_rational :: FractionalLit -> DsM (HsLit GhcRn) mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat def r rat_ty + return $ HsRat noExt r rat_ty mk_string :: FastString -> DsM (HsLit GhcRn) mk_string s = return $ HsString noSourceText s @@ -2370,6 +2379,7 @@ repOverloadedLiteral (OverLit { ol_val = val}) -- The type Rational will be in the environment, because -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used +repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral" mk_lit :: OverLitVal -> DsM (HsLit GhcRn) mk_lit (HsIntegral i) = mk_integer (il_value i) diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 3748193a19..f4fe8de227 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -9,6 +9,8 @@ This module exports some utility functions of no great interest. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Utility functions for constructing Core syntax, principally for desugaring module DsUtils ( @@ -117,13 +119,13 @@ selectMatchVars :: [Pat GhcTc] -> DsM [Id] selectMatchVars ps = mapM selectMatchVar ps selectMatchVar :: Pat GhcTc -> DsM Id -selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) -selectMatchVar (VarPat var) = return (localiseId (unLoc var)) +selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) +selectMatchVar (VarPat _ var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -selectMatchVar (AsPat var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) +selectMatchVar (AsPat _ var _) = return (unLoc var) +selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) -- OK, better make up one... {- @@ -736,7 +738,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -- and all the desugared binds mkSelectorBinds ticks pat val_expr - | L _ (VarPat (L _ v)) <- pat' -- Special case (A) + | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) @@ -783,17 +785,17 @@ mkSelectorBinds ticks pat val_expr strip_bangs :: LPat a -> LPat a -- Remove outermost bangs and parens -strip_bangs (L _ (ParPat p)) = strip_bangs p -strip_bangs (L _ (BangPat p)) = strip_bangs p -strip_bangs lp = lp +strip_bangs (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp is_flat_prod_lpat :: LPat a -> Bool is_flat_prod_lpat p = is_flat_prod_pat (unLoc p) is_flat_prod_pat :: Pat a -> Bool -is_flat_prod_pat (ParPat p) = is_flat_prod_lpat p -is_flat_prod_pat (TuplePat ps Boxed _) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) +is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p +is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps +is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) @@ -803,10 +805,10 @@ is_triv_lpat :: LPat a -> Bool is_triv_lpat p = is_triv_pat (unLoc p) is_triv_pat :: Pat a -> Bool -is_triv_pat (VarPat _) = True -is_triv_pat (WildPat _) = True -is_triv_pat (ParPat p) = is_triv_lpat p -is_triv_pat _ = False +is_triv_pat (VarPat {}) = True +is_triv_pat (WildPat{}) = True +is_triv_pat (ParPat _ p) = is_triv_lpat p +is_triv_pat _ = False {- ********************************************************************* @@ -828,7 +830,7 @@ mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs) mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc -- A vanilla tuple pattern simply gets its type from its sub-patterns -mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats) +mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box -- The Big equivalents for the source tuple expressions mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc @@ -983,8 +985,8 @@ mkBinaryTickBox ixT ixF e = do -- pat => !pat -- when -XStrict -- pat => pat -- otherwise decideBangHood :: DynFlags - -> LPat id -- ^ Original pattern - -> LPat id -- Pattern with bang if necessary + -> LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- Pattern with bang if necessary decideBangHood dflags lpat | not (xopt LangExt.Strict dflags) = lpat @@ -993,19 +995,20 @@ decideBangHood dflags lpat where go lp@(L l p) = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> lp' - BangPat _ -> lp - _ -> L l (BangPat lp) + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> lp' + BangPat _ _ -> lp + _ -> L l (BangPat noExt lp) -- | Unconditionally make a 'Pat' strict. -addBang :: LPat id -- ^ Original pattern - -> LPat id -- ^ Banged pattern +addBang :: LPat GhcTc -- ^ Original pattern + -> LPat GhcTc -- ^ Banged pattern addBang = go where go lp@(L l p) = case p of - ParPat p -> L l (ParPat (go p)) - LazyPat lp' -> L l (BangPat lp') - BangPat _ -> lp - _ -> L l (BangPat lp) + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> L l (BangPat noExt lp') + -- Should we bring the extension value over? + BangPat _ _ -> lp + _ -> L l (BangPat noExt lp) diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 7a3ee6853c..4cb8bf35ba 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -251,7 +251,7 @@ matchBangs [] _ _ = panic "matchBangs" matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) - = do { let CoPat co pat _ = firstPat eqn1 + = do { let CoPat _ co pat _ = firstPat eqn1 ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' ; match_result <- match (var':vars) ty $ @@ -267,7 +267,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 + let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' @@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) -- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView - = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 + = do { let ListPat _ _ elt_ty (Just (_,e)) = firstPat eqn1 ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern @@ -299,13 +299,13 @@ decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) decomposeFirstPat _ _ = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc -getCoPat (CoPat _ pat _) = pat +getCoPat (CoPat _ _ pat _) = pat getCoPat _ = panic "getCoPat" -getBangPat (BangPat pat ) = unLoc pat +getBangPat (BangPat _ pat ) = unLoc pat getBangPat _ = panic "getBangPat" -getViewPat (ViewPat _ pat _) = unLoc pat +getViewPat (ViewPat _ _ pat) = unLoc pat getViewPat _ = panic "getViewPat" -getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing +getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing getOLPat _ = panic "getOLPat" {- @@ -398,19 +398,19 @@ tidy1 :: Id -- The Id being scrutinised -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v (ParPat pat) = tidy1 v (unLoc pat) -tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) -tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p +tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat) +tidy1 v (SigPat _ pat) = tidy1 v (unLoc pat) +tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) +tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat (L _ var)) +tidy1 v (VarPat _ (L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v (AsPat (L _ var) pat) +tidy1 v (AsPat _ (L _ var) pat) = do { (wrap, pat') <- tidy1 v (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -425,7 +425,7 @@ tidy1 v (AsPat (L _ var) pat) The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v (LazyPat pat) +tidy1 v (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. @@ -441,7 +441,7 @@ tidy1 v (LazyPat pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat pats ty Nothing) +tidy1 _ (ListPat _ pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) @@ -450,29 +450,29 @@ tidy1 _ (ListPat pats ty Nothing) -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -tidy1 _ (PArrPat pats ty) +tidy1 _ (PArrPat ty pats) = return (idDsWrapper, unLoc parrConPat) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] -tidy1 _ (TuplePat pats boxity tys) +tidy1 _ (TuplePat tys pats boxity) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys -tidy1 _ (SumPat pat alt arity tys) +tidy1 _ (SumPat tys pat alt arity) = return (idDsWrapper, unLoc sum_ConPat) where sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (LitPat lit) +tidy1 _ (LitPat _ lit) = return (idDsWrapper, tidyLitPat lit) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ (NPat (L _ lit) mb_neg eq ty) +tidy1 _ (NPat ty (L _ lit) mb_neg eq) = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty) -- Everything else goes through unchanged... @@ -484,13 +484,14 @@ tidy1 _ non_interesting_pat tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p -tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p +tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p +tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) -tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) +tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p))) +tidy_bang_pat v l (CoPat x w p t) + = tidy1 v (CoPat x w (BangPat noExt (L l p)) t) -- Discard bang around strict pattern tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p @@ -526,7 +527,7 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) +tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -537,15 +538,16 @@ push_bang_into_newtype_arg :: SrcSpan -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args) - PrefixCon [L l (BangPat arg)] + PrefixCon [L l (BangPat noExt arg)] push_bang_into_newtype_arg l _ty (RecCon rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) - RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] }) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + = L l (BangPat noExt arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [L l (BangPat (noLoc (WildPat ty)))] + = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -975,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', @@ -994,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 @@ -1029,8 +1031,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 wrap res_wrap1 res_wrap2 --------- - tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2 - tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 + tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- @@ -1071,7 +1073,7 @@ patGroup _ (ConPatOut { pat_con = L _ con | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = +patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) = case (oval, isJust mb_neg) of (HsIntegral i, False) -> PgN (fromInteger (il_value i)) (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) @@ -1079,14 +1081,15 @@ patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) = (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) PgOverS s -patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) = +patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) -patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern -patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) -patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList -patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit) +patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p) + -- Type of innelexp pattern +patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat _ _ _ (Just _)) = PgOverloadedList +patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit) patGroup _ pat = pprPanic "patGroup" (ppr pat) {- diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 355927deef..c7bff64ff3 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -102,6 +102,8 @@ dsLit (HsRat _ (FL _ _ val) ty) = do (head (tyConDataCons tycon), i_ty) x -> pprPanic "dsLit" (ppr x) +dsLit (XLit x) = pprPanic "dsLit" (ppr x) + dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr dsOverLit lit = do { dflags <- getDynFlags ; warnAboutOverflowedLiterals dflags lit @@ -110,12 +112,12 @@ dsOverLit lit = do { dflags <- getDynFlags dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr -- Post-typechecker, the HsExpr field of an OverLit contains -- (an expression for) the literal value itself -dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable - , ol_witness = witness, ol_type = ty }) +dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty + , ol_witness = witness }) | not rebindable , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] | otherwise = dsExpr witness - +dsOverLit' _ XOverLit{} = panic "dsOverLit'" {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -239,14 +241,14 @@ 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) -getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) | Just tc <- tyConAppTyCon_maybe ty = Just (il_value i, tyConName tc) getIntegralLit _ = Nothing @@ -273,7 +275,7 @@ tidyLitPat (HsString src s) (mkNilPat charTy) (unpackFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! -tidyLitPat lit = LitPat lit +tidyLitPat lit = LitPat noExt lit ---------------- tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat @@ -284,7 +286,7 @@ tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc -> Type -> Pat GhcTc -tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty +tidyNPat tidy_lit_pat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty -- False: Take short cuts only if the literal is not using rebindable syntax -- -- Once that is settled, look for cases where the type of the @@ -313,7 +315,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty type_change = not (outer_ty `eqType` ty) mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc - mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] []) + mk_con_pat con lit + = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] []) mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of @@ -327,7 +330,7 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty _ -> Nothing tidyNPat _ over_lit mb_neg eq outer_ty - = NPat (noLoc over_lit) mb_neg eq outer_ty + = NPat outer_ty (noLoc over_lit) mb_neg eq {- ************************************************************************ @@ -361,7 +364,7 @@ matchLiterals (var:vars) ty sub_groups match_group :: [EquationInfo] -> DsM (Literal, MatchResult) match_group eqns = do dflags <- getDynFlags - let LitPat hs_lit = firstPat (head eqns) + let LitPat _ hs_lit = firstPat (head eqns) match_result <- match vars ty (shiftEqns eqns) return (hsLitKey dflags hs_lit, match_result) @@ -409,7 +412,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l) matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1 + = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -440,7 +443,7 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1 + = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] @@ -452,7 +455,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns) adjustMatchResult (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats }) + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index aa1bc814c5..f008a31d4b 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 ] + 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 4336243e91..f20abab5b9 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -8,6 +8,7 @@ This module converts Template Haskell syntax into HsSyn {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, @@ -213,7 +214,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = PlaceHolder + , tcdDataCusk = placeHolder , tcdFVs = placeHolderNames }) } cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) @@ -229,7 +230,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = PlaceHolder + , tcdDataCusk = placeHolder , tcdFVs = placeHolderNames }) } cvtDec (ClassD ctxt cl tvs fds decs) @@ -541,7 +542,8 @@ cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') + ; let rec_ty = noLoc (HsFunTy noExt + (noLoc $ HsRecTy noExt rec_flds) ty') ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness @@ -560,7 +562,7 @@ cvt_arg (Bang su ss, ty) ; ty' <- wrap_apps ty'' ; let su' = cvtSrcUnpackedness su ; let ss' = cvtSrcStrictness ss - ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } + ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' } cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) @@ -568,7 +570,7 @@ cvt_id_arg (i, str, ty) ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_names - = [L li $ FieldOcc (L li i') PlaceHolder] + = [L li $ FieldOcc noExt (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -753,7 +755,7 @@ cvtLocalDecs doc ds ; let (binds, prob_sigs) = partitionWith is_bind ds' ; let (sigs, bads) = partitionWith is_sig prob_sigs ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } + ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) } cvtClause :: HsMatchContext RdrName -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -772,77 +774,89 @@ 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 noExt)) es') + Boxed } cvt (UnboxedTupE es) = do { es' <- mapM cvtl es - ; return $ ExplicitTuple - (map (noLoc . Present) es') Unboxed } + ; return $ ExplicitTuple noExt + (map (noLoc . (Present noExt)) 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] @@ -852,9 +866,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) } @@ -863,9 +877,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -956,7 +970,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 @@ -973,7 +987,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 @@ -988,8 +1002,9 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds ; returnL $ LetStmt (noLoc ds') } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType } - where - cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } + where + cvt_one ds = do { ds' <- cvtStmts ds + ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) } cvtMatch :: HsMatchContext RdrName -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -1015,13 +1030,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) - = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType} + = do { force i; return $ mkHsIntegral (mkIntegralLit i) } cvtOverLit (RationalL r) - = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType} + = do { force r; return $ mkHsFractional (mkFractionalLit r) } cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' - ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType + ; return $ mkHsIsString (quotedSourceText s) s' } cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" -- An Integer is like an (overloaded) '3' in a Haskell source program @@ -1052,9 +1067,9 @@ cvtLit :: Lit -> CvtM (HsLit GhcPs) cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } cvtLit (FloatPrimL f) - = do { force f; return $ HsFloatPrim def (mkFractionalLit f) } + = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) } cvtLit (DoublePrimL f) - = do { force f; return $ HsDoublePrim def (mkFractionalLit f) } + = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s } @@ -1083,40 +1098,46 @@ cvtp (TH.LitP l) ; return (mkNPat (noLoc l') Nothing) } -- Not right for negative patterns; -- need to think about that! - | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } -cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') } -cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] -cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] } -cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] } + | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' } +cvtp (TH.VarP s) = do { s' <- vName s + ; return $ Hs.VarPat noExt (noLoc s') } +cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExt p' } + -- Note [Dropping constructors] +cvtp (TupP ps) = do { ps' <- cvtPats ps + ; return $ TuplePat noExt ps' Boxed } +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps + ; return $ TuplePat noExt ps' Unboxed } cvtp (UnboxedSumP p alt arity) = do { p' <- cvtPat p ; unboxedSumChecks alt arity - ; return $ SumPat p' alt arity placeHolderType } + ; return $ SumPat noExt p' alt arity } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps ; pps <- mapM wrap_conpat ps' ; return $ ConPatIn s' (PrefixCon pps) } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParL ParPat $ + ; wrapParL (ParPat noExt) $ ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) } -- See Note [Operator association] cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] cvtp (ParensP p) = do { p' <- cvtPat p; ; case p' of -- may be wrapped ConPatIn (L _ (ParPat {})) -> return $ unLoc p' - _ -> return $ ParPat p' } -cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } -cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } -cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } -cvtp TH.WildP = return $ WildPat placeHolderType + _ -> return $ ParPat noExt p' } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p + ; return $ AsPat noExt s' p' } +cvtp TH.WildP = return $ WildPat noExt cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps - ; return $ ListPat ps' placeHolderType Nothing } + ; return + $ ListPat noExt ps' placeHolderType Nothing } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPatIn p' (mkLHsSigWcType t') } + ; return $ SigPat (mkLHsSigWcType t') p' } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p - ; return $ ViewPat e' p' placeHolderType } + ; return $ ViewPat noExt e' p'} cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) @@ -1127,9 +1148,9 @@ cvtPatFld (s,p) , hsRecPun = False}) } wrap_conpat :: Hs.LPat GhcPs -> CvtM (Hs.LPat GhcPs) -wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p +wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat noExt p wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p -wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p +wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat noExt p wrap_conpat p = return p {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. @@ -1155,11 +1176,11 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) cvt_tv (TH.PlainTV nm) = do { nm' <- tNameL nm - ; returnL $ UserTyVar nm' } + ; returnL $ UserTyVar noExt nm' } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tNameL nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' ki' } + ; returnL $ KindedTyVar noExt nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1196,17 +1217,18 @@ cvtTypeKind ty_str ty | tys' `lengthIs` n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) - else returnL (HsTupleTy HsBoxedOrConstraintTuple tys') + else returnL (HsTupleTy noExt + HsBoxedOrConstraintTuple tys') | n == 1 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise - -> mk_apps (HsTyVar NotPromoted + -> mk_apps (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | tys' `lengthIs` n -- Saturated - -> returnL (HsTupleTy HsUnboxedTuple tys') + -> returnL (HsTupleTy noExt HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar NotPromoted + -> mk_apps (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2 @@ -1215,28 +1237,31 @@ cvtTypeKind ty_str ty , nest 2 $ text "Sums must have an arity of at least 2" ] | tys' `lengthIs` n -- Saturated - -> returnL (HsSumTy tys') + -> returnL (HsSumTy noExt tys') | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) + -> mk_apps (HsTyVar noExt NotPromoted + (noLoc (getRdrName (sumTyCon n)))) tys' ArrowT | [x',y'] <- tys' -> do case x' of - (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x') - ; returnL (HsFunTy x'' y') } - _ -> returnL (HsFunTy x' y') + (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy noExt x') + ; returnL (HsFunTy noExt x'' y') } + _ -> returnL (HsFunTy noExt x' y') | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon))) + mk_apps (HsTyVar noExt NotPromoted + (noLoc (getRdrName funTyCon))) tys' ListT - | [x'] <- tys' -> returnL (HsListTy x') + | [x'] <- tys' -> returnL (HsListTy noExt x') | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon))) + mk_apps (HsTyVar noExt NotPromoted + (noLoc (getRdrName listTyCon))) tys' VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar NotPromoted nm') tys' } + ; mk_apps (HsTyVar noExt NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } + ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'} ForallT tvs cxt ty | null tys' @@ -1252,11 +1277,11 @@ cvtTypeKind ty_str ty SigT ty ki -> do { ty' <- cvtType ty ; ki' <- cvtKind ki - ; mk_apps (HsKindSig ty' ki') tys' + ; mk_apps (HsKindSig noExt ty' ki') tys' } LitT lit - -> returnL (HsTyLit (cvtTyLit lit)) + -> returnL (HsTyLit noExt (cvtTyLit lit)) WildCardT -> mk_apps mkAnonWildCardTy tys' @@ -1265,7 +1290,7 @@ cvtTypeKind ty_str ty -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2'] + ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2'] } UInfixT t1 s t2 @@ -1277,46 +1302,46 @@ cvtTypeKind ty_str ty ParensT t -> do { t' <- cvtType t - ; returnL $ HsParTy t' + ; returnL $ HsParTy noExt t' } PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } + ; mk_apps (HsTyVar noExt NotPromoted + (noLoc nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n | n == 1 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) | m == n -- Saturated - -> do { let kis = replicate m placeHolderKind - ; returnL (HsExplicitTupleTy kis tys') - } + -> returnL (HsExplicitTupleTy noExt tys') where m = length tys' PromotedNilT - -> returnL (HsExplicitListTy Promoted placeHolderKind []) + -> returnL (HsExplicitListTy noExt Promoted []) PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax - | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys' - -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2)) + | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys' + -> returnL (HsExplicitListTy noExt ip (ty1:tys2)) | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon))) + -> mk_apps (HsTyVar noExt NotPromoted + (noLoc (getRdrName consDataCon))) tys' StarT - -> returnL (HsTyVar NotPromoted (noLoc + -> returnL (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) ConstraintT - -> returnL (HsTyVar NotPromoted + -> returnL (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon))) EqualityT - | [x',y'] <- tys' -> returnL (HsEqTy x' y') + | [x',y'] <- tys' -> returnL (HsEqTy noExt x' y') | otherwise -> - mk_apps (HsTyVar NotPromoted + mk_apps (HsTyVar noExt NotPromoted (noLoc (getRdrName eqPrimTyCon))) tys' _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) @@ -1328,15 +1353,15 @@ mk_apps head_ty [] = returnL head_ty mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty ; p_ty <- add_parens ty - ; mk_apps (HsAppTy head_ty' p_ty) tys } + ; mk_apps (HsAppTy noExt head_ty' p_ty) tys } where -- See Note [Adding parens for splices] add_parens t - | isCompoundHsType t = returnL (HsParTy t) + | isCompoundHsType t = returnL (HsParTy noExt t) | otherwise = return t wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) -wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t) +wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy noExt t) wrap_apps t = return t -- --------------------------------------------------------------------- @@ -1367,7 +1392,7 @@ mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) go arg ret_ty = do { ret_ty_l <- returnL ret_ty - ; return (HsFunTy arg ret_ty_l) } + ; return (HsFunTy noExt arg ret_ty_l) } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs]) split_ty_app ty = go ty [] @@ -1385,17 +1410,17 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) cvtOpAppT :: LHsType GhcPs -> RdrName -> LHsType GhcPs -> LHsType GhcPs cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) = L (combineSrcSpans loc1 loc2) $ - HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') + HsAppsTy noExt (t1' ++ [noLoc $ HsAppInfix noExt (noLoc op)] ++ t2') where - t1' | L _ (HsAppsTy t1s) <- t1 + t1' | L _ (HsAppsTy _ t1s) <- t1 = t1s | otherwise - = [noLoc $ HsAppPrefix t1] + = [noLoc $ HsAppPrefix noExt t1] - t2' | L _ (HsAppsTy t2s) <- t2 + t2' | L _ (HsAppsTy _ t2s) <- t2 = t2s | otherwise - = [noLoc $ HsAppPrefix t2] + = [noLoc $ HsAppPrefix noExt t2] cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" @@ -1435,13 +1460,16 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty) ; return $ L l (HsQualTy { hst_ctxt = L l [] + , hst_xqual = noExt , hst_body = ty' }) } | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) ; let forTy = HsForAllTy { hst_bndrs = univs' + , hst_xforall = noExt , hst_body = L l cxtTy } cxtTy = HsQualTy { hst_ctxt = L l [] + , hst_xqual = noExt , hst_body = ty' } ; return $ L l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) @@ -1491,15 +1519,16 @@ mkHsForAllTy :: [TH.TyVarBndr] -> SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall - -> LHsQTyVars name + -> LHsQTyVars GhcPs -- ^ The converted type variable binders - -> LHsType name + -> LHsType GhcPs -- ^ The converted rho type - -> LHsType name + -> LHsType GhcPs -- ^ The complete type, quantified with a forall if necessary mkHsForAllTy tvs loc tvs' rho_ty | null tvs = rho_ty | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs' + , hst_xforall = noExt , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument @@ -1514,15 +1543,16 @@ mkHsQualTy :: TH.Cxt -> SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit context - -> LHsContext name + -> LHsContext GhcPs -- ^ The converted context - -> LHsType name + -> LHsType GhcPs -- ^ The converted tau type - -> LHsType name + -> LHsType GhcPs -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty - | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty } + | otherwise = L loc $ HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt' + , hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 0dc5dd08ba..10e1307367 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -14,6 +14,9 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} module HsBinds where @@ -24,6 +27,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) +import PlaceHolder import HsExtension import HsTypes import PprCore () @@ -88,7 +92,7 @@ data HsLocalBindsLR idL idR type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) -deriving instance (DataId idL, DataId idR) => Data (HsLocalBindsLR idL idR) +deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR) -- | Haskell Value Bindings type HsValBinds id = HsValBindsLR id id @@ -103,18 +107,34 @@ data HsValBindsLR idL idR -- Before renaming RHS; idR is always RdrName -- Not dependency analysed -- Recursive by default - ValBindsIn + ValBinds + (XValBinds idL idR) (LHsBindsLR idL idR) [LSig idR] -- | Value Bindings Out -- -- After renaming RHS; idR can be Name or Id Dependency analysed, -- later bindings in the list may depend on earlier ones. - | ValBindsOut - [(RecFlag, LHsBinds idL)] - [LSig GhcRn] -- AZ: how to do this? + | XValBindsLR + (XXValBindsLR idL idR) -deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR) +deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR) + +-- --------------------------------------------------------------------- +-- Deal with ValBindsOut + +-- TODO: make this the only type for ValBinds +data NHsValBindsLR idL + = NValBinds + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] +deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL) + +type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XXValBindsLR (GhcPass pL) (GhcPass pR) + = NHsValBindsLR (GhcPass pL) + +-- --------------------------------------------------------------------- -- | Located Haskell Binding type LHsBind id = LHsBindLR id id @@ -285,7 +305,7 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId idL, DataId idR) => Data (HsBindLR idL idR) +deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -325,7 +345,7 @@ data PatSynBind idL idR psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality } -deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR) +deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR) {- Note [AbsBinds] @@ -560,20 +580,20 @@ Specifically, it's just an error thunk -} -instance (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsLocalBindsLR idL idR) where +instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => Outputable (HsLocalBindsLR (GhcPass idL) (GhcPass idR)) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsValBindsLR idL idR) where - ppr (ValBindsIn binds sigs) +instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => Outputable (HsValBindsLR (GhcPass idL) (GhcPass idR)) where + ppr (ValBinds _ binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) - ppr (ValBindsOut sccs sigs) + ppr (XValBindsLR (NValBinds sccs sigs)) = getPprStyle $ \ sty -> if debugStyle sty then -- Print with sccs showing vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) @@ -584,17 +604,19 @@ instance (SourceTextX idL, SourceTextX idR, pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => LHsBindsLR idL idR -> SDoc +pprLHsBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) -pprLHsBindsForUser :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR, - SourceTextX id2, OutputableBndrId id2) - => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] +pprLHsBindsForUser :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + SourceTextX (GhcPass id2), + OutputableBndrId (GhcPass id2)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups -- and we don't want several groups of bindings each @@ -626,7 +648,7 @@ pprDeclList ds = pprDeeperList vcat ds emptyLocalBinds :: HsLocalBindsLR a b emptyLocalBinds = EmptyLocalBinds -isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool +isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds isEmptyLocalBinds EmptyLocalBinds = True @@ -635,13 +657,13 @@ eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool eqEmptyLocalBinds EmptyLocalBinds = True eqEmptyLocalBinds _ = False -isEmptyValBinds :: HsValBindsLR a b -> Bool -isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs -isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs +isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs -emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b -emptyValBindsIn = ValBindsIn emptyBag [] -emptyValBindsOut = ValBindsOut [] [] +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) +emptyValBindsIn = ValBinds noExt emptyBag [] +emptyValBindsOut = XValBindsLR (NValBinds [] []) emptyLHsBinds :: LHsBindsLR idL idR emptyLHsBinds = emptyBag @@ -650,22 +672,24 @@ isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool isEmptyLHsBinds = isEmptyBag ------------ -plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a -plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) - = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) -plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) - = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2) +plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) + -> HsValBinds(GhcPass a) +plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) + = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) + (XValBindsLR (NValBinds ds2 sigs2)) + = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) plusHsValBinds _ _ = panic "HsBinds.plusHsValBinds" -instance (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsBindLR idL idR) where +instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => Outputable (HsBindLR (GhcPass idL) (GhcPass idR)) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => HsBindLR idL idR -> SDoc +ppr_monobind :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss @@ -705,9 +729,9 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] -instance (SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (PatSynBind idL idR) where +instance (SourceTextX (GhcPass idR), + OutputableBndrId idL, OutputableBndrId (GhcPass idR)) + => Outputable (PatSynBind idL (GhcPass idR)) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) = ppr_lhs <+> ppr_rhs @@ -752,7 +776,7 @@ data HsIPBinds id [LIPBind id] TcEvBinds -- Only in typechecker output; binds -- uses of the implicit parameters -deriving instance (DataId id) => Data (HsIPBinds id) +deriving instance (DataIdLR id id) => Data (HsIPBinds id) isEmptyIPBinds :: HsIPBinds id -> Bool isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds @@ -776,13 +800,15 @@ type LIPBind id = Located (IPBind id) -- For details on above see note [Api annotations] in ApiAnnotation data IPBind id = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id) -deriving instance (DataId name) => Data (IPBind name) +deriving instance (DataIdLR id id) => Data (IPBind id) -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsIPBinds (GhcPass p)) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ whenPprDebug (ppr ds) -instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) ) + => Outputable (IPBind (GhcPass p)) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip @@ -948,7 +974,7 @@ data Sig pass (Located [Located (IdP pass)]) (Maybe (Located (IdP pass))) -deriving instance (DataId pass) => Data (Sig pass) +deriving instance (DataIdLR pass pass) => Data (Sig pass) -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) @@ -1055,11 +1081,12 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (Sig pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (Sig (GhcPass p)) where ppr sig = ppr_sig sig -ppr_sig :: (SourceTextX pass, OutputableBndrId pass ) => Sig pass -> SDoc +ppr_sig :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p) ) + => Sig (GhcPass p) -> SDoc ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) @@ -1241,4 +1268,4 @@ data HsPatSynDir id = Unidirectional | ImplicitBidirectional | ExplicitBidirectional (MatchGroup id (LHsExpr id)) -deriving instance (DataId id) => Data (HsPatSynDir id) +deriving instance (DataIdLR id id) => Data (HsPatSynDir id) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 55d43fd058..9e05a3d1c1 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -101,7 +101,7 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PlaceHolder(..) ) +import PlaceHolder ( PlaceHolder, placeHolder ) import HsExtension import NameSet @@ -149,7 +149,7 @@ data HsDecl id -- (Includes quasi-quotes) | DocD (DocDecl) -- ^ Documentation comment declaration | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration -deriving instance (DataId id) => Data (HsDecl id) +deriving instance (DataIdLR id id) => Data (HsDecl id) -- NB: all top-level fixity decls are contained EITHER @@ -195,9 +195,9 @@ data HsGroup id hs_docs :: [LDocDecl] } -deriving instance (DataId id) => Data (HsGroup id) +deriving instance (DataIdLR id id) => Data (HsGroup id) -emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a) emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } @@ -212,7 +212,8 @@ emptyGroup = HsGroup { hs_tyclds = [], hs_splcds = [], hs_docs = [] } -appendGroups :: HsGroup a -> HsGroup a -> HsGroup a +appendGroups :: HsGroup (GhcPass a) -> HsGroup (GhcPass a) + -> HsGroup (GhcPass a) appendGroups HsGroup { hs_valds = val_groups1, @@ -255,8 +256,8 @@ appendGroups hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsDecl (GhcPass p)) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def @@ -272,8 +273,8 @@ instance (SourceTextX pass, OutputableBndrId pass) ppr (DocD doc) = ppr doc ppr (RoleAnnotD ra) = ppr ra -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsGroup pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsGroup (GhcPass p)) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -315,10 +316,10 @@ data SpliceDecl id = SpliceDecl -- Top level splice (Located (HsSplice id)) SpliceExplicitFlag -deriving instance (DataId id) => Data (SpliceDecl id) +deriving instance (DataIdLR id id) => Data (SpliceDecl id) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (SpliceDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (SpliceDecl (GhcPass p)) where ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f {- @@ -538,7 +539,7 @@ data TyClDecl pass -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId id) => Data (TyClDecl id) +deriving instance (DataIdLR id id) => Data (TyClDecl id) -- Simple classifiers for TyClDecl @@ -633,17 +634,17 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) = hsTvbAllKinded tyvars && rhs_annotated rhs where rhs_annotated (L _ ty) = case ty of - HsParTy lty -> rhs_annotated lty - HsKindSig {} -> True - _ -> False + HsParTy _ lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (TyClDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (TyClDecl (GhcPass p)) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity @@ -674,8 +675,8 @@ instance (SourceTextX pass, OutputableBndrId pass) <+> pp_vanilla_decl_head lclas tyvars fixity (unLoc context) <+> pprFundeps (map unLoc fds) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (TyClGroup pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (TyClGroup (GhcPass p)) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -685,11 +686,11 @@ instance (SourceTextX pass, OutputableBndrId pass) ppr roles $$ ppr instds -pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass) - => Located (IdP pass) - -> LHsQTyVars pass +pp_vanilla_decl_head :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Located (IdP (GhcPass p)) + -> LHsQTyVars (GhcPass p) -> LexicalFixity - -> HsContext pass + -> HsContext (GhcPass p) -> SDoc pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprHsContext context, pp_tyvars tyvars] @@ -783,7 +784,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis] = TyClGroup { group_tyclds :: [LTyClDecl pass] , group_roles :: [LRoleAnnotDecl pass] , group_instds :: [LInstDecl pass] } -deriving instance (DataId id) => Data (TyClGroup id) +deriving instance (DataIdLR id id) => Data (TyClGroup id) emptyTyClGroup :: TyClGroup pass emptyTyClGroup = TyClGroup [] [] [] @@ -899,7 +900,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig] -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (FamilyResultSig pass) +deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass) -- | Located type Family Declaration type LFamilyDecl pass = Located (FamilyDecl pass) @@ -922,7 +923,7 @@ data FamilyDecl pass = FamilyDecl -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId id) => Data (FamilyDecl id) +deriving instance (DataIdLR id id) => Data (FamilyDecl id) -- | Located Injectivity Annotation type LInjectivityAnn pass = Located (InjectivityAnn pass) @@ -949,7 +950,7 @@ data FamilyInfo pass -- | 'Nothing' if we're in an hs-boot file and the user -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -deriving instance (DataId pass) => Data (FamilyInfo pass) +deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass) -- | Does this family declaration have a complete, user-supplied kind signature? famDeclHasCusk :: Maybe Bool @@ -964,21 +965,21 @@ famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True -- | Does this family declaration have user-supplied return kind signature? hasReturnKindSignature :: FamilyResultSig a -> Bool -hasReturnKindSignature NoSig = False -hasReturnKindSignature (TyVarSig (L _ (UserTyVar _))) = False -hasReturnKindSignature _ = True +hasReturnKindSignature NoSig = False +hasReturnKindSignature (TyVarSig (L _ UserTyVar{})) = False +hasReturnKindSignature _ = True -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig a -> Maybe (IdP a) resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (FamilyDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (FamilyDecl (GhcPass p)) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (SourceTextX pass, OutputableBndrId pass) - => TopLevelFlag -> FamilyDecl pass -> SDoc +pprFamilyDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars , fdFixity = fixity @@ -1057,7 +1058,7 @@ data HsDataDefn pass -- The payload of a data type defn -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataId id) => Data (HsDataDefn id) +deriving instance (DataIdLR id id) => Data (HsDataDefn id) -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] @@ -1093,10 +1094,10 @@ data HsDerivingClause pass -- -- should produce a derived instance for @C [a] (T b)@. } -deriving instance (DataId id) => Data (HsDerivingClause id) +deriving instance (DataIdLR id id) => Data (HsDerivingClause id) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsDerivingClause pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsDerivingClause (GhcPass p)) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" @@ -1176,7 +1177,7 @@ data ConDecl pass , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -deriving instance (DataId pass) => Data (ConDecl pass) +deriving instance (DataIdLR pass pass) => Data (ConDecl pass) -- | Haskell data Constructor Declaration Details type HsConDeclDetails pass @@ -1204,7 +1205,7 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs) (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty (details, res_ty) -- See Note [Sorting out the result type] = case tau of - L _ (HsFunTy (L l (HsRecTy flds)) res_ty') + L _ (HsFunTy _ (L l (HsRecTy _ flds)) res_ty') -> (RecCon (L l flds), res_ty') _other -> (PrefixCon [], tau) @@ -1213,9 +1214,9 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (SourceTextX pass, OutputableBndrId pass) - => (HsContext pass -> SDoc) -- Printing the header - -> HsDataDefn pass +pp_data_defn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => (HsContext (GhcPass p) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context , dd_cType = mb_ct @@ -1237,26 +1238,27 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsDataDefn pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsDataDefn (GhcPass p)) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (SourceTextX pass, OutputableBndrId pass) - => [LConDecl pass] -> SDoc +pp_condecls :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (ConDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl -pprConDecl :: (SourceTextX pass, OutputableBndrId pass) => ConDecl pass -> SDoc +pprConDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => ConDecl (GhcPass p) -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_qvars = mtvs , con_cxt = mcxt @@ -1381,7 +1383,7 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } -- 'ApiAnnotation.AnnInstance', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance DataId pass => Data (TyFamInstDecl pass) +deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass) ----------------- Data family instances ------------- @@ -1399,7 +1401,7 @@ newtype DataFamInstDecl pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance DataId pass => Data (DataFamInstDecl pass) +deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass) ----------------- Family instances (common types) ------------- @@ -1459,7 +1461,7 @@ data ClsInstDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId id) => Data (ClsInstDecl id) +deriving instance (DataIdLR id id) => Data (ClsInstDecl id) ----------------- Instances of all kinds ------------- @@ -1475,14 +1477,14 @@ data InstDecl pass -- Both class and family instances { dfid_inst :: DataFamInstDecl pass } | TyFamInstD -- type family instance { tfid_inst :: TyFamInstDecl pass } -deriving instance (DataId id) => Data (InstDecl id) +deriving instance (DataIdLR id id) => Data (InstDecl id) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (TyFamInstDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (TyFamInstDecl (GhcPass p)) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) - => TopLevelFlag -> TyFamInstDecl pass -> SDoc +pprTyFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1490,16 +1492,16 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass) - => TyFamInstEqn pass -> SDoc +ppr_fam_inst_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => TyFamInstEqn (GhcPass p) -> SDoc ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }}) = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs -ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass) - => LTyFamDefltEqn pass -> SDoc +ppr_fam_deflt_eqn :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LTyFamDefltEqn (GhcPass p) -> SDoc ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon , feqn_pats = tvs , feqn_fixity = fixity @@ -1507,12 +1509,12 @@ ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon = text "type" <+> pp_vanilla_decl_head tycon tvs fixity [] <+> equals <+> ppr rhs -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (DataFamInstDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (DataFamInstDecl (GhcPass p)) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass) - => TopLevelFlag -> DataFamInstDecl pass -> SDoc +pprDataFamInstDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = tycon , feqn_pats = pats @@ -1528,12 +1530,12 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) = ppr nd -pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass) - => Located (IdP pass) - -> HsTyPats pass +pprFamInstLHS :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Located (IdP (GhcPass p)) + -> HsTyPats (GhcPass p) -> LexicalFixity - -> HsContext pass - -> Maybe (LHsKind pass) + -> HsContext (GhcPass p) + -> Maybe (LHsKind (GhcPass p)) -> SDoc pprFamInstLHS thing typats fixity context mb_kind_sig -- explicit type patterns @@ -1553,8 +1555,8 @@ pprFamInstLHS thing typats fixity context mb_kind_sig | otherwise = empty -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (ClsInstDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (ClsInstDecl (GhcPass p)) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1592,8 +1594,8 @@ ppOverlapPragma mb = maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (InstDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (InstDecl (GhcPass p)) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl @@ -1632,10 +1634,10 @@ data DerivDecl pass = DerivDecl -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataId pass) => Data (DerivDecl pass) +deriving instance (DataIdLR pass pass) => Data (DerivDecl pass) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (DerivDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (DerivDecl (GhcPass p)) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1667,10 +1669,10 @@ data DefaultDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (DefaultDecl pass) +deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (DefaultDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (DefaultDecl (GhcPass p)) where ppr (DefaultDecl tys) = text "default" <+> parens (interpp'SP tys) @@ -1712,7 +1714,7 @@ data ForeignDecl pass -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (ForeignDecl pass) +deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass) {- In both ForeignImport and ForeignExport: sig_ty is the type given in the Haskell code @@ -1723,10 +1725,10 @@ deriving instance (DataId pass) => Data (ForeignDecl pass) -} noForeignImportCoercionYet :: PlaceHolder -noForeignImportCoercionYet = PlaceHolder +noForeignImportCoercionYet = placeHolder noForeignExportCoercionYet :: PlaceHolder -noForeignExportCoercionYet = PlaceHolder +noForeignExportCoercionYet = placeHolder -- Specification Of an imported external entity in dependence on the calling -- convention @@ -1773,8 +1775,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (ForeignDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (ForeignDecl (GhcPass p)) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -1829,7 +1831,7 @@ type LRuleDecls pass = Located (RuleDecls pass) -- | Rule Declarations data RuleDecls pass = HsRules { rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } -deriving instance (DataId pass) => Data (RuleDecls pass) +deriving instance (DataIdLR pass pass) => Data (RuleDecls pass) -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) @@ -1855,7 +1857,7 @@ data RuleDecl pass -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (RuleDecl pass) +deriving instance (DataIdLR pass pass) => Data (RuleDecl pass) flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls @@ -1872,7 +1874,7 @@ data RuleBndr pass -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (RuleBndr pass) +deriving instance (DataIdLR pass pass) => Data (RuleBndr pass) collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] @@ -1880,14 +1882,14 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (RuleDecls pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (RuleDecls (GhcPass p)) where ppr (HsRules st rules) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (RuleDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (RuleDecl (GhcPass p)) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), @@ -1896,8 +1898,8 @@ instance (SourceTextX pass, OutputableBndrId pass) pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (RuleBndr pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (RuleBndr (GhcPass p)) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) @@ -1965,7 +1967,7 @@ data VectDecl pass (LHsSigType pass) | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now ClsInst -deriving instance (DataId pass) => Data (VectDecl pass) +deriving instance (DataIdLR pass pass) => Data (VectDecl pass) lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name @@ -1984,8 +1986,8 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (VectDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (VectDecl (GhcPass p)) where ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ @@ -2104,10 +2106,10 @@ data AnnDecl pass = HsAnnotation -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (AnnDecl pass) +deriving instance (DataIdLR pass pass) => Data (AnnDecl pass) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (AnnDecl pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (AnnDecl (GhcPass p)) where ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index fedaa4491a..6b3440ae8b 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -11,6 +11,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -20,6 +22,7 @@ module HsExpr where -- friends: import GhcPrelude +import PlaceHolder import HsDecls import HsPat import HsLit @@ -82,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 = [] @@ -109,17 +112,17 @@ noPostTcTable = [] data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p , syn_arg_wraps :: [HsWrapper] , syn_res_wrap :: HsWrapper } -deriving instance (DataId p) => Data (SyntaxExpr p) +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 } @@ -127,13 +130,14 @@ 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 -- not past the typechecker -instance (SourceTextX p, OutputableBndrId p) => Outputable (SyntaxExpr p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (SyntaxExpr (GhcPass p)) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -277,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 @@ -289,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', @@ -314,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', @@ -322,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 @@ -352,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 @@ -373,6 +386,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | ExplicitTuple + (XExplicitTuple p) [LHsTupArg p] Boxity @@ -384,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', @@ -403,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 @@ -416,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) -- @@ -425,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', @@ -434,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,...] -- @@ -447,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] @@ -461,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 @@ -471,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 @@ -485,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 @@ -507,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 -- @@ -524,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) @@ -540,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'@, @@ -548,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 @@ -556,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) @@ -568,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 @@ -586,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 @@ -597,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 @@ -606,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 --------------------------------------- @@ -620,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) @@ -633,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 @@ -644,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 @@ -663,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 @@ -675,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 --------------------------------------- @@ -701,10 +714,138 @@ 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) -deriving instance (DataId p) => Data (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 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 -- @@ -719,13 +860,23 @@ type LHsTupArg id = Located (HsTupArg id) -- | Haskell Tuple Argument data HsTupArg id - = Present (LHsExpr id) -- ^ The argument - | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type -deriving instance (DataId id) => Data (HsTupArg id) + = Present (XPresent id) (LHsExpr id) -- ^ The argument + | Missing (XMissing id) -- ^ The argument is missing, but this is its type + | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point +deriving instance (DataIdLR id id) => Data (HsTupArg id) + +type instance XPresent (GhcPass _) = PlaceHolder + +type instance XMissing GhcPs = PlaceHolder +type instance XMissing GhcRn = PlaceHolder +type instance XMissing GhcTc = Type + +type instance XXTupArg (GhcPass _) = PlaceHolder tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True tupArgPresent (L _ (Missing {})) = False +tupArgPresent (L _ (XTupArg {})) = False {- Note [Parens in HsSyn] @@ -799,16 +950,19 @@ RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. -} -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsExpr (GhcPass p)) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc +pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsExpr (GhcPass p) -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc +pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -816,56 +970,56 @@ 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 idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR) - => HsLocalBindsLR idL idR -> SDoc +pprBinds :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc +ppr_lexpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsExpr (GhcPass p) -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall p. (SourceTextX p, OutputableBndrId p) => HsExpr 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 :: 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) = 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 @@ -877,63 +1031,67 @@ 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 [] = [] - ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es - ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es punc (Present {} : _) = comma <> space punc (Missing {} : _) = comma + punc (XTupArg {} : _) = comma <> space punc [] = empty -ppr_expr (ExplicitSum alt arity expr _) +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", @@ -950,15 +1108,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))) @@ -972,49 +1130,48 @@ 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 (HsProc _ pat (L _ (XCmdTop x))) + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x] 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, @@ -1022,7 +1179,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, @@ -1030,44 +1187,49 @@ 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 -- | Located Haskell Wildcard Type Expression -data LHsWcTypeX = forall p. (SourceTextX p, OutputableBndrId p) - => LHsWcTypeX (LHsWcType p) - -ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p - -> [Either (LHsExpr p) LHsWcTypeX] +data LHsWcTypeX = forall p. ( SourceTextX (GhcPass p) + , OutputableBndrId (GhcPass p)) + => LHsWcTypeX (LHsWcType (GhcPass p)) + +ppr_apps :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) + -- -> [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)) @@ -1085,16 +1247,19 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc +pprDebugParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsExpr (GhcPass p) -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc +pprParendLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsExpr (GhcPass p) -> SDoc pprParendLExpr (L _ e) = pprParendExpr e -pprParendExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc +pprParendExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) -> SDoc pprParendExpr expr | hsExprNeedsParens expr = parens (pprExpr expr) | otherwise = pprExpr expr @@ -1120,13 +1285,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 @@ -1139,8 +1304,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 @@ -1165,10 +1330,10 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (XCmdArrApp id) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t (LHsExpr id) -- arrow expression, f (LHsExpr id) -- input expression, arg - (PostTc id Type) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t HsArrAppType -- higher-order (-<<) or first-order (-<) Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) @@ -1178,6 +1343,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XCmdArrForm id) (LHsExpr id) -- The operator. -- After type-checking, a type abstraction to be -- applied to the type of the local environment tuple @@ -1187,22 +1353,26 @@ data HsCmd id -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands - | HsCmdApp (LHsCmd id) + | HsCmdApp (XCmdApp id) + (LHsCmd id) (LHsExpr id) - | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa + | HsCmdLam (XCmdLam id) + (MatchGroup id (LHsCmd id)) -- kappa -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', -- 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdPar (LHsCmd id) -- parenthesised command + | HsCmdPar (XCmdPar id) + (LHsCmd id) -- parenthesised command -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdCase (LHsExpr id) + | HsCmdCase (XCmdCase id) + (LHsExpr id) (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, @@ -1210,7 +1380,8 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function + | HsCmdIf (XCmdIf id) + (Maybe (SyntaxExpr id)) -- cond function (LHsExpr id) -- predicate (LHsCmd id) -- then part (LHsCmd id) -- else part @@ -1221,7 +1392,8 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdLet (LHsLocalBinds id) -- let(rec) + | HsCmdLet (XCmdLet id) + (LHsLocalBinds id) -- let(rec) (LHsCmd id) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', -- 'ApiAnnotation.AnnOpen' @'{'@, @@ -1229,8 +1401,8 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdDo (Located [CmdLStmt id]) - (PostTc id Type) -- Type of the whole expression + | HsCmdDo (XCmdDo id) -- Type of the whole expression + (Located [CmdLStmt id]) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnVbar', @@ -1238,11 +1410,32 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdWrap HsWrapper + | HsCmdWrap (XCmdWrap id) + HsWrapper (HsCmd id) -- If cmd :: arg1 --> res -- wrap :: arg1 "->" arg2 -- Then (HsCmdWrap wrap cmd) :: arg2 --> res -deriving instance (DataId id) => Data (HsCmd id) + | XCmd (XXCmd id) -- Note [Trees that Grow] extension point +deriving instance (DataIdLR id id) => Data (HsCmd id) + +type instance XCmdArrApp GhcPs = PlaceHolder +type instance XCmdArrApp GhcRn = PlaceHolder +type instance XCmdArrApp GhcTc = Type + +type instance XCmdArrForm (GhcPass _) = PlaceHolder +type instance XCmdApp (GhcPass _) = PlaceHolder +type instance XCmdLam (GhcPass _) = PlaceHolder +type instance XCmdPar (GhcPass _) = PlaceHolder +type instance XCmdCase (GhcPass _) = PlaceHolder +type instance XCmdIf (GhcPass _) = PlaceHolder +type instance XCmdLet (GhcPass _) = PlaceHolder + +type instance XCmdDo GhcPs = PlaceHolder +type instance XCmdDo GhcRn = PlaceHolder +type instance XCmdDo GhcTc = Type + +type instance XCmdWrap (GhcPass _) = PlaceHolder +type instance XXCmd (GhcPass _) = PlaceHolder -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1259,22 +1452,36 @@ type LHsCmdTop p = Located (HsCmdTop p) -- | Haskell Top-level Command data HsCmdTop p - = HsCmdTop (LHsCmd p) - (PostTc p Type) -- Nested tuple of inputs on the command's stack - (PostTc p Type) -- return type of the command - (CmdSyntaxTable p) -- See Note [CmdSyntaxTable] -deriving instance (DataId p) => Data (HsCmdTop p) + = HsCmdTop (XCmdTop p) + (LHsCmd p) + | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point +deriving instance (DataIdLR p p) => Data (HsCmdTop p) + +data CmdTopTc + = CmdTopTc Type -- Nested tuple of inputs on the command's stack + Type -- return type of the command + (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + deriving Data -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where +type instance XCmdTop GhcPs = PlaceHolder +type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] +type instance XCmdTop GhcTc = CmdTopTc + +type instance XXCmdTop (GhcPass _) = PlaceHolder + +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsCmd (GhcPass p)) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc +pprLCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsCmd (GhcPass p) -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc +pprCmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsCmd (GhcPass p) -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1282,81 +1489,87 @@ isQuietHsCmd :: HsCmd id -> Bool -- Parentheses do display something, but it gives little info and -- if we go deeper when we go inside them then we get ugly things -- like (...) -isQuietHsCmd (HsCmdPar _) = True +isQuietHsCmd (HsCmdPar {}) = True -- applications don't display anything themselves -isQuietHsCmd (HsCmdApp _ _) = True +isQuietHsCmd (HsCmdApp {}) = True isQuietHsCmd _ = False ----------------------- -ppr_lcmd :: (SourceTextX p, OutputableBndrId p) => LHsCmd p -> SDoc +ppr_lcmd :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsCmd (GhcPass p) -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall p. (SourceTextX p, OutputableBndrId p) => HsCmd p -> SDoc -ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) +ppr_cmd :: forall p. (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsCmd (GhcPass p) -> SDoc +ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) -ppr_cmd (HsCmdApp c e) +ppr_cmd (HsCmdApp _ c e) = let (fun, args) = collect_args c [e] in hang (ppr_lcmd fun) 2 (sep (map ppr args)) where - collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) + collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) collect_args fun args = (fun, args) -ppr_cmd (HsCmdLam matches) +ppr_cmd (HsCmdLam _ matches) = pprMatches matches -ppr_cmd (HsCmdCase expr matches) +ppr_cmd (HsCmdCase _ expr matches) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], nest 2 (pprMatches matches) ] -ppr_cmd (HsCmdIf _ e ct ce) +ppr_cmd (HsCmdIf _ _ e ct ce) = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], nest 4 (ppr ct), text "else", nest 4 (ppr ce)] -- special case: let ... in let ... -ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _))) +ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lcmd cmd] -ppr_cmd (HsCmdLet (L _ binds) cmd) +ppr_cmd (HsCmdLet _ (L _ binds) cmd) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr cmd)] -ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts +ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts -ppr_cmd (HsCmdWrap w cmd) +ppr_cmd (HsCmdWrap _ w cmd) = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) -ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) _ (Just _) [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm (L _ (HsConLikeOut c)) Infix _ [arg1, arg2]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm op _ _ args) +ppr_cmd (HsCmdArrForm _ op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") +ppr_cmd (XCmd x) = ppr x -pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc -pprCmdArg (HsCmdTop cmd _ _ _) +pprCmdArg :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg (HsCmdTop _ cmd) = ppr_lcmd cmd +pprCmdArg (XCmdTop x) = ppr x -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsCmdTop (GhcPass p)) where ppr = pprCmdArg {- @@ -1392,6 +1605,7 @@ a function defined by pattern matching must have the same number of patterns in each equation. -} +-- AZ:TODO complete TTG on this, once DataId etc is resolved data MatchGroup p body = MG { mg_alts :: Located [LMatch p body] -- The alternatives , mg_arg_tys :: [PostTc p Type] -- Types of the arguments, t1..tn @@ -1400,13 +1614,14 @@ data MatchGroup p body -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns -deriving instance (Data body,DataId p) => Data (MatchGroup p body) +deriving instance (Data body,DataIdLR p p) => Data (MatchGroup p body) -- | Located Match type LMatch id body = Located (Match id body) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a -- list +-- AZ:TODO complete TTG on this, once DataId etc is resolved -- For details on above see note [Api annotations] in ApiAnnotation data Match p body = Match { @@ -1415,10 +1630,11 @@ data Match p body m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) } -deriving instance (Data body,DataId p) => Data (Match p body) +deriving instance (Data body,DataIdLR p p) => Data (Match p body) -instance (SourceTextX idR, OutputableBndrId idR, Outputable body) - => Outputable (Match idR body) where +instance (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), + Outputable body) + => Outputable (Match (GhcPass idR) body) where ppr = pprMatch {- @@ -1494,46 +1710,53 @@ hsLMatchPats (L _ (Match { m_pats = pats })) = pats -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' +-- AZ:TODO complete TTG on this, once DataId etc is resolved -- For details on above see note [Api annotations] in ApiAnnotation data GRHSs p body = GRHSs { grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause } -deriving instance (Data body,DataId p) => Data (GRHSs p body) +deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body) -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) +-- AZ:TODO complete TTG on this, once DataId etc is resolved -- | Guarded Right Hand Side. data GRHS id body = GRHS [GuardLStmt id] -- Guards body -- Right hand side -deriving instance (Data body,DataId id) => Data (GRHS id body) +deriving instance (Data body,DataIdLR id id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. -pprMatches :: (SourceTextX idR, OutputableBndrId idR, Outputable body) - => MatchGroup idR body -> SDoc +pprMatches :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), + Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc pprMatches MG { mg_alts = matches } = vcat (map pprMatch (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) - => MatchGroup idR body -> SDoc +pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), + Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc pprFunBind matches = pprMatches matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, - OutputableBndrId bndr, - OutputableBndrId p, +pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p), + SourceTextX (GhcPass bndr), + OutputableBndrId (GhcPass bndr), + OutputableBndrId (GhcPass p), Outputable body) - => LPat bndr -> GRHSs p body -> SDoc + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc pprPatBind pat (grhss) - = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP p)) grhss)] + = sep [ppr pat, nest 2 + (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] -pprMatch :: (SourceTextX idR, OutputableBndrId idR, Outputable body) - => Match idR body -> SDoc +pprMatch :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), + Outputable body) + => Match (GhcPass idR) body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 (pprGRHSs ctxt (m_grhss match)) ] @@ -1566,8 +1789,9 @@ pprMatch match (pat1:pats1) = m_pats match (pat2:pats2) = pats1 -pprGRHSs :: (SourceTextX idR, OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHSs idR body -> SDoc +pprGRHSs :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), + Outputable body) + => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc pprGRHSs ctxt (GRHSs grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) -- Print the "where" even if the contents of the binds is empty. Only @@ -1575,8 +1799,9 @@ pprGRHSs ctxt (GRHSs grhss (L _ binds)) $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (SourceTextX idR, OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHS idR body -> SDoc +pprGRHS :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), + Outputable body) + => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc pprGRHS ctxt (GRHS [] body) = pp_rhs ctxt body @@ -1670,7 +1895,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 @@ -1759,7 +1984,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- With rebindable syntax the type might not -- be quite as simple as (m (tya, tyb, tyc)). } -deriving instance (Data body, DataId idL, DataId idR) +deriving instance (Data body, DataIdLR idL idR) => Data (StmtLR idL idR body) data TransForm -- The 'f' below is the 'using' function, 'e' is the by function @@ -1770,13 +1995,18 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by functio -- | Parenthesised Statement Block data ParStmtBlock idL idR = ParStmtBlock + (XParStmtBlock idL idR) [ExprLStmt idL] [IdP idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator -deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) + | XParStmtBlock (XXParStmtBlock idL idR) +deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR) + +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder -- | Applicative Argument -data ApplicativeArg idL idR +data ApplicativeArg idL = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) (LPat idL) -- WildPat if it was a BodyStmt (see below) (LHsExpr idL) @@ -1788,8 +2018,7 @@ data ApplicativeArg idL idR [ExprLStmt idL] -- stmts (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) (LPat idL) -- (v1,...,vn) - -deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR) +deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL) {- Note [The type of bind in Stmts] @@ -1956,19 +2185,24 @@ Bool flag that is True when the original statement was a BodyStmt, so that we can pretty-print it correctly. -} -instance (SourceTextX idL, OutputableBndrId idL) - => Outputable (ParStmtBlock idL idR) where - ppr (ParStmtBlock stmts _ _) = interpp'SP stmts +instance (SourceTextX (GhcPass idL), OutputableBndrId (GhcPass idL), + Outputable (XXParStmtBlock (GhcPass idL) idR)) + => Outputable (ParStmtBlock (GhcPass idL) idR) where + ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts + ppr (XParStmtBlock x) = ppr x -instance (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => Outputable (StmtLR idL idR body) where +instance (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), + Outputable body) + => Outputable (StmtLR (GhcPass idL) (GhcPass idR) body) where ppr stmt = pprStmt stmt -pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR, +pprStmt :: forall idL idR body . (SourceTextX (GhcPass idL), + SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), Outputable body) - => (StmtLR idL idR body) -> SDoc + => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc pprStmt (LastStmt expr ret_stripped _) = whenPprDebug (text "[last]") <+> (if ret_stripped then text "return" else empty) <+> @@ -2002,17 +2236,17 @@ 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 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") - :: ExprStmt idL)] + :: ExprStmt (GhcPass idL))] | otherwise = [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt idL)] + :: ExprStmt (GhcPass idL))] flattenArg (_, ApplicativeArgMany stmts _ _) = concatMap flattenStmt stmts @@ -2024,22 +2258,23 @@ 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") - :: ExprStmt idL) + :: ExprStmt (GhcPass idL)) | otherwise = ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt") - :: ExprStmt idL) + :: ExprStmt (GhcPass idL)) 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 p, OutputableBndrId p) - => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc +pprTransformStmt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) + -> Maybe (LHsExpr (GhcPass p)) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) @@ -2055,8 +2290,9 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (SourceTextX p, OutputableBndrId p, Outputable body) - => HsStmtContext any -> [LStmt p body] -> SDoc +pprDo :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), + Outputable body) + => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts @@ -2066,14 +2302,16 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => [LStmtLR idL idR body] -> SDoc +ppr_do_stmts :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), + Outputable body) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc -- Print a bunch of do stmts ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) -pprComp :: (SourceTextX p, OutputableBndrId p, Outputable body) - => [LStmt p body] -> SDoc +pprComp :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), + Outputable body) + => [LStmt (GhcPass p) body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals = if null initStmts @@ -2087,8 +2325,9 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (SourceTextX p, OutputableBndrId p, Outputable body) - => [LStmt p body] -> SDoc +pprQuals :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), + Outputable body) + => [LStmt (GhcPass p) body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -2103,30 +2342,44 @@ pprQuals quals = interpp'SP quals -- | Haskell Splice data HsSplice id = HsTypedSplice -- $$z or $$(f 4) + (XTypedSplice id) SpliceDecoration -- Whether $$( ) variant found, for pretty printing (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsUntypedSplice -- $z or $(f 4) + (XUntypedSplice id) SpliceDecoration -- Whether $( ) variant found, for pretty printing (IdP id) -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice + (XQuasiQuote id) (IdP id) -- Splice point (IdP id) -- Quoter SrcSpan -- The span of the enclosed string FastString -- The enclosed string + -- AZ:TODO: use XSplice instead of HsSpliced | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in -- RnSplice. -- This is the result of splicing a splice. It is produced by -- the renamer and consumed by the typechecker. It lives only -- between the two. + (XSpliced id) ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing + | XSplice (XXSplice id) -- Note [Trees that Grow] extension point deriving Typeable -deriving instance (DataId id) => Data (HsSplice id) +deriving instance (DataIdLR id id) => Data (HsSplice id) + + +type instance XTypedSplice (GhcPass _) = PlaceHolder +type instance XUntypedSplice (GhcPass _) = PlaceHolder +type instance XQuasiQuote (GhcPass _) = PlaceHolder +type instance XSpliced (GhcPass _) = PlaceHolder +type instance XXSplice (GhcPass _) = PlaceHolder + -- | A splice can appear with various decorations wrapped around it. This data -- type captures explicitly how it was originally written, for use in the pretty @@ -2168,7 +2421,7 @@ data HsSplicedThing id | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern deriving Typeable -deriving instance (DataId id) => Data (HsSplicedThing id) +deriving instance (DataIdLR id id) => Data (HsSplicedThing id) -- See Note [Pending Splices] type SplicePointName = Name @@ -2192,7 +2445,6 @@ data PendingTcSplice = PendingTcSplice SplicePointName (LHsExpr GhcTc) deriving Data - {- Note [Pending Splices] ~~~~~~~~~~~~~~~~~~~~~~ @@ -2257,85 +2509,103 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} -instance (SourceTextX p, OutputableBndrId p) - => Outputable (HsSplicedThing p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsSplicedThing (GhcPass p)) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsSplice p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsSplice (GhcPass p)) where ppr s = pprSplice s -pprPendingSplice :: (SourceTextX p, OutputableBndrId p) - => SplicePointName -> LHsExpr p -> SDoc +pprPendingSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => SplicePointName -> LHsExpr (GhcPass p) -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) - => HsSplice p -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" pprSpliceDecl e ImplicitSplice = ppr_splice_decl e -ppr_splice_decl :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc -ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty +ppr_splice_decl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SDoc +ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e -pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc -pprSplice (HsTypedSplice HasParens n e) +pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SDoc +pprSplice (HsTypedSplice _ HasParens n e) = ppr_splice (text "$$(") n e (text ")") -pprSplice (HsTypedSplice HasDollar n e) +pprSplice (HsTypedSplice _ HasDollar n e) = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice NoParens n e) +pprSplice (HsTypedSplice _ NoParens n e) = ppr_splice empty n e empty -pprSplice (HsUntypedSplice HasParens n e) +pprSplice (HsUntypedSplice _ HasParens n e) = ppr_splice (text "$(") n e (text ")") -pprSplice (HsUntypedSplice HasDollar n e) +pprSplice (HsUntypedSplice _ HasDollar n e) = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice NoParens n e) +pprSplice (HsUntypedSplice _ NoParens n e) = ppr_splice empty n e empty -pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ thing) = ppr thing +pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ _ thing) = ppr thing +pprSplice (XSplice x) = ppr x ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: (SourceTextX p, OutputableBndrId p) - => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc +ppr_splice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc ppr_splice herald n e trail = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail -- | Haskell Bracket -data HsBracket p = ExpBr (LHsExpr p) -- [| expr |] - | PatBr (LPat p) -- [p| pat |] - | DecBrL [LHsDecl p] -- [d| decls |]; result of parser - | DecBrG (HsGroup p) -- [d| decls |]; result of renamer - | TypBr (LHsType p) -- [t| type |] - | VarBr Bool (IdP p) -- True: 'x, False: ''T - -- (The Bool flag is used only in pprHsBracket) - | TExpBr (LHsExpr p) -- [|| expr ||] -deriving instance (DataId p) => Data (HsBracket p) +data HsBracket p + = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] + | PatBr (XPatBr p) (LPat p) -- [p| pat |] + | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser + | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer + | TypBr (XTypBr p) (LHsType p) -- [t| type |] + | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) + | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] + | XBracket (XXBracket p) -- Note [Trees that Grow] extension point +deriving instance (DataIdLR p p) => Data (HsBracket p) + +type instance XExpBr (GhcPass _) = PlaceHolder +type instance XPatBr (GhcPass _) = PlaceHolder +type instance XDecBrL (GhcPass _) = PlaceHolder +type instance XDecBrG (GhcPass _) = PlaceHolder +type instance XTypBr (GhcPass _) = PlaceHolder +type instance XVarBr (GhcPass _) = PlaceHolder +type instance XTExpBr (GhcPass _) = PlaceHolder +type instance XXBracket (GhcPass _) = PlaceHolder isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsBracket p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsBracket (GhcPass p)) where ppr = pprHsBracket -pprHsBracket :: (SourceTextX p, OutputableBndrId p) => HsBracket p -> SDoc -pprHsBracket (ExpBr e) = thBrackets empty (ppr e) -pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) -pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) -pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr True n) +pprHsBracket :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsBracket (GhcPass p) -> SDoc +pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) +pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr _ True n) = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr False n) +pprHsBracket (VarBr _ False n) = text "''" <> pprPrefixOcc n -pprHsBracket (TExpBr e) = thTyBrackets (ppr e) +pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) +pprHsBracket (XBracket e) = ppr e thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> @@ -2368,10 +2638,11 @@ data ArithSeqInfo id | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) -deriving instance (DataId id) => Data (ArithSeqInfo id) +deriving instance (DataIdLR id id) => Data (ArithSeqInfo id) +-- AZ: Sould ArithSeqInfo have a TTG extension? -instance (SourceTextX p, OutputableBndrId p) - => Outputable (ArithSeqInfo p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (ArithSeqInfo (GhcPass p)) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -2587,19 +2858,21 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" -pprMatchInCtxt :: (SourceTextX idR, OutputableBndrId idR, +pprMatchInCtxt :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), -- TODO:AZ these constraints do not make sense - Outputable (NameOrRdrName (NameOrRdrName (IdP idR))), - Outputable body) - => Match idR body -> SDoc + Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), + Outputable body) + => Match (GhcPass idR) body -> SDoc pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) 4 (pprMatch match) -pprStmtInCtxt :: (SourceTextX idL, SourceTextX idR, - OutputableBndrId idL, OutputableBndrId idR, +pprStmtInCtxt :: (SourceTextX (GhcPass idL), SourceTextX (GhcPass idR), + OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), Outputable body) - => HsStmtContext (IdP idL) -> StmtLR idL idR body -> SDoc + => HsStmtContext (IdP (GhcPass idL)) + -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (text "In the expression:") 2 (ppr e) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index bac8a5a183..500d601477 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -5,6 +5,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} module HsExpr where @@ -12,7 +13,7 @@ import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import BasicTypes ( SpliceExplicitFlag(..)) -import HsExtension ( OutputableBndrId, DataId, SourceTextX ) +import HsExtension ( OutputableBndrId, DataIdLR, SourceTextX, GhcPass ) import Data.Data hiding ( Fixity ) type role HsExpr nominal @@ -28,32 +29,39 @@ data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) data SyntaxExpr (i :: *) -instance (DataId p) => Data (HsSplice p) -instance (DataId p) => Data (HsExpr p) -instance (DataId p) => Data (HsCmd p) -instance (Data body,DataId p) => Data (MatchGroup p body) -instance (Data body,DataId p) => Data (GRHSs p body) -instance (DataId p) => Data (SyntaxExpr p) +instance (DataIdLR p p) => Data (HsSplice p) +instance (DataIdLR p p) => Data (HsExpr p) +instance (DataIdLR p p) => Data (HsCmd p) +instance (Data body,DataIdLR p p) => Data (MatchGroup p body) +instance (Data body,DataIdLR p p) => Data (GRHSs p body) +instance (DataIdLR p p) => Data (SyntaxExpr p) -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsExpr p) -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsExpr (GhcPass p)) +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsCmd (GhcPass p)) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (SourceTextX p, OutputableBndrId p) => LHsExpr p -> SDoc +pprLExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsExpr (GhcPass p) -> SDoc -pprExpr :: (SourceTextX p, OutputableBndrId p) => HsExpr p -> SDoc +pprExpr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) -> SDoc -pprSplice :: (SourceTextX p, OutputableBndrId p) => HsSplice p -> SDoc +pprSplice :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SDoc -pprSpliceDecl :: (SourceTextX p, OutputableBndrId p) - => HsSplice p -> SpliceExplicitFlag -> SDoc +pprSpliceDecl :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprPatBind :: forall bndr p body. (SourceTextX p, SourceTextX bndr, - OutputableBndrId bndr, - OutputableBndrId p, +pprPatBind :: forall bndr p body. (SourceTextX (GhcPass p), + SourceTextX (GhcPass bndr), + OutputableBndrId (GhcPass bndr), + OutputableBndrId (GhcPass p), Outputable body) - => LPat bndr -> GRHSs p body -> SDoc + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc -pprFunBind :: (SourceTextX idR, OutputableBndrId idR, Outputable body) - => MatchGroup idR body -> SDoc +pprFunBind :: (SourceTextX (GhcPass idR), OutputableBndrId (GhcPass idR), + Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 80dfa67ea3..86a0bd9431 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -7,6 +7,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder module HsExtension where @@ -55,6 +58,10 @@ haskell-src-exts ASTs as well. -} +-- | Used when constructing a term with an unused extension point. +noExt :: PlaceHolder +noExt = PlaceHolder + -- | Used as a data type index for the hsSyn AST data GhcPass (c :: Pass) deriving instance Eq (GhcPass c) @@ -76,6 +83,8 @@ type instance PostTc GhcPs ty = PlaceHolder type instance PostTc GhcRn ty = PlaceHolder type instance PostTc GhcTc ty = ty +-- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty) + -- | Types that are not defined until after renaming type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder type instance PostRn GhcPs ty = PlaceHolder @@ -87,88 +96,415 @@ type family IdP p type instance IdP GhcPs = RdrName type instance IdP GhcRn = Name type instance IdP GhcTc = Id +-- type instance IdP (GHC x) = IdP x + +type LIdP p = Located (IdP p) +-- --------------------------------------------------------------------- +-- type families for the Pat extension points +type family XWildPat x +type family XVarPat x +type family XLazyPat x +type family XAsPat x +type family XParPat x +type family XBangPat x +type family XListPat x +type family XTuplePat x +type family XSumPat x +type family XPArrPat x +type family XConPat x +type family XViewPat x +type family XSplicePat x +type family XLitPat x +type family XNPat x +type family XNPlusKPat x +type family XSigPat x +type family XCoPat x +type family XXPat x + + +type ForallXPat (c :: * -> Constraint) (x :: *) = + ( c (XWildPat x) + , c (XVarPat x) + , c (XLazyPat x) + , c (XAsPat x) + , c (XParPat x) + , c (XBangPat x) + , c (XListPat x) + , c (XTuplePat x) + , c (XSumPat x) + , c (XPArrPat x) + , c (XViewPat x) + , c (XSplicePat x) + , c (XLitPat x) + , c (XNPat x) + , c (XNPlusKPat x) + , c (XSigPat x) + , c (XCoPat x) + , c (XXPat x) + ) +-- --------------------------------------------------------------------- +-- ValBindsLR type families --- We define a type family for each extension point. This is based on prepending --- 'X' to the constructor name, for ease of reference. -type family XHsChar x -type family XHsCharPrim x -type family XHsString x +type family XValBinds x x' +type family XXValBindsLR x x' + +type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XValBinds 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 +type family XHsCharPrim x +type family XHsString x type family XHsStringPrim x -type family XHsInt x -type family XHsIntPrim x -type family XHsWordPrim x -type family XHsInt64Prim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x type family XHsWord64Prim x -type family XHsInteger x -type family XHsRat x -type family XHsFloatPrim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x type family XHsDoublePrim x +type family XXLit x --- | Helper to apply a constraint to all extension points. It has one +-- | Helper to apply a constraint to all HsLit extension points. It has one -- entry per extension point type family. -type ForallX (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsString x) +type ForallXHsLit (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsString x) , c (XHsStringPrim x) - , c (XHsInt x) - , c (XHsIntPrim x) - , c (XHsWordPrim x) - , c (XHsInt64Prim x) + , c (XHsInt x) + , c (XHsIntPrim x) + , c (XHsWordPrim x) + , c (XHsInt64Prim x) , c (XHsWord64Prim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsFloatPrim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsFloatPrim x) , c (XHsDoublePrim x) + , c (XXLit x) ) --- Provide the specific extension types for the parser phase. -type instance XHsChar GhcPs = SourceText -type instance XHsCharPrim GhcPs = SourceText -type instance XHsString GhcPs = SourceText -type instance XHsStringPrim GhcPs = SourceText -type instance XHsInt GhcPs = () -type instance XHsIntPrim GhcPs = SourceText -type instance XHsWordPrim GhcPs = SourceText -type instance XHsInt64Prim GhcPs = SourceText -type instance XHsWord64Prim GhcPs = SourceText -type instance XHsInteger GhcPs = SourceText -type instance XHsRat GhcPs = () -type instance XHsFloatPrim GhcPs = () -type instance XHsDoublePrim GhcPs = () - --- Provide the specific extension types for the renamer phase. -type instance XHsChar GhcRn = SourceText -type instance XHsCharPrim GhcRn = SourceText -type instance XHsString GhcRn = SourceText -type instance XHsStringPrim GhcRn = SourceText -type instance XHsInt GhcRn = () -type instance XHsIntPrim GhcRn = SourceText -type instance XHsWordPrim GhcRn = SourceText -type instance XHsInt64Prim GhcRn = SourceText -type instance XHsWord64Prim GhcRn = SourceText -type instance XHsInteger GhcRn = SourceText -type instance XHsRat GhcRn = () -type instance XHsFloatPrim GhcRn = () -type instance XHsDoublePrim GhcRn = () - --- Provide the specific extension types for the typechecker phase. -type instance XHsChar GhcTc = SourceText -type instance XHsCharPrim GhcTc = SourceText -type instance XHsString GhcTc = SourceText -type instance XHsStringPrim GhcTc = SourceText -type instance XHsInt GhcTc = () -type instance XHsIntPrim GhcTc = SourceText -type instance XHsWordPrim GhcTc = SourceText -type instance XHsInt64Prim GhcTc = SourceText -type instance XHsWord64Prim GhcTc = SourceText -type instance XHsInteger GhcTc = SourceText -type instance XHsRat GhcTc = () -type instance XHsFloatPrim GhcTc = () -type instance XHsDoublePrim GhcTc = () +type family XOverLit x +type family XXOverLit x + +type ForallXOverLit (c :: * -> Constraint) (x :: *) = + ( c (XOverLit x) + , c (XXOverLit x) + ) + +-- --------------------------------------------------------------------- +-- Type families for the Type type families + +type family XForAllTy x +type family XQualTy x +type family XTyVar x +type family XAppsTy x +type family XAppTy x +type family XFunTy x +type family XListTy x +type family XPArrTy x +type family XTupleTy x +type family XSumTy x +type family XOpTy x +type family XParTy x +type family XIParamTy x +type family XEqTy x +type family XKindSig x +type family XSpliceTy x +type family XDocTy x +type family XBangTy x +type family XRecTy x +type family XExplicitListTy x +type family XExplicitTupleTy x +type family XTyLit x +type family XWildCardTy x +type family XXType x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXType (c :: * -> Constraint) (x :: *) = + ( c (XForAllTy x) + , c (XQualTy x) + , c (XTyVar x) + , c (XAppsTy x) + , c (XAppTy x) + , c (XFunTy x) + , c (XListTy x) + , c (XPArrTy x) + , c (XTupleTy x) + , c (XSumTy x) + , c (XOpTy x) + , c (XParTy x) + , c (XIParamTy x) + , c (XEqTy x) + , c (XKindSig x) + , c (XSpliceTy x) + , c (XDocTy x) + , c (XBangTy x) + , c (XRecTy x) + , c (XExplicitListTy x) + , c (XExplicitTupleTy x) + , c (XTyLit x) + , c (XWildCardTy x) + , c (XXType x) + ) + +-- --------------------------------------------------------------------- + +type family XUserTyVar x +type family XKindedTyVar x +type family XXTyVarBndr x + +type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = + ( c (XUserTyVar x) + , c (XKindedTyVar x) + , c (XXTyVarBndr x) + ) + +-- --------------------------------------------------------------------- + +type family XAppInfix x +type family XAppPrefix x +type family XXAppType x + +type ForallXAppType (c :: * -> Constraint) (x :: *) = + ( c (XAppInfix x) + , c (XAppPrefix x) + , c (XXAppType x) + ) + +-- --------------------------------------------------------------------- + +type family XFieldOcc x +type family XXFieldOcc x + +type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XFieldOcc x) + , c (XXFieldOcc x) + ) + +-- --------------------------------------------------------------------- + +type family XUnambiguous x +type family XAmbiguous x +type family XXAmbiguousFieldOcc x + +type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XUnambiguous x) + , c (XAmbiguous x) + , c (XXAmbiguousFieldOcc 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) + ) +-- --------------------------------------------------------------------- + +type family XPresent x +type family XMissing x +type family XXTupArg x + +type ForallXTupArg (c :: * -> Constraint) (x :: *) = + ( c (XPresent x) + , c (XMissing x) + , c (XXTupArg x) + ) +-- --------------------------------------------------------------------- + +type family XTypedSplice x +type family XUntypedSplice x +type family XQuasiQuote x +type family XSpliced x +type family XXSplice x + +type ForallXSplice (c :: * -> Constraint) (x :: *) = + ( c (XTypedSplice x) + , c (XUntypedSplice x) + , c (XQuasiQuote x) + , c (XSpliced x) + , c (XXSplice x) + ) + +-- --------------------------------------------------------------------- + +type family XExpBr x +type family XPatBr x +type family XDecBrL x +type family XDecBrG x +type family XTypBr x +type family XVarBr x +type family XTExpBr x +type family XXBracket x + +type ForallXBracket (c :: * -> Constraint) (x :: *) = + ( c (XExpBr x) + , c (XPatBr x) + , c (XDecBrL x) + , c (XDecBrG x) + , c (XTypBr x) + , c (XVarBr x) + , c (XTExpBr x) + , c (XXBracket x) + ) + +-- --------------------------------------------------------------------- + +type family XCmdTop x +type family XXCmdTop x + +type ForallXCmdTop (c :: * -> Constraint) (x :: *) = + ( c (XCmdTop x) + , c (XXCmdTop x) + ) + +-- --------------------------------------------------------------------- + +type family XCmdArrApp x +type family XCmdArrForm x +type family XCmdApp x +type family XCmdLam x +type family XCmdPar x +type family XCmdCase x +type family XCmdIf x +type family XCmdLet x +type family XCmdDo x +type family XCmdWrap x +type family XXCmd x + +type ForallXCmd (c :: * -> Constraint) (x :: *) = + ( c (XCmdArrApp x) + , c (XCmdArrForm x) + , c (XCmdApp x) + , c (XCmdLam x) + , c (XCmdPar x) + , c (XCmdCase x) + , c (XCmdIf x) + , c (XCmdLet x) + , c (XCmdDo x) + , c (XCmdWrap x) + , c (XXCmd x) + ) + +-- --------------------------------------------------------------------- + +type family XParStmtBlock x x' +type family XXParStmtBlock x x' + +type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XParStmtBlock x x') + , c (XXParStmtBlock x x') + ) -- --------------------------------------------------------------------- @@ -212,22 +548,6 @@ instance HasSourceText SourceText where -- ---------------------------------------------------------------------- --- | Defaults for each annotation, used to simplify creation in arbitrary --- contexts -class HasDefault a where - def :: a - -instance HasDefault () where - def = () - -instance HasDefault SourceText where - def = NoSourceText - --- | Provide a single constraint that captures the requirement for a default --- across all the extension points. -type HasDefaultX x = ForallX HasDefault x - --- ---------------------------------------------------------------------- -- | Conversion of annotations from one type index to another. This is required -- where the AST is converted from one pass to another, and the extension values -- need to be brought along if possible. So for example a 'SourceText' is @@ -254,15 +574,69 @@ type ConvertIdX a b = XHsStringPrim a ~ XHsStringPrim b, XHsString a ~ XHsString b, XHsCharPrim a ~ XHsCharPrim b, - XHsChar a ~ XHsChar b) + XHsChar a ~ XHsChar b, + XXLit a ~ XXLit b) + +-- ---------------------------------------------------------------------- + +-- | Provide a summary constraint that gives all am Outputable constraint to +-- extension points needing one +type OutputableX p = + ( Outputable (XXPat p) + , Outputable (XXPat GhcRn) + + , Outputable (XSigPat p) + , Outputable (XSigPat GhcRn) + + , Outputable (XXLit p) + , Outputable (XXOverLit p) + + , Outputable (XXType p) + + , Outputable (XExprWithTySig p) + , Outputable (XExprWithTySig GhcRn) + + , Outputable (XAppTypeE p) + , Outputable (XAppTypeE GhcRn) + + -- , Outputable (XXParStmtBlock (GhcPass idL) idR) + ) +-- TODO: Should OutputableX be included in OutputableBndrId? -- ---------------------------------------------------------------------- -- type DataId p = ( Data p - , ForallX Data p + + , ForallXHsLit Data p + , ForallXPat Data p + + -- Th following GhcRn constraints should go away once TTG is fully implemented + , ForallXPat Data GhcRn + , ForallXType Data GhcRn + , ForallXExpr Data GhcRn + , ForallXTupArg Data GhcRn + , ForallXSplice Data GhcRn + , ForallXBracket Data GhcRn + , ForallXCmdTop Data GhcRn + , ForallXCmd Data GhcRn + + , ForallXOverLit Data p + , ForallXType Data p + , ForallXTyVarBndr Data p + , ForallXAppType Data p + , ForallXFieldOcc Data p + , ForallXAmbiguousFieldOcc Data p + + , ForallXExpr Data p + , ForallXTupArg Data p + , ForallXSplice Data p + , ForallXBracket Data p + , ForallXCmdTop Data p + , ForallXCmd Data p + , Data (NameOrRdrName (IdP p)) , Data (IdP p) @@ -282,10 +656,23 @@ type DataId p = , Data (PostTc p [Type]) ) +type DataIdLR pL pR = + ( DataId pL + , DataId pR + , ForallXValBindsLR Data pL pR + , ForallXValBindsLR Data pL pL + , ForallXValBindsLR Data pR pR + + , ForallXParStmtBlock Data pL pR + , ForallXParStmtBlock Data pL pL + , ForallXParStmtBlock Data pR pR + , ForallXParStmtBlock Data GhcRn GhcRn + ) -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @id@ and the 'NameOrRdrName' type for it type OutputableBndrId id = ( OutputableBndr (NameOrRdrName (IdP id)) , OutputableBndr (IdP id) + , OutputableX id ) diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 7f0864eccc..a47b0ff4fe 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -28,6 +28,7 @@ import Type ( Type ) import Outputable import FastString import HsExtension +import PlaceHolder import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -77,8 +78,25 @@ data HsLit x | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double + | XLit (XXLit x) + deriving instance (DataId x) => Data (HsLit x) +type instance XHsChar (GhcPass _) = SourceText +type instance XHsCharPrim (GhcPass _) = SourceText +type instance XHsString (GhcPass _) = SourceText +type instance XHsStringPrim (GhcPass _) = SourceText +type instance XHsInt (GhcPass _) = PlaceHolder +type instance XHsIntPrim (GhcPass _) = SourceText +type instance XHsWordPrim (GhcPass _) = SourceText +type instance XHsInt64Prim (GhcPass _) = SourceText +type instance XHsWord64Prim (GhcPass _) = SourceText +type instance XHsInteger (GhcPass _) = SourceText +type instance XHsRat (GhcPass _) = PlaceHolder +type instance XHsFloatPrim (GhcPass _) = PlaceHolder +type instance XHsDoublePrim (GhcPass _) = PlaceHolder +type instance XXLit (GhcPass _) = PlaceHolder + instance Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 @@ -99,11 +117,25 @@ instance Eq (HsLit x) where -- | Haskell Overloaded Literal data HsOverLit p = OverLit { - ol_val :: OverLitVal, - ol_rebindable :: PostRn p Bool, -- Note [ol_rebindable] - ol_witness :: HsExpr p, -- Note [Overloaded literal witnesses] - ol_type :: PostTc p Type } -deriving instance (DataId p) => Data (HsOverLit p) + ol_ext :: (XOverLit p), + ol_val :: OverLitVal, + ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] + + | XOverLit + (XXOverLit p) +deriving instance (DataIdLR p p) => Data (HsOverLit p) + +data OverLitTc + = OverLitTc { + ol_rebindable :: Bool, -- Note [ol_rebindable] + ol_type :: Type } + deriving Data + +type instance XOverLit GhcPs = PlaceHolder +type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] +type instance XOverLit GhcTc = OverLitTc + +type instance XXOverLit (GhcPass _) = PlaceHolder -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -119,8 +151,9 @@ negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" -overLitType :: HsOverLit p -> PostTc p Type -overLitType = ol_type +overLitType :: HsOverLit GhcTc -> Type +overLitType (OverLit (OverLitTc _ ty) _ _) = ty +overLitType XOverLit{} = panic "overLitType" -- | Convert a literal from one index type to another, updating the annotations -- according to the relevant 'Convertable' instance @@ -138,6 +171,7 @@ convertLit (HsInteger a x b) = (HsInteger (convert a) x b) convertLit (HsRat a x b) = (HsRat (convert a) x b) convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) +convertLit (XLit a) = (XLit (convert a)) {- Note [ol_rebindable] @@ -171,8 +205,10 @@ found to have. -- Comparison operations are needed when grouping literals -- for compiling pattern-matching (module MatchLit) -instance Eq (HsOverLit p) where - (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2 +instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where + (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 + (XOverLit val1) == (XOverLit val2) = val1 == val2 + _ == _ = panic "Eq HsOverLit" instance Eq OverLitVal where (HsIntegral i1) == (HsIntegral i2) = i1 == i2 @@ -180,8 +216,10 @@ instance Eq OverLitVal where (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 _ == _ = False -instance Ord (HsOverLit p) where - compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2 +instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where + compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2 + compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 + compare _ _ = panic "Ord HsOverLit" instance Ord OverLitVal where compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 @@ -195,7 +233,7 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsFractional _) = GT -- Instance specific to GhcPs, need the SourceText -instance (SourceTextX x) => Outputable (HsLit x) where +instance (SourceTextX (GhcPass x)) => Outputable (HsLit (GhcPass x)) where ppr (HsChar st c) = pprWithSourceText (getSourceText st) (pprHsChar c) ppr (HsCharPrim st c) = pp_st_suffix (getSourceText st) primCharSuffix (pprPrimChar c) @@ -217,16 +255,18 @@ instance (SourceTextX x) => Outputable (HsLit x) where = pp_st_suffix (getSourceText st) primInt64Suffix (pprPrimInt64 i) ppr (HsWord64Prim st w) = pp_st_suffix (getSourceText st) primWord64Suffix (pprPrimWord64 w) + ppr (XLit x) = ppr x pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc pp_st_suffix NoSourceText _ doc = doc pp_st_suffix (SourceText st) suffix _ = text st <> suffix -- in debug mode, print the expression that it's resolved to, too -instance (SourceTextX p, OutputableBndrId p) - => Outputable (HsOverLit p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsOverLit (GhcPass p)) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (whenPprDebug (parens (pprExpr witness))) + ppr (XOverLit x) = ppr x instance Outputable OverLitVal where ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) @@ -239,7 +279,7 @@ instance Outputable OverLitVal where -- mainly for too reasons: -- * We do not want to expose their internal representation -- * The warnings become too messy -pmPprHsLit :: (SourceTextX x) => HsLit x -> SDoc +pmPprHsLit :: (SourceTextX (GhcPass x)) => HsLit (GhcPass x) -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c pmPprHsLit (HsString st s) = pprWithSourceText (getSourceText st) @@ -254,3 +294,4 @@ pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d +pmPprHsLit (XLit x) = ppr x diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index e05d8bbf68..863f00c99b 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -15,6 +15,7 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} module HsPat ( Pat(..), InPat, OutPat, LPat, @@ -49,6 +50,7 @@ import HsExtension import HsTypes import TcEvidence import BasicTypes +import PlaceHolder -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn @@ -78,42 +80,49 @@ type LPat p = Located (Pat p) -- For details on above see note [Api annotations] in ApiAnnotation data Pat p = ------------ Simple patterns --------------- - WildPat (PostTc p Type) -- ^ Wildcard Pattern + WildPat (XWildPat p) -- ^ Wildcard Pattern -- The sole reason for a type on a WildPat is to -- support hsPatType :: Pat Id -> Type -- AZ:TODO above comment needs to be updated - | VarPat (Located (IdP p)) -- ^ Variable Pattern + | VarPat (XVarPat p) + (Located (IdP p)) -- ^ Variable Pattern -- See Note [Located RdrNames] in HsExpr - | LazyPat (LPat p) -- ^ Lazy Pattern + | LazyPat (XLazyPat p) + (LPat p) -- ^ Lazy Pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' -- For details on above see note [Api annotations] in ApiAnnotation - | AsPat (Located (IdP p)) (LPat p) -- ^ As pattern + | AsPat (XAsPat p) + (Located (IdP p)) (LPat p) -- ^ As pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | ParPat (LPat p) -- ^ Parenthesised pattern + | ParPat (XParPat p) + (LPat p) -- ^ Parenthesised pattern -- See Note [Parens in HsSyn] in HsExpr -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | BangPat (LPat p) -- ^ Bang pattern + | BangPat (XBangPat p) + (LPat p) -- ^ Bang pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' -- For details on above see note [Api annotations] in ApiAnnotation ------------ Lists, tuples, arrays --------------- - | ListPat [LPat p] + | ListPat (XListPat p) + [LPat p] (PostTc p Type) -- The type of the elements (Maybe (PostTc p Type, SyntaxExpr p)) -- For rebindable syntax -- For OverloadedLists a Just (ty,fn) gives -- overall type of the pattern, and the toList - -- function to convert the scrutinee to a list value +-- function to convert the scrutinee to a list value + -- ^ Syntactic List -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, @@ -121,12 +130,13 @@ data Pat p -- For details on above see note [Api annotations] in ApiAnnotation - | TuplePat [LPat p] -- Tuple sub-patterns + | TuplePat (XTuplePat p) + -- after typechecking, holds the types of the tuple components + [LPat p] -- Tuple sub-patterns Boxity -- UnitPat is TuplePat [] - [PostTc p Type] -- [] before typechecker, filled in afterwards - -- with the types of the tuple components - -- You might think that the PostTc p Type was redundant, because we can - -- get the pattern type by getting the types of the sub-patterns. + -- You might think that the post typechecking Type was redundant, + -- because we can get the pattern type by getting the types of the + -- sub-patterns. -- But it's essential -- data T a where -- T1 :: Int -> T Int @@ -146,12 +156,12 @@ data Pat p -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ - | SumPat (LPat p) -- Sum sub-pattern - ConTag -- Alternative (one-based) - Arity -- Arity (INVARIANT: ≥ 2) - (PostTc p [Type]) -- PlaceHolder before typechecker, filled in + | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in -- afterwards with the types of the -- alternative + (LPat p) -- Sum sub-pattern + ConTag -- Alternative (one-based) + Arity -- Arity (INVARIANT: ≥ 2) -- ^ Anonymous sum pattern -- -- - 'ApiAnnotation.AnnKeywordId' : @@ -159,8 +169,8 @@ data Pat p -- 'ApiAnnotation.AnnClose' @'#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | PArrPat [LPat p] -- Syntactic parallel array - (PostTc p Type) -- The type of the elements + | PArrPat (XPArrPat p) -- After typechecking, the type of the elements + [LPat p] -- Syntactic parallel array -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnClose' @':]'@ @@ -195,11 +205,11 @@ data Pat p -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | ViewPat (LHsExpr p) + | ViewPat (XViewPat p) -- The overall type of the pattern + -- (= the argument type of the view function) + -- for hsPatType. + (LHsExpr p) (LPat p) - (PostTc p Type) -- The overall type of the pattern - -- (= the argument type of the view function) - -- for hsPatType. -- ^ View Pattern ------------ Pattern splices --------------- @@ -207,31 +217,34 @@ data Pat p -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | SplicePat (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + | SplicePat (XSplicePat p) + (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) ------------ Literal and n+k patterns --------------- - | LitPat (HsLit p) -- ^ Literal Pattern + | LitPat (XLitPat p) + (HsLit p) -- ^ Literal Pattern -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. | NPat -- Natural Pattern -- Used for all overloaded literals, -- including overloaded strings with -XOverloadedStrings + (XNPat p) -- Overall type of pattern. Might be + -- different than the literal's type + -- if (==) or negate changes the type (Located (HsOverLit p)) -- ALWAYS positive (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for -- negative patterns, Nothing -- otherwise (SyntaxExpr p) -- Equality checker, of type t->t->Bool - (PostTc p Type) -- Overall type of pattern. Might be - -- different than the literal's type - -- if (==) or negate changes the type -- ^ Natural Pattern -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ -- For details on above see note [Api annotations] in ApiAnnotation - | NPlusKPat (Located (IdP p)) -- n+k pattern + | NPlusKPat (XNPlusKPat p) -- Type of overall pattern + (Located (IdP p)) -- n+k pattern (Located (HsOverLit p)) -- It'll always be an HsIntegral (HsOverLit p) -- See Note [NPlusK patterns] in TcPat -- NB: This could be (PostTc ...), but that induced a @@ -239,24 +252,22 @@ data Pat p (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) - (PostTc p Type) -- Type of overall pattern -- ^ n+k pattern ------------ Pattern type signatures --------------- -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SigPatIn (LPat p) -- Pattern with a type signature - (LHsSigWcType p) -- Signature can bind both - -- kind and type vars - -- ^ Pattern with a type signature - - | SigPatOut (LPat p) - Type + | SigPat (XSigPat p) -- Before typechecker + -- Signature can bind both + -- kind and type vars + -- After typechecker: Type + (LPat p) -- Pattern with a type signature -- ^ Pattern with a type signature ------------ Pattern coercions (translation only) --------------- - | CoPat HsWrapper -- Coercion Pattern + | CoPat (XCoPat p) + HsWrapper -- Coercion Pattern -- If co :: t1 ~ t2, p :: t2, -- then (CoPat co p) :: t1 (Pat p) -- Why not LPat? Ans: existing locn will do @@ -264,7 +275,65 @@ data Pat p -- During desugaring a (CoPat co pat) turns into a cast with 'co' on -- the scrutinee, followed by a match on 'pat' -- ^ Coercion Pattern -deriving instance (DataId p) => Data (Pat p) + + -- | Trees that Grow extension point for new constructors + | XPat + (XXPat p) +deriving instance (DataIdLR p p) => Data (Pat p) + +-- --------------------------------------------------------------------- + +type instance XWildPat GhcPs = PlaceHolder +type instance XWildPat GhcRn = PlaceHolder +type instance XWildPat GhcTc = Type + +type instance XVarPat (GhcPass _) = PlaceHolder +type instance XLazyPat (GhcPass _) = PlaceHolder +type instance XAsPat (GhcPass _) = PlaceHolder +type instance XParPat (GhcPass _) = PlaceHolder +type instance XBangPat (GhcPass _) = PlaceHolder + +-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap +-- compiler, as it triggers https://ghc.haskell.org/trac/ghc/ticket/14396 for +-- `SyntaxExpr` +type instance XListPat (GhcPass _) = PlaceHolder + +type instance XTuplePat GhcPs = PlaceHolder +type instance XTuplePat GhcRn = PlaceHolder +type instance XTuplePat GhcTc = [Type] + +type instance XSumPat GhcPs = PlaceHolder +type instance XSumPat GhcRn = PlaceHolder +type instance XSumPat GhcTc = [Type] + +type instance XPArrPat GhcPs = PlaceHolder +type instance XPArrPat GhcRn = PlaceHolder +type instance XPArrPat GhcTc = Type + +type instance XViewPat GhcPs = PlaceHolder +type instance XViewPat GhcRn = PlaceHolder +type instance XViewPat GhcTc = Type + +type instance XSplicePat (GhcPass _) = PlaceHolder +type instance XLitPat (GhcPass _) = PlaceHolder + +type instance XNPat GhcPs = PlaceHolder +type instance XNPat GhcRn = PlaceHolder +type instance XNPat GhcTc = Type + +type instance XNPlusKPat GhcPs = PlaceHolder +type instance XNPlusKPat GhcRn = PlaceHolder +type instance XNPlusKPat GhcTc = Type + +type instance XSigPat GhcPs = (LHsSigWcType GhcPs) +type instance XSigPat GhcRn = (LHsSigWcType GhcRn) +type instance XSigPat GhcTc = Type + +type instance XCoPat (GhcPass _) = PlaceHolder +type instance XXPat (GhcPass _) = PlaceHolder + +-- --------------------------------------------------------------------- + -- | Haskell Constructor Pattern Details type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) @@ -382,24 +451,24 @@ data HsRecField' id arg = HsRecField { -- -- See also Note [Disambiguating record fields] in TcExpr. -hsRecFields :: HsRecFields p arg -> [PostRn p (IdP p)] +hsRecFields :: HsRecFields p arg -> [XFieldOcc p] hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) -- Probably won't typecheck at once, things have changed :/ hsRecFieldsArgs :: HsRecFields p arg -> [arg] hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) -hsRecFieldSel :: HsRecField pass arg -> Located (PostRn pass (IdP pass)) -hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl +hsRecFieldSel :: HsRecField pass arg -> Located (XFieldOcc pass) +hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField p -> Located RdrName +hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id -hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc +hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl @@ -413,8 +482,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (Pat pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (Pat (GhcPass p)) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -426,10 +495,12 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (SourceTextX pass, OutputableBndrId pass) => LPat pass -> SDoc +pprParendLPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LPat (GhcPass p) -> SDoc pprParendLPat (L _ p) = pprParendPat p -pprParendPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc +pprParendPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Pat (GhcPass p) -> SDoc pprParendPat p = sdocWithDynFlags $ \ dflags -> if need_parens dflags p then parens (pprPat p) @@ -443,29 +514,31 @@ pprParendPat p = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (SourceTextX pass, OutputableBndrId pass) => Pat pass -> SDoc -pprPat (VarPat (L _ var)) = pprPatBndr var +pprPat :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Pat (GhcPass p) -> SDoc +pprPat (VarPat _ (L _ var)) = pprPatBndr var pprPat (WildPat _) = char '_' -pprPat (LazyPat pat) = char '~' <> pprParendLPat pat -pprPat (BangPat pat) = char '!' <> pprParendLPat pat -pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] -pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] -pprPat (ParPat pat) = parens (ppr pat) -pprPat (LitPat s) = ppr s -pprPat (NPat l Nothing _ _) = ppr l -pprPat (NPat l (Just _) _ _) = char '-' <> ppr l -pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k] -pprPat (SplicePat splice) = pprSplice splice -pprPat (CoPat co pat _) = pprHsWrapper co (\parens -> if parens +pprPat (LazyPat _ pat) = char '~' <> pprParendLPat pat +pprPat (BangPat _ pat) = char '!' <> pprParendLPat pat +pprPat (AsPat _ name pat) = hcat [ pprPrefixOcc (unLoc name), char '@' + , pprParendLPat pat] +pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] +pprPat (ParPat _ pat) = parens (ppr pat) +pprPat (LitPat _ s) = ppr s +pprPat (NPat _ l Nothing _) = ppr l +pprPat (NPat _ l (Just _) _) = char '-' <> ppr l +pprPat (NPlusKPat _ n k _ _ _)= hcat [ppr n, char '+', ppr k] +pprPat (SplicePat _ splice) = pprSplice splice +pprPat (CoPat _ co pat _) = pprHsWrapper co (\parens -> if parens then pprParendPat pat else pprPat pat) -pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (ListPat pats _ _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) -pprPat (TuplePat pats bx _) = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) -pprPat (SumPat pat alt arity _) = sumParens (pprAlternative ppr pat alt arity) -pprPat (ConPatIn con details) = pprUserCon (unLoc con) details +pprPat (SigPat ty pat) = ppr pat <+> dcolon <+> ppr ty +pprPat (ListPat _ pats _ _) = brackets (interpp'SP pats) +pprPat (PArrPat _ pats) = paBrackets (interpp'SP pats) +pprPat (TuplePat _ pats bx) + = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) +pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) +pprPat (ConPatIn con details) = pprUserCon (unLoc con) details pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, pat_binds = binds, pat_args = details }) = sdocWithDynFlags $ \dflags -> @@ -478,14 +551,16 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, , ppr binds]) <+> pprConArgs details else pprUserCon (unLoc con) details +pprPat (XPat x) = ppr x - -pprUserCon :: (SourceTextX p, OutputableBndr con, OutputableBndrId p) - => con -> HsConPatDetails p -> SDoc +pprUserCon :: (SourceTextX (GhcPass p), OutputableBndr con, + OutputableBndrId (GhcPass p)) + => con -> HsConPatDetails (GhcPass p) -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (SourceTextX p, OutputableBndrId p) => HsConPatDetails p -> SDoc +pprConArgs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsConPatDetails (GhcPass p) -> SDoc pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] pprConArgs (RecCon rpats) = ppr rpats @@ -524,9 +599,12 @@ mkPrefixConPat dc pats tys mkNilPat :: Type -> OutPat p mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] -mkCharLitPat :: (SourceTextX p) => SourceText -> Char -> OutPat p +mkCharLitPat :: (SourceTextX (GhcPass p)) + => SourceText -> Char -> OutPat (GhcPass p) mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat (HsCharPrim (setSourceText src) c)] [] + [noLoc $ LitPat noExt + (HsCharPrim (setSourceText src) c)] + [] {- ************************************************************************ @@ -561,7 +639,7 @@ The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. -} isBangedLPat :: LPat p -> Bool -isBangedLPat (L _ (ParPat p)) = isBangedLPat p +isBangedLPat (L _ (ParPat _ p)) = isBangedLPat p isBangedLPat (L _ (BangPat {})) = True isBangedLPat _ = False @@ -579,8 +657,8 @@ looksLazyPatBind _ = False looksLazyLPat :: LPat p -> Bool -looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p -looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p +looksLazyLPat (L _ (ParPat _ p)) = looksLazyLPat p +looksLazyLPat (L _ (AsPat _ _ p)) = looksLazyLPat p looksLazyLPat (L _ (BangPat {})) = False looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False @@ -607,15 +685,14 @@ isIrrefutableHsPat pat go1 (WildPat {}) = True go1 (VarPat {}) = True go1 (LazyPat {}) = True - go1 (BangPat pat) = go pat - go1 (CoPat _ pat _) = go1 pat - go1 (ParPat pat) = go pat - go1 (AsPat _ pat) = go pat - go1 (ViewPat _ pat _) = go pat - go1 (SigPatIn pat _) = go pat - go1 (SigPatOut pat _) = go pat - go1 (TuplePat pats _ _) = all go pats - go1 (SumPat _ _ _ _) = False + go1 (BangPat _ pat) = go pat + go1 (CoPat _ _ pat _) = go1 pat + go1 (ParPat _ pat) = go pat + go1 (AsPat _ _ pat) = go pat + go1 (ViewPat _ _ pat) = go pat + go1 (SigPat _ pat) = go pat + go1 (TuplePat _ pats _) = all go pats + go1 (SumPat {}) = False -- See Note [Unboxed sum patterns aren't irrefutable] go1 (ListPat {}) = False go1 (PArrPat {}) = False -- ? @@ -637,6 +714,8 @@ isIrrefutableHsPat pat -- since we cannot know until the splice is evaluated. go1 (SplicePat {}) = False + go1 (XPat {}) = False + {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as @@ -664,10 +743,9 @@ hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (SplicePat {}) = False hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p) -hsPatNeedsParens (SigPatIn {}) = True -hsPatNeedsParens (SigPatOut {}) = True +hsPatNeedsParens (SigPat {}) = True hsPatNeedsParens (ViewPat {}) = True -hsPatNeedsParens (CoPat _ p _) = hsPatNeedsParens p +hsPatNeedsParens (CoPat _ _ p _) = hsPatNeedsParens p hsPatNeedsParens (WildPat {}) = False hsPatNeedsParens (VarPat {}) = False hsPatNeedsParens (LazyPat {}) = False @@ -680,6 +758,7 @@ hsPatNeedsParens (ListPat {}) = False hsPatNeedsParens (PArrPat {}) = False hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False +hsPatNeedsParens (XPat {}) = True -- conservative default conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens (PrefixCon {}) = False @@ -691,30 +770,29 @@ conPatNeedsParens (RecCon {}) = False -} -- May need to add more cases -collectEvVarsPats :: [Pat p] -> Bag EvVar +collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar collectEvVarsPats = unionManyBags . map collectEvVarsPat -collectEvVarsLPat :: LPat p -> Bag EvVar +collectEvVarsLPat :: LPat GhcTc -> Bag EvVar collectEvVarsLPat (L _ pat) = collectEvVarsPat pat -collectEvVarsPat :: Pat p -> Bag EvVar +collectEvVarsPat :: Pat GhcTc -> Bag EvVar collectEvVarsPat pat = case pat of - LazyPat p -> collectEvVarsLPat p - AsPat _ p -> collectEvVarsLPat p - ParPat p -> collectEvVarsLPat p - BangPat p -> collectEvVarsLPat p - ListPat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps - TuplePat ps _ _ -> unionManyBags $ map collectEvVarsLPat ps - SumPat p _ _ _ -> collectEvVarsLPat p - PArrPat ps _ -> unionManyBags $ map collectEvVarsLPat ps + LazyPat _ p -> collectEvVarsLPat p + AsPat _ _ p -> collectEvVarsLPat p + ParPat _ p -> collectEvVarsLPat p + BangPat _ p -> collectEvVarsLPat p + ListPat _ ps _ _ -> unionManyBags $ map collectEvVarsLPat ps + TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps + SumPat _ p _ _ -> collectEvVarsLPat p + PArrPat _ ps -> unionManyBags $ map collectEvVarsLPat ps ConPatOut {pat_dicts = dicts, pat_args = args} - -> unionBags (listToBag dicts) + -> unionBags (listToBag dicts) $ unionManyBags $ map collectEvVarsLPat $ hsConPatArgs args - SigPatOut p _ -> collectEvVarsLPat p - CoPat _ p _ -> collectEvVarsPat p - ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" - SigPatIn _ _ -> panic "foldMapPatBag: SigPatIn" - _other_pat -> emptyBag + SigPat _ p -> collectEvVarsLPat p + CoPat _ _ p _ -> collectEvVarsPat p + ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" + _other_pat -> emptyBag diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index 8cb82ed22e..eb090bdd8f 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -4,17 +4,19 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE FlexibleInstances #-} module HsPat where import SrcLoc( Located ) import Data.Data hiding (Fixity) import Outputable -import HsExtension ( SourceTextX, DataId, OutputableBndrId ) +import HsExtension ( SourceTextX, DataIdLR, OutputableBndrId, GhcPass ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) -instance (DataId p) => Data (Pat p) -instance (SourceTextX pass, OutputableBndrId pass) => Outputable (Pat pass) +instance (DataIdLR p p) => Data (Pat p) +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (Pat (GhcPass p)) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 62bfa2e5c5..4a3eca31c6 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -15,6 +15,7 @@ therefore, is almost nothing but re-exporting. {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} module HsSyn ( module HsBinds, @@ -110,10 +111,10 @@ data HsModule name -- hsmodImports,hsmodDecls if this style is used. -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId name) => Data (HsModule name) +deriving instance (DataIdLR name name) => Data (HsModule name) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsModule pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsModule (GhcPass p)) where ppr (HsModule Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index f5b4149f99..be70fe8ec8 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -15,9 +15,10 @@ HsTypes: Abstract syntax: user-defined types -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module HsTypes ( - HsType(..), LHsType, HsKind, LHsKind, + HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsImplicitBndrs(..), @@ -44,7 +45,7 @@ module HsTypes ( rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, - HsWildCardInfo(..), mkAnonWildCardTy, + HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard, wildCardName, sameWildCard, mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, @@ -73,8 +74,9 @@ import GhcPrelude import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import PlaceHolder ( PlaceHolder(..) ) +import PlaceHolder ( PlaceHolder, placeHolder ) import HsExtension +import HsLit () -- for instances import Id ( Id ) import Name( Name ) @@ -110,11 +112,11 @@ type LBangType pass = Located (BangType pass) type BangType pass = HsType pass -- Bangs are in the HsType data type getBangType :: LHsType a -> LHsType a -getBangType (L _ (HsBangTy _ ty)) = ty -getBangType ty = ty +getBangType (L _ (HsBangTy _ _ ty)) = ty +getBangType ty = ty getBangStrictness :: LHsType a -> HsSrcBang -getBangStrictness (L _ (HsBangTy s _)) = s +getBangStrictness (L _ (HsBangTy _ s _)) = s getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) {- @@ -270,11 +272,11 @@ data LHsQTyVars pass -- See Note [HsType binders] -- See Note [Dependent LHsQTyVars] in TcHsType } -deriving instance (DataId pass) => Data (LHsQTyVars pass) +deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass) mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs -mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs - , hsq_dependent = PlaceHolder } +mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs + , hsq_dependent = placeHolder } hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] hsQTvExplicit = hsq_explicit @@ -364,12 +366,12 @@ the explicitly forall'd tyvar 'a' is bound by the HsForAllTy mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing mkHsImplicitBndrs x = HsIB { hsib_body = x - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder } + , hsib_vars = placeHolder + , hsib_closed = placeHolder } mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x - , hswc_wcs = PlaceHolder } + , hswc_wcs = placeHolder } -- Add empty binders. This is a bit suspicious; what if -- the wrapped thing had free type variables? @@ -405,9 +407,11 @@ instance OutputableBndr HsIPName where -- | Haskell Type Variable Binder data HsTyVarBndr pass = UserTyVar -- no explicit kinding + (XUserTyVar pass) (Located (IdP pass)) -- See Note [Located RdrNames] in HsExpr | KindedTyVar + (XKindedTyVar pass) (Located (IdP pass)) (LHsKind pass) -- The user-supplied kind signature -- ^ @@ -415,12 +419,20 @@ data HsTyVarBndr pass -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (HsTyVarBndr pass) + + | XTyVarBndr + (XXTyVarBndr pass) +deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass) + +type instance XUserTyVar (GhcPass _) = PlaceHolder +type instance XKindedTyVar (GhcPass _) = PlaceHolder +type instance XXTyVarBndr (GhcPass _) = PlaceHolder -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr pass -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True +isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar" -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars pass -> Bool @@ -429,19 +441,22 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -- | Haskell Type data HsType pass = HsForAllTy -- See Note [HsType binders] - { hst_bndrs :: [LHsTyVarBndr pass] + { hst_xforall :: XForAllTy pass, + hst_bndrs :: [LHsTyVarBndr pass] -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType pass -- body type + , hst_body :: LHsType pass -- body type } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation | HsQualTy -- See Note [HsType binders] - { hst_ctxt :: LHsContext pass -- Context C => blah - , hst_body :: LHsType pass } + { hst_xqual :: XQualTy pass + , hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } - | HsTyVar Promoted -- whether explicitly promoted, for the pretty + | HsTyVar (XTyVar pass) + Promoted -- whether explicitly promoted, for the pretty -- printer (Located (IdP pass)) -- Type variable, type constructor, or data constructor @@ -451,53 +466,62 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsAppsTy [LHsAppType pass] -- Used only before renaming, + | HsAppsTy (XAppsTy pass) + [LHsAppType pass] -- Used only before renaming, -- Note [HsAppsTy] -- ^ - 'ApiAnnotation.AnnKeywordId' : None - | HsAppTy (LHsType pass) + | HsAppTy (XAppTy pass) + (LHsType pass) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsFunTy (LHsType pass) -- function type + | HsFunTy (XFunTy pass) + (LHsType pass) -- function type (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', -- For details on above see note [Api annotations] in ApiAnnotation - | HsListTy (LHsType pass) -- Element type + | HsListTy (XListTy pass) + (LHsType pass) -- Element type -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, -- 'ApiAnnotation.AnnClose' @']'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsPArrTy (LHsType pass) -- Elem. type of parallel array: [:t:] + | HsPArrTy (XPArrTy pass) + (LHsType pass) -- Elem. type of parallel array: [:t:] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'[:'@, -- 'ApiAnnotation.AnnClose' @':]'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsTupleTy HsTupleSort + | HsTupleTy (XTupleTy pass) + HsTupleSort [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, -- 'ApiAnnotation.AnnClose' @')' or '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsSumTy [LHsType pass] -- Element types (length gives arity) + | HsSumTy (XSumTy pass) + [LHsType pass] -- Element types (length gives arity) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, -- 'ApiAnnotation.AnnClose' '#)'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsOpTy (LHsType pass) (Located (IdP pass)) (LHsType pass) + | HsOpTy (XOpTy pass) + (LHsType pass) (Located (IdP pass)) (LHsType pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsParTy (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr + | HsParTy (XParTy pass) + (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, @@ -505,7 +529,8 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsIParamTy (Located HsIPName) -- (?x :: ty) + | HsIParamTy (XIParamTy pass) + (Located HsIPName) -- (?x :: ty) (LHsType pass) -- Implicit parameters as they occur in -- contexts -- ^ @@ -515,7 +540,8 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsEqTy (LHsType pass) -- ty1 ~ ty2 + | HsEqTy (XEqTy pass) + (LHsType pass) -- ty1 ~ ty2 (LHsType pass) -- Always allowed even without -- TypeOperators, and has special -- kinding rule @@ -526,7 +552,8 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsKindSig (LHsType pass) -- (ty :: kind) + | HsKindSig (XKindSig pass) + (LHsType pass) -- (ty :: kind) (LHsKind pass) -- A type with a kind signature -- ^ -- > (ty :: kind) @@ -536,19 +563,21 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceTy (HsSplice pass) -- Includes quasi-quotes - (PostTc pass Kind) + | HsSpliceTy (XSpliceTy pass) + (HsSplice pass) -- Includes quasi-quotes -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsDocTy (LHsType pass) LHsDocString -- A documented type + | HsDocTy (XDocTy pass) + (LHsType pass) LHsDocString -- A documented type -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsBangTy HsSrcBang (LHsType pass) -- Bang-style type annotations + | HsBangTy (XBangTy pass) + HsSrcBang (LHsType pass) -- Bang-style type annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, -- 'ApiAnnotation.AnnClose' @'#-}'@ @@ -556,21 +585,22 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation - | HsRecTy [LConDeclField pass] -- Only in data type declarations + | HsRecTy (XRecTy pass) + [LConDeclField pass] -- Only in data type declarations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, -- 'ApiAnnotation.AnnClose' @'}'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreTy Type -- An escape hatch for tunnelling a *closed* - -- Core Type through HsSyn. - -- ^ - 'ApiAnnotation.AnnKeywordId' : None + -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* + -- -- Core Type through HsSyn. + -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitListTy -- A promoted explicit list + (XExplicitListTy pass) Promoted -- whether explcitly promoted, for pretty printer - (PostTc pass Kind) -- See Note [Promoted lists and tuples] [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, -- 'ApiAnnotation.AnnClose' @']'@ @@ -578,24 +608,78 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitTupleTy -- A promoted explicit tuple - [PostTc pass Kind] -- See Note [Promoted lists and tuples] + (XExplicitTupleTy pass) [LHsType pass] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, -- 'ApiAnnotation.AnnClose' @')'@ -- For details on above see note [Api annotations] in ApiAnnotation - | HsTyLit HsTyLit -- A promoted numeric literal. + | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation - | HsWildCardTy (HsWildCardInfo pass) -- A type wildcard + | HsWildCardTy (XWildCardTy pass) -- A type wildcard -- See Note [The wildcard story for types] -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (HsType pass) + + -- For adding new constructors via Trees that Grow + | XHsType + (XXType pass) +deriving instance (DataIdLR pass pass) => Data (HsType pass) + +data NewHsTypeX + = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. + deriving Data + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + +instance Outputable NewHsTypeX where + ppr (NHsCoreTy ty) = ppr ty + +type instance XForAllTy (GhcPass _) = PlaceHolder +type instance XQualTy (GhcPass _) = PlaceHolder +type instance XTyVar (GhcPass _) = PlaceHolder +type instance XAppsTy (GhcPass _) = PlaceHolder +type instance XAppTy (GhcPass _) = PlaceHolder +type instance XFunTy (GhcPass _) = PlaceHolder +type instance XListTy (GhcPass _) = PlaceHolder +type instance XPArrTy (GhcPass _) = PlaceHolder +type instance XTupleTy (GhcPass _) = PlaceHolder +type instance XSumTy (GhcPass _) = PlaceHolder +type instance XOpTy (GhcPass _) = PlaceHolder +type instance XParTy (GhcPass _) = PlaceHolder +type instance XIParamTy (GhcPass _) = PlaceHolder +type instance XEqTy (GhcPass _) = PlaceHolder +type instance XKindSig (GhcPass _) = PlaceHolder + +type instance XSpliceTy GhcPs = PlaceHolder +type instance XSpliceTy GhcRn = PlaceHolder +type instance XSpliceTy GhcTc = Kind + +type instance XDocTy (GhcPass _) = PlaceHolder +type instance XBangTy (GhcPass _) = PlaceHolder +type instance XRecTy (GhcPass _) = PlaceHolder + +type instance XExplicitListTy GhcPs = PlaceHolder +type instance XExplicitListTy GhcRn = PlaceHolder +type instance XExplicitListTy GhcTc = Kind + +type instance XExplicitTupleTy GhcPs = PlaceHolder +type instance XExplicitTupleTy GhcRn = PlaceHolder +type instance XExplicitTupleTy GhcTc = [Kind] + +type instance XTyLit (GhcPass _) = PlaceHolder + +type instance XWildCardTy GhcPs = PlaceHolder +type instance XWildCardTy GhcRn = HsWildCardInfo GhcRn +type instance XWildCardTy GhcTc = HsWildCardInfo GhcTc + +type instance XXType (GhcPass _) = NewHsTypeX + -- Note [Literal source text] in BasicTypes for SourceText fields in -- the following @@ -605,7 +689,8 @@ data HsTyLit | HsStrTy SourceText FastString deriving Data -newtype HsWildCardInfo pass -- See Note [The wildcard story for types] +-- AZ: fold this into the XWildCardTy completely, removing the type +newtype HsWildCardInfo pass -- See Note [The wildcard story for types] = AnonWildCard (PostRn pass (Located Name)) -- A anonymous wild card ('_'). A fresh Name is generated for -- each individual anonymous wildcard during renaming @@ -617,12 +702,21 @@ type LHsAppType pass = Located (HsAppType pass) -- | Haskell Application Type data HsAppType pass - = HsAppInfix (Located (IdP pass)) -- either a symbol or an id in backticks - | HsAppPrefix (LHsType pass) -- anything else, including things like (+) -deriving instance (DataId pass) => Data (HsAppType pass) + = HsAppInfix (XAppInfix pass) + (Located (IdP pass)) -- either a symbol or an id in backticks + | HsAppPrefix (XAppPrefix pass) + (LHsType pass) -- anything else, including things like (+) + + | XAppType + (XXAppType pass) +deriving instance (DataIdLR pass pass) => Data (HsAppType pass) + +type instance XAppInfix (GhcPass _) = PlaceHolder +type instance XAppPrefix (GhcPass _) = PlaceHolder +type instance XXAppType (GhcPass _) = PlaceHolder -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsAppType pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsAppType (GhcPass p)) where ppr = ppr_app_ty {- @@ -764,10 +858,10 @@ data ConDeclField pass -- Record fields have Haddoc docs on them -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (ConDeclField pass) +deriving instance (DataIdLR pass pass) => Data (ConDeclField pass) -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (ConDeclField pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (ConDeclField (GhcPass p)) where ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty -- HsConDetails is used for patterns/expressions *and* for data type @@ -789,11 +883,11 @@ instance (Outputable arg, Outputable rec) -- parser and rejigs them using information about fixities from the renamer. -- See Note [Sorting out the result type] in RdrHsSyn updateGadtResult - :: (Monad m) + :: (Monad m, OutputableX GhcRn) => (SDoc -> m ()) -> SDoc -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) - -- ^ Original details + -- ^ Original details -> LHsType GhcRn -- ^ Original result type -> m (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), LHsType GhcRn) @@ -874,8 +968,9 @@ I don't know if this is a good idea, but there it is. --------------------- hsTyVarName :: HsTyVarBndr pass -> IdP pass -hsTyVarName (UserTyVar (L _ n)) = n -hsTyVarName (KindedTyVar (L _ n) _) = n +hsTyVarName (UserTyVar _ (L _ n)) = n +hsTyVarName (KindedTyVar _ (L _ n) _) = n +hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName" hsLTyVarName :: LHsTyVarBndr pass -> IdP pass hsLTyVarName = hsTyVarName . unLoc @@ -896,15 +991,17 @@ hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr pass -> LHsType pass +hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) hsLTyVarBndrToType = fmap cvt - where cvt (UserTyVar n) = HsTyVar NotPromoted n - cvt (KindedTyVar (L name_loc n) kind) - = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind + where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n + cvt (KindedTyVar _ (L name_loc n) kind) + = HsKindSig noExt + (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind + cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType" -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass] +hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- @@ -917,9 +1014,9 @@ sameWildCard :: Located (HsWildCardInfo pass) sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 ignoreParens :: LHsType pass -> LHsType pass -ignoreParens (L _ (HsParTy ty)) = ignoreParens ty -ignoreParens (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ignoreParens ty -ignoreParens ty = ty +ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty +ignoreParens (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = ignoreParens ty +ignoreParens ty = ty {- ************************************************************************ @@ -930,15 +1027,17 @@ ignoreParens ty = ty -} mkAnonWildCardTy :: HsType GhcPs -mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder) +mkAnonWildCardTy = HsWildCardTy noExt -mkHsOpTy :: LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass -mkHsOpTy ty1 op ty2 = HsOpTy ty1 op ty2 +mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) + -> LHsType (GhcPass p) -> HsType (GhcPass p) +mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2 -mkHsAppTy :: LHsType pass -> LHsType pass -> LHsType pass -mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) +mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy noExt t1 t2) -mkHsAppTys :: LHsType pass -> [LHsType pass] -> LHsType pass +mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] + -> LHsType (GhcPass p) mkHsAppTys = foldl mkHsAppTy @@ -957,36 +1056,37 @@ mkHsAppTys = foldl mkHsAppTy -- Also deals with (->) t1 t2; that is why it only works on LHsType Name -- (see Trac #9096) splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) -splitHsFunType (L _ (HsParTy ty)) +splitHsFunType (L _ (HsParTy _ ty)) = splitHsFunType ty -splitHsFunType (L _ (HsFunTy x y)) +splitHsFunType (L _ (HsFunTy _ x y)) | (args, res) <- splitHsFunType y = (x:args, res) -splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) +splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName + go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName , [t1,t2] <- tys , (args, res) <- splitHsFunType t2 = (t1:args, res) - go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys) - go (L _ (HsParTy ty)) tys = go ty tys - go _ _ = ([], orig_ty) -- Failure to match + go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) + go (L _ (HsParTy _ ty)) tys = go ty tys + go _ _ = ([], orig_ty) -- Failure to match splitHsFunType other = ([], other) -------------------------------- -- | Retrieves the head of an HsAppsTy, if this can be done unambiguously, -- without consulting fixities. -getAppsTyHead_maybe :: [LHsAppType pass] - -> Maybe (LHsType pass, [LHsType pass], LexicalFixity) +getAppsTyHead_maybe :: [LHsAppType (GhcPass p)] + -> Maybe ( LHsType (GhcPass p) + , [LHsType (GhcPass p)], LexicalFixity) getAppsTyHead_maybe tys = case splitHsAppsTy tys of ([app1:apps], []) -> -- no symbols, some normal types Just (mkHsAppTys app1 apps, [], Prefix) ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator - Just ( L loc (HsTyVar NotPromoted (L loc op)) + Just ( L loc (HsTyVar noExt NotPromoted (L loc op)) , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr], Infix) _ -> -- can't figure it out Nothing @@ -1001,35 +1101,36 @@ splitHsAppsTy :: [LHsAppType pass] -> ([[LHsType pass]], [Located (IdP pass)]) splitHsAppsTy = go [] [] [] where go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) - go acc acc_non acc_sym (L _ (HsAppPrefix ty) : rest) + go acc acc_non acc_sym (L _ (HsAppPrefix _ ty) : rest) = go (ty : acc) acc_non acc_sym rest - go acc acc_non acc_sym (L _ (HsAppInfix op) : rest) + go acc acc_non acc_sym (L _ (HsAppInfix _ op) : rest) = go [] (reverse acc : acc_non) (op : acc_sym) rest + go _ _ _ (L _ (XAppType _):_) = panic "splitHsAppsTy" -- Retrieve the name of the "head" of a nested type application -- somewhat like splitHsAppTys, but a little more thorough -- used to examine the result of a GADT-like datacon, so it doesn't handle -- *all* cases (like lists, tuples, (~), etc.) -hsTyGetAppHead_maybe :: LHsType pass - -> Maybe (Located (IdP pass), [LHsType pass]) +hsTyGetAppHead_maybe :: LHsType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)]) hsTyGetAppHead_maybe = go [] where - go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) - go tys (L _ (HsAppsTy apps)) + go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys) + go tys (L _ (HsAppsTy _ apps)) | Just (head, args, _) <- getAppsTyHead_maybe apps - = go (args ++ tys) head - go tys (L _ (HsAppTy l r)) = go (r : tys) l - go tys (L _ (HsOpTy l (L loc n) r)) = Just (L loc n, l : r : tys) - go tys (L _ (HsParTy t)) = go tys t - go tys (L _ (HsKindSig t _)) = go tys t + = go (args ++ tys) head + go tys (L _ (HsAppTy _ l r)) = go (r : tys) l + go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys) + go tys (L _ (HsParTy _ t)) = go tys t + go tys (L _ (HsKindSig _ t _)) = go tys t go _ _ = Nothing splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn] -> (LHsType GhcRn, [LHsType GhcRn]) -- no need to worry about HsAppsTy here -splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) -splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as -splitHsAppTys f as = (f,as) +splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as) +splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as +splitHsAppTys f as = (f,as) -------------------------------- splitLHsPatSynTy :: LHsType pass @@ -1054,12 +1155,12 @@ splitLHsSigmaTy ty splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) -splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t +splitLHsForAllTy (L _ (HsParTy _ t)) = splitLHsForAllTy t splitLHsForAllTy body = ([], body) splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) -splitLHsQualTy (L _ (HsParTy t)) = splitLHsQualTy t +splitLHsQualTy (L _ (HsParTy _ t)) = splitLHsQualTy t splitLHsQualTy body = (noLoc [], body) splitLHsInstDeclTy :: LHsSigType GhcRn @@ -1077,7 +1178,8 @@ getLHsInstDeclHead inst_ty | (_tvs, _cxt, body_ty) <- splitLHsSigmaTy (hsSigType inst_ty) = body_ty -getLHsInstDeclClass_maybe :: LHsSigType pass -> Maybe (Located (IdP pass)) +getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p))) -- Works on (HsSigType RdrName) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty @@ -1100,19 +1202,28 @@ type LFieldOcc pass = Located (FieldOcc pass) -- Represents an *occurrence* of an unambiguous field. We store -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. -data FieldOcc pass = FieldOcc { rdrNameFieldOcc :: Located RdrName +data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass + , rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in HsExpr - , selectorFieldOcc :: PostRn pass (IdP pass) } -deriving instance Eq (PostRn pass (IdP pass)) => Eq (FieldOcc pass) -deriving instance Ord (PostRn pass (IdP pass)) => Ord (FieldOcc pass) + + | XFieldOcc + (XXFieldOcc pass) +deriving instance (Eq (XFieldOcc (GhcPass p))) => Eq (FieldOcc (GhcPass p)) +deriving instance (Ord (XFieldOcc (GhcPass p))) => Ord (FieldOcc (GhcPass p)) deriving instance (DataId pass) => Data (FieldOcc pass) +type instance XFieldOcc GhcPs = PlaceHolder +type instance XFieldOcc GhcRn = Name +type instance XFieldOcc GhcTc = Id + +type instance XXFieldOcc (GhcPass _) = PlaceHolder + instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc rdr PlaceHolder +mkFieldOcc rdr = FieldOcc placeHolder rdr -- | Ambiguous Field Occurrence @@ -1128,34 +1239,51 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr data AmbiguousFieldOcc pass - = Unambiguous (Located RdrName) (PostRn pass (IdP pass)) - | Ambiguous (Located RdrName) (PostTc pass (IdP pass)) + = Unambiguous (XUnambiguous pass) (Located RdrName) + | Ambiguous (XAmbiguous pass) (Located RdrName) + | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) deriving instance DataId pass => Data (AmbiguousFieldOcc pass) -instance Outputable (AmbiguousFieldOcc pass) where +type instance XUnambiguous GhcPs = PlaceHolder +type instance XUnambiguous GhcRn = Name +type instance XUnambiguous GhcTc = Id + +type instance XAmbiguous GhcPs = PlaceHolder +type instance XAmbiguous GhcRn = PlaceHolder +type instance XAmbiguous GhcTc = Id + +type instance XXAmbiguousFieldOcc (GhcPass _) = PlaceHolder + +instance Outputable (AmbiguousFieldOcc (GhcPass p)) where ppr = ppr . rdrNameAmbiguousFieldOcc -instance OutputableBndr (AmbiguousFieldOcc pass) where +instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs -mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder +mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc pass -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName +rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr +rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr +rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) + = panic "rdrNameAmbiguousFieldOcc" selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id -selectorAmbiguousFieldOcc (Unambiguous _ sel) = sel -selectorAmbiguousFieldOcc (Ambiguous _ sel) = sel +selectorAmbiguousFieldOcc (Unambiguous sel _) = sel +selectorAmbiguousFieldOcc (Ambiguous sel _) = sel +selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _) + = panic "selectorAmbiguousFieldOcc" unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel +unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc" -ambiguousFieldOcc :: FieldOcc pass -> AmbiguousFieldOcc pass -ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel +ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc +ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr +ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" {- ************************************************************************ @@ -1165,21 +1293,22 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel ************************************************************************ -} -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsType pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsType (GhcPass p)) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (LHsQTyVars pass) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (LHsQTyVars (GhcPass p)) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (HsTyVarBndr pass) where - ppr (UserTyVar n) = ppr n - ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsTyVarBndr (GhcPass p)) where + ppr (UserTyVar _ n) = ppr n + ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] + ppr (XTyVarBndr n) = ppr n instance (Outputable thing) => Outputable (HsImplicitBndrs pass thing) where ppr (HsIB { hsib_body = ty }) = ppr ty @@ -1190,8 +1319,11 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs pass thing) where instance Outputable (HsWildCardInfo pass) where ppr (AnonWildCard _) = char '_' -pprHsForAll :: (SourceTextX pass, OutputableBndrId pass) - => [LHsTyVarBndr pass] -> LHsContext pass -> SDoc +pprAnonWildCard :: SDoc +pprAnonWildCard = char '_' + +pprHsForAll :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints @@ -1201,44 +1333,44 @@ pprHsForAll = pprHsForAllExtra Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (SourceTextX pass, OutputableBndrId pass) - => Maybe SrcSpan -> [LHsTyVarBndr pass] -> LHsContext pass - -> SDoc +pprHsForAllExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Maybe SrcSpan -> [LHsTyVarBndr (GhcPass p)] + -> LHsContext (GhcPass p) -> SDoc pprHsForAllExtra extra qtvs cxt = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) where show_extra = isJust extra -pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass) - => [LHsTyVarBndr pass] -> SDoc +pprHsForAllTvs :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => [LHsTyVarBndr (GhcPass p)] -> SDoc pprHsForAllTvs qtvs | null qtvs = whenPprDebug (forAllLit <+> dot) | otherwise = forAllLit <+> interppSP qtvs <> dot -pprHsContext :: (SourceTextX pass, OutputableBndrId pass) - => HsContext pass -> SDoc +pprHsContext :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsContext (GhcPass p) -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe -pprHsContextNoArrow :: (SourceTextX pass, OutputableBndrId pass) - => HsContext pass -> SDoc +pprHsContextNoArrow :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsContext (GhcPass p) -> SDoc pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe -pprHsContextMaybe :: (SourceTextX pass, OutputableBndrId pass) - => HsContext pass -> Maybe SDoc +pprHsContextMaybe :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsContext (GhcPass p) -> Maybe SDoc pprHsContextMaybe [] = Nothing pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty pred pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -- For use in a HsQualTy, which always gets printed if it exists. -pprHsContextAlways :: (SourceTextX pass, OutputableBndrId pass) - => HsContext pass -> SDoc +pprHsContextAlways :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsContext (GhcPass p) -> SDoc pprHsContextAlways [] = parens empty <+> darrow pprHsContextAlways [L _ ty] = ppr_mono_ty ty <+> darrow pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (SourceTextX pass, OutputableBndrId pass) - => Bool -> HsContext pass -> SDoc +pprHsContextExtra :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Bool -> HsContext (GhcPass p) -> SDoc pprHsContextExtra show_extra ctxt | not show_extra = pprHsContext ctxt @@ -1249,8 +1381,8 @@ pprHsContextExtra show_extra ctxt where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: (SourceTextX pass, OutputableBndrId pass) - => [LConDeclField pass] -> SDoc +pprConDeclFields :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => [LConDeclField (GhcPass p)] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, @@ -1274,76 +1406,79 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc +pprHsType :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsType (GhcPass p) -> SDoc pprHsType ty = ppr_mono_ty ty -ppr_mono_lty :: (SourceTextX pass, OutputableBndrId pass) - => LHsType pass -> SDoc +ppr_mono_lty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass) - => HsType pass -> SDoc +ppr_mono_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsType (GhcPass p) -> SDoc ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) = sep [pprHsForAllTvs tvs, ppr_mono_lty ty] ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) = sep [pprHsContextAlways ctxt, ppr_mono_lty ty] +ppr_mono_ty (XHsType t) = ppr t -ppr_mono_ty (HsBangTy b ty) = ppr b <> ppr_mono_lty ty -ppr_mono_ty (HsRecTy flds) = pprConDeclFields flds -ppr_mono_ty (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name -ppr_mono_ty (HsTyVar Promoted (L _ name)) +ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty +ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds +ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name +ppr_mono_ty (HsTyVar _ Promoted (L _ name)) = space <> quote (pprPrefixOcc name) -- We need a space before the ' above, so the parser -- does not attach it to the previous symbol -ppr_mono_ty (HsFunTy ty1 ty2) = ppr_fun_ty ty1 ty2 -ppr_mono_ty (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys) +ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 +ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple -ppr_mono_ty (HsSumTy tys) = tupleParens UnboxedTuple (pprWithBars ppr tys) -ppr_mono_ty (HsKindSig ty kind) = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind) -ppr_mono_ty (HsListTy ty) = brackets (ppr_mono_lty ty) -ppr_mono_ty (HsPArrTy ty) = paBrackets (ppr_mono_lty ty) -ppr_mono_ty (HsIParamTy n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) -ppr_mono_ty (HsSpliceTy s _) = pprSplice s -ppr_mono_ty (HsCoreTy ty) = ppr ty -ppr_mono_ty (HsExplicitListTy Promoted _ tys) +ppr_mono_ty (HsSumTy _ tys) + = tupleParens UnboxedTuple (pprWithBars ppr tys) +ppr_mono_ty (HsKindSig _ ty kind) + = parens (ppr_mono_lty ty <+> dcolon <+> ppr kind) +ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) +ppr_mono_ty (HsPArrTy _ ty) = paBrackets (ppr_mono_lty ty) +ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) +ppr_mono_ty (HsSpliceTy _ s) = pprSplice s +ppr_mono_ty (HsExplicitListTy _ Promoted tys) = quote $ brackets (interpp'SP tys) -ppr_mono_ty (HsExplicitListTy NotPromoted _ tys) +ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) = brackets (interpp'SP tys) ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) -ppr_mono_ty (HsTyLit t) = ppr_tylit t -ppr_mono_ty (HsWildCardTy {}) = char '_' +ppr_mono_ty (HsTyLit _ t) = ppr_tylit t +ppr_mono_ty (HsWildCardTy {}) = char '_' -ppr_mono_ty (HsEqTy ty1 ty2) +ppr_mono_ty (HsEqTy _ ty1 ty2) = ppr_mono_lty ty1 <+> char '~' <+> ppr_mono_lty ty2 -ppr_mono_ty (HsAppsTy tys) +ppr_mono_ty (HsAppsTy _ tys) = hsep (map (ppr_app_ty . unLoc) tys) -ppr_mono_ty (HsAppTy fun_ty arg_ty) +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] -ppr_mono_ty (HsOpTy ty1 (L _ op) ty2) +ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) = sep [ ppr_mono_lty ty1 , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] -ppr_mono_ty (HsParTy ty) +ppr_mono_ty (HsParTy _ ty) = parens (ppr_mono_lty ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because -- toHsType doesn't put in any HsParTys, so we may still need them -ppr_mono_ty (HsDocTy ty doc) +ppr_mono_ty (HsDocTy _ ty doc) -- AZ: Should we add parens? Should we introduce "-- ^"? = ppr_mono_lty ty <+> ppr (unLoc doc) -- we pretty print Haddock comments on types as if they were -- postfix operators -------------------------- -ppr_fun_ty :: (SourceTextX pass, OutputableBndrId pass) - => LHsType pass -> LHsType pass -> SDoc +ppr_fun_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc ppr_fun_ty ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2 @@ -1351,16 +1486,17 @@ ppr_fun_ty ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: (SourceTextX pass, OutputableBndrId pass) - => HsAppType pass -> SDoc -ppr_app_ty (HsAppInfix (L _ n)) = pprInfixOcc n -ppr_app_ty (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n)))) +ppr_app_ty :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsAppType (GhcPass p) -> SDoc +ppr_app_ty (HsAppInfix _ (L _ n)) = pprInfixOcc n +ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ NotPromoted (L _ n)))) = pprPrefixOcc n -ppr_app_ty (HsAppPrefix (L _ (HsTyVar Promoted (L _ n)))) +ppr_app_ty (HsAppPrefix _ (L _ (HsTyVar _ Promoted (L _ n)))) = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so -- the parser does not attach it to the -- previous symbol -ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty +ppr_app_ty (HsAppPrefix _ ty) = ppr_mono_lty ty +ppr_app_ty (XAppType ty) = ppr ty -------------------------- ppr_tylit :: HsTyLit -> SDoc diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 8e17994993..e5f0fb6187 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -50,7 +50,7 @@ module HsUtils( -- Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, - nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat, + nlWildPatName, nlTuplePat, mkParPat, nlParPat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types @@ -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,35 +203,35 @@ 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 name -> LPat name -mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) +mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat noExt lp) | otherwise = lp -nlParPat :: LPat name -> LPat name -nlParPat p = noLoc (ParPat p) +nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +nlParPat p = noLoc (ParPat noExt p) ------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral :: IntegralLit -> PostTc GhcPs Type - -> HsOverLit GhcPs -mkHsFractional :: FractionalLit -> PostTc GhcPs Type -> HsOverLit GhcPs -mkHsIsString :: SourceText -> FastString -> PostTc GhcPs Type - -> HsOverLit GhcPs +mkHsIntegral :: IntegralLit -> HsOverLit GhcPs +mkHsFractional :: FractionalLit -> HsOverLit GhcPs +mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs @@ -239,60 +240,72 @@ 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 -mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noExpr -mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr -mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr +mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr +mkHsFractional f = OverLit noExt (HsFractional f) noExpr +mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr noRebindableInfo :: PlaceHolder -noRebindableInfo = PlaceHolder -- Just another placeholder; +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 - -mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType -mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType - -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) +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 (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 , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr - , trS_bind_arg_ty = PlaceHolder + , trS_bind_arg_ty = placeHolder , trS_fmap = noExpr } mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } @@ -301,12 +314,12 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s mkLastStmt body = LastStmt body False noSyntaxExpr mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType -mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder +mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr placeHolder mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy -- don't use placeHolderTypeTc above, because that panics during zonking -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 = [] @@ -325,28 +338,29 @@ 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")) mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e +mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsSpliceE hasParen e = HsSpliceE (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 noExt hasParen unqualSplice e) mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs -mkHsSpliceTy hasParen e - = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind +mkHsSpliceTy hasParen e = HsSpliceTy noExt + (HsUntypedSplice noExt hasParen unqualSplice e) mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs -mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote +mkHsQuasiQuote quoter span quote + = HsQuasiQuote noExt unqualSplice quoter span quote unqualQuasiQuote :: RdrName unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) @@ -361,13 +375,15 @@ mkHsStringPrimLit fs = HsStringPrim noSourceText (fastStringToByteString fs) ------------- -userHsLTyVarBndrs :: SrcSpan -> [Located (IdP name)] -> [LHsTyVarBndr name] +userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] + -> [LHsTyVarBndr (GhcPass p)] -- Caller sets location -userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] +userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt v) | v <- bndrs ] -userHsTyVarBndrs :: SrcSpan -> [IdP name] -> [LHsTyVarBndr name] +userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)] -- Caller sets location -userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] +userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar noExt (L loc v)) + | v <- bndrs ] {- @@ -378,29 +394,30 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] ************************************************************************ -} -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 :: HasDefaultX p => Integer -> LHsExpr p -nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n))) +nlHsIntLit :: Integer -> LHsExpr (GhcPass p) +nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n))) -nlVarPat :: IdP id -> LPat id -nlVarPat n = noLoc (VarPat (noLoc n)) +nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) +nlVarPat n = noLoc (VarPat noExt (noLoc n)) -nlLitPat :: HsLit p -> LPat p -nlLitPat l = noLoc (LitPat l) +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 @@ -412,13 +429,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) @@ -444,50 +462,49 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat))) nlWildPat :: LPat GhcPs -nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking +nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking nlWildPatName :: LPat GhcRn -nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking - -nlWildPatId :: LPat GhcTc -nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking +nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs 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 name -> LHsType name -> LHsType name -nlHsTyVar :: IdP name -> LHsType name -nlHsFunTy :: LHsType name -> LHsType name -> LHsType name -nlHsParTy :: LHsType name -> LHsType name +nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) +nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsAppTy f t = noLoc (HsAppTy f t) -nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy a b) -nlHsParTy t = noLoc (HsParTy t) +nlHsAppTy f t = noLoc (HsAppTy noExt f t) +nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x)) +nlHsFunTy a b = noLoc (HsFunTy noExt a b) +nlHsParTy t = noLoc (HsParTy noExt t) -nlHsTyConApp :: IdP name -> [LHsType name] -> LHsType name +nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys {- @@ -495,37 +512,38 @@ 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 noExt)) es) Boxed -mkLHsVarTuple :: [IdP a] -> LHsExpr a +mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) -nlTuplePat :: [LPat id] -> Boxity -> LPat id -nlTuplePat pats box = noLoc (TuplePat pats box []) +nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs +nlTuplePat pats box = noLoc (TuplePat noExt pats box) missingTupArg :: HsTupArg GhcPs -missingTupArg = Missing placeHolderType +missingTupArg = Missing noExt -mkLHsPatTup :: [LPat id] -> LPat id -mkLHsPatTup [] = noLoc $ TuplePat [] Boxed [] +mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed [] +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 -mkBigLHsVarPatTup :: [IdP id] -> LPat id +mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) -mkBigLHsPatTup :: [LPat id] -> LPat id +mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkBigLHsPatTup = mkChunkified mkLHsPatTup -- $big_tuples @@ -632,16 +650,18 @@ typeToLHsType ty | isPredTy arg , (theta, tau) <- tcSplitPhiTy ty = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) + , hst_xqual = noExt , hst_body = go tau }) go (FunTy arg res) = nlHsFunTy (go arg) (go res) go ty@(ForAllTy {}) | (tvs, tau) <- tcSplitForAllTys ty = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs + , hst_xforall = noExt , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) - go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy noSourceText n) - go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy noSourceText s) + go (LitTy (NumTyLit n)) = noLoc $ HsTyLit noExt (HsNumTy noSourceText n) + go (LitTy (StrTyLit s)) = noLoc $ HsTyLit noExt (HsStrTy noSourceText s) go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where args' = filterOutInvisibleTypes tc args @@ -652,7 +672,7 @@ typeToLHsType ty -- so we must remove them here (Trac #8563) go_tv :: TyVar -> LHsTyVarBndr GhcPs - go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) + go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv)) (go (tyVarKind tv)) @@ -662,41 +682,41 @@ 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 +mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap w cmd + | otherwise = HsCmdWrap noExt w cmd -mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id +mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) -mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id +mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat co_fn p ty + | otherwise = CoPat noExt co_fn p ty -mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id +mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat (mkWpCastN co) pat ty + | otherwise = CoPat noExt (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -769,14 +789,16 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_strictness = NoSrcStrict } ------------ -mkMatch :: HsMatchContext (NameOrRdrName (IdP p)) -> [LPat p] -> LHsExpr p - -> Located (HsLocalBinds p) -> LMatch p (LHsExpr p) +mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) + -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) + -> Located (HsLocalBinds (GhcPass p)) + -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr lbinds = noLoc (Match { m_ctxt = ctxt , m_pats = map paren pats , m_grhss = GRHSs (unguardedRHS noSrcSpan expr) lbinds }) where - paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) + paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat noExt lp) | otherwise = lp {- @@ -864,13 +886,15 @@ isBangedHsBind (PatBind {pat_lhs = pat}) isBangedHsBind _ = False -collectLocalBinders :: HsLocalBindsLR idL idR -> [IdP idL] +collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds -- No pattern synonyms here collectLocalBinders (HsIPBinds _) = [] collectLocalBinders EmptyLocalBinds = [] -collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [IdP idL] +collectHsIdBinders, collectHsValBinders + :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -- Collect Id binders only, or Ids + pattern synonyms, respectively collectHsIdBinders = collect_hs_val_binders True collectHsValBinders = collect_hs_val_binders False @@ -886,9 +910,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL] -- Same as collectHsBindsBinders, but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] -collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [IdP idL] -collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds [] -collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds +collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] +collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) + = collect_out_binds ps binds collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p] collect_out_binds ps = foldr (collect_binds ps . snd) [] @@ -903,7 +929,7 @@ collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds - -- The only time we collect binders from a typechecked + -- binding (hence see AbsBinds) is in zonking in TcHsSyn collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc @@ -918,23 +944,27 @@ collectMethodBinders binds = foldrBag (get . unLoc) [] binds -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: [LStmtLR idL idR body] -> [IdP idL] +collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR idL idR body] -> [IdP idL] +collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR idL idR body -> [IdP idL] +collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR idL idR body -> [IdP idL] +collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders - $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders + $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss collectStmtBinders ApplicativeStmt{} = [] @@ -952,33 +982,33 @@ collect_lpat :: LPat pass -> [IdP pass] -> [IdP pass] collect_lpat (L _ pat) bndrs = go pat where - go (VarPat (L _ var)) = var : bndrs + go (VarPat _ (L _ var)) = var : bndrs go (WildPat _) = bndrs - go (LazyPat pat) = collect_lpat pat bndrs - go (BangPat pat) = collect_lpat pat bndrs - go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs - go (ViewPat _ pat _) = collect_lpat pat bndrs - go (ParPat pat) = collect_lpat pat bndrs + go (LazyPat _ pat) = collect_lpat pat bndrs + go (BangPat _ pat) = collect_lpat pat bndrs + go (AsPat _ (L _ a) pat) = a : collect_lpat pat bndrs + go (ViewPat _ _ pat) = collect_lpat pat bndrs + go (ParPat _ pat) = collect_lpat pat bndrs - go (ListPat pats _ _) = foldr collect_lpat bndrs pats - go (PArrPat pats _) = foldr collect_lpat bndrs pats - go (TuplePat pats _ _) = foldr collect_lpat bndrs pats - go (SumPat pat _ _ _) = collect_lpat pat bndrs + go (ListPat _ pats _ _) = foldr collect_lpat bndrs pats + go (PArrPat _ pats) = foldr collect_lpat bndrs pats + go (TuplePat _ pats _) = foldr collect_lpat bndrs pats + go (SumPat _ pat _ _) = collect_lpat pat bndrs go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] - go (LitPat _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs + go (LitPat _ _) = bndrs + go (NPat {}) = bndrs + go (NPlusKPat _ (L _ n) _ _ _ _)= n : bndrs - go (SigPatIn pat _) = collect_lpat pat bndrs - go (SigPatOut pat _) = collect_lpat pat bndrs + go (SigPat _ pat) = collect_lpat pat bndrs - go (SplicePat (HsSpliced _ (HsSplicedPat pat))) + go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go pat - go (SplicePat _) = bndrs - go (CoPat _ pat _) = go pat + go (SplicePat _ _) = bndrs + go (CoPat _ _ pat _) = go pat + go (XPat {}) = bndrs {- Note [Dictionary binders in ConPatOut] See also same Note in DsArrows @@ -1027,7 +1057,7 @@ hsTyClForeignBinders tycl_decls foreign_decls foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs + getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- hsLTyClDeclBinders :: Located (TyClDecl pass) @@ -1062,11 +1092,11 @@ hsForeignDeclsBinders foreign_decls ------------------- -hsPatSynSelectors :: HsValBinds p -> [IdP p] +hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] -- Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by collectHsValBinders. -hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors" -hsPatSynSelectors (ValBindsOut binds _) +hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (XValBindsLR (NValBinds binds _)) = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] @@ -1123,11 +1153,11 @@ hsConDeclsBinders cons = go id cons L loc (ConDeclGADT { con_names = names , con_type = HsIB { hsib_body = res_ty}}) -> case tau of - L _ (HsFunTy - (L _ (HsAppsTy - [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty) + L _ (HsFunTy _ + (L _ (HsAppsTy _ + [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))])) _) -> record_gadt flds - L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) + L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _res_ty) -> record_gadt flds _other -> (map (L loc . unLoc) names ++ ns, fs) @@ -1188,13 +1218,16 @@ The main purpose is to find names introduced by record wildcards so that we can warning the user when they don't use those names (#4404) -} -lStmtsImplicits :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet +lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] + -> NameSet lStmtsImplicits = hs_lstmts where - hs_lstmts :: [LStmtLR GhcRn idR (Located (body idR))] -> NameSet + hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] + -> NameSet hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet - hs_stmt :: StmtLR GhcRn idR (Located (body idR)) -> NameSet + hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) + -> NameSet hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args) where do_arg (_, ApplicativeArgOne pat _ _) = lPatImplicits pat @@ -1202,7 +1235,8 @@ lStmtsImplicits = hs_lstmts hs_stmt (LetStmt binds) = hs_local_binds (unLoc binds) hs_stmt (BodyStmt {}) = emptyNameSet hs_stmt (LastStmt {}) = emptyNameSet - hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] + hs_stmt (ParStmt xs _ _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs + , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss @@ -1210,10 +1244,10 @@ lStmtsImplicits = hs_lstmts hs_local_binds (HsIPBinds _) = emptyNameSet hs_local_binds EmptyLocalBinds = emptyNameSet -hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet -hsValBindsImplicits (ValBindsOut binds _) +hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet +hsValBindsImplicits (XValBindsLR (NValBinds binds _)) = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds -hsValBindsImplicits (ValBindsIn binds _) +hsValBindsImplicits (ValBinds _ binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet @@ -1229,18 +1263,17 @@ lPatImplicits = hs_lpat hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` rest) emptyNameSet - hs_pat (LazyPat pat) = hs_lpat pat - hs_pat (BangPat pat) = hs_lpat pat - hs_pat (AsPat _ pat) = hs_lpat pat - hs_pat (ViewPat _ pat _) = hs_lpat pat - hs_pat (ParPat pat) = hs_lpat pat - hs_pat (ListPat pats _ _) = hs_lpats pats - hs_pat (PArrPat pats _) = hs_lpats pats - hs_pat (TuplePat pats _ _) = hs_lpats pats - - hs_pat (SigPatIn pat _) = hs_lpat pat - hs_pat (SigPatOut pat _) = hs_lpat pat - hs_pat (CoPat _ pat _) = hs_pat pat + hs_pat (LazyPat _ pat) = hs_lpat pat + hs_pat (BangPat _ pat) = hs_lpat pat + hs_pat (AsPat _ _ pat) = hs_lpat pat + hs_pat (ViewPat _ _ pat) = hs_lpat pat + hs_pat (ParPat _ pat) = hs_lpat pat + hs_pat (ListPat _ pats _ _) = hs_lpats pats + hs_pat (PArrPat _ pats) = hs_lpats pats + hs_pat (TuplePat _ pats _) = hs_lpats pats + + hs_pat (SigPat _ pat) = hs_lpat pat + hs_pat (CoPat _ _ pat _) = hs_pat pat hs_pat (ConPatIn _ ps) = details ps hs_pat (ConPatOut {pat_args=ps}) = details ps diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 0b4711a364..9d99c9a3cb 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -6,10 +6,9 @@ module PlaceHolder where -import GhcPrelude () +import GhcPrelude ( Eq(..), Ord(..) ) -import Type ( Type ) -import Outputable +import Outputable hiding ( (<>) ) import Name import NameSet import RdrName @@ -31,29 +30,23 @@ import Data.Data hiding ( Fixity ) -- | used as place holder in PostTc and PostRn values data PlaceHolder = PlaceHolder - deriving (Data) + deriving (Data,Eq,Ord) -placeHolderKind :: PlaceHolder -placeHolderKind = PlaceHolder +instance Outputable PlaceHolder where + ppr _ = text "PlaceHolder" -placeHolderFixity :: PlaceHolder -placeHolderFixity = PlaceHolder +placeHolder :: PlaceHolder +placeHolder = PlaceHolder placeHolderType :: PlaceHolder placeHolderType = PlaceHolder -placeHolderTypeTc :: Type -placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType" - placeHolderNames :: PlaceHolder placeHolderNames = PlaceHolder placeHolderNamesTc :: NameSet placeHolderNamesTc = emptyNameSet -placeHolderHsWrapper :: PlaceHolder -placeHolderHsWrapper = PlaceHolder - {- Note [Pass sensitive types] diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 48b8eccaca..23e5c9289a 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -102,7 +102,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0) + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) count_bind (PatBind {}) = (0,1,0) count_bind (FunBind {}) = (0,1,0) count_bind (PatSynBind {}) = (0,0,1) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index e63d6e3a95..1012c25b28 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -871,7 +871,8 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do let expr_fs = fsLit "_compileParsedExpr" expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc let_stmt = L loc . LetStmt . L loc . HsValBinds $ - ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] + ValBinds noExt + (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt updateFixityEnv fix_env @@ -894,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 c60f51722f..5cceaf44fe 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1739,13 +1739,15 @@ ctype :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 + , hst_xforall = noExt , hst_body = $4 }) [mu AnnForall $1, mj AnnDot $3] } | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 + , hst_xqual = noExt , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3)) [mu AnnDcolon $2] } | type { $1 } @@ -1764,13 +1766,15 @@ ctypedoc :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> ams (sLL $1 $> $ HsForAllTy { hst_bndrs = $2 + , hst_xforall = noExt , hst_body = $4 }) [mu AnnForall $1,mj AnnDot $3] } | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 + , hst_xqual = noExt , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy $1 $3)) + | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExt $1 $3)) [mu AnnDcolon $2] } | typedoc { $1 } @@ -1822,31 +1826,32 @@ is connected to the first type too. type :: { LHsType GhcPs } : btype { $1 } | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy $1 $3) + >> ams (sLL $1 $> $ HsFunTy noExt $1 $3) [mu AnnRarrow $2] } typedoc :: { LHsType GhcPs } : btype { $1 } - | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } - | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) + | btype docprev { sLL $1 $> $ HsDocTy noExt $1 $2 } + | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy noExt $1 $3) [mu AnnRarrow $2] } | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ - HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) + HsFunTy noExt (L (comb2 $1 $2) + (HsDocTy noExt $1 $2)) $4) [mu AnnRarrow $3] } -- See Note [Parsing ~] btype :: { LHsType GhcPs } : tyapps {% splitTildeApps (reverse (unLoc $1)) >>= - \ts -> return $ sL1 $1 $ HsAppsTy ts } + \ts -> return $ sL1 $1 $ HsAppsTy noExt ts } -- Used for parsing Haskell98-style data constructors, -- in order to forbid the blasphemous -- > data Foo = Int :+ Char :* Bool -- See also Note [Parsing data constructors is hard] in RdrHsSyn btype_no_ops :: { LHsType GhcPs } - : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 } + : btype_no_ops atype { sLL $1 $> $ HsAppTy noExt $1 $2 } | atype { $1 } tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed @@ -1855,58 +1860,57 @@ tyapps :: { Located [LHsAppType GhcPs] } -- NB: This list is reversed -- See Note [HsAppsTy] in HsTypes tyapp :: { LHsAppType GhcPs } - : atype { sL1 $1 $ HsAppPrefix $1 } - | qtyconop { sL1 $1 $ HsAppInfix $1 } - | tyvarop { sL1 $1 $ HsAppInfix $1 } - | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2) + : atype { sL1 $1 $ HsAppPrefix noExt $1 } + | qtyconop { sL1 $1 $ HsAppInfix noExt $1 } + | tyvarop { sL1 $1 $ HsAppInfix noExt $1 } + | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix noExt $2) [mj AnnSimpleQuote $1] } - | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2) + | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix noExt $2) [mj AnnSimpleQuote $1] } atype :: { LHsType GhcPs } - : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples - | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples]) - | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) + : ntgtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- Not including unit tuples + | tyvar { sL1 $1 (HsTyVar noExt NotPromoted $1) } -- (See Note [Unit tuples]) + | strict_mark atype {% ams (sLL $1 $> (HsBangTy noExt (snd $ unLoc $1) $2)) (fst $ unLoc $1) } -- Constructor sigs only | '{' fielddecls '}' {% amms (checkRecordSyntax - (sLL $1 $> $ HsRecTy $2)) + (sLL $1 $> $ HsRecTy noExt $2)) -- Constructor sigs only [moc $1,mcc $3] } - | '(' ')' {% ams (sLL $1 $> $ HsTupleTy + | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExt HsBoxedOrConstraintTuple []) [mop $1,mcp $2] } | '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsTupleTy + ams (sLL $1 $> $ HsTupleTy noExt HsBoxedOrConstraintTuple ($2 : $4)) [mop $1,mcp $5] } - | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple []) + | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple []) [mo $1,mc $2] } - | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy HsUnboxedTuple $2) + | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExt HsUnboxedTuple $2) [mo $1,mc $3] } - | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy $2) + | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExt $2) [mo $1,mc $3] } - | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy $2) [mos $1,mcs $3] } - | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy $2) [mo $1,mc $3] } - | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy $2) [mop $1,mcp $3] } - | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4) + | '[' ctype ']' {% ams (sLL $1 $> $ HsListTy noExt $2) [mos $1,mcs $3] } + | '[:' ctype ':]' {% ams (sLL $1 $> $ HsPArrTy noExt $2) [mo $1,mc $3] } + | '(' ctype ')' {% ams (sLL $1 $> $ HsParTy noExt $2) [mop $1,mcp $3] } + | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig noExt $2 $4) [mop $1,mu AnnDcolon $3,mcp $5] } - | quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) } + | 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 - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $3) AnnComma (gl $4) >> - ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) + ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5)) [mj AnnSimpleQuote $1,mop $2,mcp $6] } - | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy Promoted - placeHolderKind $3) + | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3) [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2) + | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } -- Two or more [ty, ty, ty] must be a promoted list type, just as @@ -1915,13 +1919,12 @@ atype :: { LHsType GhcPs } -- so you have to quote those.) | '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsExplicitListTy NotPromoted - placeHolderKind ($2 : $4)) + ams (sLL $1 $> $ HsExplicitListTy noExt NotPromoted ($2 : $4)) [mos $1,mcs $5] } - | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1) - (il_value (getINTEGER $1)) } - | STRING { sLL $1 $> $ HsTyLit $ HsStrTy (getSTRINGs $1) - (getSTRING $1) } + | INTEGER { sLL $1 $> $ HsTyLit noExt $ HsNumTy (getINTEGERs $1) + (il_value (getINTEGER $1)) } + | STRING { sLL $1 $> $ HsTyLit noExt $ HsStrTy (getSTRINGs $1) + (getSTRING $1) } | '_' { sL1 $1 $ mkAnonWildCardTy } -- An inst_type is what occurs in the head of an instance decl @@ -1956,8 +1959,8 @@ tv_bndrs :: { [LHsTyVarBndr GhcPs] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr GhcPs } - : tyvar { sL1 $1 (UserTyVar $1) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar $2 $4)) + : tyvar { sL1 $1 (UserTyVar noExt $1) } + | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExt $2 $4)) [mop $1,mu AnnDcolon $3 ,mcp $5] } @@ -2128,7 +2131,7 @@ fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev {% ams (L (comb2 $2 $4) - (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc ln PlaceHolder) (unLoc $2))) $4 ($1 `mplus` $5))) + (ConDeclField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExt ln) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2199,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 $> }; @@ -2352,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 @@ -2403,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) @@ -2421,19 +2423,18 @@ 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 - placeHolderType [])) + ams (sLL $1 $> $ HsProc noExt p (sLL $1 $> $ HsCmdTop noExt cmd)) -- 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 @@ -2441,7 +2442,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) } @@ -2484,19 +2485,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 } @@ -2507,72 +2508,70 @@ 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) placeHolderType) } - | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional - (getRATIONAL $1) placeHolderType) } + | 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) - (Present $2)] Unboxed)) + | '(#' texp '#)' {% ams (sLL $1 $> (ExplicitTuple noExt [L (gl $2) + (Present noExt $2)] Unboxed)) [mo $1,mc $3] } | '(#' tup_exprs '#)' {% do { e <- mkSumOrTuple Unboxed (comb2 $1 $3) (snd $2) ; ams (sLL $1 $> e) ((mo $1:fst $2) ++ [mc $3]) } } | '[' 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 noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket noExt (VarBr noExt False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket noExt (ExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } - | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) + | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket noExt (TExpBr noExt $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } - | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket (TypBr $2)) [mo $1,mu AnnCloseQ $3] } + | '[t|' ctype '|]' {% ams (sLL $1 $> $ HsBracket noExt (TypBr noExt $2)) [mo $1,mu AnnCloseQ $3] } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> - ams (sLL $1 $> $ HsBracket (PatBr p)) + ams (sLL $1 $> $ HsBracket noExt (PatBr noExt p)) [mo $1,mu AnnCloseQ $3] } - | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket (DecBrL (snd $2))) + | '[d|' cvtopbody '|]' {% ams (sLL $1 $> $ HsBracket noExt (DecBrL noExt (snd $2))) (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { sL1 $1 (HsSpliceE (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) @@ -2584,8 +2583,7 @@ cmdargs :: { [LHsCmdTop GhcPs] } acmd :: { LHsCmdTop GhcPs } : aexp2 {% checkCommand $1 >>= \ cmd -> - return (sL1 $1 $ HsCmdTop cmd - placeHolderType placeHolderType []) } + return (sL1 $1 $ HsCmdTop noExt cmd) } cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 @@ -2616,17 +2614,17 @@ 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) } : texp commas_tup_tail {% do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Present $1)) : snd $2)) } } + ; return ([],Tuple ((sL1 $1 (Present noExt $1)) : snd $2)) } } | texp bars { (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } @@ -2649,8 +2647,8 @@ commas_tup_tail : commas tup_tail -- Always follows a comma tup_tail :: { [LHsTupArg GhcPs] } : texp commas_tup_tail {% addAnnotation (gl $1) AnnComma (fst $2) >> - return ((L (gl $1) (Present $1)) : snd $2) } - | texp { [L (gl $1) (Present $1)] } + return ((L (gl $1) (Present noExt $1)) : snd $2) } + | texp { [L (gl $1) (Present noExt $1)] } | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- @@ -2659,19 +2657,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 -> @@ -2694,7 +2691,7 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | + qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock noExt qs [] noSyntaxExpr | qs <- qss] noExpr noSyntaxExpr placeHolderType] -- We actually found some actual parallel lists so @@ -2751,15 +2748,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) } @@ -2845,8 +2841,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 } @@ -2854,14 +2850,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] } @@ -3139,8 +3135,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified | tycon { $1 } qtycondoc :: { LHsType GhcPs } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar NotPromoted $1) } - | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) } + : qtycon { sL1 $1 (HsTyVar noExt NotPromoted $1) } + | qtycon docprev { sLL $1 $> (HsDocTy noExt (sL1 $1 (HsTyVar noExt NotPromoted $1)) $2) } tycon :: { Located RdrName } -- Unqualified : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } @@ -3173,15 +3169,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 } @@ -3338,8 +3334,8 @@ literal :: { Located (HsLit GhcPs) } $ getPRIMCHAR $1 } | PRIMSTRING { sL1 $1 $ HsStringPrim (sst $ getPRIMSTRINGs $1) $ getPRIMSTRING $1 } - | PRIMFLOAT { sL1 $1 $ HsFloatPrim def $ getPRIMFLOAT $1 } - | PRIMDOUBLE { sL1 $1 $ HsDoublePrim def $ getPRIMDOUBLE $1 } + | PRIMFLOAT { sL1 $1 $ HsFloatPrim noExt $ getPRIMFLOAT $1 } + | PRIMDOUBLE { sL1 $1 $ HsDoublePrim noExt $ getPRIMDOUBLE $1 } ----------------------------------------------------------------------------- -- Layout diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 126e92e7ad..7285f5fef9 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -186,7 +186,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, - tcdDataCusk = PlaceHolder, + tcdDataCusk = placeHolder, tcdFVs = placeHolderNames })) } mkDataDefn :: NewOrData @@ -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 @@ -349,7 +349,7 @@ cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) - return $ ValBindsIn mbs sigs } + return $ ValBinds noExt mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] @@ -476,15 +476,15 @@ splitCon ty = split ty [] where -- This is used somewhere where HsAppsTy is not used - split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) - split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] + split (L _ (HsAppTy _ t u)) ts = split t (u : ts) + split (L l (HsTyVar _ _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) + split (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) [] = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) - mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) - mk_rest ts = PrefixCon ts + mk_rest [L l (HsRecTy _ flds)] = RecCon (L l flds) + mk_rest ts = PrefixCon ts tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) -- See Note [Parsing data constructors is hard] @@ -695,15 +695,16 @@ checkTyVars pp_what equals_or_where tc tparms ; return (mkHsQTvs tvs) } where - chk (L _ (HsParTy ty)) = chk ty - chk (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = chk ty + chk (L _ (HsParTy _ ty)) = chk ty + chk (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = chk ty -- Check that the name space is correct! - chk (L l (HsKindSig - (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k)) - | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) - chk (L l (HsTyVar _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) + chk (L l (HsKindSig _ + (L _ (HsAppsTy _ [L _ (HsAppPrefix _ (L lv (HsTyVar _ _ (L _ tv))))])) + k)) + | isRdrTyVar tv = return (L l (KindedTyVar noExt (L lv tv) k)) + chk (L l (HsTyVar _ _ (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar noExt (L ltv tv))) chk t@(L loc _) = Left (loc, vcat [ text "Unexpected type" <+> quotes (ppr t) @@ -752,23 +753,23 @@ checkTyClHdr is_cls ty where goL (L l ty) acc ann fix = go l ty acc ann fix - go l (HsTyVar _ (L _ tc)) acc ann fix + go l (HsTyVar _ _ (L _ tc)) acc ann fix | isRdrTc tc = return (L l tc, acc, fix, ann) - go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix + go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) - go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix - go _ (HsAppTy t1 t2) acc ann fix = goL t1 (t2:acc) ann fix - go _ (HsAppsTy ts) acc ann _fix + go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix + go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix + go _ (HsAppsTy _ ts) acc ann _fix | Just (head, args, fixity) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann fixity - go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix + go _ (HsAppsTy _ [L _ (HsAppInfix _ (L loc star))]) [] ann fix | isStar star = return (L loc (nameRdrName starKindTyConName), [], fix, ann) | isUniStar star = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann) - go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix + go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix = return (L l (nameRdrName tup_name), ts, fix, ann) where arity = length ts @@ -783,14 +784,15 @@ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) checkContext (L l orig_t) = check [] (L l orig_t) where - check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type + check anns (L lp (HsTupleTy _ _ ts)) -- (Eq a, Ord b) shows up as a tuple type = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () -- don't let HsAppsTy get in the way - check anns (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) + check anns (L _ (HsAppsTy _ [L _ (HsAppPrefix _ ty)])) = check anns ty - check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way + check anns (L lp1 (HsParTy _ ty)) + -- to be sure HsParTy doesn't get into the way = check anns' ty where anns' = if l == lp1 then anns else (anns ++ mkParensApiAnn lp1) @@ -815,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 @@ -825,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) [] @@ -839,76 +841,76 @@ checkAPat msg loc e0 = do pState <- getPState let opts = options pState case e0 of - EWildPat -> return (WildPat placeHolderType) - HsVar x -> return (VarPat x) - HsLit (HsStringPrim _ _) -- (#13260) + EWildPat _ -> return (WildPat noExt) + HsVar _ x -> return (VarPat noExt x) + HsLit _ (HsStringPrim _ _) -- (#13260) -> parseErrorSDoc loc (text "Illegal unboxed string literal in pattern:" $$ ppr e0) - HsLit l -> return (LitPat 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 ; addAnnotation loc AnnBang lb - ; return (BangPat e') } + ; return (BangPat noExt e') } else parseErrorSDoc loc (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e0) } - ELazyPat e -> checkLPat msg e >>= (return . LazyPat) - EAsPat n e -> checkLPat msg e >>= (return . AsPat 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 >>= - (return . (\p -> ViewPat expr p placeHolderType)) - ExprWithTySig e t -> do e <- checkLPat msg e - return (SigPatIn e t) + EViewPat _ expr patE -> checkLPat msg patE >>= + (return . (\p -> ViewPat noExt expr p)) + 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) + HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt)) ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es - return (ListPat ps placeHolderType Nothing) + return (ListPat noExt ps placeHolderType Nothing) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es - return (PArrPat ps placeHolderType) + 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 ps b []) + [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 p alt arity placeHolderType) + 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) - -> return (SplicePat 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 @@ -942,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 @@ -995,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 @@ -1017,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") @@ -1052,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 @@ -1077,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)) @@ -1101,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 @@ -1115,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 @@ -1124,23 +1128,24 @@ isFunLhs e = go e [] [] -- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d splitTilde :: LHsType GhcPs -> P (LHsType GhcPs) splitTilde t = go t - where go (L loc (HsAppTy t1 t2)) - | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') + where go (L loc (HsAppTy _ t1 t2)) + | L lo (HsBangTy _ (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') <- t2 = do moveAnnotations lo loc t1' <- go t1 - return (L loc (HsEqTy t1' t2')) + return (L loc (HsEqTy noExt t1' t2')) | otherwise = do t1' <- go t1 case t1' of - (L lo (HsEqTy tl tr)) -> do + (L lo (HsEqTy _ tl tr)) -> do let lr = combineLocs tr t2 moveAnnotations lo loc - return (L loc (HsEqTy tl (L lr (HsAppTy tr t2)))) + return (L loc (HsEqTy noExt tl + (L lr (HsAppTy noExt tr t2)))) t -> do - return (L loc (HsAppTy t t2)) + return (L loc (HsAppTy noExt t t2)) go t = return t @@ -1152,14 +1157,14 @@ splitTildeApps [] = return [] splitTildeApps (t : rest) = do rest' <- concatMapM go rest return (t : rest') - where go (L l (HsAppPrefix - (L loc (HsBangTy + where go (L l (HsAppPrefix _ + (L loc (HsBangTy noExt (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) ty)))) = addAnnotation l AnnTilde tilde_loc >> return - [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)), - L l (HsAppPrefix ty)] + [L tilde_loc (HsAppInfix noExt (L tilde_loc eqTyCon_RDR)), + L l (HsAppPrefix noExt ty)] -- NOTE: no annotation is attached to an HsAppPrefix, so the -- surrounding SrcSpan is not critical where @@ -1195,34 +1200,35 @@ 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) = - return $ HsCmdArrForm e Prefix mf args -checkCmd _ (HsApp e1 e2) = - checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) -checkCmd _ (HsLam mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') -checkCmd _ (HsPar e) = - checkCommand e >>= (\c -> return $ HsCmdPar c) -checkCmd _ (HsCase e mg) = - checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') -checkCmd _ (HsIf cf ep et ee) = do +checkCmd _ (HsArrApp _ e1 e2 haat b) = + return $ HsCmdArrApp noExt e1 e2 haat b +checkCmd _ (HsArrForm _ e mf args) = + return $ HsCmdArrForm noExt e Prefix mf args +checkCmd _ (HsApp _ e1 e2) = + checkCommand e1 >>= (\c -> return $ HsCmdApp noExt c e2) +checkCmd _ (HsLam _ mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam noExt mg') +checkCmd _ (HsPar _ e) = + checkCommand e >>= (\c -> return $ HsCmdPar noExt c) +checkCmd _ (HsCase _ e mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase noExt e mg') +checkCmd _ (HsIf _ cf ep et ee) = do pt <- checkCommand et pe <- checkCommand ee - return $ HsCmdIf cf ep pt pe -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 _ (OpApp eLeft op _fixity eRight) = do + return $ HsCmdIf noExt cf ep pt pe +checkCmd _ (HsLet _ lb e) = + checkCommand e >>= (\c -> return $ HsCmdLet noExt lb c) +checkCmd _ (HsDo _ DoExpr (L l stmts)) = + mapM checkCmdLStmt stmts >>= + (\ss -> return $ HsCmdDo noExt (L l ss) ) + +checkCmd _ (OpApp _ eLeft op eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight - let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] - arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] - return $ HsCmdArrForm op Infix Nothing [arg1, arg2] + let arg1 = L (getLoc c1) $ HsCmdTop noExt c1 + arg2 = L (getLoc c2) $ HsCmdTop noExt c2 + return $ HsCmdArrForm noExt op Infix Nothing [arg1, arg2] checkCmd l e = cmdFail l e @@ -1286,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) @@ -1295,23 +1301,23 @@ 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 } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun) - = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun +mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) + = HsRecField (L loc (Unambiguous noExt rdr)) arg pun +mk_rec_upd_field (HsRecField (L _ (XFieldOcc _)) _ _) + = panic "mk_rec_upd_field" mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -1563,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/RnBinds.hs b/compiler/rename/RnBinds.hs index 02a37b20ef..d8fcf4e690 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -183,10 +183,10 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures -rnTopBindsBoot bound_names (ValBindsIn mbinds sigs) +rnTopBindsBoot bound_names (ValBinds _ mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs - ; return (ValBindsOut [] sigs', usesOnly fvs) } + ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) {- @@ -274,9 +274,9 @@ rnLocalValBindsLHS fix_env binds rnValBindsLHS :: NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBindsIn mbinds sigs) +rnValBindsLHS topP (ValBinds x mbinds sigs) = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds - ; return $ ValBindsIn mbinds' sigs } + ; return $ ValBinds x mbinds' sigs } where bndrs = collectHsBindsBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs @@ -291,7 +291,7 @@ rnValBindsRHS :: HsSigCtxt -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -rnValBindsRHS ctxt (ValBindsIn mbinds sigs) +rnValBindsRHS ctxt (ValBinds _ mbinds sigs) = do { (sigs', sig_fvs) <- renameSigs ctxt sigs ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus @@ -311,7 +311,7 @@ rnValBindsRHS ctxt (ValBindsIn mbinds sigs) -- so that the binders are removed from -- the uses in the sigs - ; return (ValBindsOut anal_binds sigs', valbind'_dus) } + ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) @@ -336,7 +336,7 @@ rnLocalValBindsAndThen :: HsValBinds GhcPs -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) -> RnM (result, FreeVars) -rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside +rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside = do { -- (A) Create the local fixity environment new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] 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 3cb24173ec..22e474b481 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,58 +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 (ambiguousFieldOcc (FieldOcc (L l v) s)) - , unitFV s) ; + return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ; Just (Right fs@(_:_:_)) -> - return ( HsRecFld (Ambiguous (L l v) PlaceHolder) + 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 placeHolderType)) + 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 @@ -183,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 @@ -201,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 } @@ -226,71 +225,72 @@ 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) + rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e + ; return (L l (Present x e'), fvs) } + rnTupArg (L l (Missing _)) = return (L l (Missing noExt) , emptyFVs) + rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg" -rnExpr (ExplicitSum 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 }) }) @@ -298,53 +298,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. @@ -352,7 +352,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 @@ -407,11 +407,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 @@ -420,8 +420,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 @@ -434,17 +434,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) @@ -466,26 +466,26 @@ rnCmdArgs (arg:args) rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where - rnCmdTop' (HsCmdTop cmd _ _ _) + rnCmdTop' (HsCmdTop _ cmd) = do { (cmd', fvCmd) <- rnLCmd cmd ; let cmd_names = [arrAName, composeAName, firstAName] ++ nameSetElemsStable (methodNamesCmd (unLoc cmd')) -- Generate the rebindable syntax for the monad ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - ; return (HsCmdTop cmd' placeHolderType placeHolderType - (cmd_names `zip` cmd_names'), + ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', fvCmd `plusFV` cmd_fvs) } + rnCmdTop' (XCmdTop{}) = panic "rnCmdTop" rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) -rnCmd (HsCmdArrApp arrow arg _ ho rtl) +rnCmd (HsCmdArrApp x arrow arg ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + ; return (HsCmdArrApp x arrow' arg' ho rtl, fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of @@ -498,9 +498,9 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- inside 'arrow'. In the higher-order case (-<<), they are. -- infix form -rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) +rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) - ; let L _ (HsVar (L _ op_name)) = op' + ; let L _ (HsVar _ (L _ op_name)) = op' ; (arg1',fv_arg1) <- rnCmdTop arg1 ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity @@ -508,47 +508,48 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) ; final_e <- mkOpFormRn arg1' op' fixity arg2' ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } -rnCmd (HsCmdArrForm op f fixity cmds) +rnCmd (HsCmdArrForm x op f fixity cmds) = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) } + ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } -rnCmd (HsCmdApp fun arg) +rnCmd (HsCmdApp x fun arg) = do { (fun',fvFun) <- rnLCmd fun ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } + ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam matches) +rnCmd (HsCmdLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam matches', fvMatch) } + ; return (HsCmdLam x matches', fvMatch) } -rnCmd (HsCmdPar e) +rnCmd (HsCmdPar x e) = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar e', fvs_e) } + ; return (HsCmdPar x e', fvs_e) } -rnCmd (HsCmdCase expr matches) +rnCmd (HsCmdCase x expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdIf _ p b1 b2) +rnCmd (HsCmdIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 ; (b2', fvB2) <- rnLCmd b2 ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet (L l binds) cmd) +rnCmd (HsCmdLet x (L l binds) cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet (L l binds') cmd', fvExpr) } + ; return (HsCmdLet x (L l binds') cmd', fvExpr) } -rnCmd (HsCmdDo (L l stmts) _) +rnCmd (HsCmdDo x (L l stmts)) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) } + ; return ( HsCmdDo x (L l stmts'), fvs ) } rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) +rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -560,26 +561,28 @@ methodNamesLCmd = methodNamesCmd . unLoc methodNamesCmd :: HsCmd GhcRn -> CmdNeeds -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) = emptyFVs -methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd +methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd -methodNamesCmd (HsCmdPar c) = methodNamesLCmd c +methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdIf _ _ c1 c2) +methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts -methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c -methodNamesCmd (HsCmdLam match) = methodNamesMatch match +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match -methodNamesCmd (HsCmdCase _ matches) +methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName +methodNamesCmd (XCmd {}) = panic "methodNamesCmd" + --methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient -- to error here so we just do what's convenient. @@ -863,7 +866,7 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder) + ; return (( [( L loc (BindStmt pat' body' bind_op fail_op placeHolder) , fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} @@ -946,7 +949,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map , trS_by = by', trS_using = using', trS_form = form , trS_ret = return_op, trS_bind = bind_op - , trS_bind_arg_ty = PlaceHolder + , trS_bind_arg_ty = placeHolder , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } rnStmt _ _ (L _ ApplicativeStmt{}) _ = @@ -971,7 +974,7 @@ rnParallelStmts ctxt return_op segs thing_inside ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } - rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) + rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do @@ -979,8 +982,9 @@ rnParallelStmts ctxt return_op segs thing_inside ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } - ; let seg' = ParStmtBlock stmts' used_bndrs return_op + ; let seg' = ParStmtBlock x stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } + rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts" cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" @@ -1000,12 +1004,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 @@ -1095,7 +1099,7 @@ rnRecStmtsAndThen rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> + (L _ (LetStmt (L _ (HsValBinds (ValBinds _ _ sigs))))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig s)) -> (L loc s) : acc _ -> acc) acc sigs @@ -1196,7 +1200,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat) ; let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] } + L loc (BindStmt pat' body' bind_op fail_op placeHolder))] } rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) = failWith (badIpBinds (text "an mdo expression") binds) @@ -1700,7 +1704,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) @@ -1786,25 +1790,24 @@ can do with the rest of the statements in the same "do" expression. isStrictPattern :: LPat id -> Bool isStrictPattern (L _ pat) = case pat of - WildPat{} -> False - VarPat{} -> False - LazyPat{} -> False - AsPat _ p -> isStrictPattern p - ParPat p -> isStrictPattern p - ViewPat _ p _ -> isStrictPattern p - SigPatIn p _ -> isStrictPattern p - SigPatOut p _ -> isStrictPattern p - BangPat{} -> True - ListPat{} -> True - TuplePat{} -> True - SumPat{} -> True - PArrPat{} -> True - ConPatIn{} -> True - ConPatOut{} -> True - LitPat{} -> True - NPat{} -> True - NPlusKPat{} -> True - SplicePat{} -> True + WildPat{} -> False + VarPat{} -> False + LazyPat{} -> False + AsPat _ _ p -> isStrictPattern p + ParPat _ p -> isStrictPattern p + ViewPat _ _ p -> isStrictPattern p + SigPat _ p -> isStrictPattern p + BangPat{} -> True + ListPat{} -> True + TuplePat{} -> True + SumPat{} -> True + PArrPat{} -> True + ConPatIn{} -> True + ConPatOut{} -> True + LitPat{} -> True + NPat{} -> True + NPlusKPat{} -> True + SplicePat{} -> True _otherwise -> panic "isStrictPattern" isLetStmt :: LStmt a b -> Bool @@ -1876,8 +1879,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 @@ -1912,15 +1915,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 @@ -2102,7 +2105,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/RnFixity.hs b/compiler/rename/RnFixity.hs index b1305f55f3..f1bfb380a5 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -179,9 +179,9 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n -- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are -- multiple possible selectors with different fixities, generate an error. lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (Unambiguous (L _ rdr) n) +lookupFieldFixityRn (Unambiguous n (L _ rdr)) = lookupFixityRn' n (rdrNameOcc rdr) -lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr +lookupFieldFixityRn (Ambiguous _ (L _ rdr)) = get_ambiguous_fixity rdr where get_ambiguous_fixity :: RdrName -> RnM Fixity get_ambiguous_fixity rdr_name = do @@ -209,3 +209,4 @@ lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr format_ambig (elt, fix) = hang (ppr fix) 2 (pprNameProvenance elt) +lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn" diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index b1dc8877b5..f4962d55ef 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -604,7 +604,7 @@ getLocalNonValBinders fixity_env ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) ; return (envs, new_bndrs) } } where - ValBindsIn _val_binds val_sigs = binds + ValBinds _ _val_binds val_sigs = binds for_hs_bndrs :: [Located RdrName] for_hs_bndrs = hsForeignDeclsBinders foreign_decls @@ -652,11 +652,13 @@ getLocalNonValBinders fixity_env where (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty cdflds = case tau of - L _ (HsFunTy - (L _ (HsAppsTy - [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds - L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds - _ -> [] + L _ (HsFunTy _ + (L _ (HsAppsTy _ + [L _ (HsAppPrefix _ (L _ (HsRecTy _ flds)))])) + _) -> flds + L _ (HsFunTy _ (L _ (HsRecTy _ flds)) _) + -> flds + _ -> [] find_con_flds _ = [] find_con_name rdr @@ -664,10 +666,11 @@ getLocalNonValBinders fixity_env find (\ n -> nameOccName n == rdrNameOcc rdr) names find_con_decl_flds (L _ x) = map find_con_decl_fld (cd_fld_names x) - find_con_decl_fld (L _ (FieldOcc (L _ rdr) _)) + find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr) + find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders" new_assoc :: Bool -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) @@ -707,7 +710,8 @@ getLocalNonValBinders fixity_env newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _)) +newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector" +newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) = do { selName <- newTopSrcBinder $ L loc $ field ; return $ qualFieldLbl { flSelector = selName } } where diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 2846754f11..7d31a87ad3 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -11,6 +11,8 @@ free variables. -} {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module RnPat (-- main entry points rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -383,17 +385,20 @@ rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) -rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) -rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') } -rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } -rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') } -rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (L loc rdr) - ; return (VarPat (L l name)) } +rnPatAndThen _ (WildPat _) = return (WildPat noExt) +rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (ParPat x pat') } +rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (LazyPat x pat') } +rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (BangPat x pat') } +rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (L loc rdr) + ; return (VarPat x (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPatIn pat sig) +rnPatAndThen mk (SigPat sig pat ) -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is -- important to rename its type signature _before_ renaming the rest of the -- pattern, so that type variables are first bound by the _outermost_ pattern @@ -405,21 +410,21 @@ rnPatAndThen mk (SigPatIn pat sig) -- ~~~~~~~~~~~~~~~^ the same `a' then used here = do { sig' <- rnHsSigCps sig ; pat' <- rnLPatAndThen mk pat - ; return (SigPatIn pat' sig') } + ; return (SigPat sig' pat' ) } -rnPatAndThen mk (LitPat lit) +rnPatAndThen mk (LitPat x lit) | HsString src s <- lit = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) ; if ovlStr then rnPatAndThen mk - (mkNPat (noLoc (mkHsIsString src s placeHolderType)) + (mkNPat (noLoc (mkHsIsString src s)) Nothing) else normal_lit } | otherwise = normal_lit where - normal_lit = do { liftCps (rnLit lit); return (LitPat (convertLit lit)) } + normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } -rnPatAndThen _ (NPat (L l lit) mb_neg _eq _) +rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit ; mb_neg' -- See Note [Negative zero] <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName @@ -431,9 +436,9 @@ rnPatAndThen _ (NPat (L l lit) mb_neg _eq _) (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat (L l lit') mb_neg' eq' placeHolderType) } + ; return (NPat x (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _) +rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as @@ -441,16 +446,16 @@ rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _) -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) - (L l lit') lit' ge minus placeHolderType) } + ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat rdr pat) +rnPatAndThen mk (AsPat x rdr pat) = do { new_name <- newPatLName mk rdr ; pat' <- rnLPatAndThen mk pat - ; return (AsPat new_name pat') } + ; return (AsPat x new_name pat') } -rnPatAndThen mk p@(ViewPat expr pat _ty) +rnPatAndThen mk p@(ViewPat x expr pat) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns ; checkErr vp_flag (badViewPat p) } -- Because of the way we're arranging the recursive calls, @@ -459,45 +464,46 @@ rnPatAndThen mk p@(ViewPat expr pat _ty) ; pat' <- rnLPatAndThen mk pat -- Note: at this point the PreTcType in ty can only be a placeHolder -- ; return (ViewPat expr' pat' ty) } - ; return (ViewPat expr' pat' placeHolderType) } + ; return (ViewPat x expr' pat') } rnPatAndThen mk (ConPatIn con stuff) -- rnConPatAndThen takes care of reconstructing the pattern -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. = case unLoc con == nameRdrName (dataConName nilDataCon) of True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists - ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing) + ; if ol_flag then rnPatAndThen mk (ListPat noExt [] + placeHolderType Nothing) else rnConPatAndThen mk con stuff} False -> rnConPatAndThen mk con stuff -rnPatAndThen mk (ListPat pats _ _) +rnPatAndThen mk (ListPat x pats _ _) = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists ; pats' <- rnLPatsAndThen mk pats ; case opt_OverloadedLists of True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName - ; return (ListPat pats' placeHolderType + ; return (ListPat x pats' placeHolderType (Just (placeHolderType, to_list_name)))} - False -> return (ListPat pats' placeHolderType Nothing) } + False -> return (ListPat x pats' placeHolderType Nothing) } -rnPatAndThen mk (PArrPat pats _) +rnPatAndThen mk (PArrPat x pats) = do { pats' <- rnLPatsAndThen mk pats - ; return (PArrPat pats' placeHolderType) } + ; return (PArrPat x pats') } -rnPatAndThen mk (TuplePat pats boxed _) +rnPatAndThen mk (TuplePat x pats boxed) = do { liftCps $ checkTupSize (length pats) ; pats' <- rnLPatsAndThen mk pats - ; return (TuplePat pats' boxed []) } + ; return (TuplePat x pats' boxed) } -rnPatAndThen mk (SumPat pat alt arity _) +rnPatAndThen mk (SumPat x pat alt arity) = do { pat <- rnLPatAndThen mk pat - ; return (SumPat pat alt arity PlaceHolder) + ; return (SumPat x pat alt arity) } -- If a splice has been run already, just rename the result. -rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat))) - = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat +rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat))) + = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat -rnPatAndThen mk (SplicePat splice) +rnPatAndThen mk (SplicePat _ splice) = do { eith <- liftCpsFV $ rnSplicePat splice ; case eith of -- See Note [rnSplicePat] in RnSplice Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed @@ -540,7 +546,7 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) ; flds' <- mapM rn_field (flds `zip` [1..]) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat (L l n) + mkVarPat l n = VarPat noExt (L l n) rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' })) } @@ -602,7 +608,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) -> RnM (LHsRecField GhcRn (Located arg)) rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc (L ll lbl) _) + = L loc (FieldOcc _ (L ll lbl)) , hsRecFieldArg = arg , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl @@ -613,9 +619,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; return (L loc (mk_arg loc arg_rdr)) } else return arg ; return (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc (L ll lbl) sel) + = L loc (FieldOcc sel (L ll lbl)) , hsRecFieldArg = arg' , hsRecPun = pun })) } + rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) + = panic "rnHsRecFields" rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat -> Maybe Name -- The constructor (Nothing for an @@ -656,7 +664,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; addUsedGREs dot_dot_gres ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel) + { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields @@ -764,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' @@ -774,10 +782,10 @@ rnHsRecUpdFields flds Right _ -> fvs lbl' = case sel of Left sel_name -> - L loc (Unambiguous (L loc lbl) sel_name) + L loc (Unambiguous sel_name (L loc lbl)) Right [sel_name] -> - L loc (Unambiguous (L loc lbl) sel_name) - Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder) + L loc (Unambiguous sel_name (L loc lbl)) + Right _ -> L loc (Ambiguous noExt (L loc lbl)) ; return (L l (HsRecField { hsRecFieldLbl = lbl' , hsRecFieldArg = arg'' @@ -798,7 +806,7 @@ getFieldLbls :: [LHsRecField id arg] -> [RdrName] getFieldLbls flds = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds -getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName] +getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds needFlagDotDot :: HsRecFieldContext -> SDoc @@ -882,11 +890,10 @@ 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_rebindable = rebindable - , ol_type = placeHolderType } + , ol_ext = rebindable } ; if isNegativeZeroOverLit lit' then do { (SyntaxExpr { syn_expr = negate_name }, fvs2) <- lookupSyntaxName negateName diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index b182382381..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') @@ -2079,7 +2080,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } where new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] - new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds + new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs @@ -2092,7 +2093,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder) + mkFieldOcc (L l name) = L l (FieldOcc noExt (L l name)) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) @@ -2251,9 +2252,9 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a -add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs -add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" +add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs +add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind" -add_sig :: LSig a -> HsValBinds a -> HsValBinds a -add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" +add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) +add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig" diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 36b1eda140..fc7240ef44 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -18,7 +18,6 @@ import NameSet import HsSyn import RdrName import TcRnMonad -import Kind import RnEnv import RnUtils ( HsDocContext(..), newLocalBndrRn ) @@ -103,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 [] @@ -111,11 +110,11 @@ 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) -rn_bracket outer_stage br@(VarBr flg rdr_name) +rn_bracket outer_stage br@(VarBr x flg rdr_name) = do { name <- lookupOccRn rdr_name ; this_mod <- getModule @@ -137,17 +136,18 @@ rn_bracket outer_stage br@(VarBr flg rdr_name) (quotedNameStageErr br) } } } - ; return (VarBr flg name, unitFV name) } + ; return (VarBr x flg name, unitFV name) } -rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr e', fvs) } +rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr x e', fvs) } -rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) +rn_bracket _ (PatBr x p) + = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) -rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr t', fvs) } +rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr x t', fvs) } -rn_bracket _ (DecBrL decls) +rn_bracket _ (DecBrL x decls) = do { group <- groupDecls decls ; gbl_env <- getGblEnv ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } @@ -159,7 +159,7 @@ rn_bracket _ (DecBrL decls) -- Discard the tcg_env; it contains only extra info about fixity ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))) - ; return (DecBrG group', duUses (tcg_dus tcg_env)) } + ; return (DecBrG x group', duUses (tcg_dus tcg_env)) } where groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls decls @@ -173,10 +173,12 @@ rn_bracket _ (DecBrL decls) } }} -rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" +rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" -rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (TExpBr e', fvs) } +rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr x e', fvs) } + +rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket" quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body @@ -294,10 +296,11 @@ runRnSplice flavour run_meta ppr_res splice = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) ; let the_expr = case splice' of - HsUntypedSplice _ _ e -> e - HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str - HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) - HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + HsUntypedSplice _ _ _ e -> e + HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str + HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) + HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + XSplice {} -> pprPanic "runRnSplice" (ppr splice) -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name @@ -335,14 +338,16 @@ runRnSplice flavour run_meta ppr_res splice makePending :: UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice -makePending flavour (HsUntypedSplice _ n e) +makePending flavour (HsUntypedSplice _ _ n e) = PendingRnSplice flavour n e -makePending flavour (HsQuasiQuote n quoter q_span quote) +makePending flavour (HsQuasiQuote _ n quoter q_span quote) = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) makePending _ splice@(HsTypedSplice {}) = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSpliced {}) = pprPanic "makePending" (ppr splice) +makePending _ splice@(XSplice {}) + = pprPanic "makePending" (ppr splice) ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString @@ -350,13 +355,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 @@ -366,21 +371,21 @@ mkQuasiQuoteExpr flavour quoter q_span quote --------------------- rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all -rnSplice (HsTypedSplice hasParen splice_name expr) +rnSplice (HsTypedSplice x hasParen splice_name expr) = do { checkTH expr "Template Haskell typed splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr - ; return (HsTypedSplice hasParen n' expr', fvs) } + ; return (HsTypedSplice x hasParen n' expr', fvs) } -rnSplice (HsUntypedSplice hasParen splice_name expr) +rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { checkTH expr "Template Haskell untyped splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr - ; return (HsUntypedSplice hasParen n' expr', fvs) } + ; return (HsUntypedSplice x hasParen n' expr', fvs) } -rnSplice (HsQuasiQuote splice_name quoter q_loc quote) +rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { checkTH quoter "Template Haskell quasi-quote" ; loc <- getSrcSpanM ; splice_name' <- newLocalBndrRn (L loc splice_name) @@ -391,9 +396,11 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote) ; when (nameIsLocalOrFrom this_mod quoter') $ checkThLocalName quoter' - ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') } + ; return (HsQuasiQuote x splice_name' quoter' q_loc quote + , unitFV quoter') } rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) +rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice) --------------------- rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) @@ -402,7 +409,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 @@ -415,7 +422,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 @@ -423,8 +430,8 @@ rnSpliceExpr splice runRnSplice UntypedExpSplice runMetaE ppr rn_splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsPar $ HsSpliceE - . HsSpliced (ThModFinalizers mod_finalizers) + ; return ( HsPar noExt $ HsSpliceE noExt + . HsSpliced noExt (ThModFinalizers mod_finalizers) . HsSplicedExpr <$> lexpr3 , fvs) @@ -521,13 +528,13 @@ References: -} ---------------------- -rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind - -> RnM (HsType GhcRn, FreeVars) -rnSpliceType splice k +rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSpliceType splice = rnSpliceGen run_type_splice pend_type_splice splice where pend_type_splice rn_splice - = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k) + = ( makePending UntypedTypeSplice rn_splice + , HsSpliceTy noExt rn_splice) run_type_splice rn_splice = do { traceRn "rnSpliceType: untyped type splice" empty @@ -537,8 +544,8 @@ rnSpliceType splice k ; checkNoErrs $ rnLHsType doc hs_ty2 } -- checkNoErrs: see Note [Renamer errors] -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsParTy $ flip HsSpliceTy k - . HsSpliced (ThModFinalizers mod_finalizers) + ; return ( HsParTy noExt $ HsSpliceTy noExt + . HsSpliced noExt (ThModFinalizers mod_finalizers) . HsSplicedTy <$> hs_ty3 , fvs @@ -594,17 +601,18 @@ rnSplicePat splice = rnSpliceGen run_pat_splice pend_pat_splice splice where pend_pat_splice rn_splice - = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice)) + = (makePending UntypedPatSplice rn_splice + , Right (SplicePat noExt rn_splice)) run_pat_splice rn_splice = do { traceRn "rnSplicePat: untyped pattern splice" empty ; (pat, mod_finalizers) <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( Left $ ParPat $ SplicePat - . HsSpliced (ThModFinalizers mod_finalizers) - . HsSplicedPat <$> - pat + ; return ( Left $ ParPat noExt $ (SplicePat noExt) + . HsSpliced noExt (ThModFinalizers mod_finalizers) + . HsSplicedPat <$> + pat , emptyFVs ) } -- Wrap the result of the quasi-quoter in parens so that we don't @@ -687,6 +695,7 @@ spliceCtxt splice HsTypedSplice {} -> text "typed splice:" HsQuasiQuote {} -> text "quasi-quotation:" HsSpliced {} -> text "spliced expression:" + XSplice {} -> text "spliced expression:" -- | The splice data to be logged data SpliceInfo diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot index d8f0f1fc7f..7844acd2c9 100644 --- a/compiler/rename/RnSplice.hs-boot +++ b/compiler/rename/RnSplice.hs-boot @@ -4,11 +4,9 @@ import GhcPrelude import HsSyn import TcRnMonad import NameSet -import Kind -rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind - -> RnM (HsType GhcRn, FreeVars) +rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) , FreeVars ) rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index dd66cd3aec..2e1b12d8e0 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -156,24 +156,27 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body }) = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> do { (hs_body', fvs) <- rn_lty env hs_body - ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) } + ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs' + , hst_body = hs_body' }, fvs) } rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; wc' <- setSrcSpan lx $ - do { checkExtraConstraintWildCard env wc - ; rnAnonWildCard wc } + do { checkExtraConstraintWildCard env + ; rnAnonWildCard } ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + ; return (HsQualTy { hst_xqual = noExt + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty - ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + ; return (HsQualTy { hst_xqual = noExt + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } rn_ty env hs_ty = rnHsTyKi env hs_ty @@ -181,17 +184,16 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) -checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs - -> RnM () +checkExtraConstraintWildCard :: RnTyKiEnv -> RnM () -- Rename the extra-constraint spot in a type signature -- (blah, _) => type -- Check that extra-constraints are allowed at all, and -- if so that it's an anonymous wildcard -checkExtraConstraintWildCard env wc +checkExtraConstraintWildCard env = checkWildCard env mb_bad where mb_bad | not (extraConstraintWildCardsAllowed env) - = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc) + = Just (text "Extra-constraint wildcard" <+> quotes (pprAnonWildCard) <+> text "not allowed") | otherwise = Nothing @@ -507,43 +509,44 @@ rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) Nothing tyvars $ \ tyvars' -> do { (tau', fvs) <- rnLHsTyKi env tau - ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' } + ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars' + , hst_body = tau' } , fvs) } } rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) = do { checkTypeInType env ty -- See Note [QualTy in kinds] ; (ctxt', fvs1) <- rnTyKiContext env lctxt ; (tau', fvs2) <- rnLHsTyKi env tau - ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' } + ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt' + , hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar ip (L loc rdr_name)) +rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { name <- rnTyVar env rdr_name - ; return (HsTyVar ip (L loc name), unitFV name) } + ; return (HsTyVar noExt ip (L loc name), unitFV name) } -rnHsTyKi env ty@(HsOpTy ty1 l_op ty2) +rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ do { (l_op', fvs1) <- rnHsTyOp env ty l_op ; fix <- lookupTyFixityRn l_op' ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2) (unLoc l_op') fix ty1' ty2' ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } -rnHsTyKi env (HsParTy ty) +rnHsTyKi env (HsParTy _ ty) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsParTy ty', fvs) } + ; return (HsParTy noExt ty', fvs) } -rnHsTyKi env (HsBangTy b ty) +rnHsTyKi env (HsBangTy _ b ty) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsBangTy b ty', fvs) } - -rnHsTyKi env ty@(HsRecTy flds) + ; return (HsBangTy noExt b ty', fvs) } +rnHsTyKi env ty@(HsRecTy _ flds) = do { let ctxt = rtke_ctxt env ; fls <- get_fields ctxt ; (flds', fvs) <- rnConDeclFields ctxt fls flds - ; return (HsRecTy flds', fvs) } + ; return (HsRecTy noExt flds', fvs) } where get_fields (ConDeclCtx names) = concatMapM (lookupConstructorFields . unLoc) names @@ -552,7 +555,7 @@ rnHsTyKi env ty@(HsRecTy flds) 2 (ppr ty)) ; return [] } -rnHsTyKi env (HsFunTy ty1 ty2) +rnHsTyKi env (HsFunTy _ ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 -- Might find a for-all as the arg of a function type ; (ty2', fvs2) <- rnLHsTyKi env ty2 @@ -560,58 +563,58 @@ rnHsTyKi env (HsFunTy ty1 ty2) -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' + ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2' ; return (res_ty, fvs1 `plusFV` fvs2) } -rnHsTyKi env listTy@(HsListTy ty) +rnHsTyKi env listTy@(HsListTy _ ty) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env listTy)) ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsListTy ty', fvs) } + ; return (HsListTy noExt ty', fvs) } -rnHsTyKi env t@(HsKindSig ty k) +rnHsTyKi env t@(HsKindSig _ ty k) = do { checkTypeInType env t ; kind_sigs_ok <- xoptM LangExt.KindSignatures ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k - ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } + ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi env t@(HsPArrTy ty) +rnHsTyKi env t@(HsPArrTy _ ty) = do { notInKinds env t ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsPArrTy ty', fvs) } + ; return (HsPArrTy noExt ty', fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi env tupleTy@(HsTupleTy tup_con tys) +rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env tupleTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsTupleTy tup_con tys', fvs) } + ; return (HsTupleTy noExt tup_con tys', fvs) } -rnHsTyKi env sumTy@(HsSumTy tys) +rnHsTyKi env sumTy@(HsSumTy _ tys) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env sumTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsSumTy tys', fvs) } + ; return (HsSumTy noExt tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412) -rnHsTyKi env tyLit@(HsTyLit t) +rnHsTyKi env tyLit@(HsTyLit _ t) = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env tyLit)) ; when (negLit t) (addErr negLitErr) ; checkTypeInType env tyLit - ; return (HsTyLit t, emptyFVs) } + ; return (HsTyLit noExt t, emptyFVs) } where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit -rnHsTyKi env overall_ty@(HsAppsTy tys) +rnHsTyKi env overall_ty@(HsAppsTy _ tys) = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions let (non_syms, syms) = splitHsAppsTy tys @@ -639,7 +642,7 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) (non_syms1 : non_syms2 : non_syms) (L loc star : ops) | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey = deal_with_star acc1 acc2 - ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star)) + ((non_syms1 ++ L loc (HsTyVar noExt NotPromoted (L loc star)) : non_syms2) : non_syms) ops deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) @@ -660,60 +663,60 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) build_res_ty (arg1 : args) (op1 : ops) = do { rhs <- build_res_ty args ops ; fix <- lookupTyFixityRn op1 - ; res <- - mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs + ; res <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 op1 t2) (unLoc op1) + fix arg1 rhs ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs) ; return (L loc res) } build_res_ty [arg] [] = return arg build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty) -rnHsTyKi env (HsAppTy ty1 ty2) +rnHsTyKi env (HsAppTy _ ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } + ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi env t@(HsIParamTy n ty) +rnHsTyKi env t@(HsIParamTy _ n ty) = do { notInKinds env t ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsIParamTy n ty', fvs) } + ; return (HsIParamTy noExt n ty', fvs) } -rnHsTyKi env t@(HsEqTy ty1 ty2) +rnHsTyKi env t@(HsEqTy _ ty1 ty2) = do { checkTypeInType env t ; (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } + ; return (HsEqTy noExt ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi _ (HsSpliceTy sp k) - = rnSpliceType sp k +rnHsTyKi _ (HsSpliceTy _ sp) + = rnSpliceType sp -rnHsTyKi env (HsDocTy ty haddock_doc) +rnHsTyKi env (HsDocTy _ ty haddock_doc) = do { (ty', fvs) <- rnLHsTyKi env ty ; haddock_doc' <- rnLHsDoc haddock_doc - ; return (HsDocTy ty' haddock_doc', fvs) } + ; return (HsDocTy noExt ty' haddock_doc', fvs) } -rnHsTyKi _ (HsCoreTy ty) - = return (HsCoreTy ty, emptyFVs) +rnHsTyKi _ (XHsType (NHsCoreTy ty)) + = return (XHsType (NHsCoreTy ty), emptyFVs) -- The emptyFVs probably isn't quite right -- but I don't think it matters -rnHsTyKi env ty@(HsExplicitListTy ip k tys) +rnHsTyKi env ty@(HsExplicitListTy _ ip tys) = do { checkTypeInType env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitListTy ip k tys', fvs) } + ; return (HsExplicitListTy noExt ip tys', fvs) } -rnHsTyKi env ty@(HsExplicitTupleTy kis tys) +rnHsTyKi env ty@(HsExplicitTupleTy _ tys) = do { checkTypeInType env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitTupleTy kis tys', fvs) } + ; return (HsExplicitTupleTy noExt tys', fvs) } -rnHsTyKi env (HsWildCardTy wc) - = do { checkAnonWildCard env wc - ; wc' <- rnAnonWildCard wc +rnHsTyKi env (HsWildCardTy _) + = do { checkAnonWildCard env + ; wc' <- rnAnonWildCard ; return (HsWildCardTy wc', emptyFVs) } -- emptyFVs: this occurrence does not refer to a -- user-written binding site, so don't treat @@ -760,21 +763,22 @@ checkWildCard env (Just doc) checkWildCard _ Nothing = return () -checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM () +checkAnonWildCard :: RnTyKiEnv -> RnM () -- Report an error if an anonymous wildcard is illegal here -checkAnonWildCard env wc +checkAnonWildCard env = checkWildCard env mb_bad where mb_bad :: Maybe SDoc mb_bad | not (wildCardsAllowed env) - = Just (notAllowed (ppr wc)) + = Just (notAllowed pprAnonWildCard) | otherwise = case rtke_what env of RnTypeBody -> Nothing RnConstraint -> Just constraint_msg RnTopConstraint -> Just constraint_msg - constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint") + constraint_msg = hang + (notAllowed pprAnonWildCard <+> text "in a constraint") 2 hint_msg hint_msg = vcat [ text "except as the last top-level constraint of a type signature" , nest 2 (text "e.g f :: (Eq a, _) => blah") ] @@ -810,8 +814,8 @@ wildCardsAllowed env HsTypeCtx {} -> True _ -> False -rnAnonWildCard :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn) -rnAnonWildCard (AnonWildCard _) +rnAnonWildCard :: RnM (HsWildCardInfo GhcRn) +rnAnonWildCard = do { loc <- getSrcSpanM ; uniq <- newUnique ; let name = mkInternalName uniq (mkTyVarOcc "_") loc @@ -1057,20 +1061,23 @@ bindLHsTyVarBndr :: HsDocContext -> LHsTyVarBndr GhcPs -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar lrdr@(L lv _))) thing_inside +bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (L loc (UserTyVar (L lv nm))) } + thing_inside (L loc (UserTyVar x (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar lrdr@(L lv _) kind)) thing_inside +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) + thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $ - thing_inside (L loc (KindedTyVar (L lv tv_nm) kind')) + thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } +bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr" + newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name newTyVarNameRn mb_assoc (L loc rdr) = do { rdr_env <- getLocalRdrEnv @@ -1087,44 +1094,46 @@ collectAnonWildCards lty = go lty where go (L _ ty) = case ty of HsWildCardTy (AnonWildCard (L _ wc)) -> [wc] - HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys) - HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2 - HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2 - HsListTy ty -> go ty - HsPArrTy ty -> go ty - HsTupleTy _ tys -> gos tys - HsSumTy tys -> gos tys - HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2 - HsParTy ty -> go ty - HsIParamTy _ ty -> go ty - HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2 - HsKindSig ty kind -> go ty `mappend` go kind - HsDocTy ty _ -> go ty - HsBangTy _ ty -> go ty - HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys + HsAppsTy _ tys -> gos (mapMaybe (prefix_types_only . unLoc) tys) + HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2 + HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2 + HsListTy _ ty -> go ty + HsPArrTy _ ty -> go ty + HsTupleTy _ _ tys -> gos tys + HsSumTy _ tys -> gos tys + HsOpTy _ ty1 _ ty2 -> go ty1 `mappend` go ty2 + HsParTy _ ty -> go ty + HsIParamTy _ _ ty -> go ty + HsEqTy _ ty1 ty2 -> go ty1 `mappend` go ty2 + HsKindSig _ ty kind -> go ty `mappend` go kind + HsDocTy _ ty _ -> go ty + HsBangTy _ _ ty -> go ty + HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds + HsExplicitListTy _ _ tys -> gos tys + HsExplicitTupleTy _ tys -> gos tys HsForAllTy { hst_bndrs = bndrs , hst_body = ty } -> collectAnonWildCardsBndrs bndrs `mappend` go ty HsQualTy { hst_ctxt = L _ ctxt , hst_body = ty } -> gos ctxt `mappend` go ty - HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty HsSpliceTy{} -> mempty - HsCoreTy{} -> mempty HsTyLit{} -> mempty HsTyVar{} -> mempty + XHsType{} -> mempty gos = mconcat . map go - prefix_types_only (HsAppPrefix ty) = Just ty - prefix_types_only (HsAppInfix _) = Nothing + prefix_types_only (HsAppPrefix _ ty) = Just ty + prefix_types_only (HsAppInfix _ _) = Nothing + prefix_types_only (XAppType _) = Nothing collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name] collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs where - go (UserTyVar _) = [] - go (KindedTyVar _ ki) = collectAnonWildCards ki + go (UserTyVar _ _) = [] + go (KindedTyVar _ _ ki) = collectAnonWildCards ki + go (XTyVarBndr{}) = [] {- ********************************************************* @@ -1159,10 +1168,11 @@ rnField fl_env env (L l (ConDeclField names ty haddock_doc)) ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl) + lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl + lookupField (XFieldOcc{}) = panic "rnField" {- ************************************************************************ @@ -1196,15 +1206,15 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExt ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy t1 op2 t2) + (\t1 t2 -> HsOpTy noExt t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - HsFunTy funTyConName funTyFixity ty21 ty22 loc2 + (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2) @@ -1235,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 @@ -1276,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) ---------------------------- @@ -1296,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 @@ -1314,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 @@ -1330,25 +1341,24 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1) - [a11,a12])) _ _ _)) +mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1) + [a11,a12])))) op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsCmdArrForm op2 f (Just fix2) [a1, a2]) + return (HsCmdArrForm x op2 f (Just fix2) [a1, a2]) | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsCmdArrForm op1 f (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) - placeHolderType placeHolderType [])]) + return (HsCmdArrForm noExt op1 f (Just fix1) + [a11, L loc (HsCmdTop [] (L loc new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2]) + = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2]) -------------------------------------- @@ -1426,8 +1436,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 @@ -1713,7 +1723,7 @@ rmDupsInRdrTyVars (FKTV kis tys) extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName] extractRdrKindSigVars (L _ resultSig) | KindSig k <- resultSig = kindRdrNameFromSig k - | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k + | TyVarSig (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k | otherwise = return [] where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k @@ -1768,43 +1778,43 @@ extract_lkind = extract_lty KindLevel extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lty t_or_k (L _ ty) acc = case ty of - HsTyVar _ ltv -> extract_tv t_or_k ltv acc - HsBangTy _ ty -> extract_lty t_or_k ty acc - HsRecTy flds -> foldrM (extract_lty t_or_k - . cd_fld_type . unLoc) acc - flds - HsAppsTy tys -> extract_apps t_or_k tys acc - HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsListTy ty -> extract_lty t_or_k ty acc - HsPArrTy ty -> extract_lty t_or_k ty acc - HsTupleTy _ tys -> extract_ltys t_or_k tys acc - HsSumTy tys -> extract_ltys t_or_k tys acc - HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsIParamTy _ ty -> extract_lty t_or_k ty acc - HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<< - extract_lty t_or_k ty1 =<< - extract_lty t_or_k ty2 acc - HsParTy ty -> extract_lty t_or_k ty acc - HsCoreTy {} -> return acc -- The type is closed - HsSpliceTy {} -> return acc -- Type splices mention no tvs - HsDocTy ty _ -> extract_lty t_or_k ty acc - HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc - HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc - HsTyLit _ -> return acc - HsKindSig ty ki -> extract_lty t_or_k ty =<< - extract_lkind ki acc + HsTyVar _ _ ltv -> extract_tv t_or_k ltv acc + HsBangTy _ _ ty -> extract_lty t_or_k ty acc + HsRecTy _ flds -> foldrM (extract_lty t_or_k + . cd_fld_type . unLoc) acc + flds + HsAppsTy _ tys -> extract_apps t_or_k tys acc + HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsListTy _ ty -> extract_lty t_or_k ty acc + HsPArrTy _ ty -> extract_lty t_or_k ty acc + HsTupleTy _ _ tys -> extract_ltys t_or_k tys acc + HsSumTy _ tys -> extract_ltys t_or_k tys acc + HsFunTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsIParamTy _ _ ty -> extract_lty t_or_k ty acc + HsEqTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsOpTy _ ty1 tv ty2 -> extract_tv t_or_k tv =<< + extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsParTy _ ty -> extract_lty t_or_k ty acc + HsSpliceTy {} -> return acc -- Type splices mention no tvs + HsDocTy _ ty _ -> extract_lty t_or_k ty acc + HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc + HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc + HsTyLit _ _ -> return acc + HsKindSig _ ty ki -> extract_lty t_or_k ty =<< + extract_lkind ki acc HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc =<< - extract_lty t_or_k ty emptyFKTV + -> extract_hs_tv_bndrs tvs acc =<< + extract_lty t_or_k ty emptyFKTV HsQualTy { hst_ctxt = ctxt, hst_body = ty } - -> extract_lctxt t_or_k ctxt =<< - extract_lty t_or_k ty acc + -> extract_lctxt t_or_k ctxt =<< + extract_lty t_or_k ty acc + XHsType {} -> return acc -- We deal with these separately in rnLHsTypeWithWildCards - HsWildCardTy {} -> return acc + HsWildCardTy {} -> return acc extract_apps :: TypeOrKind -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars @@ -1812,8 +1822,9 @@ extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars -extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc -extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc +extract_app t_or_k (L _ (HsAppInfix _ tv)) acc = extract_tv t_or_k tv acc +extract_app t_or_k (L _ (HsAppPrefix _ ty)) acc = extract_lty t_or_k ty acc +extract_app _ (L _ (XAppType _ )) _ = panic "extract_app" extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars -> FreeKiTyVars -> RnM FreeKiTyVars @@ -1853,7 +1864,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName] -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = do { fktvs <- foldrM extract_lkind emptyFKTV - [k | L _ (KindedTyVar _ k) <- tv_bndrs] + [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] ; return (freeKiTyVarsKindVars fktvs) } -- There will /be/ no free tyvars! diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 6d656fefc3..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))) } {- ************************************************************************ @@ -530,7 +530,7 @@ newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTcId) newOverloadedLit - lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty + lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty | not rebindable -- all built-in overloaded lits are tau-types, so we can just -- tauify the ExpType @@ -541,8 +541,8 @@ newOverloadedLit -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr, ol_type = res_ty - , ol_rebindable = False }) + Just expr -> return (lit { ol_witness = expr + , ol_ext = OverLitTc False res_ty }) Nothing -> newNonTrivialOverloadedLit orig lit (mkCheckExpType res_ty) } @@ -550,6 +550,7 @@ newOverloadedLit = newNonTrivialOverloadedLit orig lit res_ty where orig = LiteralOrigin lit +newOverloadedLit XOverLit{} _ = panic "newOverloadedLit" -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in TcUnify @@ -558,8 +559,8 @@ newNonTrivialOverloadedLit :: CtOrigin -> ExpRhoType -> TcM (HsOverLit GhcTcId) newNonTrivialOverloadedLit orig - lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name) - , ol_rebindable = rebindable }) res_ty + 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 ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) @@ -568,13 +569,12 @@ newNonTrivialOverloadedLit orig ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] ; res_ty <- readExpType res_ty ; return (lit { ol_witness = witness - , ol_type = res_ty - , ol_rebindable = rebindable }) } + , ol_ext = OverLitTc rebindable res_ty }) } newNonTrivialOverloadedLit _ lit _ = pprPanic "newNonTrivialOverloadedLit" (ppr lit) ------------ -mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p) +mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) mkOverLit (HsIntegral i) = do { integer_ty <- tcMetaTy integerTyConName ; return (HsInteger (setSourceText $ il_text i) @@ -582,7 +582,7 @@ mkOverLit (HsIntegral i) mkOverLit (HsFractional r) = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat def r rat_ty) } + ; return (HsRat noExt r rat_ty) } mkOverLit (HsIsString src s) = return (HsString (setSourceText src) s) @@ -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/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index edf696e3c9..3463750d7e 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -72,6 +72,7 @@ annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod -annCtxt :: (SourceTextX p, OutputableBndrId p) => AnnDecl p -> SDoc +annCtxt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => AnnDecl (GhcPass p) -> SDoc annCtxt ann = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 96750f7260..318e4c683b 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -121,11 +121,13 @@ tcCmdTop :: CmdEnv -> CmdType -> TcM (LHsCmdTop GhcTcId) -tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) +tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty) = setSrcSpan loc $ do { cmd' <- tcCmd env cmd cmd_ty ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } + ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') } +tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop" + ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId) -- The main recursive function @@ -135,35 +137,35 @@ tcCmd env (L loc cmd) res_ty ; return (L loc cmd') } tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTcId) -tc_cmd env (HsCmdPar cmd) res_ty +tc_cmd env (HsCmdPar x cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar cmd') } + ; return (HsCmdPar x cmd') } -tc_cmd env (HsCmdLet (L l binds) (L body_loc body)) res_ty +tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan body_loc $ tc_cmd env body res_ty - ; return (HsCmdLet (L l binds') (L body_loc body')) } + ; return (HsCmdLet x (L l binds') (L body_loc body')) } -tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) +tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do (scrut', scrut_ty) <- tcInferRho scrut matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty) - return (HsCmdCase scrut' matches') + return (HsCmdCase x scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' ; tcCmd env body (stk, res_ty') } -tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' +tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf Nothing pred' b1' b2') + ; return (HsCmdIf x Nothing pred' b1' b2') } -tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if +tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if = do { pred_ty <- newOpenFlexiTyVarTy -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not @@ -179,7 +181,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf (Just fun') pred' b1' b2') + ; return (HsCmdIf x (Just fun') pred' b1' b2') } ------------------------------------------- @@ -198,7 +200,7 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- -- (plus -<< requires ArrowApply) -tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) +tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; let fun_ty = mkCmdArrTy env arg_ty res_ty @@ -206,7 +208,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } + ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) } where -- Before type-checking f, use the environment of the enclosing -- proc for the (-<) case. @@ -225,12 +227,12 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) -- ----------------------------- -- D;G |-a cmd exp : stk --> res -tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty) - ; return (HsCmdApp fun' arg') } + ; return (HsCmdApp x fun' arg') } ------------------------------------------- -- Lambda @@ -240,9 +242,9 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) -- D;G |-a (\x.cmd) : (t,stk) --> res tc_cmd env - (HsCmdLam (MG { mg_alts = L l [L mtch_loc + (HsCmdLam x (MG { mg_alts = L l [L mtch_loc (match@(Match { m_pats = pats, m_grhss = grhss }))], - mg_origin = origin })) + mg_origin = origin })) (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match) $ do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk @@ -255,8 +257,9 @@ tc_cmd env ; let match' = L mtch_loc (Match { m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) arg_tys = map hsLPatType pats' - cmd' = HsCmdLam (MG { mg_alts = L l [match'], mg_arg_tys = arg_tys - , mg_res_ty = res_ty, mg_origin = origin }) + cmd' = HsCmdLam x (MG { mg_alts = L l [match'] + , mg_arg_tys = arg_tys + , mg_res_ty = res_ty, mg_origin = origin }) ; return (mkHsCmdWrap (mkWpCastN co) cmd') } where n_pats = length pats @@ -277,10 +280,10 @@ tc_cmd env ------------------------------------------- -- Do notation -tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) +tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty) = do { co <- unifyType Nothing unitTy cmd_stk -- Expecting empty argument stack ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo (L l stmts') res_ty)) } + ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) } ----------------------------------------------------------------- @@ -297,7 +300,7 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) -- ---------------------------------------------- -- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' @@ -305,7 +308,7 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcPolyExpr expr e_ty - ; return (HsCmdArrForm expr' f fixity cmd_args') } + ; return (HsCmdArrForm x expr' f fixity cmd_args') } where tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType) @@ -317,6 +320,8 @@ tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } +tc_cmd _ (XCmd {}) _ = panic "tc_cmd" + ----------------------------------------------------------------- -- Base case for illegal commands -- This is where expressions that aren't commands get rejected diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 6a9b22a9bb..515eb4df35 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -308,13 +308,13 @@ tcCompleteSigs sigs = in mapMaybeM (addLocM doOne) sigs tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv -tcRecSelBinds (ValBindsOut binds sigs) +tcRecSelBinds (XValBindsLR (NValBinds binds sigs)) = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds ; return tcg_env' } -tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds" +tcRecSelBinds (ValBinds {}) = panic "tcRecSelBinds" tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type @@ -342,10 +342,10 @@ tcLocalBinds EmptyLocalBinds thing_inside = do { thing <- thing_inside ; return (EmptyLocalBinds, thing) } -tcLocalBinds (HsValBinds (ValBindsOut binds sigs)) thing_inside +tcLocalBinds (HsValBinds (XValBindsLR (NValBinds binds sigs))) thing_inside = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds (ValBindsOut binds' sigs), thing) } -tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds" + ; return (HsValBinds (XValBindsLR (NValBinds binds' sigs)), thing) } +tcLocalBinds (HsValBinds (ValBinds {})) _ = panic "tcLocalBinds" tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside = do { ipClass <- tcLookupClass ipClassName @@ -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) @@ -1742,7 +1742,8 @@ isClosedBndrGroup type_env binds -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (SourceTextX p, OutputableBndrId p, Outputable body) - => LPat p -> GRHSs GhcRn body -> SDoc +patMonoBindsCtxt :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p), + Outputable body) + => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 33ce5810ca..3012801856 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -336,7 +336,7 @@ renameDeriv is_boot inst_infos bagBinds -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) + ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs) ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds ; let bndrs = collectHsValBinders rn_aux_lhs ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ; diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 21b895eea3..8d11fed65c 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -884,10 +884,12 @@ data InstBindings a -- Used only to improve error messages } -instance (SourceTextX a, OutputableBndrId a) => Outputable (InstInfo a) where +instance (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a)) + => Outputable (InstInfo (GhcPass a)) where ppr = pprInstInfoDetails -pprInstInfoDetails :: (SourceTextX a, OutputableBndrId a) => InstInfo a -> SDoc +pprInstInfoDetails :: (SourceTextX (GhcPass a), OutputableBndrId (GhcPass a)) + => InstInfo (GhcPass a) -> SDoc pprInstInfoDetails info = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 4eb5dd1562..a9d8b64515 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 (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 @@ -386,7 +389,8 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty -- -- The *result* type can have any kind (Trac #8739), -- so we don't need to check anything for that - ; _ <- unifyKind (Just (HsCoreTy arg2_sigma)) (typeKind arg2_sigma) liftedTypeKind + ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma)) + (typeKind arg2_sigma) liftedTypeKind -- ignore the evidence. arg2_sigma must have type * or #, -- because we know arg2_sigma -> or_res_ty is well-kinded -- (because otherwise matchActualFunTys would fail) @@ -400,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 @@ -411,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 lbl sel_name)) - ; 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 @@ -427,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 @@ -440,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 @@ -460,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 @@ -479,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) @@ -499,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 @@ -546,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 @@ -565,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] @@ -578,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] -> @@ -588,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 @@ -602,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. @@ -649,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')) } @@ -683,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' } } } {- @@ -970,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 {- @@ -1012,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 @@ -1032,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 {- @@ -1157,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 @@ -1172,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 lbl sel_name))) 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] @@ -1246,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) } @@ -1383,8 +1392,9 @@ tcTupArgs args tys = ASSERT( equalLength args tys ) mapM go (args `zip` tys) where go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty)) - go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (L l (Present expr')) } + go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty + ; return (L l (Present x expr')) } + go (L _ (XTupArg{}), _) = panic "tcTupArgs" --------------------------- -- See TcType.SyntaxOpType also for commentary @@ -1407,7 +1417,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) @@ -1680,27 +1690,31 @@ 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 +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 +tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of Nothing -> ambiguousSelector lbl Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg - ; tcCheckRecSelId rn_expr (Unambiguous lbl sel_name) res_ty } + ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl) + res_ty } +tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId" ------------------------ tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType) -tcInferRecSelId (Unambiguous (L _ lbl) sel) +tcInferRecSelId (Unambiguous sel (L _ lbl)) = do { (expr', ty) <- tc_infer_id lbl sel ; return (expr', ty) } -tcInferRecSelId (Ambiguous lbl _) +tcInferRecSelId (Ambiguous _ lbl) = ambiguousSelector lbl +tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId" ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType) @@ -1729,7 +1743,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) @@ -1755,12 +1769,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] @@ -1771,7 +1785,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 @@ -1803,7 +1818,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 } {- @@ -1885,7 +1901,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']) } @@ -1927,7 +1943,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']) } @@ -2005,7 +2021,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 @@ -2215,8 +2231,9 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Extract the selector name of a field update if it is unambiguous isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of - Unambiguous _ sel_name -> Just (x, sel_name) + Unambiguous sel_name _ -> Just (x, sel_name) Ambiguous{} -> Nothing + XAmbiguousFieldOcc{} -> Nothing -- Look up the possible parents and selector GREs for each field getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn @@ -2284,7 +2301,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty ; let L loc af = hsRecFieldLbl upd lbl = rdrNameAmbiguousFieldOcc af ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous (L loc lbl) i) } } + = L loc (Unambiguous i (L loc lbl)) } } -- Extract the outermost TyCon of a type, if there is one; for @@ -2320,8 +2337,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 @@ -2384,21 +2401,22 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds , hsRecFieldArg = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (L loc lbl) (idName sel_id)) + f = L loc (FieldOcc (idName sel_id) (L loc lbl)) ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl - = L loc (Unambiguous (L loc lbl) - (selectorFieldOcc (unLoc f'))) + = L loc (Unambiguous + (extFieldOcc (unLoc f')) + (L loc lbl)) , hsRecFieldArg = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs +tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs | Just field_ty <- assocMaybe flds_w_tys sel_name = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcPolyExprNC rhs field_ty @@ -2409,12 +2427,13 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc lbl field_id), rhs')) } + ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } | otherwise = do { addErrTc (badFieldCon con_like field_lbl) ; return Nothing } where field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) +tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField" checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index d9166e5e00..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 @@ -614,7 +614,8 @@ gen_Enum_binds loc tycon = do (nlHsApp (nlHsVar (tag2con_RDR dflags tycon)) (nlHsApps plus_RDR [ nlHsVarApps intDataCon_RDR [ah_RDR] - , nlHsLit (HsInt def (mkIntegralLit (-1 :: Int)))])) + , nlHsLit (HsInt noExt + (mkIntegralLit (-1 :: Int)))])) to_enum dflags = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ @@ -774,7 +775,7 @@ gen_Ix_binds loc tycon = do enum_index dflags = mk_easy_FunBind loc unsafeIndex_RDR - [noLoc (AsPat (noLoc c_RDR) + [noLoc (AsPat noExt (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( @@ -1142,7 +1143,7 @@ gen_Show_binds get_fixity loc tycon | otherwise = ([a_Pat, con_pat], showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit - (HsInt def (mkIntegralLit con_prec_plus_one)))) + (HsInt noExt (mkIntegralLit con_prec_plus_one)))) (nlHsPar (nested_compose_Expr show_thingies))) where data_con_RDR = getRdrName data_con @@ -1226,7 +1227,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st -- | showsPrec :: Show a => Int -> a -> ShowS mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs mk_showsPrec_app p x - = nlHsApps showsPrec_RDR [nlHsLit (HsInt def (mkIntegralLit p)), x] + = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x] -- | shows :: Show a => a -> ShowS mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs @@ -1699,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) @@ -1758,7 +1759,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon) where rdr_name = con2tag_RDR dflags tycon - sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ + sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ mkParentType tycon `mkFunTy` intPrimTy @@ -1783,7 +1784,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) L loc (TypeSig [L loc rdr_name] sig_ty)) where sig_ty = mkLHsSigWcType $ L loc $ - HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ + XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon rdr_name = tag2con_RDR dflags tycon @@ -1793,7 +1794,7 @@ genAuxBindSpec dflags loc (DerivMaxTag tycon) L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = maxtag_RDR dflags tycon - sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) + sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim NoSourceText max_tag)) max_tag = case (tyConDataCons tycon) of @@ -2092,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/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index 61e2864c13..ab6220e9b5 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -8,6 +8,7 @@ The deriving code for the Functor, Foldable, and Traversable classes {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} module TcGenFunctor ( FFoldType(..), functorLikeTraverse, diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 01b7176a6e..29dfefbab2 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -10,7 +10,8 @@ checker. -} {-# LANGUAGE CPP, TupleSections #-} -{-# LANGUAGE CPP, TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} module TcHsSyn ( -- * Extracting types from HsSyn @@ -88,28 +89,28 @@ hsLPatType :: OutPat GhcTc -> Type hsLPatType (L _ pat) = hsPatType pat hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat pat) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat (L _ var)) = idType var -hsPatType (BangPat pat) = hsLPatType pat -hsPatType (LazyPat pat) = hsLPatType pat -hsPatType (LitPat lit) = hsLitType lit -hsPatType (AsPat var _) = idType (unLoc var) -hsPatType (ViewPat _ _ ty) = ty -hsPatType (ListPat _ ty Nothing) = mkListTy ty -hsPatType (ListPat _ _ (Just (ty,_))) = ty -hsPatType (PArrPat _ ty) = mkPArrTy ty -hsPatType (TuplePat _ bx tys) = mkTupleTy bx tys -hsPatType (SumPat _ _ _ tys) = mkSumTy tys +hsPatType (ParPat _ pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat _ (L _ var)) = idType var +hsPatType (BangPat _ pat) = hsLPatType pat +hsPatType (LazyPat _ pat) = hsLPatType pat +hsPatType (LitPat _ lit) = hsLitType lit +hsPatType (AsPat _ var _) = idType (unLoc var) +hsPatType (ViewPat ty _ _) = ty +hsPatType (ListPat _ _ ty Nothing) = mkListTy ty +hsPatType (ListPat _ _ _ (Just (ty,_))) = ty +hsPatType (PArrPat ty _) = mkPArrTy ty +hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys +hsPatType (SumPat tys _ _ _ ) = mkSumTy tys hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys }) - = conLikeResTy con tys -hsPatType (SigPatOut _ ty) = ty -hsPatType (NPat _ _ _ ty) = ty -hsPatType (NPlusKPat _ _ _ _ _ ty) = ty -hsPatType (CoPat _ _ ty) = ty -hsPatType p = pprPanic "hsPatType" (ppr p) - -hsLitType :: HsLit p -> TcType + = conLikeResTy con tys +hsPatType (SigPat ty _) = ty +hsPatType (NPat ty _ _ _) = ty +hsPatType (NPlusKPat ty _ _ _ _ _) = ty +hsPatType (CoPat _ _ _ ty) = ty +hsPatType p = pprPanic "hsPatType" (ppr p) + +hsLitType :: HsLit (GhcPass p) -> TcType hsLitType (HsChar _ _) = charTy hsLitType (HsCharPrim _ _) = charPrimTy hsLitType (HsString _ _) = stringTy @@ -123,14 +124,15 @@ hsLitType (HsInteger _ _ ty) = ty hsLitType (HsRat _ _ ty) = ty hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy +hsLitType (XLit p) = pprPanic "hsLitType" (ppr p) -- Overloaded literals. Here mainly because it uses isIntTy etc shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId) shortCutLit dflags (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && inIntRange dflags i = Just (HsLit (HsInt def 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, @@ -139,16 +141,16 @@ shortCutLit dflags (HsIntegral int@(IL src neg i)) ty -- literals, compiled without -O shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim def f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim def f)) + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExt f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f)) | 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 @@ -308,7 +310,9 @@ zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc) -zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel +zonkFieldOcc env (FieldOcc sel lbl) + = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel +zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc" zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) zonkEvBndrsX = mapAccumLM zonkEvBndrX @@ -393,12 +397,12 @@ zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId zonkLocalBinds env EmptyLocalBinds = return (env, EmptyLocalBinds) -zonkLocalBinds _ (HsValBinds (ValBindsIn {})) +zonkLocalBinds _ (HsValBinds (ValBinds {})) = panic "zonkLocalBinds" -- Not in typechecker output -zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs)) +zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs))) = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) } + ; return (env1, HsValBinds (XValBindsLR (NValBinds new_binds sigs))) } where go env [] = return (env, []) @@ -603,115 +607,116 @@ 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 (Present x e)) = do { e' <- zonkLExpr env e + ; return (L l (Present x e')) } zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t ; return (L l (Missing t')) } + zonk_tup_arg (L _ (XTupArg{})) = panic "zonkExpr.XTupArg" -zonkExpr env (ExplicitSum 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 @@ -722,15 +727,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 @@ -745,27 +750,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 @@ -780,33 +789,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 @@ -853,60 +862,60 @@ zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd -zonkCmd env (HsCmdWrap w cmd) +zonkCmd env (HsCmdWrap x w cmd) = do { (env1, w') <- zonkCoFn env w ; cmd' <- zonkCmd env1 cmd - ; return (HsCmdWrap w' cmd') } -zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) + ; return (HsCmdWrap x w' cmd') } +zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 new_ty <- zonkTcTypeToType env ty - return (HsCmdArrApp new_e1 new_e2 new_ty ho rl) + return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) -zonkCmd env (HsCmdArrForm op f fixity args) +zonkCmd env (HsCmdArrForm x op f fixity args) = do new_op <- zonkLExpr env op new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm new_op f fixity new_args) + return (HsCmdArrForm x new_op f fixity new_args) -zonkCmd env (HsCmdApp c e) +zonkCmd env (HsCmdApp x c e) = do new_c <- zonkLCmd env c new_e <- zonkLExpr env e - return (HsCmdApp new_c new_e) + return (HsCmdApp x new_c new_e) -zonkCmd env (HsCmdLam matches) +zonkCmd env (HsCmdLam x matches) = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam new_matches) + return (HsCmdLam x new_matches) -zonkCmd env (HsCmdPar c) +zonkCmd env (HsCmdPar x c) = do new_c <- zonkLCmd env c - return (HsCmdPar new_c) + return (HsCmdPar x new_c) -zonkCmd env (HsCmdCase expr ms) +zonkCmd env (HsCmdCase x expr ms) = do new_expr <- zonkLExpr env expr new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase new_expr new_ms) + return (HsCmdCase x new_expr new_ms) -zonkCmd env (HsCmdIf eCond ePred cThen cElse) +zonkCmd env (HsCmdIf x eCond ePred cThen cElse) = do { (env1, new_eCond) <- zonkWit env eCond ; new_ePred <- zonkLExpr env1 ePred ; new_cThen <- zonkLCmd env1 cThen ; new_cElse <- zonkLCmd env1 cElse - ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } + ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w -zonkCmd env (HsCmdLet (L l binds) cmd) +zonkCmd env (HsCmdLet x (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet (L l new_binds) new_cmd) + return (HsCmdLet x (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo (L l stmts) ty) +zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToType env ty - return (HsCmdDo (L l new_stmts) new_ty) - + return (HsCmdDo new_ty (L l new_stmts)) +zonkCmd _ (XCmd{}) = panic "zonkCmd" @@ -914,7 +923,7 @@ zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc) -zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) +zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) = do new_cmd <- zonkLCmd env cmd new_stack_tys <- zonkTcTypeToType env stack_tys new_ty <- zonkTcTypeToType env ty @@ -925,7 +934,8 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) -- but indeed it should always be lifted due to the typing -- rules for arrows - return (HsCmdTop new_cmd new_stack_tys new_ty new_ids) + return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) +zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top" ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) @@ -953,10 +963,12 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc) -zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) +zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e }) = do { ty' <- zonkTcTypeToType env ty ; e' <- zonkExpr env e - ; return (lit { ol_witness = e', ol_type = ty' }) } + ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) } + +zonkOverLit _ XOverLit{} = panic "zonkOverLit" ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc) @@ -1000,15 +1012,18 @@ zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty) = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op ; new_bind_ty <- zonkTcTypeToType env1 bind_ty ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs - ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] + ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs + , b <- bs] env2 = extendIdZonkEnvRec env1 new_binders ; new_mzip <- zonkExpr env2 mzip_op ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) } where - zonk_branch env1 (ParStmtBlock stmts bndrs return_op) + zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts ; (env3, new_return) <- zonkSyntaxExpr env2 return_op - ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) } + ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) + new_return) } + zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt" zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id @@ -1173,9 +1188,9 @@ zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc) zonkPat env pat = wrapLocSndM (zonk_pat env) pat zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat p) +zonk_pat env (ParPat x p) = do { (env', p') <- zonkPat env p - ; return (env', ParPat p') } + ; return (env', ParPat x p') } zonk_pat env (WildPat ty) = do { ty' <- zonkTcTypeToType env ty @@ -1183,55 +1198,55 @@ zonk_pat env (WildPat ty) (text "In a wildcard pattern") ; return (env, WildPat ty') } -zonk_pat env (VarPat (L l v)) +zonk_pat env (VarPat x (L l v)) = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat (L l v')) } + ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) } -zonk_pat env (LazyPat pat) +zonk_pat env (LazyPat x pat) = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat pat') } + ; return (env', LazyPat x pat') } -zonk_pat env (BangPat pat) +zonk_pat env (BangPat x pat) = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat pat') } + ; return (env', BangPat x pat') } -zonk_pat env (AsPat (L loc v) pat) +zonk_pat env (AsPat x (L loc v) pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat (L loc v') pat') } + ; return (env', AsPat x (L loc v') pat') } -zonk_pat env (ViewPat expr pat ty) +zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr ; (env', pat') <- zonkPat env pat ; ty' <- zonkTcTypeToType env ty - ; return (env', ViewPat expr' pat' ty') } + ; return (env', ViewPat ty' expr' pat') } -zonk_pat env (ListPat pats ty Nothing) +zonk_pat env (ListPat x pats ty Nothing) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty' Nothing) } + ; return (env', ListPat x pats' ty' Nothing) } -zonk_pat env (ListPat pats ty (Just (ty2,wit))) +zonk_pat env (ListPat x pats ty (Just (ty2,wit))) = do { (env', wit') <- zonkSyntaxExpr env wit ; ty2' <- zonkTcTypeToType env' ty2 ; ty' <- zonkTcTypeToType env' ty ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) } + ; return (env'', ListPat x pats' ty' (Just (ty2',wit'))) } -zonk_pat env (PArrPat pats ty) +zonk_pat env (PArrPat ty pats) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', PArrPat pats' ty') } + ; return (env', PArrPat ty' pats') } -zonk_pat env (TuplePat pats boxed tys) +zonk_pat env (TuplePat tys pats boxed) = do { tys' <- mapM (zonkTcTypeToType env) tys ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat pats' boxed tys') } + ; return (env', TuplePat tys' pats' boxed) } -zonk_pat env (SumPat pat alt arity tys) +zonk_pat env (SumPat tys pat alt arity ) = do { tys' <- mapM (zonkTcTypeToType env) tys ; (env', pat') <- zonkPat env pat - ; return (env', SumPat pat' alt arity tys') } + ; return (env', SumPat tys' pat' alt arity) } zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars , pat_dicts = evs, pat_binds = binds @@ -1265,14 +1280,14 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars where doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p -zonk_pat env (LitPat lit) = return (env, LitPat lit) +zonk_pat env (LitPat x lit) = return (env, LitPat x lit) -zonk_pat env (SigPatOut pat ty) +zonk_pat env (SigPat ty pat) = do { ty' <- zonkTcTypeToType env ty ; (env', pat') <- zonkPat env pat - ; return (env', SigPatOut pat' ty') } + ; return (env', SigPat ty' pat') } -zonk_pat env (NPat (L l lit) mb_neg eq_expr ty) +zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr ; (env2, mb_neg') <- case mb_neg of Nothing -> return (env1, Nothing) @@ -1280,9 +1295,9 @@ zonk_pat env (NPat (L l lit) mb_neg eq_expr ty) ; lit' <- zonkOverLit env2 lit ; ty' <- zonkTcTypeToType env2 ty - ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') } + ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } -zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty) +zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) = do { (env1, e1') <- zonkSyntaxExpr env e1 ; (env2, e2') <- zonkSyntaxExpr env1 e2 ; n' <- zonkIdBndr env2 n @@ -1290,13 +1305,13 @@ zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty) ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToType env2 ty ; return (extendIdZonkEnv1 env2 n', - NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') } + NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } -zonk_pat env (CoPat co_fn pat ty) +zonk_pat env (CoPat x co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn ; (env'', pat') <- zonkPat env' (noLoc pat) ; ty' <- zonkTcTypeToType env'' ty - ; return (env'', CoPat co_fn' (unLoc pat') ty') } + ; return (env'', CoPat x co_fn' (unLoc pat') ty') } zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 6908d16dfc..762efbf5c8 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -484,19 +484,20 @@ tc_infer_lhs_type mode (L span ty) -- | Infer the kind of a type and desugar. This is the "up" type-checker, -- as described in Note [Bidirectional type checking] tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) -tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv -tc_infer_hs_type mode (HsAppTy ty1 ty2) +tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv +tc_infer_hs_type mode (HsAppTy _ ty1 ty2) = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty ; fun_kind' <- zonkTcType fun_kind ; tcTyApps mode fun_ty fun_ty' fun_kind' arg_tys } -tc_infer_hs_type mode (HsParTy t) = tc_infer_lhs_type mode t -tc_infer_hs_type mode (HsOpTy lhs (L loc_op op) rhs) +tc_infer_hs_type mode (HsParTy _ t) = tc_infer_lhs_type mode t +tc_infer_hs_type mode (HsOpTy _ lhs (L loc_op op) rhs) | not (op `hasKey` funTyConKey) = do { (op', op_kind) <- tcTyVar mode op ; op_kind' <- zonkTcType op_kind - ; tcTyApps mode (noLoc $ HsTyVar NotPromoted (L loc_op op)) op' op_kind' [lhs, rhs] } -tc_infer_hs_type mode (HsKindSig ty sig) + ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted (L loc_op op)) + op' op_kind' [lhs, rhs] } +tc_infer_hs_type mode (HsKindSig _ ty sig) = do { sig' <- tc_lhs_kind (kindLevel mode) sig ; ty' <- tc_lhs_type mode ty sig' ; return (ty', sig') } @@ -506,10 +507,10 @@ tc_infer_hs_type mode (HsKindSig ty sig) -- splices or not. -- -- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _) +tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) = tc_infer_hs_type mode ty -tc_infer_hs_type mode (HsDocTy ty _) = tc_infer_lhs_type mode ty -tc_infer_hs_type _ (HsCoreTy ty) = return (ty, typeKind ty) +tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty +tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) = return (ty, typeKind ty) tc_infer_hs_type mode other_ty = do { kv <- newMetaKindVar ; ty' <- tc_hs_type mode other_ty kv @@ -531,23 +532,25 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of ; res_k <- newOpenTypeKind ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind } + ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') + liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (HsFunTy ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind } + ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') + liftedTypeKind exp_kind } ------------------------------------------ -- See also Note [Bidirectional type checking] tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType -tc_hs_type mode (HsParTy ty) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type mode (HsDocTy ty _) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind tc_hs_type _ ty@(HsBangTy {}) _ -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210) = failWithTc (text "Unexpected strictness annotation:" <+> ppr ty) -tc_hs_type _ ty@(HsRecTy _) _ +tc_hs_type _ ty@(HsRecTy _ _) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) @@ -557,9 +560,7 @@ tc_hs_type _ ty@(HsRecTy _) _ -- while capturing the local environment. -- -- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty)) - _ - ) +tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) exp_kind = do addModFinalizersWithLclEnv mod_finalizers tc_hs_type mode ty exp_kind @@ -569,10 +570,10 @@ tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind = failWithTc (text "Unexpected type splice:" <+> ppr ty) ---------- Functions and applications -tc_hs_type mode (HsFunTy ty1 ty2) exp_kind +tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind = tc_fun_type mode ty1 ty2 exp_kind -tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind +tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind | op `hasKey` funTyConKey = tc_fun_type mode ty1 ty2 exp_kind @@ -606,12 +607,12 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind ; return (mkPhiTy ctxt' ty') } --------- Lists, arrays, and tuples -tc_hs_type mode rn_ty@(HsListTy elt_ty) exp_kind +tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; checkWiredInTyCon listTyCon ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } -tc_hs_type mode rn_ty@(HsPArrTy elt_ty) exp_kind +tc_hs_type mode rn_ty@(HsPArrTy _ elt_ty) exp_kind = do { MASSERT( isTypeLevel (mode_level mode) ) ; tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; checkWiredInTyCon parrTyCon @@ -619,7 +620,7 @@ tc_hs_type mode rn_ty@(HsPArrTy elt_ty) exp_kind -- See Note [Distinguishing tuple kinds] in HsTypes -- See Note [Inferring tuple kinds] -tc_hs_type mode rn_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind +tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind -- (NB: not zonking before looking at exp_k, to avoid left-right bias) | Just tup_sort <- tupKindSort_maybe exp_kind = traceTc "tc_hs_type tuple" (ppr hs_tys) >> @@ -647,7 +648,7 @@ tc_hs_type mode rn_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } -tc_hs_type mode rn_ty@(HsTupleTy hs_tup_sort tys) exp_kind +tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind = tc_tuple rn_ty mode tup_sort tys exp_kind where tup_sort = case hs_tup_sort of -- Fourth case dealt with above @@ -656,7 +657,7 @@ tc_hs_type mode rn_ty@(HsTupleTy hs_tup_sort tys) exp_kind HsConstraintTuple -> ConstraintTuple _ -> panic "tc_hs_type HsTupleTy" -tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind +tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind = do { let arity = length hs_tys ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds @@ -669,7 +670,7 @@ tc_hs_type mode rn_ty@(HsSumTy hs_tys) exp_kind } --------- Promoted lists and tuples -tc_hs_type mode rn_ty@(HsExplicitListTy _ _k tys) exp_kind +tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind = do { tks <- mapM (tc_infer_lhs_type mode) tys ; (taus', kind) <- unifyKinds tys tks ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') @@ -691,7 +692,7 @@ tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind arity = length tys --------- Constraint types -tc_hs_type mode rn_ty@(HsIParamTy (L _ n) ty) exp_kind +tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind = do { MASSERT( isTypeLevel (mode_level mode) ) ; ty' <- tc_lhs_type mode ty liftedTypeKind ; let n' = mkStrLitTy $ hsIPNameFS n @@ -699,7 +700,7 @@ tc_hs_type mode rn_ty@(HsIParamTy (L _ n) ty) exp_kind ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) constraintKind exp_kind } -tc_hs_type mode rn_ty@(HsEqTy ty1 ty2) exp_kind +tc_hs_type mode rn_ty@(HsEqTy _ ty1 ty2) exp_kind = do { (ty1', kind1) <- tc_infer_lhs_type mode ty1 ; (ty2', kind2) <- tc_infer_lhs_type mode ty2 ; ty2'' <- checkExpectedKind (unLoc ty2) ty2' kind2 kind1 @@ -708,11 +709,11 @@ tc_hs_type mode rn_ty@(HsEqTy ty1 ty2) exp_kind ; checkExpectedKind rn_ty ty' constraintKind exp_kind } --------- Literals -tc_hs_type _ rn_ty@(HsTyLit (HsNumTy _ n)) exp_kind +tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind = do { checkWiredInTyCon typeNatKindCon ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } -tc_hs_type _ rn_ty@(HsTyLit (HsStrTy _ s)) exp_kind +tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind = do { checkWiredInTyCon typeSymbolKindCon ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } @@ -722,7 +723,7 @@ tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsCoreTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type _ (HsWildCardTy wc) exp_kind = do { wc_tv <- tcWildCardOcc wc exp_kind @@ -1496,19 +1497,20 @@ kcHsTyVarBndrs name flav cusk all_kind_vars = tcExtendTyVarEnv [tv] thing_inside kc_hs_tv :: HsTyVarBndr GhcRn -> TcM (TcTyVar, Bool) - kc_hs_tv (UserTyVar lname@(L _ name)) + kc_hs_tv (UserTyVar _ lname@(L _ name)) = do { tv_pair@(tv, scoped) <- tcHsTyVarName Nothing name -- Open type/data families default their variables to kind *. ; when (open_fam && not scoped) $ -- (don't default class tyvars) - discardResult $ unifyKind (Just (HsTyVar NotPromoted lname)) liftedTypeKind - (tyVarKind tv) + discardResult $ unifyKind (Just (HsTyVar noExt NotPromoted lname)) + liftedTypeKind (tyVarKind tv) ; return tv_pair } - kc_hs_tv (KindedTyVar (L _ name) lhs_kind) + kc_hs_tv (KindedTyVar _ (L _ name) lhs_kind) = do { kind <- tcLHsKindSig lhs_kind ; tcHsTyVarName (Just kind) name } + kc_hs_tv (XTyVarBndr{}) = panic "kc_hs_tv" report_non_cusk_tvs all_tvs = do { all_tvs <- mapM zonkTyCoVarKind all_tvs @@ -1626,14 +1628,16 @@ tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) -- -- See also Note [Associated type tyvar names] in Class -- -tcHsTyVarBndr new_tv (UserTyVar (L _ name)) +tcHsTyVarBndr new_tv (UserTyVar _(L _ name)) = do { kind <- newMetaKindVar ; new_tv name kind } -tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind) +tcHsTyVarBndr new_tv (KindedTyVar _ (L _ name) kind) = do { kind <- tcLHsKindSig kind ; new_tv name kind } +tcHsTyVarBndr _ (XTyVarBndr{}) = panic "tcHsTyVarBndr" + newWildTyVar :: Name -> TcM TcTyVar -- ^ New unification variable for a wildcard newWildTyVar _name @@ -1656,7 +1660,8 @@ tcHsTyVarName m_kind name Just (ATyVar _ tv) -> do { whenIsJust m_kind $ \ kind -> discardResult $ - unifyKind (Just (HsTyVar NotPromoted (noLoc name))) kind (tyVarKind tv) + unifyKind (Just (HsTyVar noExt NotPromoted (noLoc name))) + kind (tyVarKind tv) ; return (tv, True) } _ -> do { kind <- case m_kind of Just kind -> return kind diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 89a0ec6272..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,8 +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 $ HsCoreTy 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..1863a2fdda 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) @@ -468,13 +468,14 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside loop [] = do { thing <- thing_inside elt_ty ; return ([], thing) } -- matching in the branches - loop (ParStmtBlock stmts names _ : pairs) + loop (ParStmtBlock x stmts names _ : pairs) = do { (stmts', (ids, pairs', thing)) <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> do { ids <- tcLookupLocalIds names ; (pairs', thing) <- loop pairs ; return (ids, pairs', thing) } - ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) } + ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } + loop (XParStmtBlock{}:_) = panic "tcLcStmt" tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap @@ -761,7 +762,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside -- type dummies since we don't know all binder types yet ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) - [ names | ParStmtBlock _ names _ <- bndr_stmts_s ] + [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] -- Typecheck bind: ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] @@ -791,7 +792,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside -- matching in the branches loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) - (ParStmtBlock stmts names return_op : pairs) + (ParStmtBlock x stmts names return_op : pairs) = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in ; (stmts', (ids, return_op', pairs', thing)) <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ @@ -804,7 +805,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside \ _ -> return () ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs ; return (ids, return_op', pairs', thing) } - ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) } + ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } loop _ _ _ _ = panic "tcMcStmt.loop" tcMcStmt _ stmt _ _ @@ -1011,10 +1012,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 +1053,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 +1074,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/TcPat.hs b/compiler/typecheck/TcPat.hs index c5e367e3be..05aa489b55 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -324,21 +324,21 @@ tc_pat :: PatEnv -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat (L l name)) pat_ty thing_inside +tc_pat penv (VarPat x (L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat (L l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } -tc_pat penv (ParPat pat) pat_ty thing_inside +tc_pat penv (ParPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ParPat pat', res) } + ; return (ParPat x pat', res) } -tc_pat penv (BangPat pat) pat_ty thing_inside +tc_pat penv (BangPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (BangPat pat', res) } + ; return (BangPat x pat', res) } -tc_pat penv (LazyPat pat) pat_ty thing_inside +tc_pat penv (LazyPat x pat) pat_ty thing_inside = do { (pat', (res, pat_ct)) <- tc_lpat pat pat_ty (makeLazy penv) $ captureConstraints thing_inside @@ -352,14 +352,14 @@ tc_pat penv (LazyPat pat) pat_ty thing_inside ; pat_ty <- readExpType pat_ty ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind - ; return (LazyPat pat', res) } + ; return (LazyPat x pat', res) } tc_pat _ (WildPat _) pat_ty thing_inside = do { res <- thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside +tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) @@ -372,9 +372,10 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, + res) } -tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside +tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside = do { -- Expr must have type `forall a1...aN. OPT' -> B` -- where overall_pat_ty is an instance of OPT'. @@ -401,30 +402,30 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside -- (overall_pat_ty -> inf_res_ty) expr_wrap = expr_wrap2' <.> expr_wrap1 doc = text "When checking the view pattern function:" <+> (ppr expr) - ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) } + ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)} -- Type signatures in patterns -- See Note [Pattern coercions] below -tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside +tc_pat penv (SigPat sig_ty pat ) pat_ty thing_inside = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty ; (pat', res) <- tcExtendTyVarEnv2 wcs $ tcExtendTyVarEnv2 tv_binds $ tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } + ; return (mkHsWrapPat wrap (SigPat inner_ty pat') pat_ty, res) } ------------------------ -- Lists, tuples, arrays -tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside +tc_pat penv (ListPat x pats _ Nothing) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) - } + ; return (mkHsWrapPat coi (ListPat x pats' elt_ty Nothing) pat_ty, res) +} -tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside +tc_pat penv (ListPat x pats _ (Just (_,e))) pat_ty thing_inside = do { tau_pat_ty <- expTypeToType pat_ty ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] @@ -433,18 +434,18 @@ tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; return (pats', res, elt_ty) } - ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res) - } + ; return (ListPat x pats' elt_ty (Just (tau_pat_ty,e')), res) +} -tc_pat penv (PArrPat pats _) pat_ty thing_inside +tc_pat penv (PArrPat _ pats ) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res) + ; return (mkHsWrapPat coi (PArrPat elt_ty pats') pat_ty, res) } -tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside +tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside = do { let arity = length pats tc = tupleTyCon boxity arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) @@ -463,19 +464,19 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside -- This is a pretty odd place to make the switch, but -- it was easy to do. ; let - unmangled_result = TuplePat pats' boxity con_arg_tys + unmangled_result = TuplePat con_arg_tys pats' boxity -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat (noLoc unmangled_result) - | otherwise = unmangled_result + isBoxed boxity = LazyPat noExt (noLoc unmangled_result) + | otherwise = unmangled_result ; pat_ty <- readExpType pat_ty ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced return (mkHsWrapPat coi possibly_mangled_result pat_ty, res) } -tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside +tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside = do { let tc = sumTyCon arity ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) penv pat_ty @@ -484,7 +485,8 @@ tc_pat penv (SumPat pat alt arity _) pat_ty thing_inside ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1))) penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (SumPat pat' alt arity con_arg_tys) pat_ty, res) + ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty + , res) } ------------------------ @@ -494,12 +496,12 @@ tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside ------------------------ -- Literal patterns -tc_pat penv (LitPat simple_lit) pat_ty thing_inside +tc_pat penv (LitPat x simple_lit) pat_ty thing_inside = do { let lit_ty = hsLitType simple_lit ; wrap <- tcSubTypePat penv pat_ty lit_ty ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return ( mkHsWrapPat wrap (LitPat (convertLit simple_lit)) pat_ty + ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty , res) } ------------------------ @@ -520,7 +522,7 @@ tc_pat penv (LitPat simple_lit) pat_ty thing_inside -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside +tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] @@ -538,7 +540,7 @@ tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return (NPat (L l lit') mb_neg' eq' pat_ty, res) } + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -569,7 +571,8 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside +tc_pat penv (NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus) pat_ty + thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit ; (lit1', ge') @@ -598,15 +601,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat (L nm_loc bndr_id) (L loc lit1') lit2' - ge' minus'' pat_ty + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' + ge' minus'' ; return (pat', res) } -- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'. -- Here we get rid of it and add the finalizers to the global environment. -- -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. -tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat))) +tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat))) pat_ty thing_inside = do addModFinalizersWithLclEnv mod_finalizers tc_pat penv pat pat_ty thing_inside @@ -982,14 +985,16 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv + tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat' + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' pun), res) } + tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ + = panic "tcConArgs" find_field_ty :: Name -> FieldLabelString -> TcM TcType find_field_ty sel lbl diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 283127215c..2035abc1ba 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] @@ -515,7 +515,7 @@ mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -- ^ Visible field labels -> HsValBinds GhcRn mkPatSynRecSelBinds ps fields - = ValBindsOut selector_binds sigs + = XValBindsLR (NValBinds selector_binds sigs) where (sigs, selector_binds) = unzip (map mkRecSel fields) mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl @@ -608,11 +608,11 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] - where - builder_args = [L loc (VarPat (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) - builder_args body - (noLoc EmptyLocalBinds) + where + builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_args body + (noLoc EmptyLocalBinds) args = case details of PrefixPatSyn args -> args @@ -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 @@ -688,48 +688,52 @@ tcPatToExpr name args pat = go pat InfixCon l r -> mkPrefixConExpr con [l,r] RecCon fields -> mkRecordConExpr con fields - go1 (SigPatIn pat _) = go1 (unLoc pat) + go1 (SigPat _ pat) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat (L l var)) + 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 (PArrPat pats ptt) = do { exprs <- mapM go pats - ; return $ ExplicitPArr ptt exprs } - go1 p@(ListPat pats ptt reb) - | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList ptt Nothing exprs } + go1 (ParPat _ pat) = fmap (HsPar noExt) $ go pat + go1 (PArrPat _ pats) = do { exprs <- mapM go pats + ; return $ ExplicitPArr noExt exprs } + go1 p@(ListPat _ pats _ty reb) + | Nothing <- reb = do { exprs <- mapM go pats + ; return $ ExplicitList noExt Nothing exprs } | otherwise = notInvertibleListPat p - go1 (TuplePat pats box _) = do { exprs <- mapM go pats - ; return $ ExplicitTuple - (map (noLoc . Present) exprs) box } - go1 (SumPat pat alt arity _) = do { expr <- go1 (unLoc pat) - ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder + go1 (TuplePat _ pats box) = do { exprs <- mapM go pats + ; return $ ExplicitTuple noExt + (map (noLoc . (Present noExt)) exprs) + box } + go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) + ; return $ ExplicitSum noExt alt arity + (noLoc expr) } - go1 (LitPat lit) = return $ HsLit lit - go1 (NPat (L _ n) mb_neg _ _) - | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit n)] - | otherwise = return $ HsOverLit n + go1 (LitPat _ lit) = return $ HsLit noExt lit + go1 (NPat _ (L _ n) mb_neg _) + | 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 (SigPatOut{}) = panic "SigPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" - go1 (SplicePat (HsSpliced _ (HsSplicedPat pat))) + go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go1 pat - go1 (SplicePat (HsSpliced{})) = panic "Invalid splice variety" + go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" -- The following patterns are not invertible. - go1 p@(BangPat {}) = notInvertible p -- #14112 - go1 p@(LazyPat {}) = notInvertible p - go1 p@(WildPat {}) = notInvertible p - go1 p@(AsPat {}) = notInvertible p - go1 p@(ViewPat {}) = notInvertible p - go1 p@(NPlusKPat {}) = notInvertible p - go1 p@(SplicePat (HsTypedSplice {})) = notInvertible p - go1 p@(SplicePat (HsUntypedSplice {})) = notInvertible p - go1 p@(SplicePat (HsQuasiQuote {})) = notInvertible p + go1 p@(BangPat {}) = notInvertible p -- #14112 + go1 p@(LazyPat {}) = notInvertible p + go1 p@(WildPat {}) = notInvertible p + go1 p@(AsPat {}) = notInvertible p + go1 p@(ViewPat {}) = notInvertible p + go1 p@(NPlusKPat {}) = notInvertible p + go1 p@(XPat {}) = notInvertible p + go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p + go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p + go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p + go1 p@(SplicePat _ (XSplice {})) = notInvertible p notInvertible p = Left (not_invertible_msg p) @@ -841,39 +845,41 @@ tcCheckPatSynPat = go go1 :: Pat GhcRn -> TcM () -- See Note [Bad patterns] - go1 p@(AsPat _ _) = asPatInPatSynErr p - go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p - - go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) - go1 VarPat{} = return () - go1 WildPat{} = return () - go1 (LazyPat pat) = go pat - go1 (ParPat pat) = go pat - go1 (BangPat pat) = go pat - go1 (PArrPat pats _) = mapM_ go pats - go1 (ListPat pats _ _) = mapM_ go pats - go1 (TuplePat pats _ _) = mapM_ go pats - go1 (SumPat pat _ _ _) = go pat - go1 LitPat{} = return () - go1 NPat{} = return () - go1 (SigPatIn pat _) = go pat - go1 (ViewPat _ pat _) = go pat - go1 (SplicePat splice) - | HsSpliced mod_finalizers (HsSplicedPat pat) <- splice + go1 p@(AsPat _ _ _) = asPatInPatSynErr p + go1 p@NPlusKPat{} = nPlusKPatInPatSynErr p + + go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) + go1 VarPat{} = return () + go1 WildPat{} = return () + go1 (LazyPat _ pat) = go pat + go1 (ParPat _ pat) = go pat + go1 (BangPat _ pat) = go pat + go1 (PArrPat _ pats) = mapM_ go pats + go1 (ListPat _ pats _ _) = mapM_ go pats + go1 (TuplePat _ pats _) = mapM_ go pats + go1 (SumPat _ pat _ _) = go pat + go1 LitPat{} = return () + go1 NPat{} = return () + go1 (SigPat _ pat) = go pat + go1 (ViewPat _ _ pat) = go pat + go1 (SplicePat _ splice) + | HsSpliced _ mod_finalizers (HsSplicedPat pat) <- splice = do addModFinalizersWithLclEnv mod_finalizers go1 pat | otherwise = panic "non-pattern from spliced thing" go1 ConPatOut{} = panic "ConPatOut in output of renamer" - go1 SigPatOut{} = panic "SigPatOut in output of renamer" go1 CoPat{} = panic "CoPat in output of renamer" + go1 XPat{} = panic "XPat in output of renamer" -asPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a +asPatInPatSynErr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Pat (GhcPass p) -> TcM a asPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) -nPlusKPatInPatSynErr :: (SourceTextX p, OutputableBndrId p) => Pat p -> TcM a +nPlusKPatInPatSynErr :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Pat (GhcPass p) -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain n+k-pattern:") @@ -919,20 +925,20 @@ tcCollectEx pat = go pat go = go1 . unLoc go1 :: Pat GhcTc -> ([TyVar], [EvVar]) - go1 (LazyPat p) = go p - go1 (AsPat _ p) = go p - go1 (ParPat p) = go p - go1 (BangPat p) = go p - go1 (ListPat ps _ _) = mergeMany . map go $ ps - go1 (TuplePat ps _ _) = mergeMany . map go $ ps - go1 (SumPat p _ _ _) = go p - go1 (PArrPat ps _) = mergeMany . map go $ ps - go1 (ViewPat _ p _) = go p - go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ + go1 (LazyPat _ p) = go p + go1 (AsPat _ _ p) = go p + go1 (ParPat _ p) = go p + go1 (BangPat _ p) = go p + go1 (ListPat _ ps _ _) = mergeMany . map go $ ps + go1 (TuplePat _ ps _) = mergeMany . map go $ ps + go1 (SumPat _ p _ _) = go p + go1 (PArrPat _ ps) = mergeMany . map go $ ps + go1 (ViewPat _ _ p) = go p + go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $ goConDetails $ pat_args con - go1 (SigPatOut p _) = go p - go1 (CoPat _ p _) = go1 p - go1 (NPlusKPat n k _ geq subtract _) + go1 (SigPat _ p) = go p + go1 (CoPat _ _ p _) = go1 p + go1 (NPlusKPat _ n k _ geq subtract) = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract go1 _ = empty diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index fd63effbe6..58fb78be14 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -13,6 +13,7 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} module TcRnDriver ( tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, @@ -576,7 +577,8 @@ tcRnHsBootDecls hsc_src decls , hs_ruleds = rule_decls , hs_vects = vect_decls , hs_annds = _ - , hs_valds = ValBindsOut val_binds val_sigs }) + , hs_valds + = XValBindsLR (NValBinds val_binds val_sigs) }) <- rnTopSrcDecls first_group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource @@ -1322,7 +1324,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_annds = annotation_decls, hs_ruleds = rule_decls, hs_vects = vect_decls, - hs_valds = hs_val_binds@(ValBindsOut val_binds val_sigs) }) + hs_valds = hs_val_binds@(XValBindsLR + (NValBinds val_binds val_sigs)) }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc "Tc2 (src)" empty ; @@ -1330,7 +1333,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Source-language instances, including derivings, -- and import the supporting declarations traceTc "Tc3" empty ; - (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs) + (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs)) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; setGblEnv tcg_env $ do { @@ -1675,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] @@ -1995,15 +1998,16 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ - ValBindsOut [(NonRecursive,unitBag the_bind)] [] + let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ XValBindsLR + (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e] - bind_stmt = L loc $ BindStmt (L loc (VarPat (L loc fresh_it))) - (nlHsApp ghciStep rn_expr) - (mkRnSyntaxExpr bindIOName) - noSyntaxExpr - PlaceHolder + bind_stmt = L loc $ BindStmt + (L loc (VarPat noExt (L loc fresh_it))) + (nlHsApp ghciStep rn_expr) + (mkRnSyntaxExpr bindIOName) + noSyntaxExpr + placeHolder -- [; print it] print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) @@ -2120,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)) @@ -2128,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) @@ -2139,13 +2144,15 @@ getGhciStepIO = do let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)] - , hst_body = nlHsFunTy ghciM ioM } + step_ty = noLoc $ HsForAllTy + { hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)] + , hst_xforall = noExt + , hst_body = nlHsFunTy ghciM ioM } 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 5f7498fa16..7e347ffe2c 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..1543b7f085 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -161,7 +161,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -- See Note [How brackets and nested splices are handled] -- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTypedBracket rn_expr brack@(TExpBr expr) res_ty +tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty = addErrCtxt (quotationCtxtDoc brack) $ do { cur_stage <- getStage ; ps_ref <- newMutVar [] @@ -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,17 +194,19 @@ 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 -tcBrackTy (VarBr _ _) = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) -tcBrackTy (ExpBr _) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) -tcBrackTy (TypBr _) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) -tcBrackTy (DecBrG _) = tcMetaTy decsQTyConName -- Result type is Q [Dec] -tcBrackTy (PatBr _) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) -tcBrackTy (DecBrL _) = panic "tcBrackTy: Unexpected DecBrL" -tcBrackTy (TExpBr _) = panic "tcUntypedBracket: Unexpected TExpBr" +tcBrackTy (VarBr {}) = tcMetaTy nameTyConName + -- Result type is Var (not Q-monadic) +tcBrackTy (ExpBr {}) = tcMetaTy expQTyConName -- Result type is ExpQ (= Q Exp) +tcBrackTy (TypBr {}) = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ) +tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec] +tcBrackTy (PatBr {}) = tcMetaTy patQTyConName -- Result type is PatQ (= Q Pat) +tcBrackTy (DecBrL {}) = panic "tcBrackTy: Unexpected DecBrL" +tcBrackTy (TExpBr {}) = panic "tcUntypedBracket: Unexpected TExpBr" +tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket" --------------- tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice @@ -432,7 +434,7 @@ When a variable is used, we compare ************************************************************************ -} -tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty +tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty = addErrCtxt (spliceCtxtDoc splice) $ setSrcSpan (getLoc expr) $ do { stage <- getStage @@ -582,8 +584,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/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 97981836ae..b0b90d910f 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -526,9 +526,9 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name where -- Keep this synchronized with 'hsDeclHasCusk'. kind_annotation (L _ ty) = case ty of - HsParTy lty -> kind_annotation lty - HsKindSig _ k -> Just k - _ -> Nothing + HsParTy _ lty -> kind_annotation lty + HsKindSig _ _ k -> Just k + _ -> Nothing --------------------------------- getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class @@ -548,8 +548,8 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name = do { (tycon, _) <- kcHsTyVarBndrs name flav cusk True ktvs $ do { res_k <- case resultSig of - KindSig ki -> tcLHsKindSig ki - TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki + KindSig ki -> tcLHsKindSig ki + TyVarSig (L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return liftedTypeKind -- closed type families have their return kind inferred @@ -1403,7 +1403,7 @@ tc_fam_ty_pats tc_fam_tc mb_clsinfo tv_names arg_pats -- See Note [Quantifying over family patterns] ; (arg_tvs, (args, stuff)) <- tcImplicitTKBndrs tv_names $ do { let loc = nameSrcSpan name - lhs_fun = L loc (HsTyVar NotPromoted (L loc name)) + lhs_fun = L loc (HsTyVar noExt NotPromoted (L loc name)) fun_ty = mkTyConApp tc_fam_tc [] fun_kind = tyConKind tc_fam_tc mb_kind_env = thdOf3 <$> mb_clsinfo diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 6b77cc7b7b..7d8a004041 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -827,7 +827,7 @@ mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications mkRecSelBinds tycons - = ValBindsOut binds sigs + = XValBindsLR (NValBinds binds sigs) where (sigs, binds) = unzip rec_sels rec_sels = map mkRecSelBind [ (tc,fld) @@ -882,13 +882,14 @@ 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 { hsRecFieldLbl - = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name) - , hsRecFieldArg = L loc (VarPat (L loc field_var)) + = L loc (FieldOcc sel_name (L loc $ mkVarUnqual lbl)) + , hsRecFieldArg + = L loc (VarPat noExt (L loc field_var)) , hsRecPun = False }) sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc @@ -898,10 +899,10 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat placeHolderType)] - (mkHsApp (L loc (HsVar + [L loc (WildPat noExt)] + (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 fd8749a3e1..bd555916a2 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -321,19 +321,19 @@ 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)) getTypeLPat (L spn pat) = pure (Just (getMaybeId pat,spn,hsPatType pat)) where - getMaybeId (VarPat (L _ vid)) = Just vid - getMaybeId _ = Nothing + getMaybeId (VarPat _ (L _ vid)) = Just vid + getMaybeId _ = Nothing -- | Get ALL source spans in the source. listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs index 3a8a29abd4..b04be775c3 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 46ab21412e..b80ab62507 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -49,6 +49,7 @@ (PrefixCon [({ DumpParsedAst.hs:5:26-30 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:5:26-30 } (Unqual @@ -73,25 +74,32 @@ {OccName: Length})) [({ DumpParsedAst.hs:8:10-17 } (HsParTy + (PlaceHolder) ({ DumpParsedAst.hs:8:11-16 } (HsAppsTy + (PlaceHolder) [({ DumpParsedAst.hs:8:11 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:8:11 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:11 } (Unqual {OccName: a})))))) ,({ DumpParsedAst.hs:8:13 } (HsAppInfix + (PlaceHolder) ({ DumpParsedAst.hs:8:13 } (Exact {Name: :})))) ,({ DumpParsedAst.hs:8:15-16 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:8:15-16 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:15-16 } (Unqual @@ -99,32 +107,42 @@ (Prefix) ({ DumpParsedAst.hs:8:21-36 } (HsAppsTy + (PlaceHolder) [({ DumpParsedAst.hs:8:21-24 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:8:21-24 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:21-24 } (Unqual {OccName: Succ})))))) ,({ DumpParsedAst.hs:8:26-36 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:8:26-36 } (HsParTy + (PlaceHolder) ({ DumpParsedAst.hs:8:27-35 } (HsAppsTy + (PlaceHolder) [({ DumpParsedAst.hs:8:27-32 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:8:27-32 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:27-32 } (Unqual {OccName: Length})))))) ,({ DumpParsedAst.hs:8:34-35 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:8:34-35 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:8:34-35 } (Unqual @@ -139,16 +157,19 @@ {OccName: Length})) [({ DumpParsedAst.hs:9:10-12 } (HsExplicitListTy - (Promoted) (PlaceHolder) + (Promoted) []))] (Prefix) ({ DumpParsedAst.hs:9:21-24 } (HsAppsTy + (PlaceHolder) [({ DumpParsedAst.hs:9:21-24 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:9:21-24 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:9:21-24 } (Unqual @@ -161,21 +182,28 @@ (PlaceHolder) [({ DumpParsedAst.hs:7:20-30 } (KindedTyVar + (PlaceHolder) ({ DumpParsedAst.hs:7:21-22 } (Unqual {OccName: as})) ({ DumpParsedAst.hs:7:27-29 } (HsAppsTy + (PlaceHolder) [({ DumpParsedAst.hs:7:27-29 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:7:27-29 } (HsListTy + (PlaceHolder) ({ DumpParsedAst.hs:7:28 } (HsAppsTy + (PlaceHolder) [({ DumpParsedAst.hs:7:28 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:7:28 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:7:28 } (Unqual @@ -186,10 +214,13 @@ (KindSig ({ DumpParsedAst.hs:7:35-39 } (HsAppsTy + (PlaceHolder) [({ DumpParsedAst.hs:7:35-39 } (HsAppPrefix + (PlaceHolder) ({ DumpParsedAst.hs:7:35-39 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpParsedAst.hs:7:35-39 } (Unqual @@ -218,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 c7daf90ff0..fbc30626fa 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -4,50 +4,54 @@ (Just ((,,,) (HsGroup - (ValBindsOut - [((,) - (NonRecursive) - {Bag(Located (HsBind Name)): - [({ DumpRenamedAst.hs:18:1-23 } - (FunBind - ({ DumpRenamedAst.hs:18:1-4 } - {Name: DumpRenamedAst.main}) - (MG - ({ DumpRenamedAst.hs:18:1-23 } - [({ DumpRenamedAst.hs:18:1-23 } - (Match - (FunRhs - ({ DumpRenamedAst.hs:18:1-4 } - {Name: DumpRenamedAst.main}) - (Prefix) - (NoSrcStrict)) - [] - (GRHSs - [({ DumpRenamedAst.hs:18:6-23 } - (GRHS - [] - ({ DumpRenamedAst.hs:18:8-23 } - (HsApp - ({ DumpRenamedAst.hs:18:8-15 } - (HsVar - ({ DumpRenamedAst.hs:18:8-15 } - {Name: System.IO.putStrLn}))) - ({ DumpRenamedAst.hs:18:17-23 } - (HsLit - (HsString - (SourceText - "\"hello\"") - {FastString: "hello"})))))))] - ({ <no location info> } - (EmptyLocalBinds)))))]) - [] - (PlaceHolder) - (FromSource)) - (WpHole) - {NameSet: - []} - []))]})] - []) + (XValBindsLR + (NValBinds + [((,) + (NonRecursive) + {Bag(Located (HsBind Name)): + [({ DumpRenamedAst.hs:18:1-23 } + (FunBind + ({ DumpRenamedAst.hs:18:1-4 } + {Name: DumpRenamedAst.main}) + (MG + ({ DumpRenamedAst.hs:18:1-23 } + [({ DumpRenamedAst.hs:18:1-23 } + (Match + (FunRhs + ({ DumpRenamedAst.hs:18:1-4 } + {Name: DumpRenamedAst.main}) + (Prefix) + (NoSrcStrict)) + [] + (GRHSs + [({ DumpRenamedAst.hs:18:6-23 } + (GRHS + [] + ({ 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\"") + {FastString: "hello"})))))))] + ({ <no location info> } + (EmptyLocalBinds)))))]) + [] + (PlaceHolder) + (FromSource)) + (WpHole) + {NameSet: + []} + []))]})] + [])) [] [(TyClGroup [({ DumpRenamedAst.hs:6:1-30 } @@ -88,6 +92,7 @@ (PrefixCon [({ DumpRenamedAst.hs:6:26-30 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:6:26-30 } {Name: DumpRenamedAst.Peano})))]) @@ -114,10 +119,13 @@ {Name: DumpRenamedAst.Length}) [({ DumpRenamedAst.hs:9:10-17 } (HsParTy + (PlaceHolder) ({ DumpRenamedAst.hs:9:11-16 } (HsOpTy + (PlaceHolder) ({ DumpRenamedAst.hs:9:11 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:11 } {Name: a}))) @@ -125,28 +133,35 @@ {Name: :}) ({ DumpRenamedAst.hs:9:15-16 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:15-16 } {Name: as})))))))] (Prefix) ({ DumpRenamedAst.hs:9:21-36 } (HsAppTy + (PlaceHolder) ({ DumpRenamedAst.hs:9:21-24 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:21-24 } {Name: DumpRenamedAst.Succ}))) ({ DumpRenamedAst.hs:9:26-36 } (HsParTy + (PlaceHolder) ({ DumpRenamedAst.hs:9:27-35 } (HsAppTy + (PlaceHolder) ({ DumpRenamedAst.hs:9:27-32 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:27-32 } {Name: DumpRenamedAst.Length}))) ({ DumpRenamedAst.hs:9:34-35 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:9:34-35 } {Name: as})))))))))) @@ -159,12 +174,13 @@ {Name: DumpRenamedAst.Length}) [({ DumpRenamedAst.hs:10:10-12 } (HsExplicitListTy - (Promoted) (PlaceHolder) + (Promoted) []))] (Prefix) ({ DumpRenamedAst.hs:10:21-24 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:10:21-24 } {Name: DumpRenamedAst.Zero})))) @@ -175,12 +191,15 @@ [{Name: k}] [({ DumpRenamedAst.hs:8:20-30 } (KindedTyVar + (PlaceHolder) ({ DumpRenamedAst.hs:8:21-22 } {Name: as}) ({ DumpRenamedAst.hs:8:27-29 } (HsListTy + (PlaceHolder) ({ DumpRenamedAst.hs:8:28 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:8:28 } {Name: k})))))))] @@ -191,6 +210,7 @@ (KindSig ({ DumpRenamedAst.hs:8:35-39 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:8:35-39 } {Name: DumpRenamedAst.Peano}))))) @@ -214,20 +234,25 @@ (KindSig ({ DumpRenamedAst.hs:12:20-30 } (HsFunTy + (PlaceHolder) ({ DumpRenamedAst.hs:12:20 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:12:20 } {Name: k}))) ({ DumpRenamedAst.hs:12:25-30 } (HsFunTy + (PlaceHolder) ({ DumpRenamedAst.hs:12:25 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:12:25 } {Name: k}))) ({ DumpRenamedAst.hs:12:30 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:12:30 } {Name: GHC.Types.*}))))))))) @@ -244,20 +269,25 @@ {Name: DumpRenamedAst.Nat}) [({ DumpRenamedAst.hs:15:22-34 } (HsKindSig + (PlaceHolder) ({ DumpRenamedAst.hs:15:23 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:23 } {Name: a}))) ({ DumpRenamedAst.hs:15:28-33 } (HsFunTy + (PlaceHolder) ({ DumpRenamedAst.hs:15:28 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:28 } {Name: k}))) ({ DumpRenamedAst.hs:15:33 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:33 } {Name: GHC.Types.*})))))))] @@ -270,22 +300,28 @@ (Just ({ DumpRenamedAst.hs:15:39-51 } (HsFunTy + (PlaceHolder) ({ DumpRenamedAst.hs:15:39-46 } (HsParTy + (PlaceHolder) ({ DumpRenamedAst.hs:15:40-45 } (HsFunTy + (PlaceHolder) ({ DumpRenamedAst.hs:15:40 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:40 } {Name: k}))) ({ DumpRenamedAst.hs:15:45 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:45 } {Name: GHC.Types.*}))))))) ({ DumpRenamedAst.hs:15:51 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:15:51 } {Name: GHC.Types.*})))))) @@ -298,56 +334,72 @@ ,{Name: g}] ({ DumpRenamedAst.hs:16:10-45 } (HsFunTy + (PlaceHolder) ({ DumpRenamedAst.hs:16:10-34 } (HsParTy + (PlaceHolder) ({ DumpRenamedAst.hs:16:11-33 } (HsForAllTy + (PlaceHolder) [({ DumpRenamedAst.hs:16:18-19 } (UserTyVar + (PlaceHolder) ({ DumpRenamedAst.hs:16:18-19 } {Name: xx})))] ({ DumpRenamedAst.hs:16:22-33 } (HsFunTy + (PlaceHolder) ({ DumpRenamedAst.hs:16:22-25 } (HsAppTy + (PlaceHolder) ({ DumpRenamedAst.hs:16:22 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:22 } {Name: f}))) ({ DumpRenamedAst.hs:16:24-25 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:24-25 } {Name: xx}))))) ({ DumpRenamedAst.hs:16:30-33 } (HsAppTy + (PlaceHolder) ({ DumpRenamedAst.hs:16:30 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:30 } {Name: g}))) ({ DumpRenamedAst.hs:16:32-33 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:32-33 } {Name: xx}))))))))))) ({ DumpRenamedAst.hs:16:39-45 } (HsAppTy + (PlaceHolder) ({ DumpRenamedAst.hs:16:39-43 } (HsAppTy + (PlaceHolder) ({ DumpRenamedAst.hs:16:39-41 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:39-41 } {Name: DumpRenamedAst.Nat}))) ({ DumpRenamedAst.hs:16:43 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:43 } {Name: f}))))) ({ DumpRenamedAst.hs:16:45 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ DumpRenamedAst.hs:16:45 } {Name: g}))))))) 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/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 53e4a6f941..4965410e65 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -4,9 +4,10 @@ (Just ((,,,) (HsGroup - (ValBindsOut - [] - []) + (XValBindsLR + (NValBinds + [] + [])) [] [(TyClGroup [({ T14189.hs:6:1-42 } @@ -36,6 +37,7 @@ (PrefixCon [({ T14189.hs:6:18-20 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ T14189.hs:6:18-20 } {Name: GHC.Types.Int})))]) @@ -65,12 +67,13 @@ (ConDeclField [({ T14189.hs:6:33 } (FieldOcc + {Name: T14189.f} ({ T14189.hs:6:33 } (Unqual - {OccName: f})) - {Name: T14189.f}))] + {OccName: f}))))] ({ T14189.hs:6:38-40 } (HsTyVar + (PlaceHolder) (NotPromoted) ({ T14189.hs:6:38-40 } {Name: GHC.Types.Int}))) diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index b7e6b215ca..4d7c171393 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), 51592019560, 10) + [(wordsize(64), 102142130576, 10) # 2012-08-14: 26070600504 (amd64/Linux) # 2012-08-29: 26353100288 (amd64/Linux, new CG) # 2012-09-18: 26882813032 (amd64/Linux) @@ -166,6 +166,9 @@ test('haddock.compiler', # 2017-06-05: 65378619232 (amd64/Linux) Desugar modules compiled with -fno-code # 2017-06-06: 55990521024 (amd64/Linux) Don't pass on -dcore-lint in Haddock.mk # 2017-07-12: 51592019560 (amd64/Linux) Use getNameToInstancesIndex + # 2017-11-07: 65807004616 (amd64/Linux) Trees that grow + # 2017-11-11: 89414230688 (amd64/Linux) Trees that grow HsExpr + # 2017-11-12: 102142130576 (amd64/Linux) Trees that grow HsExpr #2 ,(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 42bb1b05c8..9cf060937e 100644 --- a/testsuite/tests/quasiquotation/T7918.hs +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -29,19 +29,19 @@ 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 () showTyVar :: Maybe (HsType GhcRn) -> Traverse () - showTyVar (Just (HsTyVar _ (L _ v))) = + showTyVar (Just (HsTyVar _ _ (L _ v))) = modify $ \(loc, ids) -> (loc, (v, loc) : ids) showTyVar _ = return () showPatVar :: Maybe (Pat GhcTc) -> Traverse () - showPatVar (Just (VarPat (L _ v))) = + showPatVar (Just (VarPat _ (L _ v))) = modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) showPatVar _ = return () diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index f74c7514db..059692622e 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -254,7 +254,7 @@ boundValues :: ModuleName -> HsGroup GhcRn -> [FoundThing] -- ^Finds all the top-level definitions in a module boundValues mod group = let vals = case hs_valds group of - ValBindsOut nest _sigs -> + XValBindsLR (NValBinds nest _sigs) -> [ x | (_rec, binds) <- nest , bind <- bagToList binds , x <- boundThings mod bind ] @@ -291,21 +291,20 @@ boundThings modname lbinding = lid id = FoundThing modname (getOccString id) loc in case unLoc lpat of WildPat _ -> tl - VarPat (L _ name) -> lid name : tl - LazyPat p -> patThings p tl - AsPat id p -> patThings p (thing id : tl) - ParPat p -> patThings p tl - BangPat p -> patThings p tl - ListPat ps _ _ -> foldr patThings tl ps - TuplePat ps _ _ -> foldr patThings tl ps - PArrPat ps _ -> foldr patThings tl ps + VarPat _ (L _ name) -> lid name : tl + LazyPat _ p -> patThings p tl + AsPat _ id p -> patThings p (thing id : tl) + ParPat _ p -> patThings p tl + BangPat _ p -> patThings p tl + ListPat _ ps _ _ -> foldr patThings tl ps + TuplePat _ ps _ -> foldr patThings tl ps + PArrPat _ ps -> foldr patThings tl ps ConPatIn _ conargs -> conArgs conargs tl ConPatOut{ pat_args = conargs } -> conArgs conargs tl - LitPat _ -> tl + LitPat _ _ -> tl NPat {} -> tl -- form of literal pattern? - NPlusKPat id _ _ _ _ _ -> thing id : tl - SigPatIn p _ -> patThings p tl - SigPatOut p _ -> patThings p tl + NPlusKPat _ id _ _ _ _ -> thing id : tl + SigPat _ p -> patThings p tl _ -> error "boundThings" conArgs (PrefixCon ps) tl = foldr patThings tl ps conArgs (RecCon (HsRecFields { rec_flds = flds })) tl diff --git a/utils/haddock b/utils/haddock -Subproject ae0d140334fff57f2737dbd7c5804b4868d9c3a +Subproject 04fd3e021cfe04eaaa470be4ae8408a41782186 |