From 4d765e3cd0a735f9a7e8d13fb6633f9ee534fbfb Mon Sep 17 00:00:00 2001 From: Moritz Drexl Date: Sat, 5 Aug 2017 16:44:40 +0200 Subject: Fix renaming after instance signature specializing (#660) * rework rename * Add regression test for Bug 613 * update tests * update changelog --- CHANGES.md | 2 + haddock-api/src/Haddock/Interface/Specialize.hs | 132 +++++------- html-test/ref/Bug613.html | 260 ++++++++++++++++++++++++ html-test/ref/Instances.html | 178 ++++++++-------- html-test/src/Bug613.hs | 16 ++ 5 files changed, 418 insertions(+), 170 deletions(-) create mode 100644 html-test/ref/Bug613.html create mode 100644 html-test/src/Bug613.hs diff --git a/CHANGES.md b/CHANGES.md index bf60817a..5050339d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,8 @@ * to be released + * Fix renaming of type variables after specializing instance method signatures (#613) + * Move markup related data types to haddock-library ## Changes in version 2.18.1 diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index da8c3e7b..84168151 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -17,7 +17,6 @@ import Name import FastString import Control.Monad -import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Data.Data @@ -204,7 +203,7 @@ setInternalOccName occ name = -- | Compute set of free variables of given type. freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set NameRep + => HsType name -> Set Name freeVariables = everythingWithState Set.empty Set.union query where @@ -213,7 +212,7 @@ freeVariables = (Set.empty, Set.union ctx (bndrsNames bndrs)) Just (HsTyVar _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getNameRep name, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) @@ -225,33 +224,36 @@ freeVariables = -- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something --- like @(a -> c) -> b@). -rename :: SetName name => Set NameRep -> HsType name -> HsType name -rename fv typ = runReader (renameType typ) $ RenameEnv - { rneFV = fv - , rneCtx = Map.empty - } - +-- like @(a -> b0) -> b@). +rename :: (Eq name, DataId name, SetName name) + => Set Name -> HsType name -> HsType name +rename fv typ = evalState (renameType typ) env + where + env = RenameEnv + { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv + , rneSigFVs = Set.map getNameRep $ freeVariables typ + , rneCtx = Map.empty + } + mkPair name = (getNameRep name, name) -- | Renaming monad. -type Rename name = Reader (RenameEnv name) - --- | Binding generation monad. -type Rebind name = State (RenameEnv name) +type Rename name = State (RenameEnv name) data RenameEnv name = RenameEnv - { rneFV :: Set NameRep - , rneCtx :: Map Name name - } + { rneHeadFVs :: Map NameRep Name + , rneSigFVs :: Set NameRep + , rneCtx :: Map Name name + } -renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> +renameType :: (Eq name, SetName name) + => HsType name -> Rename name (HsType name) +renameType (HsForAllTy bndrs lt) = HsForAllTy - <$> pure bndrs' + <$> mapM (located renameBinder) bndrs <*> renameLType lt renameType (HsQualTy lctxt lt) = - HsQualTy + HsQualTy <$> located renameContext lctxt <*> renameLType lt renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name @@ -281,85 +283,61 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" -renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType :: (Eq name, SetName name) + => LHsType name -> Rename name (LHsType name) renameLType = located renameType -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes :: (Eq name, SetName name) + => [LHsType name] -> Rename name [LHsType name] renameLTypes = mapM renameLType -renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext :: (Eq name, SetName name) + => HsContext name -> Rename name (HsContext name) renameContext = renameLTypes -{- -renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) -renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname --} - - -renameName :: SetName name => name -> Rename name name -renameName name = do - RenameEnv { rneCtx = ctx } <- ask - pure $ fromMaybe name (Map.lookup (getName name) ctx) - - -rebind :: SetName name - => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) - -> Rename name a -rebind lbndrs action = do - (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask - local (const env') (action lbndrs') - -rebindLTyVarBndrs :: SetName name - => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] -rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs +renameBinder :: (Eq name, SetName name) + => HsTyVarBndr name -> Rename name (HsTyVarBndr name) +renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname +renameBinder (KindedTyVar lname lkind) = + KindedTyVar <$> located renameName lname <*> located renameType lkind -rebindTyVarBndr :: SetName name - => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar (L l name)) = - UserTyVar . L l <$> rebindName name -rebindTyVarBndr (KindedTyVar name kinds) = - KindedTyVar <$> located rebindName name <*> pure kinds - - -rebindName :: SetName name => name -> Rebind name name -rebindName name = do +-- | Core renaming logic. +renameName :: (Eq name, SetName name) => name -> Rename name name +renameName name = do RenameEnv { .. } <- get - taken <- takenNames case Map.lookup (getName name) rneCtx of - Just name' -> pure name' - Nothing | getNameRep name `Set.member` taken -> freshName name - Nothing -> reuseName name + Nothing + | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs + , headTv /= getName name -> freshName name + Just name' -> return name' + _ -> return name -- | Generate fresh occurrence name, put it into context and return. -freshName :: SetName name => name -> Rebind name name +freshName :: SetName name => name -> Rename name name freshName name = do - env@RenameEnv { .. } <- get taken <- takenNames let name' = setInternalNameRep (findFreshName taken rep) name - put $ env { rneCtx = Map.insert nname name' rneCtx } + modify $ \rne -> rne + { rneCtx = Map.insert (getName name) name' (rneCtx rne) } return name' where nname = getName name rep = getNameRep nname -reuseName :: SetName name => name -> Rebind name name -reuseName name = do - env@RenameEnv { .. } <- get - put $ env { rneCtx = Map.insert (getName name) name rneCtx } - return name - - -takenNames :: NamedThing name => Rebind name (Set NameRep) +takenNames :: NamedThing name => Rename name (Set NameRep) takenNames = do RenameEnv { .. } <- get - return $ Set.union rneFV (ctxElems rneCtx) + return $ headReps rneHeadFVs `Set.union` + rneSigFVs `Set.union` + ctxElems rneCtx where + headReps = Set.fromList . Map.keys ctxElems = Set.fromList . map getNameRep . Map.elems @@ -371,15 +349,7 @@ findFreshName taken = alternativeNames :: NameRep -> [NameRep] -alternativeNames name - | [_] <- nameRepString name = letterNames ++ alternativeNames' name - where - letterNames = map (stringNameRep . pure) ['a'..'z'] -alternativeNames name = alternativeNames' name - - -alternativeNames' :: NameRep -> [NameRep] -alternativeNames' name = +alternativeNames name = [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] where str = nameRepString name diff --git a/html-test/ref/Bug613.html b/html-test/ref/Bug613.html new file mode 100644 index 00000000..924f37d4 --- /dev/null +++ b/html-test/ref/Bug613.html @@ -0,0 +1,260 @@ +Bug613

Safe HaskellSafe

Bug613

Synopsis

Documentation

class Functor f where #

Minimal complete definition

fmap

Methods

fmap :: (a -> b) -> f a -> f b #

Instances

Functor (Either a) #

Methods

fmap :: (a0 -> b) -> Either a a0 -> Either a b #

Functor (ThreeVars a0 a) #

Methods

fmap :: (a1 -> b) -> ThreeVars a0 a a1 -> ThreeVars a0 a b #

data ThreeVars a0 a b #

Phantom type a0 is added to block the first renaming from a to a0. This ensures that the renamer doesn't create a new conflict

Constructors

ThreeVars a b

Instances

Functor (ThreeVars a0 a) #

Methods

fmap :: (a1 -> b) -> ThreeVars a0 a a1 -> ThreeVars a0 a b #

\ No newline at end of file diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html index b014e8df..c9ca6f82 100644 --- a/html-test/ref/Instances.html +++ b/html-test/ref/Instances.html @@ -102,9 +102,9 @@ window.onload = function () {pageLoad();}; ><~~ Int) -> a -> a ) -> a0 -> a <~~ a a0 #

