From f0222eaf888dafb9fdb6dbbac0527fc28223588d Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 29 Jul 2015 19:32:32 +0200 Subject: Refactor specializer module to be independent from XHTML backend. --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 18 +- .../src/Haddock/Backends/Xhtml/Specialize.hs | 382 -------------------- haddock-api/src/Haddock/Convert.hs | 6 +- haddock-api/src/Haddock/Interface/Specialize.hs | 396 +++++++++++++++++++++ 4 files changed, 407 insertions(+), 395 deletions(-) delete mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs create mode 100644 haddock-api/src/Haddock/Interface/Specialize.hs (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 7255bf42..7da1f08e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -22,7 +22,6 @@ module Haddock.Backends.Xhtml.Decl ( import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names -import Haddock.Backends.Xhtml.Specialize import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils @@ -563,10 +562,8 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = ) where iid = instanceId origin no ihdClsName - sigs = ppInstanceSigs links splice unicode qual - clsiTyVars ihdTypes clsiSigs - ats = ppInstanceAssocTys links splice unicode qual - clsiTyVars ihdTypes clsiAssocTys + sigs = ppInstanceSigs links splice unicode qual clsiSigs + ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys TypeInst rhs -> (ptype, mdoc, []) where @@ -587,20 +584,19 @@ ppInstHead links splice unicode qual mdoc origin no (InstHead {..}) = ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification - -> LHsTyVarBndrs DocName -> [HsType DocName] -> [PseudoFamilyDecl DocName] -> [Html] -ppInstanceAssocTys links splice unicode qual bndrs tys = - map ppFamilyDecl' . map (specializePseudoFamilyDecl bndrs tys) +ppInstanceAssocTys links splice unicode qual = + map ppFamilyDecl' where ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification - -> LHsTyVarBndrs DocName -> [HsType DocName] -> [Sig DocName] + -> [Sig DocName] -> [Html] -ppInstanceSigs links splice unicode qual bndrs tys sigs = do - TypeSig lnames (L loc typ) _ <- map (specializeSig bndrs tys) sigs +ppInstanceSigs links splice unicode qual sigs = do + TypeSig lnames (L loc typ) _ <- sigs let names = map unLoc lnames return $ ppSimpleSig links splice unicode qual loc names typ diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs deleted file mode 100644 index 2295605b..00000000 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ /dev/null @@ -1,382 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} - - -module Haddock.Backends.Xhtml.Specialize - ( specializePseudoFamilyDecl, specializeSig - ) where - - -import Haddock.Syb -import Haddock.Types - -import GHC -import Name -import FastString - -import Control.Monad -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State - -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) -import qualified Data.Set as Set - - --- | Instantiate all occurrences of given name with particular type. -specialize :: (Eq name, Typeable name) - => Data a - => name -> HsType name -> a -> a -specialize name details = - everywhere $ mkT step - where - step (HsTyVar name') | name == name' = details - step typ = typ - - --- | Instantiate all occurrences of given names with corresponding types. --- --- It is just a convenience function wrapping 'specialize' that supports more --- that one specialization. -specialize' :: (Eq name, Typeable name) - => Data a - => [(name, HsType name)] -> a -> a -specialize' = flip $ foldr (uncurry specialize) - - --- | Instantiate given binders with corresponding types. --- --- Again, it is just a convenience function around 'specialize'. Note that --- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Eq name, Typeable name, DataId name) - => Data a - => LHsTyVarBndrs name -> [HsType name] - -> a -> a -specializeTyVarBndrs bndrs typs = - specialize' $ zip bndrs' typs - where - bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs - bname (UserTyVar name) = name - bname (KindedTyVar (L _ name) _) = name - - -specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) - => LHsTyVarBndrs name -> [HsType name] - -> PseudoFamilyDecl name - -> PseudoFamilyDecl name -specializePseudoFamilyDecl bndrs typs decl = - decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } - where - specializeTyVars = specializeTyVarBndrs bndrs typs - - -specializeSig :: (Eq name, Typeable name, DataId name, SetName name) - => LHsTyVarBndrs name -> [HsType name] - -> Sig name - -> Sig name -specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = - TypeSig lnames (L loc typ') prn - where - typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ - fv = foldr Set.union Set.empty . map freeVariables $ typs -specializeSig _ _ sig = sig - - --- | Make given type use tuple and list literals where appropriate. --- --- After applying 'specialize' function some terms may not use idiomatic list --- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This --- can be fixed using 'sugar' function, that will turn such types into @[a]@ --- and @(a, b, c)@. -sugar :: forall name. (NamedThing name, DataId name) - => HsType name -> HsType name -sugar = - everywhere $ mkT step - where - step :: HsType name -> HsType name - step = sugarTuples . sugarLists - - -sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp - where - name' = getName name - strName = occNameString . nameOccName $ name' -sugarLists typ = typ - - -sugarTuples :: NamedThing name => HsType name -> HsType name -sugarTuples typ = - aux [] typ - where - aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp - aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar name) - | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps - where - name' = getName name - strName = occNameString . nameOccName $ name' - suitable = case parseTupleArity strName of - Just arity -> arity == length apps - Nothing -> False - aux _ _ = typ - - --- | Compute arity of given tuple operator. --- --- >>> parseTupleArity "(,,)" --- Just 3 --- --- >>> parseTupleArity "(,,,,)" --- Just 5 --- --- >>> parseTupleArity "abc" --- Nothing --- --- >>> parseTupleArity "()" --- Nothing -parseTupleArity :: String -> Maybe Int -parseTupleArity ('(':commas) = do - n <- parseCommas commas - guard $ n /= 0 - return $ n + 1 - where - parseCommas (',':rest) = (+ 1) <$> parseCommas rest - parseCommas ")" = Just 0 - parseCommas _ = Nothing -parseTupleArity _ = Nothing - - --- | Haskell AST type representation. --- --- This type is used for renaming (more below), essentially the ambiguous (!) --- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well, --- it was 'OccName' before, but turned out that 'OccName' sometimes also --- contains namespace information, differentiating visually same types. --- --- And 'FastString' is used because it is /visual/ part of 'OccName' - it is --- not converted to 'String' or alike to avoid new allocations. Additionally, --- since it is stored mostly in 'Set', fast comparison of 'FastString' is also --- quite nice. -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 - where - nname = getName name - nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) - - --- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set NameRep -freeVariables = - everythingWithState Set.empty Set.union query - where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy _ _ bndrs _ _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar name) - | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getNameRep name, ctx) - _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs - - --- | Make given type visually unambiguous. --- --- After applying 'specialize' method, some free type variables may become --- visually ambiguous - for example, having @a -> b@ and specializing @a@ to --- @(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 - } - - --- | Renaming monad. -type Rename name = Reader (RenameEnv name) - --- | Binding generation monad. -type Rebind name = State (RenameEnv name) - -data RenameEnv name = RenameEnv - { rneFV :: Set NameRep - , rneCtx :: Map Name name - } - - -renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' -> - HsForAllTy - <$> pure ex - <*> pure mspan - <*> pure lbndrs' - <*> located renameContext lctx - <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> renameName name -renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la -renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr -renameType (HsListTy lt) = HsListTy <$> renameLType lt -renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt -renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt -renameType (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb -renameType (HsParTy lt) = HsParTy <$> renameLType lt -renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt -renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb -renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk -renameType t@(HsQuasiQuoteTy _) = pure t -renameType t@(HsSpliceTy _ _) = pure t -renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc -renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt -renameType t@(HsRecTy _) = pure t -renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ph ltys) = - HsExplicitListTy ph <$> renameLTypes ltys -renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> renameLTypes ltys -renameType t@(HsTyLit _) = pure t -renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t -renameType HsWildcardTy = pure HsWildcardTy -renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name - - -renameLType :: SetName name => LHsType name -> Rename name (LHsType name) -renameLType = located renameType - - -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] -renameLTypes = mapM renameLType - - -renameContext :: 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 $ case Map.lookup (getName name) ctx of - Just name' -> name' - Nothing -> name - - -rebind :: SetName name - => LHsTyVarBndrs name -> (LHsTyVarBndrs 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 - => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name) -rebindLTyVarBndrs lbndrs = do - tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs - pure $ lbndrs { hsq_tvs = tys' } - - -rebindTyVarBndr :: SetName name - => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar name) = - UserTyVar <$> rebindName name -rebindTyVarBndr (KindedTyVar name kinds) = - KindedTyVar <$> located rebindName name <*> pure kinds - - -rebindName :: SetName name => name -> Rebind name name -rebindName 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 - - --- | Generate fresh occurrence name, put it into context and return. -freshName :: SetName name => name -> Rebind 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 } - 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 = do - RenameEnv { .. } <- get - return $ Set.union rneFV (ctxElems rneCtx) - where - ctxElems = Set.fromList . map getNameRep . Map.elems - - -findFreshName :: Set NameRep -> NameRep -> NameRep -findFreshName taken = - fromJust . List.find isFresh . alternativeNames - where - isFresh = not . flip Set.member 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 = - [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] - where - str = nameRepString name - - -located :: Functor f => (a -> f b) -> Located a -> f (Located b) -located f (L loc e) = L loc <$> f e - - -tyVarName :: HsTyVarBndr name -> name -tyVarName (UserTyVar name) = name -tyVarName (KindedTyVar (L _ name) _) = name diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 095bd9e0..c9664652 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -25,7 +25,6 @@ import Data.Either (lefts, rights) import Data.List( partition ) import DataCon import FamInstEnv -import Haddock.Types import HsSyn import Kind ( splitKindFunTys, synTyConResKind, isKind ) import Name @@ -41,6 +40,9 @@ import TysWiredIn ( listTyConName, eqTyCon ) import Unique ( getUnique ) import Var +import Haddock.Types +import Haddock.Interface.Specialize + -- the main function here! yay! @@ -390,7 +392,7 @@ synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = InstHead +synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdKinds = map (unLoc . synifyType WithinType) ks , ihdTypes = map (unLoc . synifyType WithinType) ts diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs new file mode 100644 index 00000000..df7f63bc --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + + +module Haddock.Interface.Specialize + ( specializeInstHead + ) where + + +import Haddock.Syb +import Haddock.Types + +import GHC +import Name +import FastString + +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State + +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) +import qualified Data.Set as Set + + +-- | Instantiate all occurrences of given name with particular type. +specialize :: (Eq name, Typeable name) + => Data a + => name -> HsType name -> a -> a +specialize name details = + everywhere $ mkT step + where + step (HsTyVar name') | name == name' = details + step typ = typ + + +-- | Instantiate all occurrences of given names with corresponding types. +-- +-- It is just a convenience function wrapping 'specialize' that supports more +-- that one specialization. +specialize' :: (Eq name, Typeable name) + => Data a + => [(name, HsType name)] -> a -> a +specialize' = flip $ foldr (uncurry specialize) + + +-- | Instantiate given binders with corresponding types. +-- +-- Again, it is just a convenience function around 'specialize'. Note that +-- length of type list should be the same as the number of binders. +specializeTyVarBndrs :: (Eq name, Typeable name, DataId name) + => Data a + => LHsTyVarBndrs name -> [HsType name] + -> a -> a +specializeTyVarBndrs bndrs typs = + specialize' $ zip bndrs' typs + where + bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs + bname (UserTyVar name) = name + bname (KindedTyVar (L _ name) _) = name + + +specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name) + => LHsTyVarBndrs name -> [HsType name] + -> PseudoFamilyDecl name + -> PseudoFamilyDecl name +specializePseudoFamilyDecl bndrs typs decl = + decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } + where + specializeTyVars = specializeTyVarBndrs bndrs typs + + +specializeSig :: (Eq name, Typeable name, DataId name, SetName name) + => LHsTyVarBndrs name -> [HsType name] + -> Sig name + -> Sig name +specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) = + TypeSig lnames (L loc typ') prn + where + typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ + fv = foldr Set.union Set.empty . map freeVariables $ typs +specializeSig _ _ sig = sig + + +specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name) + => InstHead name -> InstHead name +specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = + ihd { ihdInstType = instType' } + where + instType' = clsi + { clsiSigs = map specializeSig' clsiSigs + , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys + } + specializeSig' = specializeSig clsiTyVars ihdTypes + specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes +specializeInstHead ihd = ihd + + +-- | Make given type use tuple and list literals where appropriate. +-- +-- After applying 'specialize' function some terms may not use idiomatic list +-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This +-- can be fixed using 'sugar' function, that will turn such types into @[a]@ +-- and @(a, b, c)@. +sugar :: forall name. (NamedThing name, DataId name) + => HsType name -> HsType name +sugar = + everywhere $ mkT step + where + step :: HsType name -> HsType name + step = sugarTuples . sugarLists + + +sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp + where + name' = getName name + strName = occNameString . nameOccName $ name' +sugarLists typ = typ + + +sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples typ = + aux [] typ + where + aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy (L _ typ')) = aux apps typ' + aux apps (HsTyVar name) + | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + where + name' = getName name + strName = occNameString . nameOccName $ name' + suitable = case parseTupleArity strName of + Just arity -> arity == length apps + Nothing -> False + aux _ _ = typ + + +-- | Compute arity of given tuple operator. +-- +-- >>> parseTupleArity "(,,)" +-- Just 3 +-- +-- >>> parseTupleArity "(,,,,)" +-- Just 5 +-- +-- >>> parseTupleArity "abc" +-- Nothing +-- +-- >>> parseTupleArity "()" +-- Nothing +parseTupleArity :: String -> Maybe Int +parseTupleArity ('(':commas) = do + n <- parseCommas commas + guard $ n /= 0 + return $ n + 1 + where + parseCommas (',':rest) = (+ 1) <$> parseCommas rest + parseCommas ")" = Just 0 + parseCommas _ = Nothing +parseTupleArity _ = Nothing + + +-- | Haskell AST type representation. +-- +-- This type is used for renaming (more below), essentially the ambiguous (!) +-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well, +-- it was 'OccName' before, but turned out that 'OccName' sometimes also +-- contains namespace information, differentiating visually same types. +-- +-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is +-- not converted to 'String' or alike to avoid new allocations. Additionally, +-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also +-- quite nice. +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 + where + nname = getName name + nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) + + +-- | Compute set of free variables of given type. +freeVariables :: forall name. (NamedThing name, DataId name) + => HsType name -> Set NameRep +freeVariables = + everythingWithState Set.empty Set.union query + where + query term ctx = case cast term :: Maybe (HsType name) of + Just (HsForAllTy _ _ bndrs _ _) -> + (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsTyVar name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getNameRep name, ctx) + _ -> (Set.empty, ctx) + bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs + + +-- | Make given type visually unambiguous. +-- +-- After applying 'specialize' method, some free type variables may become +-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to +-- @(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 + } + + +-- | Renaming monad. +type Rename name = Reader (RenameEnv name) + +-- | Binding generation monad. +type Rebind name = State (RenameEnv name) + +data RenameEnv name = RenameEnv + { rneFV :: Set NameRep + , rneCtx :: Map Name name + } + + +renameType :: SetName name => HsType name -> Rename name (HsType name) +renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' -> + HsForAllTy + <$> pure ex + <*> pure mspan + <*> pure lbndrs' + <*> located renameContext lctx + <*> renameLType lt +renameType (HsTyVar name) = HsTyVar <$> renameName name +renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la +renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr +renameType (HsListTy lt) = HsListTy <$> renameLType lt +renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt +renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt +renameType (HsOpTy la lop lb) = + HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb +renameType (HsParTy lt) = HsParTy <$> renameLType lt +renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt +renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb +renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType t@(HsQuasiQuoteTy _) = pure t +renameType t@(HsSpliceTy _ _) = pure t +renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc +renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt +renameType t@(HsRecTy _) = pure t +renameType t@(HsCoreTy _) = pure t +renameType (HsExplicitListTy ph ltys) = + HsExplicitListTy ph <$> renameLTypes ltys +renameType (HsExplicitTupleTy phs ltys) = + HsExplicitTupleTy phs <$> renameLTypes ltys +renameType t@(HsTyLit _) = pure t +renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t +renameType HsWildcardTy = pure HsWildcardTy +renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name + + +renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType = located renameType + + +renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes = mapM renameLType + + +renameContext :: 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 $ case Map.lookup (getName name) ctx of + Just name' -> name' + Nothing -> name + + +rebind :: SetName name + => LHsTyVarBndrs name -> (LHsTyVarBndrs 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 + => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name) +rebindLTyVarBndrs lbndrs = do + tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs + pure $ lbndrs { hsq_tvs = tys' } + + +rebindTyVarBndr :: SetName name + => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) +rebindTyVarBndr (UserTyVar name) = + UserTyVar <$> rebindName name +rebindTyVarBndr (KindedTyVar name kinds) = + KindedTyVar <$> located rebindName name <*> pure kinds + + +rebindName :: SetName name => name -> Rebind name name +rebindName 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 + + +-- | Generate fresh occurrence name, put it into context and return. +freshName :: SetName name => name -> Rebind 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 } + 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 = do + RenameEnv { .. } <- get + return $ Set.union rneFV (ctxElems rneCtx) + where + ctxElems = Set.fromList . map getNameRep . Map.elems + + +findFreshName :: Set NameRep -> NameRep -> NameRep +findFreshName taken = + fromJust . List.find isFresh . alternativeNames + where + isFresh = not . flip Set.member 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 = + [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] + where + str = nameRepString name + + +located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located f (L loc e) = L loc <$> f e + + +tyVarName :: HsTyVarBndr name -> name +tyVarName (UserTyVar name) = name +tyVarName (KindedTyVar (L _ name) _) = name -- cgit v1.2.3