Oleg Grenrus pushed to branch wip/shorter-this-module-links at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
    ... ... @@ -80,6 +80,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
    80 80 
       nc <- freshNameCache
    81 81 
       HieFile
    82 82 
         { hie_hs_file = file
    83 
    +    , hie_module = thisModule
    83 84 
         , hie_asts = HieASTs asts
    84 85 
         , hie_types = types
    85 86 
         , hie_hs_src = rawSrc
    ... ... @@ -116,7 +117,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
    116 117 
       let tokens = fmap (\tk -> tk{tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'
    117 118
    118 119 
       -- Produce and write out the hyperlinked sources
    119 
    -  writeUtf8File path . renderToString pretty . render' fullAst $ tokens
    120 
    +  writeUtf8File path . renderToString pretty . render' thisModule fullAst $ tokens
    120 121 
       where
    121 122 
         dflags = ifaceDynFlags iface
    122 123 
         sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
    ... ... @@ -128,7 +129,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
    128 129 
             False -- lex Haddocks as comment tokens
    129 130 
             True -- produce comment tokens
    130 131 
             False -- produce position pragmas tokens
    131 
    -    render' = render (Just srcCssFile) (Just highlightScript) srcs
    132 
    +    render' thisModule = render thisModule (Just srcCssFile) (Just highlightScript) srcs
    132 133 
         path = srcdir </> hypSrcModuleFile (ifaceMod iface)
    133 134
    134 135 
         emptyHieAst fileFs =

  • utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
    ... ... @@ -15,7 +15,7 @@ import GHC.Iface.Ext.Utils (emptyNodeInfo, isEvidenceContext)
    15 15 
     import GHC.Types.Name (Name, getOccString, isInternalName, nameModule, nameUnique)
    16 16 
     import GHC.Types.SrcLoc
    17 17 
     import GHC.Types.Unique (getKey)
    18 
    -import GHC.Unit.Module (ModuleName, moduleNameString)
    18 
    +import GHC.Unit.Module (Module, ModuleName, moduleNameString)
    19 19 
     import GHC.Utils.Encoding (utf8DecodeByteString)
    20 20 
     import System.FilePath.Posix ((</>))
    21 21 
     import Text.XHtml (Html, HtmlAttr, (!))
    ... ... @@ -28,7 +28,9 @@ type StyleClass = String
    28 28
    29 29 
     -- | Produce the HTML corresponding to a hyperlinked Haskell source
    30 30 
     render
    31 
    -  :: Maybe FilePath
    31 
    +  :: Module
    32 
    +  -- ^ this module
    33 
    +  -> Maybe FilePath
    32 34 
       -- ^ path to the CSS file
    33 35 
       -> Maybe FilePath
    34 36 
       -- ^ path to the JS file
    ... ... @@ -39,12 +41,12 @@ render
    39 41 
       -> [Token]
    40 42 
       -- ^ tokens to render
    41 43 
       -> Html
    42 
    -render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens
    44 
    +render thisModule mcss mjs srcs ast tokens = header mcss mjs <> body thisModule srcs ast tokens
    43 45
    44 
    -body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
    45 
    -body srcs ast tokens = Html.body . Html.pre $ hypsrc
    46 
    +body :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html
    47 
    +body thisModule srcs ast tokens = Html.body . Html.pre $ hypsrc
    46 48 
       where
    47 
    -    hypsrc = renderWithAst srcs ast tokens
    49 
    +    hypsrc = renderWithAst thisModule srcs ast tokens
    48 50
    49 51 
     header :: Maybe FilePath -> Maybe FilePath -> Html
    50 52 
     header Nothing Nothing = Html.noHtml
    ... ... @@ -75,9 +77,9 @@ splitTokens ast toks = (before, during, after)
    75 77
    76 78 
     -- | Turn a list of tokens into hyperlinked sources, threading in relevant link
    77 79 
     -- information from the 'HieAST'.
    78 
    -renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
    79 
    -renderWithAst srcs Node{..} toks = anchored $ case toks of
    80 
    -  [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok
    80 
    +renderWithAst :: Module -> SrcMaps -> HieAST PrintedType -> [Token] -> Html
    81 
    +renderWithAst thisModule srcs Node{..} toks = anchored $ case toks of
    82 
    +  [tok] | nodeSpan == tkSpan tok -> richToken thisModule srcs nodeInfo tok
    81 83 
       -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators
    82 84 
       -- as multiple tokens.
    83 85 
       --
    ... ... @@ -92,6 +94,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of
    92 94 
         | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
    93 95 
         , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan ->
    94 96 
             richToken
    97 
    +          thisModule
    95 98 
               srcs
    96 99 
               nodeInfo
    97 100 
               ( Token
    ... ... @@ -104,6 +107,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of
    104 107 
         | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
    105 108 
         , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan ->
    106 109 
             richToken
    110 
    +          thisModule
    107 111 
               srcs
    108 112 
               nodeInfo
    109 113 
               ( Token
    ... ... @@ -118,7 +122,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of
    118 122 
         go _ [] = mempty
    119 123 
         go [] xs = foldMap renderToken xs
    120 124 
         go (cur : rest) xs =
    121 
    -      foldMap renderToken before <> renderWithAst srcs cur during <> go rest after
    125 
    +      foldMap renderToken before <> renderWithAst thisModule srcs cur during <> go rest after
    122 126 
           where
    123 127 
             (before, during, after) = splitTokens cur xs
    124 128 
         anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo)
    ... ... @@ -137,8 +141,8 @@ renderToken Token{..}
    137 141 
         tokenSpan = Html.thespan (Html.toHtml tkValue')
    138 142
    139 143 
     -- | Given information about the source position of definitions, render a token
    140 
    -richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html
    141 
    -richToken srcs details Token{..}
    144 
    +richToken :: Module -> SrcMaps -> NodeInfo PrintedType -> Token -> Html
    145 
    +richToken thisModule srcs details Token{..}
    142 146 
       | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
    143 147 
       | otherwise = annotate details $ linked content
    144 148 
       where
    ... ... @@ -155,7 +159,7 @@ richToken srcs details Token{..}
    155 159
    156 160 
         -- If we have name information, we can make links
    157 161 
         linked = case identDet of
    158 
    -      Just (n, _) -> hyperlink srcs n
    162 
    +      Just (n, _) -> hyperlink thisModule srcs n
    159 163 
           Nothing -> id
    160 164
    161 165 
     -- | Remove CRLFs from source
    ... ... @@ -253,8 +257,8 @@ internalAnchorIdent :: Name -> String
    253 257 
     internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique
    254 258
    255 259 
     -- | Generate the HTML hyperlink for an identifier
    256 
    -hyperlink :: SrcMaps -> Identifier -> Html -> Html
    257 
    -hyperlink (srcs, srcs') ident = case ident of
    260 
    +hyperlink :: Module -> SrcMaps -> Identifier -> Html -> Html
    261 
    +hyperlink thisModule (srcs, srcs') ident = case ident of
    258 262 
       Right name
    259 263 
         | isInternalName name -> internalHyperlink name
    260 264 
         | otherwise -> externalNameHyperlink name
    ... ... @@ -270,7 +274,7 @@ hyperlink (srcs, srcs') ident = case ident of
    270 274 
         externalNameHyperlink name content = case Map.lookup mdl srcs of
    271 275 
           Just SrcLocal ->
    272 276 
             Html.anchor content
    273 
    -          ! [Html.href $ hypSrcModuleNameUrl mdl name]
    277 
    +          ! [Html.href $ hypSrcModuleNameUrl' thisModule mdl name]
    274 278 
           Just (SrcExternal path) ->
    275 279 
             let hyperlinkUrl = hypSrcModuleUrlToNameFormat $ makeHyperlinkUrl path
    276 280 
              in Html.anchor content

  • utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
    ... ... @@ -9,6 +9,7 @@ module Haddock.Backends.Hyperlinker.Utils
    9 9 
       , hypSrcNameUrl
    10 10 
       , hypSrcLineUrl
    11 11 
       , hypSrcModuleNameUrl
    12 
    +  , hypSrcModuleNameUrl'
    12 13 
       , hypSrcModuleLineUrl
    13 14 
       , hypSrcModuleUrlFormat
    14 15 
       , hypSrcModuleNameUrlFormat
    ... ... @@ -71,6 +72,12 @@ hypSrcLineUrl line = "line-" ++ show line
    71 72 
     hypSrcModuleNameUrl :: Module -> Name -> String
    72 73 
     hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
    73 74
    75 
    +{-# INLINE hypSrcModuleNameUrl' #-}
    76 
    +hypSrcModuleNameUrl' :: Module -> Module -> Name -> String
    77 
    +hypSrcModuleNameUrl' this_mdl mdl name
    78 
    +  | this_mdl == mdl = "#" ++ hypSrcNameUrl name
    79 
    +  | otherwise = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
    80 
    +
    74 81 
     {-# INLINE hypSrcModuleLineUrl #-}
    75 82 
     hypSrcModuleLineUrl :: Module -> Int -> String
    76 83 
     hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help