Tue Nov 28 11:34:40 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/d508387d8bca5cdc7e29127ac859f170b66f81df

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

commit d508387d8bca5cdc7e29127ac859f170b66f81df
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Sat Jul 18 20:48:48 2015 +0200

    Implement simple mechanism for generating new type names.


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

d508387d8bca5cdc7e29127ac859f170b66f81df
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 29 +++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index d2a51fa..2c4c849 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -19,6 +19,8 @@ import Control.Monad
 import Control.Monad.Trans.RWS
 
 import Data.Data
+import qualified Data.List as List
+import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -185,14 +187,35 @@ renameNameBndr name = do
 
 renameName :: NamedThing name => name -> Rename name name
 renameName name = do
-    rnmap <- get
-    pure $ case Map.lookup (getName name) rnmap of
+    env <- get
+    pure $ case Map.lookup (getName name) env of
         Just name' -> name'
         Nothing -> name
 
 
 freshName :: NamedThing name => name -> Rename name ()
-freshName _ = pure () -- TODO.
+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
+  where
+    occ = getOccName name
+
+
+findFreshName :: Set OccName -> OccName -> OccName
+findFreshName taken =
+    fromJust . List.find isFresh . alternativeNames
+  where
+    isFresh = not . flip Set.member taken
+
+
+alternativeNames :: OccName -> [OccName]
+alternativeNames name =
+    [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ]
+  where
+    str = occNameString name
 
 
 located :: Functor f => (a -> f b) -> Located a -> f (Located b)

