Give Uniq[D]FM a phantom type for its key.

This fixes #17667 and should help to avoid such issues going forward.

The changes are mostly mechanical in nature. With two notable
exceptions.

* The register allocator.

  The register allocator references registers by distinct uniques.
  However they come from the types of VirtualReg, Reg or Unique in
  various places. As a result we sometimes cast the key type of the
  map and use functions which operate on the now typed map but take
  a raw Unique as actual key. The logic itself has not changed it
  just becomes obvious where we do so now.

* <Type>Env Modules.

As an example a ClassEnv is currently queried using the types `Class`,
`Name`, and `TyCon`. This is safe since for a distinct class value all
these expressions give the same unique.

    getUnique cls
    getUnique (classTyCon cls)
    getUnique (className cls)
    getUnique (tcName $ classTyCon cls)

This is for the most part contained within the modules defining the
interface. However it requires us to play dirty when we are given a
`Name` to lookup in a `UniqFM Class a` map. But again the logic did
not change and it's for the most part hidden behind the Env Module.

Some of these cases could be avoided by refactoring but this is left
for future work.

We also bump the haddock submodule as it uses UniqFM.

2 files changed, 9 insertions, 7 deletions

diff --git a/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs b/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs
index 1db2693c6b..b33039ca7b 100644
--- a/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs
+++ b/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs
@@ -30,4 +30,4 @@ pass g = do
 annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]
 annotationsOn guts bndr = do
   (_, anns) <- getAnnotations deserializeWithData guts
-  return $ lookupWithDefaultUFM anns [] (varUnique bndr)
+  return $ lookupWithDefaultUFM_Directly anns [] (varUnique bndr)
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
index 45a0205eb0..49a3a6cffa 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
@@ -46,14 +46,16 @@ findNameBndr target b
 mainPass :: ModGuts -> CoreM ModGuts
 mainPass guts = do
     putMsgS "Simple Plugin Pass Run"
-    (_, anns) <- getAnnotations deserializeWithData guts
-    bindsOnlyPass (mapM (changeBind anns Nothing)) guts
+    (_, anns) <- getAnnotations deserializeWithData guts :: CoreM (ModuleEnv [ReplaceWith], NameEnv [ReplaceWith])
+    -- Var's have the same uniques as their names. Making a cast from NameEnv to VarEnv safe.
+    let anns' = unsafeCastUFMKey anns :: VarEnv [ReplaceWith]
+    bindsOnlyPass (mapM (changeBind anns' Nothing)) guts
 
-changeBind :: UniqFM [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind
+changeBind :: VarEnv [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind
 changeBind anns mb_replacement (NonRec b e) = changeBindPr anns mb_replacement b e >>= (return . uncurry NonRec)
 changeBind anns mb_replacement (Rec bes) = liftM Rec $ mapM (uncurry (changeBindPr anns mb_replacement)) bes
 
-changeBindPr :: UniqFM [ReplaceWith] -> Maybe String -> CoreBndr -> CoreExpr -> CoreM (CoreBndr, CoreExpr)
+changeBindPr :: VarEnv [ReplaceWith] -> Maybe String -> CoreBndr -> CoreExpr -> CoreM (CoreBndr, CoreExpr)
 changeBindPr anns mb_replacement b e = do
     case lookupWithDefaultUFM anns [] b of
         [] -> do
@@ -65,7 +67,7 @@ changeBindPr anns mb_replacement b e = do
         _ -> do dflags <- getDynFlags
                 error ("Too many change_anns on one binder:" ++ showPpr dflags b)
 
-changeExpr :: UniqFM [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr
+changeExpr :: VarEnv [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr
 changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in case e of
         Lit (LitString _) -> case mb_replacement of
                 Nothing -> return e
@@ -80,5 +82,5 @@ changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in ca
         Tick t e -> liftM (Tick t) (go e)
         _ -> return e
 
-changeAlt :: UniqFM [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt
+changeAlt :: VarEnv [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt
 changeAlt anns mb_replacement (con, bs, e) = liftM (\e' -> (con, bs, e')) (changeExpr anns mb_replacement e)