diff options
| author | Richard Eisenberg <rae@richarde.dev> | 2019-10-15 15:33:27 +0100 |
|---|---|---|
| committer | Richard Eisenberg <rae@richarde.dev> | 2019-10-16 10:05:16 +0100 |
| commit | a18be4c81b8abb59874e4e04c1cec265fa072c86 (patch) | |
| tree | b32b7b2229277b2891b362b8145db6f6400fa745 | |
| parent | be8d71d07b39f503ba9a7fc66b6735cb1da605c9 (diff) | |
| download | haskell-wip/rae/remove-tc-dep.tar.gz | |
Break dependency from HsSyn on the typechecker.wip/rae/remove-tc-dep
There are three reasons that HsSyn has depended
on the type-checker.
1. The AST contains HsWrappers in a variety of places -- notably,
in expressions. HsWrappers are part of type-checker evidence,
and they are declared in TcEvidence.
2. In a few places (notably, AbsBinds), the AST contains a TcEvBinds.
TcEvBinds is also declared in TcEvidence.
3. Expressions can contain *delayed splices*. See Note [Running typed
splices in the zonker] in Hs.Expr. A DelayedSplice structure needs
a reference to a TcLclEnv, declared in TcRnTypes and rather
intimately tied to the type-checker.
The third of these is the most pernicious, because it requires
a dependency on a central module within the type-checker. TcEvidence,
on the other hand, might conceivably be moved out from the type-checker.
This patch removes all three dependencies. The magic is all
in Note [Abstract data] in Hs.Extension. In order to support this
change, this patch also introduces some new constraints in Hs.Extension.
Specifically, we now have IsGhcPass, which allows functions to
do a runtiem (of GHC) check to see what phase we're in, in order
to do custom processing in one phase or another.
Somewhat separately, this patch also moves HsWrap and HsCmdWrap
into an extension field. CoPat should get the same treatment, but
is not included in this patch. And, of course, there are many other
places that constructors should be moved to extension fields (like
ConPatOut). This change is actually orthogonal to the
dependency-dropping, but it seemed convenient to do them all together.
This patch subsumes !1721 (sorry @chreekat).
44 files changed, 821 insertions, 695 deletions
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index aa345f1476..0491ed5633 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -50,7 +50,7 @@ import GHC.Hs.Types import BasicTypes ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc -import GHC.Hs.Instances () -- For Data instances +import GHC.Hs.Instances ( DataX ) -- For Data instances -- others: import Outputable @@ -114,9 +114,9 @@ data HsModule pass -- For details on above see note [Api annotations] in ApiAnnotation -- deriving instance (DataIdLR name name) => Data (HsModule name) -deriving instance Data (HsModule GhcPs) -deriving instance Data (HsModule GhcRn) -deriving instance Data (HsModule GhcTc) +deriving instance DataX => Data (HsModule GhcPs) +deriving instance DataX => Data (HsModule GhcRn) +deriving instance DataX => Data (HsModule GhcTc) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 01c10b1ea1..074da0353a 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -16,6 +16,8 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module GHC.Hs.Binds where @@ -29,7 +31,7 @@ import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) import GHC.Hs.Extension import GHC.Hs.Types import CoreSyn -import TcEvidence +import PprCore () -- Outputable (Tickish id) import Type import NameSet import BasicTypes @@ -218,29 +220,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, 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 } @@ -292,7 +294,7 @@ data HsBindLR idL idR -- | Evidence bindings -- Why a list? See TcInstDcls -- Note [Typechecking plan for instance declarations] - abs_ev_binds :: [TcEvBinds], + abs_ev_binds :: [XTcEvBinds], -- | Typechecked user bindings abs_binds :: LHsBinds idL, @@ -319,8 +321,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 = XHsWrapper -- See comments on FunBind.fun_ext type instance XPatBind GhcPs (GhcPass pR) = NoExtField type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables @@ -349,7 +351,7 @@ data ABExport p = ABE { abe_ext :: XABE p , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id , abe_mono :: IdP p - , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] + , abe_wrap :: XHsWrapper -- ^ See Note [ABExport wrapper] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas } @@ -683,19 +685,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 @@ -730,7 +719,8 @@ instance (idL ~ GhcPass pl, idR ~ GhcPass pr, => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) +ppr_monobind :: forall idL idR. + (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) @@ -738,14 +728,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 @@ -761,7 +752,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 @@ -770,7 +761,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport 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 @pass $ nest 2 (text "wrap:" <+> ppr wrap) ] ppr (XABExport x) = ppr x instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, @@ -825,20 +816,12 @@ data HsIPBinds id type instance XIPBinds GhcPs = NoExtField type instance XIPBinds GhcRn = NoExtField -type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the - -- implicit parameters +type instance XIPBinds GhcTc = XTcEvBinds -- binds uses of the + -- implicit parameters type instance XXHsIPBinds (GhcPass p) = NoExtCon -isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool -isEmptyIPBindsPR (IPBinds _ is) = null is -isEmptyIPBindsPR (XHsIPBinds _) = True - -isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool -isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -isEmptyIPBindsTc (XHsIPBinds _) = True - -- | Located Implicit Parameter Binding type LIPBind id = Located (IPBind id) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a @@ -869,7 +852,7 @@ type instance XXIPBind (GhcPass p) = NoExtCon instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsIPBinds p) where ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) - $$ whenPprDebug (ppr ds) + $$ whenPprDebug (pprIfTc @pass $ ppr ds) ppr (XHsIPBinds x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where @@ -1076,7 +1059,6 @@ data TcSpecPrags = IsDefaultMethod -- ^ Super-specialised: a default method should -- be macro-expanded at every call site | SpecPrags [LTcSpecPrag] - deriving Data -- | Located Type checker Specification Pragmas type LTcSpecPrag = Located TcSpecPrag @@ -1085,11 +1067,10 @@ type LTcSpecPrag = Located TcSpecPrag data TcSpecPrag = SpecPrag Id - HsWrapper + XHsWrapper InlinePragma -- ^ The Id to be specialised, a wrapper that specialises the -- polymorphic function, and inlining spec for the specialised function - deriving Data noSpecPrags :: TcSpecPrags noSpecPrags = SpecPrags [] diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index c43a27cef2..7ceeae8b1b 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -11,6 +11,8 @@ -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Abstract syntax of global declarations. -- @@ -1956,7 +1958,10 @@ instance (p ~ GhcPass pass, 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/Dump.hs b/compiler/GHC/Hs/Dump.hs index 5bdfc8668e..eec7d1d60d 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -4,6 +4,7 @@ -} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} -- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb -- traversal which falls back to displaying based on the constructor name, so @@ -26,6 +27,7 @@ import Name import DataCon import SrcLoc import GHC.Hs +import GHC.Hs.Instances import OccName hiding (occName) import Var import Module @@ -39,7 +41,7 @@ data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan -- | Show a GHC syntax tree. This parameterised because it is also used for -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked -- out, to avoid comparing locations, only structure -showAstData :: Data a => BlankSrcSpan -> a -> SDoc +showAstData :: (DataX, Data a) => BlankSrcSpan -> a -> SDoc showAstData b a0 = blankLine $$ showAstData' a0 where showAstData' :: Data a => a -> SDoc diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index cd1a9f62bd..5db0be2b21 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -12,6 +12,9 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} -- | Abstract Haskell syntax for expressions. module GHC.Hs.Expr where @@ -30,7 +33,6 @@ import GHC.Hs.Types import GHC.Hs.Binds -- others: -import TcEvidence import CoreSyn import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) import Name @@ -43,8 +45,6 @@ import Util import Outputable import FastString import Type -import TcType (TcType) -import {-# SOURCE #-} TcRnTypes (TcLclEnv) -- libraries: import Data.Data hiding (Fixity(..)) @@ -93,6 +93,21 @@ type PostTcTable = [(Name, PostTcExpr)] -- 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 + +-- this allows for better type inference, because we can declare +-- SyntaxExprGhc to be injective (and closed). +type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p + +type family SyntaxExprGhc (p :: Pass) = (r :: *) | r -> p where + SyntaxExprGhc 'Parsed = NoExtField + SyntaxExprGhc 'Renamed = Maybe (HsExpr GhcRn) -- Nothing when the slot makes no sense + -- Why is the payload not just a Name? + -- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr + SyntaxExprGhc 'Typechecked = SyntaxExprTc + + +-- | An expression with wrappers, used for rebindable syntax -- -- This should desugar to -- @@ -100,42 +115,36 @@ 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 = SyntaxExpr { syn_expr :: HsExpr GhcTc + , syn_arg_wraps :: [XHsWrapper] + , syn_res_wrap :: XHsWrapper } + | NoSyntaxExpr -- when the slot just doesn't make sense -- | 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) +noSyntaxExpr :: forall p. IsPass p => 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. +noSyntaxExpr = case pass @p of + GhcPs -> noExtField + GhcRn -> Nothing + GhcTc -> NoSyntaxExpr + +-- | Make a 'SyntaxExpr GhcRn' from an expression +-- Used only in getMonadFailOp. +-- See Note [Monad fail : Rebindable syntax, overloaded strings] in RnExpr +mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExpr GhcRn +mkSyntaxExpr = Just + +-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the +-- renamer). 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 +mkRnSyntaxExpr name = Just $ HsVar noExtField $ noLoc name -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (SyntaxExpr p) where +instance OutputableBndrId GhcTc => Outputable SyntaxExprTc where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -146,6 +155,8 @@ instance (p ~ GhcPass pass, OutputableBndrId p) <> braces (ppr res_wrap) else ppr expr + ppr NoSyntaxExpr = text "<no syntax expr>" + -- | Command Syntax Table (for Arrow syntax) type CmdSyntaxTable p = [(Name, HsExpr p)] -- See Note [CmdSyntaxTable] @@ -627,16 +638,6 @@ data HsExpr p -- See note [Pragma source text] in BasicTypes (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 @@ -653,12 +654,19 @@ 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 :: XHsWrapper -- See note [Record Update HsWrapper] + } + +-- | 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. +data HsWrap hs_syn = HsWrap XHsWrapper + (hs_syn GhcTc) -- --------------------------------------------------------------------- @@ -739,7 +747,10 @@ type instance XTick (GhcPass _) = NoExtField type instance XBinTick (GhcPass _) = NoExtField type instance XTickPragma (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 -- --------------------------------------------------------------------- @@ -1087,16 +1098,12 @@ ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", ppr expr ] -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 _ e []) = ppr e -ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps +ppr_expr (HsTcBracketOut _ 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] @@ -1126,15 +1133,24 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) text ")"] ppr_expr (HsRecFld _ f) = ppr f -ppr_expr (XExpr x) = ppr x +ppr_expr (XExpr x) = case pass @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 (GhcPass p)) => HsExpr (GhcPass p) -> Maybe SDoc + +ppr_infix_expr :: forall p. (OutputableBndrId (GhcPass 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 _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) -ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e -ppr_infix_expr _ = Nothing +ppr_infix_expr (XExpr x) + | GhcTc <- pass @p + , HsWrap _ e <- x + = ppr_infix_expr e +ppr_infix_expr _ = Nothing ppr_apps :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) @@ -1189,7 +1205,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. IsGhcPass p => PprPrec -> HsExpr p -> Bool hsExprNeedsParens p = go where go (HsVar{}) = False @@ -1223,7 +1239,6 @@ hsExprNeedsParens p = go go (ExprWithTySig{}) = p >= sigPrec go (ArithSeq{}) = False go (HsSCC{}) = p >= appPrec - go (HsWrap _ _ e) = go e go (HsSpliceE{}) = False go (HsBracket{}) = False go (HsRnBracketOut{}) = False @@ -1235,16 +1250,23 @@ hsExprNeedsParens p = go go (HsTickPragma _ _ _ _ (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 -isAtomicHsExpr :: HsExpr id -> Bool +isAtomicHsExpr :: forall id. IsGhcPass id => HsExpr id -> Bool -- True of a single token isAtomicHsExpr (HsVar {}) = True isAtomicHsExpr (HsConLikeOut {}) = True @@ -1253,9 +1275,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 @id + , HsWrap _ e <- x = isAtomicHsExpr e isAtomicHsExpr _ = False {- @@ -1359,11 +1383,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 @@ -1383,7 +1402,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 @@ -1475,8 +1500,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) @@ -1501,7 +1524,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 pass @p of + GhcPs -> ppr x + GhcRn -> ppr x + GhcTc -> case x of + HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc pprCmdArg (HsCmdTop _ cmd) @@ -2417,7 +2444,7 @@ instance Data ThModFinalizers where -- These are the arguments that are passed to `TcSplice.runTopSplice` data DelayedSplice = DelayedSplice - TcLclEnv -- The local environment to run the splice in + XTcLclEnv -- The local environment to run the splice in (LHsExpr GhcRn) -- The original renamed expression TcType -- The result type of running the splice, unzonked (LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result @@ -2621,10 +2648,10 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> thTyBrackets :: SDoc -> SDoc thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") -instance Outputable PendingRnSplice where +instance OutputableAbstract GhcRn => Outputable PendingRnSplice where ppr (PendingRnSplice _ n e) = pprPendingSplice n e -instance Outputable PendingTcSplice where +instance OutputableAbstract GhcTc => Outputable PendingTcSplice where ppr (PendingTcSplice n e) = pprPendingSplice n e {- diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot index 8fd8f3857a..a4b1070c77 100644 --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -20,13 +20,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 (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 35afc5f8d3..9426f4ecc2 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -12,6 +12,12 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableSuperClasses #-} module GHC.Hs.Extension where @@ -129,10 +135,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) @@ -143,6 +158,35 @@ type GhcRn = GhcPass 'Renamed -- Old 'Name' type param type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, type GhcTcId = GhcTc -- Old 'TcId' type param +-- | Allows us to check what phase we're in at GHC's runtime. +-- For example, this class allows us to write +-- > f :: forall p. IsGhcPass p => HsExpr 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. +class (p ~ GhcPass (GetPass p), IsGhcPass (NoGhcTc p), NoGhcTc p ~ NoGhcTc (NoGhcTc p)) => IsGhcPass p where + type GetPass p :: Pass + ghcPass :: GhcPass (GetPass p) + +instance IsGhcPass GhcPs where + type GetPass GhcPs = 'Parsed + ghcPass = GhcPs +instance IsGhcPass GhcRn where + type GetPass GhcRn = 'Renamed + ghcPass = GhcRn +instance IsGhcPass GhcTc where + type GetPass GhcTc = 'Typechecked + ghcPass = GhcTc + +-- | This variant of 'IsGhcPass' is convenient when you have (p :: Pass) +type IsPass p = IsGhcPass (GhcPass p) + +-- | This variant of 'ghcPass' is convenient when you have (p :: Pass) +pass :: forall p. IsPass p => GhcPass p +pass = ghcPass @(GhcPass p) + -- | Maps the "normal" id type for a given pass type family IdP p type instance IdP GhcPs = RdrName @@ -1130,37 +1174,6 @@ type ConvertIdX a 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 @id@ and the 'NameOrRdrName' type for it type OutputableBndrId id = @@ -1168,7 +1181,91 @@ type OutputableBndrId id = , OutputableBndr (IdP id) , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id))) , OutputableBndr (IdP (NoGhcTc id)) - , NoGhcTc id ~ NoGhcTc (NoGhcTc id) - , OutputableX id - , OutputableX (NoGhcTc id) + , OutputableAbstract id + , OutputableAbstract (NoGhcTc id) + , IsGhcPass id ) + +-- useful helper functions: +pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc +pprIfPs pp = case pass @p of GhcPs -> pp + _ -> empty + +pprIfRn :: forall p. IsPass p => (p ~ 'Renamed => SDoc) -> SDoc +pprIfRn pp = case pass @p of GhcRn -> pp + _ -> empty + +pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc +pprIfTc pp = case pass @p of GhcTc -> pp + _ -> empty + +{-------------------------------------------------------------------------- +-- Abstract data +--------------------------------------------------------------------------- + +These are defined in this module so they can be incoporated into e.g. +OutputableBndrId. + +Note [Abstract data] +~~~~~~~~~~~~~~~~~~~~ + +We wish to keep GHC as modular as possible, with an eye to, perhaps, breaking +it up into several packages some day. To do this, we want to avoid dependencies +from HsSyn on other seemingly-unrelated parts of the compiler. Specifically, +the type-checker should depend on HsSyn, not the other way around. Yet we +need to store type-checker information in the AST in a few places (notably, +HsWrap). + +To allow us to store type-checker datatypes in the HsSyn AST but without +taking a dependency, we use *nullary families*. The idea is that we +can define, say + + type family XHsWrapper + +but leave the (orphan) instance to be defined in the type-checker. No more +dependency. This works for both type and data families. + +The only real challenge is what to do with instances (e.g. Outputable and Data). +Only the code that has access to concrete representations can write these +instances meaningfully, so we must defer the instance declarations to e.g. +the type checker. But we need the instances available for writing e.g. +Outputable instances within HsSyn. We thus *absract* over the instances +by using e.g. the OutputableAbstract pattern below. A further wrinkle here +is that HsWrappers want a custom printing function (not just ppr), so we +need the nullary class OutputableHsWrapper. This class is instantiated +where we define HsWrapper concretely. + +-} + +------------------------- +-- | An HsWrapper is, essentially, a Core expression with a hole in it. +-- They are manufactured by the type-checker, and should appear in expressions +-- only after type-checking. We thus leave the definition abstract via +-- the use of a nullary type family. +-- See Note [Abstract data] +type family XHsWrapper + +class OutputableHsWrapper where + -- | With @-fprint-typechecker-elaboration@, print the wrapper + -- otherwise just print what's inside + -- The pp_thing_inside function takes Bool to say whether + -- it's in a position that needs parens for a non-atomic thing + pprHsWrapper :: XHsWrapper -> (Bool -> SDoc) -> SDoc + +-- | Abstract version of 'TcEvBinds' (used in 'AbsBinds') +type family XTcEvBinds + +-- | Abstract version of 'TcLclEnv' (used for delayed splices) +-- See Note [Running typed splices in the zonker] in GHC.Hs.Expr +type family XTcLclEnv + +-- | A summary constraint assuming Outputable for abstract types. +-- Defining this as a type family (and thus allowing us to avoid +-- the need for XHsWrapper and XTcEvBinds in the GhcPs and GhcRn +-- cases) means that the parser needn't depend on the type-checker. +type family OutputableAbstract p :: Constraint +type instance OutputableAbstract GhcPs = () +type instance OutputableAbstract GhcRn = () +type instance OutputableAbstract GhcTc = ( Outputable XHsWrapper + , Outputable XTcEvBinds + , OutputableHsWrapper ) diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index b3a33df43c..ef147e3193 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.Hs.Instances where @@ -27,399 +28,406 @@ import GHC.Hs.Pat import GHC.Hs.ImpExp -- --------------------------------------------------------------------- +-- Data for abstract families. See Note [Abstract families] in GHC.Hs.Extension. +type DataX = (Data XHsWrapper, Data XTcEvBinds) + +-- --------------------------------------------------------------------- -- Data derivations from GHC.Hs----------------------------------------- -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Binds ---------------------------------- -- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR) -deriving instance Data (HsLocalBindsLR GhcPs GhcPs) -deriving instance Data (HsLocalBindsLR GhcPs GhcRn) -deriving instance Data (HsLocalBindsLR GhcRn GhcRn) -deriving instance Data (HsLocalBindsLR GhcTc GhcTc) +deriving instance DataX => Data (HsLocalBindsLR GhcPs GhcPs) +deriving instance DataX => Data (HsLocalBindsLR GhcPs GhcRn) +deriving instance DataX => Data (HsLocalBindsLR GhcRn GhcRn) +deriving instance DataX => Data (HsLocalBindsLR GhcTc GhcTc) -- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR) -deriving instance Data (HsValBindsLR GhcPs GhcPs) -deriving instance Data (HsValBindsLR GhcPs GhcRn) -deriving instance Data (HsValBindsLR GhcRn GhcRn) -deriving instance Data (HsValBindsLR GhcTc GhcTc) +deriving instance DataX => Data (HsValBindsLR GhcPs GhcPs) +deriving instance DataX => Data (HsValBindsLR GhcPs GhcRn) +deriving instance DataX => Data (HsValBindsLR GhcRn GhcRn) +deriving instance DataX => Data (HsValBindsLR GhcTc GhcTc) -- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) -deriving instance Data (NHsValBindsLR GhcPs) -deriving instance Data (NHsValBindsLR GhcRn) -deriving instance Data (NHsValBindsLR GhcTc) +deriving instance DataX => Data (NHsValBindsLR GhcPs) +deriving instance DataX => Data (NHsValBindsLR GhcRn) +deriving instance DataX => Data (NHsValBindsLR GhcTc) -- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) -deriving instance Data (HsBindLR GhcPs GhcPs) -deriving instance Data (HsBindLR GhcPs GhcRn) -deriving instance Data (HsBindLR GhcRn GhcRn) -deriving instance Data (HsBindLR GhcTc GhcTc) +deriving instance DataX => Data (HsBindLR GhcPs GhcPs) +deriving instance DataX => Data (HsBindLR GhcPs GhcRn) +deriving instance DataX => Data (HsBindLR GhcRn GhcRn) +deriving instance DataX => Data (HsBindLR GhcTc GhcTc) -- deriving instance (DataId p) => Data (ABExport p) -deriving instance Data (ABExport GhcPs) -deriving instance Data (ABExport GhcRn) -deriving instance Data (ABExport GhcTc) +deriving instance DataX => Data (ABExport GhcPs) +deriving instance DataX => Data (ABExport GhcRn) +deriving instance DataX => Data (ABExport GhcTc) -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) -deriving instance Data (PatSynBind GhcPs GhcPs) -deriving instance Data (PatSynBind GhcPs GhcRn) -deriving instance Data (PatSynBind GhcRn GhcRn) -deriving instance Data (PatSynBind GhcTc GhcTc) +deriving instance DataX => Data (PatSynBind GhcPs GhcPs) +deriving instance DataX => Data (PatSynBind GhcPs GhcRn) +deriving instance DataX => Data (PatSynBind GhcRn GhcRn) +deriving instance DataX => Data (PatSynBind GhcTc GhcTc) -- deriving instance (DataIdLR p p) => Data (HsIPBinds p) -deriving instance Data (HsIPBinds GhcPs) -deriving instance Data (HsIPBinds GhcRn) -deriving instance Data (HsIPBinds GhcTc) +deriving instance DataX => Data (HsIPBinds GhcPs) +deriving instance DataX => Data (HsIPBinds GhcRn) +deriving instance DataX => Data (HsIPBinds GhcTc) -- deriving instance (DataIdLR p p) => Data (IPBind p) -deriving instance Data (IPBind GhcPs) -deriving instance Data (IPBind GhcRn) -deriving instance Data (IPBind GhcTc) +deriving instance DataX => Data (IPBind GhcPs) +deriving instance DataX => Data (IPBind GhcRn) +deriving instance DataX => Data (IPBind GhcTc) -- deriving instance (DataIdLR p p) => Data (Sig p) -deriving instance Data (Sig GhcPs) -deriving instance Data (Sig GhcRn) -deriving instance Data (Sig GhcTc) +deriving instance DataX => Data (Sig GhcPs) +deriving instance DataX => Data (Sig GhcRn) +deriving instance DataX => Data (Sig GhcTc) -- deriving instance (DataId p) => Data (FixitySig p) -deriving instance Data (FixitySig GhcPs) -deriving instance Data (FixitySig GhcRn) -deriving instance Data (FixitySig GhcTc) +deriving instance DataX => Data (FixitySig GhcPs) +deriving instance DataX => Data (FixitySig GhcRn) +deriving instance DataX => Data (FixitySig GhcTc) -- deriving instance (DataId p) => Data (StandaloneKindSig p) -deriving instance Data (StandaloneKindSig GhcPs) -deriving instance Data (StandaloneKindSig GhcRn) -deriving instance Data (StandaloneKindSig GhcTc) +deriving instance DataX => Data (StandaloneKindSig GhcPs) +deriving instance DataX => Data (StandaloneKindSig GhcRn) +deriving instance DataX => Data (StandaloneKindSig GhcTc) -- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) -deriving instance Data (HsPatSynDir GhcPs) -deriving instance Data (HsPatSynDir GhcRn) -deriving instance Data (HsPatSynDir GhcTc) +deriving instance DataX => Data (HsPatSynDir GhcPs) +deriving instance DataX => Data (HsPatSynDir GhcRn) +deriving instance DataX => Data (HsPatSynDir GhcTc) + +deriving instance DataX => Data TcSpecPrag +deriving instance DataX => Data TcSpecPrags -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Decls ---------------------------------- -- deriving instance (DataIdLR p p) => Data (HsDecl p) -deriving instance Data (HsDecl GhcPs) -deriving instance Data (HsDecl GhcRn) -deriving instance Data (HsDecl GhcTc) +deriving instance DataX => Data (HsDecl GhcPs) +deriving instance DataX => Data (HsDecl GhcRn) +deriving instance DataX => Data (HsDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (HsGroup p) -deriving instance Data (HsGroup GhcPs) -deriving instance Data (HsGroup GhcRn) -deriving instance Data (HsGroup GhcTc) +deriving instance DataX => Data (HsGroup GhcPs) +deriving instance DataX => Data (HsGroup GhcRn) +deriving instance DataX => Data (HsGroup GhcTc) -- deriving instance (DataIdLR p p) => Data (SpliceDecl p) -deriving instance Data (SpliceDecl GhcPs) -deriving instance Data (SpliceDecl GhcRn) -deriving instance Data (SpliceDecl GhcTc) +deriving instance DataX => Data (SpliceDecl GhcPs) +deriving instance DataX => Data (SpliceDecl GhcRn) +deriving instance DataX => Data (SpliceDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (TyClDecl p) -deriving instance Data (TyClDecl GhcPs) -deriving instance Data (TyClDecl GhcRn) -deriving instance Data (TyClDecl GhcTc) +deriving instance DataX => Data (TyClDecl GhcPs) +deriving instance DataX => Data (TyClDecl GhcRn) +deriving instance DataX => Data (TyClDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (TyClGroup p) -deriving instance Data (TyClGroup GhcPs) -deriving instance Data (TyClGroup GhcRn) -deriving instance Data (TyClGroup GhcTc) +deriving instance DataX => Data (TyClGroup GhcPs) +deriving instance DataX => Data (TyClGroup GhcRn) +deriving instance DataX => Data (TyClGroup GhcTc) -- deriving instance (DataIdLR p p) => Data (FamilyResultSig p) -deriving instance Data (FamilyResultSig GhcPs) -deriving instance Data (FamilyResultSig GhcRn) -deriving instance Data (FamilyResultSig GhcTc) +deriving instance DataX => Data (FamilyResultSig GhcPs) +deriving instance DataX => Data (FamilyResultSig GhcRn) +deriving instance DataX => Data (FamilyResultSig GhcTc) -- deriving instance (DataIdLR p p) => Data (FamilyDecl p) -deriving instance Data (FamilyDecl GhcPs) -deriving instance Data (FamilyDecl GhcRn) -deriving instance Data (FamilyDecl GhcTc) +deriving instance DataX => Data (FamilyDecl GhcPs) +deriving instance DataX => Data (FamilyDecl GhcRn) +deriving instance DataX => Data (FamilyDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (InjectivityAnn p) -deriving instance Data (InjectivityAnn GhcPs) -deriving instance Data (InjectivityAnn GhcRn) -deriving instance Data (InjectivityAnn GhcTc) +deriving instance DataX => Data (InjectivityAnn GhcPs) +deriving instance DataX => Data (InjectivityAnn GhcRn) +deriving instance DataX => Data (InjectivityAnn GhcTc) -- deriving instance (DataIdLR p p) => Data (FamilyInfo p) -deriving instance Data (FamilyInfo GhcPs) -deriving instance Data (FamilyInfo GhcRn) -deriving instance Data (FamilyInfo GhcTc) +deriving instance DataX => Data (FamilyInfo GhcPs) +deriving instance DataX => Data (FamilyInfo GhcRn) +deriving instance DataX => Data (FamilyInfo GhcTc) -- deriving instance (DataIdLR p p) => Data (HsDataDefn p) -deriving instance Data (HsDataDefn GhcPs) -deriving instance Data (HsDataDefn GhcRn) -deriving instance Data (HsDataDefn GhcTc) +deriving instance DataX => Data (HsDataDefn GhcPs) +deriving instance DataX => Data (HsDataDefn GhcRn) +deriving instance DataX => Data (HsDataDefn GhcTc) -- deriving instance (DataIdLR p p) => Data (HsDerivingClause p) -deriving instance Data (HsDerivingClause GhcPs) -deriving instance Data (HsDerivingClause GhcRn) -deriving instance Data (HsDerivingClause GhcTc) +deriving instance DataX => Data (HsDerivingClause GhcPs) +deriving instance DataX => Data (HsDerivingClause GhcRn) +deriving instance DataX => Data (HsDerivingClause GhcTc) -- deriving instance (DataIdLR p p) => Data (ConDecl p) -deriving instance Data (ConDecl GhcPs) -deriving instance Data (ConDecl GhcRn) -deriving instance Data (ConDecl GhcTc) +deriving instance DataX => Data (ConDecl GhcPs) +deriving instance DataX => Data (ConDecl GhcRn) +deriving instance DataX => Data (ConDecl GhcTc) -- deriving instance DataIdLR p p => Data (TyFamInstDecl p) -deriving instance Data (TyFamInstDecl GhcPs) -deriving instance Data (TyFamInstDecl GhcRn) -deriving instance Data (TyFamInstDecl GhcTc) +deriving instance DataX => Data (TyFamInstDecl GhcPs) +deriving instance DataX => Data (TyFamInstDecl GhcRn) +deriving instance DataX => Data (TyFamInstDecl GhcTc) -- deriving instance DataIdLR p p => Data (DataFamInstDecl p) -deriving instance Data (DataFamInstDecl GhcPs) -deriving instance Data (DataFamInstDecl GhcRn) -deriving instance Data (DataFamInstDecl GhcTc) +deriving instance DataX => Data (DataFamInstDecl GhcPs) +deriving instance DataX => Data (DataFamInstDecl GhcRn) +deriving instance DataX => Data (DataFamInstDecl GhcTc) -- deriving instance (DataIdLR p p,Data rhs)=>Data (FamEqn p rhs) -deriving instance Data rhs => Data (FamEqn GhcPs rhs) -deriving instance Data rhs => Data (FamEqn GhcRn rhs) -deriving instance Data rhs => Data (FamEqn GhcTc rhs) +deriving instance DataX => Data rhs => Data (FamEqn GhcPs rhs) +deriving instance DataX => Data rhs => Data (FamEqn GhcRn rhs) +deriving instance DataX => Data rhs => Data (FamEqn GhcTc rhs) -- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) -deriving instance Data (ClsInstDecl GhcPs) -deriving instance Data (ClsInstDecl GhcRn) -deriving instance Data (ClsInstDecl GhcTc) +deriving instance DataX => Data (ClsInstDecl GhcPs) +deriving instance DataX => Data (ClsInstDecl GhcRn) +deriving instance DataX => Data (ClsInstDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (InstDecl p) -deriving instance Data (InstDecl GhcPs) -deriving instance Data (InstDecl GhcRn) -deriving instance Data (InstDecl GhcTc) +deriving instance DataX => Data (InstDecl GhcPs) +deriving instance DataX => Data (InstDecl GhcRn) +deriving instance DataX => Data (InstDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (DerivDecl p) -deriving instance Data (DerivDecl GhcPs) -deriving instance Data (DerivDecl GhcRn) -deriving instance Data (DerivDecl GhcTc) +deriving instance DataX => Data (DerivDecl GhcPs) +deriving instance DataX => Data (DerivDecl GhcRn) +deriving instance DataX => Data (DerivDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (DerivStrategy p) -deriving instance Data (DerivStrategy GhcPs) -deriving instance Data (DerivStrategy GhcRn) -deriving instance Data (DerivStrategy GhcTc) +deriving instance DataX => Data (DerivStrategy GhcPs) +deriving instance DataX => Data (DerivStrategy GhcRn) +deriving instance DataX => Data (DerivStrategy GhcTc) -- deriving instance (DataIdLR p p) => Data (DefaultDecl p) -deriving instance Data (DefaultDecl GhcPs) -deriving instance Data (DefaultDecl GhcRn) -deriving instance Data (DefaultDecl GhcTc) +deriving instance DataX => Data (DefaultDecl GhcPs) +deriving instance DataX => Data (DefaultDecl GhcRn) +deriving instance DataX => Data (DefaultDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (ForeignDecl p) -deriving instance Data (ForeignDecl GhcPs) -deriving instance Data (ForeignDecl GhcRn) -deriving instance Data (ForeignDecl GhcTc) +deriving instance DataX => Data (ForeignDecl GhcPs) +deriving instance DataX => Data (ForeignDecl GhcRn) +deriving instance DataX => Data (ForeignDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (RuleDecls p) -deriving instance Data (RuleDecls GhcPs) -deriving instance Data (RuleDecls GhcRn) -deriving instance Data (RuleDecls GhcTc) +deriving instance DataX => Data (RuleDecls GhcPs) +deriving instance DataX => Data (RuleDecls GhcRn) +deriving instance DataX => Data (RuleDecls GhcTc) -- deriving instance (DataIdLR p p) => Data (RuleDecl p) -deriving instance Data (RuleDecl GhcPs) -deriving instance Data (RuleDecl GhcRn) -deriving instance Data (RuleDecl GhcTc) +deriving instance DataX => Data (RuleDecl GhcPs) +deriving instance DataX => Data (RuleDecl GhcRn) +deriving instance DataX => Data (RuleDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (RuleBndr p) -deriving instance Data (RuleBndr GhcPs) -deriving instance Data (RuleBndr GhcRn) -deriving instance Data (RuleBndr GhcTc) +deriving instance DataX => Data (RuleBndr GhcPs) +deriving instance DataX => Data (RuleBndr GhcRn) +deriving instance DataX => Data (RuleBndr GhcTc) -- deriving instance (DataId p) => Data (WarnDecls p) -deriving instance Data (WarnDecls GhcPs) -deriving instance Data (WarnDecls GhcRn) -deriving instance Data (WarnDecls GhcTc) +deriving instance DataX => Data (WarnDecls GhcPs) +deriving instance DataX => Data (WarnDecls GhcRn) +deriving instance DataX => Data (WarnDecls GhcTc) -- deriving instance (DataId p) => Data (WarnDecl p) -deriving instance Data (WarnDecl GhcPs) -deriving instance Data (WarnDecl GhcRn) -deriving instance Data (WarnDecl GhcTc) +deriving instance DataX => Data (WarnDecl GhcPs) +deriving instance DataX => Data (WarnDecl GhcRn) +deriving instance DataX => Data (WarnDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (AnnDecl p) -deriving instance Data (AnnDecl GhcPs) -deriving instance Data (AnnDecl GhcRn) -deriving instance Data (AnnDecl GhcTc) +deriving instance DataX => Data (AnnDecl GhcPs) +deriving instance DataX => Data (AnnDecl GhcRn) +deriving instance DataX => Data (AnnDecl GhcTc) -- deriving instance (DataId p) => Data (RoleAnnotDecl p) -deriving instance Data (RoleAnnotDecl GhcPs) -deriving instance Data (RoleAnnotDecl GhcRn) -deriving instance Data (RoleAnnotDecl GhcTc) +deriving instance DataX => Data (RoleAnnotDecl GhcPs) +deriving instance DataX => Data (RoleAnnotDecl GhcRn) +deriving instance DataX => 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 DataX => Data SyntaxExprTc -- deriving instance (DataIdLR p p) => Data (HsExpr p) -deriving instance Data (HsExpr GhcPs) -deriving instance Data (HsExpr GhcRn) -deriving instance Data (HsExpr GhcTc) +deriving instance DataX => Data (HsExpr GhcPs) +deriving instance DataX => Data (HsExpr GhcRn) +deriving instance DataX => Data (HsExpr GhcTc) -- deriving instance (DataIdLR p p) => Data (HsTupArg p) -deriving instance Data (HsTupArg GhcPs) -deriving instance Data (HsTupArg GhcRn) -deriving instance Data (HsTupArg GhcTc) +deriving instance DataX => Data (HsTupArg GhcPs) +deriving instance DataX => Data (HsTupArg GhcRn) +deriving instance DataX => Data (HsTupArg GhcTc) -- deriving instance (DataIdLR p p) => Data (HsCmd p) -deriving instance Data (HsCmd GhcPs) -deriving instance Data (HsCmd GhcRn) -deriving instance Data (HsCmd GhcTc) +deriving instance DataX => Data (HsCmd GhcPs) +deriving instance DataX => Data (HsCmd GhcRn) +deriving instance DataX => Data (HsCmd GhcTc) -- deriving instance (DataIdLR p p) => Data (HsCmdTop p) -deriving instance Data (HsCmdTop GhcPs) -deriving instance Data (HsCmdTop GhcRn) -deriving instance Data (HsCmdTop GhcTc) +deriving instance DataX => Data (HsCmdTop GhcPs) +deriving instance DataX => Data (HsCmdTop GhcRn) +deriving instance DataX => Data (HsCmdTop GhcTc) -- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) -deriving instance (Data body) => Data (MatchGroup GhcPs body) -deriving instance (Data body) => Data (MatchGroup GhcRn body) -deriving instance (Data body) => Data (MatchGroup GhcTc body) +deriving instance (DataX, Data body) => Data (MatchGroup GhcPs body) +deriving instance (DataX, Data body) => Data (MatchGroup GhcRn body) +deriving instance (DataX, Data body) => Data (MatchGroup GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (Match p body) -deriving instance (Data body) => Data (Match GhcPs body) -deriving instance (Data body) => Data (Match GhcRn body) -deriving instance (Data body) => Data (Match GhcTc body) +deriving instance (DataX, Data body) => Data (Match GhcPs body) +deriving instance (DataX, Data body) => Data (Match GhcRn body) +deriving instance (DataX, Data body) => Data (Match GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) -deriving instance (Data body) => Data (GRHSs GhcPs body) -deriving instance (Data body) => Data (GRHSs GhcRn body) -deriving instance (Data body) => Data (GRHSs GhcTc body) +deriving instance (DataX, Data body) => Data (GRHSs GhcPs body) +deriving instance (DataX, Data body) => Data (GRHSs GhcRn body) +deriving instance (DataX, Data body) => Data (GRHSs GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) -deriving instance (Data body) => Data (GRHS GhcPs body) -deriving instance (Data body) => Data (GRHS GhcRn body) -deriving instance (Data body) => Data (GRHS GhcTc body) +deriving instance (DataX, Data body) => Data (GRHS GhcPs body) +deriving instance (DataX, Data body) => Data (GRHS GhcRn body) +deriving instance (DataX, Data body) => Data (GRHS GhcTc body) -- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) -deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body) -deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) -deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) -deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) +deriving instance (DataX, Data body) => Data (StmtLR GhcPs GhcPs body) +deriving instance (DataX, Data body) => Data (StmtLR GhcPs GhcRn body) +deriving instance (DataX, Data body) => Data (StmtLR GhcRn GhcRn body) +deriving instance (DataX, Data body) => Data (StmtLR GhcTc GhcTc body) -deriving instance Data RecStmtTc +deriving instance DataX => Data RecStmtTc +deriving instance DataX => Data RecordUpdTc +deriving instance (DataX, Data (body GhcTc), Typeable body) => Data (HsWrap body) -- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) -deriving instance Data (ParStmtBlock GhcPs GhcPs) -deriving instance Data (ParStmtBlock GhcPs GhcRn) -deriving instance Data (ParStmtBlock GhcRn GhcRn) -deriving instance Data (ParStmtBlock GhcTc GhcTc) +deriving instance DataX => Data (ParStmtBlock GhcPs GhcPs) +deriving instance DataX => Data (ParStmtBlock GhcPs GhcRn) +deriving instance DataX => Data (ParStmtBlock GhcRn GhcRn) +deriving instance DataX => Data (ParStmtBlock GhcTc GhcTc) -- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) -deriving instance Data (ApplicativeArg GhcPs) -deriving instance Data (ApplicativeArg GhcRn) -deriving instance Data (ApplicativeArg GhcTc) +deriving instance DataX => Data (ApplicativeArg GhcPs) +deriving instance DataX => Data (ApplicativeArg GhcRn) +deriving instance DataX => Data (ApplicativeArg GhcTc) -- deriving instance (DataIdLR p p) => Data (HsSplice p) -deriving instance Data (HsSplice GhcPs) -deriving instance Data (HsSplice GhcRn) -deriving instance Data (HsSplice GhcTc) +deriving instance DataX => Data (HsSplice GhcPs) +deriving instance DataX => Data (HsSplice GhcRn) +deriving instance DataX => Data (HsSplice GhcTc) -- deriving instance (DataIdLR p p) => Data (HsSplicedThing p) -deriving instance Data (HsSplicedThing GhcPs) -deriving instance Data (HsSplicedThing GhcRn) -deriving instance Data (HsSplicedThing GhcTc) +deriving instance DataX => Data (HsSplicedThing GhcPs) +deriving instance DataX => Data (HsSplicedThing GhcRn) +deriving instance DataX => Data (HsSplicedThing GhcTc) -- deriving instance (DataIdLR p p) => Data (HsBracket p) -deriving instance Data (HsBracket GhcPs) -deriving instance Data (HsBracket GhcRn) -deriving instance Data (HsBracket GhcTc) +deriving instance DataX => Data (HsBracket GhcPs) +deriving instance DataX => Data (HsBracket GhcRn) +deriving instance DataX => Data (HsBracket GhcTc) -- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) -deriving instance Data (ArithSeqInfo GhcPs) -deriving instance Data (ArithSeqInfo GhcRn) -deriving instance Data (ArithSeqInfo GhcTc) +deriving instance DataX => Data (ArithSeqInfo GhcPs) +deriving instance DataX => Data (ArithSeqInfo GhcRn) +deriving instance DataX => Data (ArithSeqInfo GhcTc) -deriving instance Data RecordConTc -deriving instance Data CmdTopTc -deriving instance Data PendingRnSplice -deriving instance Data PendingTcSplice +deriving instance DataX => Data RecordConTc +deriving instance DataX => Data CmdTopTc +deriving instance DataX => Data PendingRnSplice +deriving instance DataX => Data PendingTcSplice -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Lit ------------------------------------ -- deriving instance (DataId p) => Data (HsLit p) -deriving instance Data (HsLit GhcPs) -deriving instance Data (HsLit GhcRn) -deriving instance Data (HsLit GhcTc) +deriving instance DataX => Data (HsLit GhcPs) +deriving instance DataX => Data (HsLit GhcRn) +deriving instance DataX => Data (HsLit GhcTc) -- deriving instance (DataIdLR p p) => Data (HsOverLit p) -deriving instance Data (HsOverLit GhcPs) -deriving instance Data (HsOverLit GhcRn) -deriving instance Data (HsOverLit GhcTc) +deriving instance DataX => Data (HsOverLit GhcPs) +deriving instance DataX => Data (HsOverLit GhcRn) +deriving instance DataX => Data (HsOverLit GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Pat ------------------------------------ -- deriving instance (DataIdLR p p) => Data (Pat p) -deriving instance Data (Pat GhcPs) -deriving instance Data (Pat GhcRn) -deriving instance Data (Pat GhcTc) +deriving instance DataX => Data (Pat GhcPs) +deriving instance DataX => Data (Pat GhcRn) +deriving instance DataX => Data (Pat GhcTc) -deriving instance Data ListPatTc +deriving instance DataX => Data ListPatTc -- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) -deriving instance (Data body) => Data (HsRecFields GhcPs body) -deriving instance (Data body) => Data (HsRecFields GhcRn body) -deriving instance (Data body) => Data (HsRecFields GhcTc body) +deriving instance (DataX, Data body) => Data (HsRecFields GhcPs body) +deriving instance (DataX, Data body) => Data (HsRecFields GhcRn body) +deriving instance (DataX, Data body) => Data (HsRecFields GhcTc body) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Types ---------------------------------- -- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) -deriving instance Data (LHsQTyVars GhcPs) -deriving instance Data (LHsQTyVars GhcRn) -deriving instance Data (LHsQTyVars GhcTc) +deriving instance DataX => Data (LHsQTyVars GhcPs) +deriving instance DataX => Data (LHsQTyVars GhcRn) +deriving instance DataX => Data (LHsQTyVars GhcTc) -- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing) -deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing) -deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing) -deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing) +deriving instance (DataX, Data thing) => Data (HsImplicitBndrs GhcPs thing) +deriving instance (DataX, Data thing) => Data (HsImplicitBndrs GhcRn thing) +deriving instance (DataX, Data thing) => Data (HsImplicitBndrs GhcTc thing) -- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) -deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) -deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) -deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) +deriving instance (DataX, Data thing) => Data (HsWildCardBndrs GhcPs thing) +deriving instance (DataX, Data thing) => Data (HsWildCardBndrs GhcRn thing) +deriving instance (DataX, Data thing) => Data (HsWildCardBndrs GhcTc thing) -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) -deriving instance Data (HsTyVarBndr GhcPs) -deriving instance Data (HsTyVarBndr GhcRn) -deriving instance Data (HsTyVarBndr GhcTc) +deriving instance DataX => Data (HsTyVarBndr GhcPs) +deriving instance DataX => Data (HsTyVarBndr GhcRn) +deriving instance DataX => Data (HsTyVarBndr GhcTc) -- deriving instance (DataIdLR p p) => Data (HsType p) -deriving instance Data (HsType GhcPs) -deriving instance Data (HsType GhcRn) -deriving instance Data (HsType GhcTc) +deriving instance DataX => Data (HsType GhcPs) +deriving instance DataX => Data (HsType GhcRn) +deriving instance DataX => Data (HsType GhcTc) -deriving instance Data (LHsTypeArg GhcPs) -deriving instance Data (LHsTypeArg GhcRn) -deriving instance Data (LHsTypeArg GhcTc) +deriving instance DataX => Data (LHsTypeArg GhcPs) +deriving instance DataX => Data (LHsTypeArg GhcRn) +deriving instance DataX => Data (LHsTypeArg GhcTc) -- deriving instance (DataIdLR p p) => Data (ConDeclField p) -deriving instance Data (ConDeclField GhcPs) -deriving instance Data (ConDeclField GhcRn) -deriving instance Data (ConDeclField GhcTc) +deriving instance DataX => Data (ConDeclField GhcPs) +deriving instance DataX => Data (ConDeclField GhcRn) +deriving instance DataX => Data (ConDeclField GhcTc) -- deriving instance (DataId p) => Data (FieldOcc p) -deriving instance Data (FieldOcc GhcPs) -deriving instance Data (FieldOcc GhcRn) -deriving instance Data (FieldOcc GhcTc) +deriving instance DataX => Data (FieldOcc GhcPs) +deriving instance DataX => Data (FieldOcc GhcRn) +deriving instance DataX => Data (FieldOcc GhcTc) -- deriving instance DataId p => Data (AmbiguousFieldOcc p) -deriving instance Data (AmbiguousFieldOcc GhcPs) -deriving instance Data (AmbiguousFieldOcc GhcRn) -deriving instance Data (AmbiguousFieldOcc GhcTc) +deriving instance DataX => Data (AmbiguousFieldOcc GhcPs) +deriving instance DataX => Data (AmbiguousFieldOcc GhcRn) +deriving instance DataX => Data (AmbiguousFieldOcc GhcTc) -- deriving instance (DataId name) => Data (ImportDecl name) -deriving instance Data (ImportDecl GhcPs) -deriving instance Data (ImportDecl GhcRn) -deriving instance Data (ImportDecl GhcTc) +deriving instance DataX => Data (ImportDecl GhcPs) +deriving instance DataX => Data (ImportDecl GhcRn) +deriving instance DataX => Data (ImportDecl GhcTc) -- deriving instance (DataId name) => Data (IE name) -deriving instance Data (IE GhcPs) -deriving instance Data (IE GhcRn) -deriving instance Data (IE GhcTc) +deriving instance DataX => Data (IE GhcPs) +deriving instance DataX => Data (IE GhcRn) +deriving instance DataX => Data (IE GhcTc) -- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) -deriving instance Eq (IE GhcPs) -deriving instance Eq (IE GhcRn) -deriving instance Eq (IE GhcTc) +deriving instance DataX => Eq (IE GhcPs) +deriving instance DataX => Eq (IE GhcRn) +deriving instance DataX => Eq (IE GhcTc) -- --------------------------------------------------------------------- diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index fe8a4e88d5..c224dcf67b 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -17,6 +17,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module GHC.Hs.Pat ( Pat(..), InPat, OutPat, LPat, @@ -29,8 +31,6 @@ module GHC.Hs.Pat ( hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, - mkPrefixConPat, mkCharLitPat, mkNilPat, - looksLazyPatBind, isBangedLPat, patNeedsParens, parenthesizePat, @@ -50,11 +50,9 @@ import GHC.Hs.Binds import GHC.Hs.Lit import GHC.Hs.Extension import GHC.Hs.Types -import TcEvidence import BasicTypes -- others: import PprCore ( {- instance OutputableBndr TyVar -} ) -import TysWiredIn import Var import RdrName ( RdrName ) import ConLike @@ -187,9 +185,9 @@ data Pat p -- One reason for putting coercion variable here, I think, -- is to ensure their kinds are zonked - pat_binds :: TcEvBinds, -- Bindings involving those dictionaries + pat_binds :: XTcEvBinds, -- Bindings involving those dictionaries pat_args :: HsConPatDetails p, - pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher + pat_wrap :: XHsWrapper -- Extra wrapper to pass to the matcher -- Only relevant for pattern-synonyms; -- ignored for data cons } @@ -261,7 +259,7 @@ data Pat p ------------ Pattern coercions (translation only) --------------- | CoPat (XCoPat p) - HsWrapper -- Coercion Pattern + XHsWrapper -- Coercion Pattern -- If co :: t1 ~ t2, p :: t2, -- then (CoPat co p) :: t1 (Pat p) -- Why not LPat? Ans: existing locn will do @@ -535,7 +533,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc +pprPat :: forall p. (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat @@ -549,8 +547,9 @@ 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 @@ -571,7 +570,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 x) = ppr x @@ -608,33 +607,6 @@ instance (Outputable p, Outputable arg) {- ************************************************************************ * * -* Building patterns -* * -************************************************************************ --} - -mkPrefixConPat :: DataCon -> - [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p) --- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats tys - = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc) - , pat_tvs = [] - , pat_dicts = [] - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon pats - , pat_arg_tys = tys - , pat_wrap = idHsWrapper } - -mkNilPat :: Type -> OutPat (GhcPass p) -mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] - -mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) -mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat noExtField (HsCharPrim src c)] [] - -{- -************************************************************************ -* * * Predicates for checking things about pattern-lists in EquationInfo * * * ************************************************************************ diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 5d54196af2..52ba85b2e8 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -24,14 +24,12 @@ module GHC.Hs.Utils( mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, - mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, - mkHsDictLet, mkHsLams, - mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, - mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, + mkHsOpApp, mkHsDo, mkHsComp, + mkLHsPar, mkHsCmdIf, - nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, - nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, + nlHsVar, nlHsDataCon, + nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, @@ -102,7 +100,6 @@ import GHC.Hs.Lit import GHC.Hs.PlaceHolder import GHC.Hs.Extension -import TcEvidence import RdrName import Var import TyCoRep @@ -118,7 +115,6 @@ import NameEnv import BasicTypes import SrcLoc import FastString -import Util import Bag import Outputable import Constants @@ -195,10 +191,6 @@ mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) [mkSimpleMatch LambdaExpr pats' body] pats' = map (parenthesizePat appPrec) pats -mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc -mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars - <.> mkWpLams dicts) expr - -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) @@ -206,16 +198,8 @@ mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr -nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) -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 fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs - --------- Adding parens --------- -mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them -- So 'f x' becomes '(f x)', but '3' stays as '3' mkLHsPar le@(dL->L loc e) @@ -245,11 +229,11 @@ mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs -mkLastStmt :: Located (bodyR (GhcPass idR)) +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))) @@ -272,11 +256,11 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where last_stmt = cL (getLoc expr) $ mkLastStmt expr -mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +mkHsIf :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b -mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) +mkHsCmdIf :: IsPass p => LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b @@ -314,8 +298,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 @@ -396,23 +380,10 @@ 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 - = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" - mkLHsWrap arg_wraps args)) - -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) @@ -737,51 +708,6 @@ visible kind applications, so even specified arguments count towards injective positions in the kind of the tycon. -} -{- ********************************************************************* -* * - --------- HsWrappers: type args, dict args, casts --------- -* * -********************************************************************* -} - -mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) - --- Avoid (HsWrap co (HsWrap co' _)). --- 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 - -mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) -mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e - -mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) -mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e - -mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) - -mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) -mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap noExtField w cmd - -mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) - -mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) -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 co pat ty | isTcReflCo co = pat - | otherwise = CoPat noExtField (mkWpCastN co) pat ty - -mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc -mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr - {- l ************************************************************************ @@ -796,7 +722,6 @@ mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup Generated ms - , fun_co_fn = idHsWrapper , fun_ext = noExtField , fun_tick = [] } @@ -805,7 +730,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 = [] } @@ -831,7 +755,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 diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index b7bed75f3d..d73b5047a8 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -628,10 +628,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) @@ -832,6 +832,8 @@ addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do x' <- fmap unLoc (addTickLHsExpr (cL pos x)) return $ syn { syn_expr = x' } +addTickSyntaxExpr _ NoSyntaxExpr = return NoSyntaxExpr + -- we do not walk into patterns. addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) addTickLPat pat = return pat @@ -894,10 +896,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 ade017208d..0a049513ff 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -688,7 +688,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') diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 6498ed7f6f..e1f1628b57 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -145,7 +145,7 @@ dsHsBind dflags (VarBind { var_id = var dsHsBind dflags b@(FunBind { fun_id = (dL->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 1cf981cddd..724b00851b 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -194,7 +194,7 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] dsUnliftedBind (FunBind { fun_id = (dL->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 @@ -274,7 +274,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 @@ -755,7 +755,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = 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 ------------------------------ @@ -772,6 +771,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 NoSyntaxExpr _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 7baa748faa..f3144e141a 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1818,7 +1818,7 @@ repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p 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) + ; e' <- repE (expectJust "repP" e) ; repPview e' p} repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 8559e9ae85..52444c13f7 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -37,6 +37,8 @@ module DsUtils ( mkSelectorBinds, + mkPrefixConPat, mkCharLitPat, mkNilPat, + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang, isTrueLHsExpr @@ -777,6 +779,33 @@ mkBigLHsPatTupId = mkChunkified mkLHsPatTup {- ************************************************************************ * * +* Building patterns +* * +************************************************************************ +-} + +mkPrefixConPat :: DataCon -> + [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p) +-- Make a vanilla Prefix constructor pattern +mkPrefixConPat dc pats tys + = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc) + , pat_tvs = [] + , pat_dicts = [] + , pat_binds = emptyTcEvBinds + , pat_args = PrefixCon pats + , pat_arg_tys = tys + , pat_wrap = idHsWrapper } + +mkNilPat :: Type -> OutPat (GhcPass p) +mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] + +mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) +mkCharLitPat src c = mkPrefixConPat charDataCon + [noLoc $ LitPat noExtField (HsCharPrim src c)] [] + +{- +************************************************************************ +* * Code for pattern-matching and other failures * * ************************************************************************ diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 2e0aeb9877..7097d863de 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -1008,7 +1008,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp e (HsPar _ (dL->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 @@ -1056,6 +1056,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 = exp expr1 expr2 && and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && wrap res_wrap1 res_wrap2 + syn_exp NoSyntaxExpr NoSyntaxExpr = True + syn_exp _ _ = False --------- tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2 diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 52f8c59a4d..6c9bd19df7 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.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)) @@ -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) -> @@ -1003,9 +1004,6 @@ instance ( a ~ GhcPass p HsTickPragma _ _ _ _ expr -> [ toHie expr ] - HsWrap _ _ a -> - [ toHie $ L mspan a - ] HsBracket _ b -> [ toHie b ] @@ -1020,7 +1018,13 @@ instance ( a ~ GhcPass p HsSpliceE _ x -> [ toHie $ L mspan x ] - XExpr _ -> [] + XExpr x + | GhcTc <- pass @p + , HsWrap _ a <- x + -> [ toHie $ L mspan a ] + + | otherwise + -> [] instance ( a ~ GhcPass p , ToHie (LHsExpr a) @@ -1250,7 +1254,6 @@ instance ( a ~ GhcPass p [ pure $ locOnly ispan , toHie $ listScopes NoScope stmts ] - HsCmdWrap _ _ _ -> [] XCmd _ -> [] instance ToHie (TyClGroup GhcRn) where diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 27f192227f..8075c116f6 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -14,6 +14,7 @@ import GhcPrelude import Bag import GHC.Hs +import TcEvidence () -- instance for Outputable HsWrapper import Outputable import SrcLoc import Util diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index eeaa2c2f1d..9e5618bb83 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -163,6 +163,7 @@ import GHC.ForeignSrcLang import UniqFM import GHC.Hs +import TcEvidence () -- instance for Outputable HsWrapper import RdrName import Avail import Module diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 997f497510..4841145f03 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2422,7 +2422,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] >> return () ; (PatBind _ (dL->L l _) _rhs _) -> amsL l [] >> return () } ; @@ -2437,7 +2437,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 _ (dL->L lh _lhs) _rhs _) -> amsL lh (fst $2) >> return () } ; diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 0686f669d3..d8195bb7e7 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -112,7 +112,6 @@ import CoAxiom ( Role, fsFromRole ) import RdrName import Name import BasicTypes -import TcEvidence ( idHsWrapper ) import Lexer import Lexeme ( isLexCon ) import Type ( TyThing(..), funTyCon ) @@ -1218,7 +1217,6 @@ makeFunBind fn ms = FunBind { fun_ext = noExtField, fun_id = fn, fun_matches = mkMatchGroup FromSource ms, - fun_co_fn = idHsWrapper, fun_tick = [] } checkPatBind :: LPat GhcPs diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 3ec24a7a6d..b10d85d1c1 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -518,7 +518,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 --------------------------------------------------- @@ -536,7 +535,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 @@ -2125,15 +2123,15 @@ getMonadFailOp where reallyGetMonadFailOp rebindableSyntax overloadedStrings | rebindableSyntax && overloadedStrings = do - (failExpr, failFvs) <- lookupSyntaxName failMName - (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName + (Just failExpr, failFvs) <- lookupSyntaxName failMName + (Just fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName let arg_lit = fsLit "arg" arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit - arg_syn_expr = mkRnSyntaxExpr arg_name + Just arg_syn_expr = mkRnSyntaxExpr arg_name let 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) + (noLoc $ arg_syn_expr)) let failAfterFromStringExpr :: HsExpr GhcRn = unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 61cdc140bf..b9464b8bfd 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -864,16 +864,14 @@ rnOverLit origLit | otherwise = origLit } ; let std_name = hsOverLitName val - ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) - <- lookupSyntaxName std_name + ; (Just 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 , ol_ext = rebindable } ; if isNegativeZeroOverLit lit' - then do { (SyntaxExpr { syn_expr = negate_name }, fvs2) - <- lookupSyntaxName negateName + then do { (Just negate_name, fvs2) <- lookupSyntaxName negateName ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name) , fvs1 `plusFV` fvs2) } else return ((lit', Nothing), fvs1) } diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index dc701d360b..348a128849 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -706,8 +706,7 @@ tcPolyCheck prag_fn ; tick <- funBindTicks nm_loc mono_id mod prag_sigs ; let bind' = FunBind { fun_id = cL 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 @@ -1243,8 +1242,7 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen [ dL->L b_loc (FunBind { fun_id = (dL->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 @@ -1269,8 +1267,8 @@ tcMonoBinds is_rec sig_fn no_gen ; mono_id <- newLetBndr no_gen name rhs_ty ; return (unitBag $ cL b_loc $ FunBind { fun_id = cL 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 }]) } @@ -1417,8 +1415,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) matches (mkCheckExpType $ idType mono_id) ; return ( FunBind { fun_id = cL 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) diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index ee5b72033f..d3551a29a3 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -1,6 +1,8 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP, DeriveDataTypeable, ViewPatterns, TypeFamilies, + MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- OutputableHsWrapper module TcEvidence ( @@ -11,6 +13,10 @@ module TcEvidence ( mkWpFun, idHsWrapper, isIdHsWrapper, isErasableHsWrapper, pprHsWrapper, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, + mkHsDictLet, mkHsLams, nlHsTyApp, nlHsTyApps, nlHsSyntaxApps, + mkHsWrapPat, mkHsWrapPatCo, mkHsCmdWrap, mkLHsCmdWrap, + -- Evidence bindings TcEvBinds(..), EvBindsVar(..), EvBindMap(..), emptyEvBindMap, extendEvBinds, @@ -68,6 +74,7 @@ import Predicate import Name import Pair +import GHC.Hs import CoreSyn import Class ( classSCSelId ) import CoreFVs ( exprSomeFreeVars ) @@ -190,6 +197,9 @@ maybeTcSubCo ReprEq = mkTcSubCo ************************************************************************ -} +-- See Note [Abstract data] in GHC.Hs.Extension +type instance XHsWrapper = HsWrapper + data HsWrapper = WpHole -- The identity coercion @@ -385,6 +395,80 @@ collectHsWrapBinders wrap = go wrap [] add_lam v (vs,w) = (v:vs, w) +{- ********************************************************************* +* * + --------- Integrating HsWrapper with HsExpr ------------- +* * +********************************************************************* -} + +mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc +mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) + +-- Avoid (HsWrap co (HsWrap co' _)). +-- See Note [Detecting forced eta expansion] in DsExpr +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 GhcTc -> HsExpr GhcTc +mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e + +mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b + -> HsExpr GhcTc -> HsExpr GhcTc +mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e + +mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc +mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) + +mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc +mkHsCmdWrap w cmd | isIdHsWrapper w = cmd + | otherwise = XCmd (HsWrap w cmd) + +mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc +mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) + +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 GhcTc -> Type -> Pat GhcTc +mkHsWrapPatCo co pat ty | isTcReflCo co = pat + | otherwise = CoPat noExtField (mkWpCastN co) pat ty + +mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr + +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars + <.> mkWpLams dicts) expr + +nlHsTyApp :: IdP GhcTc -> [Type] -> LHsExpr GhcTc +nlHsTyApp fun_id tys + = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) + +nlHsTyApps :: IdP GhcTc -> [Type] -> [LHsExpr GhcTc] + -> LHsExpr GhcTc +nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs + +nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc] + -> LHsExpr GhcTc +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 + = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" + mkLHsWrap arg_wraps args)) +nlHsSyntaxApps NoSyntaxExpr args = pprPanic "nlHsSyntaxApps" (ppr args) + -- this function should never be called in scenarios where there is no + -- rebindable syntax + + {- ************************************************************************ * * @@ -393,6 +477,7 @@ collectHsWrapBinders wrap = go wrap [] ************************************************************************ -} +type instance XTcEvBinds = TcEvBinds -- See Note [Abstract data] in GHC.Hs.Extension data TcEvBinds = TcEvBinds -- Mutable evidence bindings EvBindsVar -- Mutable because they are updated "later" @@ -903,31 +988,33 @@ can just squeeze by. Here's how. instance Outputable HsWrapper where ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) -pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc --- With -fprint-typechecker-elaboration, print the wrapper --- otherwise just print what's inside --- The pp_thing_inside function takes Bool to say whether --- it's in a position that needs parens for a non-atomic thing -pprHsWrapper wrap pp_thing_inside - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags - then help pp_thing_inside wrap False - else pp_thing_inside False - where - help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc - -- True <=> appears in function application position - -- False <=> appears as body of let or lambda - help it WpHole = it - help it (WpCompose f1 f2) = help (help it f2) f1 - help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> - help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False - help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" - <+> pprParendCo co)] - help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] - help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] - help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] - help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] - help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] +-- See Note [Abstract data] in GHC.Hs.Extension +instance OutputableHsWrapper where + -- pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc + -- With -fprint-typechecker-elaboration, print the wrapper + -- otherwise just print what's inside + -- The pp_thing_inside function takes Bool to say whether + -- it's in a position that needs parens for a non-atomic thing + pprHsWrapper wrap pp_thing_inside + = sdocWithDynFlags $ \ dflags -> + if gopt Opt_PrintTypecheckerElaboration dflags + then help pp_thing_inside wrap False + else pp_thing_inside False + where + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> + help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False + help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" + <+> pprParendCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] + help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] + help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] pprLamBndr :: Id -> SDoc pprLamBndr v = pprBndr LambdaBind v diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index fa35ee2086..a57e0b6c04 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1465,8 +1465,8 @@ tcSyntaxOpGen :: CtOrigin -> 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 +tcSyntaxOpGen orig (Just 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 $ @@ -1475,6 +1475,7 @@ tcSyntaxOpGen orig op arg_tys res_ty thing_inside ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) } +tcSyntaxOpGen _ Nothing _ _ _ = panic "tcSyntaxOpGen" {- Note [tcSynArg] diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 32a8e46338..a57adbd234 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -576,13 +576,13 @@ zonk_bind env (VarBind { var_ext = x zonk_bind env bind@(FunBind { fun_id = (dL->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 = cL 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 @@ -609,7 +609,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs | has_sig , (dL->L loc bind@(FunBind { fun_id = (dL->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 @@ -618,7 +618,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs ; return $ cL loc $ bind { fun_id = cL 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 @@ -956,10 +956,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 @@ -998,6 +998,7 @@ zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr ; return (env1, SyntaxExpr { syn_expr = expr' , syn_arg_wraps = arg_wraps' , syn_res_wrap = res_wrap' }) } +zonkSyntaxExpr env NoSyntaxExpr = return (env, NoSyntaxExpr) ------------------------------------------------------------------------- @@ -1006,10 +1007,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 @@ -1059,8 +1060,6 @@ zonkCmd env (HsCmdDo ty (dL->L l stmts)) new_ty <- zonkTcTypeToTypeX env ty return (HsCmdDo new_ty (cL 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 16150dfec7..3903d53dfa 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1171,7 +1171,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/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs index 5ac1e30357..b43097fb6b 100644 --- a/compiler/typecheck/TcOrigin.hs +++ b/compiler/typecheck/TcOrigin.hs @@ -26,6 +26,7 @@ module TcOrigin ( import GhcPrelude import TcType +import TcEvidence () -- Outputable instances import GHC.Hs @@ -494,7 +495,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 _ (Just (Just syn)) _ _ _) = exprCtOrigin syn exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e @@ -515,7 +516,6 @@ exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsTickPragma _ _ _ _ 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/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 746b48401b..e96e071b76 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -749,10 +749,9 @@ tcPatSynMatcher (dL->L loc name) lpat , mg_origin = Generated } - ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = cL loc matcher_id + ; let bind = FunBind{ fun_id = cL loc matcher_id , fun_matches = mg - , fun_co_fn = idHsWrapper + , fun_ext = idHsWrapper , fun_tick = [] } matcher_bind = unitBag (noLoc bind) @@ -839,10 +838,9 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) let match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group - bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = cL loc (idName builder_id) + bind = FunBind { fun_id = cL loc (idName builder_id) , fun_matches = match_group' - , fun_co_fn = idHsWrapper + , fun_ext = emptyNameSet , fun_tick = [] } sig = completeSigFromId (PatSynCtxt name) builder_id @@ -970,8 +968,8 @@ tcPatToExpr name args pat = go pat } go1 (LitPat _ lit) = return $ HsLit noExtField lit go1 (NPat _ (dL->L _ n) mb_neg _) - | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg - [noLoc (HsOverLit noExtField n)] + | Just (Just 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/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs index d88e25cc87..dbf94f309b 100644 --- a/compiler/typecheck/TcPluginM.hs +++ b/compiler/typecheck/TcPluginM.hs @@ -65,7 +65,7 @@ import TcRnMonad ( TcGblEnv, TcLclEnv, TcPluginM , unsafeTcPluginTcM, getEvBindsTcPluginM , liftIO, traceTc ) import Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) -import TcMType ( TcTyVar, TcType ) +import TcMType ( TcTyVar ) import TcEnv ( TcTyThing ) import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..) , EvExpr, EvBind, mkGivenEvBind ) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 8895593698..8426759f64 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -17,7 +17,7 @@ of the stack mechanism), you should use a TcRef (= IORef) to store them. -} {-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving, - ViewPatterns #-} + ViewPatterns, TypeFamilies #-} module TcRnTypes( TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module @@ -725,6 +725,7 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is b) used in the ModDetails of this module -} +type instance XTcLclEnv = TcLclEnv -- See Note [Abstract data] in GHC.Hs.Extension data TcLclEnv -- Changes as we move inside an expression -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 36de540aed..368a719368 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -26,7 +26,7 @@ import TcHsType import TcExpr import TcEnv import TcUnify( buildImplicationFor ) -import TcEvidence( mkTcCoVarCo ) +import TcEvidence import Type import TyCon( isTypeFamilyTyCon ) import Id diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index aa9e38357e..dd0c2c814f 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -93,7 +93,7 @@ import CoAxiom import PatSyn import ConLike import DataCon -import TcEvidence( TcEvBinds(..) ) +import TcEvidence import Id import IdInfo import DsExpr diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index c116e4fea3..ae870adf1d 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -332,7 +332,6 @@ GHC #12785. -- See Note [TcTyVars and TyVars in the typechecker] type TcCoVar = CoVar -- Used only during type inference -type TcType = Type -- A TcType can have mutable type variables type TcTyCoVar = Var -- Either a TcTyVar or a CoVar -- Invariant on ForAllTy in TcTypes: -- forall a. T diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 6e5eb94d72..c24f0a6ee0 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -25,7 +25,7 @@ import GhcPrelude import Type import Pair -import TcType ( TcType, tcEqType ) +import TcType ( tcEqType ) import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon , Injectivity(..) ) import Coercion ( Role(..) ) diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 60a0f5e3b3..e064868fc7 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -18,7 +18,7 @@ import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) ) import IfaceEnv( newGlobalBinder ) import TyCoRep( Type(..), TyLit(..) ) import TcEnv -import TcEvidence ( mkWpTyApps ) +import TcEvidence ( mkWpTyApps, mkLHsWrap ) import TcRnMonad import TcType import HscTypes ( lookupId ) diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index f25b5a275a..197d77570c 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -17,7 +17,7 @@ module Type ( TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), KindOrType, PredType, ThetaType, Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, - KnotTied, + KnotTied, TcType, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, @@ -268,6 +268,10 @@ import Maybes ( orElse ) import Data.Maybe ( isJust ) import Control.Monad ( guard ) +type TcType = Type -- A TcType can have mutable type variables +-- defined here so that modules can refer to TcType without depending +-- on the type-checker + -- $type_classification -- #type_classification# -- diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 2bf061f3b5..fd45de31a7 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -340,8 +340,8 @@ processAllTypeCheckedModule tcm = do mid | HsVar _ (dL->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 6aa8aa4578..1575c493f9 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 4612d87cad..e9cada2f10 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -363,7 +363,6 @@ (EmptyLocalBinds (NoExtField))))))]) (FromSource)) - (WpHole) []))) ,({ KindSigs.hs:26:1-29 } (TyClD @@ -604,7 +603,6 @@ (EmptyLocalBinds (NoExtField))))))]) (FromSource)) - (WpHole) [])))] (Nothing) (Nothing))) |