    {-# 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]