-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- 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 Data.List (stripPrefix)
import GHC hiding (LexicalFixity (..), anchor)
import GHC.Data.FastString (unpackFS)
import GHC.Types.Name
import GHC.Types.Name.Reader
import Text.XHtml hiding (name, p, quote)

import Haddock.Backends.Xhtml.Utils
import Haddock.GhcUtils
import Haddock.Types
import Haddock.Utils

-- | Indicator of how to render a 'DocName' into 'Html'
data Notation
  = -- | Render as-is.
    Raw
  | -- | Render using infix notation.
    Infix
  | -- | Render using prefix notation.
    Prefix
  deriving (Notation -> Notation -> Bool
(Notation -> Notation -> Bool)
-> (Notation -> Notation -> Bool) -> Eq Notation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Notation -> Notation -> Bool
== :: Notation -> Notation -> Bool
$c/= :: Notation -> Notation -> Bool
/= :: 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
$cshowsPrec :: Int -> Notation -> ShowS
showsPrec :: Int -> Notation -> ShowS
$cshow :: Notation -> String
show :: Notation -> String
$cshowList :: [Notation] -> ShowS
showList :: [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 -> GenLocated l DocName -> Html
ppLDocName :: forall l. Qualification -> Notation -> GenLocated l DocName -> Html
ppLDocName Qualification
qual Notation
notation (L l
_ 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

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

ppName :: Notation -> Name -> Html
ppName :: Notation -> Name -> Html
ppName Notation
notation Name
name =
  case Maybe FastString
m_pun of
    Just FastString
str -> String -> Html
forall a. HTML a => a -> Html
toHtml (FastString -> String
unpackFS FastString
str) -- use the punned form
    Maybe FastString
Nothing ->
      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) -- use the original identifier
  where
    m_pun :: Maybe FastString
m_pun = case Notation
notation of
      Notation
Raw -> Name -> Maybe FastString
namePun_maybe Name
name
      Notation
Prefix -> Name -> Maybe FastString
namePun_maybe Name
name
      Notation
Infix -> Maybe FastString
forall a. Maybe a
Nothing

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 -> Bool
not Bool
is_sym -> Html -> Html
quote
  Notation
Prefix | 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

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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) 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
forall unit. GenModule unit -> 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.