diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Hs.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Binds.hs | 75 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Decls.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs | 318 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs-boot | 7 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Extension.hs | 687 | ||||
| -rw-r--r-- | compiler/GHC/Hs/ImpExp.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Instances.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Lit.hs | 37 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Pat.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Pat.hs-boot | 4 | ||||
| -rw-r--r-- | compiler/GHC/Hs/PlaceHolder.hs | 70 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Types.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 111 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/PmCheck.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 35 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Binds.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Env.hs | 48 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs | 91 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs-boot | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Pat.hs | 26 | ||||
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 8 |
22 files changed, 594 insertions, 1009 deletions
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index ecd891b52e..999d59ea7a 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -12,8 +12,8 @@ therefore, is almost nothing but re-exporting. {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data @@ -28,7 +28,6 @@ module GHC.Hs ( module GHC.Hs.Types, module GHC.Hs.Utils, module GHC.Hs.Doc, - module GHC.Hs.PlaceHolder, module GHC.Hs.Extension, Fixity, @@ -43,7 +42,6 @@ import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Hs.ImpExp import GHC.Hs.Lit -import GHC.Hs.PlaceHolder import GHC.Hs.Extension import GHC.Hs.Pat import GHC.Hs.Types diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index adb8604913..1c393bbe99 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -12,11 +12,13 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module GHC.Hs.Binds where @@ -219,29 +221,29 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation FunBind { - fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains - -- the locally-bound - -- free variables of this defn. - -- See Note [Bind free vars] + fun_ext :: XFunBind idL idR, + + -- ^ After the renamer (but before the type-checker), this contains the + -- locally-bound free variables of this defn. See Note [Bind free vars] + -- + -- After the type-checker, this contains a coercion from the type of + -- the MatchGroup to the type of the Id. Example: + -- + -- @ + -- f :: Int -> forall a. a -> a + -- f x y = y + -- @ + -- + -- Then the MatchGroup will have type (Int -> a' -> a') + -- (with a free type variable a'). The coercion will take + -- a CoreExpr of this type and convert it to a CoreExpr of + -- type Int -> forall a'. a' -> a' + -- Notice that the coercion captures the free a'. fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload - fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of - -- the Id. Example: - -- - -- @ - -- f :: Int -> forall a. a -> a - -- f x y = y - -- @ - -- - -- Then the MatchGroup will have type (Int -> a' -> a') - -- (with a free type variable a'). The coercion will take - -- a CoreExpr of this type and convert it to a CoreExpr of - -- type Int -> forall a'. a' -> a' - -- Notice that the coercion captures the free a'. - fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any } @@ -320,8 +322,8 @@ data NPatBindTc = NPatBindTc { } deriving Data type instance XFunBind (GhcPass pL) GhcPs = NoExtField -type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables -type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcTc = HsWrapper -- See comments on FunBind.fun_ext type instance XPatBind GhcPs (GhcPass pR) = NoExtField type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables @@ -682,19 +684,6 @@ pprDeclList ds = pprDeeperList vcat ds emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) emptyLocalBinds = EmptyLocalBinds noExtField --- AZ:These functions do not seem to be used at all? -isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool -isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds -isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds -isEmptyLocalBindsTc (EmptyLocalBinds _) = True -isEmptyLocalBindsTc (XHsLocalBindsLR _) = True - -isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds -isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds -isEmptyLocalBindsPR (EmptyLocalBinds _) = True -isEmptyLocalBindsPR (XHsLocalBindsLR _) = True - eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool eqEmptyLocalBinds (EmptyLocalBinds _) = True eqEmptyLocalBinds _ = False @@ -728,7 +717,8 @@ instance (OutputableBndrId pl, OutputableBndrId pr) => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) +ppr_monobind :: forall idL idR. + (OutputableBndrId idL, OutputableBndrId idR) => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) @@ -736,14 +726,15 @@ ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, - fun_co_fn = wrap, fun_matches = matches, - fun_tick = ticks }) + fun_tick = ticks, + fun_ext = wrap }) = pprTicks empty (if null ticks then empty else text "-- ticks = " <> ppr ticks) $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches - $$ whenPprDebug (ppr wrap) + $$ whenPprDebug (pprIfTc @idR $ ppr wrap) + ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds @@ -759,7 +750,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , text "Exported types:" <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] , text "Binds:" <+> pprLHsBinds val_binds - , text "Evidence:" <+> ppr ev_binds ] + , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) ] else pprLHsBinds val_binds ppr_monobind (XHsBindsLR x) = ppr x @@ -768,7 +759,7 @@ instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) - , nest 2 (text "wrap:" <+> ppr wrap)] + , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ] ppr (XABExport x) = ppr x instance (OutputableBndrId l, OutputableBndrId r, @@ -867,7 +858,7 @@ type instance XXIPBind (GhcPass p) = NoExtCon instance OutputableBndrId p => Outputable (HsIPBinds (GhcPass p)) where ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) - $$ whenPprDebug (ppr ds) + $$ whenPprDebug (pprIfTc @p $ ppr ds) ppr (XHsIPBinds x) = ppr x instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index aeec0820ed..abfd0ec476 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -8,10 +8,12 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -2022,7 +2024,10 @@ instance OutputableBndrId p ppr StockStrategy = text "stock" ppr AnyclassStrategy = text "anyclass" ppr NewtypeStrategy = text "newtype" - ppr (ViaStrategy ty) = text "via" <+> ppr ty + ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of + GhcPs -> ppr ty + GhcRn -> ppr ty + GhcTc -> ppr ty -- | A short description of a @DerivStrategy'@. derivStrategyName :: DerivStrategy a -> SDoc diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index d37c8ed914..f70d5c0382 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -7,13 +7,16 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -28,7 +31,6 @@ import GhcPrelude import GHC.Hs.Decls import GHC.Hs.Pat import GHC.Hs.Lit -import GHC.Hs.PlaceHolder ( NameOrRdrName ) import GHC.Hs.Extension import GHC.Hs.Types import GHC.Hs.Binds @@ -89,14 +91,57 @@ type PostTcExpr = HsExpr GhcTc type PostTcTable = [(Name, PostTcExpr)] ------------------------- +{- Note [NoSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~ +Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc) +for several reasons: + + 1. As described in Note [Rebindable if] + + 2. In order to suppress "not in scope: xyz" messages when a bit of + rebindable syntax does not apply. For example, when using an irrefutable + pattern in a BindStmt, we don't need a `fail` operator. + + 3. Rebindable syntax might just not make sense. For example, a BodyStmt + contains the syntax for `guard`, but that's used only in monad comprehensions. + If we had more of a whiz-bang type system, we might be able to rule this + case out statically. +-} + -- | Syntax Expression -- --- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, --- by the renamer. It's used for rebindable syntax. +-- SyntaxExpr is represents the function used in interpreting rebindable +-- syntax. In the parser, we have no information to supply; in the renamer, +-- we have the name of the function (but see +-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle) +-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'. +-- +-- In some contexts, rebindable syntax is not implemented, and so we have +-- constructors to represent that possibility in both the renamer and +-- typechecker instantiations. -- -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for -- @(>>=)@, and then instantiated by the type checker with its type args -- etc +type family SyntaxExpr p + +-- Defining SyntaxExpr in two stages allows for better type inference, because +-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity, +-- noSyntaxExpr would be ambiguous. +type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p + +type family SyntaxExprGhc (p :: Pass) = (r :: *) | r -> p where + SyntaxExprGhc 'Parsed = NoExtField + SyntaxExprGhc 'Renamed = SyntaxExprRn + SyntaxExprGhc 'Typechecked = SyntaxExprTc + +-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr]. +data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn) + -- Why is the payload not just a Name? + -- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr + | NoSyntaxExprRn + +-- | An expression with wrappers, used for rebindable syntax -- -- This should desugar to -- @@ -104,45 +149,43 @@ type PostTcTable = [(Name, PostTcExpr)] -- > (syn_arg_wraps[1] arg1) ... -- -- where the actual arguments come from elsewhere in the AST. --- This could be defined using @GhcPass p@ and such, but it's --- harder to get it all to work out that way. ('noSyntaxExpr' is hard to --- write, for example.) -data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p - , syn_arg_wraps :: [HsWrapper] - , syn_res_wrap :: HsWrapper } +data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + | NoSyntaxExprTc -- See Note [NoSyntaxExpr] -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr (GhcPass p) noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) -noSyntaxExpr :: SyntaxExpr (GhcPass p) - -- Before renaming, and sometimes after, - -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField - (HsString NoSourceText - (fsLit "noSyntaxExpr")) - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers. -mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p) -mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the --- renamer), missing its HsWrappers. -mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name - -- don't care about filling in syn_arg_wraps because we're clearly - -- not past the typechecker - -instance OutputableBndrId p - => Outputable (SyntaxExpr (GhcPass p)) where - ppr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) +noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) + -- Before renaming, and sometimes after + -- See Note [NoSyntaxExpr] +noSyntaxExpr = case ghcPass @p of + GhcPs -> noExtField + GhcRn -> NoSyntaxExprRn + GhcTc -> NoSyntaxExprTc + +-- | Make a 'SyntaxExpr GhcRn' from an expression +-- Used only in getMonadFailOp. +-- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr +mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn +mkSyntaxExpr = SyntaxExprRn + +-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the +-- renamer). +mkRnSyntaxExpr :: Name -> SyntaxExprRn +mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLoc name + +instance Outputable SyntaxExprRn where + ppr (SyntaxExprRn expr) = ppr expr + ppr NoSyntaxExprRn = text "<no syntax expr>" + +instance Outputable SyntaxExprTc where + ppr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) = sdocWithDynFlags $ \ dflags -> getPprStyle $ \s -> if debugStyle s || gopt Opt_PrintExplicitCoercions dflags @@ -150,6 +193,8 @@ instance OutputableBndrId p <> braces (ppr res_wrap) else ppr expr + ppr NoSyntaxExprTc = text "<no syntax expr>" + -- | Command Syntax Table (for Arrow syntax) type CmdSyntaxTable p = [(Name, HsExpr p)] -- See Note [CmdSyntaxTable] @@ -330,10 +375,11 @@ data HsExpr p -- 'ApiAnnotation.AnnElse', -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (XIf p) - (Maybe (SyntaxExpr p)) -- cond function - -- Nothing => use the built-in 'if' - -- See Note [Rebindable if] + | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use + -- rebindable syntax + (SyntaxExpr p) -- cond function + -- NoSyntaxExpr => use the built-in 'if' + -- See Note [Rebindable if] (LHsExpr p) -- predicate (LHsExpr p) -- then part (LHsExpr p) -- else part @@ -364,7 +410,7 @@ data HsExpr p -- For details on above see note [Api annotations] in ApiAnnotation | HsDo (XDo p) -- Type of the whole expression - (HsStmtContext Name) -- The parameterisation is unimportant + (HsStmtContext GhcRn) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant (Located [ExprLStmt p]) -- "do":one or more stmts @@ -506,16 +552,6 @@ data HsExpr p -- Expressions annotated with pragmas, written as {-# ... #-} | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) - --------------------------------------- - -- Finally, HsWrap appears only in typechecker output - -- The contained Expr is *NOT* itself an HsWrap. - -- See Note [Detecting forced eta expansion] in DsExpr. This invariant - -- is maintained by GHC.Hs.Utils.mkHsWrap. - - | HsWrap (XWrap p) - HsWrapper -- TRANSLATION - (HsExpr p) - | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor @@ -532,12 +568,22 @@ data RecordUpdTc = RecordUpdTc -- _non-empty_ list of DataCons that have -- all the upd'd fields - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] - } deriving Data + , rupd_in_tys :: [Type] -- Argument types of *input* record type + , rupd_out_tys :: [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] + } + +-- | HsWrap appears only in typechecker output +-- Invariant: The contained Expr is *NOT* itself an HsWrap. +-- See Note [Detecting forced eta expansion] in DsExpr. This invariant +-- is maintained by GHC.Hs.Utils.mkHsWrap. +-- hs_syn is something like HsExpr or HsCmd +data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper + (hs_syn GhcTc) -- the thing that is wrapped + +deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) -- --------------------------------------------------------------------- @@ -570,7 +616,10 @@ type instance XExplicitSum GhcRn = NoExtField type instance XExplicitSum GhcTc = [Type] type instance XCase (GhcPass _) = NoExtField -type instance XIf (GhcPass _) = NoExtField + +type instance XIf GhcPs = Bool -- True <=> might use rebindable syntax +type instance XIf GhcRn = NoExtField +type instance XIf GhcTc = NoExtField type instance XMultiIf GhcPs = NoExtField type instance XMultiIf GhcRn = NoExtField @@ -618,7 +667,10 @@ type instance XBinTick (GhcPass _) = NoExtField type instance XPragE (GhcPass _) = NoExtField type instance XWrap (GhcPass _) = NoExtField -type instance XXExpr (GhcPass _) = NoExtCon + +type instance XXExpr GhcPs = NoExtCon +type instance XXExpr GhcRn = NoExtCon +type instance XXExpr GhcTc = HsWrap HsExpr -- --------------------------------------------------------------------- @@ -732,7 +784,12 @@ Because we allow an 'if' to return *unboxed* results, thus whereas that would not be possible using a all to a polymorphic function (because you can't call a polymorphic function at an unboxed type). -So we use Nothing to mean "use the old built-in typing rule". +So we use NoSyntaxExpr to mean "use the old built-in typing rule". + +A further complication is that, in the `deriving` code, we never want +to use rebindable syntax. So, even in GhcPs, we want to denote whether +to use rebindable syntax or not. This is done via the type instance +for XIf GhcPs. Note [Record Update HsWrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1002,16 +1059,12 @@ ppr_expr (ExprWithTySig _ expr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (HsWrap _ co_fn e) - = pprHsWrapper co_fn (\parens -> if parens then pprExpr e - else pprExpr e) - ppr_expr (HsSpliceE _ s) = pprSplice s ppr_expr (HsBracket _ b) = pprHsBracket b ppr_expr (HsRnBracketOut _ e []) = ppr e ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e -ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> ppr ps +ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps) ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] @@ -1034,15 +1087,24 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) ppr exp, text ")"] ppr_expr (HsRecFld _ f) = ppr f -ppr_expr (XExpr x) = ppr x +ppr_expr (XExpr x) = case ghcPass @p of + GhcPs -> ppr x + GhcRn -> ppr x + GhcTc -> case x of + HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e + else pprExpr e) + -ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ) -ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e -ppr_infix_expr _ = Nothing +ppr_infix_expr (XExpr x) + | GhcTc <- ghcPass @p + , HsWrap _ e <- x + = ppr_infix_expr e +ppr_infix_expr _ = Nothing ppr_apps :: (OutputableBndrId p) => HsExpr (GhcPass p) @@ -1097,7 +1159,7 @@ pprParendExpr p expr -- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs -- parentheses under precedence @p@. -hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool +hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool hsExprNeedsParens p = go where go (HsVar{}) = False @@ -1130,7 +1192,6 @@ hsExprNeedsParens p = go go (ExprWithTySig{}) = p >= sigPrec go (ArithSeq{}) = False go (HsPragE{}) = p >= appPrec - go (HsWrap _ _ e) = go e go (HsSpliceE{}) = False go (HsBracket{}) = False go (HsRnBracketOut{}) = False @@ -1141,11 +1202,18 @@ hsExprNeedsParens p = go go (HsBinTick _ _ _ (L _ e)) = go e go (RecordCon{}) = False go (HsRecFld{}) = False - go (XExpr{}) = True + go (XExpr x) + | GhcTc <- ghcPass @p + , HsWrap _ e <- x + = go e + + | otherwise + = True + -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. -parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) parenthesizeHsExpr p le@(L loc e) | hsExprNeedsParens p e = L loc (HsPar noExtField le) | otherwise = le @@ -1154,7 +1222,7 @@ stripParensHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) stripParensHsExpr (L _ (HsPar _ e)) = stripParensHsExpr e stripParensHsExpr e = e -isAtomicHsExpr :: HsExpr id -> Bool +isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool -- True of a single token isAtomicHsExpr (HsVar {}) = True isAtomicHsExpr (HsConLikeOut {}) = True @@ -1163,9 +1231,11 @@ isAtomicHsExpr (HsOverLit {}) = True isAtomicHsExpr (HsIPVar {}) = True isAtomicHsExpr (HsOverLabel {}) = True isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True +isAtomicHsExpr (XExpr x) + | GhcTc <- ghcPass @p + , HsWrap _ e <- x = isAtomicHsExpr e isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where @@ -1258,10 +1328,10 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdIf (XCmdIf id) - (Maybe (SyntaxExpr id)) -- cond function - (LHsExpr id) -- predicate - (LHsCmd id) -- then part - (LHsCmd id) -- else part + (SyntaxExpr id) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', -- 'ApiAnnotation.AnnSemi', -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', @@ -1287,11 +1357,6 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdWrap (XCmdWrap id) - HsWrapper - (HsCmd id) -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (HsCmdWrap wrap cmd) :: arg2 --> res | XCmd (XXCmd id) -- Note [Trees that Grow] extension point type instance XCmdArrApp GhcPs = NoExtField @@ -1311,7 +1376,13 @@ type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type type instance XCmdWrap (GhcPass _) = NoExtField -type instance XXCmd (GhcPass _) = NoExtCon + +type instance XXCmd GhcPs = NoExtCon +type instance XXCmd GhcRn = NoExtCon +type instance XXCmd GhcTc = HsWrap HsCmd + -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res -- | Haskell Array Application Type data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp @@ -1403,8 +1474,6 @@ ppr_cmd (HsCmdLet _ (L _ binds) cmd) ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts -ppr_cmd (HsCmdWrap _ w cmd) - = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) @@ -1429,7 +1498,11 @@ ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) ppr_cmd (HsCmdArrForm _ op _ _ args) = hang (text "(|" <+> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_cmd (XCmd x) = ppr x +ppr_cmd (XCmd x) = case ghcPass @p of + GhcPs -> ppr x + GhcRn -> ppr x + GhcTc -> case x of + HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc pprCmdArg (HsCmdTop _ cmd) @@ -1502,7 +1575,7 @@ type LMatch id body = Located (Match id body) data Match p body = Match { m_ext :: XCMatch p body, - m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), + m_ctxt :: HsMatchContext (NoGhcTc p), -- See note [m_ctxt in Match] m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) @@ -1637,7 +1710,7 @@ pprPatBind :: forall bndr p body. (OutputableBndrId bndr, => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, - nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] + nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)] pprMatch :: (OutputableBndrId idR, Outputable body) => Match (GhcPass idR) body -> SDoc @@ -1678,7 +1751,7 @@ pprMatch match (pat2:pats2) = pats1 pprGRHSs :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc + => HsMatchContext passL -> 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 @@ -1688,7 +1761,7 @@ pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) pprGRHSs _ (XGRHSs x) = ppr x pprGRHS :: (OutputableBndrId idR, Outputable body) - => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc + => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc pprGRHS ctxt (GRHS _ [] body) = pp_rhs ctxt body @@ -1697,7 +1770,7 @@ pprGRHS ctxt (GRHS _ guards body) pprGRHS _ (XGRHS x) = ppr x -pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc +pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) {- @@ -1774,6 +1847,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail + -- See Note [NoSyntaxExpr] (2) -- | 'ApplicativeStmt' represents an applicative expression built with -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the @@ -1947,6 +2021,7 @@ data ApplicativeArg idL -- match fails. -- The fail operator is noSyntaxExpr -- if the pattern match can't fail + -- See Note [NoSyntaxExpr] (2) } | ApplicativeArgMany -- do { stmts; return vars } { xarg_app_arg_many :: (XApplicativeArgMany idL) @@ -2601,8 +2676,8 @@ pp_dotdot = text " .. " -- -- Context of a pattern match. This is more subtle than it would seem. See Note -- [Varieties of pattern matches]. -data HsMatchContext id -- Not an extensible tag - = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ +data HsMatchContext p + = FunRhs { mc_fun :: LIdP p -- ^ function binder of @f@ , mc_fixity :: LexicalFixity -- ^ fixing of @f@ , mc_strictness :: SrcStrictness -- ^ was @f@ banged? -- See Note [FunBind vs PatBind] @@ -2622,16 +2697,16 @@ data HsMatchContext id -- Not an extensible tag -- tell matchWrapper what sort of -- runtime error message to generate] - | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, + | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension, -- pattern guard, etc | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration - deriving Functor -deriving instance (Data id) => Data (HsMatchContext id) +deriving instance Data (HsMatchContext GhcPs) +deriving instance Data (HsMatchContext GhcRn) -instance OutputableBndr id => Outputable (HsMatchContext id) where +instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) ppr LambdaExpr = text "LambdaExpr" ppr CaseAlt = text "CaseAlt" @@ -2645,15 +2720,14 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" -isPatSynCtxt :: HsMatchContext id -> Bool +isPatSynCtxt :: HsMatchContext p -> Bool isPatSynCtxt ctxt = case ctxt of PatSyn -> True _ -> False --- | Haskell Statement Context. It expects to be parameterised with one of --- 'RdrName', 'Name' or 'Id' -data HsStmtContext id +-- | Haskell Statement Context. +data HsStmtContext p = ListComp | MonadComp @@ -2662,11 +2736,11 @@ data HsStmtContext id | ArrowExpr -- ^do-notation in an arrow-command context | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs - | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt - deriving Functor -deriving instance (Data id) => Data (HsStmtContext id) + | PatGuard (HsMatchContext p) -- ^Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext p) -- ^A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt +deriving instance Data (HsStmtContext GhcPs) +deriving instance Data (HsStmtContext GhcRn) isComprehensionContext :: HsStmtContext id -> Bool -- Uses comprehension syntax [ e | quals ] @@ -2691,7 +2765,7 @@ isMonadCompContext :: HsStmtContext id -> Bool isMonadCompContext MonadComp = True isMonadCompContext _ = False -matchSeparator :: HsMatchContext id -> SDoc +matchSeparator :: HsMatchContext p -> SDoc matchSeparator (FunRhs {}) = text "=" matchSeparator CaseAlt = text "->" matchSeparator IfAlt = text "->" @@ -2706,8 +2780,8 @@ matchSeparator ThPatSplice = panic "unused" matchSeparator ThPatQuote = panic "unused" matchSeparator PatSyn = panic "unused" -pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc +pprMatchContext :: Outputable (IdP p) + => HsMatchContext p -> SDoc pprMatchContext ctxt | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt | otherwise = text "a" <+> pprMatchContextNoun ctxt @@ -2716,7 +2790,7 @@ pprMatchContext ctxt want_an ProcExpr = True want_an _ = False -pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) +pprMatchContextNoun :: Outputable (IdP id) => HsMatchContext id -> SDoc pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) = text "equation for" @@ -2735,8 +2809,7 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" pprMatchContextNoun PatSyn = text "pattern synonym declaration" ----------------- -pprAStmtContext, pprStmtContext :: (Outputable id, - Outputable (NameOrRdrName id)) +pprAStmtContext, pprStmtContext :: Outputable (IdP id) => HsStmtContext id -> SDoc pprAStmtContext ctxt = article <+> pprStmtContext ctxt where @@ -2769,13 +2842,13 @@ pprStmtContext (TransStmtCtxt c) = ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) (pprStmtContext c) -instance (Outputable (GhcPass p), Outputable (NameOrRdrName (GhcPass p))) +instance OutputableBndrId p => Outputable (HsStmtContext (GhcPass p)) where ppr = pprStmtContext -- Used to generate the string for a *runtime* error message -matchContextErrString :: Outputable id - => HsMatchContext id -> SDoc +matchContextErrString :: OutputableBndrId p + => HsMatchContext (GhcPass p) -> SDoc matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun matchContextErrString CaseAlt = text "case" matchContextErrString IfAlt = text "multi-way if" @@ -2797,10 +2870,7 @@ matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" -pprMatchInCtxt :: (OutputableBndrId idR, - -- TODO:AZ these constraints do not make sense - Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), - Outputable body) +pprMatchInCtxt :: (OutputableBndrId idR, Outputable body) => Match (GhcPass idR) body -> SDoc pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) @@ -2809,7 +2879,7 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) - => HsStmtContext (IdP (GhcPass idL)) + => HsStmtContext (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc pprStmtInCtxt ctxt (LastStmt _ e _ _) diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot index 03029d1d05..7ea4633760 100644 --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -1,8 +1,8 @@ {-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ExistentialQuantification #-} @@ -21,13 +21,12 @@ type role HsCmd nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal type role HsSplice nominal -type role SyntaxExpr nominal data HsExpr (i :: *) data HsCmd (i :: *) data HsSplice (i :: *) data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) -data SyntaxExpr (i :: *) +type family SyntaxExpr (i :: *) instance OutputableBndrId p => Outputable (HsExpr (GhcPass p)) instance OutputableBndrId p => Outputable (HsCmd (GhcPass p)) diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index be0333933a..ee82e4a0f9 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -11,8 +11,14 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension +{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- for pprIfTc, etc. module GHC.Hs.Extension where @@ -22,7 +28,6 @@ module GHC.Hs.Extension where import GhcPrelude import Data.Data hiding ( Fixity ) -import GHC.Hs.PlaceHolder import Name import RdrName import Var @@ -54,6 +59,74 @@ additional information for the tool, in a natural way. A further goal is to provide a means to harmonise the Template Haskell and haskell-src-exts ASTs as well. +Wrinkle: In order to print out the AST, we need to know it is Outputable. +We also sometimes need to branch on the particular pass that we're in +(e.g. to print out type information once we know it). In order to allow +both of these actions, we define OutputableBndrId, which gathers the necessary +OutputableBndr and IsPass constraints. The use of this constraint in instances +generally requires UndecidableInstances. + +See also Note [IsPass] and Note [NoGhcTc]. + +Note [IsPass] +~~~~~~~~~~~~~ +One challenge with the Trees That Grow approach +is that we sometimes have different information in different passes. +For example, we have + + type instance XViaStrategy GhcPs = LHsSigType GhcPs + type instance XViaStrategy GhcRn = LHsSigType GhcRn + type instance XViaStrategy GhcTc = Type + +This means that printing a DerivStrategy (which contains an XViaStrategy) +might need to print a LHsSigType, or it might need to print a type. Yet we +want one Outputable instance for a DerivStrategy, instead of one per pass. We +could have a large constraint, including e.g. (Outputable (XViaStrategy p), +Outputable (XViaStrategy GhcTc)), and pass that around in every context where +we might output a DerivStrategy. But a simpler alternative is to pass a +witness to whichever pass we're in. When we pattern-match on that (GADT) +witness, we learn the pass identity and can then print away. To wit, we get +the definition of GhcPass and the functions isPass. These allow us to do away +with big constraints, passing around all manner of dictionaries we might or +might not use. It does mean that we have to manually use isPass when printing, +but these places are few. + +See Note [NoGhcTc] about the superclass constraint to IsPass. + +Note [NoGhcTc] +~~~~~~~~~~~~~~ +An expression is parsed into HsExpr GhcPs, renamed into HsExpr GhcRn, and +then type-checked into HsExpr GhcTc. Not so for types! These get parsed +into HsType GhcPs, renamed into HsType GhcRn, and then type-checked into +Type. We never build an HsType GhcTc. Why do this? Because we need to be +able to compare type-checked types for equality, and we don't want to do +this with HsType. + +This causes wrinkles within the AST, where we normally thing that the whole +AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we +have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that +user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc. + +For example, this is used in ExprWithTySig: + | ExprWithTySig + (XExprWithTySig p) + + (LHsExpr p) + (LHsSigWcType (NoGhcTc p)) + +If we have (e :: ty), we still want to be able to print that (with the :: ty) +after type-checking. So we retain the LHsSigWcType GhcRn, even in an +HsExpr GhcTc. That's what NoGhcTc does. + +When we're printing the type annotation, we need to know +(Outputable (LHsSigWcType GhcRn)), even though we've assumed only that +(OutputableBndrId GhcTc). We thus must be able to prove OutputableBndrId (NoGhcTc p) +from OutputableBndrId p. The extra constraints in OutputableBndrId and +the superclass constraints of IsPass allow this. Note that the superclass +constraint of IsPass is *recursive*: it asserts that IsPass (NoGhcTcPass p) holds. +For this to make sense, we need -XUndecidableSuperClasses and the other constraint, +saying that NoGhcTcPass is idempotent. + -} -- | A placeholder type for TTG extension points that are not currently @@ -93,6 +166,12 @@ instance Outputable NoExtCon where noExtCon :: NoExtCon -> a noExtCon x = case x of {} +-- | GHC's L prefixed variants wrap their vanilla variant in this type family, +-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not +-- interested in location information can define this instance as @f p@. +type family XRec p (f :: * -> *) = r | r -> p f +type instance XRec (GhcPass p) f = Located (f (GhcPass p)) + {- Note [NoExtCon and strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -130,10 +209,19 @@ the strict field changes described above and delete gobs of code involving code that consumes unused extension constructors. -} --- | Used as a data type index for the hsSyn AST -data GhcPass (c :: Pass) -deriving instance Eq (GhcPass c) -deriving instance Typeable c => Data (GhcPass c) +-- | Used as a data type index for the hsSyn AST; also serves +-- as a singleton type for Pass +data GhcPass (c :: Pass) where + GhcPs :: GhcPs + GhcRn :: GhcRn + GhcTc :: GhcTc + +-- This really should never be entered, but the data-deriving machinery +-- needs the instance to exist. +instance Typeable p => Data (GhcPass p) where + gunfold _ _ _ = panic "instance Data GhcPass" + toConstr _ = panic "instance Data GhcPass" + dataTypeOf _ = panic "instance Data GhcPass" data Pass = Parsed | Renamed | Typechecked deriving (Data) @@ -144,23 +232,43 @@ type GhcRn = GhcPass 'Renamed -- Old 'Name' type param type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, type GhcTcId = GhcTc -- Old 'TcId' type param --- | GHC's L prefixed variants wrap their vanilla variant in this type family, --- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not --- interested in location information can define this instance as @f p@. -type family XRec p (f :: * -> *) = r | r -> p f -type instance XRec (GhcPass p) f = Located (f (GhcPass p)) +-- | Allows us to check what phase we're in at GHC's runtime. +-- For example, this class allows us to write +-- > f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah +-- > f e = case ghcPass @p of +-- > GhcPs -> ... in this RHS we have HsExpr GhcPs... +-- > GhcRn -> ... in this RHS we have HsExpr GhcRn... +-- > GhcTc -> ... in this RHS we have HsExpr GhcTc... +-- which is very useful, for example, when pretty-printing. +-- See Note [IsPass]. +class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p + , IsPass (NoGhcTcPass p) + ) => IsPass p where + ghcPass :: GhcPass p + +instance IsPass 'Parsed where + ghcPass = GhcPs +instance IsPass 'Renamed where + ghcPass = GhcRn +instance IsPass 'Typechecked where + ghcPass = GhcTc -- | Maps the "normal" id type for a given pass type family IdP p -type instance IdP GhcPs = RdrName -type instance IdP GhcRn = Name -type instance IdP GhcTc = Id +type instance IdP (GhcPass p) = IdGhcP p + +-- | Maps the "normal" id type for a given GHC pass +type family IdGhcP pass where + IdGhcP 'Parsed = RdrName + IdGhcP 'Renamed = Name + IdGhcP 'Typechecked = Id type LIdP p = Located (IdP p) -- | Marks that a field uses the GhcRn variant even when the pass -- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because -- HsType GhcTc should never occur. +-- See Note [NoGhcTc] type family NoGhcTc (p :: Type) where -- this way, GHC can figure out that the result is a GhcPass NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) @@ -179,23 +287,10 @@ type family XHsIPBinds x x' type family XEmptyLocalBinds x x' type family XXHsLocalBindsLR x x' -type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XHsValBinds x x') - , c (XHsIPBinds x x') - , c (XEmptyLocalBinds x x') - , c (XXHsLocalBindsLR x x') - ) - -- ValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' -type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XValBinds x x') - , c (XXValBindsLR x x') - ) - - -- HsBindsLR type families type family XFunBind x x' type family XPatBind x x' @@ -204,51 +299,22 @@ type family XAbsBinds x x' type family XPatSynBind x x' type family XXHsBindsLR x x' -type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XFunBind x x') - , c (XPatBind x x') - , c (XVarBind x x') - , c (XAbsBinds x x') - , c (XPatSynBind x x') - , c (XXHsBindsLR x x') - ) - -- ABExport type families type family XABE x type family XXABExport x -type ForallXABExport (c :: * -> Constraint) (x :: *) = - ( c (XABE x) - , c (XXABExport x) - ) - -- PatSynBind type families type family XPSB x x' type family XXPatSynBind x x' -type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XPSB x x') - , c (XXPatSynBind x x') - ) - -- HsIPBinds type families type family XIPBinds x type family XXHsIPBinds x -type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = - ( c (XIPBinds x) - , c (XXHsIPBinds x) - ) - -- IPBind type families type family XCIPBind x type family XXIPBind x -type ForallXIPBind (c :: * -> Constraint) (x :: *) = - ( c (XCIPBind x) - , c (XXIPBind x) - ) - -- Sig type families type family XTypeSig x type family XPatSynSig x @@ -263,30 +329,10 @@ type family XSCCFunSig x type family XCompleteMatchSig x type family XXSig x -type ForallXSig (c :: * -> Constraint) (x :: *) = - ( c (XTypeSig x) - , c (XPatSynSig x) - , c (XClassOpSig x) - , c (XIdSig x) - , c (XFixSig x) - , c (XInlineSig x) - , c (XSpecSig x) - , c (XSpecInstSig x) - , c (XMinimalSig x) - , c (XSCCFunSig x) - , c (XCompleteMatchSig x) - , c (XXSig x) - ) - -- FixitySig type families type family XFixitySig x type family XXFixitySig x -type ForallXFixitySig (c :: * -> Constraint) (x :: *) = - ( c (XFixitySig x) - , c (XXFixitySig x) - ) - -- StandaloneKindSig type families type family XStandaloneKindSig x type family XXStandaloneKindSig x @@ -311,44 +357,16 @@ type family XDocD x type family XRoleAnnotD x type family XXHsDecl x -type ForallXHsDecl (c :: * -> Constraint) (x :: *) = - ( c (XTyClD x) - , c (XInstD x) - , c (XDerivD x) - , c (XValD x) - , c (XSigD x) - , c (XKindSigD x) - , c (XDefD x) - , c (XForD x) - , c (XWarningD x) - , c (XAnnD x) - , c (XRuleD x) - , c (XSpliceD x) - , c (XDocD x) - , c (XRoleAnnotD x) - , c (XXHsDecl x) - ) - -- ------------------------------------- -- HsGroup type families type family XCHsGroup x type family XXHsGroup x -type ForallXHsGroup (c :: * -> Constraint) (x :: *) = - ( c (XCHsGroup x) - , c (XXHsGroup x) - ) - -- ------------------------------------- -- SpliceDecl type families type family XSpliceDecl x type family XXSpliceDecl x -type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) = - ( c (XSpliceDecl x) - , c (XXSpliceDecl x) - ) - -- ------------------------------------- -- TyClDecl type families type family XFamDecl x @@ -357,24 +375,11 @@ type family XDataDecl x type family XClassDecl x type family XXTyClDecl x -type ForallXTyClDecl (c :: * -> Constraint) (x :: *) = - ( c (XFamDecl x) - , c (XSynDecl x) - , c (XDataDecl x) - , c (XClassDecl x) - , c (XXTyClDecl x) - ) - -- ------------------------------------- -- TyClGroup type families type family XCTyClGroup x type family XXTyClGroup x -type ForallXTyClGroup (c :: * -> Constraint) (x :: *) = - ( c (XCTyClGroup x) - , c (XXTyClGroup x) - ) - -- ------------------------------------- -- FamilyResultSig type families type family XNoSig x @@ -382,75 +387,37 @@ type family XCKindSig x -- Clashes with XKindSig above type family XTyVarSig x type family XXFamilyResultSig x -type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) = - ( c (XNoSig x) - , c (XCKindSig x) - , c (XTyVarSig x) - , c (XXFamilyResultSig x) - ) - -- ------------------------------------- -- FamilyDecl type families type family XCFamilyDecl x type family XXFamilyDecl x -type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) = - ( c (XCFamilyDecl x) - , c (XXFamilyDecl x) - ) - -- ------------------------------------- -- HsDataDefn type families type family XCHsDataDefn x type family XXHsDataDefn x -type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) = - ( c (XCHsDataDefn x) - , c (XXHsDataDefn x) - ) - -- ------------------------------------- -- HsDerivingClause type families type family XCHsDerivingClause x type family XXHsDerivingClause x -type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) = - ( c (XCHsDerivingClause x) - , c (XXHsDerivingClause x) - ) - -- ------------------------------------- -- ConDecl type families type family XConDeclGADT x type family XConDeclH98 x type family XXConDecl x -type ForallXConDecl (c :: * -> Constraint) (x :: *) = - ( c (XConDeclGADT x) - , c (XConDeclH98 x) - , c (XXConDecl x) - ) - -- ------------------------------------- -- FamEqn type families type family XCFamEqn x r type family XXFamEqn x r -type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) = - ( c (XCFamEqn x r) - , c (XXFamEqn x r) - ) - -- ------------------------------------- -- ClsInstDecl type families type family XCClsInstDecl x type family XXClsInstDecl x -type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) = - ( c (XCClsInstDecl x) - , c (XXClsInstDecl x) - ) - -- ------------------------------------- -- ClsInstDecl type families type family XClsInstD x @@ -458,23 +425,11 @@ type family XDataFamInstD x type family XTyFamInstD x type family XXInstDecl x -type ForallXInstDecl (c :: * -> Constraint) (x :: *) = - ( c (XClsInstD x) - , c (XDataFamInstD x) - , c (XTyFamInstD x) - , c (XXInstDecl x) - ) - -- ------------------------------------- -- DerivDecl type families type family XCDerivDecl x type family XXDerivDecl x -type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = - ( c (XCDerivDecl x) - , c (XXDerivDecl x) - ) - -- ------------------------------------- -- DerivStrategy type family type family XViaStrategy x @@ -484,96 +439,48 @@ type family XViaStrategy x type family XCDefaultDecl x type family XXDefaultDecl x -type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) = - ( c (XCDefaultDecl x) - , c (XXDefaultDecl x) - ) - -- ------------------------------------- -- DefaultDecl type families type family XForeignImport x type family XForeignExport x type family XXForeignDecl x -type ForallXForeignDecl (c :: * -> Constraint) (x :: *) = - ( c (XForeignImport x) - , c (XForeignExport x) - , c (XXForeignDecl x) - ) - -- ------------------------------------- -- RuleDecls type families type family XCRuleDecls x type family XXRuleDecls x -type ForallXRuleDecls (c :: * -> Constraint) (x :: *) = - ( c (XCRuleDecls x) - , c (XXRuleDecls x) - ) - - -- ------------------------------------- -- RuleDecl type families type family XHsRule x type family XXRuleDecl x -type ForallXRuleDecl (c :: * -> Constraint) (x :: *) = - ( c (XHsRule x) - , c (XXRuleDecl x) - ) - -- ------------------------------------- -- RuleBndr type families type family XCRuleBndr x type family XRuleBndrSig x type family XXRuleBndr x -type ForallXRuleBndr (c :: * -> Constraint) (x :: *) = - ( c (XCRuleBndr x) - , c (XRuleBndrSig x) - , c (XXRuleBndr x) - ) - -- ------------------------------------- -- WarnDecls type families type family XWarnings x type family XXWarnDecls x -type ForallXWarnDecls (c :: * -> Constraint) (x :: *) = - ( c (XWarnings x) - , c (XXWarnDecls x) - ) - -- ------------------------------------- -- AnnDecl type families type family XWarning x type family XXWarnDecl x -type ForallXWarnDecl (c :: * -> Constraint) (x :: *) = - ( c (XWarning x) - , c (XXWarnDecl x) - ) - -- ------------------------------------- -- AnnDecl type families type family XHsAnnotation x type family XXAnnDecl x -type ForallXAnnDecl (c :: * -> Constraint) (x :: *) = - ( c (XHsAnnotation x) - , c (XXAnnDecl x) - ) - -- ------------------------------------- -- RoleAnnotDecl type families type family XCRoleAnnotDecl x type family XXRoleAnnotDecl x -type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) = - ( c (XCRoleAnnotDecl x) - , c (XXRoleAnnotDecl x) - ) - -- ===================================================================== -- Type families for the HsExpr extension points @@ -622,75 +529,18 @@ type family XSCC x type family XCoreAnn x type family XTickPragma x type family XXPragE x - -type ForallXExpr (c :: * -> Constraint) (x :: *) = - ( c (XVar x) - , c (XUnboundVar x) - , c (XConLikeOut x) - , c (XRecFld x) - , c (XOverLabel x) - , c (XIPVar x) - , c (XOverLitE x) - , c (XLitE x) - , c (XLam x) - , c (XLamCase x) - , c (XApp x) - , c (XAppTypeE x) - , c (XOpApp x) - , c (XNegApp x) - , c (XPar x) - , c (XSectionL x) - , c (XSectionR x) - , c (XExplicitTuple x) - , c (XExplicitSum x) - , c (XCase x) - , c (XIf x) - , c (XMultiIf x) - , c (XLet x) - , c (XDo x) - , c (XExplicitList x) - , c (XRecordCon x) - , c (XRecordUpd x) - , c (XExprWithTySig x) - , c (XArithSeq x) - , c (XSCC x) - , c (XCoreAnn x) - , c (XBracket x) - , c (XRnBracketOut x) - , c (XTcBracketOut x) - , c (XSpliceE x) - , c (XProc x) - , c (XStatic x) - , c (XTick x) - , c (XBinTick x) - , c (XTickPragma x) - , c (XWrap x) - , c (XXExpr x) - ) -- --------------------------------------------------------------------- type family XUnambiguous x type family XAmbiguous x type family XXAmbiguousFieldOcc x -type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XUnambiguous x) - , c (XAmbiguous x) - , c (XXAmbiguousFieldOcc x) - ) - -- ---------------------------------------------------------------------- type family XPresent x type family XMissing x type family XXTupArg x -type ForallXTupArg (c :: * -> Constraint) (x :: *) = - ( c (XPresent x) - , c (XMissing x) - , c (XXTupArg x) - ) - -- --------------------------------------------------------------------- type family XTypedSplice x @@ -699,14 +549,6 @@ type family XQuasiQuote x type family XSpliced x type family XXSplice x -type ForallXSplice (c :: * -> Constraint) (x :: *) = - ( c (XTypedSplice x) - , c (XUntypedSplice x) - , c (XQuasiQuote x) - , c (XSpliced x) - , c (XXSplice x) - ) - -- --------------------------------------------------------------------- type family XExpBr x @@ -718,67 +560,31 @@ type family XVarBr x type family XTExpBr x type family XXBracket x -type ForallXBracket (c :: * -> Constraint) (x :: *) = - ( c (XExpBr x) - , c (XPatBr x) - , c (XDecBrL x) - , c (XDecBrG x) - , c (XTypBr x) - , c (XVarBr x) - , c (XTExpBr x) - , c (XXBracket x) - ) - -- --------------------------------------------------------------------- type family XCmdTop x type family XXCmdTop x -type ForallXCmdTop (c :: * -> Constraint) (x :: *) = - ( c (XCmdTop x) - , c (XXCmdTop x) - ) - -- ------------------------------------- type family XMG x b type family XXMatchGroup x b -type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XMG x b) - , c (XXMatchGroup x b) - ) - -- ------------------------------------- type family XCMatch x b type family XXMatch x b -type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCMatch x b) - , c (XXMatch x b) - ) - -- ------------------------------------- type family XCGRHSs x b type family XXGRHSs x b -type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCGRHSs x b) - , c (XXGRHSs x b) - ) - -- ------------------------------------- type family XCGRHS x b type family XXGRHS x b -type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCGRHS x b) - , c (XXGRHS x b) - ) - -- ------------------------------------- type family XLastStmt x x' b @@ -791,18 +597,6 @@ type family XTransStmt x x' b type family XRecStmt x x' b type family XXStmtLR x x' b -type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) = - ( c (XLastStmt x x' b) - , c (XBindStmt x x' b) - , c (XApplicativeStmt x x' b) - , c (XBodyStmt x x' b) - , c (XLetStmt x x' b) - , c (XParStmt x x' b) - , c (XTransStmt x x' b) - , c (XRecStmt x x' b) - , c (XXStmtLR x x' b) - ) - -- --------------------------------------------------------------------- type family XCmdArrApp x @@ -817,42 +611,17 @@ type family XCmdDo x type family XCmdWrap x type family XXCmd x -type ForallXCmd (c :: * -> Constraint) (x :: *) = - ( c (XCmdArrApp x) - , c (XCmdArrForm x) - , c (XCmdApp x) - , c (XCmdLam x) - , c (XCmdPar x) - , c (XCmdCase x) - , c (XCmdIf x) - , c (XCmdLet x) - , c (XCmdDo x) - , c (XCmdWrap x) - , c (XXCmd x) - ) - -- --------------------------------------------------------------------- type family XParStmtBlock x x' type family XXParStmtBlock x x' -type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XParStmtBlock x x') - , c (XXParStmtBlock x x') - ) - -- --------------------------------------------------------------------- type family XApplicativeArgOne x type family XApplicativeArgMany x type family XXApplicativeArg x -type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) = - ( c (XApplicativeArgOne x) - , c (XApplicativeArgMany x) - , c (XXApplicativeArg x) - ) - -- ===================================================================== -- Type families for the HsImpExp extension points @@ -878,33 +647,9 @@ type family XHsFloatPrim x type family XHsDoublePrim x type family XXLit x --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXHsLit (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsDoublePrim x) - , c (XHsFloatPrim x) - , c (XHsInt x) - , c (XHsInt64Prim x) - , c (XHsIntPrim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsString x) - , c (XHsStringPrim x) - , c (XHsWord64Prim x) - , c (XHsWordPrim x) - , c (XXLit x) - ) - type family XOverLit x type family XXOverLit x -type ForallXOverLit (c :: * -> Constraint) (x :: *) = - ( c (XOverLit x) - , c (XXOverLit x) - ) - -- ===================================================================== -- Type families for the HsPat extension points @@ -927,58 +672,22 @@ 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 (XViewPat x) - , c (XSplicePat x) - , c (XLitPat x) - , c (XNPat x) - , c (XNPlusKPat x) - , c (XSigPat x) - , c (XCoPat x) - , c (XXPat x) - ) - -- ===================================================================== -- Type families for the HsTypes type families type family XHsQTvs x type family XXLHsQTyVars x -type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) = - ( c (XHsQTvs x) - , c (XXLHsQTyVars x) - ) - -- ------------------------------------- type family XHsIB x b type family XXHsImplicitBndrs x b -type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XHsIB x b) - , c (XXHsImplicitBndrs x b) - ) - -- ------------------------------------- type family XHsWC x b type family XXHsWildCardBndrs x b -type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XHsWC x b) - , c (XXHsWildCardBndrs x b) - ) - -- ------------------------------------- type family XForAllTy x @@ -1005,78 +714,28 @@ 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 (XAppTy x) - , c (XAppKindTy x) - , c (XFunTy x) - , c (XListTy x) - , c (XTupleTy x) - , c (XSumTy x) - , c (XOpTy x) - , c (XParTy x) - , c (XIParamTy x) - , c (XStarTy 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 XConDeclField x type family XXConDeclField x -type ForallXConDeclField (c :: * -> Constraint) (x :: *) = - ( c (XConDeclField x) - , c (XXConDeclField x) - ) - -- --------------------------------------------------------------------- type family XCFieldOcc x type family XXFieldOcc x -type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XCFieldOcc x) - , c (XXFieldOcc x) - ) - - -- ===================================================================== -- Type families for the HsImpExp type families type family XCImportDecl x type family XXImportDecl x -type ForallXImportDecl (c :: * -> Constraint) (x :: *) = - ( c (XCImportDecl x) - , c (XXImportDecl x) - ) - -- ------------------------------------- type family XIEVar x @@ -1089,18 +748,6 @@ type family XIEDoc x type family XIEDocNamed x type family XXIE x -type ForallXIE (c :: * -> Constraint) (x :: *) = - ( c (XIEVar x) - , c (XIEThingAbs x) - , c (XIEThingAll x) - , c (XIEThingWith x) - , c (XIEModuleContents x) - , c (XIEGroup x) - , c (XIEDoc x) - , c (XIEDocNamed x) - , c (XXIE x) - ) - -- ------------------------------------- @@ -1108,77 +755,23 @@ type ForallXIE (c :: * -> Constraint) (x :: *) = -- End of Type family definitions -- ===================================================================== --- ---------------------------------------------------------------------- --- | 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 --- converted via 'id', but needs a type signature to keep the type checker --- happy. -class Convertable a b | a -> b where - convert :: a -> b - -instance Convertable a a where - convert = id - --- | A constraint capturing all the extension points that can be converted via --- @instance Convertable a a@ -type ConvertIdX a b = - (XHsDoublePrim a ~ XHsDoublePrim b, - XHsFloatPrim a ~ XHsFloatPrim b, - XHsRat a ~ XHsRat b, - XHsInteger a ~ XHsInteger b, - XHsWord64Prim a ~ XHsWord64Prim b, - XHsInt64Prim a ~ XHsInt64Prim b, - XHsWordPrim a ~ XHsWordPrim b, - XHsIntPrim a ~ XHsIntPrim b, - XHsInt a ~ XHsInt b, - XHsStringPrim a ~ XHsStringPrim b, - XHsString a ~ XHsString b, - XHsCharPrim a ~ XHsCharPrim b, - XHsChar a ~ XHsChar b, - XXLit a ~ XXLit b) - --- ---------------------------------------------------------------------- - --- Note [OutputableX] --- ~~~~~~~~~~~~~~~~~~ --- --- is required because the type family resolution --- process cannot determine that all cases are handled for a `GhcPass p` --- case where the cases are listed separately. --- --- So --- --- type instance XXHsIPBinds (GhcPass p) = NoExtCon --- --- will correctly deduce Outputable for (GhcPass p), but --- --- type instance XIPBinds GhcPs = NoExt --- type instance XIPBinds GhcRn = NoExt --- type instance XIPBinds GhcTc = TcEvBinds --- --- will not. - - --- | Provide a summary constraint that gives all am Outputable constraint to --- extension points needing one -type OutputableX p = -- See Note [OutputableX] - ( Outputable (XIPBinds p) - , Outputable (XViaStrategy p) - , Outputable (XViaStrategy GhcRn) - ) --- TODO: Should OutputableX be included in OutputableBndrId? - --- ---------------------------------------------------------------------- - -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both --- the @p@ and the 'NameOrRdrName' type for it +-- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. type OutputableBndrId pass = - ( OutputableBndr (NameOrRdrName (IdP (GhcPass pass))) - , OutputableBndr (IdP (GhcPass pass)) - , OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass)))) - , OutputableBndr (IdP (NoGhcTc (GhcPass pass))) - , NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass)) - , OutputableX (GhcPass pass) - , OutputableX (NoGhcTc (GhcPass pass)) + ( OutputableBndr (IdGhcP pass) + , OutputableBndr (IdGhcP (NoGhcTcPass pass)) + , IsPass pass ) + +-- useful helper functions: +pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc +pprIfPs pp = case ghcPass @p of GhcPs -> pp + _ -> empty + +pprIfRn :: forall p. IsPass p => (p ~ 'Renamed => SDoc) -> SDoc +pprIfRn pp = case ghcPass @p of GhcRn -> pp + _ -> empty + +pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc +pprIfTc pp = case ghcPass @p of GhcTc -> pp + _ -> empty diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 32cc3b21a9..58a310a0c0 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -11,8 +11,8 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension module GHC.Hs.ImpExp where diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 5f6fae2cb2..fd723e1408 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -242,11 +242,6 @@ deriving instance Data (RoleAnnotDecl GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Expr ----------------------------------- --- deriving instance (DataIdLR p p) => Data (SyntaxExpr p) -deriving instance Data (SyntaxExpr GhcPs) -deriving instance Data (SyntaxExpr GhcRn) -deriving instance Data (SyntaxExpr GhcTc) - -- deriving instance (DataIdLR p p) => Data (HsPragE p) deriving instance Data (HsPragE GhcPs) deriving instance Data (HsPragE GhcRn) @@ -331,10 +326,13 @@ deriving instance Data (ArithSeqInfo GhcPs) deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordConTc -deriving instance Data CmdTopTc -deriving instance Data PendingRnSplice -deriving instance Data PendingTcSplice +deriving instance Data RecordConTc +deriving instance Data RecordUpdTc +deriving instance Data CmdTopTc +deriving instance Data PendingRnSplice +deriving instance Data PendingTcSplice +deriving instance Data SyntaxExprRn +deriving instance Data SyntaxExprTc -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Lit ------------------------------------ diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index c92f13392d..a023755ffc 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -10,8 +10,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -151,23 +151,22 @@ overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit (OverLitTc _ ty) _ _) = ty overLitType (XOverLit nec) = noExtCon nec --- | Convert a literal from one index type to another, updating the annotations --- according to the relevant 'Convertable' instance -convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b -convertLit (HsChar a x) = HsChar (convert a) x -convertLit (HsCharPrim a x) = HsCharPrim (convert a) x -convertLit (HsString a x) = HsString (convert a) x -convertLit (HsStringPrim a x) = HsStringPrim (convert a) x -convertLit (HsInt a x) = HsInt (convert a) x -convertLit (HsIntPrim a x) = HsIntPrim (convert a) x -convertLit (HsWordPrim a x) = HsWordPrim (convert a) x -convertLit (HsInt64Prim a x) = HsInt64Prim (convert a) x -convertLit (HsWord64Prim a x) = HsWord64Prim (convert a) x -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) +-- | Convert a literal from one index type to another +convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2) +convertLit (HsChar a x) = HsChar a x +convertLit (HsCharPrim a x) = HsCharPrim a x +convertLit (HsString a x) = HsString a x +convertLit (HsStringPrim a x) = HsStringPrim a x +convertLit (HsInt a x) = HsInt a x +convertLit (HsIntPrim a x) = HsIntPrim a x +convertLit (HsWordPrim a x) = HsWordPrim a x +convertLit (HsInt64Prim a x) = HsInt64Prim a x +convertLit (HsWord64Prim a x) = HsWord64Prim a x +convertLit (HsInteger a x b) = HsInteger a x b +convertLit (HsRat a x b) = HsRat a x b +convertLit (HsFloatPrim a x) = HsFloatPrim a x +convertLit (HsDoublePrim a x) = HsDoublePrim a x +convertLit (XLit a) = XLit a {- Note [ol_rebindable] diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 9812fe2c44..0a5bcb81d5 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -11,12 +11,14 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module GHC.Hs.Pat ( Pat(..), InPat, OutPat, LPat, @@ -156,9 +158,7 @@ data Pat p -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ - | SumPat (XSumPat p) -- GHC.Hs.PlaceHolder before typechecker, filled in - -- afterwards with the types of the - -- alternative + | SumPat (XSumPat p) -- after typechecker, types of the alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) Arity -- Arity (INVARIANT: ≥ 2) @@ -246,7 +246,7 @@ data Pat p -- a new hs-boot file. Not worth it. (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool - (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntaxName) + (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntax) -- ^ n+k pattern ------------ Pattern type signatures --------------- @@ -511,7 +511,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc +pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat @@ -525,11 +525,16 @@ 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 (CoPat _ co pat _) = pprIfTc @p $ + pprHsWrapper co $ \parens + -> if parens then pprParendPat appPrec pat else pprPat pat -pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty + where ppr_ty = case ghcPass @p of + GhcPs -> ppr ty + GhcRn -> ppr ty + GhcTc -> ppr ty pprPat (ListPat _ pats) = brackets (interpp'SP pats) pprPat (TuplePat _ pats bx) -- Special-case unary boxed tuples so that they are pretty-printed as @@ -553,7 +558,7 @@ pprPat (ConPatOut { pat_con = con if gopt Opt_PrintTypecheckerElaboration dflags then ppr con <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) - , ppr binds]) + , pprIfTc @p $ ppr binds ]) <+> pprConArgs details else pprUserCon (unLoc con) details pprPat (XPat n) = noExtCon n diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot index b37bf187fd..1a1e6c4a2c 100644 --- a/compiler/GHC/Hs/Pat.hs-boot +++ b/compiler/GHC/Hs/Pat.hs-boot @@ -1,8 +1,8 @@ {-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} diff --git a/compiler/GHC/Hs/PlaceHolder.hs b/compiler/GHC/Hs/PlaceHolder.hs deleted file mode 100644 index faaa1331ab..0000000000 --- a/compiler/GHC/Hs/PlaceHolder.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - -module GHC.Hs.PlaceHolder where - -import Name -import NameSet -import RdrName -import Var - - - -{- -%************************************************************************ -%* * -\subsection{Annotating the syntax} -%* * -%************************************************************************ --} - --- NB: These are intentionally open, allowing API consumers (like Haddock) --- to declare new instances - -placeHolderNamesTc :: NameSet -placeHolderNamesTc = emptyNameSet - -{- -TODO:AZ: remove this, and check if we still need all the UndecidableInstances - -Note [Pass sensitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the same AST types are re-used through parsing,renaming and type -checking there are naturally some places in the AST that do not have -any meaningful value prior to the pass they are assigned a value. - -Historically these have been filled in with place holder values of the form - - panic "error message" - -This has meant the AST is difficult to traverse using standard generic -programming techniques. The problem is addressed by introducing -pass-specific data types, implemented as a pair of open type families, -one for PostTc and one for PostRn. These are then explicitly populated -with a PlaceHolder value when they do not yet have meaning. - -In terms of actual usage, we have the following - - PostTc id Kind - PostTc id Type - - PostRn id Fixity - PostRn id NameSet - -TcId and Var are synonyms for Id - -Unfortunately the type checker termination checking conditions fail for the -DataId constraint type based on this, so even though it is safe the -UndecidableInstances pragma is required where this is used. --} - - --- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', --- for printing messages related to a 'Match' -type family NameOrRdrName id where - NameOrRdrName Id = Name - NameOrRdrName Name = Name - NameOrRdrName RdrName = RdrName diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index bc7ba47434..34709b71f1 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -11,8 +11,8 @@ GHC.Hs.Types: Abstract syntax: user-defined types {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module GHC.Hs.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 76101a73cb..22f2b02cd2 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -38,7 +38,7 @@ module GHC.Hs.Utils( mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, mkHsCmdIf, - nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, + nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -107,7 +107,6 @@ import GHC.Hs.Expr import GHC.Hs.Pat import GHC.Hs.Types import GHC.Hs.Lit -import GHC.Hs.PlaceHolder import GHC.Hs.Extension import TcEvidence @@ -151,7 +150,7 @@ just attach 'noSrcSpan' to everything. mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsPar e = L (getLoc e) (HsPar noExtField e) -mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) +mkSimpleMatch :: HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs @@ -215,18 +214,17 @@ mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr -nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) +nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc nlHsTyApp fun_id tys = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) -nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) +nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- -- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them -- So @f x@ becomes @(f x)@, but @3@ stays as @3@. -mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsPar le@(L loc e) | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le) | otherwise = le @@ -241,24 +239,26 @@ nlParPat p = noLoc (ParPat noExtField p) ------------------------------- -- These are the bits of syntax that contain rebindable names --- See GHC.Rename.Env.lookupSyntaxName +-- See GHC.Rename.Env.lookupSyntax 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 +mkHsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsComp :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs -mkLastStmt :: Located (bodyR (GhcPass idR)) +-- NB: The following functions all use noSyntaxExpr: the generated expressions +-- will not work with rebindable syntax if used after the renamer +mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) -mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) +mkBindStmt :: IsPass idR => (XBindStmt (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) ~ NoExtField) => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) @@ -281,13 +281,14 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = L (getLoc expr) $ mkLastStmt expr -mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) - -> HsExpr (GhcPass p) -mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b +-- restricted to GhcPs because other phases might need a SyntaxExpr +mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsIf c a b = HsIf True {- this might use rebindable syntax -} noSyntaxExpr c a b + -- see Note [Rebindable if] in Hs.Expr -mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) - -> HsCmd (GhcPass p) -mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b +-- restricted to GhcPs because other phases might need a SyntaxExpr +mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs +mkHsCmdIf c a b = HsCmdIf noExtField noSyntaxExpr c a b mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr mkNPlusKPat id lit @@ -323,8 +324,8 @@ mkBindStmt pat body mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr -- don't use placeHolderTypeTc above, because that panics during zonking -emptyRecStmt' :: forall idL idR body. - XRecStmt (GhcPass idL) (GhcPass idR) body +emptyRecStmt' :: forall idL idR body. IsPass idR + => XRecStmt (GhcPass idL) (GhcPass idR) body -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal = RecStmt @@ -389,6 +390,9 @@ mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) nlHsVar n = noLoc (HsVar noExtField (noLoc n)) +nl_HsVar :: IdP (GhcPass id) -> HsExpr (GhcPass id) +nl_HsVar n = HsVar noExtField (noLoc n) + -- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) @@ -405,23 +409,21 @@ nlVarPat n = noLoc (VarPat noExtField (noLoc n)) nlLitPat :: HsLit GhcPs -> LPat GhcPs nlLitPat l = noLoc (LitPat noExtField l) -nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x)) -nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) -nlHsSyntaxApps (SyntaxExpr { syn_expr = fun - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) args - | [] <- arg_wraps -- in the noSyntaxExpr case - = ASSERT( isIdHsWrapper res_wrap ) - foldl' nlHsApp (noLoc fun) args - - | otherwise +nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc] + -> LHsExpr GhcTc +nlHsSyntaxApps (SyntaxExprTc { syn_expr = fun + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) args = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) +nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args) + -- this function should never be called in scenarios where there is no + -- syntax expr -nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsApps :: IsPass id => IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) @@ -465,7 +467,7 @@ nlWildPat = noLoc (WildPat noExtField ) nlWildPatName :: LPat GhcRn nlWildPatName = noLoc (WildPat noExtField ) -nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] +nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) @@ -474,8 +476,6 @@ nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) - -> LHsExpr (GhcPass id) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs @@ -483,10 +483,11 @@ nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match])) nlHsPar e = noLoc (HsPar noExtField e) --- | Note [Rebindable nlHsIf] -- nlHsIf should generate if-expressions which are NOT subject to --- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false) +-- RebindableSyntax, so the first field of HsIf is False. (#12080) +-- See Note [Rebindable if] in Hs.Expr +nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsIf cond true false = noLoc (HsIf False noSyntaxExpr cond true false) nlHsCase expr matches = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) @@ -754,39 +755,39 @@ positions in the kind of the tycon. * * ********************************************************************* -} -mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) -- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@. -- See Note [Detecting forced eta expansion] in "DsExpr" -mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) -mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn e = HsWrap noExtField co_fn e +mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc +mkHsWrap co_fn e | isIdHsWrapper co_fn = e +mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn e = XExpr (HsWrap co_fn e) mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) + -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) + -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e -mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) -mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) +mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap noExtField w cmd + | otherwise = XCmd (HsWrap w cmd) -mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) +mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) -mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat noExtField co_fn p ty -mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPatCo co pat ty | isTcReflCo co = pat | otherwise = CoPat noExtField (mkWpCastN co) pat ty @@ -808,7 +809,6 @@ mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] mkFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms - , fun_co_fn = idHsWrapper , fun_ext = noExtField , fun_tick = [] } @@ -817,7 +817,6 @@ mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] -- ^ In Name-land, with empty bind_fvs mkTopFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms - , fun_co_fn = idHsWrapper , fun_ext = emptyNameSet -- NB: closed -- binding , fun_tick = [] } @@ -843,7 +842,7 @@ mkPatSynBind name details lpat dir = PatSynBind noExtField psb -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. isInfixFunBind :: HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind _ _ (MG _ matches _) _ _) +isInfixFunBind (FunBind { fun_matches = MG _ matches _ }) = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False @@ -859,13 +858,13 @@ mkSimpleGeneratedFunBind loc fun pats expr (noLoc emptyLocalBinds)] -- | Make a prefix, non-strict function 'HsMatchContext' -mkPrefixFunRhs :: Located id -> HsMatchContext id +mkPrefixFunRhs :: LIdP p -> HsMatchContext p mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_fixity = Prefix , mc_strictness = NoSrcStrict } ------------ -mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) +mkMatch :: HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> Located (HsLocalBinds (GhcPass p)) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index a7845de8bd..e397df455a 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -280,7 +280,7 @@ checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. -checkGuardMatches :: HsMatchContext Name -- Match context +checkGuardMatches :: HsMatchContext GhcRn -- Match context -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs -> DsM () checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 893966d3eb..022cc6cb2b 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -643,16 +643,16 @@ instance HasType (LHsExpr GhcTc) where -- See impact on Haddock output (esp. missing type annotations or links) -- before marking more things here as 'False'. See impact on Haddock -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr a -> Bool + skipDesugaring :: HsExpr GhcTc -> Bool skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - HsWrap{} -> False - _ -> True + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + XExpr (HsWrap{}) -> False + _ -> True instance ( ToHie (Context (Located (IdP a))) , ToHie (MatchGroup a (LHsExpr a)) @@ -732,7 +732,7 @@ instance ( ToHie (MatchGroup a (LHsExpr a)) instance ( a ~ GhcPass p , ToHie body - , ToHie (HsMatchContext (NameOrRdrName (IdP a))) + , ToHie (HsMatchContext (NoGhcTc a)) , ToHie (PScoped (LPat a)) , ToHie (GRHSs a body) , Data (Match a body) @@ -746,7 +746,7 @@ instance ( a ~ GhcPass p ] XMatch _ -> [] -instance ( ToHie (Context (Located a)) +instance ( ToHie (Context (Located (IdP a))) ) => ToHie (HsMatchContext a) where toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name toHie (StmtCtxt a) = toHie a @@ -885,6 +885,7 @@ instance ( a ~ GhcPass p , Data (HsTupArg a) , Data (AmbiguousFieldOcc a) , (HasRealDataConName a) + , IsPass p ) => ToHie (LHsExpr (GhcPass p)) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of HsVar _ (L _ var) -> @@ -997,9 +998,6 @@ instance ( a ~ GhcPass p HsBinTick _ _ _ expr -> [ toHie expr ] - HsWrap _ _ a -> - [ toHie $ L mspan a - ] HsBracket _ b -> [ toHie b ] @@ -1014,7 +1012,13 @@ instance ( a ~ GhcPass p HsSpliceE _ x -> [ toHie $ L mspan x ] - XExpr _ -> [] + XExpr x + | GhcTc <- ghcPass @p + , HsWrap _ a <- x + -> [ toHie $ L mspan a ] + + | otherwise + -> [] instance ( a ~ GhcPass p , ToHie (LHsExpr a) @@ -1244,7 +1248,6 @@ instance ( a ~ GhcPass p [ pure $ locOnly ispan , toHie $ listScopes NoScope stmts ] - HsCmdWrap _ _ _ -> [] XCmd _ -> [] instance ToHie (TyClGroup GhcRn) where diff --git a/compiler/GHC/Rename/Binds.hs b/compiler/GHC/Rename/Binds.hs index 6cf0a55fc6..888b8ce62d 100644 --- a/compiler/GHC/Rename/Binds.hs +++ b/compiler/GHC/Rename/Binds.hs @@ -1162,7 +1162,7 @@ checkDupMinimalSigs sigs ************************************************************************ -} -rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name +rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> MatchGroup GhcPs (Located (body GhcPs)) -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) @@ -1173,13 +1173,13 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) ; return (mkMatchGroup origin new_ms, ms_fvs) } rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec -rnMatch :: Outputable (body GhcPs) => HsMatchContext Name +rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> LMatch GhcPs (Located (body GhcPs)) -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) -rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name +rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> Match GhcPs (Located (body GhcPs)) -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) @@ -1195,7 +1195,7 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) , m_grhss = grhss'}, grhss_fvs ) }} rnMatch' _ _ (XMatch nec) = noExtCon nec -emptyCaseErr :: HsMatchContext Name -> SDoc +emptyCaseErr :: HsMatchContext GhcRn -> SDoc emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) 2 (text "Use EmptyCase to allow this") where @@ -1212,7 +1212,7 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) ************************************************************************ -} -rnGRHSs :: HsMatchContext Name +rnGRHSs :: HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> GRHSs GhcPs (Located (body GhcPs)) -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) @@ -1222,13 +1222,13 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) rnGRHSs _ _ (XGRHSs nec) = noExtCon nec -rnGRHS :: HsMatchContext Name +rnGRHS :: HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> LGRHS GhcPs (Located (body GhcPs)) -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) -rnGRHS' :: HsMatchContext Name +rnGRHS' :: HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> GRHS GhcPs (Located (body GhcPs)) -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 443c5614c8..82681a9206 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -30,7 +30,7 @@ module GHC.Rename.Env ( lookupGreAvailRn, -- Rebindable Syntax - lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames, + lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, -- Constructing usage information @@ -81,6 +81,7 @@ import GHC.Rename.Utils import qualified Data.Semigroup as Semi import Data.Either ( partitionEithers ) import Data.List (find) +import Control.Arrow ( first ) {- ********************************************************* @@ -1625,45 +1626,46 @@ We store the relevant Name in the HsSyn tree, in * HsDo respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, fromRationalName etc), but the renamer changes this to the appropriate user -name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. +name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does. We treat the original (standard) names as free-vars too, because the type checker checks the type of the user thing against the type of the standard thing. -} -lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) --- Different to lookupSyntaxName because in the non-rebindable +lookupIfThenElse :: Bool -- False <=> don't use rebindable syntax under any conditions + -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Different to lookupSyntax because in the non-rebindable -- case we desugar directly rather than calling an existing function -- Hence the (Maybe (SyntaxExpr GhcRn)) return type -lookupIfThenElse +lookupIfThenElse maybe_use_rs = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on - then return (Nothing, emptyFVs) + ; if not (rebindable_on && maybe_use_rs) + then return (NoSyntaxExprRn, emptyFVs) else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) - ; return ( Just (mkRnSyntaxExpr ite) + ; return ( mkRnSyntaxExpr ite , unitFV ite ) } } -lookupSyntaxName' :: Name -- ^ The standard name - -> RnM Name -- ^ Possibly a non-standard name -lookupSyntaxName' std_name - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return std_name - else - -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) } - -lookupSyntaxName :: Name -- The standard name - -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard - -- name +lookupSyntaxName :: Name -- ^ The standard name + -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name lookupSyntaxName std_name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then - return (mkRnSyntaxExpr std_name, emptyFVs) + return (std_name, emptyFVs) else -- Get the similarly named thing from the local environment do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) - ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } } + ; return (usr_name, unitFV usr_name) } } + +lookupSyntaxExpr :: Name -- ^ The standard name + -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name +lookupSyntaxExpr std_name + = fmap (first nl_HsVar) $ lookupSyntaxName std_name + +lookupSyntax :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name +lookupSyntax std_name + = fmap (first mkSyntaxExpr) $ lookupSyntaxExpr std_name lookupSyntaxNames :: [Name] -- Standard names -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index a03288086e..333e3c3f5a 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -202,7 +202,7 @@ rnExpr (OpApp _ e1 op e2) rnExpr (NegApp _ e _) = do { (e', fv_e) <- rnLExpr e - ; (neg_name, fv_neg) <- lookupSyntaxName negateName + ; (neg_name, fv_neg) <- lookupSyntax negateName ; final_e <- mkNegAppRn e' neg_name ; return (final_e, fv_e `plusFV` fv_neg) } @@ -273,7 +273,7 @@ rnExpr (ExplicitList x _ exps) ; (exps', fvs) <- rnExprs exps ; if opt_OverloadedLists then do { - ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; (from_list_n_name, fvs') <- lookupSyntax fromListNName ; return (ExplicitList x (Just from_list_n_name) exps' , fvs `plusFV` fvs') } else @@ -322,12 +322,12 @@ rnExpr (ExprWithTySig _ expr pty) rnLExpr expr ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } -rnExpr (HsIf x _ p b1 b2) +rnExpr (HsIf might_use_rebindable_syntax _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLExpr b1 ; (b2', fvB2) <- rnLExpr b2 - ; (mb_ite, fvITE) <- lookupIfThenElse - ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + ; (mb_ite, fvITE) <- lookupIfThenElse might_use_rebindable_syntax + ; return (HsIf noExtField mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsMultiIf x alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts @@ -339,7 +339,7 @@ rnExpr (ArithSeq x _ seq) ; (new_seq, fvs) <- rnArithSeq seq ; if opt_OverloadedLists then do { - ; (from_list_name, fvs') <- lookupSyntaxName fromListName + ; (from_list_name, fvs') <- lookupSyntax fromListName ; return (ArithSeq x (Just from_list_name) new_seq , fvs `plusFV` fvs') } else @@ -501,7 +501,7 @@ rnCmd (HsCmdIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 ; (b2', fvB2) <- rnLCmd b2 - ; (mb_ite, fvITE) <- lookupIfThenElse + ; (mb_ite, fvITE) <- lookupIfThenElse True ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} rnCmd (HsCmdLet x (L l binds) cmd) @@ -514,7 +514,6 @@ rnCmd (HsCmdDo x (L l stmts)) rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) ; return ( HsCmdDo x (L l stmts'), fvs ) } -rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) rnCmd (XCmd nec) = noExtCon nec --------------------------------------------------- @@ -532,7 +531,6 @@ methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c @@ -658,7 +656,7 @@ See Note [Deterministic UniqFM] to learn more about nondeterminism. -- | Rename some Stmts rnStmts :: Outputable (body GhcPs) - => HsStmtContext Name + => HsStmtContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) -> [LStmt GhcPs (Located (body GhcPs))] @@ -672,10 +670,10 @@ rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing :: Outputable (body GhcPs) - => HsStmtContext Name + => HsStmtContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> (HsStmtContext Name + -> (HsStmtContext GhcRn -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) -- ^ postprocess the statements @@ -694,7 +692,7 @@ rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside -- | maybe rearrange statements according to the ApplicativeDo transformation postProcessStmtsForApplicativeDo - :: HsStmtContext Name + :: HsStmtContext GhcRn -> [(ExprLStmt GhcRn, FreeVars)] -> RnM ([ExprLStmt GhcRn], FreeVars) postProcessStmtsForApplicativeDo ctxt stmts @@ -715,14 +713,14 @@ postProcessStmtsForApplicativeDo ctxt stmts -- | strip the FreeVars annotations from statements noPostProcessStmts - :: HsStmtContext Name + :: HsStmtContext GhcRn -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) rnStmtsWithFreeVars :: Outputable (body GhcPs) - => HsStmtContext Name + => HsStmtContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) @@ -785,7 +783,7 @@ At one point we failed to make this distinction, leading to #11216. -} rnStmt :: Outputable (body GhcPs) - => HsStmtContext Name + => HsStmtContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of the statement -> LStmt GhcPs (Located (body GhcPs)) @@ -928,7 +926,7 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ = rnStmt _ _ (L _ (XStmtLR nec)) _ = noExtCon nec -rnParallelStmts :: forall thing. HsStmtContext Name +rnParallelStmts :: forall thing. HsStmtContext GhcRn -> SyntaxExpr GhcRn -> [ParStmtBlock GhcPs GhcPs] -> ([Name] -> RnM (thing, FreeVars)) @@ -963,15 +961,15 @@ rnParallelStmts ctxt return_op segs thing_inside dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (NE.head vs))) -lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) --- Like lookupSyntaxName, but respects contexts +lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Like lookupSyntax, but respects contexts lookupStmtName ctxt n | rebindableContext ctxt - = lookupSyntaxName n + = lookupSyntax n | otherwise = return (mkRnSyntaxExpr n, emptyFVs) -lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars) +lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars) lookupStmtNamePoly ctxt name | rebindableContext ctxt = do { rebindable_on <- xoptM LangExt.RebindableSyntax @@ -987,7 +985,7 @@ lookupStmtNamePoly ctxt name -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable -- Neither is ArrowExpr, which has its own desugarer in DsArrows -rebindableContext :: HsStmtContext Name -> Bool +rebindableContext :: HsStmtContext GhcRn -> Bool rebindableContext ctxt = case ctxt of ListComp -> False ArrowExpr -> False @@ -1156,19 +1154,19 @@ rn_rec_stmt :: (Outputable (body GhcPs)) => -- Turns each stmt into a singleton Stmt rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _) = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; (ret_op, fvs1) <- lookupSyntax returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, L loc (LastStmt noExtField body' noret ret_op))] } rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _) = do { (body', fvs) <- rnBody body - ; (then_op, fvs1) <- lookupSyntaxName thenMName + ; (then_op, fvs1) <- lookupSyntax thenMName ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat) = do { (body', fv_expr) <- rnBody body - ; (bind_op, fvs1) <- lookupSyntaxName bindMName + ; (bind_op, fvs1) <- lookupSyntax bindMName ; (fail_op, fvs2) <- getMonadFailOp @@ -1219,7 +1217,7 @@ rn_rec_stmts rnBody bndrs stmts ; return (concat segs_s) } --------------------------------------------- -segmentRecStmts :: SrcSpan -> HsStmtContext Name +segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn -> Stmt GhcRn body -> [Segment (LStmt GhcRn body)] -> FreeVars -> ([LStmt GhcRn body], FreeVars) @@ -1323,7 +1321,7 @@ glom it together with the first two groups r <- x } -} -glomSegments :: HsStmtContext Name +glomSegments :: HsStmtContext GhcRn -> [Segment (LStmt GhcRn body)] -> [Segment [LStmt GhcRn body]] -- Each segment has a non-empty list of Stmts @@ -1534,7 +1532,7 @@ instance Outputable MonadNames where -- | rearrange a list of statements using ApplicativeDoStmt. See -- Note [ApplicativeDo]. rearrangeForApplicativeDo - :: HsStmtContext Name + :: HsStmtContext GhcRn -> [(ExprLStmt GhcRn, FreeVars)] -> RnM ([ExprLStmt GhcRn], FreeVars) @@ -1545,8 +1543,8 @@ rearrangeForApplicativeDo ctxt stmts0 = do let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts | otherwise = mkStmtTreeHeuristic stmts traceRn "rearrangeForADo" (ppr stmt_tree) - return_name <- lookupSyntaxName' returnMName - pure_name <- lookupSyntaxName' pureAName + (return_name, _) <- lookupSyntaxName returnMName + (pure_name, _) <- lookupSyntaxName pureAName let monad_names = MonadNames { return_name = return_name , pure_name = pure_name } stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs @@ -1660,7 +1658,7 @@ mkStmtTreeOptimal stmts = -- ApplicativeStmt where necessary. stmtTreeToStmts :: MonadNames - -> HsStmtContext Name + -> HsStmtContext GhcRn -> ExprStmtTree -> [ExprLStmt GhcRn] -- ^ the "tail" -> FreeVars -- ^ free variables of the tail @@ -1744,8 +1742,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do - ret <- lookupSyntaxName' returnMName - let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup + (ret, _) <- lookupSyntaxExpr returnMName + let expr = HsApp noExtField (noLoc ret) tup return (expr, emptyFVs) return ( ApplicativeArgMany { xarg_app_arg_many = noExtField @@ -1931,7 +1929,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- it this way rather than try to ignore the return later in both the -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt - :: HsStmtContext Name + :: HsStmtContext GhcRn -> [ApplicativeArg GhcRn] -- ^ The args -> Bool -- ^ True <=> need a join -> [ExprLStmt GhcRn] -- ^ The body statements @@ -1991,7 +1989,7 @@ isReturnApp monad_names (L _ e) = case e of ************************************************************************ -} -checkEmptyStmts :: HsStmtContext Name -> RnM () +checkEmptyStmts :: HsStmtContext GhcRn -> RnM () -- We've seen an empty sequence of Stmts... is that ok? checkEmptyStmts ctxt = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) @@ -2000,13 +1998,13 @@ okEmpty :: HsStmtContext a -> Bool okEmpty (PatGuard {}) = True okEmpty _ = False -emptyErr :: HsStmtContext Name -> SDoc +emptyErr :: HsStmtContext GhcRn -> SDoc emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name +checkLastStmt :: Outputable (body GhcPs) => HsStmtContext GhcRn -> LStmt GhcPs (Located (body GhcPs)) -> RnM (LStmt GhcPs (Located (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt) @@ -2036,7 +2034,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) = do { checkStmt ctxt lstmt; return lstmt } -- Checking when a particular Stmt is ok -checkStmt :: HsStmtContext Name +checkStmt :: HsStmtContext GhcRn -> LStmt GhcPs (Located (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) @@ -2064,7 +2062,7 @@ emptyInvalid :: Validity -- Payload is the empty document emptyInvalid = NotValid Outputable.empty okStmt, okDoStmt, okCompStmt, okParStmt - :: DynFlags -> HsStmtContext Name + :: DynFlags -> HsStmtContext GhcRn -> Stmt GhcPs (Located (body GhcPs)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to a generic error message @@ -2147,7 +2145,7 @@ badIpBinds what binds --------- monadFailOp :: LPat GhcPs - -> HsStmtContext Name + -> HsStmtContext GhcRn -> RnM (SyntaxExpr GhcRn, FreeVars) monadFailOp pat ctxt -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) @@ -2194,18 +2192,17 @@ getMonadFailOp where reallyGetMonadFailOp rebindableSyntax overloadedStrings | rebindableSyntax && overloadedStrings = do - (failExpr, failFvs) <- lookupSyntaxName failMName - (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName + (failExpr, failFvs) <- lookupSyntaxExpr failMName + (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName let arg_lit = mkVarOcc "arg" arg_name <- newSysName arg_lit - let arg_syn_expr = mkRnSyntaxExpr arg_name + let arg_syn_expr = nlHsVar arg_name body :: LHsExpr GhcRn = - nlHsApp (noLoc $ syn_expr failExpr) - (nlHsApp (noLoc $ syn_expr fromStringExpr) - (noLoc $ syn_expr arg_syn_expr)) + nlHsApp (noLoc failExpr) + (nlHsApp (noLoc $ fromStringExpr) arg_syn_expr) let failAfterFromStringExpr :: HsExpr GhcRn = unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) - | otherwise = lookupSyntaxName failMName + | otherwise = lookupSyntax failMName diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot index 9667b5b26c..77dec1b56a 100644 --- a/compiler/GHC/Rename/Expr.hs-boot +++ b/compiler/GHC/Rename/Expr.hs-boot @@ -10,7 +10,7 @@ rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) rnStmts :: --forall thing body. - Outputable (body GhcPs) => HsStmtContext Name + Outputable (body GhcPs) => HsStmtContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index ae509867b3..0f8041447b 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -309,7 +309,7 @@ There are various entry points to renaming patterns, depending on -- * local namemaker -- * unused and duplicate checking -- * no fixities -rnPats :: HsMatchContext Name -- for error messages +rnPats :: HsMatchContext GhcRn -- for error messages -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) @@ -337,7 +337,7 @@ rnPats ctxt pats thing_inside where doc_pat = text "In" <+> pprMatchContext ctxt -rnPat :: HsMatchContext Name -- for error messages +rnPat :: HsMatchContext GhcRn -- for error messages -> LPat GhcPs -> (LPat GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Variables bound by pattern do not @@ -429,7 +429,7 @@ rnPatAndThen mk (LitPat x lit) 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 + <- let negative = do { (neg, fvs) <- lookupSyntax negateName ; return (Just neg, fvs) } positive = return (Nothing, emptyFVs) in liftCpsFV $ case (mb_neg , mb_neg') of @@ -437,7 +437,7 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) (Just _ , Nothing) -> negative (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive - ; eq' <- liftCpsFV $ lookupSyntaxName eqName + ; eq' <- liftCpsFV $ lookupSyntax eqName ; return (NPat x (L l lit') mb_neg' eq') } rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) @@ -446,8 +446,8 @@ rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) -- We skip negateName as -- negative zero doesn't make -- sense in n + k patterns - ; minus <- liftCpsFV $ lookupSyntaxName minusName - ; ge <- liftCpsFV $ lookupSyntaxName geName + ; minus <- liftCpsFV $ lookupSyntax minusName + ; ge <- liftCpsFV $ lookupSyntax geName ; 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 @@ -481,7 +481,7 @@ 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 + True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName ; return (ListPat (Just to_list_name) pats')} False -> return (ListPat Nothing pats') } @@ -864,16 +864,12 @@ rnOverLit origLit | otherwise = origLit } ; let std_name = hsOverLitName val - ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) - <- lookupSyntaxName std_name - ; let rebindable = case from_thing_name of - HsVar _ lv -> (unLoc lv) /= std_name - _ -> panic "rnOverLit" - ; let lit' = lit { ol_witness = from_thing_name + ; (from_thing_name, fvs1) <- lookupSyntaxName std_name + ; let rebindable = from_thing_name /= std_name + lit' = lit { ol_witness = nl_HsVar from_thing_name , ol_ext = rebindable } ; if isNegativeZeroOverLit lit' - then do { (SyntaxExpr { syn_expr = negate_name }, fvs2) - <- lookupSyntaxName negateName + then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name) , fvs1 `plusFV` fvs2) } else return ((lit', Nothing), fvs1) } diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 7d970ed570..808cd21803 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -853,7 +853,7 @@ cvtLocalDecs doc ds ((_:_), (_:_)) -> failWith (text "Implicit parameters mixed with other bindings") -cvtClause :: HsMatchContext RdrName +cvtClause :: HsMatchContext GhcPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps @@ -924,7 +924,7 @@ cvtl e = wrapL (cvt e) ; return $ ExplicitSum noExtField alt arity e'} cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' } + ; return $ mkHsIf x' y' z' } cvt (MultiIfE alts) | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts @@ -1126,7 +1126,7 @@ cvtOpApp x op y -- Do notation and statements ------------------------------------- -cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs) +cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs) cvtHsDo do_or_lc stmts | null stmts = failWith (text "Empty stmt list in do-block") | otherwise @@ -1159,7 +1159,7 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') } -cvtMatch :: HsMatchContext RdrName +cvtMatch :: HsMatchContext GhcPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p |