diff options
| author | Richard Eisenberg <rae@richarde.dev> | 2019-11-05 13:11:19 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-02-08 10:16:33 -0500 |
| commit | 7755ffc2920facb7ed74efe379ad825feeaf1024 (patch) | |
| tree | c2bcece9de4776d99af32265084b78b7735d6654 | |
| parent | 309f8cfdad9cf81f5ee6003821810ea1205ae1d5 (diff) | |
| download | haskell-7755ffc2920facb7ed74efe379ad825feeaf1024.tar.gz | |
Introduce IsPass; refactor wrappers.
There are two main payloads of this patch:
1. This introduces IsPass, which allows e.g. printing
code to ask what pass it is running in (Renamed vs
Typechecked) and thus print extension fields. See
Note [IsPass] in Hs.Extension
2. This moves the HsWrap constructor into an extension
field, where it rightly belongs. This is done for
HsExpr and HsCmd, but not for HsPat, which is left
as an exercise for the reader.
There is also some refactoring around SyntaxExprs, but this
is really just incidental.
This patch subsumes !1721 (sorry @chreekat).
Along the way, there is a bit of refactoring in GHC.Hs.Extension,
including the removal of NameOrRdrName in favor of NoGhcTc.
This meant that we had no real need for GHC.Hs.PlaceHolder, so
I got rid of it.
Updates haddock submodule.
-------------------------
Metric Decrease:
haddock.compiler
-------------------------
53 files changed, 785 insertions, 1213 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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 6f9fe36141..0092e991ef 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -633,10 +633,10 @@ addTickHsExpr (HsProc x pat cmdtop) = liftM2 (HsProc x) (addTickLPat pat) (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (HsWrap x w e) = - liftM2 (HsWrap x) - (return w) - (addTickHsExpr e) -- Explicitly no tick on inside +addTickHsExpr (XExpr (HsWrap w e)) = + liftM XExpr $ + liftM (HsWrap w) + (addTickHsExpr e) -- Explicitly no tick on inside -- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) @@ -834,9 +834,11 @@ addTickIPBind (XIPBind x) = return (XIPBind x) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) -addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do +addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do x' <- fmap unLoc (addTickLHsExpr (L pos x)) return $ syn { syn_expr = x' } +addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc + -- we do not walk into patterns. addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat @@ -899,10 +901,9 @@ addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -addTickHsCmd (HsCmdWrap x w cmd) - = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd) - -addTickHsCmd (XCmd nec) = noExtCon nec +addTickHsCmd (XCmd (HsWrap w cmd)) = + liftM XCmd $ + liftM (HsWrap w) (addTickHsCmd cmd) -- Others should never happen in a command context. --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index bab9a60cad..8c1e161dc9 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -45,7 +45,6 @@ import CoreUtils import MkCore import DsBinds (dsHsWrapper) -import Name import Id import ConLike import TysWiredIn @@ -169,7 +168,7 @@ do_premap :: DsCmdEnv -> Type -> Type -> Type -> do_premap ids b_ty c_ty d_ty f g = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g -mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr +mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr mkFailExpr ctxt ty = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) @@ -530,11 +529,11 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd) (buildEnvStack else_ids stack_id) core_if <- case mb_fun of - Just fun -> do { fun_apps <- dsSyntaxExpr fun + NoSyntaxExprTc -> matchEnvStack env_ids stack_id $ + mkIfThenElse core_cond core_left core_right + _ -> do { fun_apps <- dsSyntaxExpr mb_fun [core_cond, core_left, core_right] - ; matchEnvStack env_ids stack_id fun_apps } - Nothing -> matchEnvStack env_ids stack_id $ - mkIfThenElse core_cond core_left core_right + ; matchEnvStack env_ids stack_id fun_apps } return (do_premap ids in_ty sum_ty res_ty core_if @@ -690,7 +689,7 @@ dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do return (mkApps (App core_op (Type env_ty)) core_args, unionDVarSets fv_sets) -dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do +dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids core_wrap <- dsHsWrapper wrap return (core_wrap core_cmd, env_ids') @@ -1126,7 +1125,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" -- Match a list of expressions against a list of patterns, left-to-right. matchSimplys :: [CoreExpr] -- Scrutinees - -> HsMatchContext Name -- Match kind + -> HsMatchContext GhcRn -- Match kind -> [LPat GhcTc] -- Patterns they should match -> CoreExpr -- Return this if they all match -> CoreExpr -- Return this if they don't diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index ac3a41a8fb..d573efc0c3 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -147,7 +147,7 @@ dsHsBind dflags (VarBind { var_id = var dsHsBind dflags b@(FunBind { fun_id = L _ fun , fun_matches = matches - , fun_co_fn = co_fn + , fun_ext = co_fn , fun_tick = tick }) = do { (args, body) <- matchWrapper (mkPrefixFunRhs (noLoc $ idName fun)) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 0f1386d76d..d4754fe568 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -198,7 +198,7 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches - , fun_co_fn = co_fn + , fun_ext = co_fn , fun_tick = tick }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed @@ -278,7 +278,7 @@ ds_expr _ (HsOverLit _ lit) = do { warnAboutOverflowedOverLit lit ; dsOverLit lit } -ds_expr _ (HsWrap _ co_fn e) +ds_expr _ (XExpr (HsWrap co_fn e)) = do { e' <- ds_expr True e -- This is the one place where we recurse to -- ds_expr (passing True), rather than dsExpr ; wrap' <- dsHsWrapper co_fn @@ -429,13 +429,13 @@ ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts -ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) +ds_expr _ (HsIf _ fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr ; b1 <- dsLExpr then_expr ; b2 <- dsLExpr else_expr - ; case mb_fun of - Just fun -> dsSyntaxExpr fun [pred, b1, b2] - Nothing -> return $ mkIfThenElse pred b1 b2 } + ; case fun of -- See Note [Rebindable if] in Hs.Expr + (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2] + NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 } ds_expr _ (HsMultiIf res_ty alts) | null alts @@ -741,7 +741,6 @@ ds_expr _ (HsBinTick _ ixT ixF e) = do ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" -ds_expr _ (XExpr nec) = noExtCon nec ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do @@ -766,9 +765,9 @@ ds_prag_expr (XHsPragE x) _ = noExtCon x ------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr -dsSyntaxExpr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) +dsSyntaxExpr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) arg_exprs = do { fun <- dsExpr expr ; core_arg_wraps <- mapM dsHsWrapper arg_wraps @@ -778,6 +777,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr (\_ -> core_res_wrap (mkApps fun wrapped_args)) } where mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) +dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index fe60cb8001..a424bd9d7b 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -29,7 +29,6 @@ import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTm import DsMonad import DsUtils import Type ( Type ) -import Name import Util import SrcLoc import Outputable @@ -55,7 +54,7 @@ dsGuarded grhss rhs_ty = do -- In contrast, @dsGRHSs@ produces a @MatchResult@. -dsGRHSs :: HsMatchContext Name +dsGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult @@ -68,7 +67,7 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty ; return match_result2 } dsGRHSs _ (XGRHSs nec) _ = noExtCon nec -dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) +dsGRHS :: HsMatchContext GhcRn -> Type -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM MatchResult dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty @@ -83,7 +82,7 @@ dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec -} matchGuards :: [GuardStmt GhcTc] -- Guard - -> HsStmtContext Name -- Context + -> HsStmtContext GhcRn -- Context -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard -> DsM MatchResult diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 9dcbc8faaa..5473682a40 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1971,9 +1971,10 @@ repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p ; repPaspat x' p1 } repP (ParPat _ p) = repLP p repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } -repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps) - ; e' <- repE (syn_expr e) - ; repPview e' p} +repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps) + ; e' <- repE e + ; repPview e' p} +repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps) repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 2af170be5f..998d46395d 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -97,7 +97,7 @@ import Data.IORef -} data DsMatchContext - = DsMatchContext (HsMatchContext Name) SrcSpan + = DsMatchContext (HsMatchContext GhcRn) SrcSpan deriving () instance Outputable DsMatchContext where diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index ac277893f6..d6ddfb894a 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -694,7 +694,7 @@ Call @match@ with all of this information! -} matchWrapper - :: HsMatchContext Name -- ^ For shadowing warning messages + :: HsMatchContext GhcRn -- ^ For shadowing warning messages -> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr -- case scrut of { p1 -> e1 ... } -- (and in this case the MatchGroup will @@ -775,7 +775,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches else id matchWrapper _ _ (XMatchGroup nec) = noExtCon nec -matchEquations :: HsMatchContext Name +matchEquations :: HsMatchContext GhcRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty @@ -799,7 +799,7 @@ pattern. It returns an expression. -} matchSimply :: CoreExpr -- ^ Scrutinee - -> HsMatchContext Name -- ^ Match kind + -> HsMatchContext GhcRn -- ^ Match kind -> LPat GhcTc -- ^ Pattern it should match -> CoreExpr -- ^ Return this if it matches -> CoreExpr -- ^ Return this if it doesn't @@ -813,7 +813,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc +matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult -- matchSinglePat ensures that the scrutinee is a variable -- and then calls matchSinglePatVar @@ -832,7 +832,7 @@ matchSinglePat scrut hs_ctx pat ty match_result ; return (adjustMatchResult (bindNonRec var scrut) match_result') } matchSinglePatVar :: Id -- See Note [Match Ids] - -> HsMatchContext Name -> LPat GhcTc + -> HsMatchContext GhcRn -> LPat GhcTc -> Type -> MatchResult -> DsM MatchResult matchSinglePatVar var ctx pat ty match_result = ASSERT2( isInternalName (idName var), ppr var ) @@ -1014,7 +1014,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers - exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' + exp (XExpr (HsWrap h e)) (XExpr (HsWrap h' e')) = wrap h h' && exp e e' exp (HsVar _ i) (HsVar _ i') = i == i' exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c' -- the instance for IPName derives using the id, so this works if the @@ -1053,15 +1053,17 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 --------- syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool - syn_exp (SyntaxExpr { syn_expr = expr1 - , syn_arg_wraps = arg_wraps1 - , syn_res_wrap = res_wrap1 }) - (SyntaxExpr { syn_expr = expr2 - , syn_arg_wraps = arg_wraps2 - , syn_res_wrap = res_wrap2 }) + syn_exp (SyntaxExprTc { syn_expr = expr1 + , syn_arg_wraps = arg_wraps1 + , syn_res_wrap = res_wrap1 }) + (SyntaxExprTc { syn_expr = expr2 + , syn_arg_wraps = arg_wraps2 + , syn_res_wrap = res_wrap2 }) = exp expr1 expr2 && and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && wrap res_wrap1 res_wrap2 + syn_exp NoSyntaxExprTc NoSyntaxExprTc = True + syn_exp _ _ = False --------- tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot index be5cd766ea..6d6cf989df 100644 --- a/compiler/deSugar/Match.hs-boot +++ b/compiler/deSugar/Match.hs-boot @@ -6,8 +6,7 @@ import TcType ( Type ) import DsMonad ( DsM, EquationInfo, MatchResult ) import CoreSyn ( CoreExpr ) import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) -import Name ( Name ) -import GHC.Hs.Extension ( GhcTc ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) match :: [Id] -> Type @@ -15,14 +14,14 @@ match :: [Id] -> DsM MatchResult matchWrapper - :: HsMatchContext Name + :: HsMatchContext GhcRn -> Maybe (LHsExpr GhcTc) -> MatchGroup GhcTc (LHsExpr GhcTc) -> DsM ([Id], CoreExpr) matchSimply :: CoreExpr - -> HsMatchContext Name + -> HsMatchContext GhcRn -> LPat GhcTc -> CoreExpr -> CoreExpr @@ -30,7 +29,7 @@ matchSimply matchSinglePatVar :: Id - -> HsMatchContext Name + -> HsMatchContext GhcRn -> LPat GhcTc -> Type -> MatchResult diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 59a93362bd..c965973403 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -347,7 +347,6 @@ Library GHC.Hs.Expr GHC.Hs.ImpExp GHC.Hs.Lit - GHC.Hs.PlaceHolder GHC.Hs.Extension GHC.Hs.Instances GHC.Hs.Pat diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 8f9be68f5a..8d3757f563 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2439,7 +2439,7 @@ decl_no_th :: { LHsDecl GhcPs } -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] case r of { - (FunBind _ n _ _ _) -> + (FunBind _ n _ _) -> amsL l (mj AnnFunId n:(fst $2)) >> return () ; (PatBind _ (L lh _lhs) _rhs _) -> amsL lh (fst $2) >> return () } ; diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index b2e8806caa..a4ca9aaf76 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -56,7 +56,7 @@ module RdrHsSyn ( checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat checkPattern_msg, - checkMonadComp, -- P (HsStmtContext RdrName) + checkMonadComp, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, LRuleTyTmVar, RuleTyTmVar(..), @@ -111,7 +111,6 @@ import CoAxiom ( Role, fsFromRole ) import RdrName import Name import BasicTypes -import TcEvidence ( idHsWrapper ) import Lexer import Lexeme ( isLexCon ) import Type ( TyThing(..), funTyCon ) @@ -1194,7 +1193,6 @@ makeFunBind fn ms = FunBind { fun_ext = noExtField, fun_id = fn, fun_matches = mkMatchGroup FromSource ms, - fun_co_fn = idHsWrapper, fun_tick = [] } -- See Note [FunBind vs PatBind] @@ -1675,7 +1673,7 @@ mergeDataCon all_xs = -- If the flag MonadComprehensions is set, return a 'MonadComp' context, -- otherwise use the usual 'ListComp' context -checkMonadComp :: PV (HsStmtContext Name) +checkMonadComp :: PV (HsStmtContext GhcRn) checkMonadComp = do monadComprehensions <- getBit MonadComprehensionsBit return $ if monadComprehensions @@ -2275,7 +2273,7 @@ data Frame -- ^ If-expression: if p then x else y | FrameCase LFrame [LFrameMatch] -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } - | FrameDo (HsStmtContext Name) [LFrameStmt] + | FrameDo (HsStmtContext GhcRn) [LFrameStmt] -- ^ Do-expression: do { s1; a <- s2; s3 } ... | FrameExpr (HsExpr GhcPs) -- unambiguously an expression diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 7bdcac865d..0dd83837e2 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -30,7 +30,6 @@ import TcOrigin import TcEvidence import Id( mkLocalId ) import Inst -import Name import TysWiredIn import VarSet import TysPrim @@ -161,14 +160,14 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' ; tcCmd env body (stk, res_ty') } -tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' +tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x Nothing pred' b1' b2') + ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2') } -tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if +tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if = do { pred_ty <- newOpenFlexiTyVarTy -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not @@ -184,7 +183,7 @@ tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsCmdIf x (Just fun') pred' b1' b2') + ; return (HsCmdIf x fun' pred' b1' b2') } ------------------------------------------- @@ -267,7 +266,7 @@ tc_cmd env ; return (mkHsCmdWrap (mkWpCastN co) cmd') } where n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? + match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 06b0a821c0..d848f76c2e 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -713,8 +713,7 @@ tcPolyCheck prag_fn ; tick <- funBindTicks nm_loc mono_id mod prag_sigs ; let bind' = FunBind { fun_id = L nm_loc mono_id , fun_matches = matches' - , fun_co_fn = co_fn - , fun_ext = placeHolderNamesTc + , fun_ext = co_fn , fun_tick = tick } export = ABE { abe_ext = noExtField @@ -1250,8 +1249,7 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name - , fun_matches = matches - , fun_ext = fvs })] + , fun_matches = matches })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1276,8 +1274,8 @@ tcMonoBinds is_rec sig_fn no_gen ; mono_id <- newLetBndr no_gen name rhs_ty ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, - fun_matches = matches', fun_ext = fvs, - fun_co_fn = co_fn, fun_tick = [] }, + fun_matches = matches', + fun_ext = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name , mbi_sig = Nothing , mbi_mono_id = mono_id }]) } @@ -1424,8 +1422,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) matches (mkCheckExpType $ idType mono_id) ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' - , fun_co_fn = co_fn - , fun_ext = placeHolderNamesTc + , fun_ext = co_fn , fun_tick = [] } ) } tcRhs (TcPatBind infos pat' grhss pat_ty) @@ -1438,7 +1435,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_ext = NPatBindTc placeHolderNamesTc pat_ty + , pat_ext = NPatBindTc emptyNameSet pat_ty , pat_ticks = ([],[]) } )} tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 8749f98484..eedc2f5b3d 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -3,8 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an -- orphan -{-# 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 TypeFamilies #-} module TcEnv( diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 845b81bb23..6fd9585e8a 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -534,7 +534,7 @@ tcExpr (HsCase x scrut matches) res_ty match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' +tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) ; res_ty <- tauifyExpType res_ty -- Just like Note [Case branches must never infer a non-tau type] @@ -542,9 +542,9 @@ tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if' ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty - ; return (HsIf x Nothing pred' b1' b2') } + ; return (HsIf x NoSyntaxExprTc pred' b1' b2') } -tcExpr (HsIf x (Just fun) pred b1 b2) res_ty +tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty = do { ((pred', b1', b2'), fun') <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $ \ [pred_ty, b1_ty, b2_ty] -> @@ -552,7 +552,7 @@ tcExpr (HsIf x (Just fun) pred b1 b2) res_ty ; b1' <- tcPolyExpr b1 b1_ty ; b2' <- tcPolyExpr b2 b2_ty ; return (pred', b1', b2') } - ; return (HsIf x (Just fun') pred' b1' b2') } + ; return (HsIf x fun' pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty = do { res_ty <- if isSingleton alts @@ -1401,11 +1401,11 @@ tcTupArgs args tys --------------------------- -- See TcType.SyntaxOpType also for commentary tcSyntaxOp :: CtOrigin - -> SyntaxExpr GhcRn + -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpRhoType -- ^ overall result type -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr GhcTcId) + -> TcM (a, SyntaxExprTc) -- ^ Typecheck a syntax operator -- The operator is a variable or a lambda at this stage (i.e. renamer -- output) @@ -1415,21 +1415,22 @@ tcSyntaxOp orig expr arg_tys res_ty -- | Slightly more general version of 'tcSyntaxOp' that allows the caller -- to specify the shape of the result of the syntax operator tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr GhcRn + -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr GhcTcId) -tcSyntaxOpGen orig op arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op + -> TcM (a, SyntaxExprTc) +tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside + = do { (expr, sigma) <- tcInferSigma $ noLoc op ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) ; (result, expr_wrap, arg_wraps, res_wrap) <- tcSynArgA orig sigma arg_tys res_ty $ thing_inside ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) - ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) } + ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap $ unLoc expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) } +tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" {- Note [tcSynArg] diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot index 3aa9952088..571e707752 100644 --- a/compiler/typecheck/TcExpr.hs-boot +++ b/compiler/typecheck/TcExpr.hs-boot @@ -1,6 +1,6 @@ module TcExpr where import Name -import GHC.Hs ( HsExpr, LHsExpr, SyntaxExpr ) +import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc ) import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import TcRnTypes( TcM ) import TcOrigin ( CtOrigin ) @@ -25,18 +25,18 @@ tcInferRho, tcInferRhoNC :: -> TcM (LHsExpr GhcTcId, TcRhoType) tcSyntaxOp :: CtOrigin - -> SyntaxExpr GhcRn + -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments -> ExpType -- ^ overall result type -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments - -> TcM (a, SyntaxExpr GhcTcId) + -> TcM (a, SyntaxExprTc) tcSyntaxOpGen :: CtOrigin - -> SyntaxExpr GhcRn + -> SyntaxExprRn -> [SyntaxOpType] -> SyntaxOpType -> ([TcSigmaType] -> TcM a) - -> TcM (a, SyntaxExpr GhcTcId) + -> TcM (a, SyntaxExprTc) tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId) diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index 2f03cd0950..6cc3642b8b 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -224,7 +224,7 @@ gen_Functor_binds loc tycon , ft_co_var = panic "contravariant in ft_replace" } -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... - match_for_con :: HsMatchContext RdrName + match_for_con :: HsMatchContext GhcPs -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs] -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs)) match_for_con ctxt = mkSimpleConMatch ctxt $ @@ -463,7 +463,7 @@ mkSimpleLam2 lam = -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ -- and its arguments, applying an expression (from @insides@) to each of the -- respective arguments of @con@. -mkSimpleConMatch :: Monad m => HsMatchContext RdrName +mkSimpleConMatch :: Monad m => HsMatchContext GhcPs -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)) -> [LPat GhcPs] -> DataCon @@ -499,7 +499,7 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do -- -- See Note [Generated code for DeriveFoldable and DeriveTraversable] mkSimpleConMatch2 :: Monad m - => HsMatchContext RdrName + => HsMatchContext GhcPs -> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)) -> [LPat GhcPs] diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 9db8880fc9..3ae4e63fc6 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -563,13 +563,13 @@ zonk_bind env (VarBind { var_ext = x zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = ms - , fun_co_fn = co_fn }) + , fun_ext = co_fn }) = do { new_var <- zonkIdBndr env var ; (env1, new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env1 zonkLExpr ms ; return (bind { fun_id = L loc new_var , fun_matches = new_ms - , fun_co_fn = new_co_fn }) } + , fun_ext = new_co_fn }) } zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abs_ev_binds = ev_binds @@ -596,7 +596,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs | has_sig , (L loc bind@(FunBind { fun_id = L mloc mono_id , fun_matches = ms - , fun_co_fn = co_fn })) <- lbind + , fun_ext = co_fn })) <- lbind = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder @@ -605,7 +605,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs ; return $ L loc $ bind { fun_id = L mloc new_mono_id , fun_matches = new_ms - , fun_co_fn = new_co_fn } } + , fun_ext = new_co_fn } } | otherwise = zonk_lbind env lbind -- The normal case @@ -847,18 +847,12 @@ zonkExpr env (HsCase x expr ms) new_ms <- zonkMatchGroup env zonkLExpr ms return (HsCase x new_expr new_ms) -zonkExpr env (HsIf x Nothing e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (HsIf x Nothing new_e1 new_e2 new_e3) - -zonkExpr env (HsIf x (Just fun) e1 e2 e3) +zonkExpr env (HsIf x fun e1 e2 e3) = do (env1, new_fun) <- zonkSyntaxExpr env fun new_e1 <- zonkLExpr env1 e1 new_e2 <- zonkLExpr env1 e2 new_e3 <- zonkLExpr env1 e3 - return (HsIf x (Just new_fun) new_e1 new_e2 new_e3) + return (HsIf x new_fun new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts @@ -936,10 +930,10 @@ zonkExpr env (HsProc x pat body) zonkExpr env (HsStatic fvs expr) = HsStatic fvs <$> zonkLExpr env expr -zonkExpr env (HsWrap x co_fn expr) +zonkExpr env (XExpr (HsWrap co_fn expr)) = do (env1, new_co_fn) <- zonkCoFn env co_fn new_expr <- zonkExpr env1 expr - return (HsWrap x new_co_fn new_expr) + return (XExpr (HsWrap new_co_fn new_expr)) zonkExpr _ e@(HsUnboundVar {}) = return e @@ -970,15 +964,16 @@ Now, we can safely just extend one environment. -- See Note [Skolems in zonkSyntaxExpr] zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId -> TcM (ZonkEnv, SyntaxExpr GhcTc) -zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr +zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) = do { (env0, res_wrap') <- zonkCoFn env res_wrap ; expr' <- zonkExpr env0 expr ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps - ; return (env1, SyntaxExpr { syn_expr = expr' - , syn_arg_wraps = arg_wraps' - , syn_res_wrap = res_wrap' }) } + ; return (env1, SyntaxExprTc { syn_expr = expr' + , syn_arg_wraps = arg_wraps' + , syn_res_wrap = res_wrap' }) } +zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc) ------------------------------------------------------------------------- @@ -987,10 +982,10 @@ zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc) zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd -zonkCmd env (HsCmdWrap x w cmd) +zonkCmd env (XCmd (HsWrap w cmd)) = do { (env1, w') <- zonkCoFn env w ; cmd' <- zonkCmd env1 cmd - ; return (HsCmdWrap x w' cmd') } + ; return (XCmd (HsWrap w' cmd')) } zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) = do new_e1 <- zonkLExpr env e1 new_e2 <- zonkLExpr env e2 @@ -1021,14 +1016,11 @@ zonkCmd env (HsCmdCase x expr ms) return (HsCmdCase x new_expr new_ms) zonkCmd env (HsCmdIf x eCond ePred cThen cElse) - = do { (env1, new_eCond) <- zonkWit env eCond + = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond ; new_ePred <- zonkLExpr env1 ePred ; new_cThen <- zonkLCmd env1 cThen ; new_cElse <- zonkLCmd env1 cElse ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } - where - zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w zonkCmd env (HsCmdLet x (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds @@ -1040,8 +1032,6 @@ zonkCmd env (HsCmdDo ty (L l stmts)) new_ty <- zonkTcTypeToTypeX env ty return (HsCmdDo new_ty (L l new_stmts)) -zonkCmd _ (XCmd nec) = noExtCon nec - zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 62edfae0ed..96775696a9 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1174,7 +1174,7 @@ addDFunPrags dfun_id sc_meth_ids [dict_con] = tyConDataCons clas_tc is_newtype = isNewTyCon clas_tc -wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id) +wrapId :: HsWrapper -> Id -> HsExpr GhcTc wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) {- Note [Typechecking plan for instance declarations] diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index e373fe6b8f..8088602972 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -206,7 +206,7 @@ tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body -> TcM (MatchGroup GhcTcId (Located (body GhcTcId))) data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is + = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is mc_body :: Located (body GhcRn) -- Type checker for a body of -- an alternative -> ExpRhoType @@ -291,7 +291,7 @@ tcGRHS _ _ (XGRHS nec) = noExtCon nec ************************************************************************ -} -tcDoStmts :: HsStmtContext Name +tcDoStmts :: HsStmtContext GhcRn -> Located [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTcId) -- Returns a HsDo @@ -338,13 +338,13 @@ type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType type TcStmtChecker body rho_type - = forall thing. HsStmtContext Name + = forall thing. HsStmtContext GhcRn -> Stmt GhcRn (Located (body GhcRn)) -> rho_type -- Result type for comprehension -> (rho_type -> TcM thing) -- Checker for what follows the stmt -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing) -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name +tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -- NB: higher-rank type -> [LStmt GhcRn (Located (body GhcRn))] -> rho_type @@ -354,7 +354,7 @@ tcStmts ctxt stmt_chk stmts res_ty const (return ()) ; return stmts' } -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name +tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -- NB: higher-rank type -> [LStmt GhcRn (Located (body GhcRn))] -> rho_type @@ -972,7 +972,7 @@ join :: tn -> res_ty -} tcApplicativeStmts - :: HsStmtContext Name + :: HsStmtContext GhcRn -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] -> ExpRhoType -- rhs_ty -> (TcRhoType -> TcM t) -- thing_inside diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs index 6cf1dbb8d8..fd260f01ac 100644 --- a/compiler/typecheck/TcOrigin.hs +++ b/compiler/typecheck/TcOrigin.hs @@ -205,7 +205,7 @@ data SkolemInfo | FamInstSkol -- Bound at a family instance decl | PatSkol -- An existential type variable bound by a pattern for ConLike -- a data constructor with an existential type. - (HsMatchContext Name) + (HsMatchContext GhcRn) -- e.g. data T = forall a. Eq a => MkT a -- f (MkT x) = ... -- The pattern MkT x will allocate an existential type @@ -498,7 +498,7 @@ exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) +exprCtOrigin (HsIf _ (SyntaxExprRn syn) _ _ _) = exprCtOrigin syn exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e @@ -517,7 +517,6 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" exprCtOrigin (XExpr nec) = noExtCon nec -- | Extract a suitable CtOrigin from a MatchGroup diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 97664e9526..e610bf5182 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -82,7 +82,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside ; tc_lpat pat pat_ty penv thing_inside } ----------------- -tcPats :: HsMatchContext Name +tcPats :: HsMatchContext GhcRn -> [LPat GhcRn] -- Patterns, -> [ExpSigmaType] -- and their types -> TcM a -- and the checker for the body @@ -104,14 +104,14 @@ tcPats ctxt pats pat_tys thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcPat :: HsMatchContext Name +tcPat :: HsMatchContext GhcRn -> LPat GhcRn -> ExpSigmaType -> TcM a -- Checker for body -> TcM (LPat GhcTcId, a) tcPat ctxt = tcPat_O ctxt PatOrigin -- | A variant of 'tcPat' that takes a custom origin -tcPat_O :: HsMatchContext Name +tcPat_O :: HsMatchContext GhcRn -> CtOrigin -- ^ origin to use if the type needs inst'ing -> LPat GhcRn -> ExpSigmaType -> TcM a -- Checker for body @@ -138,7 +138,7 @@ data PatEnv data PatCtxt = LamPat -- Used for lambdas, case etc - (HsMatchContext Name) + (HsMatchContext GhcRn) | LetPat -- Used only for let(rec) pattern bindings -- See Note [Typing patterns in pattern bindings] @@ -604,8 +604,18 @@ tc_pat penv (NPlusKPat _ (L nm_loc name) ; res <- tcExtendIdEnv1 name bndr_id thing_inside - ; let minus'' = minus' { syn_res_wrap = - minus_wrap <.> syn_res_wrap minus' } + ; let minus'' = case minus' of + NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus') + -- this should be statically avoidable + -- Case (3) from Note [NoSyntaxExpr] in Hs.Expr + SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus'_res_wrap } + -> SyntaxExprTc { syn_expr = minus'_expr + , syn_arg_wraps = minus'_arg_wraps + , syn_res_wrap = minus_wrap <.> minus'_res_wrap } + -- Oy. This should really be a record update, but + -- we get warnings if we try. #17783 pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' ge' minus'' ; return (pat', res) } diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 21f20c552d..ff90b473b2 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -751,10 +751,9 @@ tcPatSynMatcher (L loc name) lpat , mg_origin = Generated } - ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = L loc matcher_id + ; let bind = FunBind{ fun_id = L loc matcher_id , fun_matches = mg - , fun_co_fn = idHsWrapper + , fun_ext = idHsWrapper , fun_tick = [] } matcher_bind = unitBag (noLoc bind) @@ -841,10 +840,9 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name let match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group - bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = L loc (idName builder_id) + bind = FunBind { fun_id = L loc (idName builder_id) , fun_matches = match_group' - , fun_co_fn = idHsWrapper + , fun_ext = emptyNameSet , fun_tick = [] } sig = completeSigFromId (PatSynCtxt name) builder_id @@ -973,8 +971,9 @@ tcPatToExpr name args pat = go pat } go1 (LitPat _ lit) = return $ HsLit noExtField lit go1 (NPat _ (L _ n) mb_neg _) - | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg - [noLoc (HsOverLit noExtField n)] + | Just (SyntaxExprRn neg) <- mb_neg + = return $ unLoc $ foldl' nlHsApp (noLoc neg) + [noLoc (HsOverLit noExtField n)] | otherwise = return $ HsOverLit noExtField n go1 (ConPatOut{}) = panic "ConPatOut in output of renamer" go1 (CoPat{}) = panic "CoPat in output of renamer" diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index b07a376482..8302c2ba4f 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -340,8 +340,8 @@ processAllTypeCheckedModule tcm = do mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i | otherwise = Nothing - unwrapVar (HsWrap _ _ var) = var - unwrapVar e' = e' + unwrapVar (XExpr (HsWrap _ var)) = var + unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index d7996df404..8ae907ee25 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -454,7 +454,6 @@ (EmptyLocalBinds (NoExtField))))))]) (FromSource)) - (WpHole) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 53d4f37acf..57da7c2199 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -53,7 +53,6 @@ (EmptyLocalBinds (NoExtField))))))]) (FromSource)) - (WpHole) []))]})] [])) [] diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 5282c9f62a..3654edfa45 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -552,15 +552,15 @@ (HsApp (NoExtField) ({ <no location info> } - (HsWrap - (NoExtField) - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike})))) + (XExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike}))))) ({ <no location info> } (HsVar (NoExtField) @@ -576,15 +576,15 @@ (HsApp (NoExtField) ({ <no location info> } - (HsWrap - (NoExtField) - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike})))) + (XExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike}))))) ({ <no location info> } (HsVar (NoExtField) @@ -600,30 +600,30 @@ (HsApp (NoExtField) ({ <no location info> } - (HsWrap - (NoExtField) - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike})))) + (XExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike}))))) ({ <no location info> } (HsVar (NoExtField) ({ <no location info> } {Var: $krep}))))) ({ <no location info> } - (HsWrap - (NoExtField) - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike})))))))))))))))))) + (XExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike}))))))))))))))))))) (False))) ,({ <no location info> } (VarBind @@ -645,15 +645,15 @@ ({ <no location info> } {Var: DumpTypecheckedAst.$tcPeano}))))) ({ <no location info> } - (HsWrap - (NoExtField) - (WpTyApp - (TyConApp - ({abstract:TyCon}) - [])) - (HsConLikeOut - (NoExtField) - ({abstract:ConLike})))))) + (XExpr + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExtField) + ({abstract:ConLike}))))))) (False))) ,({ <no location info> } (VarBind @@ -718,8 +718,7 @@ {Bag(Located (HsBind Var)): [({ DumpTypecheckedAst.hs:18:1-23 } (FunBind - {NameSet: - []} + (WpHole) ({ DumpTypecheckedAst.hs:18:1-4 } {Var: main}) (MG @@ -765,7 +764,6 @@ (EmptyLocalBinds (NoExtField))))))]) (FromSource)) - (WpHole) []))]} (False)))]} diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 2873bfcfaa..06ed01539a 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -361,7 +361,6 @@ (EmptyLocalBinds (NoExtField))))))]) (FromSource)) - (WpHole) []))) ,({ KindSigs.hs:26:1-29 } (TyClD @@ -602,7 +601,6 @@ (EmptyLocalBinds (NoExtField))))))]) (FromSource)) - (WpHole) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 3867404d2c..4162fc24be 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -53,9 +53,9 @@ typecheckPlugin [name, "typecheck"] _ tc typecheckPlugin _ _ tc = return tc metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -metaPlugin' [name, "meta"] (L l (HsWrap ne w (HsPar x (L _ (HsApp noExt (L _ (HsVar _ (L _ id))) e))))) +metaPlugin' [name, "meta"] (L l (XExpr (HsWrap w (HsPar x (L _ (HsApp noExt (L _ (HsVar _ (L _ id))) e)))))) | occNameString (getOccName id) == name - = return (L l (HsWrap ne w (unLoc e))) + = return (L l (XExpr (HsWrap w (unLoc e)))) -- The test should always match this first case. If the desugaring changes -- again in the future then the panic is more useful than the previous -- inscrutable failure. diff --git a/utils/haddock b/utils/haddock -Subproject f3e3c4a766805a1bbea75bf23b84fdaaf053c22 +Subproject e7a650a94dbc118c423e684b27203a52baf34ff |