Commit 7755ffc2 authored by Richard Eisenberg's avatar Richard Eisenberg Committed by Marge Bot

Introduce IsPass; refactor wrappers.

There are two main payloads of this patch:

1. This introduces IsPass, which allows e.g. printing
   code to ask what pass it is running in (Renamed vs
   Typechecked) and thus print extension fields. See
   Note [IsPass] in Hs.Extension

2. This moves the HsWrap constructor into an extension
   field, where it rightly belongs. This is done for
   HsExpr and HsCmd, but not for HsPat, which is left
   as an exercise for the reader.

There is also some refactoring around SyntaxExprs, but this
is really just incidental.

This patch subsumes !1721 (sorry @chreekat).

Along the way, there is a bit of refactoring in GHC.Hs.Extension,
including the removal of NameOrRdrName in favor of NoGhcTc.
This meant that we had no real need for GHC.Hs.PlaceHolder, so
I got rid of it.

Updates haddock submodule.

-------------------------
Metric Decrease:
    haddock.compiler
-------------------------
parent 309f8cfd
......@@ -12,8 +12,8 @@ therefore, is almost nothing but re-exporting.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data
......@@ -28,7 +28,6 @@ module GHC.Hs (
module GHC.Hs.Types,
module GHC.Hs.Utils,
module GHC.Hs.Doc,
module GHC.Hs.PlaceHolder,
module GHC.Hs.Extension,
Fixity,
......@@ -43,7 +42,6 @@ import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.ImpExp
import GHC.Hs.Lit
import GHC.Hs.PlaceHolder
import GHC.Hs.Extension
import GHC.Hs.Pat
import GHC.Hs.Types
......
......@@ -12,11 +12,13 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Hs.Binds where
......@@ -219,29 +221,29 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
FunBind {
fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains
-- the locally-bound
-- free variables of this defn.
-- See Note [Bind free vars]
fun_ext :: XFunBind idL idR,
-- ^ After the renamer (but before the type-checker), this contains the
-- locally-bound free variables of this defn. See Note [Bind free vars]
--
-- After the type-checker, this contains a coercion from the type of
-- the MatchGroup to the type of the Id. Example:
--
-- @
-- f :: Int -> forall a. a -> a
-- f x y = y
-- @
--
-- Then the MatchGroup will have type (Int -> a' -> a')
-- (with a free type variable a'). The coercion will take
-- a CoreExpr of this type and convert it to a CoreExpr of
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
-- the Id. Example:
--
-- @
-- f :: Int -> forall a. a -> a
-- f x y = y
-- @
--
-- Then the MatchGroup will have type (Int -> a' -> a')
-- (with a free type variable a'). The coercion will take
-- a CoreExpr of this type and convert it to a CoreExpr of
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
}
......@@ -320,8 +322,8 @@ data NPatBindTc = NPatBindTc {
} deriving Data
type instance XFunBind (GhcPass pL) GhcPs = NoExtField
type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables
type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
type instance XFunBind (GhcPass pL) GhcTc = HsWrapper -- See comments on FunBind.fun_ext
type instance XPatBind GhcPs (GhcPass pR) = NoExtField
type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables
......@@ -682,19 +684,6 @@ pprDeclList ds = pprDeeperList vcat ds
emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds = EmptyLocalBinds noExtField
-- AZ:These functions do not seem to be used at all?
isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool
isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds
isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds
isEmptyLocalBindsTc (EmptyLocalBinds _) = True
isEmptyLocalBindsTc (XHsLocalBindsLR _) = True
isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds
isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds
isEmptyLocalBindsPR (EmptyLocalBinds _) = True
isEmptyLocalBindsPR (XHsLocalBindsLR _) = True
eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
eqEmptyLocalBinds (EmptyLocalBinds _) = True
eqEmptyLocalBinds _ = False
......@@ -728,7 +717,8 @@ instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where
ppr mbind = ppr_monobind mbind
ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
ppr_monobind :: forall idL idR.
(OutputableBndrId idL, OutputableBndrId idR)
=> HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
......@@ -736,14 +726,15 @@ ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
= sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
ppr_monobind (FunBind { fun_id = fun,
fun_co_fn = wrap,
fun_matches = matches,
fun_tick = ticks })
fun_tick = ticks,
fun_ext = wrap })
= pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks)
$$ whenPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind matches
$$ whenPprDebug (ppr wrap)
$$ whenPprDebug (pprIfTc @idR $ ppr wrap)
ppr_monobind (PatSynBind _ psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
......@@ -759,7 +750,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, text "Exported types:" <+>
vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
, text "Binds:" <+> pprLHsBinds val_binds
, text "Evidence:" <+> ppr ev_binds ]
, pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) ]
else
pprLHsBinds val_binds
ppr_monobind (XHsBindsLR x) = ppr x
......@@ -768,7 +759,7 @@ instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
, pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]
ppr (XABExport x) = ppr x
instance (OutputableBndrId l, OutputableBndrId r,
......@@ -867,7 +858,7 @@ type instance XXIPBind (GhcPass p) = NoExtCon
instance OutputableBndrId p
=> Outputable (HsIPBinds (GhcPass p)) where
ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
$$ whenPprDebug (pprIfTc @p $ ppr ds)
ppr (XHsIPBinds x) = ppr x
instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
......
......@@ -8,10 +8,12 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
......@@ -2022,7 +2024,10 @@ instance OutputableBndrId p
ppr StockStrategy = text "stock"
ppr AnyclassStrategy = text "anyclass"
ppr NewtypeStrategy = text "newtype"
ppr (ViaStrategy ty) = text "via" <+> ppr ty
ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of
GhcPs -> ppr ty
GhcRn -> ppr ty
GhcTc -> ppr ty
-- | A short description of a @DerivStrategy'@.
derivStrategyName :: DerivStrategy a -> SDoc
......
This diff is collapsed.
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ExistentialQuantification #-}
......@@ -21,13 +21,12 @@ type role HsCmd nominal
type role MatchGroup nominal nominal
type role GRHSs nominal nominal
type role HsSplice nominal
type role SyntaxExpr nominal
data HsExpr (i :: *)
data HsCmd (i :: *)
data HsSplice (i :: *)
data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
type family SyntaxExpr (i :: *)
instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))
instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))
......
This diff is collapsed.
......@@ -11,8 +11,8 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
module GHC.Hs.ImpExp where
......
......@@ -242,11 +242,6 @@ deriving instance Data (RoleAnnotDecl GhcTc)
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs.Expr -----------------------------------
-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p)
deriving instance Data (SyntaxExpr GhcPs)
deriving instance Data (SyntaxExpr GhcRn)
deriving instance Data (SyntaxExpr GhcTc)
-- deriving instance (DataIdLR p p) => Data (HsPragE p)
deriving instance Data (HsPragE GhcPs)
deriving instance Data (HsPragE GhcRn)
......@@ -331,10 +326,13 @@ deriving instance Data (ArithSeqInfo GhcPs)
deriving instance Data (ArithSeqInfo GhcRn)
deriving instance Data (ArithSeqInfo GhcTc)
deriving instance Data RecordConTc
deriving instance Data CmdTopTc
deriving instance Data PendingRnSplice
deriving instance Data PendingTcSplice
deriving instance Data RecordConTc
deriving instance Data RecordUpdTc
deriving instance Data CmdTopTc
deriving instance Data PendingRnSplice
deriving instance Data PendingTcSplice
deriving instance Data SyntaxExprRn
deriving instance Data SyntaxExprTc
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs.Lit ------------------------------------
......
......@@ -10,8 +10,8 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
......@@ -151,23 +151,22 @@ overLitType :: HsOverLit GhcTc -> Type
overLitType (OverLit (OverLitTc _ ty) _ _) = ty
overLitType (XOverLit nec) = noExtCon nec
-- | Convert a literal from one index type to another, updating the annotations
-- according to the relevant 'Convertable' instance
convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b
convertLit (HsChar a x) = HsChar (convert a) x
convertLit (HsCharPrim a x) = HsCharPrim (convert a) x
convertLit (HsString a x) = HsString (convert a) x
convertLit (HsStringPrim a x) = HsStringPrim (convert a) x
convertLit (HsInt a x) = HsInt (convert a) x
convertLit (HsIntPrim a x) = HsIntPrim (convert a) x
convertLit (HsWordPrim a x) = HsWordPrim (convert a) x
convertLit (HsInt64Prim a x) = HsInt64Prim (convert a) x
convertLit (HsWord64Prim a x) = HsWord64Prim (convert a) x
convertLit (HsInteger a x b) = HsInteger (convert a) x b
convertLit (HsRat a x b) = HsRat (convert a) x b
convertLit (HsFloatPrim a x) = HsFloatPrim (convert a) x
convertLit (HsDoublePrim a x) = HsDoublePrim (convert a) x
convertLit (XLit a) = XLit (convert a)
-- | Convert a literal from one index type to another
convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit (HsChar a x) = HsChar a x
convertLit (HsCharPrim a x) = HsCharPrim a x
convertLit (HsString a x) = HsString a x
convertLit (HsStringPrim a x) = HsStringPrim a x
convertLit (HsInt a x) = HsInt a x
convertLit (HsIntPrim a x) = HsIntPrim a x
convertLit (HsWordPrim a x) = HsWordPrim a x
convertLit (HsInt64Prim a x) = HsInt64Prim a x
convertLit (HsWord64Prim a x) = HsWord64Prim a x
convertLit (HsInteger a x b) = HsInteger a x b
convertLit (HsRat a x b) = HsRat a x b
convertLit (HsFloatPrim a x) = HsFloatPrim a x
convertLit (HsDoublePrim a x) = HsDoublePrim a x
convertLit (XLit a) = XLit a
{-
Note [ol_rebindable]
......
......@@ -11,12 +11,14 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Hs.Pat (
Pat(..), InPat, OutPat, LPat,
......@@ -156,9 +158,7 @@ data Pat p
-- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,
-- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@
| SumPat (XSumPat p) -- GHC.Hs.PlaceHolder before typechecker, filled in
-- afterwards with the types of the
-- alternative
| SumPat (XSumPat p) -- after typechecker, types of the alternative
(LPat p) -- Sum sub-pattern
ConTag -- Alternative (one-based)
Arity -- Arity (INVARIANT: ≥ 2)
......@@ -246,7 +246,7 @@ data Pat p
-- a new hs-boot file. Not worth it.
(SyntaxExpr p) -- (>=) function, of type t1->t2->Bool
(SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntaxName)
(SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntax)
-- ^ n+k pattern
------------ Pattern type signatures ---------------
......@@ -511,7 +511,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
pprPat (WildPat _) = char '_'
pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
......@@ -525,11 +525,16 @@ pprPat (NPat _ l Nothing _) = ppr l
pprPat (NPat _ l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k]
pprPat (SplicePat _ splice) = pprSplice splice
pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens
-> if parens
pprPat (CoPat _ co pat _) = pprIfTc @p $
pprHsWrapper co $ \parens
-> if parens
then pprParendPat appPrec pat
else pprPat pat
pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty
where ppr_ty = case ghcPass @p of
GhcPs -> ppr ty
GhcRn -> ppr ty
GhcTc -> ppr ty
pprPat (ListPat _ pats) = brackets (interpp'SP pats)
pprPat (TuplePat _ pats bx)
-- Special-case unary boxed tuples so that they are pretty-printed as
......@@ -553,7 +558,7 @@ pprPat (ConPatOut { pat_con = con
if gopt Opt_PrintTypecheckerElaboration dflags then
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, ppr binds])
, pprIfTc @p $ ppr binds ])
<+> pprConArgs details
else pprUserCon (unLoc con) details
pprPat (XPat n) = noExtCon n
......
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilies #-}
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
module GHC.Hs.PlaceHolder where
import Name
import NameSet
import RdrName
import Var
{-
%************************************************************************
%* *
\subsection{Annotating the syntax}
%* *
%************************************************************************
-}
-- NB: These are intentionally open, allowing API consumers (like Haddock)
-- to declare new instances
placeHolderNamesTc :: NameSet
placeHolderNamesTc = emptyNameSet
{-
TODO:AZ: remove this, and check if we still need all the UndecidableInstances
Note [Pass sensitive types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since the same AST types are re-used through parsing,renaming and type
checking there are naturally some places in the AST that do not have
any meaningful value prior to the pass they are assigned a value.
Historically these have been filled in with place holder values of the form
panic "error message"
This has meant the AST is difficult to traverse using standard generic
programming techniques. The problem is addressed by introducing
pass-specific data types, implemented as a pair of open type families,
one for PostTc and one for PostRn. These are then explicitly populated
with a PlaceHolder value when they do not yet have meaning.
In terms of actual usage, we have the following
PostTc id Kind
PostTc id Type
PostRn id Fixity
PostRn id NameSet
TcId and Var are synonyms for Id
Unfortunately the type checker termination checking conditions fail for the
DataId constraint type based on this, so even though it is safe the
UndecidableInstances pragma is required where this is used.
-}
-- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext',
-- for printing messages related to a 'Match'
type family NameOrRdrName id where
NameOrRdrName Id = Name
NameOrRdrName Name = Name
NameOrRdrName RdrName = RdrName
......@@ -11,8 +11,8 @@ GHC.Hs.Types: Abstract syntax: user-defined types
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module GHC.Hs.Extension
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
......
This diff is collapsed.
......@@ -280,7 +280,7 @@ checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions.
checkGuardMatches :: HsMatchContext Name -- Match context
checkGuardMatches :: HsMatchContext GhcRn -- Match context
-> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
-> DsM ()
checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
......
......@@ -643,16 +643,16 @@ instance HasType (LHsExpr GhcTc) where
-- See impact on Haddock output (esp. missing type annotations or links)
-- before marking more things here as 'False'. See impact on Haddock
-- performance before marking more things as 'True'.
skipDesugaring :: HsExpr a -> Bool
skipDesugaring :: HsExpr GhcTc -> Bool
skipDesugaring e = case e of
HsVar{} -> False
HsUnboundVar{} -> False
HsConLikeOut{} -> False
HsRecFld{} -> False
HsOverLabel{} -> False
HsIPVar{} -> False
HsWrap{} -> False
_ -> True
HsVar{} -> False
HsUnboundVar{} -> False
HsConLikeOut{} -> False
HsRecFld{} -> False
HsOverLabel{} -> False
HsIPVar{} -> False
XExpr (HsWrap{}) -> False
_ -> True
instance ( ToHie (Context (Located (IdP a)))
, ToHie (MatchGroup a (LHsExpr a))
......@@ -732,7 +732,7 @@ instance ( ToHie (MatchGroup a (LHsExpr a))
instance ( a ~ GhcPass p
, ToHie body
, ToHie (HsMatchContext (NameOrRdrName (IdP a)))
, ToHie (HsMatchContext (NoGhcTc a))
, ToHie (PScoped (LPat a))
, ToHie (GRHSs a body)
, Data (Match a body)
......@@ -746,7 +746,7 @@ instance ( a ~ GhcPass p
]
XMatch _ -> []
instance ( ToHie (Context (Located a))
instance ( ToHie (Context (Located (IdP a)))
) => ToHie (HsMatchContext a) where
toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
toHie (StmtCtxt a) = toHie a
......@@ -885,6 +885,7 @@ instance ( a ~ GhcPass p
, Data (HsTupArg a)
, Data (AmbiguousFieldOcc a)
, (HasRealDataConName a)
, IsPass p
) => ToHie (LHsExpr (GhcPass p)) where
toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
HsVar _ (L _ var) ->
......@@ -997,9 +998,6 @@ instance ( a ~ GhcPass p
HsBinTick _ _ _ expr ->
[ toHie expr
]
HsWrap _ _ a ->
[ toHie $ L mspan a
]
HsBracket _ b ->
[ toHie b
]
......@@ -1014,7 +1012,13 @@ instance ( a ~ GhcPass p
HsSpliceE _ x ->
[ toHie $ L mspan x
]
XExpr _ -> []
XExpr x
| GhcTc <- ghcPass @p
, HsWrap _ a <- x
-> [ toHie $ L mspan a ]
| otherwise
-> []
instance ( a ~ GhcPass p
, ToHie (LHsExpr a)
......@@ -1244,7 +1248,6 @@ instance ( a ~ GhcPass p
[ pure $ locOnly ispan
, toHie $ listScopes NoScope stmts
]
HsCmdWrap _ _ _ -> []
XCmd _ -> []
instance ToHie (TyClGroup GhcRn) where
......
......@@ -1162,7 +1162,7 @@ checkDupMinimalSigs sigs
************************************************************************
-}
rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> MatchGroup GhcPs (Located (body GhcPs))
-> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
......@@ -1173,13 +1173,13 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
; return (mkMatchGroup origin new_ms, ms_fvs) }
rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec
rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LMatch GhcPs (Located (body GhcPs))
-> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)
rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> Match GhcPs (Located (body GhcPs))
-> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
......@@ -1195,7 +1195,7 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
, m_grhss = grhss'}, grhss_fvs ) }}
rnMatch' _ _ (XMatch nec) = noExtCon nec
emptyCaseErr :: HsMatchContext Name -> SDoc
emptyCaseErr :: HsMatchContext GhcRn -> SDoc
emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
2 (text "Use EmptyCase to allow this")
where
......@@ -1212,7 +1212,7 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
************************************************************************
-}
rnGRHSs :: HsMatchContext Name
rnGRHSs :: HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHSs GhcPs (Located (body GhcPs))
-> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
......@@ -1222,13 +1222,13 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)
rnGRHSs _ _ (XGRHSs nec) = noExtCon nec
rnGRHS :: HsMatchContext Name
rnGRHS :: HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> LGRHS GhcPs (Located (body GhcPs))
-> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
rnGRHS' :: HsMatchContext Name
rnGRHS' :: HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHS GhcPs (Located (body GhcPs))
-> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
......
......@@ -30,7 +30,7 @@ module GHC.Rename.Env (
lookupGreAvailRn,
-- Rebindable Syntax
lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,
lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,
lookupIfThenElse,
-- Constructing usage information
......@@ -81,6 +81,7 @@ import GHC.Rename.Utils
import qualified Data.Semigroup as Semi
import Data.Either ( partitionEithers )
import Data.List (find)
import Control.Arrow ( first )
{-
*********************************************************
......@@ -1625,45 +1626,46 @@ We store the relevant Name in the HsSyn tree, in
* HsDo
respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does.
name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does.
We treat the original (standard) names as free-vars too, because the type checker
checks the type of the user thing against the type of the standard thing.
-}
lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
-- Different to lookupSyntaxName because in the non-rebindable
lookupIfThenElse :: Bool -- False <=> don't use rebindable syntax under any conditions
-> RnM (SyntaxExpr GhcRn, FreeVars)
-- Different to lookupSyntax because in the non-rebindable
-- case we desugar directly rather than calling an existing function
-- Hence the (Maybe (SyntaxExpr GhcRn)) return type
lookupIfThenElse
lookupIfThenElse maybe_use_rs
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on
then return (Nothing, emptyFVs)
; if not (rebindable_on && maybe_use_rs)
then return (NoSyntaxExprRn, emptyFVs)
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
; return ( Just (mkRnSyntaxExpr ite)
; return ( mkRnSyntaxExpr ite
, unitFV ite ) } }
lookupSyntaxName' :: Name -- ^ The standard name