{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

module Haddock.Backends.Hyperlinker.Renderer (render) where


import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils

import qualified Data.ByteString as BS

import HieTypes
import Module   ( ModuleName, moduleNameString )
import Name     ( getOccString, isInternalName, Name, nameModule, nameUnique )
import SrcLoc
import Unique   ( getKey )
import Encoding ( utf8DecodeByteString )

import System.FilePath.Posix ((</>))

import qualified Data.Map as Map
import qualified Data.Set as Set

import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html


type StyleClass = String

-- | Produce the HTML corresponding to a hyperlinked Haskell source
render
  :: Maybe FilePath    -- ^ path to the CSS file
  -> Maybe FilePath    -- ^ path to the JS file
  -> SrcMaps            -- ^ Paths to sources
  -> HieAST PrintedType  -- ^ ASTs from @.hie@ files
  -> [Token]       -- ^ tokens to render
  -> Html
render :: Maybe FilePath
-> Maybe FilePath -> SrcMaps -> HieAST FilePath -> [Token] -> Html
render Maybe FilePath
mcss Maybe FilePath
mjs SrcMaps
srcs HieAST FilePath
ast [Token]
tokens = Maybe FilePath -> Maybe FilePath -> Html
header Maybe FilePath
mcss Maybe FilePath
mjs Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> SrcMaps -> HieAST FilePath -> [Token] -> Html
body SrcMaps
srcs HieAST FilePath
ast [Token]
tokens

body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
body :: SrcMaps -> HieAST FilePath -> [Token] -> Html
body SrcMaps
srcs HieAST FilePath
ast [Token]
tokens = Html -> Html
Html.body (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
Html.pre (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
hypsrc
  where
    hypsrc :: Html
hypsrc = SrcMaps -> HieAST FilePath -> [Token] -> Html
renderWithAst SrcMaps
srcs HieAST FilePath
ast [Token]
tokens

header :: Maybe FilePath -> Maybe FilePath -> Html
header :: Maybe FilePath -> Maybe FilePath -> Html
header Maybe FilePath
Nothing Maybe FilePath
Nothing = Html
Html.noHtml
header Maybe FilePath
mcss Maybe FilePath
mjs = Html -> Html
Html.header (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> Html
css Maybe FilePath
mcss Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Maybe FilePath -> Html
js Maybe FilePath
mjs
  where
    css :: Maybe FilePath -> Html
css Maybe FilePath
Nothing = Html
Html.noHtml
    css (Just FilePath
cssFile) = Html -> Html
Html.thelink Html
Html.noHtml Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
        [ FilePath -> HtmlAttr
Html.rel FilePath
"stylesheet"
        , FilePath -> HtmlAttr
Html.thetype FilePath
"text/css"
        , FilePath -> HtmlAttr
Html.href FilePath
cssFile
        ]
    js :: Maybe FilePath -> Html
js Maybe FilePath
Nothing = Html
Html.noHtml
    js (Just FilePath
scriptFile) = Html -> Html
Html.script Html
Html.noHtml Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
        [ FilePath -> HtmlAttr
Html.thetype FilePath
"text/javascript"
        , FilePath -> HtmlAttr
Html.src FilePath
scriptFile
        ]


splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token])
splitTokens :: HieAST FilePath -> [Token] -> ([Token], [Token], [Token])
splitTokens HieAST FilePath
ast [Token]
toks = ([Token]
before,[Token]
during,[Token]
after)
  where
    ([Token]
before,[Token]
rest) = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Token -> Bool
leftOf [Token]
toks
    ([Token]
during,[Token]
after) = (Token -> Bool) -> [Token] -> ([Token], [Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Token -> Bool
inAst [Token]
rest
    leftOf :: Token -> Bool
leftOf Token
t = RealSrcSpan -> RealSrcLoc
realSrcSpanEnd (Token -> RealSrcSpan
tkSpan Token
t) RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
<= RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
nodeSp
    inAst :: Token -> Bool
inAst Token
t = RealSrcSpan
nodeSp RealSrcSpan -> RealSrcSpan -> Bool
`containsSpan` Token -> RealSrcSpan
tkSpan Token
t
    nodeSp :: RealSrcSpan
nodeSp = HieAST FilePath -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST FilePath
ast

-- | Turn a list of tokens into hyperlinked sources, threading in relevant link
-- information from the 'HieAST'.
renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
renderWithAst :: SrcMaps -> HieAST FilePath -> [Token] -> Html
renderWithAst SrcMaps
srcs Node{[HieAST FilePath]
NodeInfo FilePath
RealSrcSpan
nodeInfo :: forall a. HieAST a -> NodeInfo a
nodeChildren :: forall a. HieAST a -> [HieAST a]
nodeChildren :: [HieAST FilePath]
nodeSpan :: RealSrcSpan
nodeInfo :: NodeInfo FilePath
nodeSpan :: forall a. HieAST a -> RealSrcSpan
..} [Token]
toks = Html -> Html
anchored (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ case [Token]
toks of

    [Token
tok] | RealSrcSpan
nodeSpan RealSrcSpan -> RealSrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== Token -> RealSrcSpan
tkSpan Token
tok -> SrcMaps -> NodeInfo FilePath -> Token -> Html
richToken SrcMaps
srcs NodeInfo FilePath
nodeInfo Token
tok

    -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators
    -- as multiple tokens.
    --
    --  * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens)
    --  * @(+) 1 2@    turns into @[(, +, ), 1, 2]@    (excluding space tokens)
    --
    -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In
    -- order to make sure these get hyperlinked properly, we intercept these
    -- special sequences of tokens and merge them into just one identifier or
    -- operator token.
    [BacktickTok RealSrcSpan
s1, tok :: Token
tok@Token{ tkType :: Token -> TokenType
tkType = TokenType
TkIdentifier }, BacktickTok RealSrcSpan
s2]
          | RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s1 RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
nodeSpan
          , RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s2   RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
nodeSpan
          -> SrcMaps -> NodeInfo FilePath -> Token -> Html
richToken SrcMaps
srcs NodeInfo FilePath
nodeInfo
                       (Token :: TokenType -> ByteString -> RealSrcSpan -> Token
Token{ tkValue :: ByteString
tkValue = ByteString
"`" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Token -> ByteString
tkValue Token
tok ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"`"
                             , tkType :: TokenType
tkType = TokenType
TkOperator
                             , tkSpan :: RealSrcSpan
tkSpan = RealSrcSpan
nodeSpan })
    [OpenParenTok RealSrcSpan
s1, tok :: Token
tok@Token{ tkType :: Token -> TokenType
tkType = TokenType
TkOperator }, CloseParenTok RealSrcSpan
s2]
          | RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
s1 RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
nodeSpan
          , RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
s2   RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> RealSrcLoc
realSrcSpanEnd RealSrcSpan
nodeSpan
          -> SrcMaps -> NodeInfo FilePath -> Token -> Html
richToken SrcMaps
srcs NodeInfo FilePath
nodeInfo
                       (Token :: TokenType -> ByteString -> RealSrcSpan -> Token
Token{ tkValue :: ByteString
tkValue = ByteString
"(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Token -> ByteString
tkValue Token
tok ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
")"
                             , tkType :: TokenType
tkType = TokenType
TkOperator
                             , tkSpan :: RealSrcSpan
tkSpan = RealSrcSpan
nodeSpan })

    [Token]
_ -> [HieAST FilePath] -> [Token] -> Html
go [HieAST FilePath]
nodeChildren [Token]
toks
  where
    go :: [HieAST FilePath] -> [Token] -> Html
go [HieAST FilePath]
_ [] = Html
forall a. Monoid a => a
mempty
    go [] [Token]
xs = (Token -> Html) -> [Token] -> Html
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Token -> Html
renderToken [Token]
xs
    go (HieAST FilePath
cur:[HieAST FilePath]
rest) [Token]
xs =
        (Token -> Html) -> [Token] -> Html
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Token -> Html
renderToken [Token]
before Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> SrcMaps -> HieAST FilePath -> [Token] -> Html
renderWithAst SrcMaps
srcs HieAST FilePath
cur [Token]
during Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> [HieAST FilePath] -> [Token] -> Html
go [HieAST FilePath]
rest [Token]
after
      where
        ([Token]
before,[Token]
during,[Token]
after) = HieAST FilePath -> [Token] -> ([Token], [Token], [Token])
splitTokens HieAST FilePath
cur [Token]
xs
    anchored :: Html -> Html
anchored Html
c = (Identifier -> IdentifierDetails FilePath -> Html -> Html)
-> Html -> Map Identifier (IdentifierDetails FilePath) -> Html
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Identifier -> IdentifierDetails FilePath -> Html -> Html
forall a. Identifier -> IdentifierDetails a -> Html -> Html
anchorOne Html
c (NodeInfo FilePath -> Map Identifier (IdentifierDetails FilePath)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo FilePath
nodeInfo)
    anchorOne :: Identifier -> IdentifierDetails a -> Html -> Html
anchorOne Identifier
n IdentifierDetails a
dets Html
c = Identifier -> Set ContextInfo -> Html -> Html
externalAnchor Identifier
n Set ContextInfo
d (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Identifier -> Set ContextInfo -> Html -> Html
internalAnchor Identifier
n Set ContextInfo
d Html
c
      where d :: Set ContextInfo
d = IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo IdentifierDetails a
dets

renderToken :: Token -> Html
renderToken :: Token -> Html
renderToken Token{ByteString
RealSrcSpan
TokenType
tkSpan :: RealSrcSpan
tkValue :: ByteString
tkType :: TokenType
tkValue :: Token -> ByteString
tkType :: Token -> TokenType
tkSpan :: Token -> RealSrcSpan
..}
    | ByteString -> Bool
BS.null ByteString
tkValue = Html
forall a. Monoid a => a
mempty
    | TokenType
tkType TokenType -> TokenType -> Bool
forall a. Eq a => a -> a -> Bool
== TokenType
TkSpace = Int -> FilePath -> Html
renderSpace (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
tkSpan) FilePath
tkValue'
    | Bool
otherwise = Html
tokenSpan Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ [FilePath] -> HtmlAttr
multiclass [FilePath]
style ]
  where
    tkValue' :: FilePath
tkValue' = FilePath -> FilePath
filterCRLF (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
utf8DecodeByteString ByteString
tkValue
    style :: [FilePath]
style = TokenType -> [FilePath]
tokenStyle TokenType
tkType
    tokenSpan :: Html
tokenSpan = Html -> Html
Html.thespan (FilePath -> Html
forall a. HTML a => a -> Html
Html.toHtml FilePath
tkValue')


-- | Given information about the source position of definitions, render a token
richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html
richToken :: SrcMaps -> NodeInfo FilePath -> Token -> Html
richToken SrcMaps
srcs NodeInfo FilePath
details Token{ByteString
RealSrcSpan
TokenType
tkSpan :: RealSrcSpan
tkValue :: ByteString
tkType :: TokenType
tkValue :: Token -> ByteString
tkType :: Token -> TokenType
tkSpan :: Token -> RealSrcSpan
..}
    | TokenType
tkType TokenType -> TokenType -> Bool
forall a. Eq a => a -> a -> Bool
== TokenType
TkSpace = Int -> FilePath -> Html
renderSpace (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
tkSpan) FilePath
tkValue'
    | Bool
otherwise = NodeInfo FilePath -> Html -> Html
annotate NodeInfo FilePath
details (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
linked Html
content
  where
    tkValue' :: FilePath
tkValue' = FilePath -> FilePath
filterCRLF (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
utf8DecodeByteString ByteString
tkValue
    content :: Html
content = Html
tokenSpan Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ [FilePath] -> HtmlAttr
multiclass [FilePath]
style ]
    tokenSpan :: Html
tokenSpan = Html -> Html
Html.thespan (FilePath -> Html
forall a. HTML a => a -> Html
Html.toHtml FilePath
tkValue')
    style :: [FilePath]
style = TokenType -> [FilePath]
tokenStyle TokenType
tkType [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (ContextInfo -> [FilePath]) -> [ContextInfo] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> ContextInfo -> [FilePath]
richTokenStyle ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (NodeInfo FilePath -> [FilePath]
forall a. NodeInfo a -> [a]
nodeType NodeInfo FilePath
details))) [ContextInfo]
contexts

    contexts :: [ContextInfo]
contexts = (IdentifierDetails FilePath -> [ContextInfo])
-> [IdentifierDetails FilePath] -> [ContextInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Set ContextInfo -> [ContextInfo]
forall a. Set a -> [a]
Set.elems (Set ContextInfo -> [ContextInfo])
-> (IdentifierDetails FilePath -> Set ContextInfo)
-> IdentifierDetails FilePath
-> [ContextInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentifierDetails FilePath -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo) ([IdentifierDetails FilePath] -> [ContextInfo])
-> (NodeInfo FilePath -> [IdentifierDetails FilePath])
-> NodeInfo FilePath
-> [ContextInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Identifier (IdentifierDetails FilePath)
-> [IdentifierDetails FilePath]
forall k a. Map k a -> [a]
Map.elems (Map Identifier (IdentifierDetails FilePath)
 -> [IdentifierDetails FilePath])
-> (NodeInfo FilePath
    -> Map Identifier (IdentifierDetails FilePath))
-> NodeInfo FilePath
-> [IdentifierDetails FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo FilePath -> Map Identifier (IdentifierDetails FilePath)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (NodeInfo FilePath -> [ContextInfo])
-> NodeInfo FilePath -> [ContextInfo]
forall a b. (a -> b) -> a -> b
$ NodeInfo FilePath
details

    -- pick an arbitary identifier to hyperlink with
    identDet :: Maybe (Identifier, IdentifierDetails FilePath)
identDet = Map Identifier (IdentifierDetails FilePath)
-> Maybe (Identifier, IdentifierDetails FilePath)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin (Map Identifier (IdentifierDetails FilePath)
 -> Maybe (Identifier, IdentifierDetails FilePath))
-> (NodeInfo FilePath
    -> Map Identifier (IdentifierDetails FilePath))
-> NodeInfo FilePath
-> Maybe (Identifier, IdentifierDetails FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo FilePath -> Map Identifier (IdentifierDetails FilePath)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (NodeInfo FilePath
 -> Maybe (Identifier, IdentifierDetails FilePath))
-> NodeInfo FilePath
-> Maybe (Identifier, IdentifierDetails FilePath)
forall a b. (a -> b) -> a -> b
$ NodeInfo FilePath
details

    -- If we have name information, we can make links
    linked :: Html -> Html
linked = case Maybe (Identifier, IdentifierDetails FilePath)
identDet of
      Just (Identifier
n,IdentifierDetails FilePath
_) -> SrcMaps -> Identifier -> Html -> Html
hyperlink SrcMaps
srcs Identifier
n
      Maybe (Identifier, IdentifierDetails FilePath)
Nothing -> Html -> Html
forall a. a -> a
id

-- | Remove CRLFs from source
filterCRLF :: String -> String
filterCRLF :: FilePath -> FilePath
filterCRLF (Char
'\r':Char
'\n':FilePath
cs) = Char
'\n' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
filterCRLF FilePath
cs
filterCRLF (Char
c:FilePath
cs) = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
filterCRLF FilePath
cs
filterCRLF [] = []

annotate :: NodeInfo PrintedType -> Html -> Html
annotate :: NodeInfo FilePath -> Html -> Html
annotate  NodeInfo FilePath
ni Html
content =
    Html -> Html
Html.thespan (Html
annot Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
content) Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ FilePath -> HtmlAttr
Html.theclass FilePath
"annot" ]
  where
    annot :: Html
annot
      | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
annotation) =
          Html -> Html
Html.thespan (FilePath -> Html
forall a. HTML a => a -> Html
Html.toHtml FilePath
annotation) Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ FilePath -> HtmlAttr
Html.theclass FilePath
"annottext" ]
      | Bool
otherwise = Html
forall a. Monoid a => a
mempty
    annotation :: FilePath
annotation = FilePath
typ FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
identTyps
    typ :: FilePath
typ = [FilePath] -> FilePath
unlines (NodeInfo FilePath -> [FilePath]
forall a. NodeInfo a -> [a]
nodeType NodeInfo FilePath
ni)
    typedIdents :: [(Identifier, FilePath)]
typedIdents = [ (Identifier
n,FilePath
t) | (Identifier
n, IdentifierDetails FilePath -> Maybe FilePath
forall a. IdentifierDetails a -> Maybe a
identType -> Just FilePath
t) <- Map Identifier (IdentifierDetails FilePath)
-> [(Identifier, IdentifierDetails FilePath)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Identifier (IdentifierDetails FilePath)
 -> [(Identifier, IdentifierDetails FilePath)])
-> Map Identifier (IdentifierDetails FilePath)
-> [(Identifier, IdentifierDetails FilePath)]
forall a b. (a -> b) -> a -> b
$ NodeInfo FilePath -> Map Identifier (IdentifierDetails FilePath)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo FilePath
ni ]
    identTyps :: FilePath
identTyps
      | [(Identifier, FilePath)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Identifier, FilePath)]
typedIdents Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (NodeInfo FilePath -> [FilePath]
forall a. NodeInfo a -> [a]
nodeType NodeInfo FilePath
ni)
          = ((Identifier, FilePath) -> FilePath)
-> [(Identifier, FilePath)] -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Identifier
n,FilePath
t) -> Identifier -> FilePath
printName Identifier
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" :: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
t FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n") [(Identifier, FilePath)]
typedIdents
      | Bool
otherwise = FilePath
""

    printName :: Either ModuleName Name -> String
    printName :: Identifier -> FilePath
printName = (ModuleName -> FilePath)
-> (Name -> FilePath) -> Identifier -> FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ModuleName -> FilePath
moduleNameString Name -> FilePath
forall a. NamedThing a => a -> FilePath
getOccString

richTokenStyle
  :: Bool         -- ^ are we lacking a type annotation?
  -> ContextInfo  -- ^ in what context did this token show up?
  -> [StyleClass]
richTokenStyle :: Bool -> ContextInfo -> [FilePath]
richTokenStyle Bool
True  ContextInfo
Use           = [FilePath
"hs-type"]
richTokenStyle Bool
False ContextInfo
Use           = [FilePath
"hs-var"]
richTokenStyle  Bool
_    RecField{}    = [FilePath
"hs-var"]
richTokenStyle  Bool
_    PatternBind{} = [FilePath
"hs-var"]
richTokenStyle  Bool
_    MatchBind{}   = [FilePath
"hs-var"]
richTokenStyle  Bool
_    TyVarBind{}   = [FilePath
"hs-type"]
richTokenStyle  Bool
_    ValBind{}     = [FilePath
"hs-var"]
richTokenStyle  Bool
_    ContextInfo
TyDecl        = [FilePath
"hs-type"]
richTokenStyle  Bool
_    ClassTyDecl{} = [FilePath
"hs-type"]
richTokenStyle  Bool
_    Decl{}        = [FilePath
"hs-var"]
richTokenStyle  Bool
_    IEThing{}     = []  -- could be either a value or type

tokenStyle :: TokenType -> [StyleClass]
tokenStyle :: TokenType -> [FilePath]
tokenStyle TokenType
TkIdentifier = [FilePath
"hs-identifier"]
tokenStyle TokenType
TkKeyword = [FilePath
"hs-keyword"]
tokenStyle TokenType
TkString = [FilePath
"hs-string"]
tokenStyle TokenType
TkChar = [FilePath
"hs-char"]
tokenStyle TokenType
TkNumber = [FilePath
"hs-number"]
tokenStyle TokenType
TkOperator = [FilePath
"hs-operator"]
tokenStyle TokenType
TkGlyph = [FilePath
"hs-glyph"]
tokenStyle TokenType
TkSpecial = [FilePath
"hs-special"]
tokenStyle TokenType
TkSpace = []
tokenStyle TokenType
TkComment = [FilePath
"hs-comment"]
tokenStyle TokenType
TkCpp = [FilePath
"hs-cpp"]
tokenStyle TokenType
TkPragma = [FilePath
"hs-pragma"]
tokenStyle TokenType
TkUnknown = []

multiclass :: [StyleClass] -> HtmlAttr
multiclass :: [FilePath] -> HtmlAttr
multiclass = FilePath -> HtmlAttr
Html.theclass (FilePath -> HtmlAttr)
-> ([FilePath] -> FilePath) -> [FilePath] -> HtmlAttr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords

externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
externalAnchor :: Identifier -> Set ContextInfo -> Html -> Html
externalAnchor (Right Name
name) Set ContextInfo
contexts Html
content
  | Bool -> Bool
not (Name -> Bool
isInternalName Name
name)
  , (ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isBinding Set ContextInfo
contexts
  = Html -> Html
Html.thespan Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ FilePath -> HtmlAttr
Html.identifier (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
externalAnchorIdent Name
name ]
externalAnchor Identifier
_ Set ContextInfo
_ Html
content = Html
content

isBinding :: ContextInfo -> Bool
isBinding :: ContextInfo -> Bool
isBinding (ValBind BindType
RegularBind Scope
_ Maybe RealSrcSpan
_) = Bool
True
isBinding PatternBind{} = Bool
True
isBinding Decl{} = Bool
True
isBinding (RecField RecFieldContext
RecFieldDecl Maybe RealSrcSpan
_) = Bool
True
isBinding TyVarBind{} = Bool
True
isBinding ClassTyDecl{} = Bool
True
isBinding ContextInfo
_ = Bool
False

internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
internalAnchor :: Identifier -> Set ContextInfo -> Html -> Html
internalAnchor (Right Name
name) Set ContextInfo
contexts Html
content
  | Name -> Bool
isInternalName Name
name
  , (ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isBinding Set ContextInfo
contexts
  = Html -> Html
Html.thespan Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ FilePath -> HtmlAttr
Html.identifier (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
internalAnchorIdent Name
name ]
internalAnchor Identifier
_ Set ContextInfo
_ Html
content = Html
content

externalAnchorIdent :: Name -> String
externalAnchorIdent :: Name -> FilePath
externalAnchorIdent = Name -> FilePath
hypSrcNameUrl

internalAnchorIdent :: Name -> String
internalAnchorIdent :: Name -> FilePath
internalAnchorIdent = (FilePath
"local-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> (Name -> FilePath) -> Name -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (Name -> Int) -> Name -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
getKey (Unique -> Int) -> (Name -> Unique) -> Name -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Unique
nameUnique

-- | Generate the HTML hyperlink for an identifier
hyperlink :: SrcMaps -> Identifier -> Html -> Html
hyperlink :: SrcMaps -> Identifier -> Html -> Html
hyperlink (Map Module SrcPath
srcs, Map ModuleName SrcPath
srcs') Identifier
ident = case Identifier
ident of
    Right Name
name | Name -> Bool
isInternalName Name
name -> Name -> Html -> Html
internalHyperlink Name
name
               | Bool
otherwise -> Name -> Html -> Html
externalNameHyperlink Name
name
    Left ModuleName
name -> ModuleName -> Html -> Html
externalModHyperlink ModuleName
name

  where
    internalHyperlink :: Name -> Html -> Html
internalHyperlink Name
name Html
content =
        Html -> Html
Html.anchor Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ FilePath -> HtmlAttr
Html.href (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ FilePath
"#" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
internalAnchorIdent Name
name ]

    externalNameHyperlink :: Name -> Html -> Html
externalNameHyperlink Name
name Html
content = case Module -> Map Module SrcPath -> Maybe SrcPath
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
mdl Map Module SrcPath
srcs of
        Just SrcPath
SrcLocal -> Html -> Html
Html.anchor Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
            [ FilePath -> HtmlAttr
Html.href (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Module -> Name -> FilePath
hypSrcModuleNameUrl Module
mdl Name
name ]
        Just (SrcExternal FilePath
path) -> Html -> Html
Html.anchor Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
            [ FilePath -> HtmlAttr
Html.href (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> Maybe Module
-> Maybe Name
-> Maybe SrcSpan
-> FilePath
-> FilePath
spliceURL Maybe FilePath
forall a. Maybe a
Nothing (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
mdl) (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) Maybe SrcSpan
forall a. Maybe a
Nothing (FilePath
".." FilePath -> FilePath -> FilePath
</> FilePath
path) ]
        Maybe SrcPath
Nothing -> Html
content
      where
        mdl :: Module
mdl = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
name

    externalModHyperlink :: ModuleName -> Html -> Html
externalModHyperlink ModuleName
moduleName Html
content =
        case ModuleName -> Map ModuleName SrcPath -> Maybe SrcPath
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
moduleName Map ModuleName SrcPath
srcs' of
          Just SrcPath
SrcLocal -> Html -> Html
Html.anchor Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
            [ FilePath -> HtmlAttr
Html.href (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ ModuleName -> FilePath
hypSrcModuleUrl' ModuleName
moduleName ]
          Just (SrcExternal FilePath
path) -> Html -> Html
Html.anchor Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
            [ FilePath -> HtmlAttr
Html.href (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> Maybe ModuleName
-> Maybe Name
-> Maybe SrcSpan
-> FilePath
-> FilePath
spliceURL' Maybe FilePath
forall a. Maybe a
Nothing (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
moduleName) Maybe Name
forall a. Maybe a
Nothing Maybe SrcSpan
forall a. Maybe a
Nothing (FilePath
".." FilePath -> FilePath -> FilePath
</> FilePath
path) ]
          Maybe SrcPath
Nothing -> Html
content


renderSpace :: Int -> String -> Html
renderSpace :: Int -> FilePath -> Html
renderSpace !Int
_ FilePath
"" = Html
Html.noHtml
renderSpace !Int
line (Char
'\n':FilePath
rest) = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat
    [ Html -> Html
Html.thespan (Char -> Html
forall a. HTML a => a -> Html
Html.toHtml Char
'\n')
    , Int -> Html
lineAnchor (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    , Int -> FilePath -> Html
renderSpace (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) FilePath
rest
    ]
renderSpace Int
line FilePath
space =
    let (FilePath
hspace, FilePath
rest) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') FilePath
space
    in (Html -> Html
Html.thespan (Html -> Html) -> (FilePath -> Html) -> FilePath -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Html
forall a. HTML a => a -> Html
Html.toHtml) FilePath
hspace Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath -> Html
renderSpace Int
line FilePath
rest


lineAnchor :: Int -> Html
lineAnchor :: Int -> Html
lineAnchor Int
line = Html -> Html
Html.thespan Html
Html.noHtml Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ FilePath -> HtmlAttr
Html.identifier (FilePath -> HtmlAttr) -> FilePath -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
hypSrcLineUrl Int
line ]