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

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

import qualified Data.ByteString as BS

import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext)
import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique)
import GHC.Types.SrcLoc
import GHC.Types.Unique (getKey)
import GHC.Unit.Module (ModuleName, moduleNameString)
import GHC.Utils.Encoding (utf8DecodeByteString)
import System.FilePath.Posix ((</>))
import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html

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

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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Bool -> ContextInfo -> [String]
richTokenStyle ([String] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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]