diff options
Diffstat (limited to 'haddock-api')
-rw-r--r-- | haddock-api/haddock-api.cabal | 1 | ||||
-rw-r--r-- | haddock-api/resources/html/quick-jump.css | 1 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 7 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 15 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 9 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Json.hs | 4 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 2 | ||||
-rw-r--r-- | haddock-api/src/Haddock/InterfaceFile.hs | 43 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Types.hs | 3 |
14 files changed, 69 insertions, 30 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 52191e13..e6de8b81 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -190,6 +190,7 @@ test-suite spec , containers , deepseq , directory + , exceptions , filepath , ghc-boot , transformers diff --git a/haddock-api/resources/html/quick-jump.css b/haddock-api/resources/html/quick-jump.css index d656f51c..cf10eee4 100644 --- a/haddock-api/resources/html/quick-jump.css +++ b/haddock-api/resources/html/quick-jump.css @@ -15,7 +15,6 @@ left: calc(50% - 22em); width: 44em; z-index: 1000; - pointer-events: none; overflow-y: auto; } diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 3bf12477..f7e1c77b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -35,7 +35,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.State import Data.Char -import Data.List +import Data.List (intercalate, isPrefixOf) import Data.Maybe import Data.Version @@ -343,7 +343,7 @@ markupTag dflags = Markup { markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), - markupModule = box (TagInline "a") . str, + markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label), markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupBold = box (TagInline "b"), diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 8ecc185b..d85a3970 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -18,7 +18,7 @@ import Data.Maybe import System.Directory import System.FilePath -import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 5b27847e..df1f94e6 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1241,7 +1241,12 @@ latexMarkup = Markup , markupAppend = \l r v -> l v . r v , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) - , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl))) + , markupModule = + \(ModLink m mLabel) v -> + case mLabel of + Just lbl -> inlineElem . tt $ lbl v empty + Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m + in (tt (text mdl))) , markupWarning = \p v -> p v , markupEmphasis = \p v -> inlineElem (emph (p v empty)) , markupBold = \p v -> inlineElem (bold (p v empty)) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 378d0559..7670b193 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -44,13 +44,14 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupAppend = (+++), markupIdentifier = thecode . ppId insertAnchors, markupIdentifierUnchecked = thecode . ppUncheckedLink qual, - markupModule = \m -> let (mdl,ref) = break (=='#') m - -- Accomodate for old style - -- foo\#bar anchors - mdl' = case reverse mdl of - '\\':_ -> init mdl - _ -> mdl - in ppModuleRef (mkModuleName mdl') ref, + markupModule = \(ModLink m lbl) -> + let (mdl,ref) = break (=='#') m + -- Accomodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef lbl (mkModuleName mdl') ref, markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupBold = strong, diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 8553cdfb..b324fa38 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -186,9 +186,12 @@ ppModule mdl = anchor ! [href (moduleUrl mdl)] << toHtml (moduleString mdl) -ppModuleRef :: ModuleName -> String -> Html -ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] - << toHtml (moduleNameString mdl) +ppModuleRef :: Maybe Html -> ModuleName -> String -> Html +ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << toHtml (moduleNameString mdl) +ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << lbl + -- NB: The ref parameter already includes the '#'. -- This function is only called from markupModule expanding a -- DocModule, which doesn't seem to be ever be used. diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index f3377965..b4c20b99 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -295,8 +295,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env ifaceHaddockCoverage interface percentage :: Int - percentage = - round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) + percentage = div (haddocked * 100) haddockable modString :: String modString = moduleString (ifaceMod interface) @@ -369,4 +368,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env - diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 72f1ab62..9a773b6c 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -727,7 +727,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Just synifiedDecl -> pure synifiedDecl Nothing -> pprPanic "availExportItem" (O.text err) - availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn + availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> IfM m [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 9b80d98f..92fb2e75 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -98,9 +98,9 @@ jsonDoc (DocIdentifierUnchecked modName) = jsonObject , ("modName", jsonString (showModName modName)) ] -jsonDoc (DocModule s) = jsonObject +jsonDoc (DocModule (ModLink m _l)) = jsonObject [ ("tag", jsonString "DocModule") - , ("string", jsonString s) + , ("string", jsonString m) ] jsonDoc (DocWarning x) = jsonObject diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 2df2bbbf..6da89e7c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -150,7 +150,7 @@ rename dflags gre = rn DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) - DocModule str -> pure (DocModule str) + DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l DocPic str -> pure (DocPic str) DocMathInline str -> pure (DocMathInline str) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index c6d61d05..f37e1da9 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -345,7 +345,7 @@ renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr fla renameLBinder = located renameBinder -- | Core renaming logic. -renameName :: (Eq name, SetName name) => name -> Rename name name +renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 9c34da54..95bfc903 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -46,7 +46,6 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique - data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, ifInstalledIfaces :: [InstalledInterface] @@ -69,6 +68,18 @@ ifUnitId if_ = binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface +-- Note [The DocModule story] +-- +-- Breaking changes to the DocH type result in Haddock being unable to read +-- existing interfaces. This is especially painful for interfaces shipped +-- with GHC distributions since there is no easy way to regenerate them! +-- +-- PR #1315 introduced a breaking change to the DocModule constructor. To +-- maintain backward compatibility we +-- +-- Parse the old DocModule constructor format (tag 5) and parse the contained +-- string into a proper ModLink structure. When writing interfaces we exclusively +-- use the new DocModule format (tag 24) -- IMPORTANT: Since datatypes in the GHC API might change between major -- versions, and because we store GHC datatypes in our interface files, we need @@ -87,7 +98,7 @@ binaryInterfaceVersion :: Word16 binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16] -binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] +binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion] #else #error Unsupported GHC version #endif @@ -159,7 +170,7 @@ writeInterfaceFile filename iface = do type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m +nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do @@ -444,6 +455,15 @@ instance Binary a => Binary (Hyperlink a) where label <- get bh return (Hyperlink url label) +instance Binary a => Binary (ModLink a) where + put_ bh (ModLink m label) = do + put_ bh m + put_ bh label + get bh = do + m <- get bh + label <- get bh + return (ModLink m label) + instance Binary Picture where put_ bh (Picture uri title) = do put_ bh uri @@ -522,9 +542,6 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh (DocIdentifier ae) = do putByte bh 4 put_ bh ae - put_ bh (DocModule af) = do - putByte bh 5 - put_ bh af put_ bh (DocEmphasis ag) = do putByte bh 6 put_ bh ag @@ -579,6 +596,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where put_ bh (DocTable x) = do putByte bh 23 put_ bh x + -- See note [The DocModule story] + put_ bh (DocModule af) = do + putByte bh 24 + put_ bh af get bh = do h <- getByte bh @@ -598,9 +619,13 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where 4 -> do ae <- get bh return (DocIdentifier ae) + -- See note [The DocModule story] 5 -> do af <- get bh - return (DocModule af) + return $ DocModule ModLink + { modLinkName = af + , modLinkLabel = Nothing + } 6 -> do ag <- get bh return (DocEmphasis ag) @@ -655,6 +680,10 @@ instance (Binary mod, Binary id) => Binary (DocH mod id) where 23 -> do x <- get bh return (DocTable x) + -- See note [The DocModule story] + 24 -> do + af <- get bh + return (DocModule af) _ -> error "invalid binary data found in the interface file" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 7fd11d69..83c9dd72 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -510,6 +510,9 @@ instance NFData id => NFData (Header id) where instance NFData id => NFData (Hyperlink id) where rnf (Hyperlink a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (ModLink id) where + rnf (ModLink a b) = a `deepseq` b `deepseq` () + instance NFData Picture where rnf (Picture a b) = a `deepseq` b `deepseq` () |