aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-18 20:48:48 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:30 +0100
commitd508387d8bca5cdc7e29127ac859f170b66f81df (patch)
tree026d0a9ed20be4ae247f545a2bd149560605d22e /haddock-api/src/Haddock/Backends/Xhtml
parent4b352b94f07436d45dfcce8070c2f8301218b9ac (diff)
Implement simple mechanism for generating new type names.
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs29
1 files 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 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)