-----------------------------------------------------------------------------
-- |
-- 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 (Notation -> Notation -> Bool
(Notation -> Notation -> Bool)
-> (Notation -> Notation -> Bool) -> Eq Notation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Notation -> Notation -> Bool
$c/= :: Notation -> Notation -> Bool
== :: Notation -> Notation -> Bool
$c== :: Notation -> Notation -> Bool
Eq, Int -> Notation -> ShowS
[Notation] -> ShowS
Notation -> String
(Int -> Notation -> ShowS)
-> (Notation -> String) -> ([Notation] -> ShowS) -> Show Notation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Notation] -> ShowS
$cshowList :: [Notation] -> ShowS
show :: Notation -> String
$cshow :: Notation -> String
showsPrec :: Int -> Notation -> ShowS
$cshowsPrec :: Int -> Notation -> ShowS
Show)

ppOccName :: OccName -> Html
ppOccName :: OccName -> Html
ppOccName = String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> (OccName -> String) -> OccName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString


ppRdrName :: RdrName -> Html
ppRdrName :: RdrName -> Html
ppRdrName = OccName -> Html
ppOccName (OccName -> Html) -> (RdrName -> OccName) -> RdrName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> OccName
rdrNameOcc

ppIPName :: HsIPName -> Html
ppIPName :: HsIPName -> Html
ppIPName = String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> (HsIPName -> String) -> HsIPName -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'?'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> (HsIPName -> String) -> HsIPName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS (FastString -> String)
-> (HsIPName -> FastString) -> HsIPName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsIPName -> FastString
hsIPNameFS


ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html
ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html
ppUncheckedLink Qualification
_ Wrap (ModuleName, OccName)
x = ModuleName -> Maybe OccName -> Html -> Html
linkIdOcc' ModuleName
mdl (OccName -> Maybe OccName
forall a. a -> Maybe a
Just OccName
occ) (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
occHtml
  where
    (ModuleName
mdl, OccName
occ) = Wrap (ModuleName, OccName) -> (ModuleName, OccName)
forall n. Wrap n -> n
unwrap Wrap (ModuleName, OccName)
x
    occHtml :: Html
occHtml = String -> Html
forall a. HTML a => a -> Html
toHtml (((ModuleName, OccName) -> String)
-> Wrap (ModuleName, OccName) -> String
forall a. (a -> String) -> Wrap a -> String
showWrapped (OccName -> String
occNameString (OccName -> String)
-> ((ModuleName, OccName) -> OccName)
-> (ModuleName, OccName)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, OccName) -> OccName
forall a b. (a, b) -> b
snd) Wrap (ModuleName, OccName)
x) -- TODO: apply ppQualifyName

-- The Bool indicates if it is to be rendered in infix notation
ppLDocName :: Qualification -> Notation -> Located DocName -> Html
ppLDocName :: Qualification -> Notation -> Located DocName -> Html
ppLDocName Qualification
qual Notation
notation (L SrcSpan
_ DocName
d) = Qualification -> Notation -> Bool -> DocName -> Html
ppDocName Qualification
qual Notation
notation Bool
True DocName
d

ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
ppDocName Qualification
qual Notation
notation Bool
insertAnchors DocName
docName =
  case DocName
docName of
    Documented Name
name Module
mdl ->
      Module -> Maybe OccName -> Bool -> Html -> Html
