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

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

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