diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2017-11-05 21:49:11 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2017-11-07 08:30:37 +0200 |
| commit | 0ff152c9e633accca48815e26e59d1af1fe44ceb (patch) | |
| tree | 2feec6a252ac5a4d2d6a98cd42e64f3ac801893e /compiler | |
| parent | 275ac8ef0a0081f16abbfb8934e10cf271573768 (diff) | |
| download | haskell-0ff152c9e633accca48815e26e59d1af1fe44ceb.tar.gz | |
WIP on combining Step 1 and 3 of Trees That Grow
See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow
Trees that grow extension points are added for
- ValBinds
- HsPat
- HsLit
- HsOverLit
- HsType
- HsTyVarBndr
- HsAppType
- FieldOcc
- AmbiguousFieldOcc
Updates haddock submodule
Test Plan: ./validate
Reviewers: shayan-najd, simonpj, austin, goldfire, bgamari
Subscribers: goldfire, rwbarton, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D4147
Diffstat (limited to 'compiler')
49 files changed, 2182 insertions, 1547 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index d49a5c3ab8..0dac73a87c 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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,10 +751,10 @@ 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 @@ -765,12 +765,12 @@ translatePat fam_insts pat = case pat of False -> mkCanFailPmPat arg_ty -- list - ListPat ps ty Nothing -> do + ListPat (ListPatTc ty Nothing) ps -> do foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec fam_insts (map unLoc ps) -- overloaded list - ListPat lpats elem_ty (Just (pat_ty, _to_list)) + ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats | Just e_ty <- splitListTyConApp_maybe pat_ty , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty -- elem_ty is frequently something like @@ -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 (ListPatTc e_ty Nothing) lpats) -- 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)) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 24d7d8a61c..c482c5c458 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -1187,31 +1187,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..e51dbc36ad 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -973,7 +973,7 @@ dsDo stmts [mfix_pat] body] , mg_arg_tys = [tup_ty], mg_res_ty = body_ty , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats + mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats body = noLoc $ HsDo DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2a181e8d16..070c6641b8 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -198,8 +198,8 @@ hsSigTvBinders binds get_scoped_tvs _ = [] sigs = case binds of - ValBindsIn _ sigs -> sigs - ValBindsOut _ sigs -> sigs + ValBindsIn _ _ sigs -> sigs + ValBindsOut _ sigs -> sigs {- Notes @@ -695,7 +695,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 +917,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 +1002,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 +1015,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 +1063,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) @@ -1137,8 +1139,9 @@ 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)) + Unambiguous x _ -> repE (HsVar (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 @@ -1318,7 +1321,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) @@ -1424,7 +1427,7 @@ rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_val_binds (ValBindsIn _ _) +rep_val_binds (ValBindsIn _ _ _) = panic "rep_val_binds: ValBindsIn" rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ] @@ -1611,19 +1614,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 Nothing ps) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps) + ; e' <- repE (syn_expr e) + ; repPview e' p} +repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } -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 +1647,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 +2204,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 +2364,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 +2377,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..b1aa886725 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 (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1 ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern @@ -299,13 +299,14 @@ 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 (ListPatTc ty (Just _)) pats) + = ListPat (ListPatTc ty Nothing) pats getOLPat _ = panic "getOLPat" {- @@ -398,19 +399,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 +426,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 +442,7 @@ tidy1 v (LazyPat pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat pats ty Nothing) +tidy1 _ (ListPat (ListPatTc ty Nothing) pats) = return (idDsWrapper, unLoc list_ConPat) where list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) @@ -450,29 +451,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 +485,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 +528,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 +539,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) @@ -1071,7 +1074,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 +1082,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 (ListPatTc _ (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..0af58e9728 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] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -246,7 +248,7 @@ 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/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 4336243e91..5e15288b25 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, @@ -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 (ValBindsIn noExt (listToBag binds) sigs)) } cvtClause :: HsMatchContext RdrName -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -1015,13 +1017,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 +1054,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 +1085,45 @@ 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' } + _ -> 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 placeHolderType 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' } 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 +1134,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 +1162,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 +1203,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 +1223,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 +1263,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 +1276,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 +1288,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 +1339,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 +1378,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 +1396,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 +1446,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 +1505,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 +1529,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..c65018bde8 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,68 @@ 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? - -deriving instance (DataId idL, DataId idR) => Data (HsValBindsLR idL idR) + | XValBindsLR + (XXValBindsLR idL idR) + +deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR) + +-- --------------------------------------------------------------------- +-- Deal with ValBindsOut + +data XHsValBindsLR idL + = NValBindsOut + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] +deriving instance (DataId idL) => Data (XHsValBindsLR idL) + +-- The ValBindsIn pattern exists so we can use the COMPLETE pragma for these +-- patterns +pattern + ValBindsIn :: + (XValBinds idL idR) -> + (LHsBindsLR idL idR) -> + [LSig idR] -> + HsValBindsLR idL idR +pattern + ValBindsOut :: + [(RecFlag, LHsBinds idL)] -> + [LSig GhcRn] -> + HsValBindsLR idL idR + +pattern + ValBindsIn x b s + = ValBinds x b s +pattern + ValBindsOut a b + = XValBindsLR (NValBindsOut a b) + +{-# + COMPLETE + ValBindsIn, + ValBindsOut + #-} + +-- This is not extensible using the parameterised GhcPass namespace +-- type instance +-- XValBinds (GhcPass pass) (GhcPass pass') = NoFieldExt +-- type instance +-- XNewValBindsLR (GhcPass pass) (GhcPass pass') +-- = NewHsValBindsLR (GhcPass pass) (GhcPass pass') +type instance + XValBinds pL pR = PlaceHolder +type instance + XXValBindsLR pL pR + = XHsValBindsLR pL + +-- --------------------------------------------------------------------- -- | Located Haskell Binding type LHsBind id = LHsBindLR id id @@ -285,7 +339,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 +379,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,17 +614,17 @@ 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 (ValBindsIn _ binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) ppr (ValBindsOut sccs sigs) @@ -584,17 +638,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 @@ -636,11 +692,11 @@ eqEmptyLocalBinds EmptyLocalBinds = True eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR a b -> Bool -isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBindsIn _ ds sigs) = isEmptyLHsBinds ds && null sigs isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b -emptyValBindsIn = ValBindsIn emptyBag [] +emptyValBindsIn = ValBindsIn noExt emptyBag [] emptyValBindsOut = ValBindsOut [] [] emptyLHsBinds :: LHsBindsLR idL idR @@ -650,22 +706,23 @@ 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 :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) + -> HsValBinds(GhcPass a) +plusHsValBinds (ValBindsIn _ ds1 sigs1) (ValBindsIn _ ds2 sigs2) + = ValBindsIn noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2) plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) = ValBindsOut (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 +762,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 +809,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 +833,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 +1007,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 +1114,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) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 55d43fd058..0d906cb68d 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -195,7 +195,7 @@ 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 emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } @@ -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, @@ -317,8 +318,8 @@ data SpliceDecl id SpliceExplicitFlag deriving instance (DataId 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 {- @@ -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] @@ -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 @@ -1095,8 +1096,8 @@ data HsDerivingClause pass } deriving instance (DataId 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" @@ -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 @@ -1477,12 +1479,12 @@ data InstDecl pass -- Both class and family instances { tfid_inst :: TyFamInstDecl pass } deriving instance (DataId 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 @@ -1634,8 +1636,8 @@ data DerivDecl pass = DerivDecl } deriving instance (DataId 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 }) @@ -1669,8 +1671,8 @@ data DefaultDecl pass -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId 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) @@ -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) @@ -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) @@ -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 $ @@ -2106,8 +2108,8 @@ data AnnDecl pass = HsAnnotation -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId 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..b8904c768e 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -11,6 +11,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -109,7 +110,7 @@ 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) @@ -133,7 +134,8 @@ mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name -- 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 }) @@ -704,7 +706,7 @@ data HsExpr p | HsWrap HsWrapper -- TRANSLATION (HsExpr p) -deriving instance (DataId p) => Data (HsExpr p) +deriving instance (DataIdLR p p) => Data (HsExpr p) -- | Located Haskell Tuple Argument -- @@ -721,7 +723,7 @@ type LHsTupArg id = Located (HsTupArg id) 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) +deriving instance (DataIdLR id id) => Data (HsTupArg id) tupArgPresent :: LHsTupArg id -> Bool tupArgPresent (L _ (Present {})) = True @@ -799,16 +801,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) @@ -824,16 +829,18 @@ isQuietHsExpr (HsAppTypeOut _ _) = 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 :: 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 @@ -1051,11 +1058,13 @@ ppr_expr (HsRecFld f) = ppr f -- 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) +data LHsWcTypeX = forall p. ( SourceTextX (GhcPass p) + , OutputableBndrId (GhcPass p)) + => LHsWcTypeX (LHsWcType (GhcPass p)) -ppr_apps :: (SourceTextX p, OutputableBndrId p) => HsExpr p - -> [Either (LHsExpr p) LHsWcTypeX] +ppr_apps :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) + -> [Either (LHsExpr (GhcPass p)) LHsWcTypeX] -> SDoc ppr_apps (HsApp (L _ fun) arg) args = ppr_apps fun (Left arg : args) @@ -1085,16 +1094,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 @@ -1242,7 +1254,7 @@ data HsCmd id (HsCmd id) -- If cmd :: arg1 --> res -- wrap :: arg1 "->" arg2 -- Then (HsCmdWrap wrap cmd) :: arg2 --> res -deriving instance (DataId id) => Data (HsCmd id) +deriving instance (DataIdLR id id) => Data (HsCmd id) -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1263,18 +1275,21 @@ data HsCmdTop 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) +deriving instance (DataIdLR p p) => Data (HsCmdTop p) -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmd p) where +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) @@ -1288,10 +1303,12 @@ 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 :: 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) @@ -1352,11 +1369,13 @@ ppr_cmd (HsCmdArrForm op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") -pprCmdArg :: (SourceTextX p, OutputableBndrId p) => HsCmdTop p -> SDoc +pprCmdArg :: (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => HsCmdTop (GhcPass p) -> SDoc pprCmdArg (HsCmdTop cmd _ _ _) = ppr_lcmd cmd -instance (SourceTextX p, OutputableBndrId p) => Outputable (HsCmdTop p) where +instance (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (HsCmdTop (GhcPass p)) where ppr = pprCmdArg {- @@ -1415,10 +1434,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 {- @@ -1500,7 +1520,7 @@ data GRHSs p body 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) @@ -1508,32 +1528,37 @@ type LGRHS id body = Located (GRHS id body) -- | 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 +1591,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 +1601,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 @@ -1759,7 +1786,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 @@ -1773,7 +1800,7 @@ data ParStmtBlock 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) +deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR) -- | Applicative Argument data ApplicativeArg idL idR @@ -1788,8 +1815,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 idR) => Data (ApplicativeArg idL idR) {- Note [The type of bind in Stmts] @@ -1956,19 +1982,22 @@ 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 +instance (SourceTextX (GhcPass idL), OutputableBndrId (GhcPass idL)) + => Outputable (ParStmtBlock (GhcPass idL) idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -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 +2031,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 :: ExprLStmt (GhcPass idL) -> [SDoc] flattenStmt (L _ (ApplicativeStmt args _ _)) = concatMap flattenArg args flattenStmt stmt = [ppr stmt] 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 @@ -2027,10 +2056,10 @@ pprStmt (ApplicativeStmt args mb_join _) 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 "<-" <+> @@ -2038,8 +2067,9 @@ pprStmt (ApplicativeStmt args mb_join _) (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) -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 +2085,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 +2097,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 +2120,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 @@ -2126,7 +2160,7 @@ data HsSplice id ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing deriving Typeable -deriving instance (DataId id) => Data (HsSplice id) +deriving instance (DataIdLR id id) => Data (HsSplice id) -- | 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 +2202,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 +2226,6 @@ data PendingTcSplice = PendingTcSplice SplicePointName (LHsExpr GhcTc) deriving Data - {- Note [Pending Splices] ~~~~~~~~~~~~~~~~~~~~~~ @@ -2257,30 +2290,33 @@ 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 :: (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 :: (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) @@ -2301,8 +2337,8 @@ 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 @@ -2315,17 +2351,19 @@ data HsBracket p = ExpBr (LHsExpr p) -- [| expr |] | 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) +deriving instance (DataIdLR p p) => Data (HsBracket p) 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 :: (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) @@ -2368,10 +2406,10 @@ 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) -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 +2625,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..8b8fcde3ce 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, DataId, 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 (DataIdLR p p) => Data (HsSplice p) +instance (DataIdLR p p) => Data (HsExpr p) +instance (DataIdLR p 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 (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..b88906b2d0 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,214 @@ 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 +type family XValBinds x x' +type family XXValBindsLR x x' --- 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 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) + ) -- --------------------------------------------------------------------- @@ -212,22 +347,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 +373,46 @@ 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) + ) +-- TODO: Should OutputableX be included in OutputableBndrId? -- ---------------------------------------------------------------------- -- type DataId p = ( Data p - , ForallX Data p + + , ForallXHsLit Data p + , ForallXPat Data p + + -- AZ: The following ForAllXXXX shoulbe be unnecessary? Driven by ValBindsOut + -- , ForallXPat Data (GhcPass 'Parsed) + , ForallXPat Data (GhcPass 'Renamed) + -- , ForallXPat Data (GhcPass 'Typechecked) + , ForallXType Data (GhcPass 'Renamed) + + , ForallXOverLit Data p + , ForallXType Data p + , ForallXTyVarBndr Data p + , ForallXAppType Data p + , ForallXFieldOcc Data p + , ForallXAmbiguousFieldOcc Data p + , Data (NameOrRdrName (IdP p)) , Data (IdP p) @@ -282,10 +432,16 @@ type DataId p = , Data (PostTc p [Type]) ) +type DataIdLR pL pR = + ( DataId pL + , DataId pR + , ForallXValBindsLR Data pL pR + ) -- |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..e0904b89fc 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -15,9 +15,11 @@ -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} module HsPat ( Pat(..), InPat, OutPat, LPat, + ListPatTc(..), HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField'(..), LHsRecField', @@ -49,6 +51,7 @@ import HsExtension import HsTypes import TcEvidence import BasicTypes +import PlaceHolder -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn @@ -78,42 +81,47 @@ 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] - (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 + | ListPat (XListPat p) + -- See XListPat type instances below. + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList + -- function to convert the scrutinee to a list value + [LPat p] -- ^ Syntactic List -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, @@ -121,12 +129,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 +155,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 +168,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 +204,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 +216,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 +251,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,8 +274,74 @@ 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 + + -- | Trees that Grow extension point for new constructors + | XPat + (XXPat p) deriving instance (DataId p) => Data (Pat p) +-- | The typechecker-specific information for a 'ListPat' +data ListPatTc = + ListPatTc Type -- The type of the elements + (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList + -- function to convert the scrutinee to a list value + deriving Data + +-- --------------------------------------------------------------------- + +type instance XWildPat GhcPs = PlaceHolder +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 + +type instance XListPat GhcPs = PlaceHolder +type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) -- For rebindable syntax +type instance XListPat GhcTc = ListPatTc + +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 +458,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 +489,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 +502,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 +521,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 +558,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 +606,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 PlaceHolder + (HsCharPrim (setSourceText src) c)] + [] {- ************************************************************************ @@ -561,7 +646,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 +664,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 +692,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 +721,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 +750,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 +765,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 +777,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..47dae434ce 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, DataId, 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 (SourceTextX (GhcPass p), OutputableBndrId (GhcPass p)) + => Outputable (Pat (GhcPass p)) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 62bfa2e5c5..280f5d36ce 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, @@ -112,8 +113,8 @@ data HsModule name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId 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..d9c1b46d0e 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, @@ -75,6 +76,7 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import 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,7 +272,7 @@ 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 @@ -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..3543690602 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -215,22 +215,20 @@ mkLHsPar :: LHsExpr name -> LHsExpr name mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar 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 PlaceHolder 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 @@ -255,9 +253,9 @@ 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; @@ -270,8 +268,9 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) 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 +mkNPat lit neg = NPat noExt lit neg noSyntaxExpr +mkNPlusKPat id lit + = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr mkTransformStmt :: (SourceTextX idR, PostTc idR Type ~ PlaceHolder) => [ExprLStmt idL] -> LHsExpr idR @@ -342,8 +341,8 @@ mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs -mkHsSpliceTy hasParen e - = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind +mkHsSpliceTy hasParen e = HsSpliceTy noExt + (HsUntypedSplice hasParen unqualSplice e) mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote @@ -361,13 +360,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 ] {- @@ -388,14 +389,14 @@ nlHsDataCon con = noLoc (HsConLikeOut (RealDataCon con)) nlHsLit :: HsLit p -> LHsExpr p nlHsLit n = noLoc (HsLit n) -nlHsIntLit :: HasDefaultX p => Integer -> LHsExpr p -nlHsIntLit n = noLoc (HsLit (HsInt def (mkIntegralLit n))) +nlHsIntLit :: Integer -> LHsExpr (GhcPass p) +nlHsIntLit n = noLoc (HsLit (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)) @@ -477,17 +478,17 @@ nlHsIf cond true false = noLoc (HsIf Nothing cond true false) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) nlList exprs = noLoc (ExplicitList placeHolderType 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 {- @@ -503,16 +504,16 @@ mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . Present) es) Boxed mkLHsVarTuple :: [IdP a] -> LHsExpr 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 -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 @@ -522,10 +523,10 @@ mkBigLHsTup :: [LHsExpr id] -> LHsExpr 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 +633,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 +655,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)) @@ -690,13 +693,13 @@ mkHsCmdWrap w cmd | isIdHsWrapper w = cmd mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id 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 +772,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 {- @@ -887,8 +892,8 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [IdP idL] 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 ps (ValBindsIn _ binds _) = collect_binds ps binds [] +collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds collect_out_binds :: Bool -> [(RecFlag, LHsBinds p)] -> [IdP p] collect_out_binds ps = foldr (collect_binds ps . snd) [] @@ -952,33 +957,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 +1032,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) @@ -1065,7 +1070,7 @@ hsForeignDeclsBinders foreign_decls hsPatSynSelectors :: HsValBinds p -> [IdP p] -- Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by collectHsValBinders. -hsPatSynSelectors (ValBindsIn _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (ValBindsIn _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (ValBindsOut binds _) = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds @@ -1123,11 +1128,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) @@ -1213,7 +1218,7 @@ lStmtsImplicits = hs_lstmts hsValBindsImplicits :: HsValBindsLR GhcRn idR -> NameSet hsValBindsImplicits (ValBindsOut binds _) = foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds -hsValBindsImplicits (ValBindsIn binds _) +hsValBindsImplicits (ValBindsIn _ binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet @@ -1229,18 +1234,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..55778d9adf 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -6,10 +6,10 @@ module PlaceHolder where -import GhcPrelude () +import GhcPrelude ( Eq(..), Ord(..) ) import Type ( Type ) -import Outputable +import Outputable hiding ( (<>) ) import Name import NameSet import RdrName @@ -31,7 +31,10 @@ import Data.Data hiding ( Fixity ) -- | used as place holder in PostTc and PostRn values data PlaceHolder = PlaceHolder - deriving (Data) + deriving (Data,Eq,Ord) + +instance Outputable PlaceHolder where + ppr _ = text "PlaceHolder" placeHolderKind :: PlaceHolder placeHolderKind = PlaceHolder 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..72092d737e 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) [] + ValBindsIn noExt + (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt updateFixityEnv fix_env diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index d4a26895d6..6c278045b9 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 $ (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! @@ -2516,10 +2519,8 @@ aexp2 :: { LHsExpr GhcPs } -- 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 $! mkHsIntegral (getINTEGER $1) ) } + | RATIONAL { sL (getLoc $1) (HsOverLit $! 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 @@ -3139,8 +3140,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) } @@ -3338,8 +3339,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..63444f144e 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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 $ ValBindsIn 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) @@ -840,11 +842,11 @@ checkAPat msg loc e0 = do let opts = options pState case e0 of EWildPat -> return (WildPat placeHolderType) - HsVar x -> return (VarPat x) + 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 @@ -858,16 +860,16 @@ checkAPat msg loc e0 = do -> 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)) + (return . (\p -> ViewPat noExt expr p)) ExprWithTySig e t -> do e <- checkLPat msg e - return (SigPatIn e t) + return (SigPat t e) -- n+k patterns OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ @@ -882,27 +884,27 @@ checkAPat msg loc e0 = do -> 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) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es - return (PArrPat ps placeHolderType) + return (PArrPat noExt ps) ExplicitTuple es b | all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | L _ (Present e) <- es] - return (TuplePat ps b []) + return (TuplePat noExt ps b) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) 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) + -> return (SplicePat noExt s) _ -> patFail msg loc e0 placeHolderPunRhs :: LHsExpr GhcPs @@ -1124,23 +1126,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 +1155,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 @@ -1310,8 +1313,10 @@ 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 diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 02a37b20ef..ef8489f586 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -183,7 +183,7 @@ 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 (ValBindsIn _ mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs ; return (ValBindsOut [] sigs', usesOnly fvs) } @@ -274,9 +274,9 @@ rnLocalValBindsLHS fix_env binds rnValBindsLHS :: NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs) -rnValBindsLHS topP (ValBindsIn mbinds sigs) +rnValBindsLHS topP (ValBindsIn x mbinds sigs) = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds - ; return $ ValBindsIn mbinds' sigs } + ; return $ ValBindsIn 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 (ValBindsIn _ 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 @@ -336,7 +336,7 @@ rnLocalValBindsAndThen :: HsValBinds GhcPs -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) -> RnM (result, FreeVars) -rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside +rnLocalValBindsAndThen binds@(ValBindsIn _ _ 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/RnExpr.hs b/compiler/rename/RnExpr.hs index cf47932365..b1e0513264 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -126,10 +126,9 @@ rnExpr (HsVar (L l v)) | otherwise -> finishHsVar (L l name) ; Just (Right [s]) -> - return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s)) - , unitFV s) ; + return ( HsRecFld (Unambiguous s (L l v) ), unitFV s) ; Just (Right fs@(_:_:_)) -> - return ( HsRecFld (Ambiguous (L l v) PlaceHolder) + return ( HsRecFld (Ambiguous noExt (L l v)) , mkFVs fs); Just (Right []) -> panic "runExpr/HsVar" } } @@ -146,7 +145,7 @@ rnExpr (HsOverLabel _ v) rnExpr (HsLit lit@(HsString src s)) = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings ; if opt_OverloadedStrings then - rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) + rnExpr (HsOverLit (mkHsIsString src s)) else do { ; rnLit lit ; return (HsLit (convertLit lit), emptyFVs) } } @@ -1095,7 +1094,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 (ValBindsIn _ _ sigs))))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig s)) -> (L loc s) : acc _ -> acc) acc sigs @@ -1786,25 +1785,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 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..ce2f1574d8 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 + ValBindsIn _ _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..8072c71455 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, @@ -384,16 +386,19 @@ 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 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,44 @@ 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 []) else rnConPatAndThen mk con stuff} False -> rnConPatAndThen mk con stuff -rnPatAndThen mk (ListPat pats _ _) +rnPatAndThen mk (ListPat _ pats) = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists ; pats' <- rnLPatsAndThen mk pats ; case opt_OverloadedLists of True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName - ; return (ListPat pats' placeHolderType - (Just (placeHolderType, to_list_name)))} - False -> return (ListPat pats' placeHolderType Nothing) } + ; return (ListPat (Just to_list_name) pats')} + False -> return (ListPat Nothing pats') } -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 mfs (HsSplicedPat pat))) + = SplicePat x . HsSpliced 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 +544,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 +606,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 +617,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 +662,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 @@ -774,10 +780,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 +804,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 @@ -885,8 +891,7 @@ rnOverLit origLit 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..d4aefe7d98 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -2079,7 +2079,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 (ValBindsIn _ binds _) = foldrBagM new_ps' [] binds new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs @@ -2092,7 +2092,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 +2251,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 (ValBindsIn x bs sigs) = ValBindsIn x (bs `snocBag` b) sigs +add_bind _ (ValBindsOut {}) = 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 s (ValBindsIn x bs sigs) = ValBindsIn x bs (s:sigs) +add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 36b1eda140..c681f1f42d 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 ) @@ -521,13 +520,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,7 +536,7 @@ 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 + ; return ( HsParTy noExt $ HsSpliceTy noExt . HsSpliced (ThModFinalizers mod_finalizers) . HsSplicedTy <$> hs_ty3 @@ -594,14 +593,15 @@ 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 + ; return ( Left $ ParPat noExt $ (SplicePat noExt) . HsSpliced (ThModFinalizers mod_finalizers) . HsSplicedPat <$> pat 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..8366684b53 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) @@ -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..d0ff4c7f45 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -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 @@ -559,7 +560,7 @@ newNonTrivialOverloadedLit :: CtOrigin -> TcM (HsOverLit GhcTcId) newNonTrivialOverloadedLit orig lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name) - , ol_rebindable = rebindable }) res_ty + , 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) 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/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 6a9b22a9bb..f67c86e9d6 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -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..3198406227 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 = ValBindsIn 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..014e97625e 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -241,7 +241,7 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty applyFromLabel loc fromLabel = L loc (HsVar (L loc fromLabel)) `HsAppType` - mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l))) + mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))) tcExpr (HsLam match) res_ty = do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty @@ -386,7 +386,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) @@ -413,12 +414,12 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; return (OpApp (mkLHsWrap wrap1 arg1') op' fix 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)) + ; let op' = L loc (HsRecFld (Unambiguous sel_name lbl)) ; tcExpr (OpApp arg1 op' fix arg2) res_ty } @@ -1172,11 +1173,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 (Unambiguous sel_name lbl))) args } -- See Note [Visible type application for the empty list constructor] go (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg] @@ -1684,23 +1685,26 @@ tcCheckId name res_ty tcWrapResultO (OccurrenceOf name) (HsVar (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 $ 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) @@ -2215,8 +2219,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 +2289,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 @@ -2384,21 +2389,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 +2415,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..714008a5a6 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -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 @@ -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 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..cc4e588235 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 (ListPatTc ty Nothing) _ ) = mkListTy ty +hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _ ) = ty +hsPatType (PArrPat ty _) = mkPArrTy ty +hsPatType (TuplePat tys _ bx) = mkTupleTy bx tys +hsPatType (SumPat tys _ _ _ ) = mkSumTy tys 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,12 +124,13 @@ 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 (HsInt noExt int)) | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i)) | isIntegerTy ty = Just (HsLit (HsInteger src i ty)) | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty @@ -139,8 +141,8 @@ 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 @@ -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 @@ -953,10 +957,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) @@ -1173,9 +1179,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 +1189,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 (ListPatTc ty Nothing) pats) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty' Nothing) } + ; return (env', ListPat (ListPatTc ty' Nothing) pats') } -zonk_pat env (ListPat pats ty (Just (ty2,wit))) +zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats) = do { (env', wit') <- zonkSyntaxExpr env wit ; ty2' <- zonkTcTypeToType env' ty2 ; ty' <- zonkTcTypeToType env' ty ; (env'', pats') <- zonkPats env' pats - ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) } + ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') } -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 +1271,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 +1286,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 +1296,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 e5a07ec99e..19fd5c141b 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 @@ -1494,19 +1495,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 @@ -1624,14 +1626,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 @@ -1654,7 +1658,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..3dbe02d6da 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1606,7 +1606,8 @@ mkDefMethBind clas inst_tys sel_id dm_name where mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn mk_vta fun ty = noLoc (HsAppType fun (mkEmptyWildCardBndrs - $ nlHsParTy $ noLoc $ HsCoreTy ty)) + $ nlHsParTy + $ noLoc $ XHsType $ NHsCoreTy ty)) -- NB: use visible type application -- See Note [Default methods in instances] diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index c5e367e3be..7c3872c78b 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,31 @@ 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 Nothing pats) pat_ty thing_inside = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty)) pats penv thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) + ; return (mkHsWrapPat coi + (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res) } -tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside +tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside = do { tau_pat_ty <- expTypeToType pat_ty ; ((pats', res, elt_ty), e') <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)] @@ -433,18 +435,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 (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', 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 +465,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 +486,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 +497,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 +523,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 +541,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 +572,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 +602,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 +986,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 58d1506812..24de0a87f2 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -581,11 +581,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 @@ -661,48 +661,48 @@ 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) | 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 $ go pat + go1 (PArrPat _ pats) = do { exprs <- mapM go pats + ; return $ ExplicitPArr PlaceHolder exprs } + go1 p@(ListPat reb pats) + | Nothing <- reb = do { exprs <- mapM go pats + ; return $ ExplicitList PlaceHolder Nothing exprs } | otherwise = notInvertibleListPat p - go1 (TuplePat pats box _) = do { exprs <- mapM go pats + 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) + go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) ; return $ ExplicitSum alt arity (noLoc expr) PlaceHolder } - go1 (LitPat lit) = return $ HsLit lit - go1 (NPat (L _ n) mb_neg _ _) + 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 (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 notInvertible p = Left (not_invertible_msg p) @@ -813,38 +813,40 @@ tcCheckPatSynPat = go go = addLocM go1 go1 :: Pat GhcRn -> TcM () - go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) - go1 VarPat{} = return () - go1 WildPat{} = return () - go1 p@(AsPat _ _) = asPatInPatSynErr p - 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) + go1 (ConPatIn _ info) = mapM_ go (hsConPatArgs info) + go1 VarPat{} = return () + go1 WildPat{} = return () + go1 p@(AsPat _ _ _) = asPatInPatSynErr p + 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 p@NPlusKPat{} = nPlusKPatInPatSynErr p 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:") @@ -873,20 +875,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..c0ec5d7d08 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, @@ -1999,11 +2000,12 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) ValBindsOut [(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)) @@ -2139,8 +2141,10 @@ 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) 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..0e8019093e 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -887,8 +887,9 @@ mkOneRecordSelector all_cons idDetails fl 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 |