summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.hs306
-rw-r--r--compiler/rename/RnEnv.hs251
-rw-r--r--compiler/rename/RnExpr.hs566
-rw-r--r--compiler/rename/RnFixity.hs7
-rw-r--r--compiler/rename/RnHsDoc.hs4
-rw-r--r--compiler/rename/RnNames.hs339
-rw-r--r--compiler/rename/RnPat.hs214
-rw-r--r--compiler/rename/RnSource.hs1005
-rw-r--r--compiler/rename/RnSplice.hs109
-rw-r--r--compiler/rename/RnSplice.hs-boot5
-rw-r--r--compiler/rename/RnTypes.hs1371
-rw-r--r--compiler/rename/RnUnbound.hs13
-rw-r--r--compiler/rename/RnUtils.hs52
13 files changed, 2323 insertions, 1919 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index e18068bc2b..7cd5c55245 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -21,16 +21,17 @@ module RnBinds (
-- Other bindings
rnMethodBinds, renameSigs,
- rnMatchGroup, rnGRHSs, rnGRHS,
+ rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
makeMiniFixityEnv, MiniFixityEnv,
HsSigCtxt(..)
) where
+import GhcPrelude
+
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import TcRnMonad
-import TcEvidence ( emptyTcEvBinds )
import RnTypes
import RnPat
import RnNames
@@ -47,18 +48,19 @@ import NameSet
import RdrName ( RdrName, rdrNameOcc )
import SrcLoc
import ListSetOps ( findDupsEq )
-import BasicTypes ( RecFlag(..), LexicalFixity(..) )
+import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..) )
import Bag
import Util
import Outputable
-import FastString
import UniqSet
import Maybes ( orElse )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
-import Data.List ( partition, sort )
+import Data.Foldable ( toList )
+import Data.List ( partition, sort )
+import Data.List.NonEmpty ( NonEmpty(..) )
{-
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -180,10 +182,10 @@ rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
-> RnM (HsValBinds GhcRn, DefUses)
-- A hs-boot file has no bindings.
-- Return a single HsBindGroup with empty binds and renamed signatures
-rnTopBindsBoot bound_names (ValBindsIn mbinds sigs)
+rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
- ; return (ValBindsOut [] sigs', usesOnly fvs) }
+ ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
{-
@@ -200,27 +202,31 @@ rnLocalBindsAndThen :: HsLocalBinds GhcPs
-- This version (a) assumes that the binding vars are *not* already in scope
-- (b) removes the binders from the free vars of the thing inside
-- The parser doesn't produce ThenBinds
-rnLocalBindsAndThen EmptyLocalBinds thing_inside =
- thing_inside EmptyLocalBinds emptyNameSet
+rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =
+ thing_inside (EmptyLocalBinds x) emptyNameSet
-rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
+rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside
= rnLocalValBindsAndThen val_binds $ \ val_binds' ->
- thing_inside (HsValBinds val_binds')
+ thing_inside (HsValBinds x val_binds')
-rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
+rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
(binds',fv_binds) <- rnIPBinds binds
- (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds
+ (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
return (thing, fvs_thing `plusFV` fv_binds)
+rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"
+
rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
-rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
+rnIPBinds (IPBinds _ ip_binds ) = do
(ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
- return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
+ return (IPBinds noExt ip_binds', plusFVs fvs_s)
+rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"
rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
-rnIPBind (IPBind ~(Left n) expr) = do
+rnIPBind (IPBind _ ~(Left n) expr) = do
(expr',fvExpr) <- rnLExpr expr
- return (IPBind (Left n) expr', fvExpr)
+ return (IPBind noExt (Left n) expr', fvExpr)
+rnIPBind (XIPBind _) = panic "rnIPBind"
{-
************************************************************************
@@ -271,9 +277,9 @@ rnLocalValBindsLHS fix_env binds
rnValBindsLHS :: NameMaker
-> HsValBinds GhcPs
-> RnM (HsValBindsLR GhcRn GhcPs)
-rnValBindsLHS topP (ValBindsIn mbinds sigs)
+rnValBindsLHS topP (ValBinds x mbinds sigs)
= do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
- ; return $ ValBindsIn mbinds' sigs }
+ ; return $ ValBinds x mbinds' sigs }
where
bndrs = collectHsBindsBinders mbinds
doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs
@@ -288,12 +294,12 @@ rnValBindsRHS :: HsSigCtxt
-> HsValBindsLR GhcRn GhcPs
-> RnM (HsValBinds GhcRn, DefUses)
-rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
+rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
= do { (sigs', sig_fvs) <- renameSigs ctxt sigs
- ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
+ ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds
; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
- ; let patsyn_fvs = foldr (unionNameSet . psb_fvs) emptyNameSet $
+ ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $
getPatSynBinds anal_binds
-- The uses in binds_w_dus for PatSynBinds do not include
-- variables used in the patsyn builders; see
@@ -308,7 +314,7 @@ rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
-- so that the binders are removed from
-- the uses in the sigs
- ; return (ValBindsOut anal_binds sigs', valbind'_dus) }
+ ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }
rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
@@ -333,10 +339,10 @@ rnLocalValBindsAndThen
:: HsValBinds GhcPs
-> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
-rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
+rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
= do { -- (A) Create the local fixity environment
- new_fixities <- makeMiniFixityEnv [L loc sig
- | L loc (FixSig sig) <- sigs]
+ new_fixities <- makeMiniFixityEnv [ L loc sig
+ | L loc (FixSig _ sig) <- sigs]
-- (B) Rename the LHSes
; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
@@ -402,27 +408,27 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
= do
-- we don't actually use the FV processing of rnPatsAndThen here
(pat',pat'_fvs) <- rnBindPat name_maker pat
- return (bind { pat_lhs = pat', bind_fvs = pat'_fvs })
+ return (bind { pat_lhs = pat', pat_ext = pat'_fvs })
-- We temporarily store the pat's FVs in bind_fvs;
-- gets updated to the FVs of the whole bind
-- when doing the RHS below
rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
= do { name <- applyNameMaker name_maker rdr_name
- ; return (bind { fun_id = name
- , bind_fvs = placeHolderNamesTc }) }
+ ; return (bind { fun_id = name
+ , fun_ext = noExt }) }
-rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
+rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
= do { addLocM checkConName rdrname
; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already
- ; return (PatSynBind psb{ psb_id = name }) }
+ ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
| otherwise -- Pattern synonym, not at top level
= do { addErr localPatternSynonymErr -- Complain, but make up a fake
-- name so that we can carry on
; name <- applyNameMaker name_maker rdrname
- ; return (PatSynBind psb{ psb_id = name }) }
+ ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr
@@ -447,7 +453,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
-- pat fvs were stored in bind_fvs
-- after processing the LHS
- , bind_fvs = pat_fvs })
+ , pat_ext = pat_fvs })
= do { mod <- getModule
; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
@@ -459,14 +465,15 @@ rnBind _ bind@(PatBind { pat_lhs = pat
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
bndrs = collectPatBinders pat
bind' = bind { pat_rhs = grhss'
- , pat_rhs_ty = placeHolderType, bind_fvs = fvs' }
+ , pat_ext = fvs' }
ok_nobind_pat
= -- See Note [Pattern bindings that bind no variables]
case pat of
- L _ (WildPat {}) -> True
- L _ (BangPat {}) -> True -- #9127, #13646
- _ -> False
+ L _ (WildPat {}) -> True
+ L _ (BangPat {}) -> True -- #9127, #13646
+ L _ (SplicePat {}) -> True
+ _ -> False
-- Warn if the pattern binds no variables
-- See Note [Pattern bindings that bind no variables]
@@ -498,13 +505,13 @@ rnBind sig_fn bind@(FunBind { fun_id = name
; fvs' `seq` -- See Note [Free-variable space leak]
return (bind { fun_matches = matches'
- , bind_fvs = fvs' },
+ , fun_ext = fvs' },
[plain_name], rhs_fvs)
}
-rnBind sig_fn (PatSynBind bind)
+rnBind sig_fn (PatSynBind x bind)
= do { (bind', name, fvs) <- rnPatSynBind sig_fn bind
- ; return (PatSynBind bind', name, fvs) }
+ ; return (PatSynBind x bind', name, fvs) }
rnBind _ b = pprPanic "rnBind" (ppr b)
@@ -512,7 +519,7 @@ rnBind _ b = pprPanic "rnBind" (ppr b)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally, we want to warn about pattern bindings like
Just _ = e
-because they don't do anything! But we have two exceptions:
+because they don't do anything! But we have three exceptions:
* A wildcard pattern
_ = rhs
@@ -526,6 +533,12 @@ because they don't do anything! But we have two exceptions:
Moreover, Trac #13646 argues that even for single constructor
types, you might want to write the constructor. See also #9127.
+* A splice pattern
+ $(th-lhs) = rhs
+ It is impossible to determine whether or not th-lhs really
+ binds any variable. We should disable the warning for any pattern
+ which contain splices, but that is a more expensive check.
+
Note [Free-variable space leak]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have
@@ -568,31 +581,31 @@ depAnalBinds binds_w_dus
---------------------
-- Bind the top-level forall'd type variables in the sigs.
--- E.g f :: a -> a
+-- E.g f :: forall a. a -> a
-- f = rhs
-- The 'a' scopes over the rhs
--
-- NB: there'll usually be just one (for a function binding)
-- but if there are many, one may shadow the rest; too bad!
--- e.g x :: [a] -> [a]
--- y :: [(a,a)] -> a
+-- e.g x :: forall a. [a] -> [a]
+-- y :: forall a. [(a,a)] -> a
-- (x,y) = e
-- In e, 'a' will be in scope, and it'll be the one from 'y'!
-mkSigTvFn :: [LSig GhcRn] -> (Name -> [Name])
+mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])
-- Return a lookup function that maps an Id Name to the names
-- of the type variables that should scope over its body.
-mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` []
+mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
where
env = mkHsSigEnv get_scoped_tvs sigs
get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
-- Returns (binders, scoped tvs for those binders)
- get_scoped_tvs (L _ (ClassOpSig _ names sig_ty))
+ get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
= Just (names, hsScopedTvs sig_ty)
- get_scoped_tvs (L _ (TypeSig names sig_ty))
+ get_scoped_tvs (L _ (TypeSig _ names sig_ty))
= Just (names, hsWcScopedTvs sig_ty)
- get_scoped_tvs (L _ (PatSynSig names sig_ty))
+ get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
= Just (names, hsScopedTvs sig_ty)
get_scoped_tvs _ = Nothing
@@ -607,9 +620,10 @@ makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
where
- add_one_sig env (L loc (FixitySig names fixity)) =
+ add_one_sig env (L loc (FixitySig _ names fixity)) =
foldlM add_one env [ (loc,name_loc,name,fixity)
| L name_loc name <- names ]
+ add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"
add_one env (loc, name_loc, name,fixity) = do
{ -- this fixity decl is a duplicate iff
@@ -649,27 +663,27 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
-- invariant: no free vars here when it's a FunBind
= do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
; unless pattern_synonym_ok (addErr patternSynonymErr)
- ; let sig_tvs = sig_fn name
+ ; let scoped_tvs = sig_fn name
- ; ((pat', details'), fvs1) <- bindSigTyVarsFV sig_tvs $
+ ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
rnPat PatSyn pat $ \pat' ->
-- We check the 'RdrName's instead of the 'Name's
-- so that the binding locations are reported
-- from the left-hand side
case details of
- PrefixPatSyn vars ->
+ PrefixCon vars ->
do { checkDupRdrNames vars
; names <- mapM lookupPatSynBndr vars
- ; return ( (pat', PrefixPatSyn names)
+ ; return ( (pat', PrefixCon names)
, mkFVs (map unLoc names)) }
- InfixPatSyn var1 var2 ->
+ InfixCon var1 var2 ->
do { checkDupRdrNames [var1, var2]
; name1 <- lookupPatSynBndr var1
; name2 <- lookupPatSynBndr var2
-- ; checkPrecMatch -- TODO
- ; return ( (pat', InfixPatSyn name1 name2)
+ ; return ( (pat', InfixCon name1 name2)
, mkFVs (map unLoc [name1, name2])) }
- RecordPatSyn vars ->
+ RecCon vars ->
do { checkDupRdrNames (map recordPatSynSelectorId vars)
; let rnRecordPatSynField
(RecordPatSynField { recordPatSynSelectorId = visible
@@ -679,14 +693,14 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
; return $ RecordPatSynField { recordPatSynSelectorId = visible'
, recordPatSynPatVar = hidden' } }
; names <- mapM rnRecordPatSynField vars
- ; return ( (pat', RecordPatSyn names)
+ ; return ( (pat', RecCon names)
, mkFVs (map (unLoc . recordPatSynPatVar) names)) }
; (dir', fvs2) <- case dir of
Unidirectional -> return (Unidirectional, emptyFVs)
ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
ExplicitBidirectional mg ->
- do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $
+ do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $
rnMatchGroup (mkPrefixFunRhs (L l name))
rnLExpr mg
; return (ExplicitBidirectional mg', fvs) }
@@ -701,9 +715,9 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
bind' = bind{ psb_args = details'
, psb_def = pat'
, psb_dir = dir'
- , psb_fvs = fvs' }
+ , psb_ext = fvs' }
selector_names = case details' of
- RecordPatSyn names ->
+ RecCon names ->
map (unLoc . recordPatSynSelectorId) names
_ -> []
@@ -720,6 +734,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
= hang (text "Illegal pattern synonym declaration")
2 (text "Use -XPatternSynonyms to enable this extension")
+rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"
+
{-
Note [Renaming pattern synonym variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -851,7 +867,7 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs
-- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
; scoped_tvs <- xoptM LangExt.ScopedTypeVariables
; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
- do { binds_w_dus <- mapBagM (rnLBind (mkSigTvFn other_sigs')) binds'
+ do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'
; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
emptyFVs binds_w_dus
; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
@@ -873,9 +889,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
= setSrcSpan loc $ do
do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name
-- We use the selector name as the binder
- ; let bind' = bind { fun_id = sel_name
- , bind_fvs = placeHolderNamesTc }
-
+ ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }
; return (L loc bind' `consBag` rest ) }
-- Report error for all other forms of bindings
@@ -938,42 +952,41 @@ renameSigs ctxt sigs
-- Doesn't seem worth much trouble to sort this.
renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
--- FixitySig is renamed elsewhere.
-renameSig _ (IdSig x)
- = return (IdSig x, emptyFVs) -- Actually this never occurs
+renameSig _ (IdSig _ x)
+ = return (IdSig noExt x, emptyFVs) -- Actually this never occurs
-renameSig ctxt sig@(TypeSig vs ty)
+renameSig ctxt sig@(TypeSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; let doc = TypeSigCtx (ppr_sig_bndrs vs)
; (new_ty, fvs) <- rnHsSigWcType doc ty
- ; return (TypeSig new_vs new_ty, fvs) }
+ ; return (TypeSig noExt new_vs new_ty, fvs) }
-renameSig ctxt sig@(ClassOpSig is_deflt vs ty)
+renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
= do { defaultSigs_on <- xoptM LangExt.DefaultSignatures
; when (is_deflt && not defaultSigs_on) $
addErr (defaultSigErr sig)
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
- ; return (ClassOpSig is_deflt new_v new_ty, fvs) }
+ ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }
where
(v1:_) = vs
ty_ctxt = GenericCtx (text "a class method signature for"
<+> quotes (ppr v1))
-renameSig _ (SpecInstSig src ty)
+renameSig _ (SpecInstSig _ src ty)
= do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
- ; return (SpecInstSig src new_ty,fvs) }
+ ; return (SpecInstSig noExt src new_ty,fvs) }
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
-- so, in the top-level case (when mb_names is Nothing)
-- we use lookupOccRn. If there's both an imported and a local 'f'
-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
-renameSig ctxt sig@(SpecSig v tys inl)
+renameSig ctxt sig@(SpecSig _ v tys inl)
= do { new_v <- case ctxt of
TopSigCtxt {} -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
- ; return (SpecSig new_v new_ty inl, fvs) }
+ ; return (SpecSig noExt new_v new_ty inl, fvs) }
where
ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
<+> quotes (ppr v))
@@ -981,33 +994,33 @@ renameSig ctxt sig@(SpecSig v tys inl)
= do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
-renameSig ctxt sig@(InlineSig v s)
+renameSig ctxt sig@(InlineSig _ v s)
= do { new_v <- lookupSigOccRn ctxt sig v
- ; return (InlineSig new_v s, emptyFVs) }
+ ; return (InlineSig noExt new_v s, emptyFVs) }
-renameSig ctxt sig@(FixSig (FixitySig vs f))
- = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
- ; return (FixSig (FixitySig new_vs f), emptyFVs) }
+renameSig ctxt (FixSig _ fsig)
+ = do { new_fsig <- rnSrcFixityDecl ctxt fsig
+ ; return (FixSig noExt new_fsig, emptyFVs) }
-renameSig ctxt sig@(MinimalSig s (L l bf))
+renameSig ctxt sig@(MinimalSig _ s (L l bf))
= do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
- return (MinimalSig s (L l new_bf), emptyFVs)
+ return (MinimalSig noExt s (L l new_bf), emptyFVs)
-renameSig ctxt sig@(PatSynSig vs ty)
+renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; (ty', fvs) <- rnHsSigType ty_ctxt ty
- ; return (PatSynSig new_vs ty', fvs) }
+ ; return (PatSynSig noExt new_vs ty', fvs) }
where
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
<+> ppr_sig_bndrs vs)
-renameSig ctxt sig@(SCCFunSig st v s)
+renameSig ctxt sig@(SCCFunSig _ st v s)
= do { new_v <- lookupSigOccRn ctxt sig v
- ; return (SCCFunSig st new_v s, emptyFVs) }
+ ; return (SCCFunSig noExt st new_v s, emptyFVs) }
-- COMPLETE Sigs can refer to imported IDs which is why we use
-- lookupLocatedOccRn rather than lookupSigOccRn
-renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
+renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
= do new_bf <- traverse lookupLocatedOccRn bf
new_mty <- traverse lookupLocatedOccRn mty
@@ -1016,7 +1029,7 @@ renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
-- Why 'any'? See Note [Orphan COMPLETE pragmas]
addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
- return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs)
+ return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)
where
orphanError :: SDoc
orphanError =
@@ -1024,6 +1037,8 @@ renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty)
text "A COMPLETE pragma must mention at least one data constructor" $$
text "or pattern synonym defined in the same module."
+renameSig _ (XSig _) = panic "renameSig"
+
{-
Note [Orphan COMPLETE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1090,8 +1105,10 @@ okHsSig ctxt (L _ sig)
(CompleteMatchSig {}, TopSigCtxt {} ) -> True
(CompleteMatchSig {}, _) -> False
+ (XSig _, _) -> panic "okHsSig"
+
-------------------
-findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]]
+findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
-- not-in-scope binders, which gives bogus dup-sig errors
@@ -1103,20 +1120,20 @@ findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]]
findDupSigs sigs
= findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
where
- expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig)
- expand_sig sig@(InlineSig n _) = [(n,sig)]
- expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns]
- expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns]
- expand_sig sig@(PatSynSig ns _ ) = [(n,sig) | n <- ns]
- expand_sig sig@(SCCFunSig _ n _) = [(n,sig)]
+ expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
+ expand_sig sig@(InlineSig _ n _) = [(n,sig)]
+ expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns]
+ expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns]
+ expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns]
+ expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)]
expand_sig _ = []
matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2
mtch (FixSig {}) (FixSig {}) = True
mtch (InlineSig {}) (InlineSig {}) = True
mtch (TypeSig {}) (TypeSig {}) = True
- mtch (ClassOpSig d1 _ _) (ClassOpSig d2 _ _) = d1 == d2
- mtch (PatSynSig _ _) (PatSynSig _ _) = True
+ mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
+ mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True
mtch (SCCFunSig{}) (SCCFunSig{}) = True
mtch _ _ = False
@@ -1144,6 +1161,7 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup origin new_ms, ms_fvs) }
+rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"
rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1155,24 +1173,17 @@ rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> Match GhcPs (Located (body GhcPs))
-> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
-rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats
- , m_type = maybe_rhs_sig, m_grhss = grhss })
- = do { -- Result type signatures are no longer supported
- case maybe_rhs_sig of
- Nothing -> return ()
- Just (L loc ty) -> addErrAt loc (resSigErr match ty)
-
- ; let fixity = if isInfixMatch match then Infix else Prefix
- -- Now the main event
- -- Note that there are no local fixity decls for matches
+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
+ = do { -- Note that there are no local fixity decls for matches
; rnPats ctxt pats $ \ pats' -> do
{ (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
- ; let mf' = case (ctxt,mf) of
- (FunRhs (L _ funid) _ _,FunRhs (L lf _) _ strict)
- -> FunRhs (L lf funid) fixity strict
+ ; let mf' = case (ctxt, mf) of
+ (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
+ -> mf { mc_fun = L lf funid }
_ -> ctxt
- ; return (Match { m_ctxt = mf', m_pats = pats'
- , m_type = Nothing, m_grhss = grhss'}, grhss_fvs ) }}
+ ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'
+ , m_grhss = grhss'}, grhss_fvs ) }}
+rnMatch' _ _ (XMatch _) = panic "rnMatch'"
emptyCaseErr :: HsMatchContext Name -> SDoc
emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
@@ -1183,15 +1194,6 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
LambdaExpr -> text "\\case expression"
_ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
-
-resSigErr :: Outputable body
- => Match GhcPs body -> HsType GhcPs -> SDoc
-resSigErr match ty
- = vcat [ text "Illegal result type signature" <+> quotes (ppr ty)
- , nest 2 $ ptext (sLit
- "Result signatures are no longer supported in pattern matches")
- , pprMatchInCtxt match ]
-
{-
************************************************************************
* *
@@ -1204,10 +1206,11 @@ rnGRHSs :: HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHSs GhcPs (Located (body GhcPs))
-> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
-rnGRHSs ctxt rnBody (GRHSs grhss (L l binds))
+rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
= rnLocalBindsAndThen binds $ \ binds' _ -> do
(grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
- return (GRHSs grhss' (L l binds'), fvGRHSs)
+ return (GRHSs noExt grhss' (L l binds'), fvGRHSs)
+rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"
rnGRHS :: HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1219,7 +1222,7 @@ rnGRHS' :: HsMatchContext Name
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> GRHS GhcPs (Located (body GhcPs))
-> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
-rnGRHS' ctxt rnBody (GRHS guards rhs)
+rnGRHS' ctxt rnBody (GRHS _ guards rhs)
= do { pattern_guards_allowed <- xoptM LangExt.PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
rnBody rhs
@@ -1227,14 +1230,48 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
; unless (pattern_guards_allowed || is_standard_guard guards')
(addWarn NoReason (nonStdGuardErr guards'))
- ; return (GRHS guards' rhs', fvs) }
+ ; return (GRHS noExt guards' rhs', fvs) }
where
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [] = True
- is_standard_guard [L _ (BodyStmt _ _ _ _)] = True
- is_standard_guard _ = False
+ is_standard_guard [] = True
+ is_standard_guard [L _ (BodyStmt {})] = True
+ is_standard_guard _ = False
+rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"
+
+{-
+*********************************************************
+* *
+ Source-code fixity declarations
+* *
+*********************************************************
+-}
+
+rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
+-- Rename a fixity decl, so we can put
+-- the renamed decl in the renamed syntax tree
+-- Errors if the thing being fixed is not defined locally.
+rnSrcFixityDecl sig_ctxt = rn_decl
+ where
+ rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
+ -- GHC extension: look up both the tycon and data con
+ -- for con-like things; hence returning a list
+ -- If neither are in scope, report an error; otherwise
+ -- return a fixity sig for each (slightly odd)
+ rn_decl (FixitySig _ fnames fixity)
+ = do names <- concatMapM lookup_one fnames
+ return (FixitySig noExt names fixity)
+ rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"
+
+ lookup_one :: Located RdrName -> RnM [Located Name]
+ lookup_one (L name_loc rdr_name)
+ = setSrcSpan name_loc $
+ -- This lookup will fail if the name is not defined in the
+ -- same binding group as this fixity declaration.
+ do names <- lookupLocalTcNames sig_ctxt what rdr_name
+ return [ L name_loc name | (_, name) <- names ]
+ what = text "fixity signature"
{-
************************************************************************
@@ -1244,17 +1281,18 @@ rnGRHS' ctxt rnBody (GRHS guards rhs)
************************************************************************
-}
-dupSigDeclErr :: [(Located RdrName, Sig GhcPs)] -> RnM ()
-dupSigDeclErr pairs@((L loc name, sig) : _)
+dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()
+dupSigDeclErr pairs@((L loc name, sig) :| _)
= addErrAt loc $
vcat [ text "Duplicate" <+> what_it_is
<> text "s for" <+> quotes (ppr name)
- , text "at" <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ]
+ , text "at" <+> vcat (map ppr $ sort
+ $ map (getLoc . fst)
+ $ toList pairs)
+ ]
where
what_it_is = hsSigDoc sig
-dupSigDeclErr [] = panic "dupSigDeclErr"
-
misplacedSigErr :: LSig GhcRn -> RnM ()
misplacedSigErr (L loc sig)
= addErrAt loc $
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 617b3556bb..16897c2681 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -13,14 +13,13 @@ module RnEnv (
lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
lookupLocalOccRn_maybe, lookupInfoOccRn,
lookupLocalOccThLvl_maybe, lookupLocalOccRn,
- lookupTypeOccRn, lookupKindOccRn,
+ lookupTypeOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
- lookupSubBndrOcc_helper,
ChildLookupResult(..),
-
- combineChildLookupResult,
+ lookupSubBndrOcc_helper,
+ combineChildLookupResult, -- Called by lookupChildrenExport
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
lookupSigCtxtOccRn,
@@ -45,6 +44,8 @@ module RnEnv (
#include "HsVersions.h"
+import GhcPrelude
+
import LoadIface ( loadInterfaceForName, loadSrcInterface_maybe )
import IfaceEnv
import HsSyn
@@ -53,7 +54,7 @@ import HscTypes
import TcEnv
import TcRnMonad
import RdrHsSyn ( setRdrNameSpace )
-import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName )
+import TysWiredIn
import Name
import NameSet
import NameEnv
@@ -62,8 +63,8 @@ import Module
import ConLike
import DataCon
import TyCon
+import ErrUtils ( MsgDoc )
import PrelNames ( rOOT_MAIN )
-import ErrUtils ( MsgDoc, ErrMsg )
import BasicTypes ( pprWarningTxtForMsg, TopLevelFlag(..))
import SrcLoc
import Outputable
@@ -76,8 +77,10 @@ import ListSetOps ( minusList )
import qualified GHC.LanguageExtensions as LangExt
import RnUnbound
import RnUtils
-import Data.Functor (($>))
import Data.Maybe (isJust)
+import qualified Data.Semigroup as Semi
+import Data.Either ( partitionEithers )
+import Data.List (find)
{-
*********************************************************
@@ -193,7 +196,7 @@ newTopSrcBinder (L loc rdr_name)
= do { when (isQual rdr_name)
(addErrAt loc (badQualBndrErr rdr_name))
-- Binders should not be qualified; if they are, and with a different
- -- module name, we we get a confusing "M.T is not in scope" error later
+ -- module name, we get a confusing "M.T is not in scope" error later
; stage <- getStage
; if isBrackStage stage then
@@ -430,34 +433,122 @@ lookupExactOrOrig rdr_name res k
-----------------------------------------------
--- Used for record construction and pattern matching
--- When the -XDisambiguateRecordFields flag is on, take account of the
--- constructor name to disambiguate which field to use; it's just the
--- same as for instance decls
+-- | Look up an occurrence of a field in record construction or pattern
+-- matching (but not update). When the -XDisambiguateRecordFields
+-- flag is on, take account of the data constructor name to
+-- disambiguate which field to use.
--
--- NB: Consider this:
--- module Foo where { data R = R { fld :: Int } }
--- module Odd where { import Foo; fld x = x { fld = 3 } }
--- Arguably this should work, because the reference to 'fld' is
--- unambiguous because there is only one field id 'fld' in scope.
--- But currently it's rejected.
-
-lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual
- -- Just tycon => use tycon to disambiguate
- -> SDoc -> RdrName
+-- See Note [DisambiguateRecordFields].
+lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual
+ -- Just con => use data con to disambiguate
+ -> RdrName
-> RnM Name
-lookupRecFieldOcc parent doc rdr_name
- | Just tc_name <- parent
- = do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name
- ; case mb_name of
- Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
- Right n -> return n }
-
+lookupRecFieldOcc mb_con rdr_name
+ | Just con <- mb_con
+ , isUnboundName con -- Avoid error cascade
+ = return (mkUnboundNameRdr rdr_name)
+ | Just con <- mb_con
+ = do { flds <- lookupConstructorFields con
+ ; env <- getGlobalRdrEnv
+ ; let lbl = occNameFS (rdrNameOcc rdr_name)
+ mb_field = do fl <- find ((== lbl) . flLabel) flds
+ -- We have the label, now check it is in
+ -- scope (with the correct qualifier if
+ -- there is one, hence calling pickGREs).
+ gre <- lookupGRE_FieldLabel env fl
+ guard (not (isQual rdr_name
+ && null (pickGREs rdr_name [gre])))
+ return (fl, gre)
+ ; case mb_field of
+ Just (fl, gre) -> do { addUsedGRE True gre
+ ; return (flSelector fl) }
+ Nothing -> lookupGlobalOccRn rdr_name }
+ -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
| otherwise
-- This use of Global is right as we are looking up a selector which
-- can only be defined at the top level.
= lookupGlobalOccRn rdr_name
+{- Note [DisambiguateRecordFields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are looking up record fields in record construction or pattern
+matching, we can take advantage of the data constructor name to
+resolve fields that would otherwise be ambiguous (provided the
+-XDisambiguateRecordFields flag is on).
+
+For example, consider:
+
+ data S = MkS { x :: Int }
+ data T = MkT { x :: Int }
+
+ e = MkS { x = 3 }
+
+When we are renaming the occurrence of `x` in `e`, instead of looking
+`x` up directly (and finding both fields), lookupRecFieldOcc will
+search the fields of `MkS` to find the only possible `x` the user can
+mean.
+
+Of course, we still have to check the field is in scope, using
+lookupGRE_FieldLabel. The handling of qualified imports is slightly
+subtle: the occurrence may be unqualified even if the field is
+imported only qualified (but if the occurrence is qualified, the
+qualifier must be correct). For example:
+
+ module A where
+ data S = MkS { x :: Int }
+ data T = MkT { x :: Int }
+
+ module B where
+ import qualified A (S(..))
+ import A (T(MkT))
+
+ e1 = MkT { x = 3 } -- x not in scope, so fail
+ e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail
+ e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted)
+
+In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`,
+lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard
+will fail because the field RdrName `B.x` is qualified and pickGREs
+rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the
+GRE for `A.x` and the guard will succeed because the field RdrName `x`
+is unqualified.
+
+
+Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whenever we fail to find the field or it is not in scope, mb_field
+will be False, and we fall back on looking it up normally using
+lookupGlobalOccRn. We don't report an error immediately because the
+actual problem might be located elsewhere. For example (Trac #9975):
+
+ data Test = Test { x :: Int }
+ pattern Test wat = Test { x = wat }
+
+Here there are multiple declarations of Test (as a data constructor
+and as a pattern synonym), which will be reported as an error. We
+shouldn't also report an error about the occurrence of `x` in the
+pattern synonym RHS. However, if the pattern synonym gets added to
+the environment first, we will try and fail to find `x` amongst the
+(nonexistent) fields of the pattern synonym.
+
+Alternatively, the scope check can fail due to Template Haskell.
+Consider (Trac #12130):
+
+ module Foo where
+ import M
+ b = $(funny)
+
+ module M(funny) where
+ data T = MkT { x :: Int }
+ funny :: Q Exp
+ funny = [| MkT { x = 3 } |]
+
+When we splice, `MkT` is not lexically in scope, so
+lookupGRE_FieldLabel will fail. But there is no need for
+disambiguation anyway, because `x` is an original name, and
+lookupGlobalOccRn will find it.
+-}
+
-- | Used in export lists to lookup the children.
@@ -584,32 +675,32 @@ instance Outputable DisambigInfo where
ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre
ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres
-instance Monoid DisambigInfo where
- mempty = NoOccurrence
+instance Semi.Semigroup DisambigInfo where
-- This is the key line: We prefer disambiguated occurrences to other
-- names.
- _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
- DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g'
-
+ _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
+ DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'
- NoOccurrence `mappend` m = m
- m `mappend` NoOccurrence = m
- UniqueOccurrence g `mappend` UniqueOccurrence g'
+ NoOccurrence <> m = m
+ m <> NoOccurrence = m
+ UniqueOccurrence g <> UniqueOccurrence g'
= AmbiguousOccurrence [g, g']
- UniqueOccurrence g `mappend` AmbiguousOccurrence gs
+ UniqueOccurrence g <> AmbiguousOccurrence gs
= AmbiguousOccurrence (g:gs)
- AmbiguousOccurrence gs `mappend` UniqueOccurrence g'
+ AmbiguousOccurrence gs <> UniqueOccurrence g'
= AmbiguousOccurrence (g':gs)
- AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs'
+ AmbiguousOccurrence gs <> AmbiguousOccurrence gs'
= AmbiguousOccurrence (gs ++ gs')
+
+instance Monoid DisambigInfo where
+ mempty = NoOccurrence
+ mappend = (Semi.<>)
+
-- Lookup SubBndrOcc can never be ambiguous
--
-- Records the result of looking up a child.
data ChildLookupResult
= NameNotFound -- We couldn't find a suitable name
- | NameErr ErrMsg -- We found an unambiguous name
- -- but there's another error
- -- we should abort from
| IncorrectParent Name -- Parent
Name -- Name of thing we were looking for
SDoc -- How to print the name
@@ -628,9 +719,8 @@ combineChildLookupResult (x:xs) = do
instance Outputable ChildLookupResult where
ppr NameNotFound = text "NameNotFound"
- ppr (FoundName _p n) = text "Found:" <+> ppr n
+ ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n
ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls
- ppr (NameErr _) = text "Error"
ppr (IncorrectParent p n td ns) = text "IncorrectParent"
<+> hsep [ppr p, ppr n, td, ppr ns]
@@ -650,9 +740,10 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))
FoundName _p n -> return (Right n)
FoundFL fl -> return (Right (flSelector fl))
- NameErr err -> reportError err $> (Right $ mkUnboundNameRdr rdr_name)
- IncorrectParent {} -> return $ Left (unknownSubordinateErr doc rdr_name)
-
+ IncorrectParent {}
+ -- See [Mismatched class methods and associated type families]
+ -- in TcInstDecls.
+ -> return $ Left (unknownSubordinateErr doc rdr_name)
{-
Note [Family instance binders]
@@ -822,20 +913,6 @@ lookupLocalOccRn rdr_name
Just name -> return name
Nothing -> unboundName WL_LocalOnly rdr_name }
-lookupKindOccRn :: RdrName -> RnM Name
--- Looking up a name occurring in a kind
-lookupKindOccRn rdr_name
- | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types]
- = badVarInType rdr_name
- | otherwise
- = do { typeintype <- xoptM LangExt.TypeInType
- ; if | typeintype -> lookupTypeOccRn rdr_name
- -- With -XNoTypeInType, treat any usage of * in kinds as in scope
- -- this is a dirty hack, but then again so was the old * kind.
- | isStar rdr_name -> return starKindTyConName
- | isUniStar rdr_name -> return unicodeStarKindTyConName
- | otherwise -> lookupOccRn rdr_name }
-
-- lookupPromotedOccRn looks up an optionally promoted RdrName.
lookupTypeOccRn :: RdrName -> RnM Name
-- see Note [Demotion]
@@ -844,16 +921,17 @@ lookupTypeOccRn rdr_name
= badVarInType rdr_name
| otherwise
= do { mb_name <- lookupOccRn_maybe rdr_name
- ; case mb_name of {
- Just name -> return name ;
- Nothing -> do { dflags <- getDynFlags
- ; lookup_demoted rdr_name dflags } } }
+ ; case mb_name of
+ Just name -> return name
+ Nothing -> lookup_demoted rdr_name }
-lookup_demoted :: RdrName -> DynFlags -> RnM Name
-lookup_demoted rdr_name dflags
+lookup_demoted :: RdrName -> RnM Name
+lookup_demoted rdr_name
| Just demoted_rdr <- demoteRdrName rdr_name
-- Maybe it's the name of a *data* constructor
= do { data_kinds <- xoptM LangExt.DataKinds
+ ; star_is_type <- xoptM LangExt.StarIsType
+ ; let star_info = starInfo star_is_type rdr_name
; if data_kinds
then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_name of
@@ -871,7 +949,7 @@ lookup_demoted rdr_name dflags
mb_demoted_name <- discardErrs $
lookupOccRn_maybe demoted_rdr
; let suggestion | isJust mb_demoted_name = suggest_dk
- | otherwise = star_info
+ | otherwise = star_info
; unboundNameX WL_Any rdr_name suggestion } }
| otherwise
@@ -887,17 +965,6 @@ lookup_demoted rdr_name dflags
, text "instead of"
, quotes (ppr name) <> dot ]
- star_info
- | isStar rdr_name || isUniStar rdr_name
- = if xopt LangExt.TypeInType dflags
- then text "NB: With TypeInType, you must import" <+>
- ppr rdr_name <+> text "from Data.Kind"
- else empty
-
- | otherwise
- = empty
-
-
badVarInType :: RdrName -> RnM Name
badVarInType rdr_name
= do { addErr (text "Illegal promoted term variable in a type:"
@@ -1249,7 +1316,7 @@ It is enabled by default and disabled by the flag
Note [Safe Haskell and GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We DONT do this Safe Haskell as we need to check imports. We can
+We DON'T do this Safe Haskell as we need to check imports. We can
and should instead check the qualified import but at the moment
this requires some refactoring so leave as a TODO
-}
@@ -1437,7 +1504,7 @@ lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
-- See Note [Fixity signature lookup]
lookupLocalTcNames ctxt what rdr_name
= do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
- ; let (errs, names) = splitEithers mb_gres
+ ; let (errs, names) = partitionEithers mb_gres
; when (null names) $ addErr (head errs) -- Bleat about one only
; return names }
where
@@ -1558,10 +1625,10 @@ lookupSyntaxNames :: [Name] -- Standard names
lookupSyntaxNames std_names
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on then
- return (map (HsVar . noLoc) std_names, emptyFVs)
+ return (map (HsVar noExt . noLoc) std_names, emptyFVs)
else
do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
- ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } }
+ ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }
-- Error messages
@@ -1573,5 +1640,17 @@ opDeclErr n
badOrigBinding :: RdrName -> SDoc
badOrigBinding name
- = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name)
- -- The rdrNameOcc is because we don't want to print Prelude.(,)
+ | Just _ <- isBuiltInOcc_maybe occ
+ = text "Illegal binding of built-in syntax:" <+> ppr occ
+ -- Use an OccName here because we don't want to print Prelude.(,)
+ | otherwise
+ = text "Cannot redefine a Name retrieved by a Template Haskell quote:"
+ <+> ppr name
+ -- This can happen when one tries to use a Template Haskell splice to
+ -- define a top-level identifier with an already existing name, e.g.,
+ --
+ -- $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])
+ --
+ -- (See Trac #13968.)
+ where
+ occ = rdrNameOcc name
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index c5c75ab671..ae2bdf7a2b 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -21,9 +21,12 @@ module RnExpr (
#include "HsVersions.h"
+import GhcPrelude
+
import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMatchGroup, rnGRHS, makeMiniFixityEnv)
import HsSyn
+import TcEnv ( isBrackStage )
import TcRnMonad
import Module ( getModule )
import RnEnv
@@ -57,6 +60,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Data.Ord
import Data.Array
+import qualified Data.List.NonEmpty as NE
{-
************************************************************************
@@ -92,7 +96,7 @@ finishHsVar (L l name)
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
- ; return (HsVar (L l name), unitFV name) }
+ ; return (HsVar noExt (L l name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v
@@ -104,13 +108,13 @@ rnUnboundVar v
; uv <- if startsWithUnderscore occ
then return (TrueExprHole occ)
else OutOfScope occ <$> getGlobalRdrEnv
- ; return (HsUnboundVar uv, emptyFVs) }
+ ; return (HsUnboundVar noExt uv, emptyFVs) }
else -- Fail immediately (qualified name)
do { n <- reportUnboundName v
- ; return (HsVar (noLoc n), emptyFVs) } }
+ ; return (HsVar noExt (noLoc n), emptyFVs) } }
-rnExpr (HsVar (L l v))
+rnExpr (HsVar _ (L l v))
= do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
; case mb_name of {
@@ -118,58 +122,57 @@ rnExpr (HsVar (L l v))
Just (Left name)
| name == nilDataConName -- Treat [] as an ExplicitList, so that
-- OverloadedLists works correctly
- -> rnExpr (ExplicitList placeHolderType Nothing [])
+ -> rnExpr (ExplicitList noExt Nothing [])
| otherwise
-> finishHsVar (L l name) ;
Just (Right [s]) ->
- return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s))
- , unitFV s) ;
+ return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;
Just (Right fs@(_:_:_)) ->
- return ( HsRecFld (Ambiguous (L l v) PlaceHolder)
+ return ( HsRecFld noExt (Ambiguous noExt (L l v))
, mkFVs fs);
Just (Right []) -> panic "runExpr/HsVar" } }
-rnExpr (HsIPVar v)
- = return (HsIPVar v, emptyFVs)
+rnExpr (HsIPVar x v)
+ = return (HsIPVar x v, emptyFVs)
-rnExpr (HsOverLabel _ v)
+rnExpr (HsOverLabel x _ v)
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
- ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }
- else return (HsOverLabel Nothing v, emptyFVs) }
+ ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }
+ else return (HsOverLabel x Nothing v, emptyFVs) }
-rnExpr (HsLit lit@(HsString src s))
+rnExpr (HsLit x lit@(HsString src s))
= do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
; if opt_OverloadedStrings then
- rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
+ rnExpr (HsOverLit x (mkHsIsString src s))
else do {
; rnLit lit
- ; return (HsLit (convertLit lit), emptyFVs) } }
+ ; return (HsLit x (convertLit lit), emptyFVs) } }
-rnExpr (HsLit lit)
+rnExpr (HsLit x lit)
= do { rnLit lit
- ; return (HsLit (convertLit lit), emptyFVs) }
+ ; return (HsLit x(convertLit lit), emptyFVs) }
-rnExpr (HsOverLit lit)
+rnExpr (HsOverLit x lit)
= do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
; case mb_neg of
- Nothing -> return (HsOverLit lit', fvs)
- Just neg -> return ( HsApp (noLoc neg) (noLoc (HsOverLit lit'))
+ Nothing -> return (HsOverLit x lit', fvs)
+ Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))
, fvs ) }
-rnExpr (HsApp fun arg)
+rnExpr (HsApp x fun arg)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnLExpr arg
- ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
+ ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
-rnExpr (HsAppType fun arg)
+rnExpr (HsAppType arg fun)
= do { (fun',fvFun) <- rnLExpr fun
; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
- ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }
+ ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) }
-rnExpr (OpApp e1 op _ e2)
+rnExpr (OpApp _ e1 op e2)
= do { (e1', fv_e1) <- rnLExpr e1
; (e2', fv_e2) <- rnLExpr e2
; (op', fv_op) <- rnLExpr op
@@ -180,15 +183,15 @@ rnExpr (OpApp e1 op _ e2)
-- more, so I've removed the test. Adding HsPars in TcGenDeriv
-- should prevent bad things happening.
; fixity <- case op' of
- L _ (HsVar (L _ n)) -> lookupFixityRn n
- L _ (HsRecFld f) -> lookupFieldFixityRn f
+ L _ (HsVar _ (L _ n)) -> lookupFixityRn n
+ L _ (HsRecFld _ f) -> lookupFieldFixityRn f
_ -> return (Fixity NoSourceText minPrecedence InfixL)
-- c.f. lookupFixity for unbound
; final_e <- mkOpAppRn e1' op' fixity e2'
; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
-rnExpr (NegApp e _)
+rnExpr (NegApp _ e _)
= do { (e', fv_e) <- rnLExpr e
; (neg_name, fv_neg) <- lookupSyntaxName negateName
; final_e <- mkNegAppRn e' neg_name
@@ -198,24 +201,24 @@ rnExpr (NegApp e _)
-- Template Haskell extensions
-- Don't ifdef-GHCI them because we want to fail gracefully
-- (not with an rnExpr crash) in a stage-1 compiler.
-rnExpr e@(HsBracket br_body) = rnBracket e br_body
+rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
-rnExpr (HsSpliceE splice) = rnSpliceExpr splice
+rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
---------------------------------------------
-- Sections
-- See Note [Parsing sections] in Parser.y
-rnExpr (HsPar (L loc (section@(SectionL {}))))
+rnExpr (HsPar x (L loc (section@(SectionL {}))))
= do { (section', fvs) <- rnSection section
- ; return (HsPar (L loc section'), fvs) }
+ ; return (HsPar x (L loc section'), fvs) }
-rnExpr (HsPar (L loc (section@(SectionR {}))))
+rnExpr (HsPar x (L loc (section@(SectionR {}))))
= do { (section', fvs) <- rnSection section
- ; return (HsPar (L loc section'), fvs) }
+ ; return (HsPar x (L loc section'), fvs) }
-rnExpr (HsPar e)
+rnExpr (HsPar x e)
= do { (e', fvs_e) <- rnLExpr e
- ; return (HsPar e', fvs_e) }
+ ; return (HsPar x e', fvs_e) }
rnExpr expr@(SectionL {})
= do { addErr (sectionErr expr); rnSection expr }
@@ -223,71 +226,68 @@ rnExpr expr@(SectionR {})
= do { addErr (sectionErr expr); rnSection expr }
---------------------------------------------
-rnExpr (HsCoreAnn src ann expr)
+rnExpr (HsCoreAnn x src ann expr)
= do { (expr', fvs_expr) <- rnLExpr expr
- ; return (HsCoreAnn src ann expr', fvs_expr) }
+ ; return (HsCoreAnn x src ann expr', fvs_expr) }
-rnExpr (HsSCC src lbl expr)
+rnExpr (HsSCC x src lbl expr)
= do { (expr', fvs_expr) <- rnLExpr expr
- ; return (HsSCC src lbl expr', fvs_expr) }
-rnExpr (HsTickPragma src info srcInfo expr)
+ ; return (HsSCC x src lbl expr', fvs_expr) }
+rnExpr (HsTickPragma x src info srcInfo expr)
= do { (expr', fvs_expr) <- rnLExpr expr
- ; return (HsTickPragma src info srcInfo expr', fvs_expr) }
+ ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
-rnExpr (HsLam matches)
+rnExpr (HsLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
- ; return (HsLam matches', fvMatch) }
+ ; return (HsLam x matches', fvMatch) }
-rnExpr (HsLamCase matches)
+rnExpr (HsLamCase x matches)
= do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
- ; return (HsLamCase matches', fvs_ms) }
+ ; return (HsLamCase x matches', fvs_ms) }
-rnExpr (HsCase expr matches)
+rnExpr (HsCase x expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
- ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+ ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
-rnExpr (HsLet (L l binds) expr)
+rnExpr (HsLet x (L l binds) expr)
= rnLocalBindsAndThen binds $ \binds' _ -> do
{ (expr',fvExpr) <- rnLExpr expr
- ; return (HsLet (L l binds') expr', fvExpr) }
+ ; return (HsLet x (L l binds') expr', fvExpr) }
-rnExpr (HsDo do_or_lc (L l stmts) _)
+rnExpr (HsDo x do_or_lc (L l stmts))
= do { ((stmts', _), fvs) <-
rnStmtsWithPostProcessing do_or_lc rnLExpr
postProcessStmtsForApplicativeDo stmts
(\ _ -> return ((), emptyFVs))
- ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
+ ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }
-rnExpr (ExplicitList _ _ exps)
+rnExpr (ExplicitList x _ exps)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (exps', fvs) <- rnExprs exps
; if opt_OverloadedLists
then do {
; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
- ; return (ExplicitList placeHolderType (Just from_list_n_name) exps'
+ ; return (ExplicitList x (Just from_list_n_name) exps'
, fvs `plusFV` fvs') }
else
- return (ExplicitList placeHolderType Nothing exps', fvs) }
-
-rnExpr (ExplicitPArr _ exps)
- = do { (exps', fvs) <- rnExprs exps
- ; return (ExplicitPArr placeHolderType exps', fvs) }
+ return (ExplicitList x Nothing exps', fvs) }
-rnExpr (ExplicitTuple tup_args boxity)
+rnExpr (ExplicitTuple x tup_args boxity)
= do { checkTupleSection tup_args
; checkTupSize (length tup_args)
; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
- ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
+ ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
where
- rnTupArg (L l (Present e)) = do { (e',fvs) <- rnLExpr e
- ; return (L l (Present e'), fvs) }
- rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
+ rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e
+ ; return (L l (Present x e'), fvs) }
+ rnTupArg (L l (Missing _)) = return (L l (Missing noExt)
, emptyFVs)
+ rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"
-rnExpr (ExplicitSum alt arity expr _)
+rnExpr (ExplicitSum x alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
- ; return (ExplicitSum alt arity expr' PlaceHolder, fvs) }
+ ; return (ExplicitSum x alt arity expr', fvs) }
rnExpr (RecordCon { rcon_con_name = con_id
, rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
@@ -295,53 +295,49 @@ rnExpr (RecordCon { rcon_con_name = con_id
; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
- ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
- , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+ ; return (RecordCon { rcon_ext = noExt
+ , rcon_con_name = con_lname, rcon_flds = rec_binds' }
, fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
where
- mk_hs_var l n = HsVar (L l n)
+ mk_hs_var l n = HsVar noExt (L l n)
rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
= do { (expr', fvExpr) <- rnLExpr expr
; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
- ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
- , rupd_cons = PlaceHolder, rupd_in_tys = PlaceHolder
- , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder }
+ ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'
+ , rupd_flds = rbinds' }
, fvExpr `plusFV` fvRbinds) }
-rnExpr (ExprWithTySig expr pty)
+rnExpr (ExprWithTySig pty expr)
= do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
- ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
+ ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) }
-rnExpr (HsIf _ p b1 b2)
+rnExpr (HsIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLExpr b1
; (b2', fvB2) <- rnLExpr b2
; (mb_ite, fvITE) <- lookupIfThenElse
- ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+ ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
-rnExpr (HsMultiIf _ty alts)
+rnExpr (HsMultiIf x alts)
= do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
-- ; return (HsMultiIf ty alts', fvs) }
- ; return (HsMultiIf placeHolderType alts', fvs) }
+ ; return (HsMultiIf x alts', fvs) }
-rnExpr (ArithSeq _ _ seq)
+rnExpr (ArithSeq x _ seq)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (new_seq, fvs) <- rnArithSeq seq
; if opt_OverloadedLists
then do {
; (from_list_name, fvs') <- lookupSyntaxName fromListName
- ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
+ ; return (ArithSeq x (Just from_list_name) new_seq
+ , fvs `plusFV` fvs') }
else
- return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
-
-rnExpr (PArrSeq _ seq)
- = do { (new_seq, fvs) <- rnArithSeq seq
- ; return (PArrSeq noPostTcExpr new_seq, fvs) }
+ return (ArithSeq x Nothing new_seq, fvs) }
{-
These three are pattern syntax appearing in expressions.
@@ -349,7 +345,7 @@ Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.
-}
-rnExpr EWildPat = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
+rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
rnExpr e@(EAsPat {})
= do { opt_TypeApplications <- xoptM LangExt.TypeApplications
; let msg | opt_TypeApplications
@@ -368,12 +364,22 @@ rnExpr e@(ELazyPat {}) = patSynErr e empty
* *
************************************************************************
-For the static form we check that the free variables are all top-level
-value bindings. This is done by checking that the name is external or
-wired-in. See the Notes about the NameSorts in Name.hs.
+For the static form we check that it is not used in splices.
+We also collect the free variables of the term which come from
+this module. See Note [Grand plan for static forms] in StaticPtrTable.
-}
rnExpr e@(HsStatic _ expr) = do
+ -- Normally, you wouldn't be able to construct a static expression without
+ -- first enabling -XStaticPointers in the first place, since that extension
+ -- is what makes the parser treat `static` as a keyword. But this is not a
+ -- sufficient safeguard, as one can construct static expressions by another
+ -- mechanism: Template Haskell (see #14204). To ensure that GHC is
+ -- absolutely prepared to cope with static forms, we check for
+ -- -XStaticPointers here as well.
+ unlessXOptM LangExt.StaticPointers $
+ addErr $ hang (text "Illegal static expression:" <+> ppr e)
+ 2 (text "Use StaticPointers to enable this extension")
(expr',fvExpr) <- rnLExpr expr
stage <- getStage
case stage of
@@ -394,11 +400,11 @@ rnExpr e@(HsStatic _ expr) = do
************************************************************************
-}
-rnExpr (HsProc pat body)
+rnExpr (HsProc x pat body)
= newArrowScope $
rnPat ProcExpr pat $ \ pat' -> do
{ (body',fvBody) <- rnCmdTop body
- ; return (HsProc pat' body', fvBody) }
+ ; return (HsProc x pat' body', fvBody) }
-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
rnExpr e@(HsArrApp {}) = arrowFail e
@@ -407,8 +413,8 @@ rnExpr e@(HsArrForm {}) = arrowFail e
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap
-hsHoleExpr :: HsExpr id
-hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
arrowFail e
@@ -421,17 +427,17 @@ arrowFail e
----------------------
-- See Note [Parsing sections] in Parser.y
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnSection section@(SectionR op expr)
+rnSection section@(SectionR x op expr)
= do { (op', fvs_op) <- rnLExpr op
; (expr', fvs_expr) <- rnLExpr expr
; checkSectionPrec InfixR section op' expr'
- ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
+ ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }
-rnSection section@(SectionL expr op)
+rnSection section@(SectionL x expr op)
= do { (expr', fvs_expr) <- rnLExpr expr
; (op', fvs_op) <- rnLExpr op
; checkSectionPrec InfixL section op' expr'
- ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
+ ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }
rnSection other = pprPanic "rnSection" (ppr other)
@@ -453,26 +459,26 @@ rnCmdArgs (arg:args)
rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
rnCmdTop = wrapLocFstM rnCmdTop'
where
- rnCmdTop' (HsCmdTop cmd _ _ _)
+ rnCmdTop' (HsCmdTop _ cmd)
= do { (cmd', fvCmd) <- rnLCmd cmd
; let cmd_names = [arrAName, composeAName, firstAName] ++
nameSetElemsStable (methodNamesCmd (unLoc cmd'))
-- Generate the rebindable syntax for the monad
; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
- ; return (HsCmdTop cmd' placeHolderType placeHolderType
- (cmd_names `zip` cmd_names'),
+ ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
fvCmd `plusFV` cmd_fvs) }
+ rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd = wrapLocFstM rnCmd
rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
-rnCmd (HsCmdArrApp arrow arg _ ho rtl)
+rnCmd (HsCmdArrApp x arrow arg ho rtl)
= do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
; (arg',fvArg) <- rnLExpr arg
- ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl,
+ ; return (HsCmdArrApp x arrow' arg' ho rtl,
fvArrow `plusFV` fvArg) }
where
select_arrow_scope tc = case ho of
@@ -485,9 +491,9 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
-- inside 'arrow'. In the higher-order case (-<<), they are.
-- infix form
-rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
+rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
= do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
- ; let L _ (HsVar (L _ op_name)) = op'
+ ; let L _ (HsVar _ (L _ op_name)) = op'
; (arg1',fv_arg1) <- rnCmdTop arg1
; (arg2',fv_arg2) <- rnCmdTop arg2
-- Deal with fixity
@@ -495,47 +501,48 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2])
; final_e <- mkOpFormRn arg1' op' fixity arg2'
; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
-rnCmd (HsCmdArrForm op f fixity cmds)
+rnCmd (HsCmdArrForm x op f fixity cmds)
= do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
; (cmds',fvCmds) <- rnCmdArgs cmds
- ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) }
+ ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }
-rnCmd (HsCmdApp fun arg)
+rnCmd (HsCmdApp x fun arg)
= do { (fun',fvFun) <- rnLCmd fun
; (arg',fvArg) <- rnLExpr arg
- ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) }
+ ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
-rnCmd (HsCmdLam matches)
+rnCmd (HsCmdLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
- ; return (HsCmdLam matches', fvMatch) }
+ ; return (HsCmdLam x matches', fvMatch) }
-rnCmd (HsCmdPar e)
+rnCmd (HsCmdPar x e)
= do { (e', fvs_e) <- rnLCmd e
- ; return (HsCmdPar e', fvs_e) }
+ ; return (HsCmdPar x e', fvs_e) }
-rnCmd (HsCmdCase expr matches)
+rnCmd (HsCmdCase x expr matches)
= do { (new_expr, e_fvs) <- rnLExpr expr
; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
- ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+ ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
-rnCmd (HsCmdIf _ p b1 b2)
+rnCmd (HsCmdIf x _ p b1 b2)
= do { (p', fvP) <- rnLExpr p
; (b1', fvB1) <- rnLCmd b1
; (b2', fvB2) <- rnLCmd b2
; (mb_ite, fvITE) <- lookupIfThenElse
- ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+ ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
-rnCmd (HsCmdLet (L l binds) cmd)
+rnCmd (HsCmdLet x (L l binds) cmd)
= rnLocalBindsAndThen binds $ \ binds' _ -> do
{ (cmd',fvExpr) <- rnLCmd cmd
- ; return (HsCmdLet (L l binds') cmd', fvExpr) }
+ ; return (HsCmdLet x (L l binds') cmd', fvExpr) }
-rnCmd (HsCmdDo (L l stmts) _)
+rnCmd (HsCmdDo x (L l stmts))
= do { ((stmts', _), fvs) <-
rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
- ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
+ ; return ( HsCmdDo x (L l stmts'), fvs ) }
rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
+rnCmd cmd@(XCmd {}) = pprPanic "rnCmd" (ppr cmd)
---------------------------------------------------
type CmdNeeds = FreeVars -- Only inhabitants are
@@ -547,26 +554,28 @@ methodNamesLCmd = methodNamesCmd . unLoc
methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
= emptyFVs
-methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
= unitFV appAName
methodNamesCmd (HsCmdArrForm {}) = emptyFVs
-methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
+methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd
-methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
+methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c
-methodNamesCmd (HsCmdIf _ _ c1 c2)
+methodNamesCmd (HsCmdIf _ _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
-methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c
-methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
-methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c
-methodNamesCmd (HsCmdLam match) = methodNamesMatch match
+methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c
+methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts
+methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c
+methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match
-methodNamesCmd (HsCmdCase _ matches)
+methodNamesCmd (HsCmdCase _ _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
+methodNamesCmd (XCmd {}) = panic "methodNamesCmd"
+
--methodNamesCmd _ = emptyFVs
-- Other forms can't occur in commands, but it's not convenient
-- to error here so we just do what's convenient.
@@ -577,17 +586,21 @@ methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesMatch (MG { mg_alts = L _ ms })
= plusFVs (map do_one ms)
where
- do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
+ do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
+ do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"
+methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"
-------------------------------------------------
-- gaw 2004
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"
-------------------------------------------------
methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
-methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"
---------------------------------------------------
methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
@@ -598,17 +611,18 @@ methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd
-methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd
-methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd
+methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) =
methodNamesStmts stmts `addOneFV` loopAName
-methodNamesStmt (LetStmt {}) = emptyFVs
-methodNamesStmt (ParStmt {}) = emptyFVs
-methodNamesStmt (TransStmt {}) = emptyFVs
-methodNamesStmt ApplicativeStmt{} = emptyFVs
+methodNamesStmt (LetStmt {}) = emptyFVs
+methodNamesStmt (ParStmt {}) = emptyFVs
+methodNamesStmt (TransStmt {}) = emptyFVs
+methodNamesStmt ApplicativeStmt{} = emptyFVs
-- ParStmt and TransStmt can't occur in commands, but it's not
-- convenient to error here so we just do what's convenient
+methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"
{-
************************************************************************
@@ -718,8 +732,12 @@ postProcessStmtsForApplicativeDo ctxt stmts
ado_is_on <- xoptM LangExt.ApplicativeDo
; let is_do_expr | DoExpr <- ctxt = True
| otherwise = False
- ; if ado_is_on && is_do_expr
- then rearrangeForApplicativeDo ctxt stmts
+ -- don't apply the transformation inside TH brackets, because
+ -- DsMeta does not handle ApplicativeDo.
+ ; in_th_bracket <- isBrackStage <$> getStage
+ ; if ado_is_on && is_do_expr && not in_th_bracket
+ then do { traceRn "ppsfa" (ppr stmts)
+ ; rearrangeForApplicativeDo ctxt stmts }
else noPostProcessStmts ctxt stmts }
-- | strip the FreeVars annotations from statements
@@ -806,28 +824,36 @@ rnStmt :: Outputable (body GhcPs)
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
-rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
+rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside
= do { (body', fv_expr) <- rnBody body
- ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
- ; (thing, fvs3) <- thing_inside []
- ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
- fv_expr `plusFV` fvs1 `plusFV` fvs3) }
-
-rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
+ ; (ret_op, fvs1) <- if isMonadCompContext ctxt
+ then lookupStmtName ctxt returnMName
+ else return (noSyntaxExpr, emptyFVs)
+ -- The 'return' in a LastStmt is used only
+ -- for MonadComp; and we don't want to report
+ -- "non in scope: return" in other cases
+ -- Trac #15607
+
+ ; (thing, fvs3) <- thing_inside []
+ ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]
+ , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+
+rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
; (then_op, fvs1) <- lookupStmtName ctxt thenMName
- ; (guard_op, fvs2) <- if isListCompExpr ctxt
+
+ ; (guard_op, fvs2) <- if isComprehensionContext ctxt
then lookupStmtName ctxt guardMName
else return (noSyntaxExpr, emptyFVs)
- -- Only list/parr/monad comprehensions use 'guard'
+ -- Only list/monad comprehensions use 'guard'
-- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
-- Here "gd" is a guard
+
; (thing, fvs3) <- thing_inside []
- ; return (([(L loc (BodyStmt body'
- then_op guard_op placeHolderType), fv_expr)], thing),
- fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+ ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]
+ , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
-rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
+rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
@@ -837,29 +863,33 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
-- If the pattern is irrefutable (e.g.: wildcard, tuple,
-- ~pat, etc.) we should not need to fail.
| isIrrefutableHsPat pat
- = return (noSyntaxExpr, emptyFVs)
+ = return (noSyntaxExpr, emptyFVs)
+
-- For non-monadic contexts (e.g. guard patterns, list
-- comprehensions, etc.) we should not need to fail.
-- See Note [Failing pattern matches in Stmts]
| not (isMonadFailStmtContext ctxt)
- = return (noSyntaxExpr, emptyFVs)
+ = return (noSyntaxExpr, emptyFVs)
+
| xMonadFailEnabled = lookupSyntaxName failMName
| otherwise = lookupSyntaxName failMName_preMFP
+
; (fail_op, fvs2) <- getFailFunction
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
- ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)
+ ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)
, fv_expr )]
, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
-- fv_expr shouldn't really be filtered by the rnPatsAndThen
-- but it does not matter because the names are unique
-rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
+rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside
= do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
- ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) } }
+ ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)
+ , fvs) } }
rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
= do { (return_op, fvs1) <- lookupStmtName ctxt returnMName
@@ -891,12 +921,12 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
, fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
-rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside
+rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
= do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName
; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
; (return_op, fvs3) <- lookupStmtName ctxt returnMName
; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
- ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)
+ ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)
, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
@@ -929,15 +959,18 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
-- See Note [TransStmt binder map] in HsExpr
; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
- ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+ ; return (([(L loc (TransStmt { trS_ext = noExt
+ , trS_stmts = stmts', trS_bndrs = bndr_map
, trS_by = by', trS_using = using', trS_form = form
, trS_ret = return_op, trS_bind = bind_op
- , trS_bind_arg_ty = PlaceHolder
, trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
rnStmt _ _ (L _ ApplicativeStmt{}) _ =
panic "rnStmt: ApplicativeStmt"
+rnStmt _ _ (L _ XStmtLR{}) _ =
+ panic "rnStmt: XStmtLR"
+
rnParallelStmts :: forall thing. HsStmtContext Name
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
@@ -957,7 +990,7 @@ rnParallelStmts ctxt return_op segs thing_inside
; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
; return (([], thing), fvs) }
- rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs)
+ rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs)
<- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
setLocalRdrEnv env $ do
@@ -965,12 +998,13 @@ rnParallelStmts ctxt return_op segs thing_inside
; let used_bndrs = filter (`elemNameSet` fvs) bndrs
; return ((used_bndrs, segs', thing), fvs) }
- ; let seg' = ParStmtBlock stmts' used_bndrs return_op
+ ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
; return ((seg':segs', thing), fvs) }
+ rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
- <+> quotes (ppr (head vs)))
+ <+> quotes (ppr (NE.head vs)))
lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupSyntaxName, but respects contexts
@@ -986,20 +1020,19 @@ lookupStmtNamePoly ctxt name
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fm <- lookupOccRn (nameRdrName name)
- ; return (HsVar (noLoc fm), unitFV fm) }
+ ; return (HsVar noExt (noLoc fm), unitFV fm) }
else not_rebindable }
| otherwise
= not_rebindable
where
- not_rebindable = return (HsVar (noLoc name), emptyFVs)
+ not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)
-- | Is this a context where we respect RebindableSyntax?
--- but ListComp/PArrComp are never rebindable
+-- but ListComp are never rebindable
-- Neither is ArrowExpr, which has its own desugarer in DsArrows
rebindableContext :: HsStmtContext Name -> Bool
rebindableContext ctxt = case ctxt of
ListComp -> False
- PArrComp -> False
ArrowExpr -> False
PatGuard {} -> False
@@ -1081,10 +1114,10 @@ rnRecStmtsAndThen rnBody s cont
collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
collectRecStmtsFixities l =
foldr (\ s -> \acc -> case s of
- (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
- foldr (\ sig -> \ acc -> case sig of
- (L loc (FixSig s)) -> (L loc s) : acc
- _ -> acc) acc sigs
+ (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->
+ foldr (\ sig -> \ acc -> case sig of
+ (L loc (FixSig _ s)) -> (L loc s) : acc
+ _ -> acc) acc sigs
_ -> acc) [] l
-- left-hand sides
@@ -1096,25 +1129,24 @@ rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
-- so we don't bother to compute it accurately in the other cases
-> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
-rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
- = return [(L loc (BodyStmt body a b c), emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
+ = return [(L loc (BodyStmt noExt body a b), emptyFVs)]
-rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
- = return [(L loc (LastStmt body noret a), emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
+ = return [(L loc (LastStmt noExt body noret a), emptyFVs)]
-rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
+rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
= do
-- should the ctxt be MDo instead?
(pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
- return [(L loc (BindStmt pat' body a b t),
- fv_pat)]
+ return [(L loc (BindStmt noExt pat' body a b), fv_pat)]
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
= failWith (badIpBinds (text "an mdo expression") binds)
-rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
+rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))
= do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
- return [(L loc (LetStmt (L l (HsValBinds binds'))),
+ return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),
-- Warning: this is bogus; see function invariant
emptyFVs
)]
@@ -1132,8 +1164,12 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
= pprPanic "rn_rec_stmt" (ppr stmt)
-rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))
= panic "rn_rec_stmt LetStmt EmptyLocalBinds"
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))
+ = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"
+rn_rec_stmt_lhs _ (L _ (XStmtLR _))
+ = panic "rn_rec_stmt XStmtLR"
rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
-> [LStmt GhcPs body]
@@ -1158,19 +1194,19 @@ rn_rec_stmt :: (Outputable (body GhcPs)) =>
-- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
+rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
= do { (body', fv_expr) <- rnBody body
; (ret_op, fvs1) <- lookupSyntaxName returnMName
; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
- L loc (LastStmt body' noret ret_op))] }
+ L loc (LastStmt noExt body' noret ret_op))] }
-rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
+rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
= do { (body', fvs) <- rnBody body
; (then_op, fvs1) <- lookupSyntaxName thenMName
; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
- L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
+ L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }
-rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
+rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupSyntaxName bindMName
@@ -1182,17 +1218,17 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
; let bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
- L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }
+ L loc (BindStmt noExt pat' body' bind_op fail_op))] }
-rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
= failWith (badIpBinds (text "an mdo expression") binds)
-rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
+rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
= do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
-- fixities and unused are handled above in rnRecStmtsAndThen
; let fvs = allUses du_binds
; return [(duDefs du_binds, fvs, emptyNameSet,
- L loc (LetStmt (L l (HsValBinds binds'))))] }
+ L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }
-- no RecStmt case because they get flattened above when doing the LHSes
rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
@@ -1204,12 +1240,18 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
-rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)
+ = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
+rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)
+ = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)
+
rn_rec_stmts :: Outputable (body GhcPs) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
@@ -1512,6 +1554,7 @@ rearrangeForApplicativeDo ctxt stmts0 = do
optimal_ado <- goptM Opt_OptimalApplicativeDo
let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
| otherwise = mkStmtTreeHeuristic stmts
+ traceRn "rearrangeForADo" (ppr stmt_tree)
return_name <- lookupSyntaxName' returnMName
pure_name <- lookupSyntaxName' pureAName
let monad_names = MonadNames { return_name = return_name
@@ -1529,6 +1572,13 @@ data StmtTree a
| StmtTreeBind (StmtTree a) (StmtTree a)
| StmtTreeApplicative [StmtTree a]
+instance Outputable a => Outputable (StmtTree a) where
+ ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x)
+ ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind")
+ 2 (sep [ppr x, ppr y]))
+ ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
+ 2 (vcat (map ppr xs)))
+
flattenStmtTree :: StmtTree a -> [a]
flattenStmtTree t = go t []
where
@@ -1633,11 +1683,16 @@ stmtTreeToStmts
-- In the spec, but we do it here rather than in the desugarer,
-- because we need the typechecker to typecheck the <$> form rather than
-- the bind form, which would give rise to a Monad constraint.
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))
tail _tail_fvs
| not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
-- See Note [ApplicativeDo and strict patterns]
- = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
+ = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
+ tail _tail_fvs
+ | (False,tail') <- needJoin monad_names tail
+ = mkApplicativeStmt ctxt
+ [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'
stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
return (s : tail, emptyNameSet)
@@ -1655,8 +1710,10 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
(stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
return (stmts, unionNameSets (fvs:fvss))
where
- stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt pat exp _ _ _), _)) =
- return (ApplicativeArgOne pat exp, emptyFVs)
+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))
+ = return (ApplicativeArgOne noExt pat exp False, emptyFVs)
+ stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
+ return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)
stmtTreeArg ctxt tail_fvs tree = do
let stmts = flattenStmtTree tree
pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
@@ -1671,8 +1728,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
return (unLoc tup, emptyNameSet)
| otherwise -> do
(ret,fvs) <- lookupStmtNamePoly ctxt returnMName
- return (HsApp (noLoc ret) tup, fvs)
- return ( ApplicativeArgMany stmts' mb_ret pat
+ return (HsApp noExt (noLoc ret) tup, fvs)
+ return ( ApplicativeArgMany noExt stmts' mb_ret pat
, fvs1 `plusFV` fvs2)
@@ -1726,7 +1783,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
pvars = mkNameSet (collectStmtBinders (unLoc stmt))
isStrictPatternBind :: ExprLStmt GhcRn -> Bool
- isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat
+ isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
isStrictPatternBind _ = False
{-
@@ -1757,24 +1814,23 @@ can do with the rest of the statements in the same "do" expression.
isStrictPattern :: LPat id -> Bool
isStrictPattern (L _ pat) =
case pat of
- WildPat{} -> False
- VarPat{} -> False
- LazyPat{} -> False
- AsPat _ p -> isStrictPattern p
- ParPat p -> isStrictPattern p
- ViewPat _ p _ -> isStrictPattern p
- SigPatIn p _ -> isStrictPattern p
- SigPatOut p _ -> isStrictPattern p
- BangPat{} -> True
- TuplePat{} -> True
- SumPat{} -> True
- PArrPat{} -> True
- ConPatIn{} -> True
- ConPatOut{} -> True
- LitPat{} -> True
- NPat{} -> True
- NPlusKPat{} -> True
- SplicePat{} -> True
+ WildPat{} -> False
+ VarPat{} -> False
+ LazyPat{} -> False
+ AsPat _ _ p -> isStrictPattern p
+ ParPat _ p -> isStrictPattern p
+ ViewPat _ _ p -> isStrictPattern p
+ SigPat _ p -> isStrictPattern p
+ BangPat{} -> True
+ ListPat{} -> True
+ TuplePat{} -> True
+ SumPat{} -> True
+ ConPatIn{} -> True
+ ConPatOut{} -> True
+ LitPat{} -> True
+ NPat{} -> True
+ NPlusKPat{} -> True
+ SplicePat{} -> True
_otherwise -> panic "isStrictPattern"
isLetStmt :: LStmt a b -> Bool
@@ -1810,10 +1866,13 @@ slurpIndependentStmts
slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
where
-- If we encounter a BindStmt that doesn't depend on a previous BindStmt
- -- in this group, then add it to the group.
- go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
- | isEmptyNameSet (bndrs `intersectNameSet` fvs)
- = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
+ -- in this group, then add it to the group. We have to be careful about
+ -- strict patterns though; splitSegments expects that if we return Just
+ -- then we have actually done some splitting. Otherwise it will go into
+ -- an infinite loop (#14163).
+ go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
+ | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
+ = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)
bndrs' rest
where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
-- If we encounter a LetStmt that doesn't depend on a BindStmt in this
@@ -1821,9 +1880,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- grouping more BindStmts.
-- TODO: perhaps we shouldn't do this if there are any strict bindings,
-- because we might be moving evaluation earlier.
- go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
+ go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)
| isEmptyNameSet (bndrs `intersectNameSet` fvs)
- = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
+ = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest
go _ [] _ _ = Nothing
go _ [_] _ _ = Nothing
go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
@@ -1843,7 +1902,7 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
-- typechecker and the desugarer (I tried it that way first!).
mkApplicativeStmt
:: HsStmtContext Name
- -> [ApplicativeArg GhcRn GhcRn] -- ^ The args
+ -> [ApplicativeArg GhcRn] -- ^ The args
-> Bool -- ^ True <=> need a join
-> [ExprLStmt GhcRn] -- ^ The body statements
-> RnM ([ExprLStmt GhcRn], FreeVars)
@@ -1856,10 +1915,9 @@ mkApplicativeStmt ctxt args need_join body_stmts
; return (Just join_op, fvs) }
else
return (Nothing, emptyNameSet)
- ; let applicative_stmt = noLoc $ ApplicativeStmt
+ ; let applicative_stmt = noLoc $ ApplicativeStmt noExt
(zip (fmap_op : repeat ap_op) args)
mb_join
- placeHolderType
; return ( applicative_stmt : body_stmts
, fvs1 `plusFV` fvs2 `plusFV` fvs3) }
@@ -1869,9 +1927,9 @@ needJoin :: MonadNames
-> [ExprLStmt GhcRn]
-> (Bool, [ExprLStmt GhcRn])
needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg
-needJoin monad_names [L loc (LastStmt e _ t)]
+needJoin monad_names [L loc (LastStmt _ e _ t)]
| Just arg <- isReturnApp monad_names e =
- (False, [L loc (LastStmt arg True t)])
+ (False, [L loc (LastStmt noExt arg True t)])
needJoin _monad_names stmts = (True, stmts)
-- | @Just e@, if the expression is @return e@ or @return $ e@,
@@ -1879,15 +1937,15 @@ needJoin _monad_names stmts = (True, stmts)
isReturnApp :: MonadNames
-> LHsExpr GhcRn
-> Maybe (LHsExpr GhcRn)
-isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr
+isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr
isReturnApp monad_names (L _ e) = case e of
- OpApp l op _ r | is_return l, is_dollar op -> Just r
- HsApp f arg | is_return f -> Just arg
+ OpApp _ l op r | is_return l, is_dollar op -> Just r
+ HsApp _ f arg | is_return f -> Just arg
_otherwise -> Nothing
where
- is_var f (L _ (HsPar e)) = is_var f e
- is_var f (L _ (HsAppType e _)) = is_var f e
- is_var f (L _ (HsVar (L _ r))) = f r
+ is_var f (L _ (HsPar _ e)) = is_var f e
+ is_var f (L _ (HsAppType _ e)) = is_var f e
+ is_var f (L _ (HsVar _ (L _ r))) = f r
-- TODO: I don't know how to get this right for rebindable syntax
is_var _ _ = False
@@ -1925,7 +1983,6 @@ checkLastStmt ctxt lstmt@(L loc stmt)
= case ctxt of
ListComp -> check_comp
MonadComp -> check_comp
- PArrComp -> check_comp
ArrowExpr -> check_do
DoExpr -> check_do
MDoExpr -> check_do
@@ -1933,7 +1990,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
where
check_do -- Expect BodyStmt, and change it to LastStmt
= case stmt of
- BodyStmt e _ _ _ -> return (L loc (mkLastStmt e))
+ BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
-- LastStmt directly (unlike the parser)
_ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
@@ -1970,16 +2027,17 @@ pprStmtCat (LetStmt {}) = text "let"
pprStmtCat (RecStmt {}) = text "rec"
pprStmtCat (ParStmt {}) = text "parallel"
pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
+pprStmtCat (XStmtLR {}) = panic "pprStmtCat: XStmtLR"
------------
emptyInvalid :: Validity -- Payload is the empty document
emptyInvalid = NotValid Outputable.empty
-okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
+okStmt, okDoStmt, okCompStmt, okParStmt
:: DynFlags -> HsStmtContext Name
-> Stmt GhcPs (Located (body GhcPs)) -> Validity
-- Return Nothing if OK, (Just extra) if not ok
--- The "extra" is an SDoc that is appended to an generic error message
+-- The "extra" is an SDoc that is appended to a generic error message
okStmt dflags ctxt stmt
= case ctxt of
@@ -1991,7 +2049,6 @@ okStmt dflags ctxt stmt
GhciStmtCtxt -> okDoStmt dflags ctxt stmt
ListComp -> okCompStmt dflags ctxt stmt
MonadComp -> okCompStmt dflags ctxt stmt
- PArrComp -> okPArrStmt dflags ctxt stmt
TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
-------------
@@ -2006,8 +2063,8 @@ okPatGuardStmt stmt
-------------
okParStmt dflags ctxt stmt
= case stmt of
- LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
- _ -> okStmt dflags ctxt stmt
+ LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid
+ _ -> okStmt dflags ctxt stmt
----------------
okDoStmt dflags ctxt stmt
@@ -2036,20 +2093,7 @@ okCompStmt dflags _ stmt
RecStmt {} -> emptyInvalid
LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
ApplicativeStmt {} -> emptyInvalid
-
-----------------
-okPArrStmt dflags _ stmt
- = case stmt of
- BindStmt {} -> IsValid
- LetStmt {} -> IsValid
- BodyStmt {} -> IsValid
- ParStmt {}
- | LangExt.ParallelListComp `xopt` dflags -> IsValid
- | otherwise -> NotValid (text "Use ParallelListComp")
- TransStmt {} -> emptyInvalid
- RecStmt {} -> emptyInvalid
- LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
- ApplicativeStmt {} -> emptyInvalid
+ XStmtLR{} -> panic "okCompStmt"
---------
checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
@@ -2069,7 +2113,7 @@ patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
nest 4 (ppr e)] $$
explanation)
- ; return (EWildPat, emptyFVs) }
+ ; return (EWildPat noExt, emptyFVs) }
badIpBinds :: Outputable a => SDoc -> a -> SDoc
badIpBinds what binds
diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs
index 0bd08574a0..f1bfb380a5 100644
--- a/compiler/rename/RnFixity.hs
+++ b/compiler/rename/RnFixity.hs
@@ -9,6 +9,8 @@ module RnFixity ( MiniFixityEnv,
lookupFixityRn, lookupFixityRn_help,
lookupFieldFixityRn, lookupTyFixityRn ) where
+import GhcPrelude
+
import LoadIface
import HsSyn
import RdrName
@@ -177,9 +179,9 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n
-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
-- multiple possible selectors with different fixities, generate an error.
lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
-lookupFieldFixityRn (Unambiguous (L _ rdr) n)
+lookupFieldFixityRn (Unambiguous n (L _ rdr))
= lookupFixityRn' n (rdrNameOcc rdr)
-lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
+lookupFieldFixityRn (Ambiguous _ (L _ rdr)) = get_ambiguous_fixity rdr
where
get_ambiguous_fixity :: RdrName -> RnM Fixity
get_ambiguous_fixity rdr_name = do
@@ -207,3 +209,4 @@ lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr
format_ambig (elt, fix) = hang (ppr fix)
2 (pprNameProvenance elt)
+lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"
diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs
index 9e53f49320..ac2589df4e 100644
--- a/compiler/rename/RnHsDoc.hs
+++ b/compiler/rename/RnHsDoc.hs
@@ -1,6 +1,8 @@
module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
+import GhcPrelude
+
import TcRnTypes
import HsSyn
import SrcLoc
@@ -19,5 +21,5 @@ rnLHsDoc (L pos doc) = do
return (L pos doc')
rnHsDoc :: HsDocString -> RnM HsDocString
-rnHsDoc (HsDocString s) = return (HsDocString s)
+rnHsDoc = pure
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 6197bc7480..8ded9c27db 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -20,11 +20,17 @@ module RnNames (
mkChildEnv,
findChildren,
dodgyMsg,
- dodgyMsgInsert
+ dodgyMsgInsert,
+ findImportUsage,
+ getMinimalImports,
+ printMinimalImports,
+ ImportDeclUsage
) where
#include "HsVersions.h"
+import GhcPrelude
+
import DynFlags
import HsSyn
import TcEnv
@@ -132,7 +138,7 @@ So there is an interesting design question in regards to transitive trust
checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch
of modules and packages, some packages it requires to be trusted as its using
-XTrustworthy modules from them. Now if I have a module A that doesn't use safe
-haskell at all and simply imports B, should A inherit all the the trust
+haskell at all and simply imports B, should A inherit all the trust
requirements from B? Should A now also require that a package p is trusted since
B required it?
@@ -175,16 +181,71 @@ rnImports imports = do
return (decls, rdr_env, imp_avails, hpc_usage)
where
+ -- See Note [Combining ImportAvails]
combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
-> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
- combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False)
-
- plus (decl, gbl_env1, imp_avails1,hpc_usage1)
- (decls, gbl_env2, imp_avails2,hpc_usage2)
+ combine ss =
+ let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr
+ plus
+ ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)
+ ss
+ in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },
+ hpc_usage)
+
+ plus (decl, gbl_env1, imp_avails1, hpc_usage1)
+ (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)
= ( decl:decls,
gbl_env1 `plusGlobalRdrEnv` gbl_env2,
- imp_avails1 `plusImportAvails` imp_avails2,
- hpc_usage1 || hpc_usage2 )
+ imp_avails1' `plusImportAvails` imp_avails2,
+ hpc_usage1 || hpc_usage2,
+ extendModuleSetList finsts_set new_finsts )
+ where
+ imp_avails1' = imp_avails1 { imp_finsts = [] }
+ new_finsts = imp_finsts imp_avails1
+
+{-
+Note [Combining ImportAvails]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+imp_finsts in ImportAvails is a list of family instance modules
+transitively depended on by an import. imp_finsts for a currently
+compiled module is a union of all the imp_finsts of imports.
+Computing the union of two lists of size N is O(N^2) and if we
+do it to M imports we end up with O(M*N^2). That can get very
+expensive for bigger module hierarchies.
+
+Union can be optimized to O(N log N) if we use a Set.
+imp_finsts is converted back and forth between dep_finsts, so
+changing a type of imp_finsts means either paying for the conversions
+or changing the type of dep_finsts as well.
+
+I've measured that the conversions would cost 20% of allocations on my
+test case, so that can be ruled out.
+
+Changing the type of dep_finsts forces checkFamInsts to
+get the module lists in non-deterministic order. If we wanted to restore
+the deterministic order, we'd have to sort there, which is an additional
+cost. As far as I can tell, using a non-deterministic order is fine there,
+but that's a brittle nonlocal property which I'd like to avoid.
+
+Additionally, dep_finsts is read from an interface file, so its "natural"
+type is a list. Which makes it a natural type for imp_finsts.
+
+Since rnImports.combine is really the only place that would benefit from
+it being a Set, it makes sense to optimize the hot loop in rnImports.combine
+without changing the representation.
+
+So here's what we do: instead of naively merging ImportAvails with
+plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts
+and compute the union on the side using Sets. When we're done, we can
+convert it back to a list. One nice side effect of this approach is that
+if there's a lot of overlap in the imp_finsts of imports, the
+Set doesn't really need to grow and we don't need to allocate.
+
+Running generateModules from Trac #14693 with DEPTH=16, WIDTH=30 finishes in
+23s before, and 11s after.
+-}
+
+
-- | Given a located import declaration @decl@ from @this_mod@,
-- calculate the following pieces of information:
@@ -204,7 +265,9 @@ rnImports imports = do
rnImportDecl :: Module -> LImportDecl GhcPs
-> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
rnImportDecl this_mod
- (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg
+ (L loc decl@(ImportDecl { ideclExt = noExt
+ , ideclName = loc_imp_mod_name
+ , ideclPkgQual = mb_pkg
, ideclSource = want_boot, ideclSafe = mod_safe
, ideclQualified = qual_only, ideclImplicit = implicit
, ideclAs = as_mod, ideclHiding = imp_details }))
@@ -313,10 +376,11 @@ rnImportDecl this_mod
_ -> return ()
)
- let new_imp_decl = L loc (decl { ideclSafe = mod_safe'
+ let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'
, ideclHiding = new_imp_details })
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
+rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
@@ -499,7 +563,7 @@ extendGlobalRdrEnvRn avails new_fixities
; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
- ; let fix_env' = foldl extend_fix_env fix_env new_gres
+ ; let fix_env' = foldl' extend_fix_env fix_env new_gres
gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
@@ -602,7 +666,7 @@ getLocalNonValBinders fixity_env
; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
; return (envs, new_bndrs) } }
where
- ValBindsIn _val_binds val_sigs = binds
+ ValBinds _ _val_binds val_sigs = binds
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = hsForeignDeclsBinders foreign_decls
@@ -610,7 +674,7 @@ getLocalNonValBinders fixity_env
-- In a hs-boot file, the value binders come from the
-- *signatures*, and there should be no foreign binders
hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
- | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]
+ | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
-- the SrcSpan attached to the input should be the span of the
-- declaration, not just the name
@@ -637,24 +701,16 @@ getLocalNonValBinders fixity_env
-> [(Name, [FieldLabel])]
mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
where
- find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
- , con_details = RecCon cdflds }))
+ find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
+ , con_args = RecCon cdflds }))
= [( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds) )]
- find_con_flds (L _ (ConDeclGADT
- { con_names = rdrs
- , con_type = (HsIB { hsib_body = res_ty})}))
- = map (\ (L _ rdr) -> ( find_con_name rdr
- , concatMap find_con_decl_flds cdflds))
- rdrs
- where
- (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
- cdflds = case tau of
- L _ (HsFunTy
- (L _ (HsAppsTy
- [L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _) -> flds
- L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
- _ -> []
+ find_con_flds (L _ (ConDeclGADT { con_names = rdrs
+ , con_args = RecCon flds }))
+ = [ ( find_con_name rdr
+ , concatMap find_con_decl_flds (unLoc flds))
+ | L _ rdr <- rdrs ]
+
find_con_flds _ = []
find_con_name rdr
@@ -662,20 +718,22 @@ getLocalNonValBinders fixity_env
find (\ n -> nameOccName n == rdrNameOcc rdr) names
find_con_decl_flds (L _ x)
= map find_con_decl_fld (cd_fld_names x)
- find_con_decl_fld (L _ (FieldOcc (L _ rdr) _))
+
+ find_con_decl_fld (L _ (FieldOcc _ (L _ rdr)))
= expectJust "getLocalNonValBinders/find_con_decl_fld" $
find (\ fl -> flLabel fl == lbl) flds
where lbl = occNameFS (rdrNameOcc rdr)
+ find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"
new_assoc :: Bool -> LInstDecl GhcPs
-> RnM ([AvailInfo], [(Name, [FieldLabel])])
new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
-- type instances don't bind new names
- new_assoc overload_ok (L _ (DataFamInstD d))
+ new_assoc overload_ok (L _ (DataFamInstD _ d))
= do { (avail, flds) <- new_di overload_ok Nothing d
; return ([avail], flds) }
- new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
+ new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty
, cid_datafam_insts = adts })))
| Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
@@ -685,26 +743,32 @@ getLocalNonValBinders fixity_env
| otherwise
= return ([], []) -- Do not crash on ill-formed instances
-- Eg instance !Show Int Trac #3811c
+ new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"
+ new_assoc _ (L _ (XInstDecl _)) = panic "new_assoc"
new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
- new_di overload_ok mb_cls ti_decl
- = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
- ; let (bndrs, flds) = hsDataFamInstBinders ti_decl
+ new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
+ HsIB { hsib_body = ti_decl }})
+ = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
+ ; let (bndrs, flds) = hsDataFamInstBinders dfid
; sub_names <- mapM newTopSrcBinder bndrs
; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
; let avail = AvailTC (unLoc main_name) sub_names flds'
-- main_name is not bound here!
- fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds'
+ fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
; return (avail, fld_env) }
+ new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"
new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
+getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"
newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
-newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _))
+newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"
+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))
= do { selName <- newTopSrcBinder $ L loc $ field
; return $ qualFieldLbl { flSelector = selName } }
where
@@ -803,7 +867,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-- NB the AvailInfo may have duplicates, and several items
-- for the same parent; e.g N(x) and N(y)
- names = availsToNameSet (map snd items2)
+ names = availsToNameSetWithSelectors (map snd items2)
keep n = not (n `elemNameSet` names)
pruned_avails = filterAvails keep all_avails
hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
@@ -819,8 +883,9 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
imp_occ_env :: OccEnv (Name, -- the name
AvailInfo, -- the export item providing the name
Maybe Name) -- the parent of associated types
- imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing))
- | a <- all_avails, n <- availNames a]
+ imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))
+ | a <- all_avails
+ , (n, occ) <- availNamesWithOccs a]
where
-- See Note [Dealing with imports]
-- 'combine' is only called for associated data types which appear
@@ -835,10 +900,11 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
else (name1, a2, Just p1)
combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
- lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
- lookup_name rdr | isQual rdr = failLookupWith (QualImportError rdr)
- | Just succ <- mb_success = return succ
- | otherwise = failLookupWith BadImport
+ lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
+ lookup_name ie rdr
+ | isQual rdr = failLookupWith (QualImportError rdr)
+ | Just succ <- mb_success = return succ
+ | otherwise = failLookupWith (BadImport ie)
where
mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
@@ -855,8 +921,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)
emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)
- emit_warning BadImportW = whenWOptM Opt_WarnDodgyImports $
- addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg BadImport)
+ emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $
+ addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))
run_lookup :: IELookupM a -> TcRn (Maybe a)
run_lookup m = case m of
@@ -864,7 +930,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
Succeeded a -> return (Just a)
lookup_err_msg err = case err of
- BadImport -> badImportItemErr iface decl_spec ieRdr all_avails
+ BadImport ie -> badImportItemErr iface decl_spec ie all_avails
IllegalImport -> illegalImportItemErr
QualImportError rdr -> qualImportItemErr rdr
@@ -882,13 +948,13 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])
lookup_ie ie = handle_bad_import $ do
case ie of
- IEVar (L l n) -> do
- (name, avail, _) <- lookup_name $ ieWrappedName n
- return ([(IEVar (L l (replaceWrappedName n name)),
+ IEVar _ (L l n) -> do
+ (name, avail, _) <- lookup_name ie $ ieWrappedName n
+ return ([(IEVar noExt (L l (replaceWrappedName n name)),
trimAvail avail name)], [])
- IEThingAll (L l tc) -> do
- (name, avail, mb_parent) <- lookup_name $ ieWrappedName tc
+ IEThingAll _ (L l tc) -> do
+ (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc
let warns = case avail of
Avail {} -- e.g. f(..)
-> [DodgyImport $ ieWrappedName tc]
@@ -903,7 +969,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
| otherwise
-> []
- renamed_ie = IEThingAll (L l (replaceWrappedName tc name))
+ renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))
sub_avails = case avail of
Avail {} -> []
AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
@@ -913,26 +979,30 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
-- associated type
- IEThingAbs (L l tc')
+ IEThingAbs _ (L l tc')
| want_hiding -- hiding ( C )
-- Here the 'C' can be a data constructor
-- *or* a type/class, or even both
-> let tc = ieWrappedName tc'
- tc_name = lookup_name tc
- dc_name = lookup_name (setRdrNameSpace tc srcDataName)
+ tc_name = lookup_name ie tc
+ dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)
in
case catIELookupM [ tc_name, dc_name ] of
- [] -> failLookupWith BadImport
+ [] -> failLookupWith (BadImport ie)
names -> return ([mkIEThingAbs tc' l name | name <- names], [])
| otherwise
- -> do nameAvail <- lookup_name (ieWrappedName tc')
+ -> do nameAvail <- lookup_name ie (ieWrappedName tc')
return ([mkIEThingAbs tc' l nameAvail]
, [])
- IEThingWith (L l rdr_tc) wc rdr_ns' rdr_fs ->
+ IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->
ASSERT2(null rdr_fs, ppr rdr_fs) do
- (name, AvailTC _ ns subflds, mb_parent)
- <- lookup_name (ieWrappedName rdr_tc)
+ (name, avail, mb_parent)
+ <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)
+
+ let (ns,subflds) = case avail of
+ AvailTC _ ns' subflds' -> (ns',subflds')
+ Avail _ -> panic "filterImports"
-- Look up the children in the sub-names of the parent
let subnames = case ns of -- The tc is first in ns,
@@ -940,15 +1010,20 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-- See the AvailTC Invariant in Avail.hs
(n1:ns1) | n1 == name -> ns1
| otherwise -> ns
- rdr_ns = map ieLWrappedName rdr_ns'
case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
- Nothing -> failLookupWith BadImport
- Just (childnames, childflds) ->
+
+ Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))
+ -- We are trying to import T( a,b,c,d ), and failed
+ -- to find 'b' and 'd'. So we make up an import item
+ -- to report as failing, namely T( b, d ).
+ -- c.f. Trac #15412
+
+ Succeeded (childnames, childflds) ->
case mb_parent of
-- non-associated ty/cls
Nothing
- -> return ([(IEThingWith (L l name') wc childnames'
- childflds,
+ -> return ([(IEThingWith noExt (L l name') wc childnames'
+ childflds,
AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
[])
where name' = replaceWrappedName rdr_tc name
@@ -956,10 +1031,10 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-- childnames' = postrn_ies childnames
-- associated ty
Just parent
- -> return ([(IEThingWith (L l name') wc childnames'
+ -> return ([(IEThingWith noExt (L l name') wc childnames'
childflds,
AvailTC name (map unLoc childnames) (map unLoc childflds)),
- (IEThingWith (L l name') wc childnames'
+ (IEThingWith noExt (L l name') wc childnames'
childflds,
AvailTC parent [name] [])],
[])
@@ -972,25 +1047,26 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
where
mkIEThingAbs tc l (n, av, Nothing )
- = (IEThingAbs (L l (replaceWrappedName tc n)), trimAvail av n)
+ = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)
mkIEThingAbs tc l (n, _, Just parent)
- = (IEThingAbs (L l (replaceWrappedName tc n)), AvailTC parent [n] [])
+ = (IEThingAbs noExt (L l (replaceWrappedName tc n))
+ , AvailTC parent [n] [])
handle_bad_import m = catchIELookup m $ \err -> case err of
- BadImport | want_hiding -> return ([], [BadImportW])
- _ -> failLookupWith err
+ BadImport ie | want_hiding -> return ([], [BadImportW ie])
+ _ -> failLookupWith err
type IELookupM = MaybeErr IELookupError
data IELookupWarning
- = BadImportW
+ = BadImportW (IE GhcPs)
| MissingImportList
| DodgyImport RdrName
-- NB. use the RdrName for reporting a "dodgy" import
data IELookupError
= QualImportError RdrName
- | BadImport
+ | BadImport (IE GhcPs)
| IllegalImport
failLookupWith :: IELookupError -> IELookupM a
@@ -1018,8 +1094,8 @@ gresFromIE decl_spec (L loc ie, avail)
= gresFromAvail prov_fn avail
where
is_explicit = case ie of
- IEThingAll (L _ name) -> \n -> n == ieWrappedName name
- _ -> \_ -> True
+ IEThingAll _ (L _ name) -> \n -> n == ieWrappedName name
+ _ -> \_ -> True
prov_fn name
= Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
where
@@ -1053,8 +1129,9 @@ mkChildEnv gres = foldr add emptyNameEnv gres
findChildren :: NameEnv [a] -> Name -> [a]
findChildren env n = lookupNameEnv env n `orElse` []
-lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]
- -> Maybe ([Located Name], [Located FieldLabel])
+lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]
+ -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed
+ ([Located Name], [Located FieldLabel])
-- (lookupChildren all_kids rdr_items) maps each rdr_item to its
-- corresponding Name all_kids, if the former exists
-- The matching is done by FastString, not OccName, so that
@@ -1063,17 +1140,27 @@ lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]
-- the RdrName for AssocTy may have a (bogus) DataName namespace
-- (Really the rdr_items should be FastStrings in the first place.)
lookupChildren all_kids rdr_items
- = do xs <- mapM doOne rdr_items
- return (fmap concat (partitionEithers xs))
+ | null fails
+ = Succeeded (fmap concat (partitionEithers oks))
+ -- This 'fmap concat' trickily applies concat to the /second/ component
+ -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])
+ | otherwise
+ = Failed fails
where
- doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of
- Just [Left n] -> Just (Left (L l n))
- Just rs | all isRight rs -> Just (Right (map (L l) (rights rs)))
- _ -> Nothing
+ mb_xs = map doOne rdr_items
+ fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]
+ oks = [ ok | Succeeded ok <- mb_xs ]
+ oks :: [Either (Located Name) [Located FieldLabel]]
+
+ doOne item@(L l r)
+ = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
+ Just [Left n] -> Succeeded (Left (L l n))
+ Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))
+ _ -> Failed item
-- See Note [Children for duplicate record fields]
kid_env = extendFsEnvList_C (++) emptyFsEnv
- [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
+ [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
@@ -1181,7 +1268,7 @@ warnMissingSignatures gbl_env
pat_syns = tcg_patsyns gbl_env
-- Warn about missing signatures
- -- Do this only when we we have a type to offer
+ -- Do this only when we have a type to offer
; warn_missing_sigs <- woptM Opt_WarnMissingSignatures
; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures
; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures
@@ -1275,13 +1362,13 @@ findImportUsage imports used_gres
_other -> emptyNameSet -- No explicit import list => no unused-name list
add_unused :: IE GhcRn -> NameSet -> NameSet
- add_unused (IEVar (L _ n)) acc
+ add_unused (IEVar _ (L _ n)) acc
= add_unused_name (ieWrappedName n) acc
- add_unused (IEThingAbs (L _ n)) acc
+ add_unused (IEThingAbs _ (L _ n)) acc
= add_unused_name (ieWrappedName n) acc
- add_unused (IEThingAll (L _ n)) acc
+ add_unused (IEThingAll _ (L _ n)) acc
= add_unused_all (ieWrappedName n) acc
- add_unused (IEThingWith (L _ p) wc ns fs) acc =
+ add_unused (IEThingWith _ (L _ p) wc ns fs) acc =
add_wc_all (add_unused_with (ieWrappedName p) xs acc)
where xs = map (ieWrappedName . unLoc) ns
++ map (flSelector . unLoc) fs
@@ -1305,6 +1392,7 @@ findImportUsage imports used_gres
-- If you use 'signum' from Num, then the user may well have
-- imported Num(signum). We don't want to complain that
-- Num is not itself mentioned. Hence the two cases in add_unused_with.
+ unused_decl (L _ (XImportDecl _)) = panic "unused_decl"
extendImportMap :: GlobalRdrElt -> ImportMap -> ImportMap
-- For each of a list of used GREs, find all the import decls that brought
@@ -1350,9 +1438,12 @@ warnUnusedImport flag fld_env (L loc decl, used, unused)
pp_mod = ppr (unLoc (ideclName decl))
pp_not_used = text "is redundant"
+ -- In warning message, pretty-print identifiers unqualified unconditionally
+ -- to improve the consistent for ambiguous/unambiguous identifiers.
+ -- See trac#14881.
ppr_possible_field n = case lookupNameEnv fld_env n of
- Just (fld, p) -> ppr p <> parens (ppr fld)
- Nothing -> ppr n
+ Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)
+ Nothing -> pprNameUnqualified n
-- Print unused names in a deterministic (lexicographic) order
sort_unused = pprWithCommas ppr_possible_field $
@@ -1381,28 +1472,9 @@ decls, and simply trim their import lists. NB that
from it. Instead we just trim to an empty import list
-}
-printMinimalImports :: [ImportDeclUsage] -> RnM ()
--- See Note [Printing minimal imports]
-printMinimalImports imports_w_usage
- = do { imports' <- mapM mk_minimal imports_w_usage
- ; this_mod <- getModule
- ; dflags <- getDynFlags
- ; liftIO $
- do { h <- openFile (mkFilename dflags this_mod) WriteMode
- ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
- -- The neverQualify is important. We are printing Names
- -- but they are in the context of an 'import' decl, and
- -- we never qualify things inside there
- -- E.g. import Blag( f, b )
- -- not import Blag( Blag.f, Blag.g )!
- }
+getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
+getMinimalImports = mapM mk_minimal
where
- mkFilename dflags this_mod
- | Just d <- dumpDir dflags = d </> basefn
- | otherwise = basefn
- where
- basefn = moduleNameString (moduleName this_mod) ++ ".imports"
-
mk_minimal (L l decl, used, unused)
| null unused
, Just (False, _) <- ideclHiding decl
@@ -1422,25 +1494,25 @@ printMinimalImports imports_w_usage
-- we want to say "T(..)", but if we're importing only a subset we want
-- to say "T(A,B,C)". So we have to find out what the module exports.
to_ie _ (Avail n)
- = [IEVar (to_ie_post_rn $ noLoc n)]
+ = [IEVar noExt (to_ie_post_rn $ noLoc n)]
to_ie _ (AvailTC n [m] [])
- | n==m = [IEThingAbs (to_ie_post_rn $ noLoc n)]
+ | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]
to_ie iface (AvailTC n ns fs)
= case [(xs,gs) | AvailTC x xs gs <- mi_exports iface
, x == n
, x `elem` xs -- Note [Partial export]
] of
- [xs] | all_used xs -> [IEThingAll (to_ie_post_rn $ noLoc n)]
+ [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]
| otherwise ->
- [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+ [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
(map (to_ie_post_rn . noLoc) (filter (/= n) ns))
(map noLoc fs)]
-- Note [Overloaded field import]
_other | all_non_overloaded fs
- -> map (IEVar . to_ie_post_rn_var . noLoc) $ ns
+ -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns
++ map flSelector fs
| otherwise ->
- [IEThingWith (to_ie_post_rn $ noLoc n) NoIEWildcard
+ [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
(map (to_ie_post_rn . noLoc) (filter (/= n) ns))
(map noLoc fs)]
where
@@ -1453,6 +1525,29 @@ printMinimalImports imports_w_usage
all_non_overloaded = all (not . flIsOverloaded)
+printMinimalImports :: [ImportDeclUsage] -> RnM ()
+-- See Note [Printing minimal imports]
+printMinimalImports imports_w_usage
+ = do { imports' <- getMinimalImports imports_w_usage
+ ; this_mod <- getModule
+ ; dflags <- getDynFlags
+ ; liftIO $
+ do { h <- openFile (mkFilename dflags this_mod) WriteMode
+ ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
+ -- The neverQualify is important. We are printing Names
+ -- but they are in the context of an 'import' decl, and
+ -- we never qualify things inside there
+ -- E.g. import Blag( f, b )
+ -- not import Blag( Blag.f, Blag.g )!
+ }
+ where
+ mkFilename dflags this_mod
+ | Just d <- dumpDir dflags = d </> basefn
+ | otherwise = basefn
+ where
+ basefn = moduleNameString (moduleName this_mod) ++ ".imports"
+
+
to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
to_ie_post_rn_var (L l n)
| isDataOcc $ occName n = L l (IEPattern (L l n))
@@ -1581,10 +1676,10 @@ dodgyMsg kind tc ie
quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
text "but it has none" ]
-dodgyMsgInsert :: forall p . IdP p -> IE p
-dodgyMsgInsert tc = IEThingAll ii
+dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
+dodgyMsgInsert tc = IEThingAll noExt ii
where
- ii :: LIEWrappedName (IdP p)
+ ii :: LIEWrappedName (IdP (GhcPass p))
ii = noLoc (IEName $ noLoc tc)
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index ff88dbffbc..6195309cab 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -11,6 +11,8 @@ free variables.
-}
{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
module RnPat (-- main entry points
rnPat, rnPats, rnBindPat, rnPatAndThen,
@@ -35,6 +37,8 @@ module RnPat (-- main entry points
-- ENH: thin imports to only what is necessary for patterns
+import GhcPrelude
+
import {-# SOURCE #-} RnExpr ( rnLExpr )
import {-# SOURCE #-} RnSplice ( rnSplicePat )
@@ -47,13 +51,10 @@ import RnEnv
import RnFixity
import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
, warnUnusedMatches, newLocalBndrRn
- , checkDupAndShadowedNames, checkTupSize
- , unknownSubordinateErr )
+ , checkDupNames, checkDupAndShadowedNames
+ , checkTupSize , unknownSubordinateErr )
import RnTypes
import PrelNames
-import TyCon ( tyConName )
-import ConLike
-import Type ( TyThing(..) )
import Name
import NameSet
import RdrName
@@ -67,7 +68,8 @@ import TysWiredIn ( nilDataCon )
import DataCon
import qualified GHC.LanguageExtensions as LangExt
-import Control.Monad ( when, liftM, ap, unless )
+import Control.Monad ( when, liftM, ap, guard )
+import qualified Data.List.NonEmpty as NE
import Data.Ratio
{-
@@ -320,10 +322,11 @@ rnPats ctxt pats thing_inside
-- complain *twice* about duplicates e.g. f (x,x) = ...
--
-- See note [Don't report shadowing for pattern synonyms]
- ; unless (isPatSynCtxt ctxt)
- (addErrCtxt doc_pat $
- checkDupAndShadowedNames envs_before $
- collectPatsBinders pats')
+ ; let bndrs = collectPatsBinders pats'
+ ; addErrCtxt doc_pat $
+ if isPatSynCtxt ctxt
+ then checkDupNames bndrs
+ else checkDupAndShadowedNames envs_before bndrs
; thing_inside pats' } }
where
doc_pat = text "In" <+> pprMatchContext ctxt
@@ -377,17 +380,20 @@ rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
-rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType)
-rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }
-rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
-rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
-rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM
- ; name <- newPatName mk (L loc rdr)
- ; return (VarPat (L l name)) }
+rnPatAndThen _ (WildPat _) = return (WildPat noExt)
+rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat
+ ; return (ParPat x pat') }
+rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
+ ; return (LazyPat x pat') }
+rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
+ ; return (BangPat x pat') }
+rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM
+ ; name <- newPatName mk (L loc rdr)
+ ; return (VarPat x (L l name)) }
-- we need to bind pattern variables for view pattern expressions
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
-rnPatAndThen mk (SigPatIn pat sig)
+rnPatAndThen mk (SigPat sig pat )
-- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
-- important to rename its type signature _before_ renaming the rest of the
-- pattern, so that type variables are first bound by the _outermost_ pattern
@@ -399,21 +405,21 @@ rnPatAndThen mk (SigPatIn pat sig)
-- ~~~~~~~~~~~~~~~^ the same `a' then used here
= do { sig' <- rnHsSigCps sig
; pat' <- rnLPatAndThen mk pat
- ; return (SigPatIn pat' sig') }
+ ; return (SigPat sig' pat' ) }
-rnPatAndThen mk (LitPat lit)
+rnPatAndThen mk (LitPat x lit)
| HsString src s <- lit
= do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
; if ovlStr
then rnPatAndThen mk
- (mkNPat (noLoc (mkHsIsString src s placeHolderType))
+ (mkNPat (noLoc (mkHsIsString src s))
Nothing)
else normal_lit }
| otherwise = normal_lit
where
- normal_lit = do { liftCps (rnLit lit); return (LitPat (convertLit lit)) }
+ normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
-rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
+rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
= do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
; mb_neg' -- See Note [Negative zero]
<- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
@@ -425,9 +431,9 @@ rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
(Nothing, Nothing) -> positive
(Just _ , Just _ ) -> positive
; eq' <- liftCpsFV $ lookupSyntaxName eqName
- ; return (NPat (L l lit') mb_neg' eq' placeHolderType) }
+ ; return (NPat x (L l lit') mb_neg' eq') }
-rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
+rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )
= do { new_name <- newPatName mk rdr
; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
-- We skip negateName as
@@ -435,16 +441,16 @@ rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
-- sense in n + k patterns
; minus <- liftCpsFV $ lookupSyntaxName minusName
; ge <- liftCpsFV $ lookupSyntaxName geName
- ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
- (L l lit') lit' ge minus placeHolderType) }
+ ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)
+ (L l lit') lit' ge minus) }
-- The Report says that n+k patterns must be in Integral
-rnPatAndThen mk (AsPat rdr pat)
+rnPatAndThen mk (AsPat x rdr pat)
= do { new_name <- newPatLName mk rdr
; pat' <- rnLPatAndThen mk pat
- ; return (AsPat new_name pat') }
+ ; return (AsPat x new_name pat') }
-rnPatAndThen mk p@(ViewPat expr pat _ty)
+rnPatAndThen mk p@(ViewPat x expr pat)
= do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
; checkErr vp_flag (badViewPat p) }
-- Because of the way we're arranging the recursive calls,
@@ -453,45 +459,40 @@ rnPatAndThen mk p@(ViewPat expr pat _ty)
; pat' <- rnLPatAndThen mk pat
-- Note: at this point the PreTcType in ty can only be a placeHolder
-- ; return (ViewPat expr' pat' ty) }
- ; return (ViewPat expr' pat' placeHolderType) }
+ ; return (ViewPat x expr' pat') }
rnPatAndThen mk (ConPatIn con stuff)
-- rnConPatAndThen takes care of reconstructing the pattern
-- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
= case unLoc con == nameRdrName (dataConName nilDataCon) of
True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
- ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing)
+ ; if ol_flag then rnPatAndThen mk (ListPat noExt [])
else rnConPatAndThen mk con stuff}
False -> rnConPatAndThen mk con stuff
-rnPatAndThen mk (ListPat pats _ _)
+rnPatAndThen mk (ListPat _ pats)
= do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
; pats' <- rnLPatsAndThen mk pats
; case opt_OverloadedLists of
True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
- ; return (ListPat pats' placeHolderType
- (Just (placeHolderType, to_list_name)))}
- False -> return (ListPat pats' placeHolderType Nothing) }
-
-rnPatAndThen mk (PArrPat pats _)
- = do { pats' <- rnLPatsAndThen mk pats
- ; return (PArrPat pats' placeHolderType) }
+ ; return (ListPat (Just to_list_name) pats')}
+ False -> return (ListPat Nothing pats') }
-rnPatAndThen mk (TuplePat pats boxed _)
+rnPatAndThen mk (TuplePat x pats boxed)
= do { liftCps $ checkTupSize (length pats)
; pats' <- rnLPatsAndThen mk pats
- ; return (TuplePat pats' boxed []) }
+ ; return (TuplePat x pats' boxed) }
-rnPatAndThen mk (SumPat pat alt arity _)
+rnPatAndThen mk (SumPat x pat alt arity)
= do { pat <- rnLPatAndThen mk pat
- ; return (SumPat pat alt arity PlaceHolder)
+ ; return (SumPat x pat alt arity)
}
-- If a splice has been run already, just rename the result.
-rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))
- = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat
+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
+ = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
-rnPatAndThen mk (SplicePat splice)
+rnPatAndThen mk (SplicePat _ splice)
= do { eith <- liftCpsFV $ rnSplicePat splice
; case eith of -- See Note [rnSplicePat] in RnSplice
Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
@@ -534,7 +535,7 @@ rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
; flds' <- mapM rn_field (flds `zip` [1..])
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
- mkVarPat l n = VarPat (L l n)
+ mkVarPat l n = VarPat noExt (L l n)
rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
(hsRecFieldArg fld)
; return (L l (fld { hsRecFieldArg = arg' })) }
@@ -568,7 +569,7 @@ rnHsRecFields
-- This surprisingly complicated pass
-- a) looks up the field name (possibly using disambiguation)
-- b) fills in puns and dot-dot stuff
--- When we we've finished, we've renamed the LHS, but not the RHS,
+-- When we've finished, we've renamed the LHS, but not the RHS,
-- of each x=e binding
--
-- This is used for record construction and pattern-matching, but not updates.
@@ -576,7 +577,7 @@ rnHsRecFields
rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
= do { pun_ok <- xoptM LangExt.RecordPuns
; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
- ; parent <- check_disambiguation disambig_ok mb_con
+ ; let parent = guard disambig_ok >> mb_con
; flds1 <- mapM (rn_fld pun_ok parent) flds
; mapM_ (addErr . dupFieldErr ctxt) dup_flds
; dotdot_flds <- rn_dotdot dotdot mb_con flds1
@@ -585,25 +586,17 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return (all_flds, mkFVs (getFieldIds all_flds)) }
where
mb_con = case ctxt of
- HsRecFieldCon con | not (isUnboundName con) -> Just con
- HsRecFieldPat con | not (isUnboundName con) -> Just con
- _ {- update or isUnboundName con -} -> Nothing
- -- The unbound name test is because if the constructor
- -- isn't in scope the constructor lookup will add an error
- -- add an error, but still return an unbound name.
- -- We don't want that to screw up the dot-dot fill-in stuff.
-
- doc = case mb_con of
- Nothing -> text "constructor field name"
- Just con -> text "field of constructor" <+> quotes (ppr con)
+ HsRecFieldCon con -> Just con
+ HsRecFieldPat con -> Just con
+ _ {- update -} -> Nothing
rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)
-> RnM (LHsRecField GhcRn (Located arg))
rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
- = L loc (FieldOcc (L ll lbl) _)
+ = L loc (FieldOcc _ (L ll lbl))
, hsRecFieldArg = arg
, hsRecPun = pun }))
- = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
+ = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
; arg' <- if pun
then do { checkErr pun_ok (badPun (L loc lbl))
-- Discard any module qualifier (#11662)
@@ -611,20 +604,22 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return (L loc (mk_arg loc arg_rdr)) }
else return arg
; return (L l (HsRecField { hsRecFieldLbl
- = L loc (FieldOcc (L ll lbl) sel)
+ = L loc (FieldOcc sel (L ll lbl))
, hsRecFieldArg = arg'
, hsRecPun = pun })) }
+ rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))
+ = panic "rnHsRecFields"
rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat
-> Maybe Name -- The constructor (Nothing for an
-- out of scope constructor)
-> [LHsRecField GhcRn (Located arg)] -- Explicit fields
-> RnM [LHsRecField GhcRn (Located arg)] -- Filled in .. fields
- rn_dotdot Nothing _mb_con _flds -- No ".." at all
- = return []
- rn_dotdot (Just {}) Nothing _flds -- Constructor out of scope
- = return []
rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
+ | not (isUnboundName con) -- This test is because if the constructor
+ -- isn't in scope the constructor lookup will add
+ -- an error but still return an unbound name. We
+ -- don't want that to screw up the dot-dot fill-in stuff.
= ASSERT( flds `lengthIs` n )
do { loc <- getSrcSpanM -- Rather approximate
; dd_flag <- xoptM LangExt.RecordWildCards
@@ -654,64 +649,32 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; addUsedGREs dot_dot_gres
; return [ L loc (HsRecField
- { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
+ { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))
, hsRecFieldArg = L loc (mk_arg loc arg_rdr)
, hsRecPun = False })
| fl <- dot_dot_fields
, let sel = flSelector fl
, let arg_rdr = mkVarUnqual (flLabel fl) ] }
- check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
- -- When disambiguation is on, return name of parent tycon.
- check_disambiguation disambig_ok mb_con
- | disambig_ok, Just con <- mb_con
- = do { env <- getGlobalRdrEnv; return (find_tycon env con) }
- | otherwise = return Nothing
-
- find_tycon :: GlobalRdrEnv -> Name {- DataCon -}
- -> Maybe Name {- TyCon -}
- -- Return the parent *type constructor* of the data constructor
- -- (that is, the parent of the data constructor),
- -- or 'Nothing' if it is a pattern synonym or not in scope.
- -- That's the parent to use for looking up record fields.
- find_tycon env con_name
- | Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name
- = Just (tyConName (dataConTyCon dc))
- -- Special case for [], which is built-in syntax
- -- and not in the GlobalRdrEnv (Trac #8448)
-
- | Just gre <- lookupGRE_Name env con_name
- = case gre_par gre of
- ParentIs p -> Just p
- _ -> Nothing -- Can happen if the con_name
- -- is for a pattern synonym
-
- | otherwise = Nothing
- -- Data constructor not lexically in scope at all
- -- See Note [Disambiguation and Template Haskell]
-
- dup_flds :: [[RdrName]]
+ rn_dotdot _dotdot _mb_con _flds
+ = return []
+ -- _dotdot = Nothing => No ".." at all
+ -- _mb_con = Nothing => Record update
+ -- _mb_con = Just unbound => Out of scope data constructor
+
+ dup_flds :: [NE.NonEmpty RdrName]
-- Each list represents a RdrName that occurred more than once
-- (the list contains all occurrences)
-- Each list in dup_fields is non-empty
(_, dup_flds) = removeDups compare (getFieldLbls flds)
-{- Note [Disambiguation and Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (Trac #12130)
- module Foo where
- import M
- b = $(funny)
-
- module M(funny) where
- data T = MkT { x :: Int }
- funny :: Q Exp
- funny = [| MkT { x = 3 } |]
-
-When we splice, neither T nor MkT are lexically in scope, so find_tycon will
-fail. But there is no need for disambiguation anyway, so we just return Nothing
--}
+-- NB: Consider this:
+-- module Foo where { data R = R { fld :: Int } }
+-- module Odd where { import Foo; fld x = x { fld = 3 } }
+-- Arguably this should work, because the reference to 'fld' is
+-- unambiguous because there is only one field id 'fld' in scope.
+-- But currently it's rejected.
rnHsRecUpdFields
:: [LHsRecUpdField GhcPs]
@@ -750,7 +713,7 @@ rnHsRecUpdFields flds
then do { checkErr pun_ok (badPun (L loc lbl))
-- Discard any module qualifier (#11662)
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
- ; return (L loc (HsVar (L loc arg_rdr))) }
+ ; return (L loc (HsVar noExt (L loc arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
@@ -760,16 +723,16 @@ rnHsRecUpdFields flds
Right _ -> fvs
lbl' = case sel of
Left sel_name ->
- L loc (Unambiguous (L loc lbl) sel_name)
+ L loc (Unambiguous sel_name (L loc lbl))
Right [sel_name] ->
- L loc (Unambiguous (L loc lbl) sel_name)
- Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder)
+ L loc (Unambiguous sel_name (L loc lbl))
+ Right _ -> L loc (Ambiguous noExt (L loc lbl))
; return (L l (HsRecField { hsRecFieldLbl = lbl'
, hsRecFieldArg = arg''
, hsRecPun = pun }), fvs') }
- dup_flds :: [[RdrName]]
+ dup_flds :: [NE.NonEmpty RdrName]
-- Each list represents a RdrName that occurred more than once
-- (the list contains all occurrences)
-- Each list in dup_fields is non-empty
@@ -784,7 +747,7 @@ getFieldLbls :: [LHsRecField id arg] -> [RdrName]
getFieldLbls flds
= map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
-getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
+getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
needFlagDotDot :: HsRecFieldContext -> SDoc
@@ -803,10 +766,10 @@ badPun :: Located RdrName -> SDoc
badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
text "Use NamedFieldPuns to permit this"]
-dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
+dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
dupFieldErr ctxt dups
= hsep [text "duplicate field name",
- quotes (ppr (head dups)),
+ quotes (ppr (NE.head dups)),
text "in record", pprRFC ctxt]
pprRFC :: HsRecFieldContext -> SDoc
@@ -868,11 +831,10 @@ rnOverLit origLit
; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
<- lookupSyntaxName std_name
; let rebindable = case from_thing_name of
- HsVar (L _ v) -> v /= std_name
- _ -> panic "rnOverLit"
+ HsVar _ (L _ v) -> v /= std_name
+ _ -> panic "rnOverLit"
; let lit' = lit { ol_witness = from_thing_name
- , ol_rebindable = rebindable
- , ol_type = placeHolderType }
+ , ol_ext = rebindable }
; if isNegativeZeroOverLit lit'
then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
<- lookupSyntaxName negateName
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 244f46b3c0..91c46b3cc4 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -14,6 +14,8 @@ module RnSource (
#include "HsVersions.h"
+import GhcPrelude
+
import {-# SOURCE #-} RnExpr( rnLExpr )
import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
@@ -27,7 +29,7 @@ import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames
, checkDupRdrNames, inHsDocContext, bindLocalNamesFV
, checkShadowedRdrNames, warnUnusedTypePatterns
, extendTyVarEnvFVRn, newLocalBndrsRn )
-import RnUnbound ( mkUnboundName )
+import RnUnbound ( mkUnboundName, notInScopeErr )
import RnNames
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcAnnotations ( annCtxt )
@@ -36,7 +38,6 @@ import TcRnMonad
import ForeignCall ( CCallTarget(..) )
import Module
import HscTypes ( Warnings(..), plusWarns )
-import Class ( FunDep )
import PrelNames ( applicativeClassName, pureAName, thenAName
, monadClassName, returnMName, thenMName
, monadFailClassName, failMName, failMName_preMFP
@@ -49,11 +50,11 @@ import NameEnv
import Avail
import Outputable
import Bag
-import BasicTypes ( DerivStrategy, RuleName, pprRuleName )
+import BasicTypes ( RuleName, pprRuleName )
import FastString
import SrcLoc
import DynFlags
-import Util ( debugIsOn, lengthExceeds, partitionWith )
+import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith )
import HscTypes ( HscEnv, hsc_dflags )
import ListSetOps ( findDupsEq, removeDups, equivClasses )
import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..)
@@ -63,8 +64,9 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Arrow ( first )
-import Data.List ( sortBy, mapAccumL )
-import Data.Maybe ( isJust )
+import Data.List ( mapAccumL )
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.Set as Set ( difference, fromList, toList, null )
{- | @rnSourceDecl@ "renames" declarations.
@@ -95,7 +97,6 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
- hs_vects = vect_decls,
hs_docs = docs })
= do {
-- (A) Process the fixity declarations, creating a mapping from
@@ -109,7 +110,6 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
--
-- * Class ops, data constructors, and record fields,
-- because they do not have value declarations.
- -- Aso step (C) depends on datacons and record fields
--
-- * For hs-boot files, include the value signatures
-- Again, they have no value declarations
@@ -128,8 +128,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
-- (D2) Rename the left-hand sides of the value bindings.
- -- This depends on everything from (B) being in scope,
- -- and on (C) for resolving record wild cards.
+ -- This depends on everything from (B) being in scope.
-- It uses the fixity env from (A) to bind fixities for view patterns.
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
@@ -138,7 +137,6 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- They are already in scope
traceRn "rnSrcDecls" (ppr id_bndrs) ;
tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
- traceRn "D2" (ppr (tcg_rdr_env (fst tc_envs)));
setEnvs tc_envs $ do {
-- Now everything is in scope, as the remaining renaming assumes.
@@ -173,7 +171,8 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- Rename fixity declarations and error if we try to
-- fix something from another module (duplicates were checked in (A))
let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
- rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
+ rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
+ fix_decls ;
-- Rename deprec decls;
-- check for duplicates and ensure that deprecated things are defined locally
@@ -185,18 +184,18 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
(rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
rnList rnHsRuleDecls rule_decls ;
-- Inside RULES, scoped type variables are on
- (rn_vect_decls, src_fvs3) <- rnList rnHsVectDecl vect_decls ;
- (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
- (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
- (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
- (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
- (rn_splice_decls, src_fvs8) <- rnList rnSpliceDecl splice_decls ;
+ (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
+ (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ;
+ (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
+ (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ;
+ (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ;
-- Haddock docs; no free vars
rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
last_tcg_env <- getGblEnv ;
-- (I) Compute the results and return
- let {rn_group = HsGroup { hs_valds = rn_val_decls,
+ let {rn_group = HsGroup { hs_ext = noExt,
+ hs_valds = rn_val_decls,
hs_splcds = rn_splice_decls,
hs_tyclds = rn_tycl_decls,
hs_derivds = rn_deriv_decls,
@@ -207,13 +206,12 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
hs_annds = rn_ann_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
- hs_vects = rn_vect_decls,
hs_docs = rn_docs } ;
tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
- src_fvs6, src_fvs7, src_fvs8] ;
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+ src_fvs5, src_fvs6, src_fvs7] ;
-- It is tiresome to gather the binders from type and class decls
src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
@@ -224,11 +222,11 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
in -- we return the deprecs in the env, not in the HsGroup above
tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
} ;
- traceRn "last" (ppr (tcg_rdr_env final_tcg_env)) ;
traceRn "finish rnSrc" (ppr rn_group) ;
traceRn "finish Dus" (ppr src_dus ) ;
return (final_tcg_env, rn_group)
}}}}
+rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
@@ -263,45 +261,6 @@ rnDocDecl (DocGroup lev doc) = do
{-
*********************************************************
* *
- Source-code fixity declarations
-* *
-*********************************************************
--}
-
-rnSrcFixityDecls :: NameSet -> [LFixitySig GhcPs] -> RnM [LFixitySig GhcRn]
--- Rename the fixity decls, so we can put
--- the renamed decls in the renamed syntax tree
--- Errors if the thing being fixed is not defined locally.
---
--- The returned FixitySigs are not actually used for anything,
--- except perhaps the GHCi API
-rnSrcFixityDecls bndr_set fix_decls
- = do fix_decls <- mapM rn_decl fix_decls
- return (concat fix_decls)
- where
- sig_ctxt = TopSigCtxt bndr_set
-
- rn_decl :: LFixitySig GhcPs -> RnM [LFixitySig GhcRn]
- -- GHC extension: look up both the tycon and data con
- -- for con-like things; hence returning a list
- -- If neither are in scope, report an error; otherwise
- -- return a fixity sig for each (slightly odd)
- rn_decl (L loc (FixitySig fnames fixity))
- = do names <- mapM lookup_one fnames
- return [ L loc (FixitySig name fixity)
- | name <- names ]
-
- lookup_one :: Located RdrName -> RnM [Located Name]
- lookup_one (L name_loc rdr_name)
- = setSrcSpan name_loc $
- -- this lookup will fail if the definition isn't local
- do names <- lookupLocalTcNames sig_ctxt what rdr_name
- return [ L name_loc name | (_, name) <- names ]
- what = text "fixity signature"
-
-{-
-*********************************************************
-* *
Source-code deprecations declarations
* *
*********************************************************
@@ -320,7 +279,7 @@ rnSrcWarnDecls _ []
rnSrcWarnDecls bndr_set decls'
= do { -- check for duplicates
- ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
+ ; mapM_ (\ dups -> let (L loc rdr :| (lrdr':_)) = dups
in addErrAt loc (dupWarnDecl lrdr' rdr))
warn_rdr_dups
; pairs_s <- mapM (addLocM rn_deprec) decls
@@ -330,18 +289,19 @@ rnSrcWarnDecls bndr_set decls'
sig_ctxt = TopSigCtxt bndr_set
- rn_deprec (Warning rdr_names txt)
+ rn_deprec (Warning _ rdr_names txt)
-- ensures that the names are defined locally
= do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
rdr_names
; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
+ rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"
what = text "deprecation"
- warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
+ warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns)
decls
-findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
+findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
-- look for duplicates among the OccNames;
@@ -363,13 +323,14 @@ dupWarnDecl (L loc _) rdr_name
-}
rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
-rnAnnDecl ann@(HsAnnotation s provenance expr)
+rnAnnDecl ann@(HsAnnotation _ s provenance expr)
= addErrCtxt (annCtxt ann) $
do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
; (expr', expr_fvs) <- setStage (Splice Untyped) $
rnLExpr expr
- ; return (HsAnnotation s provenance' expr',
+ ; return (HsAnnotation noExt s provenance' expr',
provenance_fvs `plusFV` expr_fvs) }
+rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"
rnAnnProvenance :: AnnProvenance RdrName
-> RnM (AnnProvenance Name, FreeVars)
@@ -386,11 +347,12 @@ rnAnnProvenance provenance = do
-}
rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
-rnDefaultDecl (DefaultDecl tys)
+rnDefaultDecl (DefaultDecl _ tys)
= do { (tys', fvs) <- rnLHsTypes doc_str tys
- ; return (DefaultDecl tys', fvs) }
+ ; return (DefaultDecl noExt tys', fvs) }
where
doc_str = DefaultDeclCtx
+rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"
{-
*********************************************************
@@ -410,24 +372,26 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
; let unitId = thisPackage $ hsc_dflags topEnv
spec' = patchForeignImport unitId spec
- ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
- , fd_co = noForeignImportCoercionYet
+ ; return (ForeignImport { fd_i_ext = noExt
+ , fd_name = name', fd_sig_ty = ty'
, fd_fi = spec' }, fvs) }
rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
= do { name' <- lookupLocatedOccRn name
; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
- ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
- , fd_co = noForeignExportCoercionYet
+ ; return (ForeignExport { fd_e_ext = noExt
+ , fd_name = name', fd_sig_ty = ty'
, fd_fe = spec }
, fvs `addOneFV` unLoc name') }
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
+rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"
+
-- | For Windows DLLs we need to know what packages imported symbols are from
-- to generate correct calls. Imported symbols are tagged with the current
--- package, so if they get inlined across a package boundry we'll still
+-- package, so if they get inlined across a package boundary we'll still
-- know where they're from.
--
patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
@@ -458,15 +422,19 @@ patchCCallTarget unitId callTarget =
rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
= do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
- ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
+ ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }
rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
= do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
- ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
+ ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
rnSrcInstDecl (ClsInstD { cid_inst = cid })
- = do { (cid', fvs) <- rnClsInstDecl cid
- ; return (ClsInstD { cid_inst = cid' }, fvs) }
+ = do { traceRn "rnSrcIstDecl {" (ppr cid)
+ ; (cid', fvs) <- rnClsInstDecl cid
+ ; traceRn "rnSrcIstDecl end }" empty
+ ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }
+
+rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"
-- | Warn about non-canonical typeclass instance declarations
--
@@ -613,9 +581,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
-- binding, and return @Just rhsName@ if this is the case
isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
- | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
- , L _ EmptyLocalBinds <- lbinds
- , L _ (HsVar (L _ rhsName)) <- body = Just rhsName
+ | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
+ , L _ (EmptyLocalBinds _) <- lbinds
+ , L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName
isAliasMG _ = Nothing
-- got "lhs = rhs" but expected something different
@@ -696,7 +664,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
; let all_fvs = meth_fvs `plusFV` more_fvs
`plusFV` inst_fvs
- ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
+ ; return (ClsInstDecl { cid_ext = noExt
+ , cid_poly_ty = inst_ty', cid_binds = mbinds'
, cid_sigs = uprags', cid_tyfam_insts = ats'
, cid_overlap_mode = oflag
, cid_datafam_insts = adts' },
@@ -711,45 +680,56 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- the instance context after renaming. This is a bit
-- strange, but should not matter (and it would be more work
-- to remove the context).
-
-rnFamInstDecl :: HsDocContext
- -> Maybe (Name, [Name]) -- Nothing => not associated
- -- Just (cls,tvs) => associated,
- -- and gives class and tyvars of the
- -- parent instance delc
- -> Located RdrName
- -> HsTyPats GhcPs
- -> rhs
- -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
- -> RnM (Located Name, HsTyPats GhcRn, rhs', FreeVars)
-rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
+rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
+
+rnFamInstEqn :: HsDocContext
+ -> Maybe (Name, [Name]) -- Nothing => not associated
+ -- Just (cls,tvs) => associated,
+ -- and gives class and tyvars of the
+ -- parent instance delc
+ -> [Located RdrName] -- Kind variables from the equation's RHS
+ -> FamInstEqn GhcPs rhs
+ -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+ -> RnM (FamInstEqn GhcRn rhs', FreeVars)
+rnFamInstEqn doc mb_cls rhs_kvars
+ (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+ , feqn_pats = pats
+ , feqn_fixity = fixity
+ , feqn_rhs = payload }}) rn_payload
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
- [] -> pprPanic "rnFamInstDecl" (ppr tycon)
+ [] -> pprPanic "rnFamInstEqn" (ppr tycon)
(L loc _ : []) -> loc
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats
+ ; let pat_vars = freeKiTyVarsAllVars $
+ rmDupsInRdrTyVars pat_kity_vars_with_dups
-- Use the "...Dups" form because it's needed
-- below to report unsed binder on the LHS
- ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $
- freeKiTyVarsAllVars $
- rmDupsInRdrTyVars pat_kity_vars_with_dups
+ ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars
+
+ -- Make sure to filter out the kind variables that were explicitly
+ -- bound in the type patterns.
+ ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars
+ ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars
+
+ ; let all_var_names = pat_var_names ++ payload_var_names
-- All the free vars of the family patterns
-- with a sensible binding location
; ((pats', payload'), fvs)
- <- bindLocalNamesFV var_names $
+ <- bindLocalNamesFV all_var_names $
do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
- ; (payload', rhs_fvs) <- rnPayload doc payload
+ ; (payload', rhs_fvs) <- rn_payload doc payload
-- Report unused binders on the LHS
-- See Note [Unused type variables in family instances]
- ; let groups :: [[Located RdrName]]
+ ; let groups :: [NonEmpty (Located RdrName)]
groups = equivClasses cmpLocated $
freeKiTyVarsAllVars pat_kity_vars_with_dups
; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
- [ tv | (tv:_:_) <- groups ]
+ [ tv | (tv :| (_:_)) <- groups ]
-- Add to the used variables
-- a) any variables that appear *more than once* on the LHS
-- e.g. F a Int a = Bool
@@ -761,13 +741,13 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
inst_tvs = case mb_cls of
Nothing -> []
Just (_, inst_tvs) -> inst_tvs
- ; warnUnusedTypePatterns var_names tv_nms_used
+ ; warnUnusedTypePatterns pat_var_names tv_nms_used
-- See Note [Renaming associated types]
; let bad_tvs = case mb_cls of
Nothing -> []
Just (_,cls_tkvs) -> filter is_bad cls_tkvs
- var_name_set = mkNameSet var_names
+ var_name_set = mkNameSet all_var_names
is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
&& not (cls_tkv `elemNameSet` var_name_set)
@@ -776,74 +756,76 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
; let anon_wcs = concatMap collectAnonWildCards pats'
- all_ibs = anon_wcs ++ var_names
+ all_ibs = anon_wcs ++ all_var_names
-- all_ibs: include anonymous wildcards in the implicit
-- binders In a type pattern they behave just like any
-- other type variable except for being anoymous. See
-- Note [Wildcards in family instances]
all_fvs = fvs `addOneFV` unLoc tycon'
-
- ; return (tycon',
- HsIB { hsib_body = pats'
- , hsib_vars = all_ibs
- , hsib_closed = True },
- payload',
+ -- type instance => use, hence addOneFV
+
+ ; return (HsIB { hsib_ext = all_ibs
+ , hsib_body
+ = FamEqn { feqn_ext = noExt
+ , feqn_tycon = tycon'
+ , feqn_pats = pats'
+ , feqn_fixity = fixity
+ , feqn_rhs = payload' } },
all_fvs) }
- -- type instance => use, hence addOneFV
+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"
+rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"
rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl GhcPs
-> RnM (TyFamInstDecl GhcRn, FreeVars)
-rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
+rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
= do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
- ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
- , tfid_fvs = fvs }, fvs) }
+ ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
rnTyFamInstEqn :: Maybe (Name, [Name])
-> TyFamInstEqn GhcPs
-> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
- , tfe_pats = pats
- , tfe_fixity = fixity
- , tfe_rhs = rhs })
- = do { (tycon', pats', rhs', fvs) <-
- rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
- ; return (TyFamEqn { tfe_tycon = tycon'
- , tfe_pats = pats'
- , tfe_fixity = fixity
- , tfe_rhs = rhs' }, fvs) }
+rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+ , feqn_rhs = rhs }})
+ = do { rhs_kvs <- extractHsTyRdrTyVarsKindVars rhs
+ ; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
+rnTyFamInstEqn _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
+rnTyFamInstEqn _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
rnTyFamDefltEqn :: Name
-> TyFamDefltEqn GhcPs
-> RnM (TyFamDefltEqn GhcRn, FreeVars)
-rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
- , tfe_pats = tyvars
- , tfe_fixity = fixity
- , tfe_rhs = rhs })
- = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
+rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
+ , feqn_pats = tyvars
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs })
+ = do { kvs <- extractHsTyRdrTyVarsKindVars rhs
+ ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
- ; return (TyFamEqn { tfe_tycon = tycon'
- , tfe_pats = tyvars'
- , tfe_fixity = fixity
- , tfe_rhs = rhs' }, fvs) }
+ ; return (FamEqn { feqn_ext = noExt
+ , feqn_tycon = tycon'
+ , feqn_pats = tyvars'
+ , feqn_fixity = fixity
+ , feqn_rhs = rhs' }, fvs) } }
where
ctx = TyFamilyCtx tycon
+rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"
rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl GhcPs
-> RnM (DataFamInstDecl GhcRn, FreeVars)
-rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
- , dfid_pats = pats
- , dfid_fixity = fixity
- , dfid_defn = defn })
- = do { (tycon', pats', (defn', _), fvs) <-
- rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
- ; return (DataFamInstDecl { dfid_tycon = tycon'
- , dfid_pats = pats'
- , dfid_fixity = fixity
- , dfid_defn = defn'
- , dfid_fvs = fvs }, fvs) }
+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
+ FamEqn { feqn_tycon = tycon
+ , feqn_rhs = rhs }})})
+ = do { rhs_kvs <- extractDataDefnKindVars rhs
+ ; (eqn', fvs) <-
+ rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn
+ ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))
+ = panic "rnDataFamInstDecl"
+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))
+ = panic "rnDataFamInstDecl"
-- Renaming of the associated types in instances.
@@ -886,7 +868,7 @@ is the same as
This is implemented as follows: during renaming anonymous wild cards
'_' are given freshly generated names. These names are collected after
-renaming (rnFamInstDecl) and used to make new type variables during
+renaming (rnFamInstEqn) and used to make new type variables during
type checking (tc_fam_ty_pats). One should not confuse these wild
cards with the ones from partial type signatures. The latter generate
fresh meta-variables whereas the former generate fresh skolems.
@@ -912,7 +894,7 @@ when
type T (a,_) = a
would be rejected. So we should not complain about an unused variable b
-As usual, the warnings are not reported for for type variables with names
+As usual, the warnings are not reported for type variables with names
beginning with an underscore.
Extra-constraints wild cards are not supported in type/data family
@@ -922,7 +904,7 @@ Relevant tickets: #3699, #10586, #10982 and #11451.
Note [Renaming associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Check that the RHS of the decl mentions only type variables
+Check that the RHS of the decl mentions only type variables that are explicitly
bound on the LHS. For example, this is not ok
class C a b where
type F a x :: *
@@ -930,13 +912,26 @@ bound on the LHS. For example, this is not ok
type F (p,q) x = (x, r) -- BAD: mentions 'r'
c.f. Trac #5515
-The same thing applies to kind variables, of course (Trac #7938, #9574):
+Kind variables, on the other hand, are allowed to be implicitly or explicitly
+bound. As examples, this (#9574) is acceptable:
class Funct f where
type Codomain f :: *
instance Funct ('KProxy :: KProxy o) where
+ -- o is implicitly bound by the kind signature
+ -- of the LHS type pattern ('KProxy)
type Codomain 'KProxy = NatTr (Proxy :: o -> *)
-Here 'o' is mentioned on the RHS of the Codomain function, but
-not on the LHS.
+And this (#14131) is also acceptable:
+ data family Nat :: k -> k -> *
+ -- k is implicitly bound by an invisible kind pattern
+ newtype instance Nat :: (k -> *) -> (k -> *) -> * where
+ Nat :: (forall xx. f xx -> g xx) -> Nat f g
+We could choose to disallow this, but then associated type families would not
+be able to be as expressive as top-level type synonyms. For example, this type
+synonym definition is allowed:
+ type T = (Nothing :: Maybe a)
+So for parity with type synonyms, we also allow:
+ type family T :: Maybe a
+ type instance T = (Nothing :: Maybe a)
All this applies only for *instance* declarations. In *class*
declarations there is no RHS to worry about, and the class variables
@@ -958,14 +953,17 @@ Here 'k' is in scope in the kind signature, just like 'x'.
-}
rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
-rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
+rnSrcDerivDecl (DerivDecl _ ty mds overlap)
= do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
- ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies
; unless standalone_deriv_ok (addErr standaloneDerivErr)
- ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
- illegalDerivStrategyErr $ fmap unLoc deriv_strat
- ; (ty', fvs) <- rnLHsInstType (text "a deriving declaration") ty
- ; return (DerivDecl ty' deriv_strat overlap, fvs) }
+ ; (mds', ty', fvs)
+ <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
+ rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
+ rnHsSigWcType DerivDeclCtx ty
+ ; return (DerivDecl noExt ty' mds' overlap, fvs) }
+ where
+ loc = getLoc $ hsib_body $ hswc_body ty
+rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"
standaloneDerivErr :: SDoc
standaloneDerivErr
@@ -981,12 +979,13 @@ standaloneDerivErr
-}
rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules src rules)
+rnHsRuleDecls (HsRules _ src rules)
= do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
- ; return (HsRules src rn_rules,fvs) }
+ ; return (HsRules noExt src rn_rules,fvs) }
+rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
+rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs)
= do { let rdr_names_w_loc = map get_var vars
; checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
@@ -995,11 +994,14 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
do { (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
- ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+ ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars'
+ lhs' rhs',
fv_lhs' `plusFV` fv_rhs') } }
where
- get_var (L _ (RuleBndrSig v _)) = v
- get_var (L _ (RuleBndr v)) = v
+ get_var (L _ (RuleBndrSig _ v _)) = v
+ get_var (L _ (RuleBndr _ v)) = v
+ get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl"
+rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
-> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
@@ -1010,14 +1012,14 @@ bindHsRuleVars rule_name vars names thing_inside
where
doc = RuleCtx rule_name
- go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
+ go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside
= go vars ns $ \ vars' ->
- thing_inside (L l (RuleBndr (L loc n)) : vars')
+ thing_inside (L l (RuleBndr noExt (L loc n)) : vars')
- go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
+ go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside
= rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
go vars ns $ \ vars' ->
- thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
+ thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars')
go [] [] thing_inside = thing_inside []
go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
@@ -1057,10 +1059,11 @@ validRuleLhs foralls lhs
where
checkl (L _ e) = check e
- check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
- check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
- check (HsAppType e _) = checkl e
- check (HsVar (L _ v)) | v `notElem` foralls = Nothing
+ check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1
+ `mplus` checkl_e e2
+ check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2
+ check (HsAppType _ e) = checkl e
+ check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing
check other = Just other -- Failure
-- Check an argument
@@ -1090,64 +1093,14 @@ badRuleVar name var
badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
badRuleLhsErr name lhs bad_e
= sep [text "Rule" <+> pprRuleName name <> colon,
- nest 4 (vcat [err,
+ nest 2 (vcat [err,
text "in left-hand side:" <+> ppr lhs])]
$$
text "LHS must be of form (f e1 .. en) where f is not forall'd"
where
err = case bad_e of
- HsUnboundVar uv -> text "Not in scope:" <+> ppr uv
- _ -> text "Illegal expression:" <+> ppr bad_e
-
-{-
-*********************************************************
-* *
-\subsection{Vectorisation declarations}
-* *
-*********************************************************
--}
-
-rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars)
--- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
--- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
-rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
- = do { var' <- lookupLocatedOccRn var
- ; (rhs', fv_rhs) <- rnLExpr rhs
- ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
- }
-rnHsVectDecl (HsVect _ _var _rhs)
- = failWith $ vcat
- [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
- , text "must be an identifier"
- ]
-rnHsVectDecl (HsNoVect s var)
- = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
- ; return (HsNoVect s var', unitFV (unLoc var'))
- }
-rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
- = do { tycon' <- lookupLocatedOccRn tycon
- ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
- }
-rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
- = do { tycon' <- lookupLocatedOccRn tycon
- ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
- ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
- , mkFVs [unLoc tycon', unLoc rhs_tycon'])
- }
-rnHsVectDecl (HsVectTypeOut _ _ _)
- = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
-rnHsVectDecl (HsVectClassIn s cls)
- = do { cls' <- lookupLocatedOccRn cls
- ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
- }
-rnHsVectDecl (HsVectClassOut _)
- = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
-rnHsVectDecl (HsVectInstIn instTy)
- = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
- ; return (HsVectInstIn instTy', fvs)
- }
-rnHsVectDecl (HsVectInstOut _)
- = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
+ HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv))
+ _ -> text "Illegal expression:" <+> ppr bad_e
{- **************************************************************
* *
@@ -1301,9 +1254,6 @@ rnTyClDecls tycl_ds
; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
- ; tycls_w_fvs <- addBootDeps tycls_w_fvs
- -- TBD must add_boot_deps to instds_w_fvs?
-
-- Do SCC analysis on the type/class decls
; rdr_env <- getGlobalRdrEnv
; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
@@ -1314,7 +1264,8 @@ rnTyClDecls tycl_ds
first_group
| null init_inst_ds = []
- | otherwise = [TyClGroup { group_tyclds = []
+ | otherwise = [TyClGroup { group_ext = noExt
+ , group_tyclds = []
, group_roles = []
, group_instds = init_inst_ds }]
@@ -1345,7 +1296,8 @@ rnTyClDecls tycl_ds
bndrs = map (tcdName . unLoc) tycl_ds
(inst_ds, inst_map') = getInsts bndrs inst_map
(roles, role_env') = getRoleAnnots bndrs role_env
- group = TyClGroup { group_tyclds = tycl_ds
+ group = TyClGroup { group_ext = noExt
+ , group_tyclds = tycl_ds
, group_roles = roles
, group_instds = inst_ds }
@@ -1383,123 +1335,6 @@ getParent rdr_env n
Nothing -> n
-{- Note [Extra dependencies from .hs-boot files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This is a long story, so buckle in.
-
-**Dependencies via hs-boot files are not obvious.** Consider the following case:
-
-A.hs-boot
- module A where
- data A1
-
-B.hs
- module B where
- import {-# SOURCE #-} A
- type B1 = A1
-
-A.hs
- module A where
- import B
- data A2 = MkA2 B1
- data A1 = MkA1 A2
-
-Here A2 is really recursive (via B1), but we won't see that easily when
-doing dependency analysis when compiling A.hs. When we look at A2,
-we see that its free variables are simply B1, but without (recursively) digging
-into the definition of B1 will we see that it actually refers to A1 via an
-hs-boot file.
-
-**Recursive declarations, even those broken by an hs-boot file, need to
-be type-checked together.** Whenever we refer to a declaration via
-an hs-boot file, we must be careful not to force the TyThing too early:
-ala Note [Tying the knot] if we force the TyThing before we have
-defined it ourselves in the local type environment, GHC will error.
-
-Conservatively, then, it would make sense that we to typecheck A1
-and A2 from the previous example together, because the two types are
-truly mutually recursive through B1.
-
-If we are being clever, we might observe that while kind-checking
-A2, we don't actually need to force the TyThing for A1: B1
-independently records its kind, so there is no need to go "deeper".
-But then we are in an uncomfortable situation where we have
-constructed a TyThing for A2 before we have checked A1, and we
-have to be absolutely certain we don't force it too deeply until
-we get around to kind checking A1, which could be for a very long
-time.
-
-Indeed, with datatype promotion, we may very well need to look
-at the type of MkA2 before we have kind-checked A1: consider,
-
- data T = MkT (Proxy 'MkA2)
-
-To promote MkA2, we need to lift its type to the kind level.
-We never tested this, but it seems likely A1 would get poked
-at this point.
-
-**Here's what we do instead.** So it is expedient for us to
-make sure A1 and A2 are kind checked together in a loop.
-To ensure that our dependency analysis can catch this,
-we add a dependency:
-
- - from every local declaration
- - to everything that comes from this module's .hs-boot file
- (this is gotten from sb_tcs in the SelfBootInfo).
-
-In this case, we'll add an edges
-
- - from A1 to A2 (but that edge is there already)
- - from A2 to A1 (which is new)
-
-Well, not quite *every* declaration. Imagine module A
-above had another datatype declaration:
-
- data A3 = A3 Int
-
-Even though A3 has a dependency (on Int), all its dependencies are from things
-that live on other packages. Since we don't have mutual dependencies across
-packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
-
-Hence function nameIsHomePackageImport.
-
-Note that this is fairly conservative: it essentially implies that
-EVERY type declaration in this modules hs-boot file will be kind-checked
-together in one giant loop (and furthermore makes every other type
-in the module depend on this loop). This is perhaps less than ideal, because
-the larger a recursive group, the less polymorphism available (we
-cannot infer a type to be polymorphically instantiated while we
-are inferring its kind), but no one has hollered about this (yet!)
--}
-
-addBootDeps :: [(LTyClDecl GhcRn, FreeVars)]
- -> RnM [(LTyClDecl GhcRn, FreeVars)]
--- See Note [Extra dependencies from .hs-boot files]
-addBootDeps ds_w_fvs
- = do { tcg_env <- getGblEnv
- ; let this_mod = tcg_mod tcg_env
- boot_info = tcg_self_boot tcg_env
-
- add_boot_deps :: [(LTyClDecl GhcRn, FreeVars)]
- -> [(LTyClDecl GhcRn, FreeVars)]
- add_boot_deps ds_w_fvs
- = case boot_info of
- SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
- -> map (add_one tcs) ds_w_fvs
- _ -> ds_w_fvs
-
- add_one :: NameSet -> (LTyClDecl GhcRn, FreeVars)
- -> (LTyClDecl GhcRn, FreeVars)
- add_one tcs pr@(decl,fvs)
- | has_local_imports fvs = (decl, fvs `plusFV` tcs)
- | otherwise = pr
-
- has_local_imports fvs
- = nameSetAny (nameIsHomePackageImport this_mod) fvs
- ; return (add_boot_deps ds_w_fvs) }
-
-
-
{- ******************************************************
* *
Role annotations
@@ -1522,24 +1357,24 @@ rnRoleAnnots tc_names role_annots
; mapM_ dupRoleAnnotErr dup_annots
; mapM (wrapLocM rn_role_annot1) no_dups }
where
- rn_role_annot1 (RoleAnnotDecl tycon roles)
+ rn_role_annot1 (RoleAnnotDecl _ tycon roles)
= do { -- the name is an *occurrence*, but look it up only in the
-- decls defined in this group (see #10263)
tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
(text "role annotation")
tycon
- ; return $ RoleAnnotDecl tycon' roles }
+ ; return $ RoleAnnotDecl noExt tycon' roles }
+ rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"
-dupRoleAnnotErr :: [LRoleAnnotDecl GhcPs] -> RnM ()
-dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
+dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr list
= addErrAt loc $
hang (text "Duplicate role annotations for" <+>
quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
- 2 (vcat $ map pp_role_annot sorted_list)
+ 2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
where
- sorted_list = sortBy cmp_annot list
- (L loc first_decl : _) = sorted_list
+ sorted_list = NE.sortBy cmp_annot list
+ (L loc first_decl :| _) = sorted_list
pp_role_annot (L loc decl) = hang (ppr decl)
4 (text "-- written at" <+> ppr loc)
@@ -1647,21 +1482,19 @@ rnTyClDecl :: TyClDecl GhcPs
-- in a class decl
rnTyClDecl (FamDecl { tcdFam = decl })
= do { (decl', fvs) <- rnFamDecl Nothing decl
- ; return (FamDecl decl', fvs) }
+ ; return (FamDecl noExt decl', fvs) }
rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity, tcdRhs = rhs })
= do { tycon' <- lookupLocatedTopBndrRn tycon
- ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
+ ; kvs <- extractHsTyRdrTyVarsKindVars rhs
; let doc = TySynCtx tycon
; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
- ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
- \ tyvars' _ ->
- do { (rhs', fvs) <- rnTySyn doc rhs
- ; return ((tyvars', rhs'), fvs) }
+ ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
+ do { (rhs', fvs) <- rnTySyn doc rhs
; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdFixity = fixity
- , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
+ , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
@@ -1671,20 +1504,18 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
; kvs <- extractDataDefnKindVars defn
; let doc = TyDataCtx tycon
; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
- ; ((tyvars', defn', no_kvs), fvs)
- <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
- do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
- ; let sig_tvs = filterNameSet isTyVarName kind_sig_fvs
- unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars
- ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }
+ ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
+ do { (defn', fvs) <- rnDataDefn doc defn
-- See Note [Complete user-supplied kind signatures] in HsDecls
- ; typeintype <- xoptM LangExt.TypeInType
- ; let cusk = hsTvbAllKinded tyvars' &&
- (not typeintype || no_kvs)
- ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
- , tcdFixity = fixity
- , tcdDataDefn = defn', tcdDataCusk = cusk
- , tcdFVs = fvs }, fvs) }
+ ; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs
+ rn_info = DataDeclRn { tcdDataCusk = cusk
+ , tcdFVs = fvs }
+ ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
+ ; return (DataDecl { tcdLName = tycon'
+ , tcdTyVars = tyvars'
+ , tcdFixity = fixity
+ , tcdDataDefn = defn'
+ , tcdDExt = rn_info }, fvs) } }
rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFixity = fixity,
@@ -1715,7 +1546,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
- ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
+ ; let sig_rdr_names_w_locs = [op |L _ (ClassOpSig _ False ops _) <- sigs
, op <- ops]
; checkDupRdrNames sig_rdr_names_w_locs
-- Typechecker is responsible for checking that we only
@@ -1745,19 +1576,19 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars', tcdFixity = fixity,
tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
- tcdDocs = docs', tcdFVs = all_fvs },
+ tcdDocs = docs', tcdCExt = all_fvs },
all_fvs ) }
where
cls_doc = ClassDeclCtx lcls
+rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"
+
-- "type" and "type instance" declarations
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn doc rhs = rnLHsType doc rhs
rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
- -> RnM ((HsDataDefn GhcRn, NameSet), FreeVars)
- -- the NameSet includes all Names free in the kind signature
- -- See Note [Complete user-supplied kind signatures]
+ -> RnM (HsDataDefn GhcRn, FreeVars)
rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context, dd_cons = condecls
, dd_kindSig = m_sig, dd_derivs = derivs })
@@ -1782,11 +1613,11 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
- ; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
- , dd_ctxt = context', dd_kindSig = m_sig'
- , dd_cons = condecls'
- , dd_derivs = derivs' }
- , sig_fvs )
+ ; return ( HsDataDefn { dd_ext = noExt
+ , dd_ND = new_or_data, dd_cType = cType
+ , dd_ctxt = context', dd_kindSig = m_sig'
+ , dd_cons = condecls'
+ , dd_derivs = derivs' }
, all_fvs )
}
where
@@ -1798,30 +1629,148 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
= do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
multipleDerivClausesErr
- ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
+ ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
; return (L loc ds', fvs) }
+rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"
-rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs
+rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
-> RnM (LHsDerivingClause GhcRn, FreeVars)
-rnLHsDerivingClause deriv_strats_ok doc
- (L loc (HsDerivingClause { deriv_clause_strategy = dcs
+rnLHsDerivingClause doc
+ (L loc (HsDerivingClause { deriv_clause_ext = noExt
+ , deriv_clause_strategy = dcs
, deriv_clause_tys = L loc' dct }))
- = do { failIfTc (isJust dcs && not deriv_strats_ok) $
- illegalDerivStrategyErr $ fmap unLoc dcs
- ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
- ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
- , deriv_clause_tys = L loc' dct' })
- , fvs ) }
+ = do { (dcs', dct', fvs)
+ <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->
+ mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct
+ ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExt
+ , deriv_clause_strategy = dcs'
+ , deriv_clause_tys = L loc' dct' })
+ , fvs ) }
+ where
+ rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs
+ -> RnM (LHsSigType GhcRn, FreeVars)
+ rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = L loc _}) =
+ rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $
+ rnHsSigType doc deriv_ty
+ rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"
+rnLHsDerivingClause _ (L _ (XHsDerivingClause _))
+ = panic "rnLHsDerivingClause"
+
+rnLDerivStrategy :: forall a.
+ HsDocContext
+ -> Maybe (LDerivStrategy GhcPs)
+ -> ([Name] -- The tyvars bound by the via type
+ -> SDoc -- The pretty-printed via type (used for
+ -- error message reporting)
+ -> RnM (a, FreeVars))
+ -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
+rnLDerivStrategy doc mds thing_inside
+ = case mds of
+ Nothing -> boring_case Nothing
+ Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds
+ pure (Just ds', thing, fvs)
+ where
+ rn_deriv_strat :: LDerivStrategy GhcPs
+ -> RnM (LDerivStrategy GhcRn, a, FreeVars)
+ rn_deriv_strat (L loc ds) = do
+ let extNeeded :: LangExt.Extension
+ extNeeded
+ | ViaStrategy{} <- ds
+ = LangExt.DerivingVia
+ | otherwise
+ = LangExt.DerivingStrategies
+
+ unlessXOptM extNeeded $
+ failWith $ illegalDerivStrategyErr ds
+
+ case ds of
+ StockStrategy -> boring_case (L loc StockStrategy)
+ AnyclassStrategy -> boring_case (L loc AnyclassStrategy)
+ NewtypeStrategy -> boring_case (L loc NewtypeStrategy)
+ ViaStrategy via_ty ->
+ do (via_ty', fvs1) <- rnHsSigType doc via_ty
+ let HsIB { hsib_ext = via_imp_tvs
+ , hsib_body = via_body } = via_ty'
+ (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
+ via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs
+ via_tvs = via_imp_tvs ++ via_exp_tvs
+ (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $
+ thing_inside via_tvs (ppr via_ty')
+ pure (L loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)
+
+ boring_case :: mds
+ -> RnM (mds, a, FreeVars)
+ boring_case mds = do
+ (thing, fvs) <- thing_inside [] empty
+ pure (mds, thing, fvs)
+
+-- | Errors if a @via@ type binds any floating type variables.
+-- See @Note [Floating `via` type variables]@
+rnAndReportFloatingViaTvs
+ :: forall a. Outputable a
+ => [Name] -- ^ The bound type variables from a @via@ type.
+ -> SrcSpan -- ^ The source span (for error reporting only).
+ -> SDoc -- ^ The pretty-printed @via@ type (for error reporting only).
+ -> String -- ^ A description of what the @via@ type scopes over
+ -- (for error reporting only).
+ -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.
+ -> RnM (a, FreeVars)
+rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside
+ = do (thing, thing_fvs) <- thing_inside
+ setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names
+ pure (thing, thing_fvs)
+ where
+ report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()
+ report_floating_via_tv thing used_names tv_name
+ = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat
+ [ text "Type variable" <+> quotes (ppr tv_name) <+>
+ text "is bound in the" <+> quotes (text "via") <+>
+ text "type" <+> quotes ppr_via_ty
+ , text "but is not mentioned in the derived" <+>
+ text via_scope_desc <+> quotes (ppr thing) <>
+ text ", which is illegal" ]
+
+{-
+Note [Floating `via` type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine the following `deriving via` clause:
+
+ data Quux
+ deriving Eq via (Const a Quux)
+
+This should be rejected. Why? Because it would generate the following instance:
+
+ instance Eq Quux where
+ (==) = coerce @(Quux -> Quux -> Bool)
+ @(Const a Quux -> Const a Quux -> Bool)
+ (==) :: Const a Quux -> Const a Quux -> Bool
+
+This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The
+problem is that `a` is never used anywhere in the derived class `Eq`. Since
+`a` is bound but has no use sites, we refer to it as "floating".
+
+We use the rnAndReportFloatingViaTvs function to check that any type renamed
+within the context of the `via` deriving strategy actually uses all bound
+`via` type variables, and if it doesn't, it throws an error.
+-}
badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta _
= vcat [text "No context is allowed on a GADT-style data declaration",
text "(You can put a context on each constructor, though.)"]
-illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc
+illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
illegalDerivStrategyErr ds
- = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds
- , text "Use DerivingStrategies to enable this extension" ]
+ = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
+ , text enableStrategy ]
+
+ where
+ enableStrategy :: String
+ enableStrategy
+ | ViaStrategy{} <- ds
+ = "Use DerivingVia to enable this extension"
+ | otherwise
+ = "Use DerivingStrategies to enable this extension"
multipleDerivClausesErr :: SDoc
multipleDerivClausesErr
@@ -1840,15 +1789,15 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
= do { tycon' <- lookupLocatedTopBndrRn tycon
; kvs <- extractRdrKindSigVars res_sig
; ((tyvars', res_sig', injectivity'), fv1) <-
- bindHsQTyVars doc Nothing mb_cls kvs tyvars $
- \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->
- do { let rn_sig = rnFamResultSig doc rn_kvs
+ bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
+ do { let rn_sig = rnFamResultSig doc
; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
injectivity
; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
; (info', fv2) <- rn_info info
- ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
+ ; return (FamilyDecl { fdExt = noExt
+ , fdLName = tycon', fdTyVars = tyvars'
, fdFixity = fixity
, fdInfo = info', fdResultSig = res_sig'
, fdInjectivityAnn = injectivity' }
@@ -1865,17 +1814,17 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
= return (ClosedTypeFamily Nothing, emptyFVs)
rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
rn_info DataFamily = return (DataFamily, emptyFVs)
+rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
rnFamResultSig :: HsDocContext
- -> [Name] -- kind variables already in scope
-> FamilyResultSig GhcPs
-> RnM (FamilyResultSig GhcRn, FreeVars)
-rnFamResultSig _ _ NoSig
- = return (NoSig, emptyFVs)
-rnFamResultSig doc _ (KindSig kind)
+rnFamResultSig _ (NoSig _)
+ = return (NoSig noExt, emptyFVs)
+rnFamResultSig doc (KindSig _ kind)
= do { (rndKind, ftvs) <- rnLHsKind doc kind
- ; return (KindSig rndKind, ftvs) }
-rnFamResultSig doc kv_names (TyVarSig tvbndr)
+ ; return (KindSig noExt rndKind, ftvs) }
+rnFamResultSig doc (TyVarSig _ tvbndr)
= do { -- `TyVarSig` tells us that user named the result of a type family by
-- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
-- be sure that the supplied result name is not identical to an
@@ -1893,13 +1842,11 @@ rnFamResultSig doc kv_names (TyVarSig tvbndr)
] $$
text "shadows an already bound type variable")
- ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for
+ ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
-- scoping checks that are irrelevant here
- (mkNameSet kv_names) emptyNameSet
- -- use of emptyNameSet here avoids
- -- redundant duplicate errors
- tvbndr $ \ _ _ tvbndr' ->
- return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
+ tvbndr $ \ tvbndr' ->
+ return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }
+rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"
-- Note [Renaming injectivity annotation]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1940,7 +1887,7 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
-> LFamilyResultSig GhcRn -- ^ Result signature
-> LInjectivityAnn GhcPs -- ^ Injectivity annotation
-> RnM (LInjectivityAnn GhcRn)
-rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
+rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
(L srcSpan (InjectivityAnn injFrom injTo))
= do
{ (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
@@ -2016,6 +1963,7 @@ are no data constructors we allow h98_style = True
badAssocRhs :: [Name] -> RnM ()
badAssocRhs ns
= addErr (hang (text "The RHS of an associated type declaration mentions"
+ <+> text "out-of-scope variable" <> plural ns
<+> pprWithCommas (quotes . ppr) ns)
2 (text "All such variables must be bound on the LHS"))
@@ -2024,61 +1972,101 @@ rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
-rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
- , con_cxt = mcxt, con_details = details
+rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+ , con_mb_cxt = mcxt, con_args = args
, con_doc = mb_doc })
- = do { _ <- addLocM checkConName name
- ; new_name <- lookupLocatedTopBndrRn name
- ; let doc = ConDeclCtx [new_name]
- ; mb_doc' <- rnMbLHsDoc mb_doc
- ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
-
- ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
- \new_tyvars _ -> do
- { (new_context, fvs1) <- case mcxt of
- Nothing -> return (Nothing,emptyFVs)
- Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
- ; return (Just lctx',fvs) }
- ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
- ; let (new_details',fvs3) = (new_details,emptyFVs)
+ = do { _ <- addLocM checkConName name
+ ; new_name <- lookupLocatedTopBndrRn name
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
+ -- We bind no implicit binders here; this is just like
+ -- a nested HsForAllTy. E.g. consider
+ -- data T a = forall (b::k). MkT (...)
+ -- The 'k' will already be in scope from the bindHsQTyVars
+ -- for the data decl itself. So we'll get
+ -- data T {k} a = ...
+ -- And indeed we may later discover (a::k). But that's the
+ -- scoping we get. So no implicit binders at the existential forall
+
+ ; let ctxt = ConDeclCtx [new_name]
+ ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
+ Nothing ex_tvs $ \ new_ex_tvs ->
+ do { (new_context, fvs1) <- rnMbContext ctxt mcxt
+ ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+ ; let all_fvs = fvs1 `plusFV` fvs2
; traceRn "rnConDecl" (ppr name <+> vcat
- [ text "free_kvs:" <+> ppr kvs
- , text "qtvs:" <+> ppr qtvs
- , text "qtvs':" <+> ppr qtvs' ])
- ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
- new_tyvars' = case qtvs of
- Nothing -> Nothing
- Just _ -> Just new_tyvars
- ; return (decl { con_name = new_name, con_qvars = new_tyvars'
- , con_cxt = new_context, con_details = new_details'
+ [ text "ex_tvs:" <+> ppr ex_tvs
+ , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
+
+ ; return (decl { con_ext = noExt
+ , con_name = new_name, con_ex_tvs = new_ex_tvs
+ , con_mb_cxt = new_context, con_args = new_args
, con_doc = mb_doc' },
all_fvs) }}
- where
- cxt = maybe [] unLoc mcxt
- get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
-
- get_con_qtvs :: [LHsType GhcPs]
- -> RnM ([Located RdrName], LHsQTyVars GhcPs)
- get_con_qtvs arg_tys
- | Just tvs <- qtvs -- data T = forall a. MkT (a -> a)
- = do { free_vars <- get_rdr_tvs arg_tys
- ; return (freeKiTyVarsKindVars free_vars, tvs) }
- | otherwise -- data T = MkT (a -> a)
- = return ([], mkHsQTvs [])
-
-rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
+
+rnConDecl decl@(ConDeclGADT { con_names = names
+ , con_forall = L _ explicit_forall
+ , con_qvars = qtvs
+ , con_mb_cxt = mcxt
+ , con_args = args
+ , con_res_ty = res_ty
, con_doc = mb_doc })
= do { mapM_ (addLocM checkConName) names
- ; new_names <- mapM lookupLocatedTopBndrRn names
- ; let doc = ConDeclCtx new_names
- ; mb_doc' <- rnMbLHsDoc mb_doc
-
- ; (ty', fvs) <- rnHsSigType doc ty
- ; traceRn "rnConDecl" (ppr names <+> vcat
- [ text "fvs:" <+> ppr fvs ])
- ; return (decl { con_names = new_names, con_type = ty'
+ ; new_names <- mapM lookupLocatedTopBndrRn names
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
+ ; let explicit_tkvs = hsQTvExplicit qtvs
+ theta = hsConDeclTheta mcxt
+ arg_tys = hsConDeclArgTys args
+
+ -- We must ensure that we extract the free tkvs in left-to-right
+ -- order of their appearance in the constructor type.
+ -- That order governs the order the implicitly-quantified type
+ -- variable, and hence the order needed for visible type application
+ -- See Trac #14808.
+ ; free_tkvs <- extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
+ ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs
+
+ ; let ctxt = ConDeclCtx new_names
+ mb_ctxt = Just (inHsDocContext ctxt)
+
+ ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )
+ ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->
+ bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
+ do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
+ ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+ ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
+
+ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+ (args', res_ty')
+ = case args of
+ InfixCon {} -> pprPanic "rnConDecl" (ppr names)
+ RecCon {} -> (new_args, new_res_ty)
+ PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
+ -> ASSERT( null as )
+ -- See Note [GADT abstract syntax] in HsDecls
+ (PrefixCon arg_tys, final_res_ty)
+
+ new_qtvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = implicit_tkvs
+ , hsq_dependent = emptyNameSet }
+ , hsq_explicit = explicit_tkvs }
+
+ ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
+ ; return (decl { con_g_ext = noExt, con_names = new_names
+ , con_qvars = new_qtvs, con_mb_cxt = new_cxt
+ , con_args = args', con_res_ty = res_ty'
, con_doc = mb_doc' },
- fvs) }
+ all_fvs) } }
+
+rnConDecl (XConDecl _) = panic "rnConDecl"
+
+
+rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
+ -> RnM (Maybe (LHsContext GhcRn), FreeVars)
+rnMbContext _ Nothing = return (Nothing, emptyFVs)
+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
+ ; return (Just ctx',fvs) }
rnConDeclDetails
:: Name
@@ -2120,24 +2108,24 @@ extendPatSynEnv val_decls local_fix_env thing = do {
; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
where
new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
- new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
+ new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds
new_ps _ = panic "new_ps"
new_ps' :: LHsBindLR GhcPs GhcPs
-> [(Name, [FieldLabel])]
-> TcM [(Name, [FieldLabel])]
new_ps' bind names
- | L bind_loc (PatSynBind (PSB { psb_id = L _ n
- , psb_args = RecordPatSyn as })) <- bind
+ | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n
+ , psb_args = RecCon as })) <- bind
= do
bnd_name <- newTopSrcBinder (L bind_loc n)
let rnames = map recordPatSynSelectorId as
mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
- mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
+ mkFieldOcc (L l name) = L l (FieldOcc noExt (L l name))
field_occs = map mkFieldOcc rnames
flds <- mapM (newRecordSelector False [bnd_name]) field_occs
return ((bnd_name, flds): names)
- | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
+ | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
= do
bnd_name <- newTopSrcBinder (L bind_loc n)
return ((bnd_name, []): names)
@@ -2152,8 +2140,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
*********************************************************
-}
-rnFds :: [Located (FunDep (Located RdrName))]
- -> RnM [Located (FunDep (Located Name))]
+rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
rnFds fds
= mapM (wrapLocM rn_fds) fds
where
@@ -2199,12 +2186,12 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
-- #10047: Declaration QuasiQuoters are expanded immediately, without
-- causing a group split
-add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
+add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds
= do { (ds', _) <- rnTopSpliceDecls qq
; addl gp (ds' ++ ds)
}
-add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
+add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
= do { -- We've found a top-level splice. If it is an *implicit* one
-- (i.e. a naked top level expression)
case flag of
@@ -2217,84 +2204,98 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
where
badImplicitSplice = text "Parse error: module header, import declaration"
$$ text "or top-level declaration expected."
+ -- The compiler should suggest the above, and not using
+ -- TemplateHaskell since the former suggestion is more
+ -- relevant to the larger base of users.
+ -- See Trac #12146 for discussion.
-- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
| isClassDecl d
- = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
+ = let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in
addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
| otherwise
= addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
-- Signatures: fixity sigs go a different place than all others
-add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
+add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
= addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
= addl (gp {hs_valds = add_sig (L l d) ts}) ds
-- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
+add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds
= addl (gp { hs_valds = add_bind (L l d) ts }) ds
-- Role annotations: added to the TyClGroup
-add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
= addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
-- NB instance declarations go into TyClGroups. We throw them into the first
-- group, just as we do for the TyClD case. The renamer will go on to group
-- and order them later.
-add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds
+add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds
= addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
-- The rest are routine
-add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
+add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds
= addl (gp { hs_derivds = L l d : ts }) ds
-add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
+add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds
= addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
+add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds
= addl (gp { hs_fords = L l d : ts }) ds
-add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
+add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds
= addl (gp { hs_warnds = L l d : ts }) ds
-add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
+add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds
= addl (gp { hs_annds = L l d : ts }) ds
-add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
+add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
-add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
- = addl (gp { hs_vects = L l d : ts }) ds
-add gp l (DocD d) ds
+add gp l (DocD _ d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
-
-add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_tycld d [] = [TyClGroup { group_tyclds = [d]
- , group_roles = []
+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"
+add (HsGroup {}) _ (XHsDecl _) _ = panic "RnSource.add"
+add (XHsGroup _) _ _ _ = panic "RnSource.add"
+
+add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+ -> [TyClGroup (GhcPass p)]
+add_tycld d [] = [TyClGroup { group_ext = noExt
+ , group_tyclds = [d]
+ , group_roles = []
, group_instds = []
}
]
add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
= ds { group_tyclds = d : tyclds } : dss
+add_tycld _ (XTyClGroup _: _) = panic "add_tycld"
-add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_instd d [] = [TyClGroup { group_tyclds = []
- , group_roles = []
+add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+ -> [TyClGroup (GhcPass p)]
+add_instd d [] = [TyClGroup { group_ext = noExt
+ , group_tyclds = []
+ , group_roles = []
, group_instds = [d]
}
]
add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
= ds { group_instds = d : instds } : dss
+add_instd _ (XTyClGroup _: _) = panic "add_instd"
-add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
-add_role_annot d [] = [TyClGroup { group_tyclds = []
- , group_roles = [d]
+add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+ -> [TyClGroup (GhcPass p)]
+add_role_annot d [] = [TyClGroup { group_ext = noExt
+ , group_tyclds = []
+ , group_roles = [d]
, group_instds = []
}
]
add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
= tycls { group_roles = d : roles } : rest
+add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
-add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
-add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
+add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
+add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind"
-add_sig :: LSig a -> HsValBinds a -> HsValBinds a
-add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
-add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
+add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
+add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig"
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index a03e4c88df..19bf763f63 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -11,12 +11,13 @@ module RnSplice (
#include "HsVersions.h"
+import GhcPrelude
+
import Name
import NameSet
import HsSyn
import RdrName
import TcRnMonad
-import Kind
import RnEnv
import RnUtils ( HsDocContext(..), newLocalBndrRn )
@@ -101,7 +102,7 @@ rnBracket e br_body
; (body', fvs_e) <-
setStage (Brack cur_stage RnPendingTyped) $
rn_bracket cur_stage br_body
- ; return (HsBracket body', fvs_e) }
+ ; return (HsBracket noExt body', fvs_e) }
False -> do { traceRn "Renaming untyped TH bracket" empty
; ps_var <- newMutVar []
@@ -109,11 +110,11 @@ rnBracket e br_body
setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
rn_bracket cur_stage br_body
; pendings <- readMutVar ps_var
- ; return (HsRnBracketOut body' pendings, fvs_e) }
+ ; return (HsRnBracketOut noExt body' pendings, fvs_e) }
}
rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
-rn_bracket outer_stage br@(VarBr flg rdr_name)
+rn_bracket outer_stage br@(VarBr x flg rdr_name)
= do { name <- lookupOccRn rdr_name
; this_mod <- getModule
@@ -135,17 +136,18 @@ rn_bracket outer_stage br@(VarBr flg rdr_name)
(quotedNameStageErr br) }
}
}
- ; return (VarBr flg name, unitFV name) }
+ ; return (VarBr x flg name, unitFV name) }
-rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
- ; return (ExpBr e', fvs) }
+rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
+ ; return (ExpBr x e', fvs) }
-rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
+rn_bracket _ (PatBr x p)
+ = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
-rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
- ; return (TypBr t', fvs) }
+rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+ ; return (TypBr x t', fvs) }
-rn_bracket _ (DecBrL decls)
+rn_bracket _ (DecBrL x decls)
= do { group <- groupDecls decls
; gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
@@ -157,7 +159,7 @@ rn_bracket _ (DecBrL decls)
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env)))
- ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
+ ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
where
groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
groupDecls decls
@@ -171,10 +173,12 @@ rn_bracket _ (DecBrL decls)
}
}}
-rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG"
+rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
+
+rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
+ ; return (TExpBr x e', fvs) }
-rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e
- ; return (TExpBr e', fvs) }
+rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"
quotationCtxtDoc :: HsBracket GhcPs -> SDoc
quotationCtxtDoc br_body
@@ -292,10 +296,11 @@ runRnSplice flavour run_meta ppr_res splice
= do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
; let the_expr = case splice' of
- HsUntypedSplice _ _ e -> e
- HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
- HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
- HsSpliced {} -> pprPanic "runRnSplice" (ppr splice)
+ HsUntypedSplice _ _ _ e -> e
+ HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
+ HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
+ HsSpliced {} -> pprPanic "runRnSplice" (ppr splice)
+ XSplice {} -> pprPanic "runRnSplice" (ppr splice)
-- Typecheck the expression
; meta_exp_ty <- tcMetaTy meta_ty_name
@@ -333,14 +338,16 @@ runRnSplice flavour run_meta ppr_res splice
makePending :: UntypedSpliceFlavour
-> HsSplice GhcRn
-> PendingRnSplice
-makePending flavour (HsUntypedSplice _ n e)
+makePending flavour (HsUntypedSplice _ _ n e)
= PendingRnSplice flavour n e
-makePending flavour (HsQuasiQuote n quoter q_span quote)
+makePending flavour (HsQuasiQuote _ n quoter q_span quote)
= PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
makePending _ splice@(HsTypedSplice {})
= pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSpliced {})
= pprPanic "makePending" (ppr splice)
+makePending _ splice@(XSplice {})
+ = pprPanic "makePending" (ppr splice)
------------------
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
@@ -348,13 +355,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
-- Return the expression (quoter "...quote...")
-- which is what we must run in a quasi-quote
mkQuasiQuoteExpr flavour quoter q_span quote
- = L q_span $ HsApp (L q_span $
- HsApp (L q_span (HsVar (L q_span quote_selector)))
+ = L q_span $ HsApp noExt (L q_span $
+ HsApp noExt (L q_span (HsVar noExt (L q_span quote_selector)))
quoterExpr)
quoteExpr
where
- quoterExpr = L q_span $! HsVar $! (L q_span quoter)
- quoteExpr = L q_span $! HsLit $! HsString NoSourceText quote
+ quoterExpr = L q_span $! HsVar noExt $! (L q_span quoter)
+ quoteExpr = L q_span $! HsLit noExt $! HsString NoSourceText quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
UntypedPatSplice -> quotePatName
@@ -364,21 +371,21 @@ mkQuasiQuoteExpr flavour quoter q_span quote
---------------------
rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
-- Not exported...used for all
-rnSplice (HsTypedSplice hasParen splice_name expr)
+rnSplice (HsTypedSplice x hasParen splice_name expr)
= do { checkTH expr "Template Haskell typed splice"
; loc <- getSrcSpanM
; n' <- newLocalBndrRn (L loc splice_name)
; (expr', fvs) <- rnLExpr expr
- ; return (HsTypedSplice hasParen n' expr', fvs) }
+ ; return (HsTypedSplice x hasParen n' expr', fvs) }
-rnSplice (HsUntypedSplice hasParen splice_name expr)
+rnSplice (HsUntypedSplice x hasParen splice_name expr)
= do { checkTH expr "Template Haskell untyped splice"
; loc <- getSrcSpanM
; n' <- newLocalBndrRn (L loc splice_name)
; (expr', fvs) <- rnLExpr expr
- ; return (HsUntypedSplice hasParen n' expr', fvs) }
+ ; return (HsUntypedSplice x hasParen n' expr', fvs) }
-rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
+rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
= do { checkTH quoter "Template Haskell quasi-quote"
; loc <- getSrcSpanM
; splice_name' <- newLocalBndrRn (L loc splice_name)
@@ -389,9 +396,11 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
; when (nameIsLocalOrFrom this_mod quoter') $
checkThLocalName quoter'
- ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') }
+ ; return (HsQuasiQuote x splice_name' quoter' q_loc quote
+ , unitFV quoter') }
rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(XSplice {}) = pprPanic "rnSplice" (ppr splice)
---------------------
rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
@@ -400,7 +409,7 @@ rnSpliceExpr splice
where
pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
pend_expr_splice rn_splice
- = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice)
+ = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)
run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice rn_splice
@@ -413,7 +422,7 @@ rnSpliceExpr splice
, isLocalGRE gre]
lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
- ; return (HsSpliceE rn_splice, lcl_names `plusFV` gbl_names) }
+ ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }
| otherwise -- Run it here, see Note [Running splices in the Renamer]
= do { traceRn "rnSpliceExpr: untyped expression splice" empty
@@ -421,8 +430,8 @@ rnSpliceExpr splice
runRnSplice UntypedExpSplice runMetaE ppr rn_splice
; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
-- See Note [Delaying modFinalizers in untyped splices].
- ; return ( HsPar $ HsSpliceE
- . HsSpliced (ThModFinalizers mod_finalizers)
+ ; return ( HsPar noExt $ HsSpliceE noExt
+ . HsSpliced noExt (ThModFinalizers mod_finalizers)
. HsSplicedExpr <$>
lexpr3
, fvs)
@@ -519,13 +528,13 @@ References:
-}
----------------------
-rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind
- -> RnM (HsType GhcRn, FreeVars)
-rnSpliceType splice k
+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType splice
= rnSpliceGen run_type_splice pend_type_splice splice
where
pend_type_splice rn_splice
- = (makePending UntypedTypeSplice rn_splice, HsSpliceTy rn_splice k)
+ = ( makePending UntypedTypeSplice rn_splice
+ , HsSpliceTy noExt rn_splice)
run_type_splice rn_splice
= do { traceRn "rnSpliceType: untyped type splice" empty
@@ -535,8 +544,8 @@ rnSpliceType splice k
; checkNoErrs $ rnLHsType doc hs_ty2 }
-- checkNoErrs: see Note [Renamer errors]
-- See Note [Delaying modFinalizers in untyped splices].
- ; return ( HsParTy $ flip HsSpliceTy k
- . HsSpliced (ThModFinalizers mod_finalizers)
+ ; return ( HsParTy noExt $ HsSpliceTy noExt
+ . HsSpliced noExt (ThModFinalizers mod_finalizers)
. HsSplicedTy <$>
hs_ty3
, fvs
@@ -592,17 +601,18 @@ rnSplicePat splice
= rnSpliceGen run_pat_splice pend_pat_splice splice
where
pend_pat_splice rn_splice
- = (makePending UntypedPatSplice rn_splice, Right (SplicePat rn_splice))
+ = (makePending UntypedPatSplice rn_splice
+ , Right (SplicePat noExt rn_splice))
run_pat_splice rn_splice
= do { traceRn "rnSplicePat: untyped pattern splice" empty
; (pat, mod_finalizers) <-
runRnSplice UntypedPatSplice runMetaP ppr rn_splice
-- See Note [Delaying modFinalizers in untyped splices].
- ; return ( Left $ ParPat $ SplicePat
- . HsSpliced (ThModFinalizers mod_finalizers)
- . HsSplicedPat <$>
- pat
+ ; return ( Left $ ParPat noExt $ (SplicePat noExt)
+ . HsSpliced noExt (ThModFinalizers mod_finalizers)
+ . HsSplicedPat <$>
+ pat
, emptyFVs
) }
-- Wrap the result of the quasi-quoter in parens so that we don't
@@ -610,13 +620,15 @@ rnSplicePat splice
----------------------
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
-rnSpliceDecl (SpliceDecl (L loc splice) flg)
+rnSpliceDecl (SpliceDecl _ (L loc splice) flg)
= rnSpliceGen run_decl_splice pend_decl_splice splice
where
pend_decl_splice rn_splice
- = (makePending UntypedDeclSplice rn_splice, SpliceDecl (L loc rn_splice) flg)
+ = ( makePending UntypedDeclSplice rn_splice
+ , SpliceDecl noExt (L loc rn_splice) flg)
run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
+rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
-- Declaration splice at the very top level of the module
@@ -685,6 +697,7 @@ spliceCtxt splice
HsTypedSplice {} -> text "typed splice:"
HsQuasiQuote {} -> text "quasi-quotation:"
HsSpliced {} -> text "spliced expression:"
+ XSplice {} -> text "spliced expression:"
-- | The splice data to be logged
data SpliceInfo
diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot
index 875ba05e52..7844acd2c9 100644
--- a/compiler/rename/RnSplice.hs-boot
+++ b/compiler/rename/RnSplice.hs-boot
@@ -1,13 +1,12 @@
module RnSplice where
+import GhcPrelude
import HsSyn
import TcRnMonad
import NameSet
-import Kind
-rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind
- -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
, FreeVars )
rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 014d4850c8..a78caaf6ba 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -23,15 +23,20 @@ module RnTypes (
checkPrecMatch, checkSectionPrec,
-- Binding related stuff
- bindLHsTyVarBndr,
+ bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
- extractFilteredRdrTyVars,
- extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+ extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
+ extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
+ extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
extractRdrKindSigVars, extractDataDefnKindVars,
- freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars
+ extractHsTvBndrs,
+ freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
+ elemRdr
) where
+import GhcPrelude
+
import {-# SOURCE #-} RnSplice( rnSpliceType )
import DynFlags
@@ -40,21 +45,21 @@ import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import RnUnbound ( perhapsForallMsg )
import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn
- , pprHsDocContext, bindLocalNamesFV, dupNamesErr
- , newLocalBndrRn, checkShadowedRdrNames )
+ , pprHsDocContext, bindLocalNamesFV
+ , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
import RnFixity ( lookupFieldFixityRn, lookupFixityRn
, lookupTyFixityRn )
import TcRnMonad
import RdrName
import PrelNames
import TysPrim ( funTyConName )
-import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName )
import Name
import SrcLoc
import NameSet
import FieldLabel
import Util
+import ListSetOps ( deleteBys )
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..), LexicalFixity(..) )
import Outputable
@@ -62,8 +67,8 @@ import FastString
import Maybes
import qualified GHC.LanguageExtensions as LangExt
-import Data.List ( nubBy, partition )
-import Control.Monad ( unless, when )
+import Data.List ( nubBy, partition, (\\) )
+import Control.Monad ( unless, when )
#include "HsVersions.h"
@@ -81,7 +86,7 @@ to break several loop.
rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType doc sig_ty
- = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
+ = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
return (sig_ty', emptyFVs)
rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
@@ -95,38 +100,50 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
rnHsSigWcTypeScoped ctx sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
- ; rn_hs_sig_wc_type False ctx sig_ty thing_inside
+ ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
}
- -- False: for pattern type sigs and rules we /do/ want
- -- to bring those type variables into scope
+ -- True: for pattern type sigs and rules we /do/ want
+ -- to bring those type variables into scope, even
+ -- if there's a forall at the top which usually
+ -- stops that happening
-- e.g \ (x :: forall a. a-> b) -> e
-- Here we do bring 'b' into scope
-rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs
+rn_hs_sig_wc_type :: Bool -- True <=> always bind any free tyvars of the
+ -- type, regardless of whether it has
+ -- a forall at the top
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type no_implicit_if_forall ctxt
+rn_hs_sig_wc_type always_bind_free_tvs ctxt
(HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
thing_inside
- = do { free_vars <- extractFilteredRdrTyVars hs_ty
- ; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars
- ; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ vars ->
+ = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
+ ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
+ ; let nwc_rdrs = nubL nwc_rdrs'
+ bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
+ ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
- ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }
- ib_ty' = mk_implicit_bndrs vars hs_ty' fvs1
+ ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
+ ib_ty' = HsIB { hsib_ext = vars
+ , hsib_body = hs_ty' }
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
+ = panic "rn_hs_sig_wc_type"
+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
+ = panic "rn_hs_sig_wc_type"
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
= do { free_vars <- extractFilteredRdrTyVars hs_ty
; (_, nwc_rdrs) <- partition_nwcs free_vars
; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
- ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' }
+ ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
+rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"
rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
@@ -149,27 +166,29 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
-- A lot of faff just to allow the extra-constraints wildcard to appear
rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
- = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)
- Nothing [] tvs $ \ _ tvs' _ _ ->
+ = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
do { (hs_body', fvs) <- rn_lty env hs_body
- ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) }
+ ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs'
+ , hst_body = hs_body' }, fvs) }
rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })
| Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
- , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
+ , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; wc' <- setSrcSpan lx $
- do { checkExtraConstraintWildCard env wc
- ; rnAnonWildCard wc }
+ do { checkExtraConstraintWildCard env hs_ctxt1
+ ; rnAnonWildCard }
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
- ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+ ; return (HsQualTy { hst_xqual = noExt
+ , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
| otherwise
= do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
- ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+ ; return (HsQualTy { hst_xqual = noExt
+ , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
rn_ty env hs_ty = rnHsTyKi env hs_ty
@@ -177,26 +196,45 @@ rnWcBody ctxt nwc_rdrs hs_ty
rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
-checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs
- -> RnM ()
+checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
-- Rename the extra-constraint spot in a type signature
-- (blah, _) => type
-- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard
-checkExtraConstraintWildCard env wc
+checkExtraConstraintWildCard env hs_ctxt
= checkWildCard env mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
- = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
- <+> text "not allowed")
+ = Just base_msg
+ -- Currently, we do not allow wildcards in their full glory in
+ -- standalone deriving declarations. We only allow a single
+ -- extra-constraints wildcard à la:
+ --
+ -- deriving instance _ => Eq (Foo a)
+ --
+ -- i.e., we don't support things like
+ --
+ -- deriving instance (Eq a, _) => Eq (Foo a)
+ | DerivDeclCtx {} <- rtke_ctxt env
+ , not (null hs_ctxt)
+ = Just deriv_decl_msg
| otherwise
= Nothing
+ base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
+ <+> text "not allowed"
+
+ deriv_decl_msg
+ = hang base_msg
+ 2 (vcat [ text "except as the sole constraint"
+ , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
+
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True
+ DerivDeclCtx {} -> True
_ -> False
-- | Finds free type and kind variables in a type,
@@ -204,11 +242,21 @@ extraConstraintWildCardsAllowed env
-- without variables that are already in scope in LocalRdrEnv
-- NB: this includes named wildcards, which look like perfectly
-- ordinary type variables at this point
-extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars
+extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
extractFilteredRdrTyVars hs_ty
= do { rdr_env <- getLocalRdrEnv
; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }
+-- | Finds free type and kind variables in a type,
+-- with duplicates, but
+-- without variables that are already in scope in LocalRdrEnv
+-- NB: this includes named wildcards, which look like perfectly
+-- ordinary type variables at this point
+extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
+extractFilteredRdrTyVarsDups hs_ty
+ = do { rdr_env <- getLocalRdrEnv
+ ; filterInScope rdr_env <$> extractHsTyRdrTyVarsDups hs_ty }
+
-- | When the NamedWildCards extension is enabled, partition_nwcs
-- removes type variables that start with an underscore from the
-- FreeKiTyVars in the argument and returns them in a separate list.
@@ -249,62 +297,78 @@ rnHsSigType :: HsDocContext -> LHsSigType GhcPs
-- Used for source-language type signatures
-- that cannot have wildcards
rnHsSigType ctx (HsIB { hsib_body = hs_ty })
- = do { vars <- extractFilteredRdrTyVars hs_ty
- ; rnImplicitBndrs True vars hs_ty $ \ vars ->
+ = do { traceRn "rnHsSigType" (ppr hs_ty)
+ ; vars <- extractFilteredRdrTyVarsDups hs_ty
+ ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
do { (body', fvs) <- rnLHsType ctx hs_ty
- ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
+ ; return ( HsIB { hsib_ext = vars
+ , hsib_body = body' }
+ , fvs ) } }
+rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
-rnImplicitBndrs :: Bool -- True <=> no implicit quantification
- -- if type is headed by a forall
+rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables
-- E.g. f :: forall a. a->b
- -- Do not quantify over 'b' too.
- -> FreeKiTyVars
- -> LHsType GhcPs
+ -- we do not want to bring 'b' into scope, hence False
+ -- But f :: a -> b
+ -- we want to bring both 'a' and 'b' into scope
+ -> FreeKiTyVarsWithDups
+ -- Free vars of hs_ty (excluding wildcards)
+ -- May have duplicates, which is
+ -- checked here
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside
- = do { let real_tv_rdrs -- Implicit quantification only if
- -- there is no explicit forall
- | no_implicit_if_forall
- , L _ (HsForAllTy {}) <- hs_ty = []
- | otherwise = freeKiTyVarsTypeVars free_vars
- real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs
- ; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$
- ppr real_rdrs)
-
- ; traceRn "" (text "rnSigType2" <+> ppr hs_ty $$ ppr free_vars $$
- ppr real_rdrs)
- ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs
+rnImplicitBndrs bind_free_tvs
+ fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
+ , fktv_tys = tvs_with_dups })
+ thing_inside
+ = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
+ real_tvs | bind_free_tvs = tvs
+ | otherwise = []
+ -- We always bind over free /kind/ variables.
+ -- Bind free /type/ variables only if there is no
+ -- explicit forall. E.g.
+ -- f :: Proxy (a :: k) -> b
+ -- Quantify over {k} and {a,b}
+ -- g :: forall a. Proxy (a :: k) -> b
+ -- Quantify over {k} and {}
+ -- Note that we always do the implicit kind-quantification
+ -- but, rather arbitrarily, we switch off the type-quantification
+ -- if there is an explicit forall
+
+ ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
+
+ ; whenWOptM Opt_WarnImplicitKindVars $
+ unless (bind_free_tvs || null kvs) $
+ addWarnAt (Reason Opt_WarnImplicitKindVars) (getLoc (head kvs)) $
+ implicit_kind_vars_msg kvs
+
+ ; loc <- getSrcSpanM
+ -- NB: kinds before tvs, as mandated by
+ -- Note [Ordering of implicit variables]
+ ; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs)
+
+ ; traceRn "checkMixedVars2" $
+ vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups
+ , text "tvs_with_dups" <+> ppr tvs_with_dups ]
+
; bindLocalNamesFV vars $
thing_inside vars }
+ where
+ implicit_kind_vars_msg kvs =
+ vcat [ text "An explicit" <+> quotes (text "forall") <+>
+ text "was used, but the following kind variables" <+>
+ text "are not quantified:" <+>
+ hsep (punctuate comma (map (quotes . ppr) kvs))
+ , text "Despite this fact, GHC will introduce them into scope," <+>
+ text "but it will stop doing so in the future."
+ , text "Suggested fix: add" <+>
+ quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]
rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
--- Rename the type in an instance or standalone deriving decl
--- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
-rnLHsInstType doc_str inst_ty
- | Just cls <- getLHsInstDeclClass_maybe inst_ty
- , isTcOcc (rdrNameOcc (unLoc cls))
- -- The guards check that the instance type looks like
- -- blah => C ty1 .. tyn
- = do { let full_doc = doc_str <+> text "for" <+> quotes (ppr cls)
- ; rnHsSigType (GenericCtx full_doc) inst_ty }
-
- | otherwise -- The instance is malformed, but we'd still like
- -- to make progress rather than failing outright, so
- -- we report more errors. So we rename it anyway.
- = do { addErrAt (getLoc (hsSigType inst_ty)) $
- text "Malformed instance:" <+> ppr inst_ty
- ; rnHsSigType (GenericCtx doc_str) inst_ty }
-
-mk_implicit_bndrs :: [Name] -- implicitly bound
- -> a -- payload
- -> FreeVars -- FreeVars of payload
- -> HsImplicitBndrs GhcRn a
-mk_implicit_bndrs vars body fvs
- = HsIB { hsib_vars = vars
- , hsib_body = body
- , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
-
+-- Rename the type in an instance.
+-- The 'doc_str' is "an instance declaration".
+-- Do not try to decompose the inst_ty in case it is malformed
+rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
{- ******************************************************
* *
@@ -335,35 +399,6 @@ f :: forall a. a -> (() => b) binds "a" and "b"
This situation is now considered to be an error. See rnHsTyKi for case
HsForAllTy Qualified.
-Note [Dealing with *]
-~~~~~~~~~~~~~~~~~~~~~
-As a legacy from the days when types and kinds were different, we use
-the type * to mean what we now call GHC.Types.Type. The problem is that
-* should associate just like an identifier, *not* a symbol.
-Running example: the user has written
-
- T (Int, Bool) b + c * d
-
-At this point, we have a bunch of stretches of types
-
- [[T, (Int, Bool), b], [c], [d]]
-
-these are the [[LHsType Name]] and a bunch of operators
-
- [GHC.TypeLits.+, GHC.Types.*]
-
-Note that the * is GHC.Types.*. So, we want to rearrange to have
-
- [[T, (Int, Bool), b], [c, *, d]]
-
-and
-
- [GHC.TypeLits.+]
-
-as our lists. We can then do normal fixity resolution on these. The fixities
-must come along for the ride just so that the list stays in sync with the
-operators.
-
Note [QualTy in kinds]
~~~~~~~~~~~~~~~~~~~~~~
I was wondering whether QualTy could occur only at TypeLevel. But no,
@@ -465,47 +500,56 @@ rnLHsTyKi env (L loc ty)
rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau })
- = do { checkTypeInType env ty
+ = do { checkPolyKinds env ty
; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
- Nothing [] tyvars $ \ _ tyvars' _ _ ->
+ Nothing tyvars $ \ tyvars' ->
do { (tau', fvs) <- rnLHsTyKi env tau
- ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' }
+ ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars'
+ , hst_body = tau' }
, fvs) } }
rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
- = do { checkTypeInType env ty -- See Note [QualTy in kinds]
+ = do { checkPolyKinds env ty -- See Note [QualTy in kinds]
; (ctxt', fvs1) <- rnTyKiContext env lctxt
; (tau', fvs2) <- rnLHsTyKi env tau
- ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' }
+ ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+ , hst_body = tau' }
, fvs1 `plusFV` fvs2) }
-rnHsTyKi env (HsTyVar ip (L loc rdr_name))
- = do { name <- rnTyVar env rdr_name
- ; return (HsTyVar ip (L loc name), unitFV name) }
-
-rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
+rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
+ = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
+ unlessXOptM LangExt.PolyKinds $ addErr $
+ withHsDocContext (rtke_ctxt env) $
+ vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
+ , text "Perhaps you intended to use PolyKinds" ]
+ -- Any type variable at the kind level is illegal without the use
+ -- of PolyKinds (see #14710)
+ ; name <- rnTyVar env rdr_name
+ ; return (HsTyVar noExt ip (L loc name), unitFV name) }
+
+rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
= setSrcSpan (getLoc l_op) $
do { (l_op', fvs1) <- rnHsTyOp env ty l_op
; fix <- lookupTyFixityRn l_op'
; (ty1', fvs2) <- rnLHsTyKi env ty1
; (ty2', fvs3) <- rnLHsTyKi env ty2
- ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2)
+ ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)
(unLoc l_op') fix ty1' ty2'
; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
-rnHsTyKi env (HsParTy ty)
+rnHsTyKi env (HsParTy _ ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsParTy ty', fvs) }
+ ; return (HsParTy noExt ty', fvs) }
-rnHsTyKi env (HsBangTy b ty)
+rnHsTyKi env (HsBangTy _ b ty)
= do { (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsBangTy b ty', fvs) }
+ ; return (HsBangTy noExt b ty', fvs) }
-rnHsTyKi env ty@(HsRecTy flds)
+rnHsTyKi env ty@(HsRecTy _ flds)
= do { let ctxt = rtke_ctxt env
; fls <- get_fields ctxt
; (flds', fvs) <- rnConDeclFields ctxt fls flds
- ; return (HsRecTy flds', fvs) }
+ ; return (HsRecTy noExt flds', fvs) }
where
get_fields (ConDeclCtx names)
= concatMapM (lookupConstructorFields . unLoc) names
@@ -514,7 +558,7 @@ rnHsTyKi env ty@(HsRecTy flds)
2 (ppr ty))
; return [] }
-rnHsTyKi env (HsFunTy ty1 ty2)
+rnHsTyKi env (HsFunTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
-- Might find a for-all as the arg of a function type
; (ty2', fvs2) <- rnLHsTyKi env ty2
@@ -522,160 +566,95 @@ rnHsTyKi env (HsFunTy ty1 ty2)
-- when we find return :: forall m. Monad m -> forall a. a -> m a
-- Check for fixity rearrangements
- ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
+ ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'
; return (res_ty, fvs1 `plusFV` fvs2) }
-rnHsTyKi env listTy@(HsListTy ty)
+rnHsTyKi env listTy@(HsListTy _ ty)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env listTy))
; (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsListTy ty', fvs) }
+ ; return (HsListTy noExt ty', fvs) }
-rnHsTyKi env t@(HsKindSig ty k)
- = do { checkTypeInType env t
+rnHsTyKi env t@(HsKindSig _ ty k)
+ = do { checkPolyKinds env t
; kind_sigs_ok <- xoptM LangExt.KindSignatures
; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
- ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
-
-rnHsTyKi env t@(HsPArrTy ty)
- = do { notInKinds env t
- ; (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsPArrTy ty', fvs) }
+ ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsTyKi env tupleTy@(HsTupleTy tup_con tys)
+rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env tupleTy))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsTupleTy tup_con tys', fvs) }
+ ; return (HsTupleTy noExt tup_con tys', fvs) }
-rnHsTyKi env sumTy@(HsSumTy tys)
+rnHsTyKi env sumTy@(HsSumTy _ tys)
= do { data_kinds <- xoptM LangExt.DataKinds
; when (not data_kinds && isRnKindLevel env)
(addErr (dataKindsErr env sumTy))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsSumTy tys', fvs) }
+ ; return (HsSumTy noExt tys', fvs) }
-- Ensure that a type-level integer is nonnegative (#8306, #8412)
-rnHsTyKi env tyLit@(HsTyLit t)
+rnHsTyKi env tyLit@(HsTyLit _ t)
= do { data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env tyLit))
; when (negLit t) (addErr negLitErr)
- ; checkTypeInType env tyLit
- ; return (HsTyLit t, emptyFVs) }
+ ; checkPolyKinds env tyLit
+ ; return (HsTyLit noExt t, emptyFVs) }
where
negLit (HsStrTy _ _) = False
negLit (HsNumTy _ i) = i < 0
negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
-rnHsTyKi env overall_ty@(HsAppsTy tys)
- = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions
- let (non_syms, syms) = splitHsAppsTy tys
-
- -- Step 2: rename the pieces
- ; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty) syms
- ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms
-
- -- Step 3: deal with *. See Note [Dealing with *]
- ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1
-
- -- Step 4: collapse the non-symbol regions with HsAppTy
- ; non_syms3 <- mapM deal_with_non_syms non_syms2
-
- -- Step 5: assemble the pieces, using mkHsOpTyRn
- ; L _ res_ty <- build_res_ty non_syms3 syms2
-
- -- all done. Phew.
- ; return (res_ty, fvs1 `plusFV` fvs2) }
- where
- -- See Note [Dealing with *]
- deal_with_star :: [[LHsType GhcRn]] -> [Located Name]
- -> [[LHsType GhcRn]] -> [Located Name]
- -> ([[LHsType GhcRn]], [Located Name])
- deal_with_star acc1 acc2
- (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
- | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
- = deal_with_star acc1 acc2
- ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star))
- : non_syms2) : non_syms)
- ops
- deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
- = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
- deal_with_star acc1 acc2 [non_syms] []
- = (reverse (non_syms : acc1), reverse acc2)
- deal_with_star _ _ _ _
- = pprPanic "deal_with_star" (ppr overall_ty)
-
- -- collapse [LHsType GhcRn] to LHsType GhcRn by making applications
- -- monadic only for failure
- deal_with_non_syms :: [LHsType GhcRn] -> RnM (LHsType GhcRn)
- deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms
- deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty)
-
- -- assemble a right-biased OpTy for use in mkHsOpTyRn
- build_res_ty :: [LHsType GhcRn] -> [Located Name] -> RnM (LHsType GhcRn)
- build_res_ty (arg1 : args) (op1 : ops)
- = do { rhs <- build_res_ty args ops
- ; fix <- lookupTyFixityRn op1
- ; res <-
- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs
- ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)
- ; return (L loc res)
- }
- build_res_ty [arg] [] = return arg
- build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)
-
-rnHsTyKi env (HsAppTy ty1 ty2)
+rnHsTyKi env (HsAppTy _ ty1 ty2)
= do { (ty1', fvs1) <- rnLHsTyKi env ty1
; (ty2', fvs2) <- rnLHsTyKi env ty2
- ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
+ ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
-rnHsTyKi env t@(HsIParamTy n ty)
+rnHsTyKi env t@(HsIParamTy _ n ty)
= do { notInKinds env t
; (ty', fvs) <- rnLHsTyKi env ty
- ; return (HsIParamTy n ty', fvs) }
+ ; return (HsIParamTy noExt n ty', fvs) }
-rnHsTyKi env t@(HsEqTy ty1 ty2)
- = do { checkTypeInType env t
- ; (ty1', fvs1) <- rnLHsTyKi env ty1
- ; (ty2', fvs2) <- rnLHsTyKi env ty2
- ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
+rnHsTyKi _ (HsStarTy _ isUni)
+ = return (HsStarTy noExt isUni, emptyFVs)
-rnHsTyKi _ (HsSpliceTy sp k)
- = rnSpliceType sp k
+rnHsTyKi _ (HsSpliceTy _ sp)
+ = rnSpliceType sp
-rnHsTyKi env (HsDocTy ty haddock_doc)
+rnHsTyKi env (HsDocTy _ ty haddock_doc)
= do { (ty', fvs) <- rnLHsTyKi env ty
; haddock_doc' <- rnLHsDoc haddock_doc
- ; return (HsDocTy ty' haddock_doc', fvs) }
+ ; return (HsDocTy noExt ty' haddock_doc', fvs) }
-rnHsTyKi _ (HsCoreTy ty)
- = return (HsCoreTy ty, emptyFVs)
+rnHsTyKi _ (XHsType (NHsCoreTy ty))
+ = return (XHsType (NHsCoreTy ty), emptyFVs)
-- The emptyFVs probably isn't quite right
-- but I don't think it matters
-rnHsTyKi env ty@(HsExplicitListTy ip k tys)
- = do { checkTypeInType env ty
+rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
+ = do { checkPolyKinds env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsExplicitListTy ip k tys', fvs) }
+ ; return (HsExplicitListTy noExt ip tys', fvs) }
-rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
- = do { checkTypeInType env ty
+rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
+ = do { checkPolyKinds env ty
; data_kinds <- xoptM LangExt.DataKinds
; unless data_kinds (addErr (dataKindsErr env ty))
; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
- ; return (HsExplicitTupleTy kis tys', fvs) }
+ ; return (HsExplicitTupleTy noExt tys', fvs) }
-rnHsTyKi env (HsWildCardTy wc)
- = do { checkAnonWildCard env wc
- ; wc' <- rnAnonWildCard wc
+rnHsTyKi env (HsWildCardTy _)
+ = do { checkAnonWildCard env
+ ; wc' <- rnAnonWildCard
; return (HsWildCardTy wc', emptyFVs) }
-- emptyFVs: this occurrence does not refer to a
-- user-written binding site, so don't treat
@@ -684,9 +663,7 @@ rnHsTyKi env (HsWildCardTy wc)
--------------
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar env rdr_name
- = do { name <- if isRnKindLevel env
- then lookupKindOccRn rdr_name
- else lookupTypeOccRn rdr_name
+ = do { name <- lookupTypeOccRn rdr_name
; checkNamedWildCard env name
; return name }
@@ -703,10 +680,7 @@ rnHsTyOp :: Outputable a
rnHsTyOp env overall_ty (L loc op)
= do { ops_ok <- xoptM LangExt.TypeOperators
; op' <- rnTyVar env op
- ; unless (ops_ok
- || op' == starKindTyConName
- || op' == unicodeStarKindTyConName
- || op' `hasKey` eqTyConKey) $
+ ; unless (ops_ok || op' `hasKey` eqTyConKey) $
addErr (opTyErr op overall_ty)
; let l_op' = L loc op'
; return (l_op', unitFV op') }
@@ -722,21 +696,22 @@ checkWildCard env (Just doc)
checkWildCard _ Nothing
= return ()
-checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM ()
+checkAnonWildCard :: RnTyKiEnv -> RnM ()
-- Report an error if an anonymous wildcard is illegal here
-checkAnonWildCard env wc
+checkAnonWildCard env
= checkWildCard env mb_bad
where
mb_bad :: Maybe SDoc
mb_bad | not (wildCardsAllowed env)
- = Just (notAllowed (ppr wc))
+ = Just (notAllowed pprAnonWildCard)
| otherwise
= case rtke_what env of
RnTypeBody -> Nothing
RnConstraint -> Just constraint_msg
RnTopConstraint -> Just constraint_msg
- constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint")
+ constraint_msg = hang
+ (notAllowed pprAnonWildCard <+> text "in a constraint")
2 hint_msg
hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
, nest 2 (text "e.g f :: (Eq a, _) => blah") ]
@@ -772,26 +747,26 @@ wildCardsAllowed env
HsTypeCtx {} -> True
_ -> False
-rnAnonWildCard :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn)
-rnAnonWildCard (AnonWildCard _)
+rnAnonWildCard :: RnM HsWildCardInfo
+rnAnonWildCard
= do { loc <- getSrcSpanM
; uniq <- newUnique
; let name = mkInternalName uniq (mkTyVarOcc "_") loc
; return (AnonWildCard (L loc name)) }
---------------
--- | Ensures either that we're in a type or that -XTypeInType is set
-checkTypeInType :: Outputable ty
+-- | Ensures either that we're in a type or that -XPolyKinds is set
+checkPolyKinds :: Outputable ty
=> RnTyKiEnv
-> ty -- ^ type
-> RnM ()
-checkTypeInType env ty
+checkPolyKinds env ty
| isRnKindLevel env
- = do { type_in_type <- xoptM LangExt.TypeInType
- ; unless type_in_type $
+ = do { polykinds <- xoptM LangExt.PolyKinds
+ ; unless polykinds $
addErr (text "Illegal kind:" <+> ppr ty $$
- text "Did you mean to enable TypeInType?") }
-checkTypeInType _ _ = return ()
+ text "Did you mean to enable PolyKinds?") }
+checkPolyKinds _ _ = return ()
notInKinds :: Outputable ty
=> RnTyKiEnv
@@ -799,7 +774,7 @@ notInKinds :: Outputable ty
-> RnM ()
notInKinds env ty
| isRnKindLevel env
- = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)
+ = addErr (text "Illegal kind:" <+> ppr ty)
notInKinds _ _ = return ()
{- *****************************************************
@@ -835,87 +810,199 @@ bindLRdrNames rdrs thing_inside
---------------
bindHsQTyVars :: forall a b.
HsDocContext
- -> Maybe SDoc -- if we are to check for unused tvs,
- -- a phrase like "in the type ..."
- -> Maybe a -- Just _ => an associated type decl
- -> [Located RdrName] -- Kind variables from scope, in l-to-r
- -- order, but not from ...
- -> (LHsQTyVars GhcPs) -- ... these user-written tyvars
- -> (LHsQTyVars GhcRn -> NameSet -> RnM (b, FreeVars))
- -- also returns all names used in kind signatures, for the
- -- TypeInType clause of Note [Complete user-supplied kind
- -- signatures] in HsDecls
+ -> Maybe SDoc -- Just d => check for unused tvs
+ -- d is a phrase like "in the type ..."
+ -> Maybe a -- Just _ => an associated type decl
+ -> [Located RdrName] -- Kind variables from scope, no dups
+ -> (LHsQTyVars GhcPs)
+ -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
+ -- The Bool is True <=> all kind variables used in the
+ -- kind signature are bound on the left. Reason:
+ -- the TypeInType clause of Note [Complete user-supplied
+ -- kind signatures] in HsDecls
-> RnM (b, FreeVars)
+
+-- See Note [bindHsQTyVars examples]
-- (a) Bring kind variables into scope
--- both (i) passed in (kv_bndrs)
--- and (ii) mentioned in the kinds of tv_bndrs
+-- both (i) passed in body_kv_occs
+-- and (ii) mentioned in the kinds of hsq_bndrs
-- (b) Bring type variables into scope
-bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
- = do { bindLHsTyVarBndrs doc mb_in_doc
- mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
- \ rn_kvs rn_bndrs dep_var_set all_dep_vars ->
- thing_inside (HsQTvs { hsq_implicit = rn_kvs
- , hsq_explicit = rn_bndrs
- , hsq_dependent = dep_var_set }) all_dep_vars }
-
-bindLHsTyVarBndrs :: forall a b.
- HsDocContext
- -> Maybe SDoc -- if we are to check for unused tvs,
- -- a phrase like "in the type ..."
- -> Maybe a -- Just _ => an associated type decl
- -> [Located RdrName] -- Unbound kind variables from scope,
- -- in l-to-r order, but not from ...
- -> [LHsTyVarBndr GhcPs] -- ... these user-written tyvars
- -> ( [Name] -- all kv names
- -> [LHsTyVarBndr GhcRn]
- -> NameSet -- which names, from the preceding list,
- -- are used dependently within that list
- -- See Note [Dependent LHsQTyVars] in TcHsType
- -> NameSet -- all names used in kind signatures
- -> RnM (b, FreeVars))
+--
+bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
+ = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
+ ; bndr_kv_occs <- extractHsTyVarBndrsKVs hs_tv_bndrs
+ ; rdr_env <- getLocalRdrEnv
+
+ ; let -- See Note [bindHsQTyVars examples] for what
+ -- all these various things are doing
+ bndrs, kv_occs, implicit_kvs :: [Located RdrName]
+ bndrs = map hsLTyVarLocName hs_tv_bndrs
+ kv_occs = nubL (bndr_kv_occs ++ body_kv_occs)
+ -- Make sure to list the binder kvs before the
+ -- body kvs, as mandated by
+ -- Note [Ordering of implicit variables]
+ implicit_kvs = filter_occs rdr_env bndrs kv_occs
+ -- Deleting bndrs: See Note [Kind-variable ordering]
+ -- dep_bndrs is the subset of bndrs that are dependent
+ -- i.e. appear in bndr/body_kv_occs
+ -- Can't use implicit_kvs because we've deleted bndrs from that!
+ dep_bndrs = filter (`elemRdr` kv_occs) bndrs
+ del = deleteBys eqLocated
+ all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
+
+ ; traceRn "checkMixedVars3" $
+ vcat [ text "kv_occs" <+> ppr kv_occs
+ , text "bndrs" <+> ppr hs_tv_bndrs
+ , text "bndr_kv_occs" <+> ppr bndr_kv_occs
+ , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
+ ]
+
+ ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
+
+ ; bindLocalNamesFV implicit_kv_nms $
+ bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
+ do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
+ ; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs
+ ; thing_inside (HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = implicit_kv_nms
+ , hsq_dependent = mkNameSet dep_bndr_nms }
+ , hsq_explicit = rn_bndrs })
+ all_bound_on_lhs } }
+
+ where
+ filter_occs :: LocalRdrEnv -- In scope
+ -> [Located RdrName] -- Bound here
+ -> [Located RdrName] -- Potential implicit binders
+ -> [Located RdrName] -- Final implicit binders
+ -- Filter out any potential implicit binders that are either
+ -- already in scope, or are explicitly bound here
+ filter_occs rdr_env bndrs occs
+ = filterOut is_in_scope occs
+ where
+ is_in_scope locc@(L _ occ) = isJust (lookupLocalRdrEnv rdr_env occ)
+ || locc `elemRdr` bndrs
+
+{- Note [bindHsQTyVars examples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ data T k (a::k1) (b::k) :: k2 -> k1 -> *
+
+Then:
+ hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
+ bndrs = [k,a,b]
+
+ bndr_kv_occs = [k,k1], kind variables free in kind signatures
+ of hs_tv_bndrs
+
+ body_kv_occs = [k2,k1], kind variables free in the
+ result kind signature
+
+ implicit_kvs = [k1,k2], kind variables free in kind signatures
+ of hs_tv_bndrs, and not bound by bndrs
+
+* We want to quantify add implicit bindings for implicit_kvs
+
+* The "dependent" bndrs (hsq_dependent) are the subset of
+ bndrs that are free in bndr_kv_occs or body_kv_occs
+
+* If implicit_body_kvs is non-empty, then there is a kind variable
+ mentioned in the kind signature that is not bound "on the left".
+ That's one of the rules for a CUSK, so we pass that info on
+ as the second argument to thing_inside.
+
+* Order is not important in these lists. All we are doing is
+ bring Names into scope.
+
+Finally, you may wonder why filter_occs removes in-scope variables
+from bndr/body_kv_occs. How can anything be in scope? Answer:
+HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
+ConDecls
+ data T a = forall (b::k). MkT a b
+The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
+ConDecl. Hence the local RdrEnv may be non-empty and we must filter
+out 'a' from the free vars. (Mind you, in this situation all the
+implicit kind variables are bound at the data type level, so there
+are none to bind in the ConDecl, so there are no implicitly bound
+variables at all.
+
+Note [Kind variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+ data T (a :: k) k = ...
+we report "k is out of scope" for (a::k). Reason: k is not brought
+into scope until the explicit k-binding that follows. It would be
+terribly confusing to bring into scope an /implicit/ k for a's kind
+and a distinct, shadowing explicit k that follows, something like
+ data T {k1} (a :: k1) k = ...
+
+So the rule is:
+
+ the implicit binders never include any
+ of the explicit binders in the group
+
+Note that in the denerate case
+ data T (a :: a) = blah
+we get a complaint the second 'a' is not in scope.
+
+That applies to foralls too: e.g.
+ forall (a :: k) k . blah
+
+But if the foralls are split, we treat the two groups separately:
+ forall (a :: k). forall k. blah
+Here we bring into scope an implicit k, which is later shadowed
+by the explicit k.
+
+In implementation terms
+
+* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
+ the binders {a,k}, and so end with no implicit binders. Then we
+ rename the binders left-to-right, and hence see that 'k' is out of
+ scope in the kind of 'a'.
+
+* Similarly in extract_hs_tv_bndrs
+
+Note [Variables used as both types and kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We bind the type variables tvs, and kvs is the set of free variables of the
+kinds in the scope of the binding. Here is one typical example:
+
+ forall a b. a -> (b::k) -> (c::a)
+
+Here, tvs will be {a,b}, and kvs {k,a}.
+
+We must make sure that kvs includes all of variables in the kinds of type
+variable bindings. For instance:
+
+ forall k (a :: k). Proxy a
+
+If we only look in the body of the `forall` type, we will mistakenly conclude
+that kvs is {}. But in fact, the type variable `k` is also used as a kind
+variable in (a :: k), later in the binding. (This mistake lead to #14710.)
+So tvs is {k,a} and kvs is {k}.
+
+NB: we do this only at the binding site of 'tvs'.
+-}
+
+bindLHsTyVarBndrs :: HsDocContext
+ -> Maybe SDoc -- Just d => check for unused tvs
+ -- d is a phrase like "in the type ..."
+ -> Maybe a -- Just _ => an associated type decl
+ -> [LHsTyVarBndr GhcPs] -- User-written tyvars
+ -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
-bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
+bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
= do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
- ; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs }
+ ; checkDupRdrNames tv_names_w_loc
+ ; go tv_bndrs thing_inside }
where
tv_names_w_loc = map hsLTyVarLocName tv_bndrs
- go :: [Name] -- kind-vars found (in reverse order)
- -> [LHsTyVarBndr GhcRn] -- already renamed (in reverse order)
- -> NameSet -- kind vars already in scope (for dup checking)
- -> NameSet -- type vars already in scope (for dup checking)
- -> NameSet -- (all) variables used dependently
- -> [LHsTyVarBndr GhcPs] -- still to be renamed, scoped
- -> RnM (b, FreeVars)
- go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs)
- = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
- \ kv_nms used_dependently tv_bndr' ->
- do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs)
- (tv_bndr' : rn_tvs)
- (kv_names `extendNameSetList` kv_nms)
- (tv_names `extendNameSet` hsLTyVarName tv_bndr')
- (dep_vars `unionNameSet` used_dependently)
- tv_bndrs
- ; warn_unused tv_bndr' fvs
- ; return (b, fvs) }
-
- go rn_kvs rn_tvs _kv_names tv_names dep_vars []
- = -- still need to deal with the kv_bndrs passed in originally
- bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others ->
- do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
- all_rn_tvs = reverse rn_tvs
- ; env <- getLocalRdrEnv
- ; let all_dep_vars = dep_vars `unionNameSet` others
- exp_dep_vars -- variables in all_rn_tvs that are in dep_vars
- = mkNameSet [ name
- | v <- all_rn_tvs
- , let name = hsLTyVarName v
- , name `elemNameSet` all_dep_vars ]
- ; traceRn "bindHsTyVars" (ppr env $$
- ppr all_rn_kvs $$
- ppr all_rn_tvs $$
- ppr exp_dep_vars)
- ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
+ go [] thing_inside = thing_inside []
+ go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
+ do { (res, fvs) <- go bs $ \ bs' ->
+ thing_inside (b' : bs')
+ ; warn_unused b' fvs
+ ; return (res, fvs) }
warn_unused tv_bndr fvs = case mb_in_doc of
Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
@@ -923,113 +1010,25 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
bindLHsTyVarBndr :: HsDocContext
-> Maybe a -- associated class
- -> NameSet -- kind vars already in scope
- -> NameSet -- type vars already in scope
-> LHsTyVarBndr GhcPs
- -> ([Name] -> NameSet -> LHsTyVarBndr GhcRn
- -> RnM (b, FreeVars))
- -- passed the newly-bound implicitly-declared kind vars,
- -- any other names used in a kind
- -- and the renamed LHsTyVarBndr
+ -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
-bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
- = case hs_tv_bndr of
- L loc (UserTyVar lrdr@(L lv rdr)) ->
- do { check_dup loc rdr []
- ; nm <- newTyVarNameRn mb_assoc lrdr
- ; bindLocalNamesFV [nm] $
- thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }
- L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
- do { free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
- ; check_dup lv rdr (map unLoc free_kvs)
-
- -- check for -XKindSignatures
- ; sig_ok <- xoptM LangExt.KindSignatures
+bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x lrdr@(L lv _))) thing_inside
+ = do { nm <- newTyVarNameRn mb_assoc lrdr
+ ; bindLocalNamesFV [nm] $
+ thing_inside (L loc (UserTyVar x (L lv nm))) }
+
+bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))
+ thing_inside
+ = do { sig_ok <- xoptM LangExt.KindSignatures
; unless sig_ok (badKindSigErr doc kind)
+ ; (kind', fvs1) <- rnLHsKind doc kind
+ ; tv_nm <- newTyVarNameRn mb_assoc lrdr
+ ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
+ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))
+ ; return (b, fvs1 `plusFV` fvs2) }
- -- deal with kind vars in the user-written kind
- ; bindImplicitKvs doc mb_assoc free_kvs tv_names $
- \ new_kv_nms other_kv_nms ->
- do { (kind', fvs1) <- rnLHsKind doc kind
- ; tv_nm <- newTyVarNameRn mb_assoc lrdr
- ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
- thing_inside new_kv_nms other_kv_nms
- (L loc (KindedTyVar (L lv tv_nm) kind'))
- ; return (b, fvs1 `plusFV` fvs2) }}
- where
- -- make sure that the RdrName isn't in the sets of
- -- names. We can't just check that it's not in scope at all
- -- because we might be inside an associated class.
- check_dup :: SrcSpan -> RdrName -> [RdrName] -> RnM ()
- check_dup loc rdr kindFreeVars
- = do { -- Disallow use of a type variable name in its
- -- kind signature (#11592).
- when (rdr `elem` kindFreeVars) $
- addErrAt loc (vcat [ ki_ty_self_err rdr
- , pprHsDocContext doc ])
-
- ; m_name <- lookupLocalOccRn_maybe rdr
- ; whenIsJust m_name $ \name ->
- do { when (name `elemNameSet` kv_names) $
- addErrAt loc (vcat [ ki_ty_err_msg name
- , pprHsDocContext doc ])
- ; when (name `elemNameSet` tv_names) $
- dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}
-
- ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>
- text "used as a kind variable before being bound" $$
- text "as a type variable. Perhaps reorder your variables?"
-
- ki_ty_self_err n = text "Variable" <+> quotes (ppr n) <+>
- text "is used in the kind signature of its" $$
- text "declaration as a type variable."
-
-
-bindImplicitKvs :: HsDocContext
- -> Maybe a
- -> [Located RdrName] -- ^ kind var *occurrences*, from which
- -- intent to bind is inferred
- -> NameSet -- ^ *type* variables, for type/kind
- -- misuse check for -XNoTypeInType
- -> ([Name] -> NameSet -> RnM (b, FreeVars))
- -- ^ passed new kv_names, and any other names used in a kind
- -> RnM (b, FreeVars)
-bindImplicitKvs _ _ [] _ thing_inside
- = thing_inside [] emptyNameSet
-bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
- = do { rdr_env <- getLocalRdrEnv
- ; let part_kvs lrdr@(L loc kv_rdr)
- = case lookupLocalRdrEnv rdr_env kv_rdr of
- Just kv_name -> Left (L loc kv_name)
- _ -> Right lrdr
- (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs
-
- -- check whether we're mixing types & kinds illegally
- ; type_in_type <- xoptM LangExt.TypeInType
- ; unless type_in_type $
- mapM_ (check_tv_used_in_kind tv_names) bound_kvs
-
- ; poly_kinds <- xoptM LangExt.PolyKinds
- ; unless poly_kinds $
- addErr (badKindBndrs doc new_kvs)
-
- -- bind the vars and move on
- ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
- ; bindLocalNamesFV kv_nms $
- thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) }
- where
- -- check to see if the variables free in a kind are bound as type
- -- variables. Assume -XNoTypeInType.
- check_tv_used_in_kind :: NameSet -- ^ *type* variables
- -> Located Name -- ^ renamed var used in kind
- -> RnM ()
- check_tv_used_in_kind tv_names (L loc kv_name)
- = when (kv_name `elemNameSet` tv_names) $
- addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+>
- text "used in a kind." $$
- text "Did you mean to use TypeInType?"
- , pprHsDocContext doc ])
-
+bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"
newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn mb_assoc (L loc rdr)
@@ -1047,44 +1046,40 @@ collectAnonWildCards lty = go lty
where
go (L _ ty) = case ty of
HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
- HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
- HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
- HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
- HsListTy ty -> go ty
- HsPArrTy ty -> go ty
- HsTupleTy _ tys -> gos tys
- HsSumTy tys -> gos tys
- HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2
- HsParTy ty -> go ty
- HsIParamTy _ ty -> go ty
- HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2
- HsKindSig ty kind -> go ty `mappend` go kind
- HsDocTy ty _ -> go ty
- HsBangTy _ ty -> go ty
- HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
- HsExplicitListTy _ _ tys -> gos tys
- HsExplicitTupleTy _ tys -> gos tys
+ HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2
+ HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2
+ HsListTy _ ty -> go ty
+ HsTupleTy _ _ tys -> gos tys
+ HsSumTy _ tys -> gos tys
+ HsOpTy _ ty1 _ ty2 -> go ty1 `mappend` go ty2
+ HsParTy _ ty -> go ty
+ HsIParamTy _ _ ty -> go ty
+ HsKindSig _ ty kind -> go ty `mappend` go kind
+ HsDocTy _ ty _ -> go ty
+ HsBangTy _ _ ty -> go ty
+ HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds
+ HsExplicitListTy _ _ tys -> gos tys
+ HsExplicitTupleTy _ tys -> gos tys
HsForAllTy { hst_bndrs = bndrs
, hst_body = ty } -> collectAnonWildCardsBndrs bndrs
`mappend` go ty
HsQualTy { hst_ctxt = L _ ctxt
, hst_body = ty } -> gos ctxt `mappend` go ty
- HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty
+ HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
HsSpliceTy{} -> mempty
- HsCoreTy{} -> mempty
HsTyLit{} -> mempty
HsTyVar{} -> mempty
+ HsStarTy{} -> mempty
+ XHsType{} -> mempty
gos = mconcat . map go
- prefix_types_only (HsAppPrefix ty) = Just ty
- prefix_types_only (HsAppInfix _) = Nothing
-
collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name]
collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
where
- go (UserTyVar _) = []
- go (KindedTyVar _ ki) = collectAnonWildCards ki
+ go (UserTyVar _ _) = []
+ go (KindedTyVar _ _ ki) = collectAnonWildCards ki
+ go (XTyVarBndr{}) = []
{-
*********************************************************
@@ -1112,17 +1107,20 @@ rnConDeclFields ctxt fls fields
rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
-rnField fl_env env (L l (ConDeclField names ty haddock_doc))
+rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
= do { let new_names = map (fmap lookupField) names
; (new_ty, fvs) <- rnLHsTyKi env ty
; new_haddock_doc <- rnMbLHsDoc haddock_doc
- ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
+ ; return (L l (ConDeclField noExt new_names new_ty new_haddock_doc)
+ , fvs) }
where
lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
- lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
+ lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr)
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
+ lookupField (XFieldOcc{}) = panic "rnField"
+rnField _ _ (L _ (XConDeclField _)) = panic "rnField"
{-
************************************************************************
@@ -1156,15 +1154,15 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-> RnM (HsType GhcRn)
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExt ty21 op2 ty22))
= do { fix2 <- lookupTyFixityRn op2
; mk_hs_op_ty mk1 pp_op1 fix1 ty1
- (\t1 t2 -> HsOpTy t1 op2 t2)
+ (\t1 t2 -> HsOpTy noExt t1 op2 t2)
(unLoc op2) fix2 ty21 ty22 loc2 }
-mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))
= mk_hs_op_ty mk1 pp_op1 fix1 ty1
- HsFunTy funTyConName funTyFixity ty21 ty22 loc2
+ (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2
mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
= return (mk1 ty1 ty2)
@@ -1195,38 +1193,38 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged
-> RnM (HsExpr GhcRn)
-- (e11 `op1` e12) `op2` e2
-mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
+mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
- return (OpApp e1 op2 fix2 e2)
+ return (OpApp fix2 e1 op2 e2)
| associate_right = do
new_e <- mkOpAppRn e12 op2 fix2 e2
- return (OpApp e11 op1 fix1 (L loc' new_e))
+ return (OpApp fix1 e11 op1 (L loc' new_e))
where
loc'= combineLocs e12 e2
(nofix_error, associate_right) = compareFixity fix1 fix2
---------------------------
-- (- neg_arg) `op` e2
-mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
+mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
| nofix_error
= do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
- return (OpApp e1 op2 fix2 e2)
+ return (OpApp fix2 e1 op2 e2)
| associate_right
= do new_e <- mkOpAppRn neg_arg op2 fix2 e2
- return (NegApp (L loc' new_e) neg_name)
+ return (NegApp noExt (L loc' new_e) neg_name)
where
loc' = combineLocs neg_arg e2
(nofix_error, associate_right) = compareFixity negateFixity fix2
---------------------------
-- e1 `op` - neg_arg
-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
+mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
| not associate_right -- We *want* right association
= do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
- return (OpApp e1 op1 fix1 e2)
+ return (OpApp fix1 e1 op1 e2)
where
(_, associate_right) = compareFixity fix1 negateFixity
@@ -1236,7 +1234,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
= ASSERT2( right_op_ok fix (unLoc e2),
ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
)
- return (OpApp e1 op fix e2)
+ return (OpApp fix e1 op e2)
----------------------------
@@ -1256,16 +1254,16 @@ instance Outputable OpName where
get_op :: LHsExpr GhcRn -> OpName
-- An unbound name could be either HsVar or HsUnboundVar
-- See RnExpr.rnUnboundVar
-get_op (L _ (HsVar (L _ n))) = NormalOp n
-get_op (L _ (HsUnboundVar uv)) = UnboundOp uv
-get_op (L _ (HsRecFld fld)) = RecFldOp fld
-get_op other = pprPanic "get_op" (ppr other)
+get_op (L _ (HsVar _ (L _ n))) = NormalOp n
+get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
+get_op (L _ (HsRecFld _ fld)) = RecFldOp fld
+get_op other = pprPanic "get_op" (ppr other)
-- Parser left-associates everything, but
-- derived instances may have correctly-associated things to
-- in the right operand. So we just check that the right operand is OK
right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
-right_op_ok fix1 (OpApp _ _ fix2 _)
+right_op_ok fix1 (OpApp fix2 _ _ _)
= not error_please && associate_right
where
(error_please, associate_right) = compareFixity fix1 fix2
@@ -1274,14 +1272,15 @@ right_op_ok _ _
-- Parser initially makes negation bind more tightly than any other operator
-- And "deriving" code should respect this (use HsPar if not)
-mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
+mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
+ -> RnM (HsExpr (GhcPass id))
mkNegAppRn neg_arg neg_name
= ASSERT( not_op_app (unLoc neg_arg) )
- return (NegApp neg_arg neg_name)
+ return (NegApp noExt neg_arg neg_name)
not_op_app :: HsExpr id -> Bool
-not_op_app (OpApp _ _ _ _) = False
-not_op_app _ = True
+not_op_app (OpApp {}) = False
+not_op_app _ = True
---------------------------
mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
@@ -1290,25 +1289,24 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
-> RnM (HsCmd GhcRn)
-- (e11 `op1` e12) `op2` e2
-mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1)
- [a11,a12])) _ _ _))
+mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1)
+ [a11,a12]))))
op2 fix2 a2
| nofix_error
= do precParseErr (get_op op1,fix1) (get_op op2,fix2)
- return (HsCmdArrForm op2 f (Just fix2) [a1, a2])
+ return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
| associate_right
= do new_c <- mkOpFormRn a12 op2 fix2 a2
- return (HsCmdArrForm op1 f (Just fix1)
- [a11, L loc (HsCmdTop (L loc new_c)
- placeHolderType placeHolderType [])])
+ return (HsCmdArrForm noExt op1 f (Just fix1)
+ [a11, L loc (HsCmdTop [] (L loc new_c))])
-- TODO: locs are wrong
where
(nofix_error, associate_right) = compareFixity fix1 fix2
-- Default case
mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
- = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2])
+ = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
--------------------------------------
@@ -1346,7 +1344,7 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
checkPrecMatch op (MG { mg_alts = L _ ms })
= mapM_ check ms
where
- check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
+ check (L _ (Match { m_pats = L l1 p1 : L l2 p2 :_ }))
= setSrcSpan (combineSrcSpans l1 l2) $
do checkPrec op p1 False
checkPrec op p2 True
@@ -1359,6 +1357,7 @@ checkPrecMatch op (MG { mg_alts = L _ ms })
-- but the second eqn has no args (an error, but not discovered
-- until the type checker). So we don't want to crash on the
-- second eqn.
+checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
@@ -1386,8 +1385,8 @@ checkSectionPrec :: FixityDirection -> HsExpr GhcPs
-> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
checkSectionPrec direction section op arg
= case unLoc arg of
- OpApp _ op' fix _ -> go_for_it (get_op op') fix
- NegApp _ _ -> go_for_it NegateOp negateFixity
+ OpApp fix _ op' _ -> go_for_it (get_op op') fix
+ NegApp _ _ _ -> go_for_it NegateOp negateFixity
_ -> return ()
where
op_name = get_op op
@@ -1453,13 +1452,6 @@ unexpectedTypeSigErr ty
= hang (text "Illegal type signature:" <+> quotes (ppr ty))
2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
-badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc
-badKindBndrs doc kvs
- = withHsDocContext doc $
- hang (text "Unexpected kind variable" <> plural kvs
- <+> pprQuotedList kvs)
- 2 (text "Perhaps you intended to use PolyKinds")
-
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
badKindSigErr doc (L loc ty)
= setSrcSpan loc $ addErr $
@@ -1496,10 +1488,6 @@ opTyErr op overall_ty
| otherwise
= text "Use TypeOperators to allow operators in types"
-emptyNonSymsErr :: HsType GhcPs -> SDoc
-emptyNonSymsErr overall_ty
- = text "Operator applied to too few arguments:" <+> ppr overall_ty
-
{-
************************************************************************
* *
@@ -1533,17 +1521,103 @@ In general we want to walk over a type, and find
* Its free type variables
* The free kind variables of any kind signatures in the type
-Hence we returns a pair (kind-vars, type vars)
-See also Note [HsBSig binder lists] in HsTypes
+Hence we return a pair (kind-vars, type vars)
+(See Note [HsBSig binder lists] in HsTypes.)
+Moreover, we preserve the left-to-right order of the first occurrence of each
+variable, while preserving dependency order.
+(See Note [Ordering of implicit variables].)
+
+Most clients of this code just want to know the kind/type vars, without
+duplicates. The function rmDupsInRdrTyVars removes duplicates. That function
+also makes sure that no variable is reported as both a kind var and
+a type var, preferring kind vars. Why kind vars? Consider this:
+
+ foo :: forall (a :: k). Proxy k -> Proxy a -> ...
+
+Should that be accepted?
+
+Normally, if a type signature has an explicit forall, it must list *all*
+tyvars mentioned in the type. But there's an exception for tyvars mentioned in
+a kind, as k is above. Note that k is also used "as a type variable", as the
+argument to the first Proxy. So, do we consider k to be type-variable-like and
+require it in the forall? Or do we consider k to be kind-variable-like and not
+require it?
+
+It's not just in type signatures: kind variables are implicitly brought into
+scope in a variety of places. Should vars used at both the type level and kind
+level be treated this way?
+
+GHC indeed allows kind variables to be brought into scope implicitly even when
+the kind variable is also used as a type variable. Thus, we must prefer to keep
+a variable listed as a kind var in rmDupsInRdrTyVars. If we kept it as a type
+var, then this would prevent it from being implicitly quantified (see
+rnImplicitBndrs). In the `foo` example above, that would have the consequence
+of the k in Proxy k being reported as out of scope.
+
+Note [Ordering of implicit variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the advent of -XTypeApplications, GHC makes promises about the ordering
+of implicit variable quantification. Specifically, we offer that implicitly
+quantified variables (such as those in const :: a -> b -> a, without a `forall`)
+will occur in left-to-right order of first occurrence. Here are a few examples:
+
+ const :: a -> b -> a -- forall a b. ...
+ f :: Eq a => b -> a -> a -- forall a b. ... contexts are included
+
+ type a <-< b = b -> a
+ g :: a <-< b -- forall a b. ... type synonyms matter
+
+ class Functor f where
+ fmap :: (a -> b) -> f a -> f b -- forall f a b. ...
+ -- The f is quantified by the class, so only a and b are considered in fmap
+
+This simple story is complicated by the possibility of dependency: all variables
+must come after any variables mentioned in their kinds.
+
+ typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ...
+
+The k comes first because a depends on k, even though the k appears later than
+the a in the code. Thus, GHC does a *stable topological sort* on the variables.
+By "stable", we mean that any two variables who do not depend on each other
+preserve their existing left-to-right ordering.
+
+Implicitly bound variables are collected by any function which returns a
+FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
+includes the `extract-` family of functions (extractHsTysRdrTyVars,
+extractHsTyVarBndrsKVs, etc.).
+These functions thus promise to keep left-to-right ordering.
+Look for pointers to this note to see the places where the action happens.
+
+Note that we also maintain this ordering in kind signatures. Even though
+there's no visible kind application (yet), having implicit variables be
+quantified in left-to-right order in kind signatures is nice since:
+
+* It's consistent with the treatment for type signatures.
+* It can affect how types are displayed with -fprint-explicit-kinds (see
+ #15568 for an example), which is a situation where knowing the order in
+ which implicit variables are quantified can be useful.
+* In the event that visible kind application is implemented, the order in
+ which we would expect implicit variables to be ordered in kinds will have
+ already been established.
-}
+-- See Note [Kind and type-variable binders]
+-- These lists are guaranteed to preserve left-to-right ordering of
+-- the types the variables were extracted from. See also
+-- Note [Ordering of implicit variables].
data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName]
, fktv_tys :: [Located RdrName] }
+-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
+type FreeKiTyVarsWithDups = FreeKiTyVars
+
+-- | A 'FreeKiTyVars' list that contains no duplicate variables.
+type FreeKiTyVarsNoDups = FreeKiTyVars
+
instance Outputable FreeKiTyVars where
ppr (FKTV kis tys) = ppr (kis, tys)
-emptyFKTV :: FreeKiTyVars
+emptyFKTV :: FreeKiTyVarsNoDups
emptyFKTV = FKTV [] []
freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
@@ -1565,189 +1639,256 @@ filterInScope rdr_env (FKTV kis tys)
inScope :: LocalRdrEnv -> RdrName -> Bool
inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
-extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars
--- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
--- or the free (sort, kind) variables of a HsKind
--- It's used when making the for-alls explicit.
--- Does not return any wildcards
+-- | 'extractHsTyRdrTyVars' finds the
+-- free (kind, type) variables of an 'HsType'
+-- or the free (sort, kind) variables of an 'HsKind'.
+-- It's used when making the @forall@s explicit.
+-- Does not return any wildcards.
-- When the same name occurs multiple times in the types, only the first
-- occurrence is returned.
-- See Note [Kind and type-variable binders]
+extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
extractHsTyRdrTyVars ty
- = do { FKTV kis tys <- extract_lty TypeLevel ty emptyFKTV
- ; return (FKTV (nubL kis)
- (nubL tys)) }
+ = rmDupsInRdrTyVars <$> extractHsTyRdrTyVarsDups ty
+-- | 'extractHsTyRdrTyVarsDups' find the
+-- free (kind, type) variables of an 'HsType'
+-- or the free (sort, kind) variables of an 'HsKind'.
+-- It's used when making the @forall@s explicit.
+-- Does not return any wildcards.
+-- When the same name occurs multiple times in the types, all occurrences
+-- are returned.
+extractHsTyRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
+extractHsTyRdrTyVarsDups ty
+ = extract_lty TypeLevel ty emptyFKTV
+
+-- | Extracts the free kind variables (but not the type variables) of an
+-- 'HsType'. Does not return any wildcards.
+-- When the same name occurs multiple times in the type, only the first
+-- occurrence is returned, and the left-to-right order of variables is
+-- preserved.
+-- See Note [Kind and type-variable binders] and
+-- Note [Ordering of implicit variables].
+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> RnM [Located RdrName]
+extractHsTyRdrTyVarsKindVars ty
+ = freeKiTyVarsKindVars <$> extractHsTyRdrTyVars ty
-- | Extracts free type and kind variables from types in a list.
-- When the same name occurs multiple times in the types, only the first
-- occurrence is returned and the rest is filtered out.
-- See Note [Kind and type-variable binders]
-extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVars
+extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVarsNoDups
extractHsTysRdrTyVars tys
= rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
-- | Extracts free type and kind variables from types in a list.
-- When the same name occurs multiple times in the types, all occurrences
-- are returned.
-extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVars
+extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVarsWithDups
extractHsTysRdrTyVarsDups tys
= extract_ltys TypeLevel tys emptyFKTV
--- | Removes multiple occurrences of the same name from FreeKiTyVars.
-rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars
+extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+-- However duplicates are removed
+-- E.g. given [k1, a:k1, b:k2]
+-- the function returns [k1,k2], even though k1 is bound here
+extractHsTyVarBndrsKVs tv_bndrs
+ = do { kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
+ ; return (nubL kvs) }
+
+-- | Removes multiple occurrences of the same name from FreeKiTyVars. If a
+-- variable occurs as both a kind and a type variable, only keep the occurrence
+-- as a kind variable.
+-- See also Note [Kind and type-variable binders]
+rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsNoDups
rmDupsInRdrTyVars (FKTV kis tys)
- = FKTV (nubL kis) (nubL tys)
+ = FKTV kis' tys'
+ where
+ kis' = nubL kis
+ tys' = nubL (filterOut (`elemRdr` kis') tys)
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName]
+-- Returns the free kind variables in a type family result signature, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
extractRdrKindSigVars (L _ resultSig)
- | KindSig k <- resultSig = kindRdrNameFromSig k
- | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k
+ | KindSig _ k <- resultSig = kindRdrNameFromSig k
+ | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
| otherwise = return []
where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
extractDataDefnKindVars :: HsDataDefn GhcPs -> RnM [Located RdrName]
-- Get the scoped kind variables mentioned free in the constructor decls
--- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
--- Here k should scope over the whole definition
+-- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
+-- Here k should scope over the whole definition
+--
+-- However, do NOT collect free kind vars from the deriving clauses:
+-- Eg: (Trac #14331) class C p q
+-- data D = D deriving ( C (a :: k) )
+-- Here k should /not/ scope over the whole definition. We intend
+-- this to elaborate to:
+-- class C @k1 @k2 (p::k1) (q::k2)
+-- data D = D
+-- instance forall k (a::k). C @k @* a D where ...
+--
+-- This returns variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
- , dd_cons = cons, dd_derivs = L _ derivs })
+ , dd_cons = cons })
= (nubL . freeKiTyVarsKindVars) <$>
(extract_lctxt TypeLevel ctxt =<<
extract_mb extract_lkind ksig =<<
- extract_sig_tys (concatMap (unLoc . deriv_clause_tys . unLoc) derivs) =<<
foldrM (extract_con . unLoc) emptyFKTV cons)
where
extract_con (ConDeclGADT { }) acc = return acc
- extract_con (ConDeclH98 { con_qvars = qvs
- , con_cxt = ctxt, con_details = details }) acc
- = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<
+ extract_con (ConDeclH98 { con_ex_tvs = ex_tvs
+ , con_mb_cxt = ctxt, con_args = args }) acc
+ = extract_hs_tv_bndrs ex_tvs acc =<<
extract_mlctxt ctxt =<<
- extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV
+ extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
+ extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars"
+extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"
-extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_mlctxt :: Maybe (LHsContext GhcPs)
+ -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_mlctxt Nothing acc = return acc
extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
extract_lctxt :: TypeOrKind
- -> LHsContext GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
+ -> LHsContext GhcPs
+ -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
-extract_sig_tys :: [LHsSigType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
-extract_sig_tys sig_tys acc
- = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc)
- acc sig_tys
-
extract_ltys :: TypeOrKind
- -> [LHsType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
+ -> [LHsType GhcPs]
+ -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
-extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars)
- -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_mb :: (a -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups)
+ -> Maybe a
+ -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_mb _ Nothing acc = return acc
extract_mb f (Just x) acc = f x acc
extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
extract_lkind = extract_lty KindLevel
-extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
+extract_lty :: TypeOrKind -> LHsType GhcPs
+ -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
extract_lty t_or_k (L _ ty) acc
= case ty of
- HsTyVar _ ltv -> extract_tv t_or_k ltv acc
- HsBangTy _ ty -> extract_lty t_or_k ty acc
- HsRecTy flds -> foldrM (extract_lty t_or_k
- . cd_fld_type . unLoc) acc
- flds
- HsAppsTy tys -> extract_apps t_or_k tys acc
- HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsListTy ty -> extract_lty t_or_k ty acc
- HsPArrTy ty -> extract_lty t_or_k ty acc
- HsTupleTy _ tys -> extract_ltys t_or_k tys acc
- HsSumTy tys -> extract_ltys t_or_k tys acc
- HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsIParamTy _ ty -> extract_lty t_or_k ty acc
- HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<<
- extract_lty t_or_k ty1 =<<
- extract_lty t_or_k ty2 acc
- HsParTy ty -> extract_lty t_or_k ty acc
- HsCoreTy {} -> return acc -- The type is closed
- HsSpliceTy {} -> return acc -- Type splices mention no tvs
- HsDocTy ty _ -> extract_lty t_or_k ty acc
- HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc
- HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
- HsTyLit _ -> return acc
- HsKindSig ty ki -> extract_lty t_or_k ty =<<
- extract_lkind ki acc
+ HsTyVar _ _ ltv -> extract_tv t_or_k ltv acc
+ HsBangTy _ _ ty -> extract_lty t_or_k ty acc
+ HsRecTy _ flds -> foldrM (extract_lty t_or_k
+ . cd_fld_type . unLoc) acc
+ flds
+ HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
+ extract_lty t_or_k ty2 acc
+ HsListTy _ ty -> extract_lty t_or_k ty acc
+ HsTupleTy _ _ tys -> extract_ltys t_or_k tys acc
+ HsSumTy _ tys -> extract_ltys t_or_k tys acc
+ HsFunTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
+ extract_lty t_or_k ty2 acc
+ HsIParamTy _ _ ty -> extract_lty t_or_k ty acc
+ HsOpTy _ ty1 tv ty2 -> extract_tv t_or_k tv =<<
+ extract_lty t_or_k ty1 =<<
+ extract_lty t_or_k ty2 acc
+ HsParTy _ ty -> extract_lty t_or_k ty acc
+ HsSpliceTy {} -> return acc -- Type splices mention no tvs
+ HsDocTy _ ty _ -> extract_lty t_or_k ty acc
+ HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc
+ HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
+ HsTyLit _ _ -> return acc
+ HsStarTy _ _ -> return acc
+ HsKindSig _ ty ki -> extract_lty t_or_k ty =<<
+ extract_lkind ki acc
HsForAllTy { hst_bndrs = tvs, hst_body = ty }
- -> extract_hs_tv_bndrs tvs acc =<<
- extract_lty t_or_k ty emptyFKTV
+ -> extract_hs_tv_bndrs tvs acc =<<
+ extract_lty t_or_k ty emptyFKTV
HsQualTy { hst_ctxt = ctxt, hst_body = ty }
- -> extract_lctxt t_or_k ctxt =<<
- extract_lty t_or_k ty acc
+ -> extract_lctxt t_or_k ctxt =<<
+ extract_lty t_or_k ty acc
+ XHsType {} -> return acc
-- We deal with these separately in rnLHsTypeWithWildCards
- HsWildCardTy {} -> return acc
-
-extract_apps :: TypeOrKind
- -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
-extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
-
-extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars
- -> RnM FreeKiTyVars
-extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc
-extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
-
-extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars
- -> FreeKiTyVars -> RnM FreeKiTyVars
+ HsWildCardTy {} -> return acc
+
+extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
+ -> FreeKiTyVarsWithDups -- Free in body
+ -> RnM FreeKiTyVarsWithDups -- Free in result
+extractHsTvBndrs tv_bndrs body_fvs
+ = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs
+
+extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
+ -> FreeKiTyVarsWithDups -- Accumulator
+ -> FreeKiTyVarsWithDups -- Free in body
+ -> RnM FreeKiTyVarsWithDups
-- In (forall (a :: Maybe e). a -> b) we have
-- 'a' is bound by the forall
-- 'b' is a free type variable
-- 'e' is a free kind variable
-extract_hs_tv_bndrs tvs
- (FKTV acc_kvs acc_tvs)
- -- Note accumulator comes first
- (FKTV body_kvs body_tvs)
- | null tvs
+extract_hs_tv_bndrs tv_bndrs
+ (FKTV acc_kvs acc_tvs) -- Accumulator
+ (FKTV body_kvs body_tvs) -- Free in the body
+ | null tv_bndrs
= return $
FKTV (body_kvs ++ acc_kvs) (body_tvs ++ acc_tvs)
| otherwise
- = do { FKTV bndr_kvs _
- <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs]
+ = do { bndr_kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
- ; let locals = map hsLTyVarName tvs
- ; return $
- FKTV (filterOut ((`elem` locals) . unLoc) (bndr_kvs ++ body_kvs)
- ++ acc_kvs)
- (filterOut ((`elem` locals) . unLoc) body_tvs ++ acc_tvs) }
-
-extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars
- -> RnM FreeKiTyVars
-extract_tv t_or_k ltv@(L _ tv) acc
- | isRdrTyVar tv = case acc of
- FKTV kvs tvs
- | isTypeLevel t_or_k
- -> do { when (ltv `elemRdr` kvs) $
- mixedVarsErr ltv
- ; return (FKTV kvs (ltv : tvs)) }
- | otherwise
- -> do { when (ltv `elemRdr` tvs) $
- mixedVarsErr ltv
- ; return (FKTV (ltv : kvs) tvs) }
- | otherwise = return acc
- where
- elemRdr x = any (eqLocated x)
+ ; let tv_bndr_rdrs, all_kv_occs :: [Located RdrName]
+ tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
+ -- We must include both kind variables from the binding as well
+ -- as the body of the `forall` type.
+ -- See Note [Variables used as both types and kinds].
+ all_kv_occs = bndr_kvs ++ body_kvs
-mixedVarsErr :: Located RdrName -> RnM ()
-mixedVarsErr (L loc tv)
- = do { typeintype <- xoptM LangExt.TypeInType
- ; unless typeintype $
- addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+>
- text "used as both a kind and a type" $$
- text "Did you intend to use TypeInType?" }
+ ; traceRn "checkMixedVars1" $
+ vcat [ text "bndr_kvs" <+> ppr bndr_kvs
+ , text "body_kvs" <+> ppr body_kvs
+ , text "all_kv_occs" <+> ppr all_kv_occs
+ , text "tv_bndr_rdrs" <+> ppr tv_bndr_rdrs ]
--- just used in this module; seemed convenient here
+ ; return $
+ FKTV (filterOut (`elemRdr` tv_bndr_rdrs) all_kv_occs
+ -- NB: delete all tv_bndr_rdrs from bndr_kvs as well
+ -- as body_kvs; see Note [Kind variable scoping]
+ ++ acc_kvs)
+ (filterOut (`elemRdr` tv_bndr_rdrs) body_tvs ++ acc_tvs) }
+
+extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+-- Duplicates are /not/ removed
+-- E.g. given [k1, a:k1, b:k2]
+-- the function returns [k1,k2], even though k1 is bound here
+extract_hs_tv_bndrs_kvs tv_bndrs
+ = do { fktvs <- foldrM extract_lkind emptyFKTV
+ [k | L _ (KindedTyVar _ _ k) <- tv_bndrs]
+ ; return (freeKiTyVarsKindVars fktvs) }
+ -- There will /be/ no free tyvars!
+
+extract_tv :: TypeOrKind -> Located RdrName
+ -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
+extract_tv t_or_k ltv@(L _ tv) acc@(FKTV kvs tvs)
+ | not (isRdrTyVar tv) = return acc
+ | isTypeLevel t_or_k = return (FKTV kvs (ltv : tvs))
+ | otherwise = return (FKTV (ltv : kvs) tvs)
+
+-- Deletes duplicates in a list of Located things.
+--
+-- Importantly, this function is stable with respect to the original ordering
+-- of things in the list. This is important, as it is a property that GHC
+-- relies on to maintain the left-to-right ordering of implicitly quantified
+-- type variables.
+-- See Note [Ordering of implicit variables].
nubL :: Eq a => [Located a] -> [Located a]
nubL = nubBy eqLocated
+
+elemRdr :: Located RdrName -> [Located RdrName] -> Bool
+elemRdr x = any (eqLocated x)
diff --git a/compiler/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs
index cf5dab5d37..ce5d0dc315 100644
--- a/compiler/rename/RnUnbound.hs
+++ b/compiler/rename/RnUnbound.hs
@@ -12,7 +12,10 @@ module RnUnbound ( mkUnboundName
, WhereLooking(..)
, unboundName
, unboundNameX
- , perhapsForallMsg ) where
+ , perhapsForallMsg
+ , notInScopeErr ) where
+
+import GhcPrelude
import RdrName
import HscTypes
@@ -58,8 +61,7 @@ unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
unboundNameX where_look rdr_name extra
= do { dflags <- getDynFlags
; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
- what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
- err = unknownNameErr what rdr_name $$ extra
+ err = notInScopeErr rdr_name $$ extra
; if not show_helpful_errors
then addErr err
else do { local_env <- getLocalRdrEnv
@@ -70,12 +72,13 @@ unboundNameX where_look rdr_name extra
; addErr (err $$ suggestions) }
; return (mkUnboundNameRdr rdr_name) }
-unknownNameErr :: SDoc -> RdrName -> SDoc
-unknownNameErr what rdr_name
+notInScopeErr :: RdrName -> SDoc
+notInScopeErr rdr_name
= vcat [ hang (text "Not in scope:")
2 (what <+> quotes (ppr rdr_name))
, extra ]
where
+ what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
extra | rdr_name == forall_tv_RDR = perhapsForallMsg
| otherwise = Outputable.empty
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 7b2f74f1da..0451e288be 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -26,6 +26,8 @@ module RnUtils (
where
+import GhcPrelude
+
import HsSyn
import RdrName
import HscTypes
@@ -45,6 +47,7 @@ import FastString
import Control.Monad
import Data.List
import Constants ( mAX_TUPLE_SIZE )
+import qualified Data.List.NonEmpty as NE
import qualified GHC.LanguageExtensions as LangExt
{-
@@ -292,16 +295,40 @@ addNameClashErrRn rdr_name gres
-- If there are two or more *local* defns, we'll have reported
= return () -- that already, and we don't want an error cascade
| otherwise
- = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name),
- text "It could refer to" <+> vcat (msg1 : msgs)])
+ = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
+ , text "It could refer to"
+ , nest 3 (vcat (msg1 : msgs)) ])
where
(np1:nps) = gres
- msg1 = ptext (sLit "either") <+> mk_ref np1
- msgs = [text " or" <+> mk_ref np | np <- nps]
- mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
- where nom = case gre_par gre of
- FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
- _ -> quotes (ppr (gre_name gre))
+ msg1 = text "either" <+> ppr_gre np1
+ msgs = [text " or" <+> ppr_gre np | np <- nps]
+ ppr_gre gre = sep [ pp_gre_name gre <> comma
+ , pprNameProvenance gre]
+
+ -- When printing the name, take care to qualify it in the same
+ -- way as the provenance reported by pprNameProvenance, namely
+ -- the head of 'gre_imp'. Otherwise we get confusing reports like
+ -- Ambiguous occurrence ‘null’
+ -- It could refer to either ‘T15487a.null’,
+ -- imported from ‘Prelude’ at T15487.hs:1:8-13
+ -- or ...
+ -- See Trac #15487
+ pp_gre_name gre@(GRE { gre_name = name, gre_par = parent
+ , gre_lcl = lcl, gre_imp = iss })
+ | FldParent { par_lbl = Just lbl } <- parent
+ = text "the field" <+> quotes (ppr lbl)
+ | otherwise
+ = quotes (pp_qual <> dot <> ppr (nameOccName name))
+ where
+ pp_qual | lcl
+ = ppr (nameModule name)
+ | imp : _ <- iss -- This 'imp' is the one that
+ -- pprNameProvenance chooses
+ , ImpDeclSpec { is_as = mod } <- is_decl imp
+ = ppr mod
+ | otherwise
+ = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
+ -- Invariant: either 'lcl' is True or 'iss' is non-empty
shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn occ shadowed_locs
@@ -316,13 +343,13 @@ unknownSubordinateErr doc op -- Doc is "method of class" or
= quotes (ppr op) <+> text "is not a (visible)" <+> doc
-dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
+dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
dupNamesErr get_loc names
= addErrAt big_loc $
- vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),
+ vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
locations]
where
- locs = map get_loc names
+ locs = map get_loc (NE.toList names)
big_loc = foldr1 combineSrcSpans locs
locations = text "Bound at:" <+> vcat (map ppr (sort locs))
@@ -371,7 +398,6 @@ data HsDocContext
| GHCiCtx
| SpliceTypeCtx (LHsType GhcPs)
| ClassInstanceCtx
- | VectDeclCtx (Located RdrName)
| GenericCtx SDoc -- Maybe we want to use this more!
withHsDocContext :: HsDocContext -> SDoc -> SDoc
@@ -406,5 +432,3 @@ pprHsDocContext (ConDeclCtx [name])
= text "the definition of data constructor" <+> quotes (ppr name)
pprHsDocContext (ConDeclCtx names)
= text "the definition of data constructors" <+> interpp'SP names
-pprHsDocContext (VectDeclCtx tycon)
- = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)
View Lorry Controller Status