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