Mon Nov 20 20:50:48 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/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
Link       : http://git.haskell.org/haddock.git/commitdiff/08e592eb55c4f4f86fe824e572517be7e44b2cb8

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

commit 08e592eb55c4f4f86fe824e572517be7e44b2cb8
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Wed Jul 22 00:09:10 2015 +0200

    Fix type renamer bug with incorrect names being generated.


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

08e592eb55c4f4f86fe824e572517be7e44b2cb8
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 45 ++++++++++++++--------
 1 file changed, 30 insertions(+), 15 deletions(-)

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index c127ebb..fccdaa9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -16,6 +16,7 @@ import Haddock.Types
 
 import GHC
 import Name
+import FastString
 
 import Control.Monad
 import Control.Monad.Trans.RWS
@@ -104,6 +105,20 @@ parseTupleArity ('(':commas) = do
 parseTupleArity _ = Nothing
 
 
+type NameRep = FastString
+
+getNameRep :: NamedThing name => name -> NameRep
+getNameRep = occNameFS . getOccName
+
+nameRepString :: NameRep -> String
+nameRepString = unpackFS
+
+stringNameRep :: String -> NameRep
+stringNameRep = mkFastString
+
+setInternalNameRep :: SetName name => NameRep -> name -> name
+setInternalNameRep = setInternalOccName . mkVarOccFS
+
 setInternalOccName :: SetName name => OccName -> name -> name
 setInternalOccName occ name =
     setName nname' name
@@ -112,11 +127,11 @@ setInternalOccName occ name =
     nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
 
 
-rename :: SetName name => Set OccName -> HsType name -> HsType name
+rename :: SetName name => Set NameRep -> HsType name -> HsType name
 rename fv typ = fst $ evalRWS (renameType typ) fv Map.empty
 
 
-type Rename name a = RWS (Set OccName) () (Map Name name) a
+type Rename name a = RWS (Set NameRep) () (Map Name name) a
 
 
 renameType :: SetName name => HsType name -> Rename name (HsType name)
@@ -157,7 +172,7 @@ renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
 
 
 freeVariables :: forall name. (NamedThing name, DataId name)
-              => HsType name -> Set OccName
+              => HsType name -> Set NameRep
 freeVariables =
     everythingWithState Set.empty Set.union query
   where
@@ -166,7 +181,7 @@ freeVariables =
             (Set.empty, Set.union ctx (bndrsNames bndrs))
         Just (HsTyVar name)
             | getName name `Set.member` ctx -> (Set.empty, ctx)
-            | otherwise -> (Set.singleton $ getOccName name, ctx)
+            | otherwise -> (Set.singleton $ getNameRep name, ctx)
         _ -> (Set.empty, ctx)
     bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
 
@@ -208,7 +223,7 @@ renameNameBndr name = do
     env <- get
     case Map.lookup (getName name) env of
         Just name' -> pure name'
-        Nothing | getOccName name `Set.member` fv -> freshName name
+        Nothing | getNameRep name `Set.member` fv -> freshName name
         Nothing -> pure name
 
 
@@ -224,35 +239,35 @@ freshName :: SetName name => name -> Rename name name
 freshName name = do
     fv <- ask
     env <- get
-    let taken = Set.union fv (Set.fromList . map getOccName . Map.keys $ env)
-    let name' = setInternalOccName (findFreshName taken occ) name
+    let taken = Set.union fv (Set.fromList . map getNameRep . Map.keys $ env)
+    let name' = setInternalNameRep (findFreshName taken occ) name
     put $ Map.insert nname name' env
     return name'
   where
     nname = getName name
-    occ = nameOccName nname
+    occ = getNameRep nname
 
 
-findFreshName :: Set OccName -> OccName -> OccName
+findFreshName :: Set NameRep -> NameRep -> NameRep
 findFreshName taken =
     fromJust . List.find isFresh . alternativeNames
   where
     isFresh = not . flip Set.member taken
 
 
-alternativeNames :: OccName -> [OccName]
+alternativeNames :: NameRep -> [NameRep]
 alternativeNames name
-    | [_] <- occNameString name = letterNames ++ alternativeNames' name
+    | [_] <- nameRepString name = letterNames ++ alternativeNames' name
   where
-    letterNames = map (mkVarOcc . pure) ['a'..'z']
+    letterNames = map (stringNameRep . pure) ['a'..'z']
 alternativeNames name = alternativeNames' name
 
 
-alternativeNames' :: OccName -> [OccName]
+alternativeNames' :: NameRep -> [NameRep]
 alternativeNames' name =
-    [ mkVarOcc $ str ++ show i | i :: Int <- [0..] ]
+    [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
   where
-    str = occNameString name
+    str = nameRepString name
 
 
 located :: Functor f => (a -> f b) -> Located a -> f (Located b)

