{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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 GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils ( isEvidenceContext , emptyNodeInfo )
import GHC.Unit.Module ( ModuleName, moduleNameString )
import GHC.Types.Name   ( getOccString, isInternalName, Name, nameModule, nameUnique )
import GHC.Types.SrcLoc
import GHC.Types.Unique ( getKey )
import GHC.Utils.Encoding ( utf8DecodeByteString )

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

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

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 String
-> Maybe String -> SrcMaps -> HieAST String -> [Token] -> Html
render Maybe String
mcss Maybe String
mjs SrcMaps
srcs HieAST String
ast [Token]
tokens = Maybe String -> Maybe String -> Html
header Maybe String
mcss Maybe String
mjs Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> SrcMaps -> HieAST String -> [Token] -> Html
body SrcMaps
srcs HieAST String
ast [Token]
tokens

body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
body :: SrcMaps -> HieAST String -> [Token] -> Html
body SrcMaps
srcs HieAST String
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 String -> [Token] -> Html
renderWithAst SrcMaps
srcs HieAST String
ast [Token]
tokens

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


splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token])
splitTokens :: HieAST String -> [Token] -> ([Token], [Token], [Token])
splitTokens HieAST String
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 = Span -> RealSrcLoc
realSrcSpanEnd (Token -> Span
tkSpan Token
t) RealSrcLoc -> RealSrcLoc -> Bool
forall a. Ord a => a -> a -> Bool
<= Span -> RealSrcLoc
realSrcSpanStart Span
nodeSp
    inAst :: Token -> Bool
inAst Token
t = Span
nodeSp Span -> Span -> Bool
`containsSpan` Token -> Span
tkSpan Token
t
    nodeSp :: Span
nodeSp = HieAST String -> Span
forall a. HieAST a -> Span
nodeSpan HieAST String
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 String -> [Token] -> Html
renderWithAst SrcMaps
srcs Node{[HieAST String]
Span
SourcedNodeInfo String
nodeSpan :: forall a. HieAST a -> Span
sourcedNodeInfo :: SourcedNodeInfo String
nodeSpan :: Span
nodeChildren :: [HieAST String]
nodeChildren :: forall a. HieAST a -> [HieAST a]
sourcedNodeInfo :: forall a. HieAST a -> SourcedNodeInfo a
..} [Token]
toks = Html -> Html
anchored (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ case [Token]
toks of

    [Token
tok] | Span
nodeSpan Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
== Token -> Span
tkSpan Token
tok -> SrcMaps -> NodeInfo String -> Token -> Html
richToken SrcMaps
srcs NodeInfo String
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 Span
s1, tok :: Token
tok@Token{ tkType :: Token -> TokenType
tkType = TokenType
TkIdentifier }, BacktickTok Span
s2]
          | Span -> RealSrcLoc
realSrcSpanStart Span
s1 RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> RealSrcLoc
realSrcSpanStart Span
nodeSpan
          , Span -> RealSrcLoc
realSrcSpanEnd Span
s2   RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> RealSrcLoc
realSrcSpanEnd Span
nodeSpan
          -> SrcMaps -> NodeInfo String -> Token -> Html
richToken SrcMaps
srcs NodeInfo String
nodeInfo
                       (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 :: Span
tkSpan = Span
nodeSpan })
    [OpenParenTok Span
s1, tok :: Token
tok@Token{ tkType :: Token -> TokenType
tkType = TokenType
TkOperator }, CloseParenTok Span
s2]
          | Span -> RealSrcLoc
realSrcSpanStart Span
s1 RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> RealSrcLoc
realSrcSpanStart Span
nodeSpan
          , Span -> RealSrcLoc
realSrcSpanEnd Span
s2   RealSrcLoc -> RealSrcLoc -> Bool
forall a. Eq a => a -> a -> Bool
== Span -> RealSrcLoc
realSrcSpanEnd Span
nodeSpan
          -> SrcMaps -> NodeInfo String -> Token -> Html
richToken SrcMaps
srcs NodeInfo String
nodeInfo
                       (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 :: Span
tkSpan = Span
nodeSpan })

    [Token]
_ -> [HieAST String] -> [Token] -> Html
go [HieAST String]
nodeChildren [Token]
toks
  where
    nodeInfo :: NodeInfo String
