summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-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
-rw-r--r--compiler/deSugar/Coverage.hs19
-rw-r--r--compiler/deSugar/DsArrows.hs15
-rw-r--r--compiler/deSugar/DsBinds.hs2
-rw-r--r--compiler/deSugar/DsExpr.hs20
-rw-r--r--compiler/deSugar/DsGRHSs.hs7
-rw-r--r--compiler/deSugar/DsMeta.hs7
-rw-r--r--compiler/deSugar/DsMonad.hs2
-rw-r--r--compiler/deSugar/Match.hs26
-rw-r--r--compiler/deSugar/Match.hs-boot9
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/parser/Parser.y2
-rw-r--r--compiler/parser/RdrHsSyn.hs8
-rw-r--r--compiler/typecheck/TcArrows.hs11
-rw-r--r--compiler/typecheck/TcBinds.hs15
-rw-r--r--compiler/typecheck/TcEnv.hs4
-rw-r--r--compiler/typecheck/TcExpr.hs27
-rw-r--r--compiler/typecheck/TcExpr.hs-boot10
-rw-r--r--compiler/typecheck/TcGenFunctor.hs6
-rw-r--r--compiler/typecheck/TcHsSyn.hs42
-rw-r--r--compiler/typecheck/TcInstDcls.hs2
-rw-r--r--compiler/typecheck/TcMatches.hs12
-rw-r--r--compiler/typecheck/TcOrigin.hs5
-rw-r--r--compiler/typecheck/TcPat.hs22
-rw-r--r--compiler/typecheck/TcPatSyn.hs15
46 files changed, 735 insertions, 1157 deletions
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs
index ecd891b52e..999d59ea7a 100644
--- a/compiler/GHC/Hs.hs
+++ b/compiler/GHC/Hs.hs
@@ -12,8 +12,8 @@ therefore, is almost nothing but re-exporting.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data
@@ -28,7 +28,6 @@ module GHC.Hs (
module GHC.Hs.Types,
module GHC.Hs.Utils,
module GHC.Hs.Doc,
- module GHC.Hs.PlaceHolder,
module GHC.Hs.Extension,
Fixity,
@@ -43,7 +42,6 @@ import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.ImpExp
import GHC.Hs.Lit
-import GHC.Hs.PlaceHolder
import GHC.Hs.Extension
import GHC.Hs.Pat
import GHC.Hs.Types
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index adb8604913..1c393bbe99 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -12,11 +12,13 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
module GHC.Hs.Binds where
@@ -219,29 +221,29 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
FunBind {
- fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains
- -- the locally-bound
- -- free variables of this defn.
- -- See Note [Bind free vars]
+ fun_ext :: XFunBind idL idR,
+
+ -- ^ After the renamer (but before the type-checker), this contains the
+ -- locally-bound free variables of this defn. See Note [Bind free vars]
+ --
+ -- After the type-checker, this contains a coercion from the type of
+ -- the MatchGroup to the type of the Id. Example:
+ --
+ -- @
+ -- f :: Int -> forall a. a -> a
+ -- f x y = y
+ -- @
+ --
+ -- Then the MatchGroup will have type (Int -> a' -> a')
+ -- (with a free type variable a'). The coercion will take
+ -- a CoreExpr of this type and convert it to a CoreExpr of
+ -- type Int -> forall a'. a' -> a'
+ -- Notice that the coercion captures the free a'.
fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
- fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
- -- the Id. Example:
- --
- -- @
- -- f :: Int -> forall a. a -> a
- -- f x y = y
- -- @
- --
- -- Then the MatchGroup will have type (Int -> a' -> a')
- -- (with a free type variable a'). The coercion will take
- -- a CoreExpr of this type and convert it to a CoreExpr of
- -- type Int -> forall a'. a' -> a'
- -- Notice that the coercion captures the free a'.
-
fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
}
@@ -320,8 +322,8 @@ data NPatBindTc = NPatBindTc {
} deriving Data
type instance XFunBind (GhcPass pL) GhcPs = NoExtField
-type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
-type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables
+type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
+type instance XFunBind (GhcPass pL) GhcTc = HsWrapper -- See comments on FunBind.fun_ext
type instance XPatBind GhcPs (GhcPass pR) = NoExtField
type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables
@@ -682,19 +684,6 @@ pprDeclList ds = pprDeeperList vcat ds
emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds = EmptyLocalBinds noExtField
--- AZ:These functions do not seem to be used at all?
-isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool
-isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds
-isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds
-isEmptyLocalBindsTc (EmptyLocalBinds _) = True
-isEmptyLocalBindsTc (XHsLocalBindsLR _) = True
-
-isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
-isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds
-isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds
-isEmptyLocalBindsPR (EmptyLocalBinds _) = True
-isEmptyLocalBindsPR (XHsLocalBindsLR _) = True
-
eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
eqEmptyLocalBinds (EmptyLocalBinds _) = True
eqEmptyLocalBinds _ = False
@@ -728,7 +717,8 @@ instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where
ppr mbind = ppr_monobind mbind
-ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
+ppr_monobind :: forall idL idR.
+ (OutputableBndrId idL, OutputableBndrId idR)
=> HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
@@ -736,14 +726,15 @@ ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
= sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
ppr_monobind (FunBind { fun_id = fun,
- fun_co_fn = wrap,
fun_matches = matches,
- fun_tick = ticks })
+ fun_tick = ticks,
+ fun_ext = wrap })
= pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks)
$$ whenPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind matches
- $$ whenPprDebug (ppr wrap)
+ $$ whenPprDebug (pprIfTc @idR $ ppr wrap)
+
ppr_monobind (PatSynBind _ psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
@@ -759,7 +750,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, text "Exported types:" <+>
vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
, text "Binds:" <+> pprLHsBinds val_binds
- , text "Evidence:" <+> ppr ev_binds ]
+ , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) ]
else
pprLHsBinds val_binds
ppr_monobind (XHsBindsLR x) = ppr x
@@ -768,7 +759,7 @@ instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
- , nest 2 (text "wrap:" <+> ppr wrap)]
+ , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]
ppr (XABExport x) = ppr x
instance (OutputableBndrId l, OutputableBndrId r,
@@ -867,7 +858,7 @@ type instance XXIPBind (GhcPass p) = NoExtCon
instance OutputableBndrId p
=> Outputable (HsIPBinds (GhcPass p)) where
ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
- $$ whenPprDebug (ppr ds)
+ $$ whenPprDebug (pprIfTc @p $ ppr ds)
ppr (XHsIPBinds x) = ppr x
instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index aeec0820ed..abfd0ec476 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -8,10 +8,12 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -2022,7 +2024,10 @@ instance OutputableBndrId p
ppr StockStrategy = text "stock"
ppr AnyclassStrategy = text "anyclass"
ppr NewtypeStrategy = text "newtype"
- ppr (ViaStrategy ty) = text "via" <+> ppr ty
+ ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of
+ GhcPs -> ppr ty
+ GhcRn -> ppr ty
+ GhcTc -> ppr ty
-- | A short description of a @DerivStrategy'@.
derivStrategyName :: DerivStrategy a -> SDoc
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index d37c8ed914..f70d5c0382 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -7,13 +7,16 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -28,7 +31,6 @@ import GhcPrelude
import GHC.Hs.Decls
import GHC.Hs.Pat
import GHC.Hs.Lit
-import GHC.Hs.PlaceHolder ( NameOrRdrName )
import GHC.Hs.Extension
import GHC.Hs.Types
import GHC.Hs.Binds
@@ -89,14 +91,57 @@ type PostTcExpr = HsExpr GhcTc
type PostTcTable = [(Name, PostTcExpr)]
-------------------------
+{- Note [NoSyntaxExpr]
+~~~~~~~~~~~~~~~~~~~~~~
+Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc)
+for several reasons:
+
+ 1. As described in Note [Rebindable if]
+
+ 2. In order to suppress "not in scope: xyz" messages when a bit of
+ rebindable syntax does not apply. For example, when using an irrefutable
+ pattern in a BindStmt, we don't need a `fail` operator.
+
+ 3. Rebindable syntax might just not make sense. For example, a BodyStmt
+ contains the syntax for `guard`, but that's used only in monad comprehensions.
+ If we had more of a whiz-bang type system, we might be able to rule this
+ case out statically.
+-}
+
-- | Syntax Expression
--
--- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier,
--- by the renamer. It's used for rebindable syntax.
+-- SyntaxExpr is represents the function used in interpreting rebindable
+-- syntax. In the parser, we have no information to supply; in the renamer,
+-- we have the name of the function (but see
+-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle)
+-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'.
+--
+-- In some contexts, rebindable syntax is not implemented, and so we have
+-- constructors to represent that possibility in both the renamer and
+-- typechecker instantiations.
--
-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
-- @(>>=)@, and then instantiated by the type checker with its type args
-- etc
+type family SyntaxExpr p
+
+-- Defining SyntaxExpr in two stages allows for better type inference, because
+-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,
+-- noSyntaxExpr would be ambiguous.
+type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p
+
+type family SyntaxExprGhc (p :: Pass) = (r :: *) | r -> p where
+ SyntaxExprGhc 'Parsed = NoExtField
+ SyntaxExprGhc 'Renamed = SyntaxExprRn
+ SyntaxExprGhc 'Typechecked = SyntaxExprTc
+
+-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].
+data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)
+ -- Why is the payload not just a Name?
+ -- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr
+ | NoSyntaxExprRn
+
+-- | An expression with wrappers, used for rebindable syntax
--
-- This should desugar to
--
@@ -104,45 +149,43 @@ type PostTcTable = [(Name, PostTcExpr)]
-- > (syn_arg_wraps[1] arg1) ...
--
-- where the actual arguments come from elsewhere in the AST.
--- This could be defined using @GhcPass p@ and such, but it's
--- harder to get it all to work out that way. ('noSyntaxExpr' is hard to
--- write, for example.)
-data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p
- , syn_arg_wraps :: [HsWrapper]
- , syn_res_wrap :: HsWrapper }
+data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc
+ , syn_arg_wraps :: [HsWrapper]
+ , syn_res_wrap :: HsWrapper }
+ | NoSyntaxExprTc -- See Note [NoSyntaxExpr]
-- | This is used for rebindable-syntax pieces that are too polymorphic
-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
noExpr :: HsExpr (GhcPass p)
noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr"))
-noSyntaxExpr :: SyntaxExpr (GhcPass p)
- -- Before renaming, and sometimes after,
- -- (if the syntax slot makes no sense)
-noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField
- (HsString NoSourceText
- (fsLit "noSyntaxExpr"))
- , syn_arg_wraps = []
- , syn_res_wrap = WpHole }
-
--- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers.
-mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p)
-mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr
- , syn_arg_wraps = []
- , syn_res_wrap = WpHole }
-
--- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
--- renamer), missing its HsWrappers.
-mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn
-mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name
- -- don't care about filling in syn_arg_wraps because we're clearly
- -- not past the typechecker
-
-instance OutputableBndrId p
- => Outputable (SyntaxExpr (GhcPass p)) where
- ppr (SyntaxExpr { syn_expr = expr
- , syn_arg_wraps = arg_wraps
- , syn_res_wrap = res_wrap })
+noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)
+ -- Before renaming, and sometimes after
+ -- See Note [NoSyntaxExpr]
+noSyntaxExpr = case ghcPass @p of
+ GhcPs -> noExtField
+ GhcRn -> NoSyntaxExprRn
+ GhcTc -> NoSyntaxExprTc
+
+-- | Make a 'SyntaxExpr GhcRn' from an expression
+-- Used only in getMonadFailOp.
+-- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr
+mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn
+mkSyntaxExpr = SyntaxExprRn
+
+-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the
+-- renamer).
+mkRnSyntaxExpr :: Name -> SyntaxExprRn
+mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLoc name
+
+instance Outputable SyntaxExprRn where
+ ppr (SyntaxExprRn expr) = ppr expr
+ ppr NoSyntaxExprRn = text "<no syntax expr>"
+
+instance Outputable SyntaxExprTc where
+ ppr (SyntaxExprTc { syn_expr = expr
+ , syn_arg_wraps = arg_wraps
+ , syn_res_wrap = res_wrap })
= sdocWithDynFlags $ \ dflags ->
getPprStyle $ \s ->
if debugStyle s || gopt Opt_PrintExplicitCoercions dflags
@@ -150,6 +193,8 @@ instance OutputableBndrId p
<> braces (ppr res_wrap)
else ppr expr
+ ppr NoSyntaxExprTc = text "<no syntax expr>"
+
-- | Command Syntax Table (for Arrow syntax)
type CmdSyntaxTable p = [(Name, HsExpr p)]
-- See Note [CmdSyntaxTable]
@@ -330,10 +375,11 @@ data HsExpr p
-- 'ApiAnnotation.AnnElse',
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsIf (XIf p)
- (Maybe (SyntaxExpr p)) -- cond function
- -- Nothing => use the built-in 'if'
- -- See Note [Rebindable if]
+ | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use
+ -- rebindable syntax
+ (SyntaxExpr p) -- cond function
+ -- NoSyntaxExpr => use the built-in 'if'
+ -- See Note [Rebindable if]
(LHsExpr p) -- predicate
(LHsExpr p) -- then part
(LHsExpr p) -- else part
@@ -364,7 +410,7 @@ data HsExpr p
-- For details on above see note [Api annotations] in ApiAnnotation
| HsDo (XDo p) -- Type of the whole expression
- (HsStmtContext Name) -- The parameterisation is unimportant
+ (HsStmtContext GhcRn) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
(Located [ExprLStmt p]) -- "do":one or more stmts
@@ -506,16 +552,6 @@ data HsExpr p
-- Expressions annotated with pragmas, written as {-# ... #-}
| HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
- ---------------------------------------
- -- Finally, HsWrap appears only in typechecker output
- -- The contained Expr is *NOT* itself an HsWrap.
- -- See Note [Detecting forced eta expansion] in DsExpr. This invariant
- -- is maintained by GHC.Hs.Utils.mkHsWrap.
-
- | HsWrap (XWrap p)
- HsWrapper -- TRANSLATION
- (HsExpr p)
-
| XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor
@@ -532,12 +568,22 @@ data RecordUpdTc = RecordUpdTc
-- _non-empty_ list of DataCons that have
-- all the upd'd fields
- , rupd_in_tys :: [Type] -- Argument types of *input* record type
- , rupd_out_tys :: [Type] -- and *output* record type
- -- The original type can be reconstructed
- -- with conLikeResTy
- , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
- } deriving Data
+ , rupd_in_tys :: [Type] -- Argument types of *input* record type
+ , rupd_out_tys :: [Type] -- and *output* record type
+ -- The original type can be reconstructed
+ -- with conLikeResTy
+ , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
+ }
+
+-- | HsWrap appears only in typechecker output
+-- Invariant: The contained Expr is *NOT* itself an HsWrap.
+-- See Note [Detecting forced eta expansion] in DsExpr. This invariant
+-- is maintained by GHC.Hs.Utils.mkHsWrap.
+-- hs_syn is something like HsExpr or HsCmd
+data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper
+ (hs_syn GhcTc) -- the thing that is wrapped
+
+deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)
-- ---------------------------------------------------------------------
@@ -570,7 +616,10 @@ type instance XExplicitSum GhcRn = NoExtField
type instance XExplicitSum GhcTc = [Type]
type instance XCase (GhcPass _) = NoExtField
-type instance XIf (GhcPass _) = NoExtField
+
+type instance XIf GhcPs = Bool -- True <=> might use rebindable syntax
+type instance XIf GhcRn = NoExtField
+type instance XIf GhcTc = NoExtField
type instance XMultiIf GhcPs = NoExtField
type instance XMultiIf GhcRn = NoExtField
@@ -618,7 +667,10 @@ type instance XBinTick (GhcPass _) = NoExtField
type instance XPragE (GhcPass _) = NoExtField
type instance XWrap (GhcPass _) = NoExtField
-type instance XXExpr (GhcPass _) = NoExtCon
+
+type instance XXExpr GhcPs = NoExtCon
+type instance XXExpr GhcRn = NoExtCon
+type instance XXExpr GhcTc = HsWrap HsExpr
-- ---------------------------------------------------------------------
@@ -732,7 +784,12 @@ Because we allow an 'if' to return *unboxed* results, thus
whereas that would not be possible using a all to a polymorphic function
(because you can't call a polymorphic function at an unboxed type).
-So we use Nothing to mean "use the old built-in typing rule".
+So we use NoSyntaxExpr to mean "use the old built-in typing rule".
+
+A further complication is that, in the `deriving` code, we never want
+to use rebindable syntax. So, even in GhcPs, we want to denote whether
+to use rebindable syntax or not. This is done via the type instance
+for XIf GhcPs.
Note [Record Update HsWrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1002,16 +1059,12 @@ ppr_expr (ExprWithTySig _ expr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
-ppr_expr (HsWrap _ co_fn e)
- = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
- else pprExpr e)
-
ppr_expr (HsSpliceE _ s) = pprSplice s
ppr_expr (HsBracket _ b) = pprHsBracket b
ppr_expr (HsRnBracketOut _ e []) = ppr e
ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e
-ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
+ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
@@ -1034,15 +1087,24 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
ppr exp, text ")"]
ppr_expr (HsRecFld _ f) = ppr f
-ppr_expr (XExpr x) = ppr x
+ppr_expr (XExpr x) = case ghcPass @p of
+ GhcPs -> ppr x
+ GhcRn -> ppr x
+ GhcTc -> case x of
+ HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e
+ else pprExpr e)
+
-ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
+ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c))
ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f)
ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
-ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e
-ppr_infix_expr _ = Nothing
+ppr_infix_expr (XExpr x)
+ | GhcTc <- ghcPass @p
+ , HsWrap _ e <- x
+ = ppr_infix_expr e
+ppr_infix_expr _ = Nothing
ppr_apps :: (OutputableBndrId p)
=> HsExpr (GhcPass p)
@@ -1097,7 +1159,7 @@ pprParendExpr p expr
-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs
-- parentheses under precedence @p@.
-hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool
+hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool
hsExprNeedsParens p = go
where
go (HsVar{}) = False
@@ -1130,7 +1192,6 @@ hsExprNeedsParens p = go
go (ExprWithTySig{}) = p >= sigPrec
go (ArithSeq{}) = False
go (HsPragE{}) = p >= appPrec
- go (HsWrap _ _ e) = go e
go (HsSpliceE{}) = False
go (HsBracket{}) = False
go (HsRnBracketOut{}) = False
@@ -1141,11 +1202,18 @@ hsExprNeedsParens p = go
go (HsBinTick _ _ _ (L _ e)) = go e
go (RecordCon{}) = False
go (HsRecFld{}) = False
- go (XExpr{}) = True
+ go (XExpr x)
+ | GhcTc <- ghcPass @p
+ , HsWrap _ e <- x
+ = go e
+
+ | otherwise
+ = True
+
-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,
-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.
-parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
parenthesizeHsExpr p le@(L loc e)
| hsExprNeedsParens p e = L loc (HsPar noExtField le)
| otherwise = le
@@ -1154,7 +1222,7 @@ stripParensHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
stripParensHsExpr (L _ (HsPar _ e)) = stripParensHsExpr e
stripParensHsExpr e = e
-isAtomicHsExpr :: HsExpr id -> Bool
+isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool
-- True of a single token
isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsConLikeOut {}) = True
@@ -1163,9 +1231,11 @@ isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {}) = True
isAtomicHsExpr (HsOverLabel {}) = True
isAtomicHsExpr (HsUnboundVar {}) = True
-isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e
isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr (HsRecFld{}) = True
+isAtomicHsExpr (XExpr x)
+ | GhcTc <- ghcPass @p
+ , HsWrap _ e <- x = isAtomicHsExpr e
isAtomicHsExpr _ = False
instance Outputable (HsPragE (GhcPass p)) where
@@ -1258,10 +1328,10 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsCmdIf (XCmdIf id)
- (Maybe (SyntaxExpr id)) -- cond function
- (LHsExpr id) -- predicate
- (LHsCmd id) -- then part
- (LHsCmd id) -- else part
+ (SyntaxExpr id) -- cond function
+ (LHsExpr id) -- predicate
+ (LHsCmd id) -- then part
+ (LHsCmd id) -- else part
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',
-- 'ApiAnnotation.AnnSemi',
-- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',
@@ -1287,11 +1357,6 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | HsCmdWrap (XCmdWrap id)
- HsWrapper
- (HsCmd id) -- If cmd :: arg1 --> res
- -- wrap :: arg1 "->" arg2
- -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
| XCmd (XXCmd id) -- Note [Trees that Grow] extension point
type instance XCmdArrApp GhcPs = NoExtField
@@ -1311,7 +1376,13 @@ type instance XCmdDo GhcRn = NoExtField
type instance XCmdDo GhcTc = Type
type instance XCmdWrap (GhcPass _) = NoExtField
-type instance XXCmd (GhcPass _) = NoExtCon
+
+type instance XXCmd GhcPs = NoExtCon
+type instance XXCmd GhcRn = NoExtCon
+type instance XXCmd GhcTc = HsWrap HsCmd
+ -- If cmd :: arg1 --> res
+ -- wrap :: arg1 "->" arg2
+ -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res
-- | Haskell Array Application Type
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
@@ -1403,8 +1474,6 @@ ppr_cmd (HsCmdLet _ (L _ binds) cmd)
ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts
-ppr_cmd (HsCmdWrap _ w cmd)
- = pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
@@ -1429,7 +1498,11 @@ ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2])
ppr_cmd (HsCmdArrForm _ op _ _ args)
= hang (text "(|" <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
-ppr_cmd (XCmd x) = ppr x
+ppr_cmd (XCmd x) = case ghcPass @p of
+ GhcPs -> ppr x
+ GhcRn -> ppr x
+ GhcTc -> case x of
+ HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc
pprCmdArg (HsCmdTop _ cmd)
@@ -1502,7 +1575,7 @@ type LMatch id body = Located (Match id body)
data Match p body
= Match {
m_ext :: XCMatch p body,
- m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)),
+ m_ctxt :: HsMatchContext (NoGhcTc p),
-- See note [m_ctxt in Match]
m_pats :: [LPat p], -- The patterns
m_grhss :: (GRHSs p body)
@@ -1637,7 +1710,7 @@ pprPatBind :: forall bndr p body. (OutputableBndrId bndr,
=> LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprPatBind pat (grhss)
= sep [ppr pat,
- nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]
+ nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]
pprMatch :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
@@ -1678,7 +1751,7 @@ pprMatch match
(pat2:pats2) = pats1
pprGRHSs :: (OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc
+ => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs ctxt (GRHSs _ grhss (L _ binds))
= vcat (map (pprGRHS ctxt . unLoc) grhss)
-- Print the "where" even if the contents of the binds is empty. Only
@@ -1688,7 +1761,7 @@ pprGRHSs ctxt (GRHSs _ grhss (L _ binds))
pprGRHSs _ (XGRHSs x) = ppr x
pprGRHS :: (OutputableBndrId idR, Outputable body)
- => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc
+ => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc
pprGRHS ctxt (GRHS _ [] body)
= pp_rhs ctxt body
@@ -1697,7 +1770,7 @@ pprGRHS ctxt (GRHS _ guards body)
pprGRHS _ (XGRHS x) = ppr x
-pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc
+pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
{-
@@ -1774,6 +1847,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
(SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
+ -- See Note [NoSyntaxExpr] (2)
-- | 'ApplicativeStmt' represents an applicative expression built with
-- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the
@@ -1947,6 +2021,7 @@ data ApplicativeArg idL
-- match fails.
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
+ -- See Note [NoSyntaxExpr] (2)
}
| ApplicativeArgMany -- do { stmts; return vars }
{ xarg_app_arg_many :: (XApplicativeArgMany idL)
@@ -2601,8 +2676,8 @@ pp_dotdot = text " .. "
--
-- Context of a pattern match. This is more subtle than it would seem. See Note
-- [Varieties of pattern matches].
-data HsMatchContext id -- Not an extensible tag
- = FunRhs { mc_fun :: Located id -- ^ function binder of @f@
+data HsMatchContext p
+ = FunRhs { mc_fun :: LIdP p -- ^ function binder of @f@
, mc_fixity :: LexicalFixity -- ^ fixing of @f@
, mc_strictness :: SrcStrictness -- ^ was @f@ banged?
-- See Note [FunBind vs PatBind]
@@ -2622,16 +2697,16 @@ data HsMatchContext id -- Not an extensible tag
-- tell matchWrapper what sort of
-- runtime error message to generate]
- | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension,
+ | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension,
-- pattern guard, etc
| ThPatSplice -- ^A Template Haskell pattern splice
| ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |]
| PatSyn -- ^A pattern synonym declaration
- deriving Functor
-deriving instance (Data id) => Data (HsMatchContext id)
+deriving instance Data (HsMatchContext GhcPs)
+deriving instance Data (HsMatchContext GhcRn)
-instance OutputableBndr id => Outputable (HsMatchContext id) where
+instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
ppr LambdaExpr = text "LambdaExpr"
ppr CaseAlt = text "CaseAlt"
@@ -2645,15 +2720,14 @@ instance OutputableBndr id => Outputable (HsMatchContext id) where
ppr ThPatQuote = text "ThPatQuote"
ppr PatSyn = text "PatSyn"
-isPatSynCtxt :: HsMatchContext id -> Bool
+isPatSynCtxt :: HsMatchContext p -> Bool
isPatSynCtxt ctxt =
case ctxt of
PatSyn -> True
_ -> False
--- | Haskell Statement Context. It expects to be parameterised with one of
--- 'RdrName', 'Name' or 'Id'
-data HsStmtContext id
+-- | Haskell Statement Context.
+data HsStmtContext p
= ListComp
| MonadComp
@@ -2662,11 +2736,11 @@ data HsStmtContext id
| ArrowExpr -- ^do-notation in an arrow-command context
| GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs
- | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing
- | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt
- | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt
- deriving Functor
-deriving instance (Data id) => Data (HsStmtContext id)
+ | PatGuard (HsMatchContext p) -- ^Pattern guard for specified thing
+ | ParStmtCtxt (HsStmtContext p) -- ^A branch of a parallel stmt
+ | TransStmtCtxt (HsStmtContext p) -- ^A branch of a transform stmt
+deriving instance Data (HsStmtContext GhcPs)
+deriving instance Data (HsStmtContext GhcRn)
isComprehensionContext :: HsStmtContext id -> Bool
-- Uses comprehension syntax [ e | quals ]
@@ -2691,7 +2765,7 @@ isMonadCompContext :: HsStmtContext id -> Bool
isMonadCompContext MonadComp = True
isMonadCompContext _ = False
-matchSeparator :: HsMatchContext id -> SDoc
+matchSeparator :: HsMatchContext p -> SDoc
matchSeparator (FunRhs {}) = text "="
matchSeparator CaseAlt = text "->"
matchSeparator IfAlt = text "->"
@@ -2706,8 +2780,8 @@ matchSeparator ThPatSplice = panic "unused"
matchSeparator ThPatQuote = panic "unused"
matchSeparator PatSyn = panic "unused"
-pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id)
- => HsMatchContext id -> SDoc
+pprMatchContext :: Outputable (IdP p)
+ => HsMatchContext p -> SDoc
pprMatchContext ctxt
| want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
| otherwise = text "a" <+> pprMatchContextNoun ctxt
@@ -2716,7 +2790,7 @@ pprMatchContext ctxt
want_an ProcExpr = True
want_an _ = False
-pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)
+pprMatchContextNoun :: Outputable (IdP id)
=> HsMatchContext id -> SDoc
pprMatchContextNoun (FunRhs {mc_fun=L _ fun})
= text "equation for"
@@ -2735,8 +2809,7 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
-----------------
-pprAStmtContext, pprStmtContext :: (Outputable id,
- Outputable (NameOrRdrName id))
+pprAStmtContext, pprStmtContext :: Outputable (IdP id)
=> HsStmtContext id -> SDoc
pprAStmtContext ctxt = article <+> pprStmtContext ctxt
where
@@ -2769,13 +2842,13 @@ pprStmtContext (TransStmtCtxt c) =
ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])
(pprStmtContext c)
-instance (Outputable (GhcPass p), Outputable (NameOrRdrName (GhcPass p)))
+instance OutputableBndrId p
=> Outputable (HsStmtContext (GhcPass p)) where
ppr = pprStmtContext
-- Used to generate the string for a *runtime* error message
-matchContextErrString :: Outputable id
- => HsMatchContext id -> SDoc
+matchContextErrString :: OutputableBndrId p
+ => HsMatchContext (GhcPass p) -> SDoc
matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString IfAlt = text "multi-way if"
@@ -2797,10 +2870,7 @@ matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block"
matchContextErrString (StmtCtxt ListComp) = text "list comprehension"
matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension"
-pprMatchInCtxt :: (OutputableBndrId idR,
- -- TODO:AZ these constraints do not make sense
- Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),
- Outputable body)
+pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
<> colon)
@@ -2809,7 +2879,7 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
pprStmtInCtxt :: (OutputableBndrId idL,
OutputableBndrId idR,
Outputable body)
- => HsStmtContext (IdP (GhcPass idL))
+ => HsStmtContext (GhcPass idL)
-> StmtLR (GhcPass idL) (GhcPass idR) body
-> SDoc
pprStmtInCtxt ctxt (LastStmt _ e _ _)
diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot
index 03029d1d05..7ea4633760 100644
--- a/compiler/GHC/Hs/Expr.hs-boot
+++ b/compiler/GHC/Hs/Expr.hs-boot
@@ -1,8 +1,8 @@
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
@@ -21,13 +21,12 @@ type role HsCmd nominal
type role MatchGroup nominal nominal
type role GRHSs nominal nominal
type role HsSplice nominal
-type role SyntaxExpr nominal
data HsExpr (i :: *)
data HsCmd (i :: *)
data HsSplice (i :: *)
data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
-data SyntaxExpr (i :: *)
+type family SyntaxExpr (i :: *)
instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))
instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index be0333933a..ee82e4a0f9 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -11,8 +11,14 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
+{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc]
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE AllowAmbiguousTypes #-} -- for pprIfTc, etc.
module GHC.Hs.Extension where
@@ -22,7 +28,6 @@ module GHC.Hs.Extension where
import GhcPrelude
import Data.Data hiding ( Fixity )
-import GHC.Hs.PlaceHolder
import Name
import RdrName
import Var
@@ -54,6 +59,74 @@ additional information for the tool, in a natural way.
A further goal is to provide a means to harmonise the Template Haskell and
haskell-src-exts ASTs as well.
+Wrinkle: In order to print out the AST, we need to know it is Outputable.
+We also sometimes need to branch on the particular pass that we're in
+(e.g. to print out type information once we know it). In order to allow
+both of these actions, we define OutputableBndrId, which gathers the necessary
+OutputableBndr and IsPass constraints. The use of this constraint in instances
+generally requires UndecidableInstances.
+
+See also Note [IsPass] and Note [NoGhcTc].
+
+Note [IsPass]
+~~~~~~~~~~~~~
+One challenge with the Trees That Grow approach
+is that we sometimes have different information in different passes.
+For example, we have
+
+ type instance XViaStrategy GhcPs = LHsSigType GhcPs
+ type instance XViaStrategy GhcRn = LHsSigType GhcRn
+ type instance XViaStrategy GhcTc = Type
+
+This means that printing a DerivStrategy (which contains an XViaStrategy)
+might need to print a LHsSigType, or it might need to print a type. Yet we
+want one Outputable instance for a DerivStrategy, instead of one per pass. We
+could have a large constraint, including e.g. (Outputable (XViaStrategy p),
+Outputable (XViaStrategy GhcTc)), and pass that around in every context where
+we might output a DerivStrategy. But a simpler alternative is to pass a
+witness to whichever pass we're in. When we pattern-match on that (GADT)
+witness, we learn the pass identity and can then print away. To wit, we get
+the definition of GhcPass and the functions isPass. These allow us to do away
+with big constraints, passing around all manner of dictionaries we might or
+might not use. It does mean that we have to manually use isPass when printing,
+but these places are few.
+
+See Note [NoGhcTc] about the superclass constraint to IsPass.
+
+Note [NoGhcTc]
+~~~~~~~~~~~~~~
+An expression is parsed into HsExpr GhcPs, renamed into HsExpr GhcRn, and
+then type-checked into HsExpr GhcTc. Not so for types! These get parsed
+into HsType GhcPs, renamed into HsType GhcRn, and then type-checked into
+Type. We never build an HsType GhcTc. Why do this? Because we need to be
+able to compare type-checked types for equality, and we don't want to do
+this with HsType.
+
+This causes wrinkles within the AST, where we normally thing that the whole
+AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we
+have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that
+user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc.
+
+For example, this is used in ExprWithTySig:
+ | ExprWithTySig
+ (XExprWithTySig p)
+
+ (LHsExpr p)
+ (LHsSigWcType (NoGhcTc p))
+
+If we have (e :: ty), we still want to be able to print that (with the :: ty)
+after type-checking. So we retain the LHsSigWcType GhcRn, even in an
+HsExpr GhcTc. That's what NoGhcTc does.
+
+When we're printing the type annotation, we need to know
+(Outputable (LHsSigWcType GhcRn)), even though we've assumed only that
+(OutputableBndrId GhcTc). We thus must be able to prove OutputableBndrId (NoGhcTc p)
+from OutputableBndrId p. The extra constraints in OutputableBndrId and
+the superclass constraints of IsPass allow this. Note that the superclass
+constraint of IsPass is *recursive*: it asserts that IsPass (NoGhcTcPass p) holds.
+For this to make sense, we need -XUndecidableSuperClasses and the other constraint,
+saying that NoGhcTcPass is idempotent.
+
-}
-- | A placeholder type for TTG extension points that are not currently
@@ -93,6 +166,12 @@ instance Outputable NoExtCon where
noExtCon :: NoExtCon -> a
noExtCon x = case x of {}
+-- | GHC's L prefixed variants wrap their vanilla variant in this type family,
+-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not
+-- interested in location information can define this instance as @f p@.
+type family XRec p (f :: * -> *) = r | r -> p f
+type instance XRec (GhcPass p) f = Located (f (GhcPass p))
+
{-
Note [NoExtCon and strict fields]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -130,10 +209,19 @@ the strict field changes described above and delete gobs of code involving
code that consumes unused extension constructors.
-}
--- | Used as a data type index for the hsSyn AST
-data GhcPass (c :: Pass)
-deriving instance Eq (GhcPass c)
-deriving instance Typeable c => Data (GhcPass c)
+-- | Used as a data type index for the hsSyn AST; also serves
+-- as a singleton type for Pass
+data GhcPass (c :: Pass) where
+ GhcPs :: GhcPs
+ GhcRn :: GhcRn
+ GhcTc :: GhcTc
+
+-- This really should never be entered, but the data-deriving machinery
+-- needs the instance to exist.
+instance Typeable p => Data (GhcPass p) where
+ gunfold _ _ _ = panic "instance Data GhcPass"
+ toConstr _ = panic "instance Data GhcPass"
+ dataTypeOf _ = panic "instance Data GhcPass"
data Pass = Parsed | Renamed | Typechecked
deriving (Data)
@@ -144,23 +232,43 @@ type GhcRn = GhcPass 'Renamed -- Old 'Name' type param
type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para,
type GhcTcId = GhcTc -- Old 'TcId' type param
--- | GHC's L prefixed variants wrap their vanilla variant in this type family,
--- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not
--- interested in location information can define this instance as @f p@.
-type family XRec p (f :: * -> *) = r | r -> p f
-type instance XRec (GhcPass p) f = Located (f (GhcPass p))
+-- | Allows us to check what phase we're in at GHC's runtime.
+-- For example, this class allows us to write
+-- > f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah
+-- > f e = case ghcPass @p of
+-- > GhcPs -> ... in this RHS we have HsExpr GhcPs...
+-- > GhcRn -> ... in this RHS we have HsExpr GhcRn...
+-- > GhcTc -> ... in this RHS we have HsExpr GhcTc...
+-- which is very useful, for example, when pretty-printing.
+-- See Note [IsPass].
+class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p
+ , IsPass (NoGhcTcPass p)
+ ) => IsPass p where
+ ghcPass :: GhcPass p
+
+instance IsPass 'Parsed where
+ ghcPass = GhcPs
+instance IsPass 'Renamed where
+ ghcPass = GhcRn
+instance IsPass 'Typechecked where
+ ghcPass = GhcTc
-- | Maps the "normal" id type for a given pass
type family IdP p
-type instance IdP GhcPs = RdrName
-type instance IdP GhcRn = Name
-type instance IdP GhcTc = Id
+type instance IdP (GhcPass p) = IdGhcP p
+
+-- | Maps the "normal" id type for a given GHC pass
+type family IdGhcP pass where
+ IdGhcP 'Parsed = RdrName
+ IdGhcP 'Renamed = Name
+ IdGhcP 'Typechecked = Id
type LIdP p = Located (IdP p)
-- | Marks that a field uses the GhcRn variant even when the pass
-- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because
-- HsType GhcTc should never occur.
+-- See Note [NoGhcTc]
type family NoGhcTc (p :: Type) where
-- this way, GHC can figure out that the result is a GhcPass
NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)
@@ -179,23 +287,10 @@ type family XHsIPBinds x x'
type family XEmptyLocalBinds x x'
type family XXHsLocalBindsLR x x'
-type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
- ( c (XHsValBinds x x')
- , c (XHsIPBinds x x')
- , c (XEmptyLocalBinds x x')
- , c (XXHsLocalBindsLR x x')
- )
-
-- ValBindsLR type families
type family XValBinds x x'
type family XXValBindsLR x x'
-type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
- ( c (XValBinds x x')
- , c (XXValBindsLR x x')
- )
-
-
-- HsBindsLR type families
type family XFunBind x x'
type family XPatBind x x'
@@ -204,51 +299,22 @@ type family XAbsBinds x x'
type family XPatSynBind x x'
type family XXHsBindsLR x x'
-type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =
- ( c (XFunBind x x')
- , c (XPatBind x x')
- , c (XVarBind x x')
- , c (XAbsBinds x x')
- , c (XPatSynBind x x')
- , c (XXHsBindsLR x x')
- )
-
-- ABExport type families
type family XABE x
type family XXABExport x
-type ForallXABExport (c :: * -> Constraint) (x :: *) =
- ( c (XABE x)
- , c (XXABExport x)
- )
-
-- PatSynBind type families
type family XPSB x x'
type family XXPatSynBind x x'
-type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) =
- ( c (XPSB x x')
- , c (XXPatSynBind x x')
- )
-
-- HsIPBinds type families
type family XIPBinds x
type family XXHsIPBinds x
-type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) =
- ( c (XIPBinds x)
- , c (XXHsIPBinds x)
- )
-
-- IPBind type families
type family XCIPBind x
type family XXIPBind x
-type ForallXIPBind (c :: * -> Constraint) (x :: *) =
- ( c (XCIPBind x)
- , c (XXIPBind x)
- )
-
-- Sig type families
type family XTypeSig x
type family XPatSynSig x
@@ -263,30 +329,10 @@ type family XSCCFunSig x
type family XCompleteMatchSig x
type family XXSig x
-type ForallXSig (c :: * -> Constraint) (x :: *) =
- ( c (XTypeSig x)
- , c (XPatSynSig x)
- , c (XClassOpSig x)
- , c (XIdSig x)
- , c (XFixSig x)
- , c (XInlineSig x)
- , c (XSpecSig x)
- , c (XSpecInstSig x)
- , c (XMinimalSig x)
- , c (XSCCFunSig x)
- , c (XCompleteMatchSig x)
- , c (XXSig x)
- )
-
-- FixitySig type families
type family XFixitySig x
type family XXFixitySig x
-type ForallXFixitySig (c :: * -> Constraint) (x :: *) =
- ( c (XFixitySig x)
- , c (XXFixitySig x)
- )
-
-- StandaloneKindSig type families
type family XStandaloneKindSig x
type family XXStandaloneKindSig x
@@ -311,44 +357,16 @@ type family XDocD x
type family XRoleAnnotD x
type family XXHsDecl x
-type ForallXHsDecl (c :: * -> Constraint) (x :: *) =
- ( c (XTyClD x)
- , c (XInstD x)
- , c (XDerivD x)
- , c (XValD x)
- , c (XSigD x)
- , c (XKindSigD x)
- , c (XDefD x)
- , c (XForD x)
- , c (XWarningD x)
- , c (XAnnD x)
- , c (XRuleD x)
- , c (XSpliceD x)
- , c (XDocD x)
- , c (XRoleAnnotD x)
- , c (XXHsDecl x)
- )
-
-- -------------------------------------
-- HsGroup type families
type family XCHsGroup x
type family XXHsGroup x
-type ForallXHsGroup (c :: * -> Constraint) (x :: *) =
- ( c (XCHsGroup x)
- , c (XXHsGroup x)
- )
-
-- -------------------------------------
-- SpliceDecl type families
type family XSpliceDecl x
type family XXSpliceDecl x
-type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) =
- ( c (XSpliceDecl x)
- , c (XXSpliceDecl x)
- )
-
-- -------------------------------------
-- TyClDecl type families
type family XFamDecl x
@@ -357,24 +375,11 @@ type family XDataDecl x
type family XClassDecl x
type family XXTyClDecl x
-type ForallXTyClDecl (c :: * -> Constraint) (x :: *) =
- ( c (XFamDecl x)
- , c (XSynDecl x)
- , c (XDataDecl x)
- , c (XClassDecl x)
- , c (XXTyClDecl x)
- )
-
-- -------------------------------------
-- TyClGroup type families
type family XCTyClGroup x
type family XXTyClGroup x
-type ForallXTyClGroup (c :: * -> Constraint) (x :: *) =
- ( c (XCTyClGroup x)
- , c (XXTyClGroup x)
- )
-
-- -------------------------------------
-- FamilyResultSig type families
type family XNoSig x
@@ -382,75 +387,37 @@ type family XCKindSig x -- Clashes with XKindSig above
type family XTyVarSig x
type family XXFamilyResultSig x
-type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) =
- ( c (XNoSig x)
- , c (XCKindSig x)
- , c (XTyVarSig x)
- , c (XXFamilyResultSig x)
- )
-
-- -------------------------------------
-- FamilyDecl type families
type family XCFamilyDecl x
type family XXFamilyDecl x
-type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) =
- ( c (XCFamilyDecl x)
- , c (XXFamilyDecl x)
- )
-
-- -------------------------------------
-- HsDataDefn type families
type family XCHsDataDefn x
type family XXHsDataDefn x
-type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) =
- ( c (XCHsDataDefn x)
- , c (XXHsDataDefn x)
- )
-
-- -------------------------------------
-- HsDerivingClause type families
type family XCHsDerivingClause x
type family XXHsDerivingClause x
-type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) =
- ( c (XCHsDerivingClause x)
- , c (XXHsDerivingClause x)
- )
-
-- -------------------------------------
-- ConDecl type families
type family XConDeclGADT x
type family XConDeclH98 x
type family XXConDecl x
-type ForallXConDecl (c :: * -> Constraint) (x :: *) =
- ( c (XConDeclGADT x)
- , c (XConDeclH98 x)
- , c (XXConDecl x)
- )
-
-- -------------------------------------
-- FamEqn type families
type family XCFamEqn x r
type family XXFamEqn x r
-type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) =
- ( c (XCFamEqn x r)
- , c (XXFamEqn x r)
- )
-
-- -------------------------------------
-- ClsInstDecl type families
type family XCClsInstDecl x
type family XXClsInstDecl x
-type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) =
- ( c (XCClsInstDecl x)
- , c (XXClsInstDecl x)
- )
-
-- -------------------------------------
-- ClsInstDecl type families
type family XClsInstD x
@@ -458,23 +425,11 @@ type family XDataFamInstD x
type family XTyFamInstD x
type family XXInstDecl x
-type ForallXInstDecl (c :: * -> Constraint) (x :: *) =
- ( c (XClsInstD x)
- , c (XDataFamInstD x)
- , c (XTyFamInstD x)
- , c (XXInstDecl x)
- )
-
-- -------------------------------------
-- DerivDecl type families
type family XCDerivDecl x
type family XXDerivDecl x
-type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =
- ( c (XCDerivDecl x)
- , c (XXDerivDecl x)
- )
-
-- -------------------------------------
-- DerivStrategy type family
type family XViaStrategy x
@@ -484,96 +439,48 @@ type family XViaStrategy x
type family XCDefaultDecl x
type family XXDefaultDecl x
-type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) =
- ( c (XCDefaultDecl x)
- , c (XXDefaultDecl x)
- )
-
-- -------------------------------------
-- DefaultDecl type families
type family XForeignImport x
type family XForeignExport x
type family XXForeignDecl x
-type ForallXForeignDecl (c :: * -> Constraint) (x :: *) =
- ( c (XForeignImport x)
- , c (XForeignExport x)
- , c (XXForeignDecl x)
- )
-
-- -------------------------------------
-- RuleDecls type families
type family XCRuleDecls x
type family XXRuleDecls x
-type ForallXRuleDecls (c :: * -> Constraint) (x :: *) =
- ( c (XCRuleDecls x)
- , c (XXRuleDecls x)
- )
-
-
-- -------------------------------------
-- RuleDecl type families
type family XHsRule x
type family XXRuleDecl x
-type ForallXRuleDecl (c :: * -> Constraint) (x :: *) =
- ( c (XHsRule x)
- , c (XXRuleDecl x)
- )
-
-- -------------------------------------
-- RuleBndr type families
type family XCRuleBndr x
type family XRuleBndrSig x
type family XXRuleBndr x
-type ForallXRuleBndr (c :: * -> Constraint) (x :: *) =
- ( c (XCRuleBndr x)
- , c (XRuleBndrSig x)
- , c (XXRuleBndr x)
- )
-
-- -------------------------------------
-- WarnDecls type families
type family XWarnings x
type family XXWarnDecls x
-type ForallXWarnDecls (c :: * -> Constraint) (x :: *) =
- ( c (XWarnings x)
- , c (XXWarnDecls x)
- )
-
-- -------------------------------------
-- AnnDecl type families
type family XWarning x
type family XXWarnDecl x
-type ForallXWarnDecl (c :: * -> Constraint) (x :: *) =
- ( c (XWarning x)
- , c (XXWarnDecl x)
- )
-
-- -------------------------------------
-- AnnDecl type families
type family XHsAnnotation x
type family XXAnnDecl x
-type ForallXAnnDecl (c :: * -> Constraint) (x :: *) =
- ( c (XHsAnnotation x)
- , c (XXAnnDecl x)
- )
-
-- -------------------------------------
-- RoleAnnotDecl type families
type family XCRoleAnnotDecl x
type family XXRoleAnnotDecl x
-type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) =
- ( c (XCRoleAnnotDecl x)
- , c (XXRoleAnnotDecl x)
- )
-
-- =====================================================================
-- Type families for the HsExpr extension points
@@ -622,75 +529,18 @@ type family XSCC x
type family XCoreAnn x
type family XTickPragma x
type family XXPragE x
-
-type ForallXExpr (c :: * -> Constraint) (x :: *) =
- ( c (XVar x)
- , c (XUnboundVar x)
- , c (XConLikeOut x)
- , c (XRecFld x)
- , c (XOverLabel x)
- , c (XIPVar x)
- , c (XOverLitE x)
- , c (XLitE x)
- , c (XLam x)
- , c (XLamCase x)
- , c (XApp x)
- , c (XAppTypeE x)
- , c (XOpApp x)
- , c (XNegApp x)
- , c (XPar x)
- , c (XSectionL x)
- , c (XSectionR x)
- , c (XExplicitTuple x)
- , c (XExplicitSum x)
- , c (XCase x)
- , c (XIf x)
- , c (XMultiIf x)
- , c (XLet x)
- , c (XDo x)
- , c (XExplicitList x)
- , c (XRecordCon x)
- , c (XRecordUpd x)
- , c (XExprWithTySig x)
- , c (XArithSeq x)
- , c (XSCC x)
- , c (XCoreAnn x)
- , c (XBracket x)
- , c (XRnBracketOut x)
- , c (XTcBracketOut x)
- , c (XSpliceE x)
- , c (XProc x)
- , c (XStatic x)
- , c (XTick x)
- , c (XBinTick x)
- , c (XTickPragma x)
- , c (XWrap x)
- , c (XXExpr x)
- )
-- ---------------------------------------------------------------------
type family XUnambiguous x
type family XAmbiguous x
type family XXAmbiguousFieldOcc x
-type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
- ( c (XUnambiguous x)
- , c (XAmbiguous x)
- , c (XXAmbiguousFieldOcc x)
- )
-
-- ----------------------------------------------------------------------
type family XPresent x
type family XMissing x
type family XXTupArg x
-type ForallXTupArg (c :: * -> Constraint) (x :: *) =
- ( c (XPresent x)
- , c (XMissing x)
- , c (XXTupArg x)
- )
-
-- ---------------------------------------------------------------------
type family XTypedSplice x
@@ -699,14 +549,6 @@ type family XQuasiQuote x
type family XSpliced x
type family XXSplice x
-type ForallXSplice (c :: * -> Constraint) (x :: *) =
- ( c (XTypedSplice x)
- , c (XUntypedSplice x)
- , c (XQuasiQuote x)
- , c (XSpliced x)
- , c (XXSplice x)
- )
-
-- ---------------------------------------------------------------------
type family XExpBr x
@@ -718,67 +560,31 @@ type family XVarBr x
type family XTExpBr x
type family XXBracket x
-type ForallXBracket (c :: * -> Constraint) (x :: *) =
- ( c (XExpBr x)
- , c (XPatBr x)
- , c (XDecBrL x)
- , c (XDecBrG x)
- , c (XTypBr x)
- , c (XVarBr x)
- , c (XTExpBr x)
- , c (XXBracket x)
- )
-
-- ---------------------------------------------------------------------
type family XCmdTop x
type family XXCmdTop x
-type ForallXCmdTop (c :: * -> Constraint) (x :: *) =
- ( c (XCmdTop x)
- , c (XXCmdTop x)
- )
-
-- -------------------------------------
type family XMG x b
type family XXMatchGroup x b
-type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) =
- ( c (XMG x b)
- , c (XXMatchGroup x b)
- )
-
-- -------------------------------------
type family XCMatch x b
type family XXMatch x b
-type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) =
- ( c (XCMatch x b)
- , c (XXMatch x b)
- )
-
-- -------------------------------------
type family XCGRHSs x b
type family XXGRHSs x b
-type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) =
- ( c (XCGRHSs x b)
- , c (XXGRHSs x b)
- )
-
-- -------------------------------------
type family XCGRHS x b
type family XXGRHS x b
-type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) =
- ( c (XCGRHS x b)
- , c (XXGRHS x b)
- )
-
-- -------------------------------------
type family XLastStmt x x' b
@@ -791,18 +597,6 @@ type family XTransStmt x x' b
type family XRecStmt x x' b
type family XXStmtLR x x' b
-type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) =
- ( c (XLastStmt x x' b)
- , c (XBindStmt x x' b)
- , c (XApplicativeStmt x x' b)
- , c (XBodyStmt x x' b)
- , c (XLetStmt x x' b)
- , c (XParStmt x x' b)
- , c (XTransStmt x x' b)
- , c (XRecStmt x x' b)
- , c (XXStmtLR x x' b)
- )
-
-- ---------------------------------------------------------------------
type family XCmdArrApp x
@@ -817,42 +611,17 @@ type family XCmdDo x
type family XCmdWrap x
type family XXCmd x
-type ForallXCmd (c :: * -> Constraint) (x :: *) =
- ( c (XCmdArrApp x)
- , c (XCmdArrForm x)
- , c (XCmdApp x)
- , c (XCmdLam x)
- , c (XCmdPar x)
- , c (XCmdCase x)
- , c (XCmdIf x)
- , c (XCmdLet x)
- , c (XCmdDo x)
- , c (XCmdWrap x)
- , c (XXCmd x)
- )
-
-- ---------------------------------------------------------------------
type family XParStmtBlock x x'
type family XXParStmtBlock x x'
-type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =
- ( c (XParStmtBlock x x')
- , c (XXParStmtBlock x x')
- )
-
-- ---------------------------------------------------------------------
type family XApplicativeArgOne x
type family XApplicativeArgMany x
type family XXApplicativeArg x
-type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) =
- ( c (XApplicativeArgOne x)
- , c (XApplicativeArgMany x)
- , c (XXApplicativeArg x)
- )
-
-- =====================================================================
-- Type families for the HsImpExp extension points
@@ -878,33 +647,9 @@ type family XHsFloatPrim x
type family XHsDoublePrim x
type family XXLit x
--- | Helper to apply a constraint to all extension points. It has one
--- entry per extension point type family.
-type ForallXHsLit (c :: * -> Constraint) (x :: *) =
- ( c (XHsChar x)
- , c (XHsCharPrim x)
- , c (XHsDoublePrim x)
- , c (XHsFloatPrim x)
- , c (XHsInt x)
- , c (XHsInt64Prim x)
- , c (XHsIntPrim x)
- , c (XHsInteger x)
- , c (XHsRat x)
- , c (XHsString x)
- , c (XHsStringPrim x)
- , c (XHsWord64Prim x)
- , c (XHsWordPrim x)
- , c (XXLit x)
- )
-
type family XOverLit x
type family XXOverLit x
-type ForallXOverLit (c :: * -> Constraint) (x :: *) =
- ( c (XOverLit x)
- , c (XXOverLit x)
- )
-
-- =====================================================================
-- Type families for the HsPat extension points
@@ -927,58 +672,22 @@ type family XSigPat x
type family XCoPat x
type family XXPat x
-
-type ForallXPat (c :: * -> Constraint) (x :: *) =
- ( c (XWildPat x)
- , c (XVarPat x)
- , c (XLazyPat x)
- , c (XAsPat x)
- , c (XParPat x)
- , c (XBangPat x)
- , c (XListPat x)
- , c (XTuplePat x)
- , c (XSumPat x)
- , c (XViewPat x)
- , c (XSplicePat x)
- , c (XLitPat x)
- , c (XNPat x)
- , c (XNPlusKPat x)
- , c (XSigPat x)
- , c (XCoPat x)
- , c (XXPat x)
- )
-
-- =====================================================================
-- Type families for the HsTypes type families
type family XHsQTvs x
type family XXLHsQTyVars x
-type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) =
- ( c (XHsQTvs x)
- , c (XXLHsQTyVars x)
- )
-
-- -------------------------------------
type family XHsIB x b
type family XXHsImplicitBndrs x b
-type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) =
- ( c (XHsIB x b)
- , c (XXHsImplicitBndrs x b)
- )
-
-- -------------------------------------
type family XHsWC x b
type family XXHsWildCardBndrs x b
-type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) =
- ( c (XHsWC x b)
- , c (XXHsWildCardBndrs x b)
- )
-
-- -------------------------------------
type family XForAllTy x
@@ -1005,78 +714,28 @@ type family XTyLit x
type family XWildCardTy x
type family XXType x
--- | Helper to apply a constraint to all extension points. It has one
--- entry per extension point type family.
-type ForallXType (c :: * -> Constraint) (x :: *) =
- ( c (XForAllTy x)
- , c (XQualTy x)
- , c (XTyVar x)
- , c (XAppTy x)
- , c (XAppKindTy x)
- , c (XFunTy x)
- , c (XListTy x)
- , c (XTupleTy x)
- , c (XSumTy x)
- , c (XOpTy x)
- , c (XParTy x)
- , c (XIParamTy x)
- , c (XStarTy x)
- , c (XKindSig x)
- , c (XSpliceTy x)
- , c (XDocTy x)
- , c (XBangTy x)
- , c (XRecTy x)
- , c (XExplicitListTy x)
- , c (XExplicitTupleTy x)
- , c (XTyLit x)
- , c (XWildCardTy x)
- , c (XXType x)
- )
-
-- ---------------------------------------------------------------------
type family XUserTyVar x
type family XKindedTyVar x
type family XXTyVarBndr x
-type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =
- ( c (XUserTyVar x)
- , c (XKindedTyVar x)
- , c (XXTyVarBndr x)
- )
-
-- ---------------------------------------------------------------------
type family XConDeclField x
type family XXConDeclField x
-type ForallXConDeclField (c :: * -> Constraint) (x :: *) =
- ( c (XConDeclField x)
- , c (XXConDeclField x)
- )
-
-- ---------------------------------------------------------------------
type family XCFieldOcc x
type family XXFieldOcc x
-type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =
- ( c (XCFieldOcc x)
- , c (XXFieldOcc x)
- )
-
-
-- =====================================================================
-- Type families for the HsImpExp type families
type family XCImportDecl x
type family XXImportDecl x
-type ForallXImportDecl (c :: * -> Constraint) (x :: *) =
- ( c (XCImportDecl x)
- , c (XXImportDecl x)
- )
-
-- -------------------------------------
type family XIEVar x
@@ -1089,18 +748,6 @@ type family XIEDoc x
type family XIEDocNamed x
type family XXIE x
-type ForallXIE (c :: * -> Constraint) (x :: *) =
- ( c (XIEVar x)
- , c (XIEThingAbs x)
- , c (XIEThingAll x)
- , c (XIEThingWith x)
- , c (XIEModuleContents x)
- , c (XIEGroup x)
- , c (XIEDoc x)
- , c (XIEDocNamed x)
- , c (XXIE x)
- )
-
-- -------------------------------------
@@ -1108,77 +755,23 @@ type ForallXIE (c :: * -> Constraint) (x :: *) =
-- End of Type family definitions
-- =====================================================================
--- ----------------------------------------------------------------------
--- | Conversion of annotations from one type index to another. This is required
--- where the AST is converted from one pass to another, and the extension values
--- need to be brought along if possible. So for example a 'SourceText' is
--- converted via 'id', but needs a type signature to keep the type checker
--- happy.
-class Convertable a b | a -> b where
- convert :: a -> b
-
-instance Convertable a a where
- convert = id
-
--- | A constraint capturing all the extension points that can be converted via
--- @instance Convertable a a@
-type ConvertIdX a b =
- (XHsDoublePrim a ~ XHsDoublePrim b,
- XHsFloatPrim a ~ XHsFloatPrim b,
- XHsRat a ~ XHsRat b,
- XHsInteger a ~ XHsInteger b,
- XHsWord64Prim a ~ XHsWord64Prim b,
- XHsInt64Prim a ~ XHsInt64Prim b,
- XHsWordPrim a ~ XHsWordPrim b,
- XHsIntPrim a ~ XHsIntPrim b,
- XHsInt a ~ XHsInt b,
- XHsStringPrim a ~ XHsStringPrim b,
- XHsString a ~ XHsString b,
- XHsCharPrim a ~ XHsCharPrim b,
- XHsChar a ~ XHsChar b,
- XXLit a ~ XXLit b)
-
--- ----------------------------------------------------------------------
-
--- Note [OutputableX]
--- ~~~~~~~~~~~~~~~~~~
---
--- is required because the type family resolution
--- process cannot determine that all cases are handled for a `GhcPass p`
--- case where the cases are listed separately.
---
--- So
---
--- type instance XXHsIPBinds (GhcPass p) = NoExtCon
---
--- will correctly deduce Outputable for (GhcPass p), but
---
--- type instance XIPBinds GhcPs = NoExt
--- type instance XIPBinds GhcRn = NoExt
--- type instance XIPBinds GhcTc = TcEvBinds
---
--- will not.
-
-
--- | Provide a summary constraint that gives all am Outputable constraint to
--- extension points needing one
-type OutputableX p = -- See Note [OutputableX]
- ( Outputable (XIPBinds p)
- , Outputable (XViaStrategy p)
- , Outputable (XViaStrategy GhcRn)
- )
--- TODO: Should OutputableX be included in OutputableBndrId?
-
--- ----------------------------------------------------------------------
-
-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
--- the @p@ and the 'NameOrRdrName' type for it
+-- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc].
type OutputableBndrId pass =
- ( OutputableBndr (NameOrRdrName (IdP (GhcPass pass)))
- , OutputableBndr (IdP (GhcPass pass))
- , OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass))))
- , OutputableBndr (IdP (NoGhcTc (GhcPass pass)))
- , NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass))
- , OutputableX (GhcPass pass)
- , OutputableX (NoGhcTc (GhcPass pass))
+ ( OutputableBndr (IdGhcP pass)
+ , OutputableBndr (IdGhcP (NoGhcTcPass pass))
+ , IsPass pass
)
+
+-- useful helper functions:
+pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc
+pprIfPs pp = case ghcPass @p of GhcPs -> pp
+ _ -> empty
+
+pprIfRn :: forall p. IsPass p => (p ~ 'Renamed => SDoc) -> SDoc
+pprIfRn pp = case ghcPass @p of GhcRn -> pp
+ _ -> empty
+
+pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc
+pprIfTc pp = case ghcPass @p of GhcTc -> pp
+ _ -> empty
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index 32cc3b21a9..58a310a0c0 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -11,8 +11,8 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
module GHC.Hs.ImpExp where
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 5f6fae2cb2..fd723e1408 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -242,11 +242,6 @@ deriving instance Data (RoleAnnotDecl GhcTc)
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs.Expr -----------------------------------
--- deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
-deriving instance Data (SyntaxExpr GhcPs)
-deriving instance Data (SyntaxExpr GhcRn)
-deriving instance Data (SyntaxExpr GhcTc)
-
-- deriving instance (DataIdLR p p) => Data (HsPragE p)
deriving instance Data (HsPragE GhcPs)
deriving instance Data (HsPragE GhcRn)
@@ -331,10 +326,13 @@ deriving instance Data (ArithSeqInfo GhcPs)
deriving instance Data (ArithSeqInfo GhcRn)
deriving instance Data (ArithSeqInfo GhcTc)
-deriving instance Data RecordConTc
-deriving instance Data CmdTopTc
-deriving instance Data PendingRnSplice
-deriving instance Data PendingTcSplice
+deriving instance Data RecordConTc
+deriving instance Data RecordUpdTc
+deriving instance Data CmdTopTc
+deriving instance Data PendingRnSplice
+deriving instance Data PendingTcSplice
+deriving instance Data SyntaxExprRn
+deriving instance Data SyntaxExprTc
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs.Lit ------------------------------------
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
index c92f13392d..a023755ffc 100644
--- a/compiler/GHC/Hs/Lit.hs
+++ b/compiler/GHC/Hs/Lit.hs
@@ -10,8 +10,8 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
@@ -151,23 +151,22 @@ overLitType :: HsOverLit GhcTc -> Type
overLitType (OverLit (OverLitTc _ ty) _ _) = ty
overLitType (XOverLit nec) = noExtCon nec
--- | Convert a literal from one index type to another, updating the annotations
--- according to the relevant 'Convertable' instance
-convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b
-convertLit (HsChar a x) = HsChar (convert a) x
-convertLit (HsCharPrim a x) = HsCharPrim (convert a) x
-convertLit (HsString a x) = HsString (convert a) x
-convertLit (HsStringPrim a x) = HsStringPrim (convert a) x
-convertLit (HsInt a x) = HsInt (convert a) x
-convertLit (HsIntPrim a x) = HsIntPrim (convert a) x
-convertLit (HsWordPrim a x) = HsWordPrim (convert a) x
-convertLit (HsInt64Prim a x) = HsInt64Prim (convert a) x
-convertLit (HsWord64Prim a x) = HsWord64Prim (convert a) x
-convertLit (HsInteger a x b) = HsInteger (convert a) x b
-convertLit (HsRat a x b) = HsRat (convert a) x b
-convertLit (HsFloatPrim a x) = HsFloatPrim (convert a) x
-convertLit (HsDoublePrim a x) = HsDoublePrim (convert a) x
-convertLit (XLit a) = XLit (convert a)
+-- | Convert a literal from one index type to another
+convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
+convertLit (HsChar a x) = HsChar a x
+convertLit (HsCharPrim a x) = HsCharPrim a x
+convertLit (HsString a x) = HsString a x
+convertLit (HsStringPrim a x) = HsStringPrim a x
+convertLit (HsInt a x) = HsInt a x
+convertLit (HsIntPrim a x) = HsIntPrim a x
+convertLit (HsWordPrim a x) = HsWordPrim a x
+convertLit (HsInt64Prim a x) = HsInt64Prim a x
+convertLit (HsWord64Prim a x) = HsWord64Prim a x
+convertLit (HsInteger a x b) = HsInteger a x b
+convertLit (HsRat a x b) = HsRat a x b
+convertLit (HsFloatPrim a x) = HsFloatPrim a x
+convertLit (HsDoublePrim a x) = HsDoublePrim a x
+convertLit (XLit a) = XLit a
{-
Note [ol_rebindable]
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 9812fe2c44..0a5bcb81d5 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -11,12 +11,14 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
module GHC.Hs.Pat (
Pat(..), InPat, OutPat, LPat,
@@ -156,9 +158,7 @@ data Pat p
-- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
-- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@
- | SumPat (XSumPat p) -- GHC.Hs.PlaceHolder before typechecker, filled in
- -- afterwards with the types of the
- -- alternative
+ | SumPat (XSumPat p) -- after typechecker, types of the alternative
(LPat p) -- Sum sub-pattern
ConTag -- Alternative (one-based)
Arity -- Arity (INVARIANT: ≥ 2)
@@ -246,7 +246,7 @@ data Pat p
-- a new hs-boot file. Not worth it.
(SyntaxExpr p) -- (>=) function, of type t1->t2->Bool
- (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntaxName)
+ (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntax)
-- ^ n+k pattern
------------ Pattern type signatures ---------------
@@ -511,7 +511,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
-pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
+pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
pprPat (WildPat _) = char '_'
pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
@@ -525,11 +525,16 @@ pprPat (NPat _ l Nothing _) = ppr l
pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat _ splice) = pprSplice splice
-pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens
- -> if parens
+pprPat (CoPat _ co pat _) = pprIfTc @p $
+ pprHsWrapper co $ \parens
+ -> if parens
then pprParendPat appPrec pat
else pprPat pat
-pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty
+ where ppr_ty = case ghcPass @p of
+ GhcPs -> ppr ty
+ GhcRn -> ppr ty
+ GhcTc -> ppr ty
pprPat (ListPat _ pats) = brackets (interpp'SP pats)
pprPat (TuplePat _ pats bx)
-- Special-case unary boxed tuples so that they are pretty-printed as
@@ -553,7 +558,7 @@ pprPat (ConPatOut { pat_con = con
if gopt Opt_PrintTypecheckerElaboration dflags then
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
- , ppr binds])
+ , pprIfTc @p $ ppr binds ])
<+> pprConArgs details
else pprUserCon (unLoc con) details
pprPat (XPat n) = noExtCon n
diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot
index b37bf187fd..1a1e6c4a2c 100644
--- a/compiler/GHC/Hs/Pat.hs-boot
+++ b/compiler/GHC/Hs/Pat.hs-boot
@@ -1,8 +1,8 @@
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilies #-}
diff --git a/compiler/GHC/Hs/PlaceHolder.hs b/compiler/GHC/Hs/PlaceHolder.hs
deleted file mode 100644
index faaa1331ab..0000000000
--- a/compiler/GHC/Hs/PlaceHolder.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE StandaloneDeriving #-}
-
-module GHC.Hs.PlaceHolder where
-
-import Name
-import NameSet
-import RdrName
-import Var
-
-
-
-{-
-%************************************************************************
-%* *
-\subsection{Annotating the syntax}
-%* *
-%************************************************************************
--}
-
--- NB: These are intentionally open, allowing API consumers (like Haddock)
--- to declare new instances
-
-placeHolderNamesTc :: NameSet
-placeHolderNamesTc = emptyNameSet
-
-{-
-TODO:AZ: remove this, and check if we still need all the UndecidableInstances
-
-Note [Pass sensitive types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Since the same AST types are re-used through parsing,renaming and type
-checking there are naturally some places in the AST that do not have
-any meaningful value prior to the pass they are assigned a value.
-
-Historically these have been filled in with place holder values of the form
-
- panic "error message"
-
-This has meant the AST is difficult to traverse using standard generic
-programming techniques. The problem is addressed by introducing
-pass-specific data types, implemented as a pair of open type families,
-one for PostTc and one for PostRn. These are then explicitly populated
-with a PlaceHolder value when they do not yet have meaning.
-
-In terms of actual usage, we have the following
-
- PostTc id Kind
- PostTc id Type
-
- PostRn id Fixity
- PostRn id NameSet
-
-TcId and Var are synonyms for Id
-
-Unfortunately the type checker termination checking conditions fail for the
-DataId constraint type based on this, so even though it is safe the
-UndecidableInstances pragma is required where this is used.
--}
-
-
--- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext',
--- for printing messages related to a 'Match'
-type family NameOrRdrName id where
- NameOrRdrName Id = Name
- NameOrRdrName Name = Name
- NameOrRdrName RdrName = RdrName
diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index bc7ba47434..34709b71f1 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/compiler/GHC/Hs/Types.hs
@@ -11,8 +11,8 @@ GHC.Hs.Types: Abstract syntax: user-defined types
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 76101a73cb..22f2b02cd2 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -38,7 +38,7 @@ module GHC.Hs.Utils(
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
mkHsCmdIf,
- nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
+ nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon,
nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
@@ -107,7 +107,6 @@ import GHC.Hs.Expr
import GHC.Hs.Pat
import GHC.Hs.Types
import GHC.Hs.Lit
-import GHC.Hs.PlaceHolder
import GHC.Hs.Extension
import TcEvidence
@@ -151,7 +150,7 @@ just attach 'noSrcSpan' to everything.
mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar e = L (getLoc e) (HsPar noExtField e)
-mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+mkSimpleMatch :: HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)] -> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
@@ -215,18 +214,17 @@ mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
-nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
+nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
nlHsTyApp fun_id tys
= noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id)))
-nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
- -> LHsExpr (GhcPass id)
+nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
--------- Adding parens ---------
-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them
-- So @f x@ becomes @(f x)@, but @3@ stays as @3@.
-mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar le@(L loc e)
| hsExprNeedsParens appPrec e = L loc (HsPar noExtField le)
| otherwise = le
@@ -241,24 +239,26 @@ nlParPat p = noLoc (ParPat noExtField p)
-------------------------------
-- These are the bits of syntax that contain rebindable names
--- See GHC.Rename.Env.lookupSyntaxName
+-- See GHC.Rename.Env.lookupSyntax
mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> HsOverLit GhcPs
mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
-mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
-mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
+mkHsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> HsExpr GhcPs
+mkHsComp :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
-> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
-mkLastStmt :: Located (bodyR (GhcPass idR))
+-- NB: The following functions all use noSyntaxExpr: the generated expressions
+-- will not work with rebindable syntax if used after the renamer
+mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR))
-> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
-mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
+mkBindStmt :: IsPass idR => (XBindStmt (GhcPass idL) (GhcPass idR)
(Located (bodyR (GhcPass idR))) ~ NoExtField)
=> LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
-> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
@@ -281,13 +281,14 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
where
last_stmt = L (getLoc expr) $ mkLastStmt expr
-mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
- -> HsExpr (GhcPass p)
-mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b
+-- restricted to GhcPs because other phases might need a SyntaxExpr
+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
+mkHsIf c a b = HsIf True {- this might use rebindable syntax -} noSyntaxExpr c a b
+ -- see Note [Rebindable if] in Hs.Expr
-mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
- -> HsCmd (GhcPass p)
-mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b
+-- restricted to GhcPs because other phases might need a SyntaxExpr
+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs
+mkHsCmdIf c a b = HsCmdIf noExtField noSyntaxExpr c a b
mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr
mkNPlusKPat id lit
@@ -323,8 +324,8 @@ mkBindStmt pat body
mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
-- don't use placeHolderTypeTc above, because that panics during zonking
-emptyRecStmt' :: forall idL idR body.
- XRecStmt (GhcPass idL) (GhcPass idR) body
+emptyRecStmt' :: forall idL idR body. IsPass idR
+ => XRecStmt (GhcPass idL) (GhcPass idR) body
-> StmtLR (GhcPass idL) (GhcPass idR) body
emptyRecStmt' tyVal =
RecStmt
@@ -389,6 +390,9 @@ mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar n = noLoc (HsVar noExtField (noLoc n))
+nl_HsVar :: IdP (GhcPass id) -> HsExpr (GhcPass id)
+nl_HsVar n = HsVar noExtField (noLoc n)
+
-- | NB: Only for 'LHsExpr' 'Id'.
nlHsDataCon :: DataCon -> LHsExpr GhcTc
nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con))
@@ -405,23 +409,21 @@ nlVarPat n = noLoc (VarPat noExtField (noLoc n))
nlLitPat :: HsLit GhcPs -> LPat GhcPs
nlLitPat l = noLoc (LitPat noExtField l)
-nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x))
-nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
- -> LHsExpr (GhcPass id)
-nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
- , syn_arg_wraps = arg_wraps
- , syn_res_wrap = res_wrap }) args
- | [] <- arg_wraps -- in the noSyntaxExpr case
- = ASSERT( isIdHsWrapper res_wrap )
- foldl' nlHsApp (noLoc fun) args
-
- | otherwise
+nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]
+ -> LHsExpr GhcTc
+nlHsSyntaxApps (SyntaxExprTc { syn_expr = fun
+ , syn_arg_wraps = arg_wraps
+ , syn_res_wrap = res_wrap }) args
= mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
mkLHsWrap arg_wraps args))
+nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)
+ -- this function should never be called in scenarios where there is no
+ -- syntax expr
-nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
+nlHsApps :: IsPass id => IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
@@ -465,7 +467,7 @@ nlWildPat = noLoc (WildPat noExtField )
nlWildPatName :: LPat GhcRn
nlWildPatName = noLoc (WildPat noExtField )
-nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
+nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
@@ -474,8 +476,6 @@ nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
- -> LHsExpr (GhcPass id)
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
@@ -483,10 +483,11 @@ nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match]))
nlHsPar e = noLoc (HsPar noExtField e)
--- | Note [Rebindable nlHsIf]
-- nlHsIf should generate if-expressions which are NOT subject to
--- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
-nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false)
+-- RebindableSyntax, so the first field of HsIf is False. (#12080)
+-- See Note [Rebindable if] in Hs.Expr
+nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+nlHsIf cond true false = noLoc (HsIf False noSyntaxExpr cond true false)
nlHsCase expr matches
= noLoc (HsCase noExtField expr (mkMatchGroup Generated matches))
@@ -754,39 +755,39 @@ positions in the kind of the tycon.
* *
********************************************************************* -}
-mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@.
-- See Note [Detecting forced eta expansion] in "DsExpr"
-mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
-mkHsWrap co_fn e | isIdHsWrapper co_fn = e
-mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
-mkHsWrap co_fn e = HsWrap noExtField co_fn e
+mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
+mkHsWrap co_fn e | isIdHsWrapper co_fn = e
+mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e
+mkHsWrap co_fn e = XExpr (HsWrap co_fn e)
mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b
- -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
+ -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b
- -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
+ -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
-mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
-mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
+mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
- | otherwise = HsCmdWrap noExtField w cmd
+ | otherwise = XCmd (HsWrap w cmd)
-mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
+mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
-mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
+mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
| otherwise = CoPat noExtField co_fn p ty
-mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
+mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
| otherwise = CoPat noExtField (mkWpCastN co) pat ty
@@ -808,7 +809,6 @@ mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
mkFunBind origin fn ms
= FunBind { fun_id = fn
, fun_matches = mkMatchGroup origin ms
- , fun_co_fn = idHsWrapper
, fun_ext = noExtField
, fun_tick = [] }
@@ -817,7 +817,6 @@ mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-- ^ In Name-land, with empty bind_fvs
mkTopFunBind origin fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup origin ms
- , fun_co_fn = idHsWrapper
, fun_ext = emptyNameSet -- NB: closed
-- binding
, fun_tick = [] }
@@ -843,7 +842,7 @@ mkPatSynBind name details lpat dir = PatSynBind noExtField psb
-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
-isInfixFunBind (FunBind _ _ (MG _ matches _) _ _)
+isInfixFunBind (FunBind { fun_matches = MG _ matches _ })
= any (isInfixMatch . unLoc) (unLoc matches)
isInfixFunBind _ = False
@@ -859,13 +858,13 @@ mkSimpleGeneratedFunBind loc fun pats expr
(noLoc emptyLocalBinds)]
-- | Make a prefix, non-strict function 'HsMatchContext'
-mkPrefixFunRhs :: Located id -> HsMatchContext id
+mkPrefixFunRhs :: LIdP p -> HsMatchContext p
mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
------------
-mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
+mkMatch :: HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index a7845de8bd..e397df455a 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -280,7 +280,7 @@ checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions.
-checkGuardMatches :: HsMatchContext Name -- Match context
+checkGuardMatches :: HsMatchContext GhcRn -- Match context
-> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
-> DsM ()
checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 893966d3eb..022cc6cb2b 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -643,16 +643,16 @@ instance HasType (LHsExpr GhcTc) where
-- See impact on Haddock output (esp. missing type annotations or links)
-- before marking more things here as 'False'. See impact on Haddock
-- performance before marking more things as 'True'.
- skipDesugaring :: HsExpr a -> Bool
+ skipDesugaring :: HsExpr GhcTc -> Bool
skipDesugaring e = case e of
- HsVar{} -> False
- HsUnboundVar{} -> False
- HsConLikeOut{} -> False
- HsRecFld{} -> False
- HsOverLabel{} -> False
- HsIPVar{} -> False
- HsWrap{} -> False
- _ -> True
+ HsVar{} -> False
+ HsUnboundVar{} -> False
+ HsConLikeOut{} -> False
+ HsRecFld{} -> False
+ HsOverLabel{} -> False
+ HsIPVar{} -> False
+ XExpr (HsWrap{}) -> False
+ _ -> True
instance ( ToHie (Context (Located (IdP a)))
, ToHie (MatchGroup a (LHsExpr a))
@@ -732,7 +732,7 @@ instance ( ToHie (MatchGroup a (LHsExpr a))
instance ( a ~ GhcPass p
, ToHie body
- , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
+ , ToHie (HsMatchContext (NoGhcTc a))
, ToHie (PScoped (LPat a))
, ToHie (GRHSs a body)
, Data (Match a body)
@@ -746,7 +746,7 @@ instance ( a ~ GhcPass p
]
XMatch _ -> []
-instance ( ToHie (Context (Located a))
+instance ( ToHie (Context (Located (IdP a)))
) => ToHie (HsMatchContext a) where
toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
toHie (StmtCtxt a) = toHie a
@@ -885,6 +885,7 @@ instance ( a ~ GhcPass p
, Data (HsTupArg a)
, Data (AmbiguousFieldOcc a)
, (HasRealDataConName a)
+ , IsPass p
) => ToHie (LHsExpr (GhcPass p)) where
toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
HsVar _ (L _ var) ->
@@ -997,9 +998,6 @@ instance ( a ~ GhcPass p
HsBinTick _ _ _ expr ->
[ toHie expr
]
- HsWrap _ _ a ->
- [ toHie $ L mspan a
- ]
HsBracket _ b ->
[ toHie b
]
@@ -1014,7 +1012,13 @@ instance ( a ~ GhcPass p
HsSpliceE _ x ->
[ toHie $ L mspan x
]
- XExpr _ -> []
+ XExpr x
+ | GhcTc <- ghcPass @p
+ , HsWrap _ a <- x
+ -> [ toHie $ L mspan a ]
+
+ | otherwise
+ -> []
instance ( a ~ GhcPass p
, ToHie (LHsExpr a)
@@ -1244,7 +1248,6 @@ instance ( a ~ GhcPass p
[ pure $ locOnly ispan
, toHie $ listScopes NoScope stmts
]
- HsCmdWrap _ _ _ -> []
XCmd _ -> []
instance ToHie (TyClGroup GhcRn) where
diff --git a/compiler/GHC/Rename/Binds.hs b/compiler/GHC/Rename/Binds.hs
index 6cf0a55fc6..888b8ce62d 100644
--- a/compiler/GHC/Rename/Binds.hs
+++ b/compiler/GHC/Rename/Binds.hs
@@ -1162,7 +1162,7 @@ checkDupMinimalSigs sigs
************************************************************************
-}
-rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
+rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> MatchGroup GhcPs (Located (body GhcPs))
-> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
@@ -1173,13 +1173,13 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
; return (mkMatchGroup origin new_ms, ms_fvs) }
rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec
-rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
+rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LMatch GhcPs (Located (body GhcPs))
-> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)
rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
-rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
+rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> Match GhcPs (Located (body GhcPs))
-> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
@@ -1195,7 +1195,7 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
, m_grhss = grhss'}, grhss_fvs ) }}
rnMatch' _ _ (XMatch nec) = noExtCon nec
-emptyCaseErr :: HsMatchContext Name -> SDoc
+emptyCaseErr :: HsMatchContext GhcRn -> SDoc
emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
2 (text "Use EmptyCase to allow this")
where
@@ -1212,7 +1212,7 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
************************************************************************
-}
-rnGRHSs :: HsMatchContext Name
+rnGRHSs :: HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHSs GhcPs (Located (body GhcPs))
-> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
@@ -1222,13 +1222,13 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)
rnGRHSs _ _ (XGRHSs nec) = noExtCon nec
-rnGRHS :: HsMatchContext Name
+rnGRHS :: HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LGRHS GhcPs (Located (body GhcPs))
-> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
-rnGRHS' :: HsMatchContext Name
+rnGRHS' :: HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHS GhcPs (Located (body GhcPs))
-> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 443c5614c8..82681a9206 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -30,7 +30,7 @@ module GHC.Rename.Env (
lookupGreAvailRn,
-- Rebindable Syntax
- lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,
+ lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,
lookupIfThenElse,
-- Constructing usage information
@@ -81,6 +81,7 @@ import GHC.Rename.Utils
import qualified Data.Semigroup as Semi
import Data.Either ( partitionEithers )
import Data.List (find)
+import Control.Arrow ( first )
{-
*********************************************************
@@ -1625,45 +1626,46 @@ We store the relevant Name in the HsSyn tree, in
* HsDo
respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
-name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does.
+name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does.
We treat the original (standard) names as free-vars too, because the type checker
checks the type of the user thing against the type of the standard thing.
-}
-lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
--- Different to lookupSyntaxName because in the non-rebindable
+lookupIfThenElse :: Bool -- False <=> don't use rebindable syntax under any conditions
+ -> RnM (SyntaxExpr GhcRn, FreeVars)
+-- Different to lookupSyntax because in the non-rebindable
-- case we desugar directly rather than calling an existing function
-- Hence the (Maybe (SyntaxExpr GhcRn)) return type
-lookupIfThenElse
+lookupIfThenElse maybe_use_rs
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
- ; if not rebindable_on
- then return (Nothing, emptyFVs)
+ ; if not (rebindable_on && maybe_use_rs)
+ then return (NoSyntaxExprRn, emptyFVs)
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
- ; return ( Just (mkRnSyntaxExpr ite)
+ ; return ( mkRnSyntaxExpr ite
, unitFV ite ) } }
-lookupSyntaxName' :: Name -- ^ The standard name
- -> RnM Name -- ^ Possibly a non-standard name
-lookupSyntaxName' std_name
- = do { rebindable_on <- xoptM LangExt.RebindableSyntax
- ; if not rebindable_on then
- return std_name
- else
- -- Get the similarly named thing from the local environment
- lookupOccRn (mkRdrUnqual (nameOccName std_name)) }
-
-lookupSyntaxName :: Name -- The standard name
- -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard
- -- name
+lookupSyntaxName :: Name -- ^ The standard name
+ -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name
lookupSyntaxName std_name
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on then
- return (mkRnSyntaxExpr std_name, emptyFVs)
+ return (std_name, emptyFVs)
else
-- Get the similarly named thing from the local environment
do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
- ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }
+ ; return (usr_name, unitFV usr_name) } }
+
+lookupSyntaxExpr :: Name -- ^ The standard name
+ -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name
+lookupSyntaxExpr std_name
+ = fmap (first nl_HsVar) $ lookupSyntaxName std_name
+
+lookupSyntax :: Name -- The standard name
+ -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard
+ -- name
+lookupSyntax std_name
+ = fmap (first mkSyntaxExpr) $ lookupSyntaxExpr std_name
lookupSyntaxNames :: [Name] -- Standard names
-> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index a03288086e..333e3c3f5a 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -202,7 +202,7 @@ rnExpr (OpApp _ e1 op e2)
rnExpr (NegApp _ e _)
= do { (e', fv_e) <- rnLExpr e
- ; (neg_name, fv_neg) <- lookupSyntaxName negateName
+ ; (neg_name, fv_neg) <- lookupSyntax negateName
; final_e <- mkNegAppRn e' neg_name
; return (final_e, fv_e `plusFV` fv_neg) }
@@ -273,7 +273,7 @@ rnExpr (ExplicitList x _ exps)
; (exps', fvs) <- rnExprs exps
; if opt_OverloadedLists
then do {
- ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
+ ; (from_list_n_name, fvs') <- lookupSyntax fromListNName
; return (ExplicitList x (Just from_list_n_name) exps'
, fvs `plusFV` fvs') }
else
@@ -322,12 +322,12 @@ rnExpr (ExprWithTySig _ expr pty)
rnLExpr expr
; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
-rnExpr (HsIf x _ p b1 b2)
+rnExpr (HsIf might_use_rebindable_syntax _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLExpr b1
; (b2', fvB2) <- rnLExpr b2
- ; (mb_ite, fvITE) <- lookupIfThenElse
- ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+ ; (mb_ite, fvITE) <- lookupIfThenElse might_use_rebindable_syntax
+ ; return (HsIf noExtField mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
rnExpr (HsMultiIf x alts)
= do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
@@ -339,7 +339,7 @@ rnExpr (ArithSeq x _ seq)
; (new_seq, fvs) <- rnArithSeq seq
; if opt_OverloadedLists
then do {
- ; (from_list_name, fvs') <- lookupSyntaxName fromListName
+ ; (from_list_name, fvs') <- lookupSyntax fromListName
; return (ArithSeq x (Just from_list_name) new_seq
, fvs `plusFV` fvs') }
else
@@ -501,7 +501,7 @@ rnCmd (HsCmdIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLCmd b1
; (b2', fvB2) <- rnLCmd b2
- ; (mb_ite, fvITE) <- lookupIfThenElse
+ ; (mb_ite, fvITE) <- lookupIfThenElse True
; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
rnCmd (HsCmdLet x (L l binds) cmd)
@@ -514,7 +514,6 @@ rnCmd (HsCmdDo x (L l stmts))
rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
; return ( HsCmdDo x (L l stmts'), fvs ) }
-rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
rnCmd (XCmd nec) = noExtCon nec
---------------------------------------------------
@@ -532,7 +531,6 @@ methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
= unitFV appAName
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
-methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd
methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c
@@ -658,7 +656,7 @@ See Note [Deterministic UniqFM] to learn more about nondeterminism.
-- | Rename some Stmts
rnStmts :: Outputable (body GhcPs)
- => HsStmtContext Name
+ => HsStmtContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-- ^ How to rename the body of each statement (e.g. rnLExpr)
-> [LStmt GhcPs (Located (body GhcPs))]
@@ -672,10 +670,10 @@ rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
rnStmtsWithPostProcessing
:: Outputable (body GhcPs)
- => HsStmtContext Name
+ => HsStmtContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-- ^ How to rename the body of each statement (e.g. rnLExpr)
- -> (HsStmtContext Name
+ -> (HsStmtContext GhcRn
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
-- ^ postprocess the statements
@@ -694,7 +692,7 @@ rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
-- | maybe rearrange statements according to the ApplicativeDo transformation
postProcessStmtsForApplicativeDo
- :: HsStmtContext Name
+ :: HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
postProcessStmtsForApplicativeDo ctxt stmts
@@ -715,14 +713,14 @@ postProcessStmtsForApplicativeDo ctxt stmts
-- | strip the FreeVars annotations from statements
noPostProcessStmts
- :: HsStmtContext Name
+ :: HsStmtContext GhcRn
-> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
rnStmtsWithFreeVars :: Outputable (body GhcPs)
- => HsStmtContext Name
+ => HsStmtContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
@@ -785,7 +783,7 @@ At one point we failed to make this distinction, leading to #11216.
-}
rnStmt :: Outputable (body GhcPs)
- => HsStmtContext Name
+ => HsStmtContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-- ^ How to rename the body of the statement
-> LStmt GhcPs (Located (body GhcPs))
@@ -928,7 +926,7 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ =
rnStmt _ _ (L _ (XStmtLR nec)) _ =
noExtCon nec
-rnParallelStmts :: forall thing. HsStmtContext Name
+rnParallelStmts :: forall thing. HsStmtContext GhcRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
@@ -963,15 +961,15 @@ rnParallelStmts ctxt return_op segs thing_inside
dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
<+> quotes (ppr (NE.head vs)))
-lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
--- Like lookupSyntaxName, but respects contexts
+lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+-- Like lookupSyntax, but respects contexts
lookupStmtName ctxt n
| rebindableContext ctxt
- = lookupSyntaxName n
+ = lookupSyntax n
| otherwise
= return (mkRnSyntaxExpr n, emptyFVs)
-lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
+lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly ctxt name
| rebindableContext ctxt
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
@@ -987,7 +985,7 @@ lookupStmtNamePoly ctxt name
-- | Is this a context where we respect RebindableSyntax?
-- but ListComp are never rebindable
-- Neither is ArrowExpr, which has its own desugarer in DsArrows
-rebindableContext :: HsStmtContext Name -> Bool
+rebindableContext :: HsStmtContext GhcRn -> Bool
rebindableContext ctxt = case ctxt of
ListComp -> False
ArrowExpr -> False
@@ -1156,19 +1154,19 @@ rn_rec_stmt :: (Outputable (body GhcPs)) =>
-- Turns each stmt into a singleton Stmt
rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
= do { (body', fv_expr) <- rnBody body
- ; (ret_op, fvs1) <- lookupSyntaxName returnMName
+ ; (ret_op, fvs1) <- lookupSyntax returnMName
; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
L loc (LastStmt noExtField body' noret ret_op))] }
rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
= do { (body', fvs) <- rnBody body
- ; (then_op, fvs1) <- lookupSyntaxName thenMName
+ ; (then_op, fvs1) <- lookupSyntax thenMName
; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }
rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
= do { (body', fv_expr) <- rnBody body
- ; (bind_op, fvs1) <- lookupSyntaxName bindMName
+ ; (bind_op, fvs1) <- lookupSyntax bindMName
; (fail_op, fvs2) <- getMonadFailOp
@@ -1219,7 +1217,7 @@ rn_rec_stmts rnBody bndrs stmts
; return (concat segs_s) }
---------------------------------------------
-segmentRecStmts :: SrcSpan -> HsStmtContext Name
+segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn
-> Stmt GhcRn body
-> [Segment (LStmt GhcRn body)] -> FreeVars
-> ([LStmt GhcRn body], FreeVars)
@@ -1323,7 +1321,7 @@ glom it together with the first two groups
r <- x }
-}
-glomSegments :: HsStmtContext Name
+glomSegments :: HsStmtContext GhcRn
-> [Segment (LStmt GhcRn body)]
-> [Segment [LStmt GhcRn body]]
-- Each segment has a non-empty list of Stmts
@@ -1534,7 +1532,7 @@ instance Outputable MonadNames where
-- | rearrange a list of statements using ApplicativeDoStmt. See
-- Note [ApplicativeDo].
rearrangeForApplicativeDo
- :: HsStmtContext Name
+ :: HsStmtContext GhcRn
-> [(ExprLStmt GhcRn, FreeVars)]
-> RnM ([ExprLStmt GhcRn], FreeVars)
@@ -1545,8 +1543,8 @@ rearrangeForApplicativeDo ctxt stmts0 = do
let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
| otherwise = mkStmtTreeHeuristic stmts
traceRn "rearrangeForADo" (ppr stmt_tree)
- return_name <- lookupSyntaxName' returnMName
- pure_name <- lookupSyntaxName' pureAName
+ (return_name, _) <- lookupSyntaxName returnMName
+ (pure_name, _) <- lookupSyntaxName pureAName
let monad_names = MonadNames { return_name = return_name
, pure_name = pure_name }
stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
@@ -1660,7 +1658,7 @@ mkStmtTreeOptimal stmts =
-- ApplicativeStmt where necessary.
stmtTreeToStmts
:: MonadNames
- -> HsStmtContext Name
+ -> HsStmtContext GhcRn
-> ExprStmtTree
-> [ExprLStmt GhcRn] -- ^ the "tail"
-> FreeVars -- ^ free variables of the tail
@@ -1744,8 +1742,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
if | L _ ApplicativeStmt{} <- last stmts' ->
return (unLoc tup, emptyNameSet)
| otherwise -> do
- ret <- lookupSyntaxName' returnMName
- let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup
+ (ret, _) <- lookupSyntaxExpr returnMName
+ let expr = HsApp noExtField (noLoc ret) tup
return (expr, emptyFVs)
return ( ApplicativeArgMany
{ xarg_app_arg_many = noExtField
@@ -1931,7 +1929,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- it this way rather than try to ignore the return later in both the
-- typechecker and the desugarer (I tried it that way first!).
mkApplicativeStmt
- :: HsStmtContext Name
+ :: HsStmtContext GhcRn
-> [ApplicativeArg GhcRn] -- ^ The args
-> Bool -- ^ True <=> need a join
-> [ExprLStmt GhcRn] -- ^ The body statements
@@ -1991,7 +1989,7 @@ isReturnApp monad_names (L _ e) = case e of
************************************************************************
-}
-checkEmptyStmts :: HsStmtContext Name -> RnM ()
+checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
-- We've seen an empty sequence of Stmts... is that ok?
checkEmptyStmts ctxt
= unless (okEmpty ctxt) (addErr (emptyErr ctxt))
@@ -2000,13 +1998,13 @@ okEmpty :: HsStmtContext a -> Bool
okEmpty (PatGuard {}) = True
okEmpty _ = False
-emptyErr :: HsStmtContext Name -> SDoc
+emptyErr :: HsStmtContext GhcRn -> SDoc
emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension"
emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt
----------------------
-checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
+checkLastStmt :: Outputable (body GhcPs) => HsStmtContext GhcRn
-> LStmt GhcPs (Located (body GhcPs))
-> RnM (LStmt GhcPs (Located (body GhcPs)))
checkLastStmt ctxt lstmt@(L loc stmt)
@@ -2036,7 +2034,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
= do { checkStmt ctxt lstmt; return lstmt }
-- Checking when a particular Stmt is ok
-checkStmt :: HsStmtContext Name
+checkStmt :: HsStmtContext GhcRn
-> LStmt GhcPs (Located (body GhcPs))
-> RnM ()
checkStmt ctxt (L _ stmt)
@@ -2064,7 +2062,7 @@ emptyInvalid :: Validity -- Payload is the empty document
emptyInvalid = NotValid Outputable.empty
okStmt, okDoStmt, okCompStmt, okParStmt
- :: DynFlags -> HsStmtContext Name
+ :: DynFlags -> HsStmtContext GhcRn
-> Stmt GhcPs (Located (body GhcPs)) -> Validity
-- Return Nothing if OK, (Just extra) if not ok
-- The "extra" is an SDoc that is appended to a generic error message
@@ -2147,7 +2145,7 @@ badIpBinds what binds
---------
monadFailOp :: LPat GhcPs
- -> HsStmtContext Name
+ -> HsStmtContext GhcRn
-> RnM (SyntaxExpr GhcRn, FreeVars)
monadFailOp pat ctxt
-- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
@@ -2194,18 +2192,17 @@ getMonadFailOp
where
reallyGetMonadFailOp rebindableSyntax overloadedStrings
| rebindableSyntax && overloadedStrings = do
- (failExpr, failFvs) <- lookupSyntaxName failMName
- (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName
+ (failExpr, failFvs) <- lookupSyntaxExpr failMName
+ (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
let arg_lit = mkVarOcc "arg"
arg_name <- newSysName arg_lit
- let arg_syn_expr = mkRnSyntaxExpr arg_name
+ let arg_syn_expr = nlHsVar arg_name
body :: LHsExpr GhcRn =
- nlHsApp (noLoc $ syn_expr failExpr)
- (nlHsApp (noLoc $ syn_expr fromStringExpr)
- (noLoc $ syn_expr arg_syn_expr))
+ nlHsApp (noLoc failExpr)
+ (nlHsApp (noLoc $ fromStringExpr) arg_syn_expr)
let failAfterFromStringExpr :: HsExpr GhcRn =
unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
- | otherwise = lookupSyntaxName failMName
+ | otherwise = lookupSyntax failMName
diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot
index 9667b5b26c..77dec1b56a 100644
--- a/compiler/GHC/Rename/Expr.hs-boot
+++ b/compiler/GHC/Rename/Expr.hs-boot
@@ -10,7 +10,7 @@ rnLExpr :: LHsExpr GhcPs
-> RnM (LHsExpr GhcRn, FreeVars)
rnStmts :: --forall thing body.
- Outputable (body GhcPs) => HsStmtContext Name
+ Outputable (body GhcPs) => HsStmtContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [LStmt GhcPs (Located (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index ae509867b3..0f8041447b 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -309,7 +309,7 @@ There are various entry points to renaming patterns, depending on
-- * local namemaker
-- * unused and duplicate checking
-- * no fixities
-rnPats :: HsMatchContext Name -- for error messages
+rnPats :: HsMatchContext GhcRn -- for error messages
-> [LPat GhcPs]
-> ([LPat GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
@@ -337,7 +337,7 @@ rnPats ctxt pats thing_inside
where
doc_pat = text "In" <+> pprMatchContext ctxt
-rnPat :: HsMatchContext Name -- for error messages
+rnPat :: HsMatchContext GhcRn -- for error messages
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -- Variables bound by pattern do not
@@ -429,7 +429,7 @@ rnPatAndThen mk (LitPat x lit)
rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
= do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
; mb_neg' -- See Note [Negative zero]
- <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
+ <- let negative = do { (neg, fvs) <- lookupSyntax negateName
; return (Just neg, fvs) }
positive = return (Nothing, emptyFVs)
in liftCpsFV $ case (mb_neg , mb_neg') of
@@ -437,7 +437,7 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
(Just _ , Nothing) -> negative
(Nothing, Nothing) -> positive
(Just _ , Just _ ) -> positive
- ; eq' <- liftCpsFV $ lookupSyntaxName eqName
+ ; eq' <- liftCpsFV $ lookupSyntax eqName
; return (NPat x (L l lit') mb_neg' eq') }
rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )
@@ -446,8 +446,8 @@ rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )
-- We skip negateName as
-- negative zero doesn't make
-- sense in n + k patterns
- ; minus <- liftCpsFV $ lookupSyntaxName minusName
- ; ge <- liftCpsFV $ lookupSyntaxName geName
+ ; minus <- liftCpsFV $ lookupSyntax minusName
+ ; ge <- liftCpsFV $ lookupSyntax geName
; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)
(L l lit') lit' ge minus) }
-- The Report says that n+k patterns must be in Integral
@@ -481,7 +481,7 @@ rnPatAndThen mk (ListPat _ pats)
= do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
; pats' <- rnLPatsAndThen mk pats
; case opt_OverloadedLists of
- True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
+ True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName
; return (ListPat (Just to_list_name) pats')}
False -> return (ListPat Nothing pats') }
@@ -864,16 +864,12 @@ rnOverLit origLit
| otherwise = origLit
}
; let std_name = hsOverLitName val
- ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
- <- lookupSyntaxName std_name
- ; let rebindable = case from_thing_name of
- HsVar _ lv -> (unLoc lv) /= std_name
- _ -> panic "rnOverLit"
- ; let lit' = lit { ol_witness = from_thing_name
+ ; (from_thing_name, fvs1) <- lookupSyntaxName std_name
+ ; let rebindable = from_thing_name /= std_name
+ lit' = lit { ol_witness = nl_HsVar from_thing_name
, ol_ext = rebindable }
; if isNegativeZeroOverLit lit'
- then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
- <- lookupSyntaxName negateName
+ then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
, fvs1 `plusFV` fvs2) }
else return ((lit', Nothing), fvs1) }
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 7d970ed570..808cd21803 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -853,7 +853,7 @@ cvtLocalDecs doc ds
((_:_), (_:_)) ->
failWith (text "Implicit parameters mixed with other bindings")
-cvtClause :: HsMatchContext RdrName
+cvtClause :: HsMatchContext GhcPs
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause ctxt (Clause ps body wheres)
= do { ps' <- cvtPats ps
@@ -924,7 +924,7 @@ cvtl e = wrapL (cvt e)
; return $ ExplicitSum noExtField
alt arity e'}
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
- ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' }
+ ; return $ mkHsIf x' y' z' }
cvt (MultiIfE alts)
| null alts = failWith (text "Multi-way if-expression with no alternatives")
| otherwise = do { alts' <- mapM cvtpair alts
@@ -1126,7 +1126,7 @@ cvtOpApp x op y
-- Do notation and statements
-------------------------------------
-cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
+cvtHsDo :: HsStmtContext GhcRn -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
cvtHsDo do_or_lc stmts
| null stmts = failWith (text "Empty stmt list in do-block")
| otherwise
@@ -1159,7 +1159,7 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss
; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }
cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
-cvtMatch :: HsMatchContext RdrName
+cvtMatch :: HsMatchContext GhcPs
-> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 6f9fe36141..0092e991ef 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -633,10 +633,10 @@ addTickHsExpr (HsProc x pat cmdtop) =
liftM2 (HsProc x)
(addTickLPat pat)
(liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (HsWrap x w e) =
- liftM2 (HsWrap x)
- (return w)
- (addTickHsExpr e) -- Explicitly no tick on inside
+addTickHsExpr (XExpr (HsWrap w e)) =
+ liftM XExpr $
+ liftM (HsWrap w)
+ (addTickHsExpr e) -- Explicitly no tick on inside
-- Others should never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
@@ -834,9 +834,11 @@ addTickIPBind (XIPBind x) = return (XIPBind x)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
-addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
+addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do
x' <- fmap unLoc (addTickLHsExpr (L pos x))
return $ syn { syn_expr = x' }
+addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc
+
-- we do not walk into patterns.
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
addTickLPat pat = return pat
@@ -899,10 +901,9 @@ addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-addTickHsCmd (HsCmdWrap x w cmd)
- = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
-
-addTickHsCmd (XCmd nec) = noExtCon nec
+addTickHsCmd (XCmd (HsWrap w cmd)) =
+ liftM XCmd $
+ liftM (HsWrap w) (addTickHsCmd cmd)
-- Others should never happen in a command context.
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index bab9a60cad..8c1e161dc9 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -45,7 +45,6 @@ import CoreUtils
import MkCore
import DsBinds (dsHsWrapper)
-import Name
import Id
import ConLike
import TysWiredIn
@@ -169,7 +168,7 @@ do_premap :: DsCmdEnv -> Type -> Type -> Type ->
do_premap ids b_ty c_ty d_ty f g
= do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
-mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
+mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
= mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
@@ -530,11 +529,11 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
(buildEnvStack else_ids stack_id)
core_if <- case mb_fun of
- Just fun -> do { fun_apps <- dsSyntaxExpr fun
+ NoSyntaxExprTc -> matchEnvStack env_ids stack_id $
+ mkIfThenElse core_cond core_left core_right
+ _ -> do { fun_apps <- dsSyntaxExpr mb_fun
[core_cond, core_left, core_right]
- ; matchEnvStack env_ids stack_id fun_apps }
- Nothing -> matchEnvStack env_ids stack_id $
- mkIfThenElse core_cond core_left core_right
+ ; matchEnvStack env_ids stack_id fun_apps }
return (do_premap ids in_ty sum_ty res_ty
core_if
@@ -690,7 +689,7 @@ dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
return (mkApps (App core_op (Type env_ty)) core_args,
unionDVarSets fv_sets)
-dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do
(core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
core_wrap <- dsHsWrapper wrap
return (core_wrap core_cmd, env_ids')
@@ -1126,7 +1125,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
-- Match a list of expressions against a list of patterns, left-to-right.
matchSimplys :: [CoreExpr] -- Scrutinees
- -> HsMatchContext Name -- Match kind
+ -> HsMatchContext GhcRn -- Match kind
-> [LPat GhcTc] -- Patterns they should match
-> CoreExpr -- Return this if they all match
-> CoreExpr -- Return this if they don't
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index ac3a41a8fb..d573efc0c3 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -147,7 +147,7 @@ dsHsBind dflags (VarBind { var_id = var
dsHsBind dflags b@(FunBind { fun_id = L _ fun
, fun_matches = matches
- , fun_co_fn = co_fn
+ , fun_ext = co_fn
, fun_tick = tick })
= do { (args, body) <- matchWrapper
(mkPrefixFunRhs (noLoc $ idName fun))
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 0f1386d76d..d4754fe568 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -198,7 +198,7 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
dsUnliftedBind (FunBind { fun_id = L l fun
, fun_matches = matches
- , fun_co_fn = co_fn
+ , fun_ext = co_fn
, fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed
@@ -278,7 +278,7 @@ ds_expr _ (HsOverLit _ lit)
= do { warnAboutOverflowedOverLit lit
; dsOverLit lit }
-ds_expr _ (HsWrap _ co_fn e)
+ds_expr _ (XExpr (HsWrap co_fn e))
= do { e' <- ds_expr True e -- This is the one place where we recurse to
-- ds_expr (passing True), rather than dsExpr
; wrap' <- dsHsWrapper co_fn
@@ -429,13 +429,13 @@ ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
-ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
+ds_expr _ (HsIf _ fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
; b1 <- dsLExpr then_expr
; b2 <- dsLExpr else_expr
- ; case mb_fun of
- Just fun -> dsSyntaxExpr fun [pred, b1, b2]
- Nothing -> return $ mkIfThenElse pred b1 b2 }
+ ; case fun of -- See Note [Rebindable if] in Hs.Expr
+ (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2]
+ NoSyntaxExprTc -> return $ mkIfThenElse pred b1 b2 }
ds_expr _ (HsMultiIf res_ty alts)
| null alts
@@ -741,7 +741,6 @@ ds_expr _ (HsBinTick _ ixT ixF e) = do
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
-ds_expr _ (XExpr nec) = noExtCon nec
ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr (HsPragSCC _ _ cc) expr = do
@@ -766,9 +765,9 @@ ds_prag_expr (XHsPragE x) _ = noExtCon x
------------------------------
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-dsSyntaxExpr (SyntaxExpr { syn_expr = expr
- , syn_arg_wraps = arg_wraps
- , syn_res_wrap = res_wrap })
+dsSyntaxExpr (SyntaxExprTc { syn_expr = expr
+ , syn_arg_wraps = arg_wraps
+ , syn_res_wrap = res_wrap })
arg_exprs
= do { fun <- dsExpr expr
; core_arg_wraps <- mapM dsHsWrapper arg_wraps
@@ -778,6 +777,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr
(\_ -> core_res_wrap (mkApps fun wrapped_args)) }
where
mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
+dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField rbinds sel
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index fe60cb8001..a424bd9d7b 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -29,7 +29,6 @@ import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTm
import DsMonad
import DsUtils
import Type ( Type )
-import Name
import Util
import SrcLoc
import Outputable
@@ -55,7 +54,7 @@ dsGuarded grhss rhs_ty = do
-- In contrast, @dsGRHSs@ produces a @MatchResult@.
-dsGRHSs :: HsMatchContext Name
+dsGRHSs :: HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
@@ -68,7 +67,7 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
; return match_result2 }
dsGRHSs _ (XGRHSs nec) _ = noExtCon nec
-dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
+dsGRHS :: HsMatchContext GhcRn -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
@@ -83,7 +82,7 @@ dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec
-}
matchGuards :: [GuardStmt GhcTc] -- Guard
- -> HsStmtContext Name -- Context
+ -> HsStmtContext GhcRn -- Context
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
-> DsM MatchResult
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 9dcbc8faaa..5473682a40 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1971,9 +1971,10 @@ repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
; repPaspat x' p1 }
repP (ParPat _ p) = repLP p
repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
- ; e' <- repE (syn_expr e)
- ; repPview e' p}
+repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)
+ ; e' <- repE e
+ ; repPview e' p}
+repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps)
repP (TuplePat _ ps boxed)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 2af170be5f..998d46395d 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -97,7 +97,7 @@ import Data.IORef
-}
data DsMatchContext
- = DsMatchContext (HsMatchContext Name) SrcSpan
+ = DsMatchContext (HsMatchContext GhcRn) SrcSpan
deriving ()
instance Outputable DsMatchContext where
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index ac277893f6..d6ddfb894a 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -694,7 +694,7 @@ Call @match@ with all of this information!
-}
matchWrapper
- :: HsMatchContext Name -- ^ For shadowing warning messages
+ :: HsMatchContext GhcRn -- ^ For shadowing warning messages
-> Maybe (LHsExpr GhcTc) -- ^ Scrutinee. (Just scrut) for a case expr
-- case scrut of { p1 -> e1 ... }
-- (and in this case the MatchGroup will
@@ -775,7 +775,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
else id
matchWrapper _ _ (XMatchGroup nec) = noExtCon nec
-matchEquations :: HsMatchContext Name
+matchEquations :: HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations ctxt vars eqns_info rhs_ty
@@ -799,7 +799,7 @@ pattern. It returns an expression.
-}
matchSimply :: CoreExpr -- ^ Scrutinee
- -> HsMatchContext Name -- ^ Match kind
+ -> HsMatchContext GhcRn -- ^ Match kind
-> LPat GhcTc -- ^ Pattern it should match
-> CoreExpr -- ^ Return this if it matches
-> CoreExpr -- ^ Return this if it doesn't
@@ -813,7 +813,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
+matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
-> Type -> MatchResult -> DsM MatchResult
-- matchSinglePat ensures that the scrutinee is a variable
-- and then calls matchSinglePatVar
@@ -832,7 +832,7 @@ matchSinglePat scrut hs_ctx pat ty match_result
; return (adjustMatchResult (bindNonRec var scrut) match_result') }
matchSinglePatVar :: Id -- See Note [Match Ids]
- -> HsMatchContext Name -> LPat GhcTc
+ -> HsMatchContext GhcRn -> LPat GhcTc
-> Type -> MatchResult -> DsM MatchResult
matchSinglePatVar var ctx pat ty match_result
= ASSERT2( isInternalName (idName var), ppr var )
@@ -1014,7 +1014,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp e (HsPar _ (L _ e')) = exp e e'
-- because the expressions do not necessarily have the same type,
-- we have to compare the wrappers
- exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+ exp (XExpr (HsWrap h e)) (XExpr (HsWrap h' e')) = wrap h h' && exp e e'
exp (HsVar _ i) (HsVar _ i') = i == i'
exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
-- the instance for IPName derives using the id, so this works if the
@@ -1053,15 +1053,17 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
---------
syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
- syn_exp (SyntaxExpr { syn_expr = expr1
- , syn_arg_wraps = arg_wraps1
- , syn_res_wrap = res_wrap1 })
- (SyntaxExpr { syn_expr = expr2
- , syn_arg_wraps = arg_wraps2
- , syn_res_wrap = res_wrap2 })
+ syn_exp (SyntaxExprTc { syn_expr = expr1
+ , syn_arg_wraps = arg_wraps1
+ , syn_res_wrap = res_wrap1 })
+ (SyntaxExprTc { syn_expr = expr2
+ , syn_arg_wraps = arg_wraps2
+ , syn_res_wrap = res_wrap2 })
= exp expr1 expr2 &&
and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
wrap res_wrap1 res_wrap2
+ syn_exp NoSyntaxExprTc NoSyntaxExprTc = True
+ syn_exp _ _ = False
---------
tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot
index be5cd766ea..6d6cf989df 100644
--- a/compiler/deSugar/Match.hs-boot
+++ b/compiler/deSugar/Match.hs-boot
@@ -6,8 +6,7 @@ import TcType ( Type )
import DsMonad ( DsM, EquationInfo, MatchResult )
import CoreSyn ( CoreExpr )
import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr )
-import Name ( Name )
-import GHC.Hs.Extension ( GhcTc )
+import GHC.Hs.Extension ( GhcRn, GhcTc )
match :: [Id]
-> Type
@@ -15,14 +14,14 @@ match :: [Id]
-> DsM MatchResult
matchWrapper
- :: HsMatchContext Name
+ :: HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchSimply
:: CoreExpr
- -> HsMatchContext Name
+ -> HsMatchContext GhcRn
-> LPat GhcTc
-> CoreExpr
-> CoreExpr
@@ -30,7 +29,7 @@ matchSimply
matchSinglePatVar
:: Id
- -> HsMatchContext Name
+ -> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 59a93362bd..c965973403 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -347,7 +347,6 @@ Library
GHC.Hs.Expr
GHC.Hs.ImpExp
GHC.Hs.Lit
- GHC.Hs.PlaceHolder
GHC.Hs.Extension
GHC.Hs.Instances
GHC.Hs.Pat
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 8f9be68f5a..8d3757f563 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2439,7 +2439,7 @@ decl_no_th :: { LHsDecl GhcPs }
-- a FunBind or PatBind back from checkValDef. See Note
-- [FunBind vs PatBind]
case r of {
- (FunBind _ n _ _ _) ->
+ (FunBind _ n _ _) ->
amsL l (mj AnnFunId n:(fst $2)) >> return () ;
(PatBind _ (L lh _lhs) _rhs _) ->
amsL lh (fst $2) >> return () } ;
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index b2e8806caa..a4ca9aaf76 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -56,7 +56,7 @@ module RdrHsSyn (
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
checkPattern_msg,
- checkMonadComp, -- P (HsStmtContext RdrName)
+ checkMonadComp, -- P (HsStmtContext GhcPs)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
@@ -111,7 +111,6 @@ import CoAxiom ( Role, fsFromRole )
import RdrName
import Name
import BasicTypes
-import TcEvidence ( idHsWrapper )
import Lexer
import Lexeme ( isLexCon )
import Type ( TyThing(..), funTyCon )
@@ -1194,7 +1193,6 @@ makeFunBind fn ms
= FunBind { fun_ext = noExtField,
fun_id = fn,
fun_matches = mkMatchGroup FromSource ms,
- fun_co_fn = idHsWrapper,
fun_tick = [] }
-- See Note [FunBind vs PatBind]
@@ -1675,7 +1673,7 @@ mergeDataCon all_xs =
-- If the flag MonadComprehensions is set, return a 'MonadComp' context,
-- otherwise use the usual 'ListComp' context
-checkMonadComp :: PV (HsStmtContext Name)
+checkMonadComp :: PV (HsStmtContext GhcRn)
checkMonadComp = do
monadComprehensions <- getBit MonadComprehensionsBit
return $ if monadComprehensions
@@ -2275,7 +2273,7 @@ data Frame
-- ^ If-expression: if p then x else y
| FrameCase LFrame [LFrameMatch]
-- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }
- | FrameDo (HsStmtContext Name) [LFrameStmt]
+ | FrameDo (HsStmtContext GhcRn) [LFrameStmt]
-- ^ Do-expression: do { s1; a <- s2; s3 }
...
| FrameExpr (HsExpr GhcPs) -- unambiguously an expression
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index 7bdcac865d..0dd83837e2 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -30,7 +30,6 @@ import TcOrigin
import TcEvidence
import Id( mkLocalId )
import Inst
-import Name
import TysWiredIn
import VarSet
import TysPrim
@@ -161,14 +160,14 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
; tcCmd env body (stk, res_ty') }
-tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty -- Ordinary 'if'
+tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if'
= do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
- ; return (HsCmdIf x Nothing pred' b1' b2')
+ ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2')
}
-tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
+tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if
= do { pred_ty <- newOpenFlexiTyVarTy
-- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
-- because we're going to apply it to the environment, not
@@ -184,7 +183,7 @@ tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
; b1' <- tcCmd env b1 res_ty
; b2' <- tcCmd env b2 res_ty
- ; return (HsCmdIf x (Just fun') pred' b1' b2')
+ ; return (HsCmdIf x fun' pred' b1' b2')
}
-------------------------------------------
@@ -267,7 +266,7 @@ tc_cmd env
; return (mkHsCmdWrap (mkWpCastN co) cmd') }
where
n_pats = length pats
- match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr?
+ match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr?
pg_ctxt = PatGuard match_ctxt
tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 06b0a821c0..d848f76c2e 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -713,8 +713,7 @@ tcPolyCheck prag_fn
; tick <- funBindTicks nm_loc mono_id mod prag_sigs
; let bind' = FunBind { fun_id = L nm_loc mono_id
, fun_matches = matches'
- , fun_co_fn = co_fn
- , fun_ext = placeHolderNamesTc
+ , fun_ext = co_fn
, fun_tick = tick }
export = ABE { abe_ext = noExtField
@@ -1250,8 +1249,7 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur
-> TcM (LHsBinds GhcTcId, [MonoBindInfo])
tcMonoBinds is_rec sig_fn no_gen
[ L b_loc (FunBind { fun_id = L nm_loc name
- , fun_matches = matches
- , fun_ext = fvs })]
+ , fun_matches = matches })]
-- Single function binding,
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, Nothing <- sig_fn name -- ...with no type signature
@@ -1276,8 +1274,8 @@ tcMonoBinds is_rec sig_fn no_gen
; mono_id <- newLetBndr no_gen name rhs_ty
; return (unitBag $ L b_loc $
FunBind { fun_id = L nm_loc mono_id,
- fun_matches = matches', fun_ext = fvs,
- fun_co_fn = co_fn, fun_tick = [] },
+ fun_matches = matches',
+ fun_ext = co_fn, fun_tick = [] },
[MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id }]) }
@@ -1424,8 +1422,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
matches (mkCheckExpType $ idType mono_id)
; return ( FunBind { fun_id = L loc mono_id
, fun_matches = matches'
- , fun_co_fn = co_fn
- , fun_ext = placeHolderNamesTc
+ , fun_ext = co_fn
, fun_tick = [] } ) }
tcRhs (TcPatBind infos pat' grhss pat_ty)
@@ -1438,7 +1435,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
tcGRHSsPat grhss pat_ty
; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
- , pat_ext = NPatBindTc placeHolderNamesTc pat_ty
+ , pat_ext = NPatBindTc emptyNameSet pat_ty
, pat_ticks = ([],[]) } )}
tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 8749f98484..eedc2f5b3d 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -3,8 +3,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an
-- orphan
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.Hs.PlaceHolder
+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
+ -- in module GHC.Hs.Extension
{-# LANGUAGE TypeFamilies #-}
module TcEnv(
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 845b81bb23..6fd9585e8a 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -534,7 +534,7 @@ tcExpr (HsCase x scrut matches) res_ty
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcBody }
-tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if'
+tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if'
= do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
; res_ty <- tauifyExpType res_ty
-- Just like Note [Case branches must never infer a non-tau type]
@@ -542,9 +542,9 @@ tcExpr (HsIf x Nothing pred b1 b2) res_ty -- Ordinary 'if'
; b1' <- tcMonoExpr b1 res_ty
; b2' <- tcMonoExpr b2 res_ty
- ; return (HsIf x Nothing pred' b1' b2') }
+ ; return (HsIf x NoSyntaxExprTc pred' b1' b2') }
-tcExpr (HsIf x (Just fun) pred b1 b2) res_ty
+tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty
= do { ((pred', b1', b2'), fun')
<- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
\ [pred_ty, b1_ty, b2_ty] ->
@@ -552,7 +552,7 @@ tcExpr (HsIf x (Just fun) pred b1 b2) res_ty
; b1' <- tcPolyExpr b1 b1_ty
; b2' <- tcPolyExpr b2 b2_ty
; return (pred', b1', b2') }
- ; return (HsIf x (Just fun') pred' b1' b2') }
+ ; return (HsIf x fun' pred' b1' b2') }
tcExpr (HsMultiIf _ alts) res_ty
= do { res_ty <- if isSingleton alts
@@ -1401,11 +1401,11 @@ tcTupArgs args tys
---------------------------
-- See TcType.SyntaxOpType also for commentary
tcSyntaxOp :: CtOrigin
- -> SyntaxExpr GhcRn
+ -> SyntaxExprRn
-> [SyntaxOpType] -- ^ shape of syntax operator arguments
-> ExpRhoType -- ^ overall result type
-> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
- -> TcM (a, SyntaxExpr GhcTcId)
+ -> TcM (a, SyntaxExprTc)
-- ^ Typecheck a syntax operator
-- The operator is a variable or a lambda at this stage (i.e. renamer
-- output)
@@ -1415,21 +1415,22 @@ tcSyntaxOp orig expr arg_tys res_ty
-- | Slightly more general version of 'tcSyntaxOp' that allows the caller
-- to specify the shape of the result of the syntax operator
tcSyntaxOpGen :: CtOrigin
- -> SyntaxExpr GhcRn
+ -> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
- -> TcM (a, SyntaxExpr GhcTcId)
-tcSyntaxOpGen orig op arg_tys res_ty thing_inside
- = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op
+ -> TcM (a, SyntaxExprTc)
+tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside
+ = do { (expr, sigma) <- tcInferSigma $ noLoc op
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
; (result, expr_wrap, arg_wraps, res_wrap)
<- tcSynArgA orig sigma arg_tys res_ty $
thing_inside
; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )
- ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr
- , syn_arg_wraps = arg_wraps
- , syn_res_wrap = res_wrap }) }
+ ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap $ unLoc expr
+ , syn_arg_wraps = arg_wraps
+ , syn_res_wrap = res_wrap }) }
+tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"
{-
Note [tcSynArg]
diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot
index 3aa9952088..571e707752 100644
--- a/compiler/typecheck/TcExpr.hs-boot
+++ b/compiler/typecheck/TcExpr.hs-boot
@@ -1,6 +1,6 @@
module TcExpr where
import Name
-import GHC.Hs ( HsExpr, LHsExpr, SyntaxExpr )
+import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc )
import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )
import TcRnTypes( TcM )
import TcOrigin ( CtOrigin )
@@ -25,18 +25,18 @@ tcInferRho, tcInferRhoNC ::
-> TcM (LHsExpr GhcTcId, TcRhoType)
tcSyntaxOp :: CtOrigin
- -> SyntaxExpr GhcRn
+ -> SyntaxExprRn
-> [SyntaxOpType] -- ^ shape of syntax operator arguments
-> ExpType -- ^ overall result type
-> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
- -> TcM (a, SyntaxExpr GhcTcId)
+ -> TcM (a, SyntaxExprTc)
tcSyntaxOpGen :: CtOrigin
- -> SyntaxExpr GhcRn
+ -> SyntaxExprRn
-> [SyntaxOpType]
-> SyntaxOpType
-> ([TcSigmaType] -> TcM a)
- -> TcM (a, SyntaxExpr GhcTcId)
+ -> TcM (a, SyntaxExprTc)
tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
index 2f03cd0950..6cc3642b8b 100644
--- a/compiler/typecheck/TcGenFunctor.hs
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -224,7 +224,7 @@ gen_Functor_binds loc tycon
, ft_co_var = panic "contravariant in ft_replace" }
-- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
- match_for_con :: HsMatchContext RdrName
+ match_for_con :: HsMatchContext GhcPs
-> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]
-> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
match_for_con ctxt = mkSimpleConMatch ctxt $
@@ -463,7 +463,7 @@ mkSimpleLam2 lam =
-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
-- and its arguments, applying an expression (from @insides@) to each of the
-- respective arguments of @con@.
-mkSimpleConMatch :: Monad m => HsMatchContext RdrName
+mkSimpleConMatch :: Monad m => HsMatchContext GhcPs
-> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
@@ -499,7 +499,7 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do
--
-- See Note [Generated code for DeriveFoldable and DeriveTraversable]
mkSimpleConMatch2 :: Monad m
- => HsMatchContext RdrName
+ => HsMatchContext GhcPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs]
-> m (LHsExpr GhcPs))
-> [LPat GhcPs]
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 9db8880fc9..3ae4e63fc6 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -563,13 +563,13 @@ zonk_bind env (VarBind { var_ext = x
zonk_bind env bind@(FunBind { fun_id = L loc var
, fun_matches = ms
- , fun_co_fn = co_fn })
+ , fun_ext = co_fn })
= do { new_var <- zonkIdBndr env var
; (env1, new_co_fn) <- zonkCoFn env co_fn
; new_ms <- zonkMatchGroup env1 zonkLExpr ms
; return (bind { fun_id = L loc new_var
, fun_matches = new_ms
- , fun_co_fn = new_co_fn }) }
+ , fun_ext = new_co_fn }) }
zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abs_ev_binds = ev_binds
@@ -596,7 +596,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
| has_sig
, (L loc bind@(FunBind { fun_id = L mloc mono_id
, fun_matches = ms
- , fun_co_fn = co_fn })) <- lbind
+ , fun_ext = co_fn })) <- lbind
= do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
-- Specifically /not/ zonkIdBndr; we do not
-- want to complain about a levity-polymorphic binder
@@ -605,7 +605,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
; return $ L loc $
bind { fun_id = L mloc new_mono_id
, fun_matches = new_ms
- , fun_co_fn = new_co_fn } }
+ , fun_ext = new_co_fn } }
| otherwise
= zonk_lbind env lbind -- The normal case
@@ -847,18 +847,12 @@ zonkExpr env (HsCase x expr ms)
new_ms <- zonkMatchGroup env zonkLExpr ms
return (HsCase x new_expr new_ms)
-zonkExpr env (HsIf x Nothing e1 e2 e3)
- = do new_e1 <- zonkLExpr env e1
- new_e2 <- zonkLExpr env e2
- new_e3 <- zonkLExpr env e3
- return (HsIf x Nothing new_e1 new_e2 new_e3)
-
-zonkExpr env (HsIf x (Just fun) e1 e2 e3)
+zonkExpr env (HsIf x fun e1 e2 e3)
= do (env1, new_fun) <- zonkSyntaxExpr env fun
new_e1 <- zonkLExpr env1 e1
new_e2 <- zonkLExpr env1 e2
new_e3 <- zonkLExpr env1 e3
- return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
+ return (HsIf x new_fun new_e1 new_e2 new_e3)
zonkExpr env (HsMultiIf ty alts)
= do { alts' <- mapM (wrapLocM zonk_alt) alts
@@ -936,10 +930,10 @@ zonkExpr env (HsProc x pat body)
zonkExpr env (HsStatic fvs expr)
= HsStatic fvs <$> zonkLExpr env expr
-zonkExpr env (HsWrap x co_fn expr)
+zonkExpr env (XExpr (HsWrap co_fn expr))
= do (env1, new_co_fn) <- zonkCoFn env co_fn
new_expr <- zonkExpr env1 expr
- return (HsWrap x new_co_fn new_expr)
+ return (XExpr (HsWrap new_co_fn new_expr))
zonkExpr _ e@(HsUnboundVar {})
= return e
@@ -970,15 +964,16 @@ Now, we can safely just extend one environment.
-- See Note [Skolems in zonkSyntaxExpr]
zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId
-> TcM (ZonkEnv, SyntaxExpr GhcTc)
-zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr
+zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
= do { (env0, res_wrap') <- zonkCoFn env res_wrap
; expr' <- zonkExpr env0 expr
; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
- ; return (env1, SyntaxExpr { syn_expr = expr'
- , syn_arg_wraps = arg_wraps'
- , syn_res_wrap = res_wrap' }) }
+ ; return (env1, SyntaxExprTc { syn_expr = expr'
+ , syn_arg_wraps = arg_wraps'
+ , syn_res_wrap = res_wrap' }) }
+zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc)
-------------------------------------------------------------------------
@@ -987,10 +982,10 @@ zonkCmd :: ZonkEnv -> HsCmd GhcTcId -> TcM (HsCmd GhcTc)
zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
-zonkCmd env (HsCmdWrap x w cmd)
+zonkCmd env (XCmd (HsWrap w cmd))
= do { (env1, w') <- zonkCoFn env w
; cmd' <- zonkCmd env1 cmd
- ; return (HsCmdWrap x w' cmd') }
+ ; return (XCmd (HsWrap w' cmd')) }
zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
@@ -1021,14 +1016,11 @@ zonkCmd env (HsCmdCase x expr ms)
return (HsCmdCase x new_expr new_ms)
zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
- = do { (env1, new_eCond) <- zonkWit env eCond
+ = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond
; new_ePred <- zonkLExpr env1 ePred
; new_cThen <- zonkLCmd env1 cThen
; new_cElse <- zonkLCmd env1 cElse
; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
- where
- zonkWit env Nothing = return (env, Nothing)
- zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
zonkCmd env (HsCmdLet x (L l binds) cmd)
= do (new_env, new_binds) <- zonkLocalBinds env binds
@@ -1040,8 +1032,6 @@ zonkCmd env (HsCmdDo ty (L l stmts))
new_ty <- zonkTcTypeToTypeX env ty
return (HsCmdDo new_ty (L l new_stmts))
-zonkCmd _ (XCmd nec) = noExtCon nec
-
zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 62edfae0ed..96775696a9 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -1174,7 +1174,7 @@ addDFunPrags dfun_id sc_meth_ids
[dict_con] = tyConDataCons clas_tc
is_newtype = isNewTyCon clas_tc
-wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
+wrapId :: HsWrapper -> Id -> HsExpr GhcTc
wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id))
{- Note [Typechecking plan for instance declarations]
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index e373fe6b8f..8088602972 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -206,7 +206,7 @@ tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
-> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
- = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
+ = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is
mc_body :: Located (body GhcRn) -- Type checker for a body of
-- an alternative
-> ExpRhoType
@@ -291,7 +291,7 @@ tcGRHS _ _ (XGRHS nec) = noExtCon nec
************************************************************************
-}
-tcDoStmts :: HsStmtContext Name
+tcDoStmts :: HsStmtContext GhcRn
-> Located [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTcId) -- Returns a HsDo
@@ -338,13 +338,13 @@ type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
- = forall thing. HsStmtContext Name
+ = forall thing. HsStmtContext GhcRn
-> Stmt GhcRn (Located (body GhcRn))
-> rho_type -- Result type for comprehension
-> (rho_type -> TcM thing) -- Checker for what follows the stmt
-> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)
-tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
+tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
@@ -354,7 +354,7 @@ tcStmts ctxt stmt_chk stmts res_ty
const (return ())
; return stmts' }
-tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
+tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (Located (body GhcRn))]
-> rho_type
@@ -972,7 +972,7 @@ join :: tn -> res_ty
-}
tcApplicativeStmts
- :: HsStmtContext Name
+ :: HsStmtContext GhcRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType -- rhs_ty
-> (TcRhoType -> TcM t) -- thing_inside
diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs
index 6cf1dbb8d8..fd260f01ac 100644
--- a/compiler/typecheck/TcOrigin.hs
+++ b/compiler/typecheck/TcOrigin.hs
@@ -205,7 +205,7 @@ data SkolemInfo
| FamInstSkol -- Bound at a family instance decl
| PatSkol -- An existential type variable bound by a pattern for
ConLike -- a data constructor with an existential type.
- (HsMatchContext Name)
+ (HsMatchContext GhcRn)
-- e.g. data T = forall a. Eq a => MkT a
-- f (MkT x) = ...
-- The pattern MkT x will allocate an existential type
@@ -498,7 +498,7 @@ exprCtOrigin (SectionR _ _ _) = SectionOrigin
exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple"
exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum"
exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
-exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn)
+exprCtOrigin (HsIf _ (SyntaxExprRn syn) _ _ _) = exprCtOrigin syn
exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression"
exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs
exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e
@@ -517,7 +517,6 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
-exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap"
exprCtOrigin (XExpr nec) = noExtCon nec
-- | Extract a suitable CtOrigin from a MatchGroup
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 97664e9526..e610bf5182 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -82,7 +82,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
; tc_lpat pat pat_ty penv thing_inside }
-----------------
-tcPats :: HsMatchContext Name
+tcPats :: HsMatchContext GhcRn
-> [LPat GhcRn] -- Patterns,
-> [ExpSigmaType] -- and their types
-> TcM a -- and the checker for the body
@@ -104,14 +104,14 @@ tcPats ctxt pats pat_tys thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-tcPat :: HsMatchContext Name
+tcPat :: HsMatchContext GhcRn
-> LPat GhcRn -> ExpSigmaType
-> TcM a -- Checker for body
-> TcM (LPat GhcTcId, a)
tcPat ctxt = tcPat_O ctxt PatOrigin
-- | A variant of 'tcPat' that takes a custom origin
-tcPat_O :: HsMatchContext Name
+tcPat_O :: HsMatchContext GhcRn
-> CtOrigin -- ^ origin to use if the type needs inst'ing
-> LPat GhcRn -> ExpSigmaType
-> TcM a -- Checker for body
@@ -138,7 +138,7 @@ data PatEnv
data PatCtxt
= LamPat -- Used for lambdas, case etc
- (HsMatchContext Name)
+ (HsMatchContext GhcRn)
| LetPat -- Used only for let(rec) pattern bindings
-- See Note [Typing patterns in pattern bindings]
@@ -604,8 +604,18 @@ tc_pat penv (NPlusKPat _ (L nm_loc name)
; res <- tcExtendIdEnv1 name bndr_id thing_inside
- ; let minus'' = minus' { syn_res_wrap =
- minus_wrap <.> syn_res_wrap minus' }
+ ; let minus'' = case minus' of
+ NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
+ -- this should be statically avoidable
+ -- Case (3) from Note [NoSyntaxExpr] in Hs.Expr
+ SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus'_res_wrap }
+ -> SyntaxExprTc { syn_expr = minus'_expr
+ , syn_arg_wraps = minus'_arg_wraps
+ , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
+ -- Oy. This should really be a record update, but
+ -- we get warnings if we try. #17783
pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
ge' minus''
; return (pat', res) }
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 21f20c552d..ff90b473b2 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -751,10 +751,9 @@ tcPatSynMatcher (L loc name) lpat
, mg_origin = Generated
}
- ; let bind = FunBind{ fun_ext = emptyNameSet
- , fun_id = L loc matcher_id
+ ; let bind = FunBind{ fun_id = L loc matcher_id
, fun_matches = mg
- , fun_co_fn = idHsWrapper
+ , fun_ext = idHsWrapper
, fun_tick = [] }
matcher_bind = unitBag (noLoc bind)
@@ -841,10 +840,9 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name
let match_group' | need_dummy_arg = add_dummy_arg match_group
| otherwise = match_group
- bind = FunBind { fun_ext = placeHolderNamesTc
- , fun_id = L loc (idName builder_id)
+ bind = FunBind { fun_id = L loc (idName builder_id)
, fun_matches = match_group'
- , fun_co_fn = idHsWrapper
+ , fun_ext = emptyNameSet
, fun_tick = [] }
sig = completeSigFromId (PatSynCtxt name) builder_id
@@ -973,8 +971,9 @@ tcPatToExpr name args pat = go pat
}
go1 (LitPat _ lit) = return $ HsLit noExtField lit
go1 (NPat _ (L _ n) mb_neg _)
- | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg
- [noLoc (HsOverLit noExtField n)]
+ | Just (SyntaxExprRn neg) <- mb_neg
+ = return $ unLoc $ foldl' nlHsApp (noLoc neg)
+ [noLoc (HsOverLit noExtField n)]
| otherwise = return $ HsOverLit noExtField n
go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
go1 (CoPat{}) = panic "CoPat in output of renamer"