From d508387d8bca5cdc7e29127ac859f170b66f81df Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 18 Jul 2015 20:48:48 +0200
Subject: Implement simple mechanism for generating new type names.

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

(limited to 'haddock-api/src/Haddock/Backends/Xhtml')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index d2a51fac..2c4c8498 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)
-- 
cgit v1.2.3