linkIdOcc Module
mdl (OccName -> Maybe OccName
forall a. a -> Maybe a
Just (Name -> OccName
nameOccName Name
name)) Bool
insertAnchors
      (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Qualification -> Notation -> Name -> Module -> Html
ppQualifyName Qualification
qual Notation
notation Name
name Module
mdl
    Undocumented Name
name
      | Name -> Bool
isExternalName Name
name Bool -> Bool -> Bool
|| Name -> Bool
isWiredInName Name
name ->
          Qualification -> Notation -> Name -> Module -> Html
ppQualifyName Qualification
qual Notation
notation Name
name (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name)
      | Bool
otherwise -> Notation -> Name -> Html
ppName Notation
notation Name
name


ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html
ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html
ppWrappedDocName Qualification
qual Notation
notation Bool
insertAnchors Wrap DocName
docName = case Wrap DocName
docName of
  Unadorned DocName
n -> Qualification -> Notation -> Bool -> DocName -> Html
ppDocName Qualification
qual Notation
notation Bool
insertAnchors DocName
n
  Parenthesized DocName
n -> Qualification -> Notation -> Bool -> DocName -> Html
ppDocName Qualification
qual Notation
Prefix Bool
insertAnchors DocName
n
  Backticked DocName
n -> Qualification -> Notation -> Bool -> DocName -> Html
ppDocName Qualification
qual Notation
Infix Bool
insertAnchors DocName
n

ppWrappedName :: Notation -> Wrap Name -> Html
ppWrappedName :: Notation -> Wrap Name -> Html
ppWrappedName Notation
notation Wrap Name
docName = case Wrap Name
docName of
  Unadorned Name
n -> Notation -> Name -> Html
ppName Notation
notation Name
n
  Parenthesized Name
n -> Notation -> Name -> Html
ppName Notation
Prefix Name
n
  Backticked Name
n -> Notation -> Name -> Html
ppName Notation
Infix Name
n

-- | Render a name depending on the selected qualification mode
ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
ppQualifyName Qualification
qual Notation
notation Name
name Module
mdl =
  case Qualification
qual of
    Qualification
NoQual   -> Notation -> Name -> Html
ppName Notation
notation Name
name
    Qualification
FullQual -> Notation -> Module -> Name -> Html
ppFullQualName Notation
notation Module
mdl Name
name
    LocalQual Module
localmdl ->
      if Module -> String
moduleString Module
mdl String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> String
moduleString Module
localmdl
        then Notation -> Name -> Html
ppName Notation
notation Name
name
        else Notation -> Module -> Name -> Html
ppFullQualName Notation
notation Module
mdl Name
name
    RelativeQual Module
localmdl ->
      case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (Module -> String
moduleString Module
localmdl) (Module -> String
moduleString Module
mdl) of
        -- local, A.x -> x
        Just []      -> Notation -> Name -> Html
ppName Notation
notation Name
name
        -- sub-module, A.B.x -> B.x
        Just (Char
'.':String
m) -> String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name
        -- some module with same prefix, ABC.x -> ABC.x
        Just String
_       -> Notation -> Module -> Name -> Html
ppFullQualName Notation
notation Module
mdl Name
name
        -- some other module, D.x -> D.x
        Maybe String
Nothing      -> Notation -> Module -> Name -> Html
ppFullQualName Notation
notation Module
mdl Name
name
    AliasedQual AliasMap
aliases Module
localmdl ->
      case (Module -> String
moduleString Module
mdl String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> String
moduleString Module
localmdl,
            Module -> AliasMap -> Maybe ModuleName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Module
mdl AliasMap
aliases) of
        (Bool
False, Just ModuleName
alias) -> Notation -> ModuleName -> Name -> Html
ppQualName Notation
notation ModuleName
alias Name
name
        (Bool, Maybe ModuleName)
_ -> Notation -> Name -> Html
ppName Notation
notation Name
name


ppFullQualName :: Notation -> Module -> Name -> Html
ppFullQualName :: Notation -> Module -> Name -> Html
ppFullQualName Notation
notation Module
mdl Name
name = Notation -> OccName -> Html -> Html
wrapInfix Notation
notation (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name) Html
qname
  where
    qname :: Html
qname = String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ Module -> String
moduleString Module
mdl String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name

ppQualName :: Notation -> ModuleName -> Name -> Html
ppQualName :: Notation -> ModuleName -> Name -> Html
ppQualName Notation
notation ModuleName
mdlName Name
name = Notation -> OccName -> Html -> Html
wrapInfix Notation
notation (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name) Html
qname
  where
    qname :: Html
qname = String -> Html
forall a. HTML a => a -> Html
toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
mdlName String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
: Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name

ppName :: Notation -> Name -> Html
ppName :: Notation -> Name -> Html
ppName Notation
notation Name
name = Notation -> OccName -> Html -> Html
wrapInfix Notation
notation (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
forall a. HTML a => a -> Html
toHtml (Name -> String
forall a. NamedThing a => a -> String
getOccString Name
name)


ppBinder :: Bool -> OccName -> Html
ppBinder :: Bool -> OccName -> Html
ppBinder = Notation -> Bool -> OccName -> Html
ppBinderWith Notation
Prefix

ppBinderInfix :: Bool -> OccName -> Html
ppBinderInfix :: Bool -> OccName -> Html
ppBinderInfix = Notation -> Bool -> OccName -> Html
ppBinderWith Notation
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 -> Bool -> OccName -> Html
ppBinderWith Notation
notation Bool
isRef OccName
n =
  Html -> Html
makeAnchor (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Notation -> OccName -> Html
ppBinder' Notation
notation OccName
n
  where
    name :: String
name = OccName -> String
nameAnchorId OccName
n
    makeAnchor :: Html -> Html
makeAnchor | Bool
isRef     = String -> Html -> Html
linkedAnchor String
name
               | Bool
otherwise = String -> Html -> Html
namedAnchor String
name (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
theclass String
"def"]

ppBinder' :: Notation -> OccName -> Html
ppBinder' :: Notation -> OccName -> Html
ppBinder' Notation
notation OccName
n = Notation -> OccName -> Html -> Html
wrapInfix Notation
notation OccName
n (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ OccName -> Html
ppOccName OccName
n

wrapInfix :: Notation -> OccName -> Html -> Html
wrapInfix :: Notation -> OccName -> Html -> Html
wrapInfix Notation
notation OccName
n = case Notation
notation of
  Notation
Infix | Bool
is_star_kind -> Html -> Html
forall a. a -> a
id
        | Bool -> Bool
not Bool
is_sym -> Html -> Html
quote
  Notation
Prefix | Bool
is_star_kind -> Html -> Html
forall a. a -> a
id
         | Bool
is_sym -> Html -> Html
parens
  Notation
_ -> Html -> Html
forall a. a -> a
id
  where
    is_sym :: Bool
is_sym = OccName -> Bool
isSymOcc OccName
n
    is_star_kind :: Bool
is_star_kind = OccName -> Bool
isTcOcc OccName
n Bool -> Bool -> Bool
&& OccName -> String
occNameString OccName
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"*"

linkId :: Module -> Maybe Name -> Html -> Html
linkId :: Module -> Maybe Name -> Html -> Html
linkId Module
mdl Maybe Name
mbName = Module -> Maybe OccName -> Bool -> Html -> Html
linkIdOcc Module
mdl ((Name -> OccName) -> Maybe Name -> Maybe OccName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> OccName
nameOccName Maybe Name
mbName) Bool
True


linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
linkIdOcc Module
mdl Maybe OccName
mbName Bool
insertAnchors =
  if Bool
insertAnchors
  then Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href String
url, String -> HtmlAttr
title String
ttl]
  else Html -> Html
forall a. a -> a
id
  where
    ttl :: String
ttl = ModuleName -> String
moduleNameString (Module -> ModuleName
moduleName Module
mdl)
    url :: String
url = case Maybe OccName
mbName of
      Maybe OccName
Nothing   -> Module -> String
moduleUrl Module
mdl
      Just OccName
name -> Module -> OccName -> String
moduleNameUrl Module
mdl OccName
name


linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
linkIdOcc' ModuleName
mdl Maybe OccName
mbName = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href String
url, String -> HtmlAttr
title String
ttl]
  where
    ttl :: String
ttl = ModuleName -> String
moduleNameString ModuleName
mdl
    url :: String
url = case Maybe OccName
mbName of
      Maybe OccName
Nothing   -> ModuleName -> String
moduleHtmlFile' ModuleName
mdl
      Just OccName
name -> ModuleName -> OccName -> String
moduleNameUrl' ModuleName
mdl OccName
name


ppModule :: Module -> Html
ppModule :: Module -> Html
ppModule Module
mdl = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (Module -> String
moduleUrl Module
mdl)]
               (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> Html
forall a. HTML a => a -> Html
toHtml (Module -> String
moduleString Module
mdl)


ppModuleRef :: Maybe Html -> ModuleName -> String -> Html
ppModuleRef :: Maybe Html -> ModuleName -> String -> Html
ppModuleRef Maybe Html
Nothing ModuleName
mdl String
ref = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (ModuleName -> String
moduleHtmlFile' ModuleName
mdl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ref)]
                              (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< String -> Html
forall a. HTML a => a -> Html
toHtml (ModuleName -> String
moduleNameString ModuleName
mdl)
ppModuleRef (Just Html
lbl) ModuleName
mdl String
ref = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
href (ModuleName -> String
moduleHtmlFile' ModuleName
mdl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ref)]
                                 (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
lbl

    -- 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.