Commit a44c3d90 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Make the 'extract' functions to find free type variables

of an HsType return RdrNames rather than (Located RdrNames).

This means less clutter, and the individual locations are
a bit arbitrary if a name occurs more than once.
parent e5beffb7
......@@ -269,9 +269,9 @@ mkHsBSig :: a -> HsBndrSig a
mkHsBSig x = HsBSig x placeHolderBndrs
-------------
userHsTyVarBndrs :: SrcSpan -> [Located name] -> [Located (HsTyVarBndr name)]
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | L _ v <- bndrs ]
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
\end{code}
......
......@@ -70,11 +70,11 @@ import Bag ( Bag, emptyBag, consBag, foldrBag )
import Outputable
import FastString
import Maybes
import Util ( filterOut )
import Control.Applicative ((<$>))
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.List ( nubBy )
import Data.List ( nub, nubBy )
import Data.Char
#include "HsVersions.h"
......@@ -91,24 +91,24 @@ extractHsTyRdrNames finds the free variables of a HsType
It's used when making the for-alls explicit.
\begin{code}
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
extractHsTyRdrTyVars :: LHsType RdrName -> [RdrName]
extractHsTyRdrTyVars ty = nub (extract_lty ty [])
extractHsTysRdrTyVars :: [LHsType RdrName] -> [Located RdrName]
extractHsTysRdrTyVars ty = nubBy eqLocated (extract_ltys ty [])
extractHsTysRdrTyVars :: [LHsType RdrName] -> [RdrName]
extractHsTysRdrTyVars ty = nub (extract_ltys ty [])
extract_lctxt :: LHsContext RdrName -> [Located RdrName] -> [Located RdrName]
extract_lctxt :: LHsContext RdrName -> [RdrName] -> [RdrName]
extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName]
extract_ltys :: [LHsType RdrName] -> [RdrName] -> [RdrName]
extract_ltys tys acc = foldr extract_lty acc tys
-- IA0_NOTE: Should this function also return kind variables?
-- (explicit kind poly)
extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
extract_lty (L loc ty) acc
extract_lty :: LHsType RdrName -> [RdrName] -> [RdrName]
extract_lty (L _ ty) acc
= case ty of
HsTyVar tv -> extract_tv loc tv acc
HsTyVar tv -> extract_tv tv acc
HsBangTy _ ty -> extract_lty ty acc
HsRecTy flds -> foldr (extract_lty . cd_fld_type) acc flds
HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
......@@ -118,14 +118,14 @@ extract_lty (L loc ty) acc
HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsIParamTy _ ty -> extract_lty ty acc
HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsOpTy ty1 (_, (L loc tv)) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
HsParTy ty -> extract_lty ty acc
HsCoreTy {} -> acc -- The type is closed
HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
HsSpliceTy {} -> acc -- Type splices mention no type variables
HsKindSig ty _ -> extract_lty ty acc
HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
HsForAllTy _ tvs cx ty -> acc ++ (filterOut (`elem` locals) $
extract_lctxt cx (extract_lty ty []))
where
locals = hsLTyVarNames tvs
......@@ -134,9 +134,9 @@ extract_lty (L loc ty) acc
HsExplicitTupleTy _ tys -> extract_ltys tys acc
HsWrapTy _ _ -> panic "extract_lty"
extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
| otherwise = acc
extract_tv :: RdrName -> [RdrName] -> [RdrName]
extract_tv tv acc | isRdrTyVar tv = tv : acc
| otherwise = acc
extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
-- Get the type variables out of the type patterns in a bunch of
......
......@@ -482,8 +482,13 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn })
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; tv_names <- mkTyVarBndrNames mb_cls (extractHsTysRdrTyVars pats)
; let loc = case pats of
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
(L loc _ : []) -> loc
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) (extractHsTysRdrTyVars pats))
-- All the free vars of the family patterns
-- with a sensible binding location
; bindLocalNamesFV tv_names $
do { (pats', pat_fvs) <- rnLHsTypes (TyDataCtx tycon) pats
; (defn', rhs_fvs) <- rnTyDefn tycon defn
......@@ -1059,7 +1064,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
-- For GADT syntax, the tvs are all the quantified tyvars
-- Hence the 'filter' in the ResTyH98 case only
; rdr_env <- getLocalRdrEnv
; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc
; let in_scope tv = tv `elemLocalRdrEnv` rdr_env
arg_tys = hsConDeclArgTys details
mentioned_tvs = case res_ty of
ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
......
......@@ -135,7 +135,7 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
-- when GlasgowExts is off, there usually won't be any, except for
-- class signatures:
-- class C a where { op :: a -> a }
forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned
tyvar_bndrs = userHsTyVarBndrs loc forall_tyvars
rnForAll doc Implicit tyvar_bndrs lctxt ty
......@@ -374,19 +374,20 @@ rnHsBndrSig :: Bool -- True <=> type sig, False <=> kind sig
-> HsBndrSig (LHsType RdrName)
-> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsBndrSig is_type doc (HsBSig ty _) thing_inside
rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
= do { name_env <- getLocalRdrEnv
; let tv_bndrs = [ tv | tv <- extractHsTyRdrTyVars ty
, not (unLoc tv `elemLocalRdrEnv` name_env) ]
, not (tv `elemLocalRdrEnv` name_env) ]
; checkHsBndrFlags is_type doc ty tv_bndrs
; bindLocatedLocalsFV tv_bndrs $ \ tv_names -> do
; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs]
; bindLocalNamesFV tv_names $ do
{ (ty', fvs1) <- rnLHsTyKi is_type doc ty
; (res, fvs2) <- thing_inside (HsBSig ty' tv_names)
; return (res, fvs1 `plusFV` fvs2) } }
checkHsBndrFlags :: Bool -> HsDocContext
-> LHsType RdrName -> [Located RdrName] -> RnM ()
-> LHsType RdrName -> [RdrName] -> RnM ()
checkHsBndrFlags is_type doc ty tv_bndrs
| is_type -- Type
= do { sig_ok <- xoptM Opt_ScopedTypeVariables
......@@ -398,7 +399,7 @@ checkHsBndrFlags is_type doc ty tv_bndrs
; unless (poly_kind || null tv_bndrs)
(addErr (badKindBndrs doc ty tv_bndrs)) }
badKindBndrs :: HsDocContext -> LHsKind RdrName -> [Located RdrName] -> SDoc
badKindBndrs :: HsDocContext -> LHsKind RdrName -> [RdrName] -> SDoc
badKindBndrs doc _kind kvs
= vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs
<+> pprQuotedList kvs)
......@@ -762,14 +763,13 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
%*********************************************************
\begin{code}
warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [Located RdrName] -> TcM ()
warnUnusedForAlls in_doc bound used
warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [RdrName] -> TcM ()
warnUnusedForAlls in_doc bound mentioned_rdrs
= ifWOptM Opt_WarnUnusedMatches $
mapM_ add_warn bound_but_not_used
where
bound_names = hsLTyVarLocNames bound
bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
mentioned_rdrs = map unLoc used
add_warn (L loc tv)
= addWarnAt loc $
......
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