Make the 'extract' functions to find free type variables
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 26 Mar 2012 08:00:58 +0000 (09:00 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 26 Mar 2012 08:00:58 +0000 (09:00 +0100)
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.

compiler/hsSyn/HsUtils.lhs
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs

index 2049ebb..ab1449f 100644 (file)
@@ -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}
 
 
index 9111475..bfea5ba 100644 (file)
@@ -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
index dc5e556..27ae036 100644 (file)
@@ -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)
index 6e89b12..09a5b43 100644 (file)
@@ -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 $