diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 18 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 382 |
2 files changed, 7 insertions, 393 deletions
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 |