nodeInfo = NodeInfo String
-> (NodeInfo String -> NodeInfo String)
-> Maybe (NodeInfo String)
-> NodeInfo String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NodeInfo String
forall a. NodeInfo a
emptyNodeInfo NodeInfo String -> NodeInfo String
forall a. a -> a
id (NodeOrigin
-> Map NodeOrigin (NodeInfo String) -> Maybe (NodeInfo String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeOrigin
SourceInfo (Map NodeOrigin (NodeInfo String) -> Maybe (NodeInfo String))
-> Map NodeOrigin (NodeInfo String) -> Maybe (NodeInfo String)
forall a b. (a -> b) -> a -> b
$ SourcedNodeInfo String -> Map NodeOrigin (NodeInfo String)
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo String
sourcedNodeInfo)
    go :: [HieAST String] -> [Token] -> Html
go [HieAST String]
_ [] = Html
forall a. Monoid a => a
mempty
    go [] [Token]
xs = (Token -> Html) -> [Token] -> Html
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Token -> Html
renderToken [Token]
xs
    go (HieAST String
cur:[HieAST String]
rest) [Token]
xs =
        (Token -> Html) -> [Token] -> Html
forall m a. Monoid m => (a -> m) -> [a] -> m
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 String -> [Token] -> Html
renderWithAst SrcMaps
srcs HieAST String
cur [Token]
during Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> [HieAST String] -> [Token] -> Html
go [HieAST String]
rest [Token]
after
      where
        ([Token]
before,[Token]
during,[Token]
after) = HieAST String -> [Token] -> ([Token], [Token], [Token])
splitTokens HieAST String
cur [Token]
xs
    anchored :: Html -> Html
anchored Html
c = (Identifier -> IdentifierDetails String -> Html -> Html)
-> Html -> Map Identifier (IdentifierDetails String) -> Html
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Identifier -> IdentifierDetails String -> Html -> Html
forall {a}. Identifier -> IdentifierDetails a -> Html -> Html
anchorOne Html
c (NodeInfo String -> Map Identifier (IdentifierDetails String)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo String
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
Span
TokenType
tkSpan :: Token -> Span
tkType :: Token -> TokenType
tkValue :: Token -> ByteString
tkType :: TokenType
tkValue :: ByteString
tkSpan :: Span
..}
    | 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 -> String -> Html
renderSpace (Span -> Int
srcSpanStartLine Span
tkSpan) String
tkValue'
    | Bool
otherwise = Html
tokenSpan Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [ [String] -> HtmlAttr
multiclass [String]
style ]
  where
    tkValue' :: String
tkValue' = String -> String
filterCRLF (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
utf8DecodeByteString ByteString
tkValue
    style :: [String]
style = TokenType -> [String]
tokenStyle TokenType
tkType
    tokenSpan :: Html
tokenSpan = Html -> Html
Html.thespan (String -> Html
forall a. HTML a => a -> Html
Html.toHtml String
tkValue')


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

    contexts :: [ContextInfo]
contexts = (IdentifierDetails String -> [ContextInfo])
-> [IdentifierDetails String] -> [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 String -> Set ContextInfo)
-> IdentifierDetails String
-> [ContextInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentifierDetails String -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo) ([IdentifierDetails String] -> [ContextInfo])
-> (NodeInfo String -> [IdentifierDetails String])
-> NodeInfo String
-> [ContextInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Identifier (IdentifierDetails String)
-> [IdentifierDetails String]
forall k a. Map k a -> [a]
Map.elems (Map Identifier (IdentifierDetails String)
 -> [IdentifierDetails String])
-> (NodeInfo String -> Map Identifier (IdentifierDetails String))
-> NodeInfo String
-> [IdentifierDetails String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo String -> Map Identifier (IdentifierDetails String)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers (NodeInfo String -> [ContextInfo])
-> NodeInfo String -> [ContextInfo]
forall a b. (a -> b) -> a -> b
$ NodeInfo String
details

    -- pick an arbitrary non-evidence identifier to hyperlink with
    identDet :: Maybe (Identifier, IdentifierDetails String)
identDet = Map Identifier (IdentifierDetails String)
-> Maybe (Identifier, IdentifierDetails String)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin (Map Identifier (IdentifierDetails String)
 -> Maybe (Identifier, IdentifierDetails String))
-> Map Identifier (IdentifierDetails String)
-> Maybe (Identifier, IdentifierDetails String)
forall a b. (a -> b) -> a -> b
$ (IdentifierDetails String -> Bool)
-> Map Identifier (IdentifierDetails String)
-> Map Identifier (IdentifierDetails String)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter IdentifierDetails String -> Bool
forall {a}. IdentifierDetails a -> Bool
notEvidence (Map Identifier (IdentifierDetails String)
 -> Map Identifier (IdentifierDetails String))
-> Map Identifier (IdentifierDetails String)
-> Map Identifier (IdentifierDetails String)
forall a b. (a -> b) -> a -> b
$ NodeInfo String -> Map Identifier (IdentifierDetails String)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo String
details
    notEvidence :: IdentifierDetails a -> Bool
notEvidence = Bool -> Bool
not (Bool -> Bool)
-> (IdentifierDetails a -> Bool) -> IdentifierDetails a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContextInfo -> Bool) -> Set ContextInfo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ContextInfo -> Bool
isEvidenceContext (Set ContextInfo -> Bool)
-> (IdentifierDetails a -> Set ContextInfo)
-> IdentifierDetails a
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentifierDetails a -> Set ContextInfo
forall a. IdentifierDetails a -> Set ContextInfo
identInfo

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

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

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

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

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

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

multiclass :: [StyleClass] -> HtmlAttr
multiclass :: [String] -> HtmlAttr
multiclass = String -> HtmlAttr
Html.theclass (String -> HtmlAttr)
-> ([String] -> String) -> [String] -> HtmlAttr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
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
! [ String -> HtmlAttr
Html.identifier (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Name -> String
externalAnchorIdent Name
name ]
externalAnchor Identifier
_ Set ContextInfo
_ Html
content = Html
content

isBinding :: ContextInfo -> Bool
isBinding :: ContextInfo -> Bool
isBinding (ValBind BindType
RegularBind Scope
_ Maybe Span
_) = Bool
True
isBinding PatternBind{} = Bool
True
isBinding Decl{} = Bool
True
isBinding (RecField RecFieldContext
RecFieldDecl Maybe Span
_) = 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
! [ String -> HtmlAttr
Html.identifier (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Name -> String
internalAnchorIdent Name
name ]
internalAnchor Identifier
_ Set ContextInfo
_ Html
content = Html
content

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

internalAnchorIdent :: Name -> String
internalAnchorIdent :: Name -> String
internalAnchorIdent = (String
"local-" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> String
forall a. Show a => a -> String
show (Word64 -> String) -> (Name -> Word64) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Word64
getKey (Unique -> Word64) -> (Name -> Unique) -> Name -> Word64
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
    -- In a Nix environment, we have file:// URLs with absolute paths
    makeHyperlinkUrl :: String -> String
makeHyperlinkUrl String
url | String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf String
"file://" String
url = String
url
    makeHyperlinkUrl String
url = String
".." String -> String -> String
</> String
url

    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
! [ String -> HtmlAttr
Html.href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
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
!
            [ String -> HtmlAttr
Html.href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Module -> Name -> String
hypSrcModuleNameUrl Module
mdl Name
name ]
        Just (SrcExternal String
path) ->
          let hyperlinkUrl :: String
hyperlinkUrl = String -> String
hypSrcModuleUrlToNameFormat (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
makeHyperlinkUrl String
path
           in Html -> Html
Html.anchor Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
                [ String -> HtmlAttr
Html.href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Maybe Module -> Maybe Name -> Maybe SrcSpan -> String -> String
spliceURL (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 String
hyperlinkUrl ]
        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
!
            [ String -> HtmlAttr
Html.href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ ModuleName -> String
hypSrcModuleUrl' ModuleName
moduleName ]
          Just (SrcExternal String
path) ->
            let hyperlinkUrl :: String
hyperlinkUrl = String -> String
makeHyperlinkUrl String
path
             in Html -> Html
Html.anchor Html
content Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
!
                  [ String -> HtmlAttr
Html.href (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Maybe ModuleName -> Maybe Name -> Maybe SrcSpan -> String -> String
spliceURL' (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 String
hyperlinkUrl ]
          Maybe SrcPath
Nothing -> Html
content


renderSpace :: Int -> String -> Html
renderSpace :: Int -> String -> Html
renderSpace !Int
_ String
"" = Html
Html.noHtml
renderSpace !Int
line (Char
'\n':String
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 -> String -> Html
renderSpace (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
rest
    ]
renderSpace Int
line String
space =
    let (String
hspace, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
space
    in (Html -> Html
Html.thespan (Html -> Html) -> (String -> Html) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
forall a. HTML a => a -> Html
Html.toHtml) String
hspace Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Int -> String -> Html
renderSpace Int
line String
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
! [ String -> HtmlAttr
Html.identifier (String -> HtmlAttr) -> String -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Int -> String
hypSrcLineUrl Int
line ]