X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FNameSet.lhs;h=bef9e928fda04721e208bb05be703a18c0398a21;hp=1c411592941844ac12382b561f9b0ab2351a44bb;hb=c648345e3d82c0c40333bfd8ddea2633e21b08dc;hpb=ad94d40948668032189ad22a0ad741ac1f645f50

diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs
index 1c41159..bef9e92 100644
--- a/compiler/basicTypes/NameSet.lhs
+++ b/compiler/basicTypes/NameSet.lhs
@@ -4,35 +4,39 @@
 %
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
--- for details
-
 module NameSet (
-	-- Sets of Names
+	-- * Names set type
 	NameSet,
+	
+	-- ** Manipulating these sets
 	emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
 	minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, 
 	delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
 	intersectsNameSet, intersectNameSet,
 	
-	-- Free variables
-	FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV, 
+	-- * Free variables
+	FreeVars,
+	
+	-- ** Manipulating sets of free variables
+	isEmptyFVs, emptyFVs, plusFVs, plusFV, 
 	mkFVs, addOneFV, unitFV, delFV, delFVs,
 
-	-- Defs and uses
+	-- * Defs and uses
 	Defs, Uses, DefUse, DefUses,
+	
+	-- ** Manipulating defs and uses
 	emptyDUs, usesOnly, mkDUs, plusDU, 
 	findUses, duDefs, duUses, allUses
     ) where
 
 #include "HsVersions.h"
+#include "Typeable.h"
 
 import Name
 import UniqSet
+import Util
+
+import Data.Data
 \end{code}
 
 %************************************************************************
@@ -43,6 +47,20 @@ import UniqSet
 
 \begin{code}
 type NameSet = UniqSet Name
+
+-- TODO: These Data/Typeable instances look very dubious. Surely either
+-- UniqFM should have the instances, or this should be a newtype?
+
+nameSetTc :: TyCon
+nameSetTc = mkTyCon "NameSet"
+instance Typeable NameSet where { typeOf _ = mkTyConApp nameSetTc [] }
+
+instance Data NameSet where
+  gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly
+  toConstr _   = abstractConstr "NameSet"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "NameSet"
+
 emptyNameSet	   :: NameSet
 unitNameSet	   :: Name -> NameSet
 addListToNameSet   :: NameSet -> [Name] -> NameSet
@@ -59,8 +77,9 @@ delListFromNameSet :: NameSet -> [Name] -> NameSet
 foldNameSet	   :: (Name -> b -> b) -> b -> NameSet -> b
 filterNameSet	   :: (Name -> Bool) -> NameSet -> NameSet
 intersectNameSet   :: NameSet -> NameSet -> NameSet
-intersectsNameSet  :: NameSet -> NameSet -> Bool 	-- True if non-empty intersection
-	-- (s1 `intersectsNameSet` s2) doesn't compute s2 if s1 is empty
+intersectsNameSet  :: NameSet -> NameSet -> Bool
+-- ^ True if there is a non-empty intersection.
+-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty
 
 isEmptyNameSet    = isEmptyUniqSet
 emptyNameSet	  = emptyUniqSet
@@ -104,6 +123,7 @@ mkFVs	 :: [Name] -> FreeVars
 delFV    :: Name -> FreeVars -> FreeVars
 delFVs   :: [Name] -> FreeVars -> FreeVars
 
+isEmptyFVs :: NameSet -> Bool
 isEmptyFVs  = isEmptyNameSet
 emptyFVs    = emptyNameSet
 plusFVs     = unionManyNameSets
@@ -123,21 +143,24 @@ delFVs ns s = delListFromNameSet s ns
 %************************************************************************
 
 \begin{code}
+-- | A set of names that are defined somewhere
 type Defs = NameSet
-type Uses = NameSet
 
-type DefUses = [DefUse]
-	-- In dependency order: earlier Defs scope over later Uses
+-- | A set of names that are used somewhere
+type Uses = NameSet
 
+-- | @(Just ds, us) =>@ The use of any member of the @ds@
+--                      implies that all the @us@ are used too.
+--                      Also, @us@ may mention @ds@.
+--
+-- @Nothing =>@ Nothing is defined in this group, but
+-- 	        nevertheless all the uses are essential.
+--	        Used for instance declarations, for example
 type DefUse  = (Maybe Defs, Uses)
-	-- For items (Just ds, us), the use of any member 
-	-- of the ds implies that all the us are used too
-	--
-	-- Also, us may mention ds
-	--
-	-- Nothing => Nothing defined in this group, but
-	-- 	      nevertheless all the uses are essential.
-	--	      Used for instance declarations, for example
+
+-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses'
+--   In a single (def, use) pair, the defs also scope over the uses
+type DefUses = [DefUse]
 
 emptyDUs :: DefUses
 emptyDUs = []
@@ -154,32 +177,28 @@ plusDU = (++)
 duDefs :: DefUses -> Defs
 duDefs dus = foldr get emptyNameSet dus
   where
-    get (Nothing, u1) d2 = d2
-    get (Just d1, u1) d2 = d1 `unionNameSets` d2
+    get (Nothing, _u1) d2 = d2
+    get (Just d1, _u1) d2 = d1 `unionNameSets` d2
 
-duUses :: DefUses -> Uses
--- Just like allUses, but defs are not eliminated
-duUses dus = foldr get emptyNameSet dus
+allUses :: DefUses -> Uses
+-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned
+allUses dus = foldr get emptyNameSet dus
   where
-    get (d1, u1) u2 = u1 `unionNameSets` u2
+    get (_d1, u1) u2 = u1 `unionNameSets` u2
 
-allUses :: DefUses -> Uses
--- Collect all uses, regardless of
--- whether the group is itself used,
--- but remove defs on the way
-allUses dus
-  = foldr get emptyNameSet dus
+duUses :: DefUses -> Uses
+-- ^ Collect all 'Uses', regardless of whether the group is itself used,
+-- but remove 'Defs' on the way
+duUses dus = foldr get emptyNameSet dus
   where
     get (Nothing,   rhs_uses) uses = rhs_uses `unionNameSets` uses
     get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
 				     `minusNameSet` defs
 
 findUses :: DefUses -> Uses -> Uses
--- Given some DefUses and some Uses, 
--- find all the uses, transitively. 
--- The result is a superset of the input uses;
--- and includes things defined in the input DefUses
--- (but only if they are used)
+-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively.
+-- The result is a superset of the input 'Uses'; and includes things defined 
+-- in the input 'DefUses' (but only if they are used)
 findUses dus uses 
   = foldr get uses dus
   where
@@ -187,7 +206,7 @@ findUses dus uses
 	= rhs_uses `unionNameSets` uses
     get (Just defs, rhs_uses) uses
 	| defs `intersectsNameSet` uses 	-- Used
-	|| not (all (reportIfUnused . nameOccName) (nameSetToList defs))
+	|| any (startsWithUnderscore . nameOccName) (nameSetToList defs)
 		-- At least one starts with an "_", 
 		-- so treat the group as used
 	= rhs_uses `unionNameSets` uses