diff options
Diffstat (limited to 'compiler')
39 files changed, 773 insertions, 641 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# -- |