-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Html.Names
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2009,
-- Mark Lentczner 2010
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
ppBinder, ppBinderInfix, ppBinder',
ppModule, ppModuleRef, ppIPName, linkId, Notation(..),
ppWrappedDocName, ppWrappedName,
) where
import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
import Haddock.Utils
import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
import Data.List ( stripPrefix )
import GHC hiding (LexicalFixity(..))
import Name
import RdrName
import FastString (unpackFS)
-- | Indicator of how to render a 'DocName' into 'Html'
data Notation = Raw -- ^ Render as-is.
| Infix -- ^ Render using infix notation.
| Prefix -- ^ Render using prefix notation.
deriving (Eq, Show)
ppOccName :: OccName -> Html
ppOccName = toHtml . occNameString
ppRdrName :: RdrName -> Html
ppRdrName = ppOccName . rdrNameOcc
ppIPName :: HsIPName -> Html
ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html
ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml
where
(mdl, occ) = unwrap x
occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName
-- The Bool indicates if it is to be rendered in infix notation
ppLDocName :: Qualification -> Notation -> Located DocName -> Html
ppLDocName qual notation (L _ d) = ppDocName qual notation True d
ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
ppDocName qual notation insertAnchors docName =
case docName of
Documented name mdl ->
linkIdOcc mdl (Just (nameOccName name)) insertAnchors
<< ppQualifyName qual notation name mdl
Undocumented name
| isExternalName name || isWiredInName name ->
ppQualifyName qual notation name (nameModule name)
| otherwise -> ppName notation name
ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html
ppWrappedDocName qual notation insertAnchors docName = case docName of
Unadorned n -> ppDocName qual notation insertAnchors n
Parenthesized n -> ppDocName qual Prefix insertAnchors n
Backticked n -> ppDocName qual Infix insertAnchors n
ppWrappedName :: Notation -> Wrap Name -> Html
ppWrappedName notation docName = case docName of
Unadorned n -> ppName notation n
Parenthesized n -> ppName Prefix n
Backticked n -> ppName Infix n
-- | Render a name depending on the selected qualification mode
ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
ppQualifyName qual notation name mdl =
case qual of
NoQual -> ppName notation name
FullQual -> ppFullQualName notation mdl name
LocalQual localmdl ->
if moduleString mdl == moduleString localmdl
then ppName notation name
else ppFullQualName notation mdl name
RelativeQual localmdl ->
case stripPrefix (moduleString localmdl) (moduleString mdl) of
-- local, A.x -> x
Just [] -> ppName notation name
-- sub-module, A.B.x -> B.x
Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
-- some module with same prefix, ABC.x -> ABC.x
Just _ -> ppFullQualName notation mdl name
-- some other module, D.x -> D.x
Nothing -> ppFullQualName notation mdl name
AliasedQual aliases localmdl ->
case (moduleString mdl == moduleString localmdl,
M.lookup mdl aliases) of
(False, Just alias) -> ppQualName notation alias name
_ -> ppName notation name
ppFullQualName :: Notation -> Module -> Name -> Html
ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname
where
qname = toHtml $ moduleString mdl ++ '.' : getOccString name
ppQualName :: Notation -> ModuleName -> Name -> Html
ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname
where
qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name
ppName :: Notation -> Name -> Html
ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name)
ppBinder :: Bool -> OccName -> Html
ppBinder = ppBinderWith Prefix
ppBinderInfix :: Bool -> OccName -> Html
ppBinderInfix = ppBinderWith Infix
ppBinderWith :: Notation -> Bool -> OccName -> Html
-- 'isRef' indicates whether this is merely a reference from another part of
-- the documentation or is the actual definition; in the latter case, we also
-- set the 'id' and 'class' attributes.
ppBinderWith notation isRef n =
makeAnchor << ppBinder' notation n
where
name = nameAnchorId n
makeAnchor | isRef = linkedAnchor name
| otherwise = namedAnchor name ! [theclass "def"]
ppBinder' :: Notation -> OccName -> Html
ppBinder' notation n = wrapInfix notation n $ ppOccName n
wrapInfix :: Notation -> OccName -> Html -> Html
wrapInfix notation n = case notation of
Infix | is_star_kind -> id
| not is_sym -> quote
Prefix | is_star_kind -> id
| is_sym -> parens
_ -> id
where
is_sym = isSymOcc n
is_star_kind = isTcOcc n && occNameString n == "*"
linkId :: Module -> Maybe Name -> Html -> Html
linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True
linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
linkIdOcc mdl mbName insertAnchors =
if insertAnchors
then anchor ! [href url, title ttl]
else id
where
ttl = moduleNameString (moduleName mdl)
url = case mbName of
Nothing -> moduleUrl mdl
Just name -> moduleNameUrl mdl name
linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
linkIdOcc' mdl mbName = anchor ! [href url, title ttl]
where
ttl = moduleNameString mdl
url = case mbName of
Nothing -> moduleHtmlFile' mdl
Just name -> moduleNameUrl' mdl name
ppModule :: Module -> Html
ppModule mdl = anchor ! [href (moduleUrl mdl)]
<< toHtml (moduleString mdl)
ppModuleRef :: ModuleName -> String -> Html
ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
<< toHtml (moduleNameString mdl)
-- NB: The ref parameter already includes the '#'.
-- This function is only called from markupModule expanding a
-- DocModule, which doesn't seem to be ever be used.