[commit: hoopl] master: Put back the newtype around Label (5ee8f36)

Repository : ssh://darcs.haskell.org//srv/darcs/packages/hoopl

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/5ee8f3665e13e0f9baac8943d8deb207c2453604

>---------------------------------------------------------------

commit 5ee8f3665e13e0f9baac8943d8deb207c2453604
Author: Simon Marlow <[email protected]>
Date:   Fri Jul 6 14:31:24 2012 +0100

    Put back the newtype around Label
    
    It was a pain having Label==Int, because we can't make Label-specific
    instances for things.  The performance drop doesn't seem significant.

>---------------------------------------------------------------

 src/Compiler/Hoopl/Label.hs   |   77 ++++++++++++++++++++++++++++++++++++-----
 src/Compiler/Hoopl/MkGraph.hs |    6 ++--
 2 files changed, 71 insertions(+), 12 deletions(-)

diff --git a/src/Compiler/Hoopl/Label.hs b/src/Compiler/Hoopl/Label.hs
index e8a60ef..e8a7f0b 100644
--- a/src/Compiler/Hoopl/Label.hs
+++ b/src/Compiler/Hoopl/Label.hs
@@ -22,22 +22,81 @@ import Compiler.Hoopl.Unique
 --		Label
 -----------------------------------------------------------------------------
 
-type Label = Unique
-
-lblToUnique :: Label -> Unique
-lblToUnique = id
+newtype Label = Label { lblToUnique :: Unique }
+  deriving (Eq, Ord)
 
 uniqueToLbl :: Unique -> Label
-uniqueToLbl = id
+uniqueToLbl = Label
 
---instance Show Label where
---  show (Label n) = "L" ++ show n
+instance Show Label where
+  show (Label n) = "L" ++ show n
 
 freshLabel :: UniqueMonad m => m Label
 freshLabel = freshUnique >>= return . uniqueToLbl
 
-type LabelSet = UniqueSet
-type LabelMap v = UniqueMap v
+-----------------------------------------------------------------------------
+-- LabelSet
+
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
+
+instance IsSet LabelSet where
+  type ElemOf LabelSet = Label
+
+  setNull (LS s) = setNull s
+  setSize (LS s) = setSize s
+  setMember (Label k) (LS s) = setMember k s
+
+  setEmpty = LS setEmpty
+  setSingleton (Label k) = LS (setSingleton k)
+  setInsert (Label k) (LS s) = LS (setInsert k s)
+  setDelete (Label k) (LS s) = LS (setDelete k s)
+
+  setUnion (LS x) (LS y) = LS (setUnion x y)
+  setDifference (LS x) (LS y) = LS (setDifference x y)
+  setIntersection (LS x) (LS y) = LS (setIntersection x y)
+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
+
+  setFold k z (LS s) = setFold (k . uniqueToLbl) z s
+
+  setElems (LS s) = map uniqueToLbl (setElems s)
+  setFromList ks = LS (setFromList (map lblToUnique ks))
+
+-----------------------------------------------------------------------------
+-- LabelMap
+
+newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show)
+
+instance IsMap LabelMap where
+  type KeyOf LabelMap = Label
+
+  mapNull (LM m) = mapNull m
+  mapSize (LM m) = mapSize m
+  mapMember (Label k) (LM m) = mapMember k m
+  mapLookup (Label k) (LM m) = mapLookup k m
+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
+
+  mapEmpty = LM mapEmpty
+  mapSingleton (Label k) v = LM (mapSingleton k v)
+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
+  mapDelete (Label k) (LM m) = LM (mapDelete k m)
+
+  mapUnion (LM x) (LM y) = LM (mapUnion x y)
+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)
+  mapDifference (LM x) (LM y) = LM (mapDifference x y)
+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
+
+  mapMap f (LM m) = LM (mapMap f m)
+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)
+  mapFold k z (LM m) = mapFold k z m
+  mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m
+
+  mapElems (LM m) = mapElems m
+  mapKeys (LM m) = map uniqueToLbl (mapKeys m)
+  mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]
+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
 
 -----------------------------------------------------------------------------
 -- FactBase
diff --git a/src/Compiler/Hoopl/MkGraph.hs b/src/Compiler/Hoopl/MkGraph.hs
index 769b28b..a78f46d 100644
--- a/src/Compiler/Hoopl/MkGraph.hs
+++ b/src/Compiler/Hoopl/MkGraph.hs
@@ -14,7 +14,7 @@ module Compiler.Hoopl.MkGraph
     )
 where
 
-import Compiler.Hoopl.Label (Label)
+import Compiler.Hoopl.Label (Label, uniqueToLbl)
 import Compiler.Hoopl.Block
 import Compiler.Hoopl.Graph as U
 import Compiler.Hoopl.Unique
@@ -147,8 +147,8 @@ class Uniques u where
 instance Uniques Unique where
   withFresh f = A $ freshUnique >>= (graphOfAGraph . f)
 
---instance Uniques Label where
---  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)
+instance Uniques Label where
+  withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl)
 
 -- | Lifts binary 'Graph' functions into 'AGraph' functions.
 liftA2 :: (Graph  n a b -> Graph  n c d -> Graph  n e f)