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