Fill in stub behaviour with actual environment renaming.

1 files changed, 28 insertions, 14 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 2c4c8498..a9c46463 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -102,14 +102,27 @@ parseTupleArity ('(':commas) = do
 parseTupleArity _ = Nothing
 
 
-rename :: NamedThing name => HsType name -> HsType name
+class NamedThing name => SetName name where
+
+    setName :: Name -> name -> name
+
+
+setInternalOccName :: SetName name => OccName -> name -> name
+setInternalOccName occ name =
+    setName nname' name
+  where
+    nname = getName name
+    nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
+
+
+rename :: SetName name => HsType name -> HsType name
 rename = fst . evalRWS undefined Map.empty . renameType -- TODO.
 
 
 type Rename name a = RWS (Set OccName) () (Map Name name) a
 
 
-renameType :: NamedThing name => HsType name -> Rename name (HsType name)
+renameType :: SetName name => HsType name -> Rename name (HsType name)
 renameType (HsForAllTy ex mspan lbndrs lctx lt) = do
     lbndrs' <- renameLTyVarBndrs lbndrs
     HsForAllTy
@@ -146,26 +159,26 @@ renameType HsWildcardTy = pure HsWildcardTy
 renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
-renameLType :: NamedThing name => LHsType name -> Rename name (LHsType name)
+renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
 renameLType = located renameType
 
 
-renameLTypes :: NamedThing name => [LHsType name] -> Rename name [LHsType name]
+renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]
 renameLTypes = mapM renameLType
 
 
-renameContext :: NamedThing name => HsContext name
+renameContext :: SetName name => HsContext name
               -> Rename name (HsContext name)
 renameContext = renameLTypes
 
 
-renameLTyVarBndrs :: NamedThing name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
+renameLTyVarBndrs :: SetName name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
 renameLTyVarBndrs lbndrs = do
     tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
     pure $ lbndrs { hsq_tvs = tys' }
 
 
-renameTyVarBndr :: NamedThing name => HsTyVarBndr name
+renameTyVarBndr :: SetName name => HsTyVarBndr name
                 -> Rename name (HsTyVarBndr name)
 renameTyVarBndr (UserTyVar name) =
     UserTyVar <$> renameNameBndr name
@@ -173,11 +186,11 @@ renameTyVarBndr (KindedTyVar name kinds) =
     KindedTyVar <$> located renameNameBndr name <*> pure kinds
 
 
-renameLTyOp :: NamedThing name => LHsTyOp name -> Rename name (LHsTyOp name)
+renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
 renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
 
 
-renameNameBndr :: NamedThing name => name -> Rename name name
+renameNameBndr :: SetName name => name -> Rename name name
 renameNameBndr name = do
     fv <- ask
     when (getOccName name `Set.member` fv) $
@@ -185,7 +198,7 @@ renameNameBndr name = do
     renameName name
 
 
-renameName :: NamedThing name => name -> Rename name name
+renameName :: SetName name => name -> Rename name name
 renameName name = do
     env <- get
     pure $ case Map.lookup (getName name) env of
@@ -193,15 +206,16 @@ renameName name = do
         Nothing -> name
 
 
-freshName :: NamedThing name => name -> Rename name ()
+freshName :: SetName name => name -> Rename name ()
 freshName name = do
     fv <- ask
     env <- get
     let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env)
-    let name' = undefined $ findFreshName taken occ
-    put $ Map.insert (getName name) name' env
+    let name' = setInternalOccName (findFreshName taken occ) name
+    put $ Map.insert nname name' env
   where
-    occ = getOccName name
+    nname = getName name
+    occ = nameOccName nname
 
 
 findFreshName :: Set OccName -> OccName -> OccName