<~~ (a <~~ a)) -> a0)) -> Int -> a <~~Either a Int -> a -> -> a0 -> Either a a a a0 #

Either a (Either a a) -> a a0) -> Int -> Eitherfoo :: (f a, Int) -> a -> (f a, a) ) -> a0 -> (f a, a0) #

foo' :: (f a, (f a, a)) -> :: (f a, (f a, a0)) -> Int -> (f a, (f a, Int<~~ Int) -> a -> a ) -> a0 -> a <~~ a a0 #

<~~ (a <~~ a)) -> a0)) -> Int -> a <~~foo :: (a, a, Int) -> a -> (a, a, a) ) -> a0 -> (a, a, a0) #

foo' :: (a, a, (a, a, a)) -> :: (a, a, (a, a, a0)) -> Int -> (a, a, (a, a, IntQuux a b Int -> a -> -> a0 -> Quux a b a a b a0 #

Quux a b (Quux a b a) -> a b a0) -> Int -> QuuxLiftedRep) a Int -> a -> ( -> a0 -> (LiftedRep -> LiftedRep) a a ) a a0 #

LiftedRep -> LiftedRep) a a) -> ) a a0) -> Int -> (LiftedRep

bar' :: (a, b, (a, b, (a, b, a))) -> (a, b, (a, b, (a, b, b))) :: (a, b, (a, b, (a, b, a))) -> (a, b, (a, b, (a, b, b0))) #

bar0 :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b), (a, b, c)) :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b0), (a, b, c)) #

