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

Commits:

27 changed files:

Changes:

  • compiler/GHC/Types/Unique.hs
    ... ... @@ -28,6 +28,7 @@ module GHC.Types.Unique (
    28 28 
             -- ** Constructors, destructors and operations on 'Unique's
    29 29 
             hasKey,
    30 30
    31 
    +        showUnique,
    31 32 
             pprUniqueAlways,
    32 33
    33 34 
             mkTag,
    ... ... @@ -61,7 +62,7 @@ import GHC.Utils.Word64 (intToWord64, word64ToInt)
    61 62 
     import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))
    62 63
    63 64 
     import GHC.Word         ( Word64 )
    64 
    -import Data.Char        ( chr, ord )
    65 
    +import Data.Char        ( chr, ord, isPrint )
    65 66
    66 67 
     import Language.Haskell.Syntax.Module.Name
    67 68
    ... ... @@ -308,8 +309,8 @@ showUnique uniq
    308 309 
         -- Avoid emitting non-printable characters in pretty uniques.
    309 310 
         -- See #25989.
    310 311 
         tagStr
    311 
    -      | tag < 'A' || tag > 'z' = show (ord tag) ++ "_"
    312 
    -      | otherwise              = [tag]
    312 
    +      | not (isPrint tag)  = show (ord tag) ++ "_"
    313 
    +      | otherwise          = [tag]
    313 314
    314 315 
     pprUniqueAlways :: IsLine doc => Unique -> doc
    315 316 
     -- The "always" means regardless of -dsuppress-uniques

  • libffi-tarballs
    1 
    -Subproject commit 7c51059557b68d29820a0a87cebfa6fe73c8adf5
    1 
    +Subproject commit 89a9b01c5647c8f0d3899435b99df690f582e9f1

  • libraries/Cabal
    1 
    -Subproject commit d9b0904b49dc84e0bfc79062daf2bbdf9d22a422
    1 
    +Subproject commit 269fd808e5d80223a229b6b19edfe6f5b109007a

  • libraries/Win32
    1 
    -Subproject commit 7d0772bb265a6c59eb14c441cf65c778895528df
    1 
    +Subproject commit 027cbcf0de25d681823ea92fb545a2604c3a6a8b

  • libraries/array
    1 
    -Subproject commit 6d59d5deb4f2a12656ab4c4371c0d12dac4875ef
    1 
    +Subproject commit e7ffb82fd40134da21d7642a41568f32c77c1a04

  • libraries/containers
    1 
    -Subproject commit 801b06e5d4392b028e519d5ca116a2881d559721
    1 
    +Subproject commit 4fda06c43ea14f808748aa8988158946c3ce0caf

  • libraries/deepseq
    1 
    -Subproject commit ae2762ac241a61852c9ff4c287af234fb1ad931f
    1 
    +Subproject commit af115cc226cc87fba89d0f6e2e9212e755c24983

  • libraries/directory
    1 
    -Subproject commit 6442a3cf04f74d82cdf8c9213324313d52b23d28
    1 
    +Subproject commit 005fa061171a55d35ce8dfe936cf3703525a8616

  • libraries/exceptions
    1 
    -Subproject commit b6c4290124eb1138358bf04ad9f33e67f6c5c1d8
    1 
    +Subproject commit 8e55b720f45db91f4895f710863ef9dbc10fe569

  • libraries/filepath
    1 
    -Subproject commit cbcd0ccf92f47e6c10fb9cc513a7b26facfc19fe
    1 
    +Subproject commit 65b0f8f31aac4a306135e27734988327f8eb1e6f

  • libraries/haskeline
    1 
    -Subproject commit 991953cd5d3bb9e8057de4a0d8f2cae3455865d8
    1 
    +Subproject commit 5f4bf62bf1f4846ad0b8d1fa9d45f902e3934511

  • libraries/hpc
    1 
    -Subproject commit 12675279dc5cbea4ade8b5157b080390d598f03f
    1 
    +Subproject commit f321056015dc36b454f323ca4285d684f4f782d3

  • libraries/os-string
    1 
    -Subproject commit 2e693aad07540173a0169971b27c9acac28eeff1
    1 
    +Subproject commit 4b5efedcd2da9314edda80d973a44e67020370db

  • libraries/parsec
    1 
    -Subproject commit 552730e23e1fd2dae46a60d75138b8d173492462
    1 
    +Subproject commit b87122c1c74b8240e65044a8f600f0427d4dd9c3

  • libraries/process
    1 
    -Subproject commit ae50731b5fb221a7631f7e9d818fc6716c85c51e
    1 
    +Subproject commit 9c3bfc214c72bbd0c8a30a1c41465deed0feaf47

  • libraries/semaphore-compat
    1 
    -Subproject commit ba87d1bb0209bd9f29bda1c878ddf345f8a2b199
    1 
    +Subproject commit 54882cd9a07322a4cf95d4fc0627107eaf1eb051

  • libraries/stm
    1 
    -Subproject commit 23bdcc2319965911af28542e76fc01f37c107d40
    1 
    +Subproject commit def18948f42a2eb8c34efdf65f7e614d1f6d5703

  • libraries/terminfo
    1 
    -Subproject commit 16db154e3e97e6bff62329574163851a7090f3b6
    1 
    +Subproject commit 788ce671cb1cec54c3c9b3ac1c1ba189e8424819

  • libraries/text
    1 
    -Subproject commit 5f343f668f421bfb30cead594e52d0ac6206ff67
    1 
    +Subproject commit b86564cae8d7262c7c4e7afe7a9163c83de3f175

  • libraries/time
    1 
    -Subproject commit 507f50844802f1469ba6cadfeefd4e3fecee0416
    1 
    +Subproject commit e5c5d1987011efe88a21ab6ded45aaa33a16274f

  • libraries/unix
    1 
    -Subproject commit c9b3e95b5c15b118e55522bd92963038c6a88160
    1 
    +Subproject commit 74ae1c0d9dd1518434f7d6cd3e63d7769599e0f9

  • nofib
    1 
    -Subproject commit b7391df4540ac8b11b35e1b2e2c15819b5171798
    1 
    +Subproject commit da7eed00e494aba1da9f51cb92089ca10e2454e7

  • 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
    ... ... @@ -14,8 +14,8 @@ import GHC.Iface.Ext.Types
    14 14 
     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 
    -import GHC.Types.Unique (getKey)
    18 
    -import GHC.Unit.Module (ModuleName, moduleNameString)
    17 
    +import GHC.Types.Unique (showUnique)
    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
    ... ... @@ -250,11 +254,11 @@ externalAnchorIdent :: Name -> String
    250 254 
     externalAnchorIdent = hypSrcNameUrl
    251 255
    252 256 
     internalAnchorIdent :: Name -> String
    253 
    -internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique
    257 
    +internalAnchorIdent = ("l-" ++) . showUnique . 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

  • utils/hpc
    1 
    -Subproject commit 5923da3fe77993b7afc15b5163cffcaa7da6ecf5
    1 
    +Subproject commit d1780eb21c1e5a1227fff80c8d325d5142f04255

  • utils/hsc2hs
    1 
    -Subproject commit fe3990b9f35000427b016a79330d9f195587cad8
    1 
    +Subproject commit c3b21800a67366c9591dc85a471d1dfdb1efcf29

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