Tue Nov 28 11:34:26 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.16,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11258,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T14529,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13,wip/ttg6-unrevert-2017-11-22
Link       : http://git.haskell.org/haddock.git/commitdiff/0495d71981573cf95f28468c7167b96ffd48ac11

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

commit 0495d71981573cf95f28468c7167b96ffd48ac11
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Sat Jul 18 21:02:07 2015 +0200

    Fill in stub behaviour with actual environment renaming.


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

0495d71981573cf95f28468c7167b96ffd48ac11
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 42 ++++++++++++++--------
 1 file 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 2c4c849..a9c4646 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

