Commit 5830fc44 authored by cactus's avatar cactus Committed by Simon Peyton Jones

Pattern synonym names need to be in scope before renaming bindings (#9889)

I did a bit of refactoring at the same time, needless to say
parent 678df4c2
......@@ -73,15 +73,24 @@ type HsLocalBinds id = HsLocalBindsLR id id
-- or a 'where' clause
data HsLocalBindsLR idL idR
= HsValBinds (HsValBindsLR idL idR)
-- There should be no pattern synonyms in the HsValBindsLR
-- These are *local* (not top level) bindings
-- The parser accepts them, however, leaving the the
-- renamer to report them
| HsIPBinds (HsIPBinds idR)
| EmptyLocalBinds
deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsLocalBindsLR idL idR)
type HsValBinds id = HsValBindsLR id id
-- | Value bindings (not implicit parameters)
-- Used for both top level and nested bindings
-- May contain pattern synonym bindings
data HsValBindsLR idL idR
= -- | Before renaming RHS; idR is always RdrName
-- Not dependency analysed
......@@ -97,6 +106,7 @@ data HsValBindsLR idL idR
[(RecFlag, LHsBinds idL)]
[LSig Name]
deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsValBindsLR idL idR)
......
......@@ -61,12 +61,13 @@ module HsUtils(
-- Collecting binders
collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
collectHsIdBinders,
collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
hsLTyClDeclBinders, hsTyClDeclsBinders,
hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-- Collecting implicit binders
......@@ -596,39 +597,48 @@ So these functions should not be applied to (HsSyn RdrName)
----------------- Bindings --------------------------
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
-- No pattern synonyms here
collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
collectHsValBinders :: HsValBindsLR idL idR -> [idL]
collectHsValBinders (ValBindsIn binds _) = collectHsBindsBinders binds
collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
where
collect_one (_,binds) acc = collect_binds binds acc
collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
-- Collect Id binders only, or Ids + pattern synonmys, respectively
collectHsIdBinders = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
collectHsBindBinders :: HsBindLR idL idR -> [idL]
collectHsBindBinders b = collect_bind b []
collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc
collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind (VarBind { var_id = f }) acc = f : acc
collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
= map abe_poly dbinds ++ acc
-- ++ foldr collect_bind acc binds
-- I don't think we want the binders from the nested binds
-- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc
-- Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
collectHsBindsBinders binds = collect_binds binds []
collectHsBindsBinders binds = collect_binds False binds []
collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
collectHsBindListBinders = foldr (collect_bind . unLoc) []
collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
-- Same as collectHsBindsBinders, but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []
collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
collect_out_binds ps = foldr (collect_binds ps . snd) []
collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
-- Collect Ids, or Ids + patter synonyms, depending on boolean flag
collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
-- I don't think we want the binders from the abe_binds
-- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
if omitPatSyn then acc else ps : acc
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
......@@ -728,21 +738,18 @@ So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
hsGroupBinders :: HsGroup Name -> [Name]
hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_instds = inst_decls, hs_fords = foreign_decls })
-- Collect the binders of a Group
= collectHsValBinders val_decls
++ hsTyClDeclsBinders tycl_decls inst_decls
++ hsForeignDeclsBinders foreign_decls
hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
hsForeignDeclsBinders foreign_decls
= [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
-> [LForeignDecl Name] -> [Name]
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClDeclsBinders tycl_decls inst_decls
= map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
concatMap (hsInstDeclBinders . unLoc) inst_decls)
hsTyClForeignBinders tycl_decls inst_decls foreign_decls
= map unLoc $
hsForeignDeclsBinders foreign_decls ++
concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
concatMap hsLInstDeclBinders inst_decls
-------------------
hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
......@@ -751,11 +758,8 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- mentioned in multiple constructors, the SrcLoc will be from the first
-- occurrence. We use the equality to filter out duplicate field names.
--
-- Each returned (Located name) is wrapped in a @SrcSpan@ of the whole
-- /declaration/, not just the name itself (which is how it appears in
-- the syntax tree). This SrcSpan (for the entire declaration) is used
-- as the SrcSpan for the Name that is finally produced, and hence for
-- error messages. (See Trac #8607.)
-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
-- See Note [SrcSpan for binders]
hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
= [L loc name]
......@@ -769,11 +773,33 @@ hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn
= L loc name : hsDataDefnBinders defn
-------------------
hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
-- See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
= [ L decl_loc n
| L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
-------------------
hsPatSynBinders :: LHsBindsLR idL idR -> [Located idL]
-- Collect pattern-synonym binders only, not Ids
-- See Note [SrcSpan for binders]
hsPatSynBinders binds = foldrBag addPatSynBndr [] binds
addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL]
-- See Note [SrcSpan for binders]
addPatSynBndr bind pss
| L bind_loc (PatSynBind (PSB { psb_id = L _ n })) <- bind
= L bind_loc n : pss
| otherwise
= pss
-------------------
hsLInstDeclBinders :: Eq name => LInstDecl name -> [Located name]
hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
= concatMap (hsDataFamInstBinders . unLoc) dfis
hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
hsInstDeclBinders (TyFamInstD {}) = []
hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
= hsDataFamInstBinders fi
hsLInstDeclBinders (L _ (TyFamInstD {})) = []
-------------------
-- the SrcLoc returned are for the whole declarations, not just the names
......@@ -811,6 +837,16 @@ hsConDeclsBinders cons = go id cons
(map (L loc . unLoc) names) ++ go remSeen rs
{-
Note [SrcSpan for binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~
When extracting the (Located RdrNme) for a binder, at least for the
main name (the TyCon of a type declaration etc), we want to give it
the @SrcSpan@ of the whole /declaration/, not just the name itself
(which is how it appears in the syntax tree). This SrcSpan (for the
entire declaration) is used as the SrcSpan for the Name that is
finally produced, and hence for error messages. (See Trac #8607.)
Note [Binders in family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a type or data family instance declaration, the type
......
......@@ -258,6 +258,9 @@ rnLocalValBindsLHS fix_env binds
-- g = let f = ... in f
-- should.
; let bound_names = collectHsValBinders binds'
-- There should be only Ids, but if there are any bogus
-- pattern synonyms, we'll collect them anyway, so that
-- we don't generate subsequent out-of-scope messages
; envs <- getRdrEnvs
; checkDupAndShadowedNames envs bound_names
......@@ -431,22 +434,27 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
-- gets updated to the FVs of the whole bind
-- when doing the RHS below
rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
= do { newname <- applyNameMaker name_maker name
; return (bind { fun_id = L nameLoc newname
rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
= do { name <- applyNameMaker name_maker rdr_name
; return (bind { fun_id = name
, bind_fvs = placeHolderNamesTc }) }
rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) })
= do { unless (isTopRecNameMaker name_maker) $
addErr localPatternSynonymErr
; addLocM checkConName rdrname
rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
= do { addLocM checkConName rdrname
; name <- lookupLocatedTopBndrRn rdrname -- Should be bound at top level already
; return (PatSynBind psb{ 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 = L nameLoc name }) }
; return (PatSynBind psb{ psb_id = name }) }
where
localPatternSynonymErr :: SDoc
localPatternSynonymErr
= hang (ptext (sLit "Illegal pattern synonym declaration"))
2 (ptext (sLit "Pattern synonym declarations are only valid in the top-level scope"))
= hang (ptext (sLit "Illegal pattern synonym declaration for") <+> quotes (ppr rdrname))
2 (ptext (sLit "Pattern synonym declarations are only valid at top level"))
rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
......
......@@ -260,7 +260,7 @@ lookupTopBndrRn :: RdrName -> RnM Name
lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
case nopt of
Just n' -> return n'
Nothing -> do traceRn $ text "lookupTopBndrRn"
Nothing -> do traceRn $ (text "lookupTopBndrRn fail" <+> ppr n)
unboundName WL_LocalTop n
lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
......
......@@ -491,14 +491,15 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
-- Get all the top-level binders bound the group *except*
-- for value bindings, which are treated separately
-- Specifically we return AvailInfo for
-- type decls (incl constructors and record selectors)
-- class decls (including class ops)
-- associated types
-- foreign imports
-- (in hs-boot files) value signatures
-- * type decls (incl constructors and record selectors)
-- * class decls (including class ops)
-- * associated types
-- * foreign imports
-- * pattern synonyms
-- * value signatures (in hs-boot files)
getLocalNonValBinders fixity_env
(HsGroup { hs_valds = val_binds,
(HsGroup { hs_valds = binds,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls })
......@@ -515,11 +516,11 @@ getLocalNonValBinders fixity_env
; nti_avails <- concatMapM new_assoc inst_decls
-- Finish off with value binders:
-- foreign decls for an ordinary module
-- foreign decls and pattern synonyms for an ordinary module
-- type sigs in case of a hs-boot file only
; is_boot <- tcIsHsBootOrSig
; let val_bndrs | is_boot = hs_boot_sig_bndrs
| otherwise = for_hs_bndrs
| otherwise = for_hs_bndrs ++ patsyn_hs_bndrs
; val_avails <- mapM new_simple val_bndrs
; let avails = nti_avails ++ val_avails
......@@ -529,15 +530,18 @@ getLocalNonValBinders fixity_env
; envs <- extendGlobalRdrEnvRn avails fixity_env
; return (envs, new_bndrs) } }
where
ValBindsIn val_binds val_sigs = binds
for_hs_bndrs :: [Located RdrName]
for_hs_bndrs = [ L decl_loc (unLoc nm)
| L decl_loc (ForeignImport nm _ _ _) <- foreign_decls]
for_hs_bndrs = hsForeignDeclsBinders foreign_decls
patsyn_hs_bndrs :: [Located RdrName]
patsyn_hs_bndrs = hsPatSynBinders val_binds
-- 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]
ValBindsIn _ val_sigs = val_binds
-- the SrcSpan attached to the input should be the span of the
-- declaration, not just the name
......
......@@ -212,6 +212,11 @@ rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName)
rnHsSigCps sig
= CpsRn (rnHsBndrSig PatCtx sig)
newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
newPatLName name_maker rdr_name@(L loc _)
= do { name <- newPatName name_maker rdr_name
; return (L loc name) }
newPatName :: NameMaker -> Located RdrName -> CpsRn Name
newPatName (LamMk report_unused) rdr_name
= CpsRn (\ thing_inside ->
......@@ -307,8 +312,9 @@ rnPat :: HsMatchContext Name -- for error messages
rnPat ctxt pat thing_inside
= rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName mk rdr); return n }
applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)
applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
; return n }
-- ----------- Entry point 2: rnBindPat -------------------
-- Binds local names; in a recursive scope that involves other bound vars
......@@ -392,17 +398,17 @@ rnPatAndThen _ (NPat lit mb_neg _eq)
; return (NPat lit' mb_neg' eq') }
rnPatAndThen mk (NPlusKPat rdr lit _ _)
= do { new_name <- newPatName mk rdr
= do { new_name <- newPatLName mk rdr
; lit' <- liftCpsFV $ rnOverLit lit
; minus <- liftCpsFV $ lookupSyntaxName minusName
; ge <- liftCpsFV $ lookupSyntaxName geName
; return (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus) }
; return (NPlusKPat new_name lit' ge minus) }
-- The Report says that n+k patterns must be in Integral
rnPatAndThen mk (AsPat rdr pat)
= do { new_name <- newPatName mk rdr
= do { new_name <- newPatLName mk rdr
; pat' <- rnLPatAndThen mk pat
; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
; return (AsPat new_name pat') }
rnPatAndThen mk p@(ViewPat expr pat _ty)
= do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns
......
......@@ -94,9 +94,19 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
local_fix_env <- makeMiniFixityEnv fix_decls ;
-- (B) Bring top level binders (and their fixities) into scope,
-- *except* for the value bindings, which get brought in below.
-- However *do* include class ops, data constructors
-- And for hs-boot files *do* include the value signatures
-- *except* for the value bindings, which get done in step (D)
-- with collectHsIdBinders. However *do* include
--
-- * Class ops, data constructors, and record fields,
-- because they do not have value declarations.
-- Aso step (C) depends on datacons and record fields
--
-- * Pattern synonyms, becuase they (and data constructors)
-- are needed for rnTopBindLHS (Trac #9889)
--
-- * For hs-boot files, include the value signatures
-- Again, they have no value declarations
--
(tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
setEnvs tc_envs $ do {
......@@ -114,12 +124,13 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
-- It uses the fixity env from (A) to bind fixities for view patterns.
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
-- bind the LHSes (and their fixities) in the global rdr environment
let { val_binders = collectHsValBinders new_lhs ;
let { val_binders = collectHsIdBinders new_lhs ;
-- Not pattern-synonym binders, because we did
-- them in step (B)
all_bndrs = extendNameSetList tc_bndrs val_binders ;
val_avails = map Avail val_binders } ;
traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
(tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
setEnvs (tcg_env, tcl_env) $ do {
-- Now everything is in scope, as the remaining renaming assumes.
......@@ -185,9 +196,8 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
hs_vects = rn_vect_decls,
hs_docs = rn_docs } ;
tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
other_def = (Just (mkNameSet tycl_bndrs `unionNameSet` mkNameSet ford_bndrs), emptyNameSet) ;
tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_inst_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,
src_fvs9] ;
......
......@@ -362,9 +362,9 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
= do { let bind = case bagToList binds of
[] -> panic "tc_group: empty list of binds"
[bind] -> bind
_ -> panic "tc_group: NonRecursive binds is not a singleton bag"
[] -> panic "tc_group: empty list of binds"
_ -> panic "tc_group: NonRecursive binds is not a singleton bag"
; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
; return ( [(NonRecursive, bind')], thing) }
......@@ -375,9 +375,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
-- (This used to be optional, but isn't now.)
do { traceTc "tc_group rec" (pprLHsBinds binds)
; when hasPatSyn $ recursivePatSynErr binds
; (binds1, _ids, thing) <- go sccs
-- Here is where we should do bindInstsOfLocalFuns
-- if we start having Methods again
; (binds1, thing) <- go sccs
; return ([(Recursive, binds1)], thing) }
-- Rec them all together
where
......@@ -388,12 +386,12 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
sccs :: [SCC (LHsBind Name)]
sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc
; (binds2, ids2, thing) <- tcExtendLetEnv top_lvl closed ids1 $
go sccs
; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, [], thing) }
; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1 $
go sccs
; return (binds1 `unionBags` binds2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, thing) }
tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
......@@ -417,20 +415,14 @@ tc_single :: forall thing.
tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
= do { (pat_syn, aux_binds) <- tc_pat_syn_decl
; let tything = AConLike (PatSynCon pat_syn)
-- SLPJ: Why is this necessary?
-- implicit_ids = patSynMatcher pat_syn :
-- maybeToList (patSynWorker pat_syn)
; thing <- tcExtendGlobalEnv [tything] $
-- tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
thing_inside
; thing <- tcExtendGlobalEnv [tything] thing_inside
; return (aux_binds, thing)
}
where
tc_pat_syn_decl = case sig_fn name of
Nothing -> tcInferPatSynDecl psb
Nothing -> tcInferPatSynDecl psb
Just (TcPatSynInfo tpsi) -> tcCheckPatSynDecl psb tpsi
Just _ -> panic "tc_single"
Just _ -> panic "tc_single"
tc_single top_lvl sig_fn prag_fn lbind thing_inside
= do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
......@@ -445,10 +437,9 @@ noCompleteSig Nothing = True
noCompleteSig (Just sig) = isPartialSig sig
------------------------
mkEdges :: TcSigFun -> LHsBinds Name
-> [(LHsBind Name, BKey, [BKey])]
mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
type BKey = Int -- Just number off the bindings
type BKey = Int -- Just number off the bindings
mkEdges sig_fn binds
= [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),
......@@ -463,24 +454,17 @@ mkEdges sig_fn binds
key_map :: NameEnv BKey -- Which binding it comes from
key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
, bndr <- bindersOfHsBind bind ]
bindersOfHsBind :: HsBind Name -> [Name]
bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat
bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
bindersOfHsBind (PatSynBind PSB{ psb_id = L _ psyn }) = [psyn]
bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds"
bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind"
, bndr <- collectHsBindBinders bind ]
------------------------
tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
-> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name] -- None are PatSynBind
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- Typechecks a single bunch of bindings all together,
-- Typechecks a single bunch of values bindings all together,
-- and generalises them. The bunch may be only part of a recursive
-- group, because we use type signatures to maximise polymorphism
--
......@@ -489,6 +473,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
-- important.
--
-- Knows nothing about the scope of the bindings
-- None of the bindings are pattern synonyms
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
= setSrcSpan loc $
......
pattern P :: (Num t, Eq t1) => A t t1 -- Defined at T8776.hs:6:9
pattern P :: (Num t, Eq t1) => A t t1 -- Defined at T8776.hs:6:1
{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where
pattern Id x = x
Id x = True
......@@ -20,3 +20,4 @@ test('T8968-2', normal, compile, [''])
test('T8968-3', expect_broken(9953), compile, [''])
test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0'])
test('T9857', normal, compile, [''])
test('T9889', normal, compile, [''])
local.hs:7:5:
Illegal pattern synonym declaration
Pattern synonym declarations are only valid in the top-level scope
Illegal pattern synonym declaration for ‘P’
Pattern synonym declarations are only valid at top level
pattern Single :: t -> [t] -- Defined at <interactive>:4:9
pattern Single :: t -> [t] -- Defined at <interactive>:4:1
foo :: [Bool] -> [Bool]
[False]
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment