summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorromes <rodrigo.m.mesquita@gmail.com>2022-03-13 18:06:04 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-03-14 11:36:39 -0400
commit135888ddc6adc99126b84194a5da3d8736324132 (patch)
tree70cb2a1d13e5959d802fb4d1fc15f4bcada3e7a9
parent97db789eec7a49c3ec30a83666720221c26d8f9e (diff)
downloadhaskell-135888ddc6adc99126b84194a5da3d8736324132.tar.gz
TTG Pull AbsBinds and ABExport out of the main AST
AbsBinds and ABExport both depended on the typechecker, and were thus removed from the main AST Expr. CollectPass now has a new function `collectXXHsBindsLR` used for the new HsBinds extension point Bumped haddock submodule to work with AST changes. The removed Notes from Language.Haskell.Syntax.Binds were duplicated (and not referenced) and the copies in GHC.Hs.Binds are kept (and referenced there). (See #19252)
-rw-r--r--compiler/GHC/Hs/Binds.hs140
-rw-r--r--compiler/GHC/Hs/Expr.hs3
-rw-r--r--compiler/GHC/Hs/Instances.hs7
-rw-r--r--compiler/GHC/Hs/Pat.hs4
-rw-r--r--compiler/GHC/Hs/Utils.hs63
-rw-r--r--compiler/GHC/HsToCore/Binds.hs19
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs7
-rw-r--r--compiler/GHC/HsToCore/Expr.hs10
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs7
-rw-r--r--compiler/GHC/HsToCore/Quote.hs1
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs39
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs18
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs7
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs28
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs26
-rw-r--r--compiler/Language/Haskell/Syntax/Binds.hs292
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs3
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs5
-rw-r--r--testsuite/tests/ghc-api/T6145.hs2
-rw-r--r--testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr171
-rw-r--r--testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs2
-rw-r--r--utils/check-exact/ExactPrint.hs1
m---------utils/haddock0
24 files changed, 325 insertions, 533 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 987631dc82..d67d1c4312 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -42,17 +43,17 @@ import GHC.Types.Name.Set
import GHC.Types.Basic
import GHC.Types.SourceText
import GHC.Types.SrcLoc as SrcLoc
+import GHC.Types.Var
import GHC.Data.Bag
import GHC.Data.BooleanFormula (LBooleanFormula)
import GHC.Types.Name.Reader
import GHC.Types.Name
-import GHC.Types.Id
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import Data.List (sortBy)
import Data.Function
+import Data.List (sortBy)
import Data.Data (Data)
{-
@@ -83,7 +84,7 @@ data NHsValBindsLR idL
[LSig GhcRn]
type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey
-type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
+type instance XXValBindsLR (GhcPass pL) pR
= NHsValBindsLR (GhcPass pL)
-- ---------------------------------------------------------------------
@@ -114,12 +115,11 @@ type instance XPatBind GhcRn (GhcPass pR) = NameSet -- ^ See Note [Bind free
type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs
type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField
-type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField
type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField
-type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen
-type instance XABE (GhcPass p) = NoExtField
-type instance XXABExport (GhcPass p) = DataConCantHappen
+type instance XXHsBindsLR GhcPs pR = DataConCantHappen
+type instance XXHsBindsLR GhcRn pR = DataConCantHappen
+type instance XXHsBindsLR GhcTc pR = AbsBinds
type instance XPSB (GhcPass idL) GhcPs = EpAnn [AddEpAnn]
type instance XPSB (GhcPass idL) GhcRn = NameSet -- ^ Post renaming, FVs. See Note [Bind free vars]
@@ -127,6 +127,52 @@ type instance XPSB (GhcPass idL) GhcTc = NameSet
type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen
+-- ---------------------------------------------------------------------
+
+-- | Typechecked, generalised bindings, used in the output to the type checker.
+-- See Note [AbsBinds].
+data AbsBinds = AbsBinds {
+ abs_tvs :: [TyVar],
+ abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
+
+ -- | AbsBinds only gets used when idL = idR after renaming,
+ -- but these need to be idL's for the collect... code in HsUtil
+ -- to have the right type
+ abs_exports :: [ABExport],
+
+ -- | Evidence bindings
+ -- Why a list? See "GHC.Tc.TyCl.Instance"
+ -- Note [Typechecking plan for instance declarations]
+ abs_ev_binds :: [TcEvBinds],
+
+ -- | Typechecked user bindings
+ abs_binds :: LHsBinds GhcTc,
+
+ abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds]
+ }
+
+
+ -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
+ --
+ -- Creates bindings for (polymorphic, overloaded) poly_f
+ -- in terms of monomorphic, non-overloaded mono_f
+ --
+ -- Invariants:
+ -- 1. 'binds' binds mono_f
+ -- 2. ftvs is a subset of tvs
+ -- 3. ftvs includes all tyvars free in ds
+ --
+ -- See Note [AbsBinds]
+
+-- | Abstraction Bindings Export
+data ABExport
+ = ABE { abe_poly :: Id -- ^ Any INLINE pragma is attached to this Id
+ , abe_mono :: Id
+ , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
+ -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
+ , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
+ }
+
{-
Note [AbsBinds]
~~~~~~~~~~~~~~~
@@ -474,29 +520,36 @@ ppr_monobind (FunBind { fun_id = fun,
$$ 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
- , abs_ev_binds = ev_binds })
- = sdocOption sdocPrintTypecheckerElaboration $ \case
- False -> pprLHsBinds val_binds
- True -> -- Show extra information (bug number: #10662)
- hang (text "AbsBinds"
- <+> sep [ brackets (interpp'SP tyvars)
- , brackets (interpp'SP dictvars) ])
- 2 $ braces $ vcat
- [ text "Exports:" <+>
- brackets (sep (punctuate comma (map ppr exports)))
- , text "Exported types:" <+>
- vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
- , text "Binds:" <+> pprLHsBinds val_binds
- , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds)
- ]
-
-instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
+ppr_monobind (XHsBindsLR b) = case ghcPass @idL of
+#if __GLASGOW_HASKELL__ <= 900
+ GhcPs -> dataConCantHappen b
+ GhcRn -> dataConCantHappen b
+#endif
+ GhcTc -> ppr_absbinds b
+ where
+ ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
+ , abs_exports = exports, abs_binds = val_binds
+ , abs_ev_binds = ev_binds })
+ = sdocOption sdocPrintTypecheckerElaboration $ \case
+ False -> pprLHsBinds val_binds
+ True -> -- Show extra information (bug number: #10662)
+ hang (text "AbsBinds"
+ <+> sep [ brackets (interpp'SP tyvars)
+ , brackets (interpp'SP dictvars) ])
+ 2 $ braces $ vcat
+ [ text "Exports:" <+>
+ brackets (sep (punctuate comma (map ppr exports)))
+ , text "Exported types:" <+>
+ vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
+ , text "Binds:" <+> pprLHsBinds val_binds
+ , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds)
+ ]
+
+instance Outputable ABExport where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ sep [ ppr gbl, nest 2 (text "<=" <+> ppr lcl) ]
, nest 2 (pprTcSpecPrags prags)
- , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]
+ , ppr $ nest 2 (text "wrap:" <+> ppr wrap) ]
instance (OutputableBndrId l, OutputableBndrId r)
=> Outputable (PatSynBind (GhcPass l) (GhcPass r)) where
@@ -618,6 +671,39 @@ data AnnSig
} deriving Data
+-- | Type checker Specialisation Pragmas
+--
+-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
+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
+
+-- | Type checker Specification Pragma
+data TcSpecPrag
+ = SpecPrag
+ Id
+ HsWrapper
+ 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 []
+
+hasSpecPrags :: TcSpecPrags -> Bool
+hasSpecPrags (SpecPrags ps) = not (null ps)
+hasSpecPrags IsDefaultMethod = False
+
+isDefaultMethod :: TcSpecPrags -> Bool
+isDefaultMethod IsDefaultMethod = True
+isDefaultMethod (SpecPrags {}) = False
+
instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where
ppr sig = ppr_sig sig
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 704dc70b02..595adafdf9 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1629,6 +1629,9 @@ instance Data DelayedSplice where
toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix
dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a]
+-- See Note [Pending Splices]
+type SplicePointName = Name
+
-- | Pending Renamer Splice
data PendingRnSplice
= PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 21cd9b5d76..ff5131f6e0 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -63,10 +63,9 @@ deriving instance Data (HsBindLR GhcPs GhcRn)
deriving instance Data (HsBindLR GhcRn GhcRn)
deriving instance 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 Data AbsBinds
+
+deriving instance Data ABExport
-- deriving instance DataId p => Data (RecordPatSynField p)
deriving instance Data (RecordPatSynField GhcPs)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 43f161f9bd..c81018da40 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -452,7 +452,7 @@ isBangedPat (ParPat _ _ p _) = isBangedLPat p
isBangedPat (BangPat {}) = True
isBangedPat _ = False
-looksLazyPatBind :: HsBind (GhcPass p) -> Bool
+looksLazyPatBind :: HsBind GhcTc -> Bool
-- Returns True of anything *except*
-- a StrictHsBind (as above) or
-- a VarPat
@@ -460,7 +460,7 @@ looksLazyPatBind :: HsBind (GhcPass p) -> Bool
-- Looks through AbsBinds
looksLazyPatBind (PatBind { pat_lhs = p })
= looksLazyLPat p
-looksLazyPatBind (AbsBinds { abs_binds = binds })
+looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds }))
= anyBag (looksLazyPatBind . unLoc) binds
looksLazyPatBind _
= False
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index d53fc51786..050fa53d30 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -20,17 +20,19 @@ just attach noSrcSpan to everything.
-}
-
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -151,7 +153,6 @@ import GHC.Utils.Panic
import Data.Either
import Data.Function
import Data.List ( partition, deleteBy )
-import Data.Proxy
{-
************************************************************************
@@ -978,7 +979,7 @@ BUT we have a special case when abs_sig is true;
-- information, see Note [Strict binds checks] is GHC.HsToCore.Binds.
isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
isUnliftedHsBind bind
- | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
+ | XHsBindsLR (AbsBinds { abs_exports = exports, abs_sig = has_sig }) <- bind
= if has_sig
then any (is_unlifted_id . abe_poly) exports
else any (is_unlifted_id . abe_mono) exports
@@ -993,7 +994,7 @@ isUnliftedHsBind bind
-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
isBangedHsBind :: HsBind GhcTc -> Bool
-isBangedHsBind (AbsBinds { abs_binds = binds })
+isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds }))
= anyBag (isBangedHsBind . unLoc) binds
isBangedHsBind (FunBind {fun_matches = matches})
| [L _ match] <- unLoc $ mg_alts matches
@@ -1023,7 +1024,7 @@ collectHsIdBinders flag = collect_hs_val_binders True flag
collectHsValBinders :: CollectPass (GhcPass idL)
=> CollectFlag (GhcPass idL)
- -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+ -> HsValBindsLR (GhcPass idL) idR
-> [IdP (GhcPass idL)]
collectHsValBinders flag = collect_hs_val_binders False flag
@@ -1050,7 +1051,7 @@ collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []
collect_hs_val_binders :: CollectPass (GhcPass idL)
=> Bool
-> CollectFlag (GhcPass idL)
- -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+ -> HsValBindsLR (GhcPass idL) idR
-> [IdP (GhcPass idL)]
collect_hs_val_binders ps flag = \case
ValBinds _ binds _ -> collect_binds ps flag binds []
@@ -1078,18 +1079,15 @@ collect_bind :: forall p idR. CollectPass p
-> HsBindLR p idR
-> [IdP p]
-> [IdP p]
-collect_bind _ flag (PatBind { pat_lhs = p }) acc = collect_lpat flag p acc
-collect_bind _ _ (FunBind { fun_id = f }) acc = unXRec @p f : acc
-collect_bind _ _ (VarBind { var_id = f }) acc = f : acc
-collect_bind _ _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
- -- I don't think we want the binders from the abe_binds
-
- -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk
+collect_bind _ _ (FunBind { fun_id = f }) acc = unXRec @p f : acc
+collect_bind _ flag (PatBind { pat_lhs = p }) acc = collect_lpat flag p acc
+collect_bind _ _ (VarBind { var_id = f }) acc = f : acc
collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc
| omitPatSyn = acc
| otherwise = unXRec @p ps : acc
collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc
-collect_bind _ _ (XHsBindsLR _) acc = acc
+collect_bind _ _ (XHsBindsLR b) acc = collectXXHsBindsLR @p @idR b acc
+
collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]
-- ^ Used exclusively for the bindings of an instance decl which are all
@@ -1110,14 +1108,14 @@ collectLStmtsBinders
collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)
collectStmtsBinders
- :: (CollectPass (GhcPass idL))
+ :: CollectPass (GhcPass idL)
=> CollectFlag (GhcPass idL)
-> [StmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectStmtsBinders flag = concatMap (collectStmtBinders flag)
collectLStmtBinders
- :: (CollectPass (GhcPass idL))
+ :: CollectPass (GhcPass idL)
=> CollectFlag (GhcPass idL)
-> LStmtLR (GhcPass idL) (GhcPass idR) body
-> [IdP (GhcPass idL)]
@@ -1176,7 +1174,7 @@ data CollectFlag p where
-- | Collect evidence binders
CollWithDictBinders :: CollectFlag GhcTc
-collect_lpat :: forall p. (CollectPass p)
+collect_lpat :: forall p. CollectPass p
=> CollectFlag p
-> LPat p
-> [IdP p]
@@ -1203,7 +1201,7 @@ collect_pat flag pat bndrs = case pat of
NPat {} -> bndrs
NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs
SigPat _ pat _ -> collect_lpat flag pat bndrs
- XPat ext -> collectXXPat (Proxy @p) flag ext bndrs
+ XPat ext -> collectXXPat @p flag ext bndrs
SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))
-> collect_pat flag pat bndrs
SplicePat _ _ -> bndrs
@@ -1230,10 +1228,11 @@ add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs
-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that
-- it can reuse the code in GHC for collecting binders.
class UnXRec p => CollectPass p where
- collectXXPat :: Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]
+ collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]
+ collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p]
instance IsPass p => CollectPass (GhcPass p) where
- collectXXPat _ flag ext =
+ collectXXPat flag ext =
case ghcPass @p of
GhcPs -> dataConCantHappen ext
GhcRn
@@ -1242,6 +1241,16 @@ instance IsPass p => CollectPass (GhcPass p) where
GhcTc -> case ext of
CoPat _ pat _ -> collect_pat flag pat
ExpansionPat _ pat -> collect_pat flag pat
+ collectXXHsBindsLR ext =
+ case ghcPass @p of
+ GhcPs -> dataConCantHappen ext
+ GhcRn -> dataConCantHappen ext
+ GhcTc -> case ext of
+ AbsBinds { abs_exports = dbinds } -> (map abe_poly dbinds ++)
+ -- I don't think we want the binders from the abe_binds
+
+ -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk
+
{-
Note [Dictionary binders in ConPatOut]
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index a8935e9cd9..9220326258 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -201,10 +201,12 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
else []
; return (force_var', sel_binds) }
-dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
- , abs_exports = exports
- , abs_ev_binds = ev_binds
- , abs_binds = binds, abs_sig = has_sig })
+dsHsBind
+ dflags
+ (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+ , abs_exports = exports
+ , abs_ev_binds = ev_binds
+ , abs_binds = binds, abs_sig = has_sig }))
= do { ds_binds <- addTyCs FromSource (listToBag dicts) $
dsLHsBinds binds
-- addTyCs: push type constraints deeper
@@ -220,7 +222,7 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-----------------------
dsAbsBinds :: DynFlags
- -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
+ -> [TyVar] -> [EvVar] -> [ABExport]
-> [CoreBind] -- Desugared evidence bindings
-> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings
-> Bool -- Single binding with signature
@@ -271,7 +273,7 @@ dsAbsBinds dflags tyvars dicts exports
-- lcl_id{inl-prag} = rhs -- Auxiliary binds
-- gbl_id = lcl_id |> co -- Main binds
| null tyvars, null dicts
- = do { let mk_main :: ABExport GhcTc -> DsM (Id, CoreExpr)
+ = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)
mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id
, abe_wrap = wrap })
-- No SpecPrags (no dicts)
@@ -360,7 +362,7 @@ dsAbsBinds dflags tyvars dicts exports
[] lcls
-- find exports or make up new exports for force variables
- get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
+ get_exports :: [Id] -> DsM ([Id], [ABExport])
get_exports lcls =
foldM (\(glbls, exports) lcl ->
case lookupVarEnv global_env lcl of
@@ -373,8 +375,7 @@ dsAbsBinds dflags tyvars dicts exports
mk_export local =
do global <- newSysLocalDs Many
(exprType (mkLams tyvars (mkLams dicts (Var local))))
- return (ABE { abe_ext = noExtField
- , abe_poly = global
+ return (ABE { abe_poly = global
, abe_mono = local
, abe_wrap = WpHole
, abe_prags = SpecPrags [] })
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index c59beb402c..93694c4750 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -285,12 +285,13 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds = mapBagM addTickLHsBind
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
-addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
- abs_exports = abs_exports })) =
+addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
+ , abs_exports = abs_exports
+ }))) =
withEnv add_exports $
withEnv add_inlines $ do
binds' <- addTickLHsBinds binds
- return $ L pos $ bind { abs_binds = binds' }
+ return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }
where
-- in AbsBinds, the Id on each binding is not the actual top-level
-- Id that we are defining, they are related by the abs_exports
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index c4dc64e58c..c9e6ef050d 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -143,7 +143,7 @@ ds_val_bind (NonRecursive, hsbinds) body
; dsUnliftedBind bind body }
where
- is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
+ is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
= not (null tvs && null evs)
is_polymorphic _ = False
@@ -177,10 +177,10 @@ ds_val_bind (is_rec, binds) body
------------------
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
-dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
- , abs_exports = exports
- , abs_ev_binds = ev_binds
- , abs_binds = lbinds }) body
+dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = []
+ , abs_exports = exports
+ , abs_ev_binds = ev_binds
+ , abs_binds = lbinds })) body
= do { let body1 = foldr bind_export body exports
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 7cba784245..38d3fd54d7 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -388,12 +388,13 @@ desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
, GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do
core_rhs <- dsLExpr rhs
return [PmLet x core_rhs]
- go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = []
- , abs_exports=exports, abs_binds = binds }) = do
+ go (L _ (XHsBindsLR (AbsBinds
+ { abs_tvs = [], abs_ev_vars = []
+ , abs_exports=exports, abs_binds = binds }))) = do
-- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry
-- renamings. See Note [Long-distance information for HsLocalBinds]
-- for the details.
- let go_export :: ABExport GhcTc -> Maybe PmGrd
+ let go_export :: ABExport -> Maybe PmGrd
go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}
| isIdHsWrapper wrap
= assertPpr (idType x `eqType` idType y)
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 5c95f14341..34282ec363 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1911,7 +1911,6 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
; ans <- repVal patcore x empty_decls
; return (srcLocSpan (getSrcLoc v), ans) }
-rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
, psb_args = args
, psb_def = pat
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 7b4e8bc20e..b6be92301f 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -267,12 +267,11 @@ instance ModifyState Id where
addSubstitution mono poly hs =
hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
-modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
+modifyState :: [ABExport] -> HieState -> HieState
modifyState = foldr go id
where
go ABE{abe_poly=poly,abe_mono=mono} f
= addSubstitution mono poly . f
- go _ f = f
type HieM = ReaderT NodeOrigin (State HieState)
@@ -847,21 +846,27 @@ instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
VarBind{var_rhs = expr} ->
[ toHie expr
]
- AbsBinds{ abs_exports = xs, abs_binds = binds
- , abs_ev_binds = ev_binds
- , abs_ev_vars = ev_vars } ->
- [ lift (modify (modifyState xs)) >> -- Note [Name Remapping]
- (toHie $ fmap (BC context scope) binds)
- , toHie $ map (L span . abe_wrap) xs
- , toHie $
- map (EvBindContext (mkScopeA span) (getRealSpanA span)
- . L span) ev_binds
- , toHie $
- map (C (EvidenceVarBind EvSigBind
- (mkScopeA span)
- (getRealSpanA span))
- . L span) ev_vars
- ]
+ XHsBindsLR ext -> case hiePass @p of
+#if __GLASGOW_HASKELL__ < 811
+ HieRn -> dataConCantHappen ext
+#endif
+ HieTc
+ | AbsBinds{ abs_exports = xs, abs_binds = binds
+ , abs_ev_binds = ev_binds
+ , abs_ev_vars = ev_vars } <- ext
+ ->
+ [ lift (modify (modifyState xs)) >> -- Note [Name Remapping]
+ (toHie $ fmap (BC context scope) binds)
+ , toHie $ map (L span . abe_wrap) xs
+ , toHie $
+ map (EvBindContext (mkScopeA span) (getRealSpanA span)
+ . L span) ev_binds
+ , toHie $
+ map (C (EvidenceVarBind EvSigBind
+ (mkScopeA span)
+ (getRealSpanA span))
+ . L span) ev_vars
+ ]
PatSynBind _ psb ->
[ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level
]
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 406cb87b24..f6e71f57cf 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
@@ -268,7 +269,7 @@ instance Diagnostic TcRnMessage where
2 (vcat $ map pprLBind . bagToList $ binds)
where
pprLoc loc = parens (text "defined at" <+> ppr loc)
- pprLBind :: GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
+ pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)
<+> pprLoc (locA loc)
TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index fb5d98b457..a14ff790fa 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -637,15 +637,13 @@ tcPolyCheck prag_fn
, fun_ext = wrap_gen <.> wrap_res
, fun_tick = tick }
- export = ABE { abe_ext = noExtField
- , abe_wrap = idHsWrapper
+ export = ABE { abe_wrap = idHsWrapper
, abe_poly = poly_id
, abe_mono = poly_id2
, abe_prags = SpecPrags spec_prags }
- abs_bind = L bind_loc $
- AbsBinds { abs_ext = noExtField
- , abs_tvs = []
+ abs_bind = L bind_loc $ XHsBindsLR $
+ AbsBinds { abs_tvs = []
, abs_ev_vars = []
, abs_ev_binds = []
, abs_exports = [export]
@@ -732,9 +730,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
; loc <- getSrcSpanM
; let poly_ids = map abe_poly exports
- abs_bind = L (noAnnSrcSpan loc) $
- AbsBinds { abs_ext = noExtField
- , abs_tvs = qtvs
+ abs_bind = L (noAnnSrcSpan loc) $ XHsBindsLR $
+ AbsBinds { abs_tvs = qtvs
, abs_ev_vars = givens, abs_ev_binds = [ev_binds]
, abs_exports = exports, abs_binds = binds'
, abs_sig = False }
@@ -750,7 +747,7 @@ mkExport :: TcPragEnv
-- when typechecking the bindings
-> [TyVar] -> TcThetaType -- Both already zonked
-> MonoBindInfo
- -> TcM (ABExport GhcTc)
+ -> TcM ABExport
-- Only called for generalisation plan InferGen, not by CheckGen or NoGen
--
-- mkExport generates exports with
@@ -803,8 +800,7 @@ mkExport prag_fn residual insoluble qtvs theta
; localSigWarn poly_id mb_sig
- ; return (ABE { abe_ext = noExtField
- , abe_wrap = wrap
+ ; return (ABE { abe_wrap = wrap
-- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id
, abe_poly = poly_id
, abe_mono = mono_id
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 2f55a9cea1..ee41b3e0aa 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -304,13 +304,12 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
tcPolyCheck no_prag_fn local_dm_sig
(L bind_loc lm_bind)
- ; let export = ABE { abe_ext = noExtField
- , abe_poly = global_dm_id
+ ; let export = ABE { abe_poly = global_dm_id
, abe_mono = local_dm_id
, abe_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
- full_bind = AbsBinds { abs_ext = noExtField
- , abs_tvs = tyvars
+ full_bind = XHsBindsLR $
+ AbsBinds { abs_tvs = tyvars
, abs_ev_vars = [this_dict]
, abs_exports = [export]
, abs_ev_binds = [ev_binds]
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 699c50c54b..36a58d760a 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -1321,14 +1321,13 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
-- Newtype dfuns just inline unconditionally,
-- so don't attempt to specialise them
- export = ABE { abe_ext = noExtField
- , abe_wrap = idHsWrapper
+ export = ABE { abe_wrap = idHsWrapper
, abe_poly = dfun_id_w_prags
, abe_mono = self_dict
, abe_prags = dfun_spec_prags }
-- NB: see Note [SPECIALISE instance pragmas]
- main_bind = AbsBinds { abs_ext = noExtField
- , abs_tvs = inst_tyvars
+ main_bind = XHsBindsLR $
+ AbsBinds { abs_tvs = inst_tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = []
@@ -1475,14 +1474,13 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
; let sc_top_ty = mkInfForAllTys tyvars $
mkPhiTy (map idType dfun_evs) sc_pred
sc_top_id = mkLocalId sc_top_name Many sc_top_ty
- export = ABE { abe_ext = noExtField
- , abe_wrap = idHsWrapper
+ export = ABE { abe_wrap = idHsWrapper
, abe_poly = sc_top_id
, abe_mono = sc_ev_id
, abe_prags = noSpecPrags }
local_ev_binds = TcEvBinds ev_binds_var
- bind = AbsBinds { abs_ext = noExtField
- , abs_tvs = tyvars
+ bind = XHsBindsLR $
+ AbsBinds { abs_tvs = tyvars
, abs_ev_vars = dfun_evs
, abs_exports = [export]
, abs_ev_binds = [dfun_ev_binds, local_ev_binds]
@@ -1910,15 +1908,14 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
; spec_prags <- tcSpecPrags global_meth_id prags
; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
- export = ABE { abe_ext = noExtField
- , abe_poly = global_meth_id
+ export = ABE { abe_poly = global_meth_id
, abe_mono = local_meth_id
, abe_wrap = idHsWrapper
, abe_prags = specs }
local_ev_binds = TcEvBinds ev_binds_var
- full_bind = AbsBinds { abs_ext = noExtField
- , abs_tvs = tyvars
+ full_bind = XHsBindsLR $
+ AbsBinds { abs_tvs = tyvars
, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = [dfun_ev_binds, local_ev_binds]
@@ -1968,14 +1965,13 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
- ; let export = ABE { abe_ext = noExtField
- , abe_poly = local_meth_id
+ ; let export = ABE { abe_poly = local_meth_id
, abe_mono = inner_id
, abe_wrap = hs_wrap
, abe_prags = noSpecPrags }
- ; return (unitBag $ L (getLoc meth_bind) $
- AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = []
+ ; return (unitBag $ L (getLoc meth_bind) $ XHsBindsLR $
+ AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = [export]
, abs_binds = tc_bind, abs_ev_binds = []
, abs_sig = True }) }
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index ba6c98905f..197a8d8104 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -561,12 +561,12 @@ zonk_bind env bind@(FunBind { fun_id = L loc var
, fun_matches = new_ms
, fun_ext = new_co_fn }) }
-zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
- , abs_ev_binds = ev_binds
- , abs_exports = exports
- , abs_binds = val_binds
- , abs_sig = has_sig })
- = assert (all isImmutableTyVar tyvars) $
+zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
+ , abs_ev_binds = ev_binds
+ , abs_exports = exports
+ , abs_binds = val_binds
+ , abs_sig = has_sig }))
+ = assert ( all isImmutableTyVar tyvars ) $
do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
; (env1, new_evs) <- zonkEvBndrsX env0 evs
; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
@@ -576,11 +576,11 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
; new_exports <- mapM (zonk_export env3) exports
; return (new_val_binds, new_exports) }
- ; return (AbsBinds { abs_ext = noExtField
- , abs_tvs = new_tyvars, abs_ev_vars = new_evs
+ ; return $ XHsBindsLR $
+ AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
, abs_ev_binds = new_ev_binds
, abs_exports = new_exports, abs_binds = new_val_bind
- , abs_sig = has_sig }) }
+ , abs_sig = has_sig } }
where
zonk_val_bind env lbind
| has_sig
@@ -599,17 +599,15 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
| otherwise
= zonk_lbind env lbind -- The normal case
- zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc)
- zonk_export env (ABE{ abe_ext = x
- , abe_wrap = wrap
+ zonk_export :: ZonkEnv -> ABExport -> TcM ABExport
+ zonk_export env (ABE{ abe_wrap = wrap
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = prags })
= do new_poly_id <- zonkIdBndr env poly_id
(_, new_wrap) <- zonkCoFn env wrap
new_prags <- zonkSpecPrags env prags
- return (ABE{ abe_ext = x
- , abe_wrap = new_wrap
+ return (ABE{ abe_wrap = new_wrap
, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs
index 183fce9836..c50eb7e833 100644
--- a/compiler/Language/Haskell/Syntax/Binds.hs
+++ b/compiler/Language/Haskell/Syntax/Binds.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -34,11 +33,8 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Pat
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
import GHC.Types.Name.Reader(RdrName)
-import GHC.Tc.Types.Evidence
-import GHC.Core.Type
import GHC.Types.Basic
import GHC.Types.SourceText
-import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Tickish
import GHC.Types.Var
import GHC.Types.Fixity
@@ -48,7 +44,6 @@ import GHC.Data.BooleanFormula (LBooleanFormula)
import GHC.Utils.Outputable
import GHC.Utils.Panic (pprPanic)
-import Data.Data hiding ( Fixity )
import Data.Void
{-
@@ -245,28 +240,6 @@ data HsBindLR idL idR
var_rhs :: LHsExpr idR -- ^ Located only for consistency
}
- -- | Abstraction Bindings
- | AbsBinds { -- Binds abstraction; TRANSLATION
- abs_ext :: XAbsBinds idL idR,
- abs_tvs :: [TyVar],
- abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
-
- -- | AbsBinds only gets used when idL = idR after renaming,
- -- but these need to be idL's for the collect... code in HsUtil
- -- to have the right type
- abs_exports :: [ABExport idL],
-
- -- | Evidence bindings
- -- Why a list? See "GHC.Tc.TyCl.Instance"
- -- Note [Typechecking plan for instance declarations]
- abs_ev_binds :: [TcEvBinds],
-
- -- | Typechecked user bindings
- abs_binds :: LHsBinds idL,
-
- abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds]
- }
-
-- | Patterns Synonym Binding
| PatSynBind
(XPatSynBind idL idR)
@@ -281,30 +254,6 @@ data HsBindLR idL idR
| XHsBindsLR !(XXHsBindsLR idL idR)
- -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
- --
- -- Creates bindings for (polymorphic, overloaded) poly_f
- -- in terms of monomorphic, non-overloaded mono_f
- --
- -- Invariants:
- -- 1. 'binds' binds mono_f
- -- 2. ftvs is a subset of tvs
- -- 3. ftvs includes all tyvars free in ds
- --
- -- See Note [AbsBinds]
-
--- | Abstraction Bindings Export
-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]
- -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
- , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
- }
- | XABExport !(XXABExport p)
-
-
-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',
-- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow',
-- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@,
@@ -322,214 +271,6 @@ data PatSynBind idL idR
}
| XPatSynBind !(XXPatSynBind idL idR)
-{-
-Note [AbsBinds]
-~~~~~~~~~~~~~~~
-The AbsBinds constructor is used in the output of the type checker, to
-record *typechecked* and *generalised* bindings. Specifically
-
- AbsBinds { abs_tvs = tvs
- , abs_ev_vars = [d1,d2]
- , abs_exports = [ABE { abe_poly = fp, abe_mono = fm
- , abe_wrap = fwrap }
- ABE { slly for g } ]
- , abs_ev_binds = DBINDS
- , abs_binds = BIND[fm,gm] }
-
-where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means
-
- fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ]
- [ ; BIND[fm,gm] } ]
- [ in fm ]
-
- gp = ...same again, with gm instead of fm
-
-The 'fwrap' is an impedance-matcher that typically does nothing; see
-Note [ABExport wrapper].
-
-This is a pretty bad translation, because it duplicates all the bindings.
-So the desugarer tries to do a better job:
-
- fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
- (fm,gm) -> fm
- ..ditto for gp..
-
- tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }
- in (fm,gm)
-
-In general:
-
- * abs_tvs are the type variables over which the binding group is
- generalised
- * abs_ev_var are the evidence variables (usually dictionaries)
- over which the binding group is generalised
- * abs_binds are the monomorphic bindings
- * abs_ex_binds are the evidence bindings that wrap the abs_binds
- * abs_exports connects the monomorphic Ids bound by abs_binds
- with the polymorphic Ids bound by the AbsBinds itself.
-
-For example, consider a module M, with this top-level binding, where
-there is no type signature for M.reverse,
- M.reverse [] = []
- M.reverse (x:xs) = M.reverse xs ++ [x]
-
-In Hindley-Milner, a recursive binding is typechecked with the
-*recursive* uses being *monomorphic*. So after typechecking *and*
-desugaring we will get something like this
-
- M.reverse :: forall a. [a] -> [a]
- = /\a. letrec
- reverse :: [a] -> [a] = \xs -> case xs of
- [] -> []
- (x:xs) -> reverse xs ++ [x]
- in reverse
-
-Notice that 'M.reverse' is polymorphic as expected, but there is a local
-definition for plain 'reverse' which is *monomorphic*. The type variable
-'a' scopes over the entire letrec.
-
-That's after desugaring. What about after type checking but before
-desugaring? That's where AbsBinds comes in. It looks like this:
-
- AbsBinds { abs_tvs = [a]
- , abs_ev_vars = []
- , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
- , abe_mono = reverse :: [a] -> [a]}]
- , abs_ev_binds = {}
- , abs_binds = { reverse :: [a] -> [a]
- = \xs -> case xs of
- [] -> []
- (x:xs) -> reverse xs ++ [x] } }
-
-Here,
-
- * abs_tvs says what type variables are abstracted over the binding
- group, just 'a' in this case.
- * abs_binds is the *monomorphic* bindings of the group
- * abs_exports describes how to get the polymorphic Id 'M.reverse'
- from the monomorphic one 'reverse'
-
-Notice that the *original* function (the polymorphic one you thought
-you were defining) appears in the abe_poly field of the
-abs_exports. The bindings in abs_binds are for fresh, local, Ids with
-a *monomorphic* Id.
-
-If there is a group of mutually recursive (see Note [Polymorphic
-recursion]) functions without type signatures, we get one AbsBinds
-with the monomorphic versions of the bindings in abs_binds, and one
-element of abe_exports for each variable bound in the mutually
-recursive group. This is true even for pattern bindings. Example:
- (f,g) = (\x -> x, f)
-After type checking we get
- AbsBinds { abs_tvs = [a]
- , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
- , abe_mono = f :: a -> a }
- , ABE { abe_poly = M.g :: forall a. a -> a
- , abe_mono = g :: a -> a }]
- , abs_binds = { (f,g) = (\x -> x, f) }
-
-Note [Polymorphic recursion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- Rec { f x = ...(g ef)...
-
- ; g :: forall a. [a] -> [a]
- ; g y = ...(f eg)... }
-
-These bindings /are/ mutually recursive (f calls g, and g calls f).
-But we can use the type signature for g to break the recursion,
-like this:
-
- 1. Add g :: forall a. [a] -> [a] to the type environment
-
- 2. Typecheck the definition of f, all by itself,
- including generalising it to find its most general
- type, say f :: forall b. b -> b -> [b]
-
- 3. Extend the type environment with that type for f
-
- 4. Typecheck the definition of g, all by itself,
- checking that it has the type claimed by its signature
-
-Steps 2 and 4 each generate a separate AbsBinds, so we end
-up with
- Rec { AbsBinds { ...for f ... }
- ; AbsBinds { ...for g ... } }
-
-This approach allows both f and to call each other
-polymorphically, even though only g has a signature.
-
-We get an AbsBinds that encompasses multiple source-program
-bindings only when
- * Each binding in the group has at least one binder that
- lacks a user type signature
- * The group forms a strongly connected component
-
-
-Note [The abs_sig field of AbsBinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The abs_sig field supports a couple of special cases for bindings.
-Consider
-
- x :: Num a => (# a, a #)
- x = (# 3, 4 #)
-
-The general desugaring for AbsBinds would give
-
- x = /\a. \ ($dNum :: Num a) ->
- letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
- xm
-
-But that has an illegal let-binding for an unboxed tuple. In this
-case we'd prefer to generate the (more direct)
-
- x = /\ a. \ ($dNum :: Num a) ->
- (# fromInteger $dNum 3, fromInteger $dNum 4 #)
-
-A similar thing happens with representation-polymorphic defns
-(#11405):
-
- undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
- undef = error "undef"
-
-Again, the vanilla desugaring gives a local let-binding for a
-representation-polymorphic (undefm :: a), which is illegal. But
-again we can desugar without a let:
-
- undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
-
-The abs_sig field supports this direct desugaring, with no local
-let-binding. When abs_sig = True
-
- * the abs_binds is single FunBind
-
- * the abs_exports is a singleton
-
- * we have a complete type sig for binder
- and hence the abs_binds is non-recursive
- (it binds the mono_id but refers to the poly_id
-
-These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to
-generate code without a let-binding.
-
-Note [ABExport wrapper]
-~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- (f,g) = (\x.x, \y.y)
-This ultimately desugars to something like this:
- tup :: forall a b. (a->a, b->b)
- tup = /\a b. (\x:a.x, \y:b.y)
- f :: forall a. a -> a
- f = /\a. case tup a Any of
- (fm::a->a,gm:Any->Any) -> fm
- ...similarly for g...
-
-The abe_wrap field deals with impedance-matching between
- (/\a b. case tup a b of { (f,g) -> f })
-and the thing we really want, which may have fewer type
-variables. The action happens in GHC.Tc.Gen.Bind.mkExport.
--}
-
{-
************************************************************************
@@ -742,39 +483,6 @@ type LFixitySig pass = XRec pass (FixitySig pass)
data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity
| XFixitySig !(XXFixitySig pass)
--- | Type checker Specialisation Pragmas
---
--- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
-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
-
--- | Type checker Specification Pragma
-data TcSpecPrag
- = SpecPrag
- Id
- HsWrapper
- 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 []
-
-hasSpecPrags :: TcSpecPrags -> Bool
-hasSpecPrags (SpecPrags ps) = not (null ps)
-hasSpecPrags IsDefaultMethod = False
-
-isDefaultMethod :: TcSpecPrags -> Bool
-isDefaultMethod IsDefaultMethod = True
-isDefaultMethod (SpecPrags {}) = False
-
isFixityLSig :: forall p. UnXRec p => LSig p -> Bool
isFixityLSig (unXRec @p -> FixSig {}) = True
isFixityLSig _ = False
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 0abd64d0d8..92cf9d5f20 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1616,9 +1616,6 @@ data HsSplicedThing id
| HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern
--- See Note [Pending Splices]
-type SplicePointName = Name
-
data UntypedSpliceFlavour
= UntypedExpSplice
| UntypedPatSplice
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 6a33787d87..862c212c90 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -191,14 +191,9 @@ type family XXValBindsLR x x'
type family XFunBind x x'
type family XPatBind x x'
type family XVarBind x x'
-type family XAbsBinds x x'
type family XPatSynBind x x'
type family XXHsBindsLR x x'
--- ABExport type families
-type family XABE x
-type family XXABExport x
-
-- PatSynBind type families
type family XPSB x x'
type family XXPatSynBind x x'
diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs
index 392c318768..f9dbfff86c 100644
--- a/testsuite/tests/ghc-api/T6145.hs
+++ b/testsuite/tests/ghc-api/T6145.hs
@@ -37,7 +37,7 @@ main = do
removeFile "Test.hs"
print ok
where
- isDataCon (L _ (AbsBinds { abs_binds = bs }))
+ isDataCon (L _ (XHsBindsLR (AbsBinds { abs_binds = bs })))
= not (isEmptyBag (filterBag isDataCon bs))
isDataCon (L l (f@FunBind {}))
| (MG _ (L _ (m:_)) _) <- fun_matches f,
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index de44e14add..59b4113c1b 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -1514,92 +1514,91 @@
(HsTok))))))))
,(L
(SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 })
- (AbsBinds
- (NoExtField)
- []
- []
- [(ABE
- (NoExtField)
- {Var: main}
- {Var: main}
- (WpHole)
- (SpecPrags
- []))]
- [({abstract:TcEvBinds})]
- {Bag(LocatedA (HsBind Var)):
- [(L
- (SrcSpanAnn (EpAnn
- (Anchor
- { DumpTypecheckedAst.hs:19:1-23 }
- (UnchangedAnchor))
- (AnnListItem
- [])
- (EpaComments
- [])) { DumpTypecheckedAst.hs:19:1-23 })
- (FunBind
- (WpHole)
- (L
- (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 })
- {Var: main})
- (MG
- (MatchGroupTc
- []
- (TyConApp
- ({abstract:TyCon})
- [(TyConApp
- ({abstract:TyCon})
- [])]))
+ (XHsBindsLR
+ (AbsBinds
+ []
+ []
+ [(ABE
+ {Var: main}
+ {Var: main}
+ (WpHole)
+ (SpecPrags
+ []))]
+ [({abstract:TcEvBinds})]
+ {Bag(LocatedA (HsBind Var)):
+ [(L
+ (SrcSpanAnn (EpAnn
+ (Anchor
+ { DumpTypecheckedAst.hs:19:1-23 }
+ (UnchangedAnchor))
+ (AnnListItem
+ [])
+ (EpaComments
+ [])) { DumpTypecheckedAst.hs:19:1-23 })
+ (FunBind
+ (WpHole)
(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 })
- [(L
- (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 })
- (Match
- (EpAnnNotUsed)
- (FunRhs
- (L
- (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 })
- {Var: main})
- (Prefix)
- (NoSrcStrict))
- []
- (GRHSs
- (EpaComments
- [])
- [(L
- (SrcSpanAnn
- (EpAnnNotUsed)
- { DumpTypecheckedAst.hs:19:6-23 })
- (GRHS
- (EpAnnNotUsed)
- []
- (L
- (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-23 })
- (HsApp
- (EpAnnNotUsed)
- (L
- (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-15 })
- (HsVar
- (NoExtField)
- (L
- (SrcSpanAnn (EpAnnNotUsed) { <no location info> })
- {Var: putStrLn})))
- (L
- (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:17-23 })
- (HsLit
- (EpAnn
- (Anchor
- { DumpTypecheckedAst.hs:19:17-23 }
- (UnchangedAnchor))
- (NoEpAnns)
- (EpaComments
- []))
- (HsString
- (SourceText "hello")
- {FastString: "hello"})))))))]
- (EmptyLocalBinds
- (NoExtField)))))])
- (FromSource))
- []))]}
- (False)))]}
+ (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 })
+ {Var: main})
+ (MG
+ (MatchGroupTc
+ []
+ (TyConApp
+ ({abstract:TyCon})
+ [(TyConApp
+ ({abstract:TyCon})
+ [])]))
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 })
+ [(L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 })
+ (Match
+ (EpAnnNotUsed)
+ (FunRhs
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 })
+ {Var: main})
+ (Prefix)
+ (NoSrcStrict))
+ []
+ (GRHSs
+ (EpaComments
+ [])
+ [(L
+ (SrcSpanAnn
+ (EpAnnNotUsed)
+ { DumpTypecheckedAst.hs:19:6-23 })
+ (GRHS
+ (EpAnnNotUsed)
+ []
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-23 })
+ (HsApp
+ (EpAnnNotUsed)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-15 })
+ (HsVar
+ (NoExtField)
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { <no location info> })
+ {Var: putStrLn})))
+ (L
+ (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:17-23 })
+ (HsLit
+ (EpAnn
+ (Anchor
+ { DumpTypecheckedAst.hs:19:17-23 }
+ (UnchangedAnchor))
+ (NoEpAnns)
+ (EpaComments
+ []))
+ (HsString
+ (SourceText "hello")
+ {FastString: "hello"})))))))]
+ (EmptyLocalBinds
+ (NoExtField)))))])
+ (FromSource))
+ []))]}
+ (False))))]}
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
index dfbed9e490..a56fc3cf4f 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
@@ -48,7 +48,7 @@ typecheckPlugin [name, "typecheck"] _ tc
}
where notNamedAs name (L _ FunBind { fun_id = L _ fid })
= occNameString (getOccName fid) /= name
- notNamedAs name (L _ AbsBinds { abs_binds = bnds })
+ notNamedAs name (L _ (XHsBindsLR (AbsBinds { abs_binds = bnds })))
= all (notNamedAs name) bnds
notNamedAs _ (L _ b) = True
typecheckPlugin _ _ tc = return tc
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index c8f50ae793..3fb283e1ff 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1298,7 +1298,6 @@ instance ExactPrint (HsBind GhcPs) where
getAnnotationEntry FunBind{} = NoEntryVal
getAnnotationEntry PatBind{} = NoEntryVal
getAnnotationEntry VarBind{} = NoEntryVal
- getAnnotationEntry AbsBinds{} = NoEntryVal
getAnnotationEntry PatSynBind{} = NoEntryVal
exact (FunBind _ _ matches _) = do
diff --git a/utils/haddock b/utils/haddock
-Subproject 5d14361971ec6e6c3dfca282e4b80b307087afe
+Subproject e057bfc880d98fe872e3ee9291d2ee1cd3ceecc