bar1 :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b), (a, b, c)) :: ((a, b, (a, b, a)), (a, b, (a, b, a))) -> ((a, b, b0), (a, b, c)) #

Quux a c (Quux a c b)) a c b0)) #

Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

forall a. a -> a) -> (b, forall a. a -> [c]) -> (b, c) c0. c0 -> [c]) -> (b, c1) #

forall b. (forall a. a -> [c]) -> c) -> b. b -> [c]) -> c0) -> forall a. a -> b c1. c1 -> b #

baz :: (a -> b) -> (forall c. c -> c) -> (b, a0. a0 -> a0) -> (b0, forall c. c -> a -> b) -> (b, c) c. c -> a -> b) -> (b0, c) #

baz' :: b -> ( :: b0 -> (forall c. c -> a -> b) -> ( b1. b1 -> a -> b) -> (forall c. c -> a -> b) -> [(b, a -> b)] b2. b2 -> a -> b) -> [(b0, a -> b)] #

baz'' :: b -> ( :: b0 -> (forall c. ( b1. (forall d. d -> a -> b) -> c) -> b2. b2 -> a -> b) -> c) -> forall c. c -> b c. c -> b0 #

baz :: (a, b, c) -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> (a, b, c)) -> (b, c) c0. c0 -> (a, b, c)) -> (b0, c1) #

baz' :: b -> ( :: b0 -> (forall d. d -> (a, b, c)) -> ( b1. b1 -> (a, b, c)) -> (forall d. d -> (a, b, c)) -> [(b, (a, b, c))] b2. b2 -> (a, b, c)) -> [(b0, (a, b, c))] #

baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> (a, b, c)) -> c) -> b2. b2 -> (a, b, c)) -> c0) -> forall d. d -> b c1. c1 -> b0 #

Quux a b c -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> c0. c0 -> Quux a b c) -> (b, c) a b c) -> (b0, c1) #

baz' :: b -> ( :: b0 -> (forall d. d -> b1. b1 -> Quux a b c) -> (forall d. d -> b2. b2 -> Quux a b c) -> [(b, a b c) -> [(b0, Quux a b c)] #

baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> b2. b2 -> Quux a b c) -> c) -> a b c) -> c0) -> forall d. d -> b c1. c1 -> b0 #

baz :: (a, [b], b, a) -> (forall c. c -> c) -> (b, a0. a0 -> a0) -> (b0, forall c. c -> (a, [b], b, a)) -> (b, c) c. c -> (a, [b], b, a)) -> (b0, c) #

baz' :: b -> ( :: b0 -> (forall c. c -> (a, [b], b, a)) -> ( b1. b1 -> (a, [b], b, a)) -> (forall c. c -> (a, [b], b, a)) -> [(b, (a, [b], b, a))] b2. b2 -> (a, [b], b, a)) -> [(b0, (a, [b], b, a))] #

baz'' :: b -> ( :: b0 -> (forall c. ( b1. (forall d. d -> (a, [b], b, a)) -> c) -> b2. b2 -> (a, [b], b, a)) -> c) -> forall c. c -> b c. c -> b0 #

Quux a b Int -> a -> -> a0 -> Quux a b a a b a0 #

Quux a b (Quux a b a) -> a b a0) -> Int -> QuuxQuux a c (Quux a c b)) a c b0)) #

Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

Quux a b c -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> c0. c0 -> Quux a b c) -> (b, c) a b c) -> (b0, c1) #

baz' :: b -> ( :: b0 -> (forall d. d -> b1. b1 -> Quux a b c) -> (forall d. d -> b2. b2 -> Quux a b c) -> [(b, a b c) -> [(b0, Quux a b c)] #

baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> b2. b2 -> Quux a b c) -> c) -> a b c) -> c0) -> forall d. d -> b c1. c1 -> b0 #

b) -> f a -> f b + +instance Functor (Either a) where + fmap _ (Left x) = Left x + fmap f (Right y) = Right (f y) + +-- | Phantom type a0 is added to block the first renaming from a to a0. This ensures that the renamer doesn't create a new conflict +data ThreeVars a0 a b = ThreeVars a b + +instance Functor (ThreeVars a0 a) where + fmap f (ThreeVars a b) = ThreeVars a (f b) -- cgit v1.2.3