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

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

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

splitTokens :: HieAST PrintedType -> [Token] -> ([Token], [Token], [Token])
splitTokens :: HieAST [Char] -> [Token] -> ([Token], [Token], [Token])
splitTokens HieAST [Char]
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 [Char] -> RealSrcSpan
forall a. HieAST a -> RealSrcSpan
nodeSpan HieAST [Char]
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 [Char] -> [Token] -> Html
renderWithAst SrcMaps
srcs Node{[HieAST [Char]]
RealSrcSpan
SourcedNodeInfo [Char]
nodeSpan :: forall a. HieAST a -> RealSrcSpan
sourcedNodeInfo :: SourcedNodeInfo [Char]
nodeSpan :: RealSrcSpan
nodeChildren :: [HieAST [Char]]
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] | RealSrcSpan
nodeSpan RealSrcSpan -> RealSrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== Token -> RealSrcSpan
tkSpan Token
tok -> SrcMaps -> NodeInfo [Char] -> Token -> Html
richToken SrcMaps
srcs NodeInfo [Char]
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 [Char] -> Token -> Html
richToken
          SrcMaps
srcs
          NodeInfo [Char]
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 :: 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 [Char] -> Token -> Html
richToken
          SrcMaps
srcs
          NodeInfo [Char]
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 :: RealSrcSpan
tkSpan = RealSrcSpan
nodeSpan
              }
          )
  [Token]
_ -> [HieAST [Char]] -> [Token] -> Html
go [HieAST [Char]]
nodeChildren [Token]
toks
  where
    nodeInfo :: NodeInfo [Char]
