aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs8
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs3
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs11
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs10
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs2
-rw-r--r--haddock-api/src/Haddock/Convert.hs37
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs67
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs86
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs8
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs12
-rw-r--r--haddock-api/src/Haddock/Options.hs5
-rw-r--r--haddock-api/src/Haddock/Types.hs2
-rw-r--r--haddock-api/src/Haddock/Utils.hs12
17 files changed, 183 insertions, 121 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 7a2df3a2..2bae60e7 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -161,16 +161,21 @@ haddockWithGhc ghc args = handleTopExceptions $ do
Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
_ -> return flags
+ -- bypass the interface version check
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+
unless (Flag_NoWarnings `elem` flags) $ do
hypSrcWarnings flags
forM_ (warnings args) $ \warning -> do
hPutStrLn stderr warning
+ when noChecks $
+ hPutStrLn stderr noCheckWarning
ghc flags' $ do
dflags <- getDynFlags
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
- mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+ mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
forM_ mIfaceFile $ \(_, ifaceFile) -> do
putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
@@ -192,7 +197,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
liftIO $ renderStep dflags flags sinceQual qual packages []
@@ -203,6 +208,10 @@ warnings = map format . filter (isPrefixOf "-optghc")
where
format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
+-- | Create a warning about bypassing the interface version check
+noCheckWarning :: String
+noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++
+ "Haddock to crash when reading Haddock interface files."
withGhc :: [Flag] -> Ghc a -> IO a
withGhc flags action = do
@@ -220,7 +229,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
-> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+ let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+ packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
-- Create the interfaces -- this is the core part of Haddock.
let ifaceFiles = map snd packages
@@ -411,13 +421,14 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
readInterfaceFiles :: MonadIO m
=> NameCacheAccessor m
-> [(DocPaths, FilePath)]
+ -> Bool
-> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs = do
+readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
tryReadIface (paths, file) =
- readInterfaceFile name_cache_accessor file >>= \case
+ readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
Left err -> liftIO $ do
putStrLn ("Warning: Cannot read " ++ file ++ ":")
putStrLn (" " ++ err)
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 5f77c38c..73a200f0 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -36,7 +36,6 @@ import Data.Version
import System.Directory
import System.FilePath
-import System.IO
prefix :: [String]
prefix = ["-- Hoogle documentation, generated by Haddock"
@@ -56,10 +55,7 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
| not (null (versionBranch version)) ] ++
concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
- h <- openFile (odir </> filename) WriteMode
- hSetEncoding h utf8
- hPutStr h (unlines contents)
- hClose h
+ writeUtf8File (odir </> filename) (unlines contents)
ppModule :: DynFlags -> Interface -> [String]
ppModule dflags iface =
@@ -345,7 +341,7 @@ markupTag dflags = Markup {
markupOrderedList = box (TagL 'o'),
markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
markupCodeBlock = box TagPre,
- markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
+ markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel),
markupAName = const $ str "",
markupProperty = box TagPre . str,
markupExample = box TagPre . str . unlines . map exampleToString,
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 248a8a54..8f0c4b67 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -6,6 +6,7 @@ module Haddock.Backends.Hyperlinker
import Haddock.Types
+import Haddock.Utils (writeUtf8File)
import Haddock.Backends.Hyperlinker.Renderer
import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils
@@ -44,7 +45,7 @@ ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface
-> IO ()
ppHyperlinkedModuleSource srcdir pretty srcs iface =
case ifaceTokenizedSrc iface of
- Just tokens -> writeFile path . html . render' $ tokens
+ Just tokens -> writeUtf8File path . html . render' $ tokens
Nothing -> return ()
where
render' = render (Just srcCssFile) (Just highlightScript) srcs
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index acb2c892..f8494242 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -144,7 +144,7 @@ spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) =
-- A Haskell line comment
then case span (/= '\n') str' of
(str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest)
- (_, _) -> (str, "")
+ (_, _) -> (str, "")
-- An actual Haskell token
else let (str'', rest) = spanToNewline 0 str'
@@ -165,10 +165,10 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
go :: (RealSrcLoc, [T.Token], Bool)
-- ^ current position, tokens accumulated, currently in pragma (or not)
-
+
-> (Located L.Token, String)
-- ^ next token, its content
-
+
-> (RealSrcLoc, [T.Token], Bool)
-- ^ new position, new tokens accumulated, currently in pragma (or not)
@@ -179,12 +179,12 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
)
where
(next_pos, white) = mkWhitespace pos l
-
+
classifiedTok = [ Token (classify' tok) raw rss
| RealSrcSpan rss <- [l]
, not (null raw)
]
-
+
classify' | in_prag = const TkPragma
| otherwise = classify
@@ -378,6 +378,7 @@ classify tok =
ITLarrowtail {} -> TkGlyph
ITRarrowtail {} -> TkGlyph
+ ITcomment_line_prag -> TkUnknown
ITunknown {} -> TkUnknown
ITeof -> TkUnknown
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 613c6deb..69b43eca 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -135,7 +135,7 @@ ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
- writeFile filename (show tex)
+ writeUtf8File filename (show tex)
ppLaTeXModule :: String -> FilePath -> Interface -> IO ()
@@ -168,7 +168,7 @@ ppLaTeXModule _title odir iface = do
body = processExports exports
--
- writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex)
+ writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex)
-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
@@ -974,7 +974,7 @@ tupleParens _ = parenList
sumParens :: [LaTeX] -> LaTeX
-sumParens = ubxparens . hsep . punctuate (text " | ")
+sumParens = ubxparens . hsep . punctuate (text " |")
-------------------------------------------------------------------------------
@@ -1182,7 +1182,7 @@ parLatexMarkup ppId = Markup {
markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
- markupHyperlink = \l _ -> markupLink l,
+ markupHyperlink = \(Hyperlink u l) p -> markupLink u (fmap ($p) l),
markupAName = \_ _ -> empty,
markupProperty = \p _ -> quote $ verb $ text p,
markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
@@ -1202,8 +1202,8 @@ parLatexMarkup ppId = Markup {
fixString Verb s = s
fixString Mono s = latexMonoFilter s
- markupLink (Hyperlink url mLabel) = case mLabel of
- Just label -> text "\\href" <> braces (text url) <> braces (text label)
+ markupLink url mLabel = case mLabel of
+ Just label -> text "\\href" <> braces (text url) <> braces label
Nothing -> text "\\url" <> braces (text url)
-- Is there a better way of doing this? Just a space is an aribtrary choice.
@@ -1335,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma
ubxparens :: LaTeX -> LaTeX
-ubxparens h = text "(#" <> h <> text "#)"
+ubxparens h = text "(#" <+> h <+> text "#)"
nl :: LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 46d94b37..db29c7cf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -293,7 +293,7 @@ ppHtmlContents dflags odir doctitle _maybe_package
ppModuleTree pkg qual tree
]
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
@@ -436,9 +436,9 @@ ppHtmlIndex odir doctitle _maybe_package themes
mapM_ (do_sub_index index) initialChars
-- Let's add a single large index as well for those who don't know exactly what they're looking for:
let mergedhtml = indexPage False Nothing index
- writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
+ writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
- writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html)
where
indexPage showLetters ch items =
@@ -479,7 +479,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
do_sub_index this_ix c
= unless (null index_part) $
- writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
where
html = indexPage True (Just c) index_part
index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
@@ -573,7 +573,7 @@ ppHtmlModule odir doctitle themes
]
createDirectoryIfMissing True odir
- writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
+ writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 38aa7b7e..09aabc0c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -62,8 +62,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupHyperlink = \(Hyperlink url mLabel)
-> if insertAnchors
then anchor ! [href url]
- << fromMaybe url mLabel
- else toHtml $ fromMaybe url mLabel,
+ << fromMaybe (toHtml url) mLabel
+ else fromMaybe (toHtml url) mLabel,
markupAName = \aname
-> if insertAnchors
then namedAnchor aname << ""
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 7fbaec6d..62781fd0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -183,7 +183,7 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
ubxparens :: Html -> Html
-ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
dcolon, arrow, darrow, forallSymbol :: Bool -> Html
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 6eee353b..823e288e 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -36,9 +36,10 @@ import TyCon
import Type
import TyCoRep
import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy )
-import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey
- , tYPETyConKey, liftedRepDataConKey )
+import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName
+ , unitTy, promotedNilDataCon, promotedConsDataCon )
+import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
+ , liftedRepDataConKey )
import Unique ( getUnique )
import Util ( chkAppend, compareLength, dropList, filterByList, filterOut
, splitAtList )
@@ -118,10 +119,11 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
args_types_only typats
hs_rhs = synifyType WithinType rhs
- in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs
- , hsib_closed = True }
+ in HsIB { hsib_ext = map tyVarName tkvs
, hsib_body = FamEqn { feqn_ext = noExt
, feqn_tycon = name
+ , feqn_bndrs = Nothing
+ -- this must change eventually
, feqn_pats = annot_typats
, feqn_fixity = Prefix
, feqn_rhs = hs_rhs } }
@@ -457,9 +459,24 @@ synifyType _ (TyConApp tc tys)
ConstraintTuple -> HsConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType) vis_tys)
+ | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys)
+ | Just dc <- isPromotedDataCon_maybe tc
+ , isTupleDataCon dc
+ , dataConSourceArity dc == length vis_tys
+ = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys)
-- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
+ | getName tc == listTyConName, [ty] <- vis_tys =
noLoc $ HsListTy noExt (synifyType WithinType ty)
+ | tc == promotedNilDataCon, [] <- vis_tys
+ = noLoc $ HsExplicitListTy noExt Promoted []
+ | tc == promotedConsDataCon
+ , [ty1, ty2] <- vis_tys
+ = let hTy = synifyType WithinType ty1
+ in case synifyType WithinType ty2 of
+ tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy
+ -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy')
+ | otherwise
+ -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
@@ -567,6 +584,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyKindSig :: Kind -> LHsKind GhcRn
synifyKindSig k = synifyType WithinType k
+stripKindSig :: LHsType GhcRn -> LHsType GhcRn
+stripKindSig (L _ (HsKindSig _ t _)) = t
+stripKindSig t = t
+
synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
{ ihdClsName = getName cls
@@ -652,8 +673,8 @@ tcSplitSigmaTyPreserveSynonyms ty =
tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type)
tcSplitForAllTysPreserveSynonyms ty = split ty ty []
where
- split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | See Note [Invariant: Never expand type synonyms]
tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 2d72d117..8f7abd16 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -19,6 +19,7 @@ import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils
+import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
@@ -63,16 +64,24 @@ attachInstances expInfo ifaces instIfaceMap mods = do
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
attach index iface = do
- newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap)
+
+ let getInstDoc = findInstDoc iface ifaceMap instIfaceMap
+ getFixity = findFixity iface ifaceMap instIfaceMap
+
+ newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity)
(ifaceExportItems iface)
- let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)
+ let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface)
return $ iface { ifaceExportItems = newItems
, ifaceOrphanInstances = orphanInstances
}
-attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn]
-attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
- [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing)
+attachOrphanInstances
+ :: ExportInfo
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> [ClsInst] -- ^ a list of orphan instances
+ -> [DocInstance GhcRn]
+attachOrphanInstances expInfo getInstDoc cls_instances =
+ [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing)
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
@@ -80,40 +89,40 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
attachToExportItem
- :: NameEnv ([ClsInst], [FamInst])
+ :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of)
-> ExportInfo
- -> Interface
- -> IfaceMap
- -> InstIfaceMap
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> (Name -> Maybe Fixity) -- ^ how to lookup a fixity
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
-attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
+attachToExportItem index expInfo getInstDoc getFixity export =
case attachFixities export of
e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
insts <-
let mb_instances = lookupNameEnv index (tcdName d)
cls_instances = maybeToList mb_instances >>= fst
fam_instances = maybeToList mb_instances >>= snd
- fam_insts = [ ( synifyFamInst i opaque
- , doc
- , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d))
+ fam_insts = [ ( synFamInst
+ , getInstDoc n
+ , spanNameE n synFamInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| i <- sortBy (comparing instFam) fam_instances
, let n = getName i
- , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap
, not $ isNameHidden expInfo (fi_fam i)
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
+ , let synFamInst = synifyFamInst i opaque
]
- cls_insts = [ ( synifyInstHead i
- , instLookup instDocMap n iface ifaceMap instIfaceMap
- , spanName n (synifyInstHead i) (L eSpan (tcdName d))
+ cls_insts = [ ( synClsInst
+ , getInstDoc n
+ , spanName n synClsInst (L eSpan (tcdName d))
, nameModule_maybe n
)
| let is = [ (instanceSig i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
+ , let synClsInst = synifyInstHead i
]
-- fam_insts but with failing type fams filtered out
cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
@@ -133,7 +142,7 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
, n' <- n : (map fst subDocs ++ patsyn_names)
- , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ , f <- maybeToList (getFixity n')
] }
where
patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
@@ -152,16 +161,20 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
let L l r = spanName s ok linst
in L l (Right r)
+-- | Lookup the doc associated with a certain instance
+findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)
+findInstDoc iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceDocMap $ iface) <|>
+ (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap)
+
+-- | Lookup the fixity associated with a certain name
+findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity
+findFixity iface ifaceMap instIfaceMap = \name ->
+ (Map.lookup name . ifaceFixMap $ iface) <|>
+ (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|>
+ (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap)
-instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
- -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
-instLookup f name iface ifaceMap instIfaceMap =
- case Map.lookup name (f $ toInstalledIface iface) of
- res@(Just _) -> res
- Nothing -> do
- let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
- iface' <- Map.lookup (nameModule name) ifaceMaps
- Map.lookup name (f iface')
--------------------------------------------------------------------------------
-- Collecting and sorting instances
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index b6913012..59ad4fdf 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -135,7 +135,7 @@ rename dflags gre = rn
DocCodeBlock doc -> DocCodeBlock <$> rn doc
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
DocModule str -> pure (DocModule str)
- DocHyperlink l -> pure (DocHyperlink l)
+ DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
DocPic str -> pure (DocPic str)
DocMathInline str -> pure (DocMathInline str)
DocMathDisplay str -> pure (DocMathDisplay str)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 1c976410..42281470 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -23,15 +23,15 @@ import GHC hiding (NoLink)
import Name
import Outputable ( panic )
import RdrName (RdrName(Exact))
-import PrelNames (eqTyCon_RDR)
+import TysWiredIn (eqTyCon_RDR)
import Control.Applicative
+import Control.Arrow ( first )
import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
import Prelude hiding (mapM)
-
renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface dflags renamingEnv warnings iface =
@@ -92,56 +92,53 @@ renameInterface dflags renamingEnv warnings iface =
--------------------------------------------------------------------------------
-- Monad for renaming
---
--- The monad does two things for us: it passes around the environment for
--- renaming, and it returns a list of names which couldn't be found in
--- the environment.
--------------------------------------------------------------------------------
+-- | The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
newtype RnM a =
- RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
- -> (a,[Name])
+ RnM { unRn :: (Name -> (Bool, DocName))
+ -- Name lookup function. The 'Bool' indicates that if the name
+ -- was \"found\" in the environment.
+
+ -> (a, [Name] -> [Name])
+ -- Value returned, as well as a difference list of the names not
+ -- found
}
instance Monad RnM where
- (>>=) = thenRn
- return = pure
+ m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp
+ (b, out2) = unRn (k a) lkp
+ in (b, out1 . out2)
instance Functor RnM where
- fmap f x = do a <- x; return (f a)
+ fmap f (RnM lkp) = RnM (first f . lkp)
instance Applicative RnM where
- pure = returnRn
- (<*>) = ap
-
-returnRn :: a -> RnM a
-returnRn a = RnM (const (a,[]))
-thenRn :: RnM a -> (a -> RnM b) -> RnM b
-m `thenRn` k = RnM (\lkp -> case unRn m lkp of
- (a,out1) -> case unRn (k a) lkp of
- (b,out2) -> (b,out1++out2))
-
-getLookupRn :: RnM (Name -> (Bool, DocName))
-getLookupRn = RnM (\lkp -> (lkp,[]))
-
-outRn :: Name -> RnM ()
-outRn name = RnM (const ((),[name]))
+ pure a = RnM (const (a, id))
+ mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp
+ (x, out2) = unRn mx lkp
+ in (f x, out1 . out2)
+-- | Look up a 'Name' in the renaming environment.
lookupRn :: Name -> RnM DocName
-lookupRn name = do
- lkp <- getLookupRn
+lookupRn name = RnM $ \lkp ->
case lkp name of
- (False,maps_to) -> do outRn name; return maps_to
- (True, maps_to) -> return maps_to
-
-
-runRnFM :: LinkEnv -> RnM a -> (a,[Name])
-runRnFM env rn = unRn rn lkp
+ (False,maps_to) -> (maps_to, (name :))
+ (True, maps_to) -> (maps_to, id)
+
+-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
+-- Returns the renamed value along with a list of `Name`'s that could not be
+-- renamed because they weren't in the environment.
+runRnFM :: LinkEnv -> RnM a -> (a, [Name])
+runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist [])
where
- lkp n = case Map.lookup n env of
- Nothing -> (False, Undocumented n)
- Just mdl -> (True, Documented n mdl)
+ lkp n | isTyVarName n = (True, Undocumented n)
+ | otherwise = case Map.lookup n env of
+ Nothing -> (False, Undocumented n)
+ Just mdl -> (True, Documented n mdl)
--------------------------------------------------------------------------------
@@ -600,13 +597,16 @@ renameTyFamInstEqn eqn
rename_ty_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
- rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = rhs })
+ rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = rhs })
= do { tc' <- renameL tc
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
; pats' <- mapM renameLType pats
; rhs' <- renameLType rhs
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = rhs' }) }
@@ -620,6 +620,7 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
; rhs' <- renameLType rhs
; return (L loc (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = Nothing -- this is always Nothing
, feqn_pats = tvs'
, feqn_fixity = fixity
, feqn_rhs = rhs' })) }
@@ -633,13 +634,16 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
rename_data_fam_eqn
:: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
-> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
- rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
- , feqn_fixity = fixity, feqn_rhs = defn })
+ rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+ , feqn_pats = pats, feqn_fixity = fixity
+ , feqn_rhs = defn })
= do { tc' <- renameL tc
+ ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
; pats' <- mapM renameLType pats
; defn' <- renameDataDefn defn
; return (FamEqn { feqn_ext = noExt
, feqn_tycon = tc'
+ , feqn_bndrs = bndrs'
, feqn_pats = pats'
, feqn_fixity = fixity
, feqn_rhs = defn' }) }
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 30931c26..e9511e3d 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -47,14 +47,13 @@ specialize specs = go spec_map0
-- one by one, we should avoid infinite loops.
spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
+{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-}
-- | Instantiate given binders with corresponding types.
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: Data a
- => LHsQTyVars GhcRn -> [HsType GhcRn]
- -> a -> a
+specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
@@ -64,11 +63,12 @@ specializeTyVarBndrs bndrs typs =
bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
+
specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> PseudoFamilyDecl GhcRn
-> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl bndrs typs decl =
- decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
+ decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)}
specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
-> Sig GhcRn
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index ce6ecc78..e1d8dbe1 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -82,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807)
-binaryInterfaceVersion = 33
+#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809)
+binaryInterfaceVersion = 34
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -190,8 +190,9 @@ readInterfaceFile :: forall m.
MonadIO m
=> NameCacheAccessor m
-> FilePath
+ -> Bool -- ^ Disable version check. Can cause runtime crash.
-> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename = do
+readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
bh0 <- liftIO $ readBinMem filename
magic <- liftIO $ get bh0
@@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do
case () of
_ | magic /= binaryInterfaceMagic -> return . Left $
"Magic number mismatch: couldn't load interface file: " ++ filename
- | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
+ | not bypass_checks
+ , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
"Interface file is of wrong version: " ++ filename
| otherwise -> with_name_cache $ \update_nc -> do
@@ -432,7 +434,7 @@ instance Binary Example where
result <- get bh
return (Example expression result)
-instance Binary Hyperlink where
+instance Binary a => Binary (Hyperlink a) where
put_ bh (Hyperlink url label) = do
put_ bh url
put_ bh label
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index bdc98406..e314bbd0 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -84,6 +84,7 @@ data Flag
| Flag_Version
| Flag_CompatibleInterfaceVersions
| Flag_InterfaceVersion
+ | Flag_BypassInterfaceVersonCheck
| Flag_UseContents String
| Flag_GenContents
| Flag_UseIndex String
@@ -175,6 +176,8 @@ options backwardsCompat =
"output compatible interface file versions and exit",
Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)
"output interface file version and exit",
+ Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
+ "bypass the interface file version check (dangerous)",
Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")
"set verbosity level",
Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
@@ -186,7 +189,7 @@ options backwardsCompat =
Option [] ["gen-index"] (NoArg Flag_GenIndex)
"generate an HTML index from specified\ninterfaces",
Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
- "behave as if all modules have the\nignore-exports atribute",
+ "behave as if all modules have the\nignore-exports attribute",
Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
"behave as if MODULE has the hide attribute",
Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6da45a3b..39df598a 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -467,7 +467,7 @@ instance NFData ModuleName where rnf x = seq x ()
instance NFData id => NFData (Header id) where
rnf (Header a b) = a `deepseq` b `deepseq` ()
-instance NFData Hyperlink where
+instance NFData id => NFData (Hyperlink id) where
rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
instance NFData Picture where
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index c2cdddf7..0ce99fb2 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -33,6 +33,7 @@ module Haddock.Utils (
-- * Miscellaneous utilities
getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+ writeUtf8File,
-- * HTML cross reference mapping
html_xrefs_ref, html_xrefs_ref',
@@ -75,7 +76,7 @@ import Data.List ( isSuffixOf )
import Data.Maybe ( mapMaybe )
import System.Environment ( getProgName )
import System.Exit
-import System.IO ( hPutStr, stderr )
+import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile )
import System.IO.Unsafe ( unsafePerformIO )
import qualified System.FilePath.Posix as HtmlPath
import Distribution.Verbosity
@@ -395,6 +396,15 @@ isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
isDigitChar c = c >= '0' && c <= '9'
isAlphaNumChar c = isAlphaChar c || isDigitChar c
+-- | Utility to write output to UTF-8 encoded files.
+--
+-- The problem with 'writeFile' is that it picks up its 'TextEncoding' from
+-- 'getLocaleEncoding', and on some platforms (like Windows) this default
+-- encoding isn't enough for the characters we want to write.
+writeUtf8File :: FilePath -> String -> IO ()
+writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do
+ hSetEncoding h utf8
+ hPutStr h contents
-----------------------------------------------------------------------------
-- * HTML cross references
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:43:27 +0000