From 08e592eb55c4f4f86fe824e572517be7e44b2cb8 Mon Sep 17 00:00:00 2001 From: Ɓukasz Hanuszczak Date: Wed, 22 Jul 2015 00:09:10 +0200 Subject: Fix type renamer bug with incorrect names being generated. --- .../src/Haddock/Backends/Xhtml/Specialize.hs | 45 ++++++++++++++-------- 1 file changed, 30 insertions(+), 15 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 c127ebbd..fccdaa95 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) -- cgit v1.2.3