nodeInfo = NodeInfo [Char]
-> (NodeInfo [Char] -> NodeInfo [Char])
-> Maybe (NodeInfo [Char])
-> NodeInfo [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NodeInfo [Char]
forall a. NodeInfo a
emptyNodeInfo NodeInfo [Char] -> NodeInfo [Char]
forall a. a -> a
id (NodeOrigin
-> Map NodeOrigin (NodeInfo [Char]) -> Maybe (NodeInfo [Char])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeOrigin
SourceInfo (Map NodeOrigin (NodeInfo [Char]) -> Maybe (NodeInfo [Char]))
-> Map NodeOrigin (NodeInfo [Char]) -> Maybe (NodeInfo [Char])
forall a b. (a -> b) -> a -> b
$ SourcedNodeInfo [Char] -> Map NodeOrigin (NodeInfo [Char])
forall a. SourcedNodeInfo a -> Map NodeOrigin (NodeInfo a)
getSourcedNodeInfo SourcedNodeInfo [Char]
sourcedNodeInfo)
    go :: [HieAST [Char]] -> [Token] -> Html
go [HieAST [Char]]
_ [] = 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 [Char]
cur : [HieAST [Char]]
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 [Char] -> [Token] -> Html
renderWithAst SrcMaps
srcs HieAST [Char]
cur [Token]
during Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> [HieAST [Char]] -> [Token] -> Html
go [HieAST [Char]]
rest [Token]
after
      where
        ([Token]
before, [Token]
during, [Token]
after) = HieAST [Char] -> [Token] -> ([Token], [Token], [Token])
splitTokens HieAST [Char]
cur [Token]
xs
    anchored :: Html -> Html
anchored Html
c = (Either ModuleName Name
 -> IdentifierDetails [Char] -> Html -> Html)
-> Html
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
-> Html
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey Either ModuleName Name -> IdentifierDetails [Char] -> Html -> Html
forall {a}.
Either ModuleName Name -> IdentifierDetails a -> Html -> Html
anchorOne Html
c (NodeInfo [Char]
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo [Char]
nodeInfo)
    anchorOne :: Either ModuleName Name -> IdentifierDetails a -> Html -> Html
anchorOne Either ModuleName Name
n IdentifierDetails a
dets Html
c = Either ModuleName Name -> Set ContextInfo -> Html -> Html
externalAnchor Either ModuleName Name
n Set ContextInfo
d (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Either ModuleName Name -> Set ContextInfo -> Html -> Html
internalAnchor Either ModuleName Name
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 :: Token -> RealSrcSpan
tkType :: Token -> TokenType
tkValue :: Token -> ByteString
tkType :: TokenType
tkValue :: ByteString
tkSpan :: 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 -> [Char] -> Html
renderSpace (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
tkSpan) [Char]
tkValue'
  | Bool
otherwise = Html
tokenSpan Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[[Char]] -> HtmlAttr
multiclass [[Char]]
style]
  where
    tkValue' :: [Char]
tkValue' = [Char] -> [Char]
filterCRLF ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
utf8DecodeByteString ByteString
tkValue
    style :: [[Char]]
style = TokenType -> [[Char]]
tokenStyle TokenType
tkType
    tokenSpan :: Html
tokenSpan = Html -> Html
Html.thespan ([Char] -> Html
forall a. HTML a => a -> Html
Html.toHtml [Char]
tkValue')

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

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

    -- pick an arbitrary non-evidence identifier to hyperlink with
    identDet :: Maybe (Either ModuleName Name, IdentifierDetails [Char])
identDet = Map (Either ModuleName Name) (IdentifierDetails [Char])
-> Maybe (Either ModuleName Name, IdentifierDetails [Char])
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin (Map (Either ModuleName Name) (IdentifierDetails [Char])
 -> Maybe (Either ModuleName Name, IdentifierDetails [Char]))
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
-> Maybe (Either ModuleName Name, IdentifierDetails [Char])
forall a b. (a -> b) -> a -> b
$ (IdentifierDetails [Char] -> Bool)
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter IdentifierDetails [Char] -> Bool
forall {a}. IdentifierDetails a -> Bool
notEvidence (Map (Either ModuleName Name) (IdentifierDetails [Char])
 -> Map (Either ModuleName Name) (IdentifierDetails [Char]))
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
forall a b. (a -> b) -> a -> b
$ NodeInfo [Char]
-> Map (Either ModuleName Name) (IdentifierDetails [Char])
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers NodeInfo [Char]
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 (Either ModuleName Name, IdentifierDetails [Char])
identDet of
      Just (Either ModuleName Name
n, IdentifierDetails [Char]
_) -> SrcMaps -> Either ModuleName Name -> Html -> Html
hyperlink SrcMaps
srcs Either ModuleName Name
n
      Maybe (Either ModuleName Name, IdentifierDetails [Char])
Nothing -> Html -> Html
forall a. a -> a
id

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

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

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

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

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

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

externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
externalAnchor :: Either ModuleName Name -> 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
! [[Char] -> HtmlAttr
Html.identifier ([Char] -> HtmlAttr) -> [Char] -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
externalAnchorIdent Name
name]
externalAnchor Either ModuleName Name
_ 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 :: Either ModuleName Name -> 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
! [[Char] -> HtmlAttr
Html.identifier ([Char] -> HtmlAttr) -> [Char] -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
internalAnchorIdent Name
name]
internalAnchor Either ModuleName Name
_ Set ContextInfo
_ Html
content = Html
content

externalAnchorIdent :: Name -> String
externalAnchorIdent :: Name -> [Char]
externalAnchorIdent = Name -> [Char]
hypSrcNameUrl

internalAnchorIdent :: Name -> String
internalAnchorIdent :: Name -> [Char]
internalAnchorIdent = ([Char]
"local-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> [Char]) -> (Name -> Word64) -> Name -> [Char]
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 -> Either ModuleName Name -> Html -> Html
hyperlink (Map Module SrcPath
srcs, Map ModuleName SrcPath
srcs') Either ModuleName Name
ident = case Either ModuleName Name
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 :: [Char] -> [Char]
makeHyperlinkUrl [Char]
url | [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf [Char]
"file://" [Char]
url = [Char]
url
    makeHyperlinkUrl [Char]
url = [Char]
".." [Char] -> [Char] -> [Char]
</> [Char]
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
! [[Char] -> HtmlAttr
Html.href ([Char] -> HtmlAttr) -> [Char] -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ [Char]
"#" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
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
! [[Char] -> HtmlAttr
Html.href ([Char] -> HtmlAttr) -> [Char] -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Module -> Name -> [Char]
hypSrcModuleNameUrl Module
mdl Name
name]
      Just (SrcExternal [Char]
path) ->
        let hyperlinkUrl :: [Char]
hyperlinkUrl = [Char] -> [Char]
hypSrcModuleUrlToNameFormat ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
makeHyperlinkUrl [Char]
path
         in Html -> Html
Html.anchor Html
content
              Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
Html.href ([Char] -> HtmlAttr) -> [Char] -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Maybe Module -> Maybe Name -> Maybe SrcSpan -> [Char] -> [Char]
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 [Char]
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
! [[Char] -> HtmlAttr
Html.href ([Char] -> HtmlAttr) -> [Char] -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
hypSrcModuleUrl' ModuleName
moduleName]
        Just (SrcExternal [Char]
path) ->
          let hyperlinkUrl :: [Char]
hyperlinkUrl = [Char] -> [Char]
makeHyperlinkUrl [Char]
path
           in Html -> Html
Html.anchor Html
content
                Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
Html.href ([Char] -> HtmlAttr) -> [Char] -> HtmlAttr
forall a b. (a -> b) -> a -> b
$ Maybe ModuleName -> Maybe Name -> Maybe SrcSpan -> [Char] -> [Char]
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 [Char]
hyperlinkUrl]
        Maybe SrcPath
Nothing -> Html
content

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