haddock-api 2.24.2 → 2.25.0
raw patch · 33 files changed
+1452/−1287 lines, 33 filesdep +exceptionsdep +mtldep ~basedep ~ghc
Dependencies added: exceptions, mtl
Dependency ranges changed: base, ghc
Files
- haddock-api.cabal +10/−5
- resources/html/quick-jump.css +0/−1
- src/Haddock.hs +23/−19
- src/Haddock/Backends/Hoogle.hs +18/−20
- src/Haddock/Backends/Hyperlinker.hs +13/−16
- src/Haddock/Backends/Hyperlinker/Parser.hs +53/−49
- src/Haddock/Backends/Hyperlinker/Renderer.hs +26/−20
- src/Haddock/Backends/Hyperlinker/Utils.hs +9/−9
- src/Haddock/Backends/LaTeX.hs +63/−52
- src/Haddock/Backends/Xhtml.hs +9/−8
- src/Haddock/Backends/Xhtml/Decl.hs +84/−66
- src/Haddock/Backends/Xhtml/DocMarkup.hs +1/−1
- src/Haddock/Backends/Xhtml/Layout.hs +10/−10
- src/Haddock/Backends/Xhtml/Names.hs +3/−3
- src/Haddock/Backends/Xhtml/Types.hs +1/−1
- src/Haddock/Backends/Xhtml/Utils.hs +11/−6
- src/Haddock/Convert.hs +160/−82
- src/Haddock/GhcUtils.hs +98/−127
- src/Haddock/Interface.hs +223/−108
- src/Haddock/Interface/AttachInstances.hs +41/−29
- src/Haddock/Interface/Create.hs +397/−461
- src/Haddock/Interface/Json.hs +5/−5
- src/Haddock/Interface/LexParseRn.hs +7/−6
- src/Haddock/Interface/ParseModuleHeader.hs +3/−2
- src/Haddock/Interface/Rename.hs +40/−37
- src/Haddock/Interface/Specialize.hs +33/−18
- src/Haddock/InterfaceFile.hs +26/−25
- src/Haddock/ModuleTree.hs +8/−10
- src/Haddock/Options.hs +14/−8
- src/Haddock/Parser.hs +8/−8
- src/Haddock/Types.hs +48/−66
- src/Haddock/Utils.hs +5/−7
- test/Haddock/Backends/Hyperlinker/ParserSpec.hs +2/−2
haddock-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api-version: 2.24.2+version: 2.25.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -13,7 +13,7 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple-tested-with: GHC==8.10.*+tested-with: GHC==9.0.* extra-source-files: CHANGES.md@@ -43,8 +43,8 @@ default-language: Haskell2010 -- this package typically supports only single major versions- build-depends: base ^>= 4.14.0- , ghc ^>= 8.10+ build-depends: base ^>= 4.15.0+ , ghc ^>= 9.0 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.10.0 , xhtml ^>= 3000.2.2@@ -57,8 +57,10 @@ , containers , deepseq , directory+ , exceptions , filepath , ghc-boot+ , mtl , transformers hs-source-dirs: src@@ -66,6 +68,7 @@ ghc-options: -funbox-strict-fields -O2 -Wall -Wcompat+ -Wcompat-unqualified-imports -Widentities -Wredundant-constraints -Wnoncanonical-monad-instances@@ -172,7 +175,7 @@ Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 8.10+ build-depends: ghc ^>= 9.0 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.10.0 , xhtml ^>= 3000.2.2@@ -188,8 +191,10 @@ , containers , deepseq , directory+ , exceptions , filepath , ghc-boot+ , mtl , transformers build-tool-depends:
resources/html/quick-jump.css view
@@ -15,7 +15,6 @@ left: calc(50% - 22em); width: 44em; z-index: 1000;- pointer-events: none; overflow-y: auto; }
src/Haddock.hs view
@@ -55,27 +55,25 @@ import qualified Data.Map as Map import System.IO import System.Exit+import System.FilePath #ifdef IN_GHC_TREE-import System.FilePath import System.Environment (getExecutablePath) #else import qualified GHC.Paths as GhcPaths import Paths_haddock_api (getDataDir) #endif import System.Directory (doesDirectoryExist, getTemporaryDirectory)-import System.FilePath ((</>)) import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity)-import Config-import DynFlags hiding (projectVersion, verbosity)-import ErrUtils-import Packages-import Panic (handleGhcException)-import Module-import FastString-import Outputable (defaultUserStyle)+import GHC.Settings.Config+import GHC.Driver.Session hiding (projectVersion, verbosity)+import GHC.Utils.Outputable (defaultUserStyle, withPprStyle)+import GHC.Utils.Error+import GHC.Unit+import GHC.Utils.Panic (handleGhcException)+import GHC.Data.FastString -------------------------------------------------------------------------------- -- * Exception handling@@ -154,12 +152,17 @@ sinceQual <- rightOrThrowE (sinceQualification flags) -- inject dynamic-too into flags before we proceed- flags' <- ghc flags $ do+ flags'' <- ghc flags $ do df <- getDynFlags case lookup "GHC Dynamic" (compilerInfo df) of Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + flags' <- pure $ case optParCount flags'' of+ Nothing -> flags''+ Just Nothing -> Flag_OptGhc "-j" : flags''+ Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags''+ -- bypass the interface version check let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags @@ -185,7 +188,7 @@ forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do- logOutput dflags (defaultUserStyle dflags) (renderJson (jsonInterfaceFile ifaceFile))+ logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile)) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files@@ -286,6 +289,7 @@ opt_latex_style = optLaTeXStyle flags opt_source_css = optSourceCssFile flags opt_mathjax = optMathjax flags+ pkgs = unitState dflags dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags@@ -297,8 +301,8 @@ allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = fmap ifaceMod (listToMaybe ifaces)- pkgKey = fmap moduleUnitId pkgMod- pkgStr = fmap unitIdString pkgKey+ pkgKey = fmap moduleUnit pkgMod+ pkgStr = fmap unitString pkgKey pkgNameVer = modulePackageInfo dflags flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of@@ -315,7 +319,7 @@ (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) - pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap+ pkgSrcMap = Map.mapKeys moduleUnit extSrcMap pkgSrcMap' | Flag_HyperlinkedSource `elem` flags , Just k <- pkgKey@@ -344,11 +348,11 @@ -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module- unwire m = m { moduleUnitId = unwireUnitId dflags (moduleUnitId m) }+ unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++)- case readP_to_S parseModuleId mod_str of+ case readP_to_S parseHoleyModule mod_str of [(m, "")] | Just iface <- Map.lookup m installedMap -> return [iface]@@ -375,7 +379,7 @@ when (Flag_GenContents `elem` flags) $ do withTiming dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-}- ppHtmlContents dflags' odir title pkgStr+ ppHtmlContents pkgs odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual)@@ -385,7 +389,7 @@ when (Flag_Html `elem` flags) $ do withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-}- ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir+ ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual
src/Haddock/Backends/Hoogle.hs view
@@ -18,19 +18,20 @@ ppHoogle ) where -import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..)+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..) , PromotionFlag(..), TopLevelFlag(..) )-import InstEnv (ClsInst(..))+import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) import GHC-import Outputable+import GHC.Utils.Outputable as Outputable+import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Data.Char-import Data.List (isPrefixOf, intercalate)+import Data.List (intercalate, isPrefixOf) import Data.Maybe import Data.Version @@ -72,12 +73,12 @@ dropHsDocTy = f where g (L src x) = L src (f x)- f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e)+ f (HsForAllTy x a e) = HsForAllTy x a (g e) f (HsQualTy x a e) = HsQualTy x a (g e) f (HsBangTy x a b) = HsBangTy x a (g b) f (HsAppTy x a b) = HsAppTy x (g a) (g b) f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)- f (HsFunTy x a b) = HsFunTy x (g a) (g b)+ f (HsFunTy x w a b) = HsFunTy x w (g a) (g b) f (HsListTy x a) = HsListTy x (g a) f (HsTupleTy x a b) = HsTupleTy x a (map g b) f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)@@ -196,7 +197,6 @@ -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl-ppFam _ (XFamilyDecl nec) = noExtCon nec ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x =@@ -238,30 +238,29 @@ -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where- f (PrefixCon args) = [typeSig name $ args ++ [resType]]+ f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]- f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat+ f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> noLoc $ HsFunTy noExtField x y)- apps = foldl1 (\x y -> noLoc $ HsAppTy noExtField x y)+ funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)+ apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unLoc $ funs flds)+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unLoc $ getConNames con - resType = let c = HsTyVar noExtField NotPromoted (noLoc (tcdName dat))- as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)- in apps (map noLoc (c : as))+ tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n+ tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty+ tyVarArg _ = panic "ppCtor" - tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn- tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n- tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (noLoc (HsTyVar noExtField NotPromoted n)) k- tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec+ resType = apps $ map reL $+ (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :+ map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f@@ -270,7 +269,6 @@ typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty) name = out dflags $ map unLoc $ getConNames con-ppCtor _ _ _ (XConDecl nec) = noExtCon nec ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]
src/Haddock/Backends/Hyperlinker.hs view
@@ -18,14 +18,14 @@ import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieAST(..), HieASTs(..), NodeInfo(..) )-import HieBin ( readHieFile, hie_file_result)+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-import FastString ( mkFastString )-import Module ( Module, moduleName )-import NameCache ( initNameCache )-import SrcLoc ( mkRealSrcLoc, realSrcLocSpan )-import UniqSupply ( mkSplitUniqSupply )+import GHC.Data.FastString ( mkFastString )+import GHC.Unit.Module ( Module, moduleName )+import GHC.Types.Name.Cache ( initNameCache )+import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -- | Generate hyperlinked source for given interfaces.@@ -58,12 +58,14 @@ Just hfp -> do -- Parse the GHC-produced HIE file u <- mkSplitUniqSupply 'a'+ let nc = (initNameCache u [])+ ncu = NCU $ \f -> pure $ snd $ f nc HieFile { hie_hs_file = file , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc- } <- (hie_file_result . fst)- <$> (readHieFile (initNameCache u []) hfp)+ } <- hie_file_result+ <$> (readHieFile ncu hfp) -- Get the AST and tokens corresponding to the source file we want let fileFs = mkFastString file@@ -87,15 +89,10 @@ render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface) - emptyNodeInfo = NodeInfo- { nodeAnnotations = mempty- , nodeType = []- , nodeIdentifiers = mempty- } emptyHieAst fileFs = Node- { nodeInfo = emptyNodeInfo- , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0)+ { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) , nodeChildren = []+ , sourcedNodeInfo = SourcedNodeInfo mempty } -- | Name of CSS file in output directory.
src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -3,21 +3,24 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where +import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class import Control.Applicative ( Alternative(..) ) import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import BasicTypes ( IntegralLit(..) )-import DynFlags-import ErrUtils ( pprLocErrMsg )-import FastString ( mkFastString )-import Lexer ( P(..), ParseResult(..), PState(..), Token(..)- , mkPStatePure, lexer, mkParserFlags', getErrorMessages, addFatalError )-import Bag ( bagToList )-import Outputable ( showSDoc, panic, text, ($$) )-import SrcLoc-import StringBuffer ( StringBuffer, atEnd )+import GHC.Types.Basic ( IntegralLit(..) )+import GHC.Driver.Session+import GHC.Utils.Error ( pprLocErrMsg )+import GHC.Data.FastString ( mkFastString )+import GHC.Parser.Lexer as Lexer+ ( P(..), ParseResult(..), PState(..), Token(..)+ , mkPStatePure, lexer, mkParserFlags', getErrorMessages)+import GHC.Data.Bag ( bagToList )+import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) )+import GHC.Types.SrcLoc+import GHC.Data.StringBuffer ( StringBuffer, atEnd ) import Haddock.Backends.Hyperlinker.Types as T import Haddock.GhcUtils@@ -44,7 +47,7 @@ start = mkRealSrcLoc (mkFastString fpath) 1 1 pflags = mkParserFlags' (warningFlags dflags) (extensionFlags dflags)- (thisPackage dflags)+ (homeUnitId dflags) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens@@ -57,7 +60,10 @@ (b, _) <- getInput if not (atEnd b) then do- (newToks, inPrag') <- parseCppLine <|> parsePlainTok inPrag <|> unknownLine+ mtok <- runMaybeT (parseCppLine <|> parsePlainTok inPrag)+ (newToks, inPrag') <- case mtok of+ Nothing -> unknownLine+ Just a -> pure a go inPrag' (newToks ++ toks) else pure toks@@ -65,36 +71,36 @@ -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens wrappedLexer :: P (RealLocated Lexer.Token) wrappedLexer = Lexer.lexer False andThen- where andThen (L (RealSrcSpan s) t)+ where andThen (L (RealSrcSpan s _) t) | srcSpanStartLine s /= srcSpanEndLine s || srcSpanStartCol s /= srcSpanEndCol s = pure (L s t)- andThen (L (RealSrcSpan s) ITeof) = pure (L s ITeof)+ andThen (L (RealSrcSpan s _) ITeof) = pure (L s ITeof) andThen _ = wrappedLexer -- | Try to parse a CPP line (can fail)- parseCppLine :: P ([T.Token], Bool)- parseCppLine = do+ parseCppLine :: MaybeT P ([T.Token], Bool)+ parseCppLine = MaybeT $ do (b, l) <- getInput case tryCppLine l b of Just (cppBStr, l', b') -> let cppTok = T.Token { tkType = TkCpp , tkValue = cppBStr , tkSpan = mkRealSrcSpan l l' }- in setInput (b', l') *> pure ([cppTok], False)- _ -> empty+ in setInput (b', l') *> pure (Just ([cppTok], False))+ _ -> return Nothing -- | Try to parse a regular old token (can fail)- parsePlainTok :: Bool -> P ([T.Token], Bool) -- return list is only ever 0-2 elements+ parsePlainTok :: Bool -> MaybeT P ([T.Token], Bool) -- return list is only ever 0-2 elements parsePlainTok inPrag = do- (bInit, lInit) <- getInput- L sp tok <- Lexer.lexer False return- (bEnd, _) <- getInput+ (bInit, lInit) <- lift getInput+ L sp tok <- tryP (Lexer.lexer False return)+ (bEnd, _) <- lift getInput case sp of UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed- RealSrcSpan rsp -> do+ RealSrcSpan rsp _ -> do let typ = if inPrag then TkPragma else classify tok- RealSrcLoc lStart = srcSpanStart sp -- safe since @sp@ is real+ RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real (spaceBStr, bStart) = spanPosition lInit lStart bInit inPragDef = inPragma inPrag tok @@ -102,24 +108,24 @@ -- Update internal line + file position if this is a LINE pragma ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do- L _ (ITinteger (IL { il_value = line })) <- wrappedLexer- L _ (ITstring _ file) <- wrappedLexer- L spF ITclose_prag <- wrappedLexer+ L _ (ITinteger (IL { il_value = line })) <- tryP wrappedLexer+ L _ (ITstring _ file) <- tryP wrappedLexer+ L spF ITclose_prag <- tryP wrappedLexer let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF)- (bEnd'', _) <- getInput- setInput (bEnd'', newLoc)+ (bEnd'', _) <- lift getInput+ lift $ setInput (bEnd'', newLoc) pure (bEnd'', False) -- Update internal column position if this is a COLUMN pragma ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do- L _ (ITinteger (IL { il_value = col })) <- wrappedLexer- L spF ITclose_prag <- wrappedLexer+ L _ (ITinteger (IL { il_value = col })) <- tryP wrappedLexer+ L spF ITclose_prag <- tryP wrappedLexer let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col)- (bEnd'', _) <- getInput- setInput (bEnd'', newLoc)+ (bEnd'', _) <- lift getInput+ lift $ setInput (bEnd'', newLoc) pure (bEnd'', False) @@ -149,21 +155,20 @@ -- | Get the input getInput :: P (StringBuffer, RealSrcLoc)-getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc)+getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, psRealLoc srcLoc) -- | Set the input setInput :: (StringBuffer, RealSrcLoc) -> P ()-setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) ()-+setInput (buf, srcLoc) =+ P $ \p@PState{ loc = PsLoc _ buf_loc } ->+ POk (p { buffer = buf, loc = PsLoc srcLoc buf_loc }) () --- | Orphan instance that adds backtracking to 'P'-instance Alternative P where- empty = addFatalError noSrcSpan (text "Alterative.empty")- P x <|> P y = P $ \s -> case x s of { p@POk{} -> p- ; _ -> y s }+tryP :: P a -> MaybeT P a+tryP (P f) = MaybeT $ P $ \s -> case f s of+ POk s' a -> POk s' (Just a)+ PFailed _ -> POk s Nothing --- | Try a parser. If it fails, backtrack and return the pure value.-tryOrElse :: a -> P a -> P a+tryOrElse :: Alternative f => a -> f a -> f a tryOrElse x p = p <|> pure x -- | Classify given tokens as appropriate Haskell token type.@@ -236,7 +241,6 @@ ITcolumn_prag {} -> TkPragma ITscc_prag {} -> TkPragma ITgenerated_prag {} -> TkPragma- ITcore_prag {} -> TkPragma ITunpack_prag {} -> TkPragma ITnounpack_prag {} -> TkPragma ITann_prag {} -> TkPragma@@ -261,14 +265,17 @@ ITvbar -> TkGlyph ITlarrow {} -> TkGlyph ITrarrow {} -> TkGlyph+ ITlolly {} -> TkGlyph ITat -> TkGlyph ITtilde -> TkGlyph ITdarrow {} -> TkGlyph ITminus -> TkGlyph+ ITprefixminus -> TkGlyph ITbang -> TkGlyph ITdot -> TkOperator ITstar {} -> TkOperator ITtypeApp -> TkGlyph+ ITpercent -> TkGlyph ITbiglam -> TkGlyph @@ -321,10 +328,8 @@ ITcloseQuote {} -> TkSpecial ITopenTExpQuote {} -> TkSpecial ITcloseTExpQuote -> TkSpecial- ITidEscape {} -> TkUnknown- ITparenEscape -> TkSpecial- ITidTyEscape {} -> TkUnknown- ITparenTyEscape -> TkSpecial+ ITdollar -> TkSpecial+ ITdollardollar -> TkSpecial ITtyQuote -> TkSpecial ITquasiQuote {} -> TkUnknown ITqQuasiQuote {} -> TkUnknown@@ -377,7 +382,6 @@ ITcolumn_prag {} -> True ITscc_prag {} -> True ITgenerated_prag {} -> True- ITcore_prag {} -> True ITunpack_prag {} -> True ITnounpack_prag {} -> True ITann_prag {} -> True
src/Haddock/Backends/Hyperlinker/Renderer.hs view
@@ -12,12 +12,13 @@ import qualified Data.ByteString as BS -import HieTypes-import Module ( ModuleName, moduleNameString )-import Name ( getOccString, isInternalName, Name, nameModule, nameUnique )-import SrcLoc-import Unique ( getKey )-import Encoding ( utf8DecodeByteString )+import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Utils ( isEvidenceContext , emptyNodeInfo )+import GHC.Unit.Module ( ModuleName, moduleNameString )+import GHC.Types.Name ( getOccString, isInternalName, Name, nameModule, nameUnique )+import GHC.Types.SrcLoc+import GHC.Types.Unique ( getKey )+import GHC.Utils.Encoding ( utf8DecodeByteString ) import System.FilePath.Posix ((</>)) @@ -105,6 +106,7 @@ _ -> go nodeChildren toks where+ nodeInfo = maybe emptyNodeInfo id (Map.lookup SourceInfo $ getSourcedNodeInfo sourcedNodeInfo) go _ [] = mempty go [] xs = foldMap renderToken xs go (cur:rest) xs =@@ -139,8 +141,9 @@ contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details - -- pick an arbitary identifier to hyperlink with- identDet = Map.lookupMin . nodeIdentifiers $ details+ -- pick an arbitary non-evidence identifier to hyperlink with+ identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details+ notEvidence = not . any isEvidenceContext . identInfo -- If we have name information, we can make links linked = case identDet of@@ -163,7 +166,8 @@ | otherwise = mempty annotation = typ ++ identTyps typ = unlines (nodeType ni)- typedIdents = [ (n,t) | (n, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ]+ typedIdents = [ (n,t) | (n, c@(identType -> Just t)) <- Map.toList $ nodeIdentifiers ni+ , not (any isEvidenceContext $ identInfo c) ] identTyps | length typedIdents > 1 || null (nodeType ni) = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents@@ -176,17 +180,19 @@ :: Bool -- ^ are we lacking a type annotation? -> ContextInfo -- ^ in what context did this token show up? -> [StyleClass]-richTokenStyle True Use = ["hs-type"]-richTokenStyle False Use = ["hs-var"]-richTokenStyle _ RecField{} = ["hs-var"]-richTokenStyle _ PatternBind{} = ["hs-var"]-richTokenStyle _ MatchBind{} = ["hs-var"]-richTokenStyle _ TyVarBind{} = ["hs-type"]-richTokenStyle _ ValBind{} = ["hs-var"]-richTokenStyle _ TyDecl = ["hs-type"]-richTokenStyle _ ClassTyDecl{} = ["hs-type"]-richTokenStyle _ Decl{} = ["hs-var"]-richTokenStyle _ IEThing{} = [] -- could be either a value or type+richTokenStyle True Use = ["hs-type"]+richTokenStyle False Use = ["hs-var"]+richTokenStyle _ RecField{} = ["hs-var"]+richTokenStyle _ PatternBind{} = ["hs-var"]+richTokenStyle _ MatchBind{} = ["hs-var"]+richTokenStyle _ TyVarBind{} = ["hs-type"]+richTokenStyle _ ValBind{} = ["hs-var"]+richTokenStyle _ TyDecl = ["hs-type"]+richTokenStyle _ ClassTyDecl{} = ["hs-type"]+richTokenStyle _ Decl{} = ["hs-var"]+richTokenStyle _ IEThing{} = [] -- could be either a value or type+richTokenStyle _ EvidenceVarBind{} = []+richTokenStyle _ EvidenceVarUse{} = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"]
src/Haddock/Backends/Hyperlinker/Utils.hs view
@@ -18,11 +18,11 @@ import Haddock.Backends.Xhtml.Utils import GHC-import HieTypes ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )-import IfaceType-import Name ( getOccFS, getOccString )-import Outputable ( showSDoc )-import Var ( VarBndr(..) )+import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )+import GHC.Iface.Type+import GHC.Types.Name ( getOccFS, getOccString )+import GHC.Utils.Outputable( showSDoc )+import GHC.Types.Var ( VarBndr(..) ) import System.FilePath.Posix ((</>), (<.>)) @@ -82,9 +82,9 @@ lineFormat = "line-%{LINE}" --- * HIE file procesddsing+-- * HIE file processing --- This belongs in GHC's HieUtils...+-- This belongs in GHC.Iface.Ext.Utils... -- | Pretty-printed type, ready to be turned into HTML by @xhtml@ type PrintedType = String@@ -129,8 +129,8 @@ go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t- go (HFunTy a b) = IfaceFunTy VisArg a b- go (HQualTy con b) = IfaceFunTy InvisArg con b+ go (HFunTy w a b) = IfaceFunTy VisArg w a b+ go (HQualTy con b) = IfaceFunTy InvisArg many_ty con b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
src/Haddock/Backends/LaTeX.hs view
@@ -21,16 +21,17 @@ import Haddock.Types import Haddock.Utils import Haddock.GhcUtils-import Pretty hiding (Doc, quote)-import qualified Pretty+import GHC.Utils.Ppr hiding (Doc, quote)+import qualified GHC.Utils.Ppr as Pretty -import BasicTypes ( PromotionFlag(..) )+import GHC.Types.Basic ( PromotionFlag(..) ) import GHC-import OccName-import Name ( nameOccName )-import RdrName ( rdrNameOcc )-import FastString ( unpackFS )-import Outputable ( panic)+import GHC.Types.Name.Occurrence+import GHC.Types.Name ( nameOccName )+import GHC.Types.Name.Reader ( rdrNameOcc )+import GHC.Core.Type ( Specificity(..) )+import GHC.Data.FastString ( unpackFS )+import GHC.Utils.Outputable ( panic) import qualified Data.Map as Map import System.Directory@@ -356,8 +357,6 @@ , equals , ppType unicode (unLoc rhs) ]- ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec- ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec instancesBit = ppDocInstances unicode instances @@ -366,7 +365,6 @@ -> Bool -- ^ unicode -> Bool -- ^ is the family associated? -> LaTeX-ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info@@ -389,7 +387,6 @@ NoSig _ -> empty KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr- XFamilyResultSig nec -> noExtCon nec injAnn = case injectivity of Nothing -> empty@@ -486,9 +483,9 @@ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]- do_args _n leader (HsForAllTy _ fvf tvs ltype)+ do_args _n leader (HsForAllTy _ tele ltype) = [ ( decltt leader- , decltt (ppForAllPart unicode tvs fvf)+ , decltt (ppHsForAllTelescope tele unicode) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype)@@ -496,13 +493,13 @@ , decltt (ppLContextNoArrow lctxt unicode) <+> nl ) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)+ do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let latex = ppSideBySideField subdocs unicode field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r- do_args n leader (HsFunTy _ lt r)+ do_args n leader (HsFunTy _ _w lt r) = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) : do_largs (n+1) (arrow unicode) r do_args n leader t@@ -525,13 +522,20 @@ <+> ppType unicode ty --- | Pretty-print type variables.-ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX]-ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc)+ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX+ppHsForAllTelescope tele unicode = case tele of+ HsForAllVis { hsf_vis_bndrs = bndrs } ->+ hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->+ hsep (forallSymbol unicode : ppTyVars bndrs) <> dot +ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX]+ppTyVars = map (ppSymName . getName . hsLTyVarNameI)++ tyvarNames :: LHsQTyVars DocNameI -> [Name]-tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit+tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX@@ -743,7 +747,7 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: Bool -- ^ print explicit foralls- -> [LHsTyVarBndr DocNameI] -- ^ type variables+ -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables -> HsContext DocNameI -- ^ context -> Bool -- ^ unicode -> LaTeX@@ -751,7 +755,7 @@ where ppForall | null tvs || not forall_ = empty- | otherwise = ppForAllPart unicode tvs ForallInvis+ | otherwise = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode ppCtxt | null ctxt = empty@@ -795,7 +799,7 @@ | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc- , hsep (map (ppLParendType unicode) args)+ , hsep (map (ppLParendType unicode . hsScaledThing) args) ] -- Record constructor, e.g. 'Identity { runIdentity :: a }'@@ -805,9 +809,9 @@ InfixCon arg1 arg2 | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_- , ppLParendType unicode arg1+ , ppLParendType unicode (hsScaledThing arg1) , ppOccInfix- , ppLParendType unicode arg2+ , ppLParendType unicode (hsScaledThing arg2) ] ConDeclGADT{}@@ -817,9 +821,8 @@ -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ]- XConDecl nec -> noExtCon nec - fieldPart = case (con, getConArgs con) of+ fieldPart = case (con, getConArgsI con) of -- Record style GADTs (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] @@ -827,10 +830,10 @@ (_, RecCon (L _ fields)) -> doRecordFields fields -- Any GADT or a regular H98 prefix data constructor- (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args+ (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) -- An infix H98 data constructor- (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2]+ (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) _ -> empty @@ -851,7 +854,6 @@ [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ]- XConDecl nec -> noExtCon nec -- don't use "con_doc con", in case it's reconstructed from a .hi file,@@ -871,7 +873,6 @@ -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst-ppSideBySideField _ _ (XConDeclField nec) = noExtCon nec -- | Pretty-print a bundled pattern synonym@@ -924,7 +925,8 @@ -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX+ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>+ Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX ppAppDocNameTyVarBndrs unicode n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc) where@@ -1034,51 +1036,56 @@ ppLParendType unicode ki ppLHsTypeArg _ (HsArgPar _) = text "" -ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX-ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name-ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) =- parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind)-ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec+class RenderableBndrFlag flag where+ ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX +instance RenderableBndrFlag () where+ ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name+ ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) =+ parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind++instance RenderableBndrFlag Specificity where+ ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name+ ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name+ ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) =+ parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind+ ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) =+ braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind+ ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocNameI -> LaTeX ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode - -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX-ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv- where- tvs' = ppTyVars unicode tvs- fv = case fvf of- ForallVis -> text "\\ " <> arrow unicode- ForallInvis -> dot- ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX-ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode- = sep [ ppForAllPart unicode tvs fvf+ppr_mono_ty (HsForAllTy _ tele ty) unicode+ = sep [ ppHsForAllTelescope tele unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode , ppr_mono_lty ty unicode ]-ppr_mono_ty (HsFunTy _ ty1 ty2) u+ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u- , arrow u <+> ppr_mono_lty ty2 u ]+ , arr <+> ppr_mono_lty ty2 u ]+ where arr = case mult of+ HsLinearArrow _ -> lollipop u+ HsUnrestrictedArrow _ -> arrow u+ HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)-ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind+ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy v _) _ = absurd v@@ -1365,13 +1372,17 @@ quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX+dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->")+lollipop unicode = text (if unicode then "⊸" else "%1 ->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") starSymbol unicode = text (if unicode then "★" else "*") atSign unicode = text (if unicode then "@" else "@")++multAnnotation :: LaTeX+multAnnotation = text "%" dot :: LaTeX dot = char '.'
src/Haddock/Backends/Xhtml.hs view
@@ -50,13 +50,14 @@ import Data.Ord ( comparing ) import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )-import Name+import GHC.Types.Name+import GHC.Unit.State -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- -ppHtml :: DynFlags+ppHtml :: UnitState -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface]@@ -76,7 +77,7 @@ -> Bool -- ^ Also write Quickjump index -> IO () -ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue+ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode pkg qual debug withQuickjump = do@@ -85,7 +86,7 @@ visible i = OptHide `notElem` ifaceOptions i when (isNothing maybe_contents_url) $- ppHtmlContents dflags odir doctitle maybe_package+ ppHtmlContents state odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents@@ -254,7 +255,7 @@ ppHtmlContents- :: DynFlags+ :: UnitState -> FilePath -> String -> Maybe String@@ -268,14 +269,14 @@ -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO ()-ppHtmlContents dflags odir doctitle _maybe_package+ppHtmlContents state odir doctitle _maybe_package themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do- let tree = mkModuleTree dflags showPkgs+ let tree = mkModuleTree state showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces , not (instIsSig iface)]- sig_tree = mkModuleTree dflags showPkgs+ sig_tree = mkModuleTree state showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces , instIsSig iface]
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -35,12 +35,13 @@ import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) -import BasicTypes (PromotionFlag(..), isPromoted)+import GHC.Core.Type ( Specificity(..) )+import GHC.Types.Basic (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) import GHC.Exts-import Name-import BooleanFormula-import RdrName ( rdrNameOcc )+import GHC.Types.Name+import GHC.Data.BooleanFormula+import GHC.Types.Name.Reader ( rdrNameOcc ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only@@ -151,8 +152,10 @@ do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]- do_args n leader (HsForAllTy _ fvf tvs ltype)- = do_largs n (leader <+> ppForAllPart unicode qual tvs fvf) ltype+ do_args n leader (HsForAllTy _ tele ltype)+ = do_largs n leader' ltype+ where+ leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt)@@ -161,14 +164,14 @@ = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)+ do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (ldr <+> html, mdoc, subs) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy _ lt r)+ do_args n leader (HsFunTy _ _w lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r @@ -209,7 +212,8 @@ -- | Pretty-print type variables.-ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]+ppTyVars :: RenderableBndrFlag flag =>+ Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs @@ -305,8 +309,6 @@ , Nothing , [] )- ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec- ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec -- | Print a pseudo family declaration@@ -331,7 +333,6 @@ -> Bool -- ^ is an associated type -> FamilyDecl DocNameI -- ^ family declaration -> Unicode -> Qualification -> Html-ppFamHeader _ _ (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader summary associated (FamilyDecl { fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity@@ -371,7 +372,6 @@ NoSig _ -> noHtml KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr- XFamilyResultSig nec -> noExtCon nec --------------------------------------------------------------------------------@@ -390,7 +390,8 @@ -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html+ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>+ Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where@@ -492,7 +493,7 @@ +++ shortSubDecls False ( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats- , let doc = lookupAnySubdoc (unLoc $ fdLName $ unLoc at) subdocs ] +++ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults @@ -517,9 +518,8 @@ -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs- decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname- , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs- , tcdATs = ats, tcdATDefs = atsDefs })+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection curname pkg qual d@@ -603,7 +603,7 @@ -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] ==- [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns]+ [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing@@ -634,10 +634,12 @@ -- force Splice = True to use line URLs where instName = getOccString origin- instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)+ instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) =- ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc)-+ (instanceAnchor, mModule, mdl, loc)+ where+ instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"+ mModule = ppInstHead links splice unicode qual mdoc origin False no inst mdl ppOrphanInstances :: LinksInfo -> [DocInstance DocNameI]@@ -649,9 +651,12 @@ instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) - instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)+ instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName) instDecl no (inst, mdoc, loc, mdl) =- ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc)+ (instanceAnchor, mModule, mdl, loc)+ where+ instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"+ mModule = ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification@@ -768,7 +773,6 @@ isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False- XConDecl{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames@@ -802,7 +806,6 @@ isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False- XConDecl{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix@@ -854,14 +857,14 @@ -- Prefix constructor, e.g. 'Just a' PrefixCon args ->- ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)+ ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) ->- ( header_ <+> ppOcc <+> char '{'+ ( header_ +++ ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ]@@ -870,9 +873,9 @@ -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 ->- ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1+ ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix- , ppLParendType unicode qual HideEmptyContexts arg2+ , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) ] , noHtml , noHtml@@ -884,7 +887,6 @@ , noHtml , noHtml )- XConDecl nec -> noExtCon nec where occ = map (nameOccName . getName . unLoc) $ getConNamesI con@@ -928,7 +930,7 @@ PrefixCon args | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppOcc- , hsep (map (ppLParendType unicode qual HideEmptyContexts) args)+ , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , fixity ] @@ -938,9 +940,9 @@ -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 | hasArgDocs -> header_ <+> ppOcc <+> fixity- | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1+ | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix- , ppLParendType unicode qual HideEmptyContexts arg2+ , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) , fixity ] @@ -953,9 +955,8 @@ , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ]- XConDecl nec -> noExtCon nec - fieldPart = case (con, getConArgs con) of+ fieldPart = case (con, getConArgsI con) of -- Record style GADTs (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] @@ -976,13 +977,12 @@ doConstrArgsWithDocs args = subFields pkg qual $ case con of ConDeclH98{} -> [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])- | (i, arg) <- zip [0..] args+ | (i, arg) <- zip [0..] (map hsScaledThing args) , let mdoc = Map.lookup i argDocs ] ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts- XConDecl nec -> noExtCon nec -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC.@@ -993,7 +993,7 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: Bool -- ^ print explicit foralls- -> [LHsTyVarBndr DocNameI] -- ^ type variables+ -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables -> HsContext DocNameI -- ^ context -> Unicode -> Qualification -> Html@@ -1001,7 +1001,7 @@ where ppForall | null tvs || not forall_ = noHtml- | otherwise = ppForAllPart unicode qual tvs ForallInvis+ | otherwise = ppForAllPart unicode qual (HsForAllInvis noExtField tvs) ppCtxt | null ctxt = noHtml@@ -1026,14 +1026,12 @@ -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst-ppSideBySideField _ _ _ (XConDeclField nec) = noExtCon nec ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype-ppShortField _ _ _ (XConDeclField nec) = noExtCon nec -- | Pretty print an expanded pattern (for bundled patterns)@@ -1134,14 +1132,29 @@ ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode qual emptyCtxts ki ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""-ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html-ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =- ppDocName qual Raw False name-ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) =- parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>- ppLKind unicode qual kind)-ppHsTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec +class RenderableBndrFlag flag where+ ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html++instance RenderableBndrFlag () where+ ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) =+ ppDocName qual Raw False name+ ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) =+ parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+ ppLKind unicode qual kind)++instance RenderableBndrFlag Specificity where+ ppHsTyVarBndr _ qual (UserTyVar _ SpecifiedSpec (L _ name)) =+ ppDocName qual Raw False name+ ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) =+ braces $ ppDocName qual Raw False name+ ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =+ parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+ ppLKind unicode qual kind)+ ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =+ braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+ ppLKind unicode qual kind)+ ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) @@ -1155,16 +1168,16 @@ hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = case unLoc t of- HsForAllTy _ _ _ s -> hasNonEmptyContext s- HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True- HsFunTy _ _ s -> hasNonEmptyContext s+ HsForAllTy _ _ s -> hasNonEmptyContext s+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True+ HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of- HsForAllTy _ _ _ s -> isFirstContextEmpty s- HsQualTy _ cxt _ -> null (unLoc cxt)- HsFunTy _ _ s -> isFirstContextEmpty s+ HsForAllTy _ _ s -> isFirstContextEmpty s+ HsQualTy _ cxt _ -> null (unLoc cxt)+ HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False @@ -1175,21 +1188,21 @@ let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ -ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> Html-ppForAllPart unicode qual tvs fvf = hsep (forallSymbol unicode : tvs') +++ fv- where- tvs' = ppTyVars unicode qual tvs- fv = case fvf of- ForallVis -> spaceHtml +++ arrow unicode- ForallInvis -> dot+ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html+ppForAllPart unicode qual tele = case tele of+ HsForAllVis { hsf_vis_bndrs = bndrs } ->+ hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) ++++ spaceHtml +++ arrow unicode+ HsForAllInvis { hsf_invis_bndrs = bndrs } ->+ hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html-ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts- = ppForAllPart unicode qual tvs fvf <+> ppr_mono_lty ty unicode qual emptyCtxts+ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts+ = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts@@ -1205,10 +1218,15 @@ | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*")-ppr_mono_ty (HsFunTy _ ty1 ty2) u q e =+ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts- , arrow u <+> ppr_mono_lty ty2 u q e+ , arr <+> ppr_mono_lty ty2 u q e ]+ where arr = case mult of+ HsLinearArrow _ -> lollipop u+ HsUnrestrictedArrow _ -> arrow u+ HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u+ ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsSumTy _ tys) u q _ =
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -32,7 +32,7 @@ import Data.Maybe (fromMaybe) import GHC-import Name+import GHC.Types.Name parHtmlMarkup :: Qualification -> Bool
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -50,9 +50,9 @@ import Text.XHtml hiding ( name, title, quote ) import Data.Maybe (fromMaybe) -import FastString ( unpackFS )+import GHC.Data.FastString ( unpackFS ) import GHC-import Name (nameOccName)+import GHC.Types.Name (nameOccName) -------------------------------------------------------------------------------- -- * Sections of the document@@ -153,21 +153,21 @@ -- | Sub table with source information (optional). subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool- -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html+ -> [(String, SubDecl, Maybe Module, Located DocName)] -> Maybe Html subTableSrc _ _ _ _ [] = Nothing subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where- subRow ((decl, mdoc, subs), mdl, L loc dn) =+ subRow (instanchor, (decl, mdoc, subs), mdl, L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) <+> linkHtml loc mdl dn <->- docElement td << fmap (docToHtml Nothing pkg qual) mdoc+ docElement td << fmap (docToHtml (Just instanchor) pkg qual) mdoc ) : map (cell . (td <<)) subs linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html- linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn+ linkHtml loc@(RealSrcSpan _ _) mdl dn = links lnks loc splice mdl dn linkHtml _ _ _ = noHtml subBlock :: [Html] -> Maybe Html@@ -201,7 +201,7 @@ subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool- -> [(SubDecl, Maybe Module, Located DocName)] -> Html+ -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents))@@ -214,7 +214,7 @@ subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool- -> [(SubDecl, Maybe Module, Located DocName)] -> Html+ -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++)@@ -310,9 +310,9 @@ -- 'mdl'' is a way of "overriding" the module. Without it, instances -- will point to the module defining the class/family, which is wrong. origMod = fromMaybe (nameModule n) mdl'- origPkg = moduleUnitId origMod+ origPkg = moduleUnit origMod fname = case loc of- RealSrcSpan l -> unpackFS (srcSpanFile l)+ RealSrcSpan l _ -> unpackFS (srcSpanFile l) UnhelpfulSpan _ -> error "links: UnhelpfulSpan" links _ _ _ _ _ = noHtml
src/Haddock/Backends/Xhtml/Names.hs view
@@ -28,9 +28,9 @@ import Data.List ( stripPrefix ) import GHC hiding (LexicalFixity(..))-import Name-import RdrName-import FastString (unpackFS)+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Data.FastString (unpackFS) -- | Indicator of how to render a 'DocName' into 'Html'
src/Haddock/Backends/Xhtml/Types.hs view
@@ -23,7 +23,7 @@ -- the base, module and entity URLs for the source code and wiki links.-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath)+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
src/Haddock/Backends/Xhtml/Utils.hs view
@@ -21,7 +21,8 @@ keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,- arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,+ arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,+ multAnnotation, atSign, hsep, vcat,@@ -38,9 +39,9 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml -import GHC ( SrcSpan(..), srcSpanStartLine, Name )-import Module ( Module, ModuleName, moduleName, moduleNameString )-import Name ( getOccString, nameOccName, isValOcc )+import GHC ( SrcSpan(..), srcSpanStartLine, Name )+import GHC.Unit.Module ( Module, ModuleName, moduleName, moduleNameString )+import GHC.Types.Name ( getOccString, nameOccName, isValOcc ) -- | Replace placeholder string elements with provided values.@@ -75,7 +76,7 @@ Nothing -> "" Just span_ -> case span_ of- RealSrcSpan span__ ->+ RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" @@ -187,12 +188,16 @@ ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" -dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html+dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow unicode = toHtml (if unicode then "→" else "->")+lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" atSign unicode = toHtml (if unicode then "@" else "@")++multAnnotation :: Html+multAnnotation = toHtml "%" dot :: Html dot = toHtml "."
src/Haddock/Convert.hs view
@@ -19,44 +19,49 @@ PrintRuntimeReps(..), ) where -import Bag ( emptyBag )-import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..)+#include "HsVersions.h"++import GHC.Data.Bag ( emptyBag )+import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) , PromotionFlag(..), DefMethSpec(..) )-import Class-import CoAxiom-import ConLike+import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.ConLike import Data.Either (lefts, rights)-import DataCon-import FamInstEnv+import GHC.Core.DataCon+import GHC.Core.FamInstEnv import GHC.Hs-import Name-import NameSet ( emptyNameSet )-import RdrName ( mkVarUnqual )-import PatSyn-import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )-import TcType-import TyCon-import Type-import TyCoRep-import TysPrim ( alphaTyVars )-import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName+import GHC.Types.Name+import GHC.Types.Name.Set ( emptyNameSet )+import GHC.Types.Name.Reader ( mkVarUnqual )+import GHC.Core.PatSyn+import GHC.Tc.Utils.TcType+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Builtin.Types.Prim ( alphaTyVars )+import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName , unitTy, promotedNilDataCon, promotedConsDataCon )-import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey+import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey )-import Unique ( getUnique )-import Util ( chkAppend, dropList, filterByList, filterOut )-import Var-import VarSet+import GHC.Types.Unique ( getUnique )+import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength+ , filterByList, filterOut )+import GHC.Utils.Outputable ( assertPanic )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.SrcLoc+import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) -import Data.Maybe ( catMaybes, maybeToList )+import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) -- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check--- out Note [Defaulting RuntimeRep variables] in IfaceType.hs for the+-- out Note [Defaulting RuntimeRep variables] in GHC.Iface.Type for the -- motivation. data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show @@ -85,6 +90,15 @@ extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" + cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n+ cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField+ (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind+ cvt (XTyVarBndr nec) = noExtCon nec++ -- | Convert a LHsTyVarBndr to an equivalent LHsType.+ hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)+ hsLTyVarBndrToType = mapLoc cvt+ extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs = TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)@@ -127,7 +141,7 @@ , tcdATs = atFamDecls , tcdATDefs = catMaybes atDefFamDecls , tcdDocs = [] --we don't have any docs at this point- , tcdCExt = placeHolderNamesTc }+ , tcdCExt = emptyNameSet } | otherwise -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField @@ -137,7 +151,7 @@ -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc]- (synifySigWcType ImplicitizeForAll [] (dataConUserType dc)))+ (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps)@@ -190,7 +204,7 @@ DataDecl { tcdLName = synifyName tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv- tyVarKinds+ (map scaledThing tyVarKinds) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -205,12 +219,12 @@ -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] }- , tcdDExt = DataDeclRn False placeHolderNamesTc }+ , tcdDExt = DataDeclRn False emptyNameSet } where -- tyConTyVars doesn't work on fun/prim, but we can make them up: mk_hs_tv realKind fakeTyVar- | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField (noLoc (getName fakeTyVar))- | otherwise = noLoc $ KindedTyVar noExtField (noLoc (getName fakeTyVar)) (synifyKindSig realKind)+ | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar))+ | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc) tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind@@ -298,7 +312,7 @@ DataDecl { tcdLName = name, tcdTyVars = tyvars , tcdFixity = synifyFixity name , tcdDataDefn = defn- , tcdDExt = DataDeclRn False placeHolderNamesTc }+ , tcdDExt = DataDeclRn False emptyNameSet } dataConErrs -> Left $ unlines dataConErrs -- | In this module, every TyCon being considered has come from an interface@@ -334,7 +348,7 @@ | isLiftedTypeKind kind = noLoc $ NoSig noExtField | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind =- noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField (noLoc name) (synifyKindSig kind))+ noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its@@ -351,7 +365,7 @@ name = synifyName dc -- con_qvars means a different thing depending on gadt-syntax (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc- user_tvs = dataConUserTyVars dc -- Used for GADT data constructors+ user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing@@ -359,7 +373,7 @@ linear_tys = zipWith (\ty bang ->- let tySyn = synifyType WithinType [] ty+ let tySyn = synifyType WithinType [] (scaledThing ty) in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExtField bang' tySyn)@@ -372,19 +386,19 @@ hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys)- (False,False) -> return $ PrefixCon linear_tys+ (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) (False,True) -> case linear_tys of- [a,b] -> return $ InfixCon a b+ [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) _ -> Left "synifyDataCon: infix with non-2 args?" -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> if use_gadt_syntax then return $ noLoc $- ConDeclGADT { con_g_ext = noExtField+ ConDeclGADT { con_g_ext = [] , con_names = [name]- , con_forall = noLoc $ not $ null user_tvs- , con_qvars = synifyTyVars user_tvs+ , con_forall = noLoc $ not $ null user_tvbndrs+ , con_qvars = map synifyTyVarBndr user_tvbndrs , con_mb_cxt = ctx , con_args = hat , con_res_ty = synifyType WithinType [] res_ty@@ -393,7 +407,7 @@ ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc False- , con_ex_tvs = map synifyTyVar ex_tvs+ , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing }@@ -438,21 +452,26 @@ synifyTyVars ktvs = HsQTvs { hsq_ext = [] , hsq_explicit = map synifyTyVar ktvs } -synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn-synifyTyVar = synifyTyVar' emptyVarSet+synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn+synifyTyVar = synify_ty_var emptyVarSet () --- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind+synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn+synifyTyVarBndr = synifyTyVarBndr' emptyVarSet++synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn+synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv++-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind -- signatures (even if they don't have the lifted type kind).-synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn-synifyTyVar' no_kinds tv+synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn+synify_ty_var no_kinds flag tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds- = noLoc (UserTyVar noExtField (noLoc name))- | otherwise = noLoc (KindedTyVar noExtField (noLoc name) (synifyKindSig kind))+ = noLoc (UserTyVar noExtField flag (noLoc name))+ | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv - -- | Annotate (with HsKingSig) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to synify type patterns for poly-kinded tyvars in@@ -620,38 +639,57 @@ filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) ty_args in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args'-synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty-synifyType _ vs (FunTy VisArg t1 t2) = let+synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty+synifyType _ vs (FunTy VisArg w t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2- in noLoc $ HsFunTy noExtField s1 s2+ w' = synifyMult vs w+ in noLoc $ HsFunTy noExtField w' s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =- synifyForAllType s argf vs forallty+ case argf of+ Required -> synifyVisForAllType vs forallty+ Invisible _ -> synifySigmaType s vs forallty synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" --- | Process a 'Type' which starts with a forall or a constraint into--- an 'HsType'-synifyForAllType+-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'+synifyVisForAllType+ :: [TyVar] -- ^ free variables in the type to convert+ -> Type -- ^ the forall type to convert+ -> LHsType GhcRn+synifyVisForAllType vs ty =+ let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty++ sTvs = map synifyTyVarBndr tvs++ -- Figure out what the type variable order would be inferred in the+ -- absence of an explicit forall+ tvs' = orderedFVs (mkVarSet vs) [rho]++ in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs+ , hst_xforall = noExtField+ , hst_body = synifyType WithinType (tvs' ++ vs) rho }++-- | Process a 'Type' which starts with an invisible @forall@ or a constraint+-- into an 'HsType'+synifySigmaType :: SynifyTypeState -- ^ what to do with the 'forall'- -> ArgFlag -- ^ the visibility of the @forall@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the forall type to convert -> LHsType GhcRn-synifyForAllType s argf vs ty =- let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty+synifySigmaType s vs ty =+ let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf- , hst_bndrs = sTvs+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } - sTvs = map synifyTyVar tvs+ sTvs = map synifyTyVarBndr tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall@@ -667,21 +705,20 @@ ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau - -- | Put a forall in if there are any type variables which require -- explicit kind annotations or if the inferred type variable order -- would be different. implicitForAll :: [TyCon] -- ^ type constructors that determine their args kinds -> [TyVar] -- ^ free variables in the type to convert- -> [TyVar] -- ^ type variable binders in the forall+ -> [InvisTVBinder] -- ^ type variable binders in the forall -> ThetaType -- ^ constraints right after the forall -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type -> Type -- ^ inner type -> LHsType GhcRn implicitForAll tycons vs tvs ctx synInner tau | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy- | tvs' /= tvs = noLoc sTy+ | tvs' /= (binderVars tvs) = noLoc sTy | otherwise = noLoc sPhi where sRho = synInner (tvs' ++ vs) tau@@ -690,13 +727,12 @@ = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau }- sTy = HsForAllTy { hst_fvf = ForallInvis- , hst_bndrs = sTvs+ sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } no_kinds_needed = noKindTyVars tycons tau- sTvs = map (synifyTyVar' no_kinds_needed) tvs+ sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall@@ -725,7 +761,7 @@ = let args = map (noKindTyVars ts) xs func = case f of TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var)- , xsKinds `eqTypes` map typeKind xs+ , map scaledThing xsKinds `eqTypes` map typeKind xs , isLiftedTypeKind outKind -> unitVarSet var TyConApp t ks | t `elem` ts@@ -734,13 +770,23 @@ _ -> noKindTyVars ts f in unionVarSets (func : args) noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t-noKindTyVars ts (FunTy _ t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2+noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet`+ noKindTyVars ts t1 `unionVarSet`+ noKindTyVars ts t2 noKindTyVars ts (CastTy t _) = noKindTyVars ts t noKindTyVars _ _ = emptyVarSet +synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn+synifyMult vs t = case t of+ One -> HsLinearArrow NormalSyntax+ Many -> HsUnrestrictedArrow NormalSyntax+ ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty)+++ synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps =- let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps+ let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps ts = maybeToList (tyConAppTyCon_maybe res_ty) -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",@@ -811,7 +857,7 @@ eta_expanded_lhs -- eta-expand lhs types, because sometimes data/newtype -- instances are eta-reduced; See Trac #9692- -- See Note [Eta reduction for data family axioms] in TcInstDcls in GHC+ -- See Note [Eta reduction for data family axioms] in GHC.Tc.TyCl.Instance in GHC | DataFamilyInst rep_tc <- fam_flavor = let (_, rep_tc_args) = splitTyConApp fam_rhs etad_tyvars = dropList rep_tc_args $ tyConTyVars rep_tc@@ -839,24 +885,56 @@ invariant didn't hold. -} --- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms.+-- | A version of 'TcType.tcSplitSigmaTy' that: --+-- 1. Preserves type synonyms.+-- 2. Returns 'InvisTVBinder's instead of 'TyVar's.+-- -- See Note [Invariant: Never expand type synonyms]-tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], ThetaType, Type)-tcSplitSigmaTySameVisPreserveSynonyms argf ty =- case tcSplitForAllTysSameVisPreserveSynonyms argf ty of+tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type)+tcSplitSigmaTyPreserveSynonyms ty =+ case tcSplitForAllTysInvisPreserveSynonyms ty of (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of (theta, tau) -> (tvs, theta, tau) -- | See Note [Invariant: Never expand type synonyms]-tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type)-tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty []+tcSplitSomeForAllTysPreserveSynonyms ::+ (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type)+tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty [] where- split _ (ForAllTy (Bndr tv argf) ty') tvs- | argf `sameVis` supplied_argf = split ty' ty' (tv:tvs)- split orig_ty _ tvs = (reverse tvs, orig_ty)+ split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs+ | argf_pred argf = split ty' ty' (tvb:tvs)+ split orig_ty _ tvs = (reverse tvs, orig_ty) -- | See Note [Invariant: Never expand type synonyms]+tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)+tcSplitForAllTysReqPreserveSynonyms ty =+ let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty+ req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in+ ASSERT( req_bndrs `equalLength` all_bndrs )+ (req_bndrs, body)+ where+ mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder+ mk_req_bndr_maybe (Bndr tv argf) = case argf of+ Required -> Just $ Bndr tv ()+ Invisible _ -> Nothing++-- | See Note [Invariant: Never expand type synonyms]+tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)+tcSplitForAllTysInvisPreserveSynonyms ty =+ let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty+ inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in+ ASSERT( inv_bndrs `equalLength` all_bndrs )+ (inv_bndrs, body)+ where+ mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder+ mk_inv_bndr_maybe (Bndr tv argf) = case argf of+ Invisible s -> Just $ Bndr tv s+ Required -> Nothing++-- | See Note [Invariant: Never expand type synonyms]++-- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) tcSplitPhiTyPreserveSynonyms ty0 = split ty0 [] where@@ -867,5 +945,5 @@ -- | See Note [Invariant: Never expand type synonyms] tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type)-tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg arg res) = Just (arg, res)+tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg _ arg res) = Just (arg, res) tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing
src/Haddock/GhcUtils.hs view
@@ -25,28 +25,25 @@ import Haddock.Types( DocName, DocNameI ) -import BasicTypes ( PromotionFlag(..) )-import Exception-import FV-import Outputable ( Outputable, panic, showPpr )-import Name-import NameSet-import Module-import HscTypes+import GHC.Utils.FV as FV+import GHC.Utils.Outputable ( Outputable, panic, showPpr )+import GHC.Types.Basic (PromotionFlag(..))+import GHC.Types.Name+import GHC.Unit.Module import GHC-import Class-import DynFlags-import SrcLoc ( advanceSrcLoc )-import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind,- isInvisibleArgFlag )-import VarSet ( VarSet, emptyVarSet )-import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )-import TyCoRep ( Type(..) )-import Type ( isRuntimeRepVar )-import TysWiredIn( liftedRepDataConTyCon )+import GHC.Driver.Session+import GHC.Types.SrcLoc ( advanceSrcLoc )+import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder+ , tyVarKind, updateTyVarKind, isInvisibleArgFlag )+import GHC.Types.Var.Set ( VarSet, emptyVarSet )+import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )+import GHC.Core.TyCo.Rep ( Type(..) )+import GHC.Core.Type ( isRuntimeRepVar )+import GHC.Builtin.Types( liftedRepDataConTyCon )+import GHC.Parser.Annotation (IsUnicodeSyntax(..)) -import StringBuffer ( StringBuffer )-import qualified StringBuffer as S+import GHC.Data.StringBuffer ( StringBuffer )+import qualified GHC.Data.StringBuffer as S import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS@@ -58,38 +55,6 @@ isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]-getMainDeclBinder (TyClD _ d) = [tcdName d]-getMainDeclBinder (ValD _ d) =- case collectHsBindBinders d of- [] -> []- (name:_) -> [name]-getMainDeclBinder (SigD _ d) = sigNameNoLoc d-getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]-getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []-getMainDeclBinder _ = []---- Extract the source location where an instance is defined. This is used--- to correlate InstDecls with their Instance/CoAxiom Names, via the--- instanceMap.-getInstLoc :: InstDecl (GhcPass p) -> SrcSpan-getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)-getInstLoc (DataFamInstD _ (DataFamInstDecl- { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l-getInstLoc (TyFamInstD _ (TyFamInstDecl- -- Since CoAxioms' Names refer to the whole line for type family instances- -- in particular, we need to dig a bit deeper to pull out the entire- -- equation. This does not happen for data family instances, for some reason.- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l-getInstLoc (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec-getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec-getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec-getInstLoc (XInstDecl nec) = noExtCon nec-getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec-getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec--- -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the@@ -147,48 +112,45 @@ isClassD (TyClD _ d) = isClassDecl d isClassD _ = False -isValD :: HsDecl a -> Bool-isValD (ValD _ _) = True-isValD _ = False- pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr -nubByName :: (a -> Name) -> [a] -> [a]-nubByName f ns = go emptyNameSet ns- where- go !_ [] = []- go !s (x:xs)- | y `elemNameSet` s = go s xs- | otherwise = let !s' = extendNameSet s y- in x : go s' xs- where- y = f x-- -- --------------------------------------------------------------------- -- These functions are duplicated from the GHC API, as they must be -- instantiated at DocNameI instead of (GhcPass _). -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)-hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n-hsTyVarBndrName (UserTyVar _ name) = unLoc name-hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name+hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n+hsTyVarBndrName (UserTyVar _ _ name) = unLoc name+hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec +hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName+hsTyVarNameI (UserTyVar _ _ (L _ n)) = n+hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n++hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName+hsLTyVarNameI = hsTyVarNameI . unLoc+ getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names-getConNamesI (XConDecl nec) = noExtCon nec hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing hsImplicitBodyI (HsIB { hsib_body = body }) = body-hsImplicitBodyI (XHsImplicitBndrs nec) = noExtCon nec hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI hsSigTypeI = hsImplicitBodyI +mkHsForAllInvisTeleI ::+ [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI+mkHsForAllInvisTeleI invis_bndrs =+ HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }++getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI+getConArgsI d = con_args d+ getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So@@ -198,9 +160,8 @@ , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis- , hst_xforall = noExtField- , hst_bndrs = hsQTvExplicit qtvs+ | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField+ , hst_tele = mkHsForAllInvisTeleI qtvs , hst_body = theta_ty }) | otherwise = theta_ty where@@ -209,16 +170,16 @@ | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of- RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty)- PrefixCon pos_args -> foldr mkFunTy res_ty pos_args- InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)+ RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty+ PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)+ InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField a b)+ mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT-getGADTConType (XConDecl nec) = noExtCon nec getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d]@@ -233,21 +194,19 @@ familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName familyDeclLNameI (FamilyDecl { fdLName = n }) = n-familyDeclLNameI (XFamilyDecl nec) = noExtCon nec tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln-tyClDeclLNameI (XTyClDecl nec) = noExtCon nec tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI -- ------------------------------------- -getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p)+getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the@@ -256,9 +215,8 @@ , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_fvf = ForallInvis- , hst_xforall = noExtField- , hst_bndrs = hsQTvExplicit qtvs+ | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField+ , hst_tele = mkHsForAllInvisTele qtvs , hst_body = theta_ty }) | otherwise = theta_ty where@@ -267,16 +225,17 @@ | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of- RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty)- PrefixCon pos_args -> foldr mkFunTy res_ty pos_args- InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty)+ RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty+ PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)+ InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField a b)+ -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI+ mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT-getGADTConTypeG (XConDecl nec) = noExtCon nec mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn@@ -291,9 +250,9 @@ = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where- go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }))- = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField- , hst_bndrs = tvs, hst_body = go ty })+ go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))+ = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField+ , hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty })@@ -301,7 +260,10 @@ = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)+ extra_pred :: LHsType GhcRn+ extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0))++ add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn add_ctxt (L loc preds) = L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine@@ -335,7 +297,6 @@ [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen"-restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]@@ -345,7 +306,7 @@ PrefixCon _ -> Just d RecCon fields | all field_avail (unLoc fields) -> Just d- | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) })+ | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc fields) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but@@ -355,9 +316,9 @@ field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs- field_avail (L _ (XConDeclField nec)) = noExtCon nec- field_types flds = [ t | ConDeclField _ _ t _ <- flds ] + field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]+ keep _ = Nothing restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]@@ -413,14 +374,14 @@ = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty)- go p (HsForAllTy x fvf tvs ty)- = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty)+ go p (HsForAllTy x tele ty)+ = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later... in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty)- go p (HsFunTy x ty1 ty2)- = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2)+ go p (HsFunTy x w ty1 ty2)+ = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) go p (HsAppKindTy x fun_ty arg_ki)@@ -456,10 +417,19 @@ reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a reparenLType = fmap reparenType +-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')+reparenHsForAllTelescope :: (XParTy a ~ NoExtField)+ => HsForAllTelescope a -> HsForAllTelescope a+reparenHsForAllTelescope (HsForAllVis x bndrs) =+ HsForAllVis x (map (fmap reparenTyVar) bndrs)+reparenHsForAllTelescope (HsForAllInvis x bndrs) =+ HsForAllInvis x (map (fmap reparenTyVar) bndrs)+reparenHsForAllTelescope v@XHsForAllTelescope{} = v+ -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')-reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a-reparenTyVar (UserTyVar x n) = UserTyVar x n-reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind)+reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a+reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n+reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')@@ -469,6 +439,18 @@ -------------------------------------------------------------------------------+-- * Located+-------------------------------------------------------------------------------+++unL :: Located a -> a+unL (L _ x) = x+++reL :: a -> Located a+reL = L undefined++------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -542,19 +524,6 @@ return () --- | A variant of 'gbracket' where the return value from the first computation--- is not required.-gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c-gbracket_ before_ after thing = gbracket before_ (const after) (const thing)---- Extract the minimal complete definition of a Name, if one exists-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)-minimalDef n = do- mty <- lookupGlobalName n- case mty of- Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c- _ -> return Nothing- ------------------------------------------------------------------------------- -- * DynFlags -------------------------------------------------------------------------------@@ -706,10 +675,10 @@ -- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type -- of 'const :: a -> b -> a': ----- >>> import Name+-- >>> import GHC.Types.Name -- >>> import TyCoRep--- >>> import TysPrim--- >>> import Var+-- >>> import GHC.Builtin.Types.Prim+-- >>> import GHC.Types.Var -- >>> a = TyVarTy alphaTyVar -- >>> b = TyVarTy betaTyVar -- >>> constTy = mkFunTys [a, b] a@@ -728,7 +697,9 @@ tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c-tyCoFVsOfType' (FunTy _ arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c+tyCoFVsOfType' (FunTy _ w arg res) a b c = (tyCoFVsOfType' w `unionFV`+ tyCoFVsOfType' res `unionFV`+ tyCoFVsOfType' arg) a b c tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c@@ -750,7 +721,7 @@ ------------------------------------------------------------------------------- -- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to--- 'LiftedType'. See 'defaultRuntimeRepVars' in IfaceType.hs the original such+-- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such -- function working over `IfaceType`'s. defaultRuntimeRepVars :: Type -> Type defaultRuntimeRepVars = go emptyVarEnv@@ -774,8 +745,8 @@ go subs (TyConApp tc tc_args) = TyConApp tc (map (go subs) tc_args) - go subs (FunTy af arg res)- = FunTy af (go subs arg) (go subs res)+ go subs (FunTy af w arg res)+ = FunTy af (go subs w) (go subs arg) (go subs res) go subs (AppTy t u) = AppTy (go subs t) (go subs u)
src/Haddock/Interface.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface@@ -29,44 +29,53 @@ -- using this environment. ----------------------------------------------------------------------------- module Haddock.Interface (- processModules+ plugin+ , processModules ) where -import Haddock.GhcUtils-import Haddock.InterfaceFile-import Haddock.Interface.Create-import Haddock.Interface.AttachInstances-import Haddock.Interface.Rename+import Haddock.GhcUtils (moduleString, pretty)+import Haddock.Interface.AttachInstances (attachInstances)+import Haddock.Interface.Create (createInterface1, runIfM)+import Haddock.Interface.Rename (renameInterface)+import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv) import Haddock.Options hiding (verbosity)-import Haddock.Types-import Haddock.Utils+import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv,+ expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage,+ ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE)+import Haddock.Utils (Verbosity, normal, out, verbose) -import Control.Monad-import Control.Monad.IO.Class ( liftIO )-import Control.Exception (evaluate)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map import qualified Data.Set as Set-import Text.Printf+import Text.Printf (printf) -import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)-import Digraph-import DynFlags hiding (verbosity) import GHC hiding (verbosity)-import HscTypes-import FastString (unpackFS)-import TcRnTypes (tcg_rdr_env)-import Name (nameIsFromExternalPackage, nameOccName)-import OccName (isTcOcc)-import RdrName (unQualOK, gre_name, globalRdrEnvElts)-import ErrUtils (withTimingD)-import DynamicLoading (initializePlugins)+import GHC.Data.FastString (unpackFS)+import GHC.Data.Graph.Directed+import GHC.Driver.Monad (modifySession)+import GHC.Driver.Session hiding (verbosity)+import GHC.Driver.Types (isBootSummary)+import GHC.HsToCore.Docs (getMainDeclBinder)+import GHC.Plugins (HscEnv (..), Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin,+ keepRenamedSource)+import GHC.Tc.Types (TcGblEnv (..), TcM)+import GHC.Tc.Utils.Env (tcLookupGlobal)+import GHC.Tc.Utils.Monad (setGblEnv)+import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)+import GHC.Types.Name.Occurrence (isTcOcc)+import GHC.Types.Name.Reader (globalRdrEnvElts, gre_name, unQualOK)+import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet)+import GHC.Unit.Types (IsBootInterface (..))+import GHC.Utils.Error (withTimingD) #if defined(mingw32_HOST_OS)-import System.IO import GHC.IO.Encoding.CodePage (mkLocaleEncoding)-import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))+import GHC.IO.Encoding.Failure (CodingFailureMode (TransliterateCodingFailure))+import System.IO #endif -- | Create 'Interface's and a link environment by typechecking the list of@@ -87,8 +96,14 @@ #endif out verbosity verbose "Creating interfaces..."- let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces- , iface <- ifInstalledIfaces ext ]+ let+ instIfaceMap :: InstIfaceMap+ instIfaceMap = Map.fromList+ [ (instMod iface, iface)+ | ext <- extIfaces+ , iface <- ifInstalledIfaces ext+ ]+ (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap let exportedNames =@@ -124,99 +139,200 @@ createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) createIfaces verbosity modules flags instIfaceMap = do- -- Ask GHC to tell us what the module graph is+ (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin+ verbosity flags instIfaceMap++ let+ installHaddockPlugin :: HscEnv -> HscEnv+ installHaddockPlugin hsc_env = hsc_env+ {+ hsc_dflags = (gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy)+ {+ staticPlugins = haddockPlugin : staticPlugins (hsc_dflags hsc_env)+ }+ }++ -- Note that we would rather use withTempSession but as long as we+ -- have the separate attachInstances step we need to keep the session+ -- alive to be able to find all the instances.+ modifySession installHaddockPlugin+ targets <- mapM (\filePath -> guessTarget filePath Nothing) modules setTargets targets- modGraph <- depanal [] False - -- Visit modules in that order- let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing- out verbosity normal "Haddock coverage:"- (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods- return (reverse ifaces, ms)- where- f (ifaces, ifaceMap, !ms) modSummary = do- x <- {-# SCC processModule #-}- withTimingD "processModule" (const ()) $ do- processModule verbosity modSummary flags ifaceMap instIfaceMap- return $ case x of- Just (iface, ms') -> ( iface:ifaces- , Map.insert (ifaceMod iface) iface ifaceMap- , unionModuleSet ms ms' )- Nothing -> ( ifaces- , ifaceMap- , ms ) -- Boot modules don't generate ifaces.+ loadOk <- withTimingD "load" (const ()) $+ {-# SCC load #-} GHC.load LoadAllTargets + case loadOk of+ Failed ->+ throwE "Cannot typecheck modules"+ Succeeded -> do+ modGraph <- GHC.getModuleGraph+ ifaceMap <- liftIO getIfaces+ moduleSet <- liftIO getModules -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))-processModule verbosity modsum flags modMap instIfaceMap = do- out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."+ let+ ifaces :: [Interface]+ ifaces =+ [ Map.findWithDefault+ (error "haddock:iface")+ (ms_mod ms)+ ifaceMap+ | ms <- flattenSCCs $ topSortModuleGraph True modGraph Nothing+ ] - -- Since GHC 8.6, plugins are initialized on a per module basis- hsc_env' <- getSession- dynflags' <- liftIO (initializePlugins hsc_env' (GHC.ms_hspp_opts modsum))- let modsum' = modsum { ms_hspp_opts = dynflags' }+ return (ifaces, moduleSet) - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum' - if not $ isBootSummary modsum then do- out verbosity verbose "Creating interface..."- (interface, msgs) <- {-# SCC createIterface #-}- withTimingD "createInterface" (const ()) $ do- runWriterGhc $ createInterface tm flags modMap instIfaceMap+-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock+-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to+-- parallelize the compilation process.+plugin+ :: MonadIO m+ => Verbosity+ -> [Flag]+ -> InstIfaceMap+ -> m+ (+ StaticPlugin -- the plugin to install with GHC+ , m IfaceMap -- get the processed interfaces+ , m ModuleSet -- get the loaded modules+ )+plugin verbosity flags instIfaceMap = liftIO $ do+ ifaceMapRef <- newIORef Map.empty+ moduleSetRef <- newIORef emptyModuleSet - -- We need to keep track of which modules were somehow in scope so that when- -- Haddock later looks for instances, it also looks in these modules too.- --- -- See https://github.com/haskell/haddock/issues/469.- hsc_env <- getSession- let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm- this_pkg = thisPackage (hsc_dflags hsc_env)- !mods = mkModuleSet [ nameModule name- | gre <- globalRdrEnvElts new_rdr_env- , let name = gre_name gre- , nameIsFromExternalPackage this_pkg name- , isTcOcc (nameOccName name) -- Types and classes only- , unQualOK gre ] -- In scope unqualified+ let+ processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()+ processTypeCheckedResult mod_summary tc_gbl_env+ -- Don't do anything for hs-boot modules+ | IsBoot <- isBootSummary mod_summary =+ pure ()+ | otherwise = do+ ifaces <- liftIO $ readIORef ifaceMapRef+ (iface, modules) <- withTimingD "processModule" (const ()) $+ processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env - liftIO $ mapM_ putStrLn (nub msgs)- dflags <- getDynFlags- let (haddockable, haddocked) = ifaceHaddockCoverage interface- percentage = div (haddocked * 100) haddockable- modString = moduleString (ifaceMod interface)- coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString- header = case ifaceDoc interface of- Documentation Nothing _ -> False- _ -> True- undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n- , expItemMbDoc = (Documentation Nothing _, _)- } <- ifaceExportItems interface ]- where- formatName :: SrcSpan -> HsDecl GhcRn -> String- formatName loc n = p (getMainDeclBinder n) ++ case loc of- RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"- _ -> ""+ liftIO $ do+ atomicModifyIORef' ifaceMapRef $ \xs ->+ (Map.insert (ms_mod mod_summary) iface xs, ()) - p [] = ""- p (x:_) = let n = pretty dflags x- ms = modString ++ "."- in if ms `isPrefixOf` n- then drop (length ms) n- else n+ atomicModifyIORef' moduleSetRef $ \xs ->+ (modules `unionModuleSet` xs, ()) - when (OptHide `notElem` ifaceOptions interface) $ do- out verbosity normal coverageMsg- when (Flag_NoPrintMissingDocs `notElem` flags- && not (null undocumentedExports && header)) $ do- out verbosity normal " Missing documentation for:"- unless header $ out verbosity normal " Module header"- mapM_ (out verbosity normal . (" " ++)) undocumentedExports- interface' <- liftIO $ evaluate interface- return (Just (interface', mods))- else- return Nothing+ staticPlugin :: StaticPlugin+ staticPlugin = StaticPlugin+ {+ spPlugin = PluginWithArgs+ {+ paPlugin = defaultPlugin+ {+ renamedResultAction = keepRenamedSource+ , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do+ processTypeCheckedResult mod_summary tc_gbl_env+ pure tc_gbl_env + }+ , paArguments = []+ }+ } + pure+ ( staticPlugin+ , liftIO (readIORef ifaceMapRef)+ , liftIO (readIORef moduleSetRef)+ )+++processModule1+ :: Verbosity+ -> [Flag]+ -> IfaceMap+ -> InstIfaceMap+ -> ModSummary+ -> TcGblEnv+ -> TcM (Interface, ModuleSet)+processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do+ out verbosity verbose "Creating interface..."++ let+ TcGblEnv { tcg_rdr_env } = tc_gbl_env++ (!interface, messages) <- {-# SCC createInterface #-}+ withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $+ createInterface1 flags mod_summary tc_gbl_env ifaces inst_ifaces++ -- We need to keep track of which modules were somehow in scope so that when+ -- Haddock later looks for instances, it also looks in these modules too.+ --+ -- See https://github.com/haskell/haddock/issues/469.+ dflags <- getDynFlags+ let+ mods :: ModuleSet+ !mods = mkModuleSet+ [ nameModule name+ | gre <- globalRdrEnvElts tcg_rdr_env+ , let name = gre_name gre+ , nameIsFromExternalPackage (homeUnit dflags) name+ , isTcOcc (nameOccName name) -- Types and classes only+ , unQualOK gre -- In scope unqualified+ ]++ liftIO $ mapM_ putStrLn (nub messages)++ let+ (haddockable, haddocked) =+ ifaceHaddockCoverage interface++ percentage :: Int+ percentage =+ round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double)++ modString :: String+ modString = moduleString (ifaceMod interface)++ coverageMsg :: String+ coverageMsg =+ printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString++ header :: Bool+ header = case ifaceDoc interface of+ Documentation Nothing _ -> False+ _ -> True++ undocumentedExports :: [String]+ undocumentedExports =+ [ formatName s n+ | ExportDecl { expItemDecl = L s n+ , expItemMbDoc = (Documentation Nothing _, _)+ } <- ifaceExportItems interface+ ]+ where+ formatName :: SrcSpan -> HsDecl GhcRn -> String+ formatName loc n = p (getMainDeclBinder n) ++ case loc of+ RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" +++ show (srcSpanStartLine rss) ++ ")"+ _ -> ""++ p :: Outputable a => [a] -> String+ p [] = ""+ p (x:_) = let n = pretty dflags x+ ms = modString ++ "."+ in if ms `isPrefixOf` n+ then drop (length ms) n+ else n++ when (OptHide `notElem` ifaceOptions interface) $ do+ out verbosity normal coverageMsg+ when (Flag_NoPrintMissingDocs `notElem` flags+ && not (null undocumentedExports && header)) $ do+ out verbosity normal " Missing documentation for:"+ unless header $ out verbosity normal " Module header"+ mapM_ (out verbosity normal . (" " ++)) undocumentedExports++ pure (interface, mods)++ -------------------------------------------------------------------------------- -- * Building of cross-linking environment --------------------------------------------------------------------------------@@ -243,4 +359,3 @@ mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env-
src/Haddock/Interface/AttachInstances.hs view
@@ -19,7 +19,6 @@ import Haddock.Types import Haddock.Convert-import Haddock.GhcUtils import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>))@@ -29,23 +28,25 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Class-import DynFlags-import CoreSyn (isOrphan)-import ErrUtils-import FamInstEnv+import GHC.Data.FastString (unpackFS)+import GHC.Core.Class+import GHC.Driver.Session+import GHC.Core (isOrphan)+import GHC.Utils.Error+import GHC.Core.FamInstEnv import GHC-import InstEnv-import Module ( ModuleSet, moduleSetElts )-import MonadUtils (liftIO)-import Name-import NameEnv-import Outputable (text, sep, (<+>))-import SrcLoc-import TyCon-import TyCoRep-import TysPrim( funTyConName )-import Var hiding (varName)+import GHC.Core.InstEnv+import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts )+import GHC.Utils.Monad (liftIO)+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Utils.Outputable (text, sep, (<+>))+import GHC.Types.SrcLoc+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Builtin.Types.Prim( funTyConName )+import GHC.Types.Var hiding (varName)+import GHC.HsToCore.Docs type ExportedNames = Set.Set Name type Modules = Set.Set Module@@ -179,37 +180,48 @@ -- Collecting and sorting instances -------------------------------------------------------------------------------- +-- | Stable name for stable comparisons. GHC's `Name` uses unstable+-- ordering based on their `Unique`'s.+newtype SName = SName Name +instance Eq SName where+ SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ++instance Ord SName where+ SName n1 `compare` SName n2 = n1 `stableNameCmp` n2+ -- | Simplified type for sorting types, ignoring qualification (not visible -- in Haddock output) and unifying special tycons with normal ones. -- For the benefit of the user (looks nice and predictable) and the -- tests (which prefer output to be deterministic).-data SimpleType = SimpleType Name [SimpleType]- | SimpleTyLit TyLit+data SimpleType = SimpleType SName [SimpleType]+ | SimpleIntTyLit Integer+ | SimpleStringTyLit String deriving (Eq,Ord) -instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType]) instHead (_, _, cls, args)- = (map argCount args, className cls, map simplify args)+ = (map argCount args, SName (className cls), map simplify args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts-argCount (FunTy _ _ _) = 2+argCount (FunTy _ _ _ _) = 2 argCount (ForAllTy _ t) = argCount t argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType-simplify (FunTy _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]+simplify (FunTy _ _ t1 t2) = SimpleType (SName funTyConName) [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1-simplify (TyVarTy v) = SimpleType (tyVarName v) []-simplify (TyConApp tc ts) = SimpleType (tyConName tc)+simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) []+simplify (TyConApp tc ts) = SimpleType (SName (tyConName tc)) (mapMaybe simplify_maybe ts)-simplify (LitTy l) = SimpleTyLit l+simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n+simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s) simplify (CastTy ty _) = simplify ty simplify (CoercionTy _) = error "simplify:Coercion" @@ -218,9 +230,9 @@ simplify_maybe ty = Just (simplify ty) -- Used for sorting-instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)+instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType) instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }- = (map argCount ts, n, map simplify ts, argCount t, simplify t)+ = (map argCount ts, SName n, map simplify ts, argCount t, simplify t) --------------------------------------------------------------------------------@@ -257,7 +269,7 @@ case t of TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2- FunTy _ t1 t2 -> typeHidden t1 || typeHidden t2+ FunTy _ _ t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty LitTy _ -> False
src/Haddock/Interface/Create.hs view
@@ -1,9 +1,17 @@-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}--- Note the -Wno-incomplete-record-updates. When converting Type to HsSyn we--- are using incomplete record constructions infortunately.-{-# OPTIONS_GHC -Wwarn -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create@@ -20,234 +28,332 @@ -- which creates a Haddock 'Interface' from the typechecking -- results 'TypecheckedModule' from GHC. ------------------------------------------------------------------------------module Haddock.Interface.Create (createInterface) where+module Haddock.Interface.Create (IfM, runIfM, createInterface1) where import Documentation.Haddock.Doc (metaDocAppend)-import Haddock.Types-import Haddock.Options-import Haddock.GhcUtils-import Haddock.Utils-import Haddock.Convert+import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)+import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigWcType, moduleString, parents,+ pretty, restrictTo, sigName) import Haddock.Interface.LexParseRn+import Haddock.Options (Flag (..), modulePackageInfo)+import Haddock.Types hiding (liftErrMsg)+import Haddock.Utils (replace) -import Data.Bifunctor-import Data.Bitraversable-import qualified Data.Map as M-import qualified Data.Set as S+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)+import Control.Monad.Writer.Strict hiding (tell)+import Data.Bitraversable (bitraverse)+import Data.List (find, foldl') import Data.Map (Map)-import Data.List (find, foldl', sortBy)-import Data.Maybe-import Data.Ord-import Control.Applicative-import Control.Monad-import Data.Traversable+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList)+import Data.Traversable (for) import GHC.Stack (HasCallStack) -import Avail hiding (avail)-import qualified Avail-import qualified Module-import qualified SrcLoc-import ConLike (ConLike(..))-import GHC-import HscTypes-import Name-import NameSet-import NameEnv-import Packages ( lookupModuleInAllPackages, PackageName(..) )-import Bag-import RdrName-import TcRnTypes-import FastString ( unpackFS, bytesFS )-import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) )-import qualified Outputable as O+import GHC hiding (lookupName)+import GHC.Core.Class (ClassMinimalDef, classMinimalDef)+import GHC.Core.ConLike (ConLike (..))+import GHC.Data.FastString (bytesFS, unpackFS)+import GHC.Driver.Types (HscSource (..), WarningTxt (..), Warnings (..), msHsFilePath)+import GHC.HsToCore.Docs hiding (mkMaps)+import GHC.Parser.Annotation (IsUnicodeSyntax (..))+import GHC.Tc.Types hiding (IfM)+import GHC.Tc.Utils.Monad (finalSafeMode)+import GHC.Types.Avail hiding (avail)+import qualified GHC.Types.Avail as Avail+import GHC.Types.Basic (PromotionFlag (..), SourceText (..), StringLiteral (..))+import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName)+import GHC.Types.Name.Env (lookupNameEnv)+import GHC.Types.Name.Reader (GlobalRdrEnv, globalRdrEnvElts, gre_name, gresToAvailInfo, isLocalGRE, lookupGlobalRdrEnv)+import GHC.Types.Name.Set (elemNameSet, mkNameSet)+import qualified GHC.Types.SrcLoc as SrcLoc+import qualified GHC.Unit.Module as Module+import GHC.Unit.State+import qualified GHC.Utils.Outputable as O -mkExceptionContext :: TypecheckedModule -> String++mkExceptionContext :: ModSummary -> String mkExceptionContext =- ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module+ ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name --- | Use a 'TypecheckedModule' to produce an 'Interface'.--- To do this, we need access to already processed modules in the topological--- sort. That's what's in the 'IfaceMap'.-createInterface :: HasCallStack- => TypecheckedModule- -> [Flag] -- Boolean flags- -> IfaceMap -- Locally processed modules- -> InstIfaceMap -- External, already installed interfaces- -> ErrMsgGhc Interface-createInterface tm flags modMap instIfaceMap =- withExceptionContext (mkExceptionContext tm) $ do - let ms = pm_mod_summary . tm_parsed_module $ tm- mi = moduleInfo tm- L _ hsm = parsedSource tm- !safety = modInfoSafe mi- mdl = ms_mod ms- sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))- is_sig = ms_hsc_src ms == HsigFile- dflags = ms_hspp_opts ms- !instances = modInfoInstances mi- !fam_instances = md_fam_insts md- !exportedNames = modInfoExportsWithSelectors mi- (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)- pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS+newtype IfEnv m = IfEnv+ {+ -- | Lookup names in the enviroment.+ ife_lookup_name :: Name -> m (Maybe TyThing)+ } - (TcGblEnv { tcg_rdr_env = gre- , tcg_warns = warnings- , tcg_exports = all_exports0- }, md) = tm_internals_ tm- all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre - -- The 'pkgName' is necessary to decide what package to mention in "@since"- -- annotations. Not having it is not fatal though.- --- -- Cabal can be trusted to pass the right flags, so this warning should be- -- mostly encountered when running Haddock outside of Cabal.- when (isNothing pkgName) $- liftErrMsg $ tell [ "Warning: Package name is not available." ]+-- | A monad in which we create Haddock interfaces. Not to be confused with+-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.+--+-- In the past `createInterface` was running in the `Ghc` monad but proved hard+-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting+-- over the Ghc specific clarifies where side effects happen.+newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } - -- The renamed source should always be available to us, but it's best- -- to be on the safe side.- (group_, imports, mayExports, mayDocHeader) <-- case renamedSource tm of- Nothing -> do- liftErrMsg $ tell [ "Warning: Renamed source is not available." ]- return (emptyRnGroup, [], Nothing, Nothing)- Just x -> return x+deriving newtype instance Functor m => Functor (IfM m)+deriving newtype instance Applicative m => Applicative (IfM m)+deriving newtype instance Monad m => Monad (IfM m)+deriving newtype instance MonadIO m => MonadIO (IfM m)+deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m)+deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)+deriving newtype instance (MonadThrow m) => MonadThrow (IfM m)+deriving newtype instance (MonadCatch m) => MonadCatch (IfM m) - opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - -- Process the top-level module header documentation.- (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader+-- | Run an `IfM` action.+runIfM+ -- | Lookup a global name in the current session. Used in cases+ -- where declarations don't+ :: (Name -> m (Maybe TyThing))+ -- | The action to run.+ -> IfM m a+ -- | Result and accumulated error/warning messages.+ -> m (a, [ErrMsg])+runIfM lookup_name action = do+ let+ if_env = IfEnv+ {+ ife_lookup_name = lookup_name+ }+ runWriterT (runReaderT (unIfM action) if_env) - let declsWithDocs = topDecls group_ - exports0 = fmap (map (first unLoc)) mayExports- (all_exports, exports)- | OptIgnoreExports `elem` opts = (all_local_avails, Nothing)- | otherwise = (all_exports0, exports0)+liftErrMsg :: Monad m => ErrMsgM a -> IfM m a+liftErrMsg action = do+ writer (runWriter action) - unrestrictedImportedMods- -- module re-exports are only possible with- -- explicit export list- | Just{} <- exports- = unrestrictedModuleImports (map unLoc imports)- | otherwise = M.empty - fixMap = mkFixMap group_- (decls, _) = unzip declsWithDocs- localInsts = filter (nameIsLocalOrFrom sem_mdl)- $ map getName fam_instances- ++ map getName instances- -- Locations of all TH splices- splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]+lookupName :: Monad m => Name -> IfM m (Maybe TyThing)+lookupName name = IfM $ do+ lookup_name <- asks ife_lookup_name+ lift $ lift (lookup_name name) - warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) - maps@(!docMap, !argMap, !declMap, _) <-- liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs)+createInterface1+ :: (MonadIO m, MonadCatch m)+ => [Flag]+ -> ModSummary+ -> TcGblEnv+ -> IfaceMap+ -> InstIfaceMap+ -> IfM m Interface+createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces =+ withExceptionContext (mkExceptionContext mod_sum) $ do - let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))+ let+ ModSummary+ {+ -- Cached flags from OPTIONS, INCLUDE and LANGUAGE+ -- pragmas in the modules source code. Used to infer+ -- safety of module.+ ms_hspp_opts+ , ms_location = ModLocation+ {+ ml_hie_file+ }+ } = mod_sum - -- The MAIN functionality: compute the export items which will- -- each be the actual documentation of this module.- exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre- exportedNames decls maps fixMap unrestrictedImportedMods- splices exports all_exports instIfaceMap dflags+ TcGblEnv+ {+ tcg_mod+ , tcg_src+ , tcg_semantic_mod+ , tcg_rdr_env+ , tcg_exports+ , tcg_insts+ , tcg_fam_insts+ , tcg_warns - let !visibleNames = mkVisibleNames maps exportItems opts+ -- Renamed source+ , tcg_rn_imports+ , tcg_rn_exports+ , tcg_rn_decls - -- Measure haddock documentation coverage.- let prunedExportItems0 = pruneExportItems exportItems- !haddockable = 1 + length exportItems -- module + exports- !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0- !coverage = (haddockable, haddocked)+ , tcg_doc_hdr+ } = tc_gbl_env - -- Prune the export list to just those declarations that have- -- documentation, if the 'prune' option is on.- let prunedExportItems'- | OptPrune `elem` opts = prunedExportItems0- | otherwise = exportItems- !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'+ dflags = ms_hspp_opts - let !aliases =- mkAliasMap dflags $ tm_renamed_source tm+ is_sig = tcg_src == HsigFile - modWarn <- liftErrMsg (moduleWarning dflags gre warnings)+ (pkg_name_fs, _) =+ modulePackageInfo dflags flags (Just tcg_mod) - -- Prune the docstring 'Map's to keep only docstrings that are not private.- --- -- Besides all the names that GHC has told us this module exports, we also- -- keep the docs for locally defined class instances. This is more names than- -- we need, but figuring out which instances are fully private is tricky.- --- -- We do this pruning to avoid having to rename, emit warnings, and save- -- docstrings which will anyways never be rendered.- let !localVisibleNames = S.fromList (localInsts ++ exportedNames)- !prunedDocMap = M.restrictKeys docMap localVisibleNames- !prunedArgMap = M.restrictKeys argMap localVisibleNames+ pkg_name :: Maybe Package+ pkg_name =+ let+ unpack (PackageName name) = unpackFS name+ in+ fmap unpack pkg_name_fs - return $! Interface {- ifaceMod = mdl- , ifaceIsSig = is_sig- , ifaceOrigFilename = msHsFilePath ms- , ifaceInfo = info- , ifaceDoc = Documentation mbDoc modWarn- , ifaceRnDoc = Documentation Nothing Nothing- , ifaceOptions = opts- , ifaceDocMap = prunedDocMap- , ifaceArgMap = prunedArgMap- , ifaceRnDocMap = M.empty -- Filled in `renameInterface`- , ifaceRnArgMap = M.empty -- Filled in `renameInterface`- , ifaceExportItems = prunedExportItems- , ifaceRnExportItems = [] -- Filled in `renameInterface`- , ifaceExports = exportedNames- , ifaceVisibleExports = visibleNames- , ifaceDeclMap = declMap- , ifaceFixMap = fixMap- , ifaceModuleAliases = aliases- , ifaceInstances = instances- , ifaceFamInstances = fam_instances- , ifaceOrphanInstances = [] -- Filled in `attachInstances`- , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`- , ifaceHaddockCoverage = coverage- , ifaceWarningMap = warningMap- , ifaceHieFile = Just $ ml_hie_file $ ms_location ms- , ifaceDynFlags = dflags- }+ fixities :: FixMap+ fixities = case tcg_rn_decls of+ Nothing -> mempty+ Just dx -> mkFixMap dx + -- Locations of all the TH splices+ loc_splices :: [SrcSpan]+ loc_splices = case tcg_rn_decls of+ Nothing -> []+ Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]++ decls <- case tcg_rn_decls of+ Nothing -> do+ tell [ "Warning: Renamed source is not available" ]+ pure []+ Just dx ->+ pure (topDecls dx)++ -- Derive final options to use for haddocking this module+ doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod++ let+ -- All elements of an explicit export list, if present+ export_list :: Maybe [(IE GhcRn, Avails)]+ export_list+ | OptIgnoreExports `elem` doc_opts =+ Nothing+ | Just rn_exports <- tcg_rn_exports =+ Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ]+ | otherwise =+ Nothing++ -- All the exported Names of this module.+ actual_exports :: [AvailInfo]+ actual_exports+ | OptIgnoreExports `elem` doc_opts =+ gresToAvailInfo $ filter isLocalGRE $ globalRdrEnvElts tcg_rdr_env+ | otherwise =+ tcg_exports++ exported_names :: [Name]+ exported_names =+ concatMap availNamesWithSelectors actual_exports++ -- Module imports of the form `import X`. Note that there is+ -- a) no qualification and+ -- b) no import list+ imported_modules :: Map ModuleName [ModuleName]+ imported_modules+ | Just{} <- export_list =+ unrestrictedModuleImports (map unLoc tcg_rn_imports)+ | otherwise =+ M.empty++ -- TyThings that have instances defined in this module+ local_instances :: [Name]+ local_instances =+ [ name+ | name <- map getName tcg_insts ++ map getName tcg_fam_insts+ , nameIsLocalOrFrom tcg_semantic_mod name+ ]++ -- Infer module safety+ safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env)++ -- Process the top-level module header documentation.+ (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name+ tcg_rdr_env safety tcg_doc_hdr++ -- Warnings on declarations in this module+ decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)++ -- Warning on the module header+ mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns)++ let+ -- Warnings in this module and transitive warnings from dependend modules+ warnings :: Map Name (Doc Name)+ warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))++ maps@(!docs, !arg_docs, !decl_map, _) <-+ liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls)++ export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod+ warnings tcg_rdr_env exported_names (map fst decls) maps fixities+ imported_modules loc_splices export_list actual_exports inst_ifaces dflags++ let+ visible_names :: [Name]+ visible_names = mkVisibleNames maps export_items doc_opts++ -- Measure haddock documentation coverage.+ pruned_export_items :: [ExportItem GhcRn]+ pruned_export_items = pruneExportItems export_items++ !haddockable = 1 + length export_items -- module + exports+ !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items++ coverage :: (Int, Int)+ !coverage = (haddockable, haddocked)++ aliases :: Map Module ModuleName+ aliases = mkAliasMap (unitState dflags) tcg_rn_imports++ return $! Interface+ {+ ifaceMod = tcg_mod+ , ifaceIsSig = is_sig+ , ifaceOrigFilename = msHsFilePath mod_sum+ , ifaceHieFile = Just ml_hie_file+ , ifaceInfo = info+ , ifaceDoc = Documentation header_doc mod_warning+ , ifaceRnDoc = Documentation Nothing Nothing+ , ifaceOptions = doc_opts+ , ifaceDocMap = docs+ , ifaceArgMap = arg_docs+ , ifaceRnDocMap = M.empty+ , ifaceRnArgMap = M.empty+ , ifaceExportItems = if OptPrune `elem` doc_opts then+ pruned_export_items else export_items+ , ifaceRnExportItems = []+ , ifaceExports = exported_names+ , ifaceVisibleExports = visible_names+ , ifaceDeclMap = decl_map+ , ifaceFixMap = fixities+ , ifaceModuleAliases = aliases+ , ifaceInstances = tcg_insts+ , ifaceFamInstances = tcg_fam_insts+ , ifaceOrphanInstances = [] -- Filled in attachInstances+ , ifaceRnOrphanInstances = [] -- Filled in attachInstances+ , ifaceHaddockCoverage = coverage+ , ifaceWarningMap = warnings+ , ifaceDynFlags = dflags+ }++ -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This -- will go in 'ifaceModuleAliases'.-mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName-mkAliasMap dflags mRenamedSource =- case mRenamedSource of- Nothing -> M.empty- Just (_,impDecls,_,_) ->- M.fromList $- mapMaybe (\(SrcLoc.L _ impDecl) -> do- SrcLoc.L _ alias <- ideclAs impDecl- return $- (lookupModuleDyn dflags- -- TODO: This is supremely dodgy, because in general the- -- UnitId isn't going to look anything like the package- -- qualifier (even with old versions of GHC, the- -- IPID would be p-0.1, but a package qualifier never- -- has a version number it. (Is it possible that in- -- Haddock-land, the UnitIds never have version numbers?- -- I, ezyang, have not quite understand Haddock's package- -- identifier model.)- --- -- Additionally, this is simulating some logic GHC already- -- has for deciding how to qualify names when it outputs- -- them to the user. We should reuse that information;- -- or at least reuse the renamed imports, which know what- -- they import!- (fmap Module.fsToUnitId $- fmap sl_fs $ ideclPkgQual impDecl)- (case ideclName impDecl of SrcLoc.L _ name -> name),- alias))- impDecls+mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName+mkAliasMap state impDecls =+ M.fromList $+ mapMaybe (\(SrcLoc.L _ impDecl) -> do+ SrcLoc.L _ alias <- ideclAs impDecl+ return $+ (lookupModuleDyn state+ -- TODO: This is supremely dodgy, because in general the+ -- UnitId isn't going to look anything like the package+ -- qualifier (even with old versions of GHC, the+ -- IPID would be p-0.1, but a package qualifier never+ -- has a version number it. (Is it possible that in+ -- Haddock-land, the UnitIds never have version numbers?+ -- I, ezyang, have not quite understand Haddock's package+ -- identifier model.)+ --+ -- Additionally, this is simulating some logic GHC already+ -- has for deciding how to qualify names when it outputs+ -- them to the user. We should reuse that information;+ -- or at least reuse the renamed imports, which know what+ -- they import!+ (fmap Module.fsToUnit $+ fmap sl_fs $ ideclPkgQual impDecl)+ (case ideclName impDecl of SrcLoc.L _ name -> name),+ alias))+ impDecls -- We want to know which modules are imported without any qualification. This -- way we can display module reexports more compactly. This mapping also looks@@ -287,13 +393,13 @@ -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn ::- DynFlags -> Maybe UnitId -> ModuleName -> Module+ UnitState -> Maybe Unit -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName-lookupModuleDyn dflags Nothing mdlName =- case lookupModuleInAllPackages dflags mdlName of+lookupModuleDyn state Nothing mdlName =+ case lookupModuleInAllUnits state mdlName of (m,_):_ -> m- [] -> Module.mkModule Module.mainUnitId mdlName+ [] -> Module.mkModule Module.mainUnit mdlName -------------------------------------------------------------------------------@@ -398,9 +504,8 @@ , [(Name, Map Int (MDoc Name))] , [(Name, [LHsDecl GhcRn])] )- mappings (ldecl, docStrs) = do- let L l decl = ldecl- declDoc :: [HsDocString] -> Map Int HsDocString+ mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do+ let declDoc :: [HsDocString] -> Map Int HsDocString -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs@@ -428,12 +533,13 @@ seqList subDocs `seq` seqList subArgs `seq` pure (dm, am, cm)+ mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], []) - instanceMap :: Map SrcSpan Name- instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]+ instanceMap :: Map RealSrcSpan Name+ instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] - names :: SrcSpan -> HsDecl GhcRn -> [Name]- names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2].+ names :: RealSrcSpan -> HsDecl GhcRn -> [Name]+ names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2]. where loc = case d of -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and@@ -456,200 +562,13 @@ -------------------------------------------------------------------------------- --- | Get all subordinate declarations inside a declaration, and their docs.--- A subordinate declaration is something like the associate type or data--- family of a type class.-subordinates :: InstMap- -> HsDecl GhcRn- -> [(Name, [HsDocString], Map Int HsDocString)]-subordinates instMap decl = case decl of- InstD _ (ClsInstD _ d) -> do- DataFamInstDecl { dfid_eqn = HsIB { hsib_body =- FamEqn { feqn_tycon = L l _- , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d- [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))- -> dataSubs (feqn_rhs d)- TyClD _ d | isClassDecl d -> classSubs d- | isDataDecl d -> dataSubs (tcdDataDefn d)- _ -> []- where- classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd- , name <- getMainDeclBinder d, not (isValD d)- ]- dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]- dataSubs dd = constrs ++ fields ++ derivs- where- cons = map unLoc $ (dd_cons dd)- constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c)- | c <- cons, cname <- getConNames c ]- fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)- | RecCon flds <- map getConArgs cons- , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)- , L _ n <- ns ]- derivs = [ (instName, [unLoc doc], M.empty)- | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $- concatMap (unLoc . deriv_clause_tys . unLoc) $- unLoc $ dd_derivs dd- , Just instName <- [M.lookup l instMap] ]-- extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)- extract_deriv_ty ty =- case dL ty of- -- deriving (forall a. C a {- ^ Doc comment -})- L l (HsForAllTy{ hst_fvf = ForallInvis- , hst_body = dL->L _ (HsDocTy _ _ doc) })- -> Just (l, doc)- -- deriving (C a {- ^ Doc comment -})- L l (HsDocTy _ _ doc) -> Just (l, doc)- _ -> Nothing---- | Extract constructor argument docs from inside constructor decls.-conArgDocs :: ConDecl GhcRn -> Map Int HsDocString-conArgDocs con = case getConArgs con of- PrefixCon args -> go 0 (map unLoc args ++ ret)- InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)- RecCon _ -> go 1 ret- where- go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys- go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys- go n (_ : tys) = go (n+1) tys- go _ [] = M.empty-- ret = case con of- ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]- _ -> []---- | Extract function argument docs from inside top-level decls.-declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString-declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty))-declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty))-declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty))-declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty))-declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty)-declTypeDocs _ = M.empty---- | Extract function argument docs from inside types.-typeDocs :: HsType GhcRn -> Map Int HsDocString-typeDocs = go 0- where- go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)- go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)- go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty- go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)- go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc- go _ _ = M.empty---- | All the sub declarations of a class (that we handle), ordered by--- source location, with documentation attached if it exists.-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]-classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls- where- decls = docs ++ defs ++ sigs ++ ats- docs = mkDecls tcdDocs (DocD noExtField) class_- defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_- sigs = mkDecls tcdSigs (SigD noExtField) class_- ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_----- | The top-level declarations of a module that we care about,--- ordered by source location, with documentation attached if it exists.-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]-topDecls =- filterClasses . filterDecls . collectDocs . sortByLoc . ungroup- -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap-mkFixMap group_ = M.fromList [ (n,f)- | L _ (FixitySig _ ns f) <- hs_fixds group_,- L _ n <- ns ]----- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.-ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]-ungroup group_ =- mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++- mkDecls hs_derivds (DerivD noExtField) group_ ++- mkDecls hs_defds (DefD noExtField) group_ ++- mkDecls hs_fords (ForD noExtField) group_ ++- mkDecls hs_docs (DocD noExtField) group_ ++- mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++- mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++- mkDecls (valbinds . hs_valds) (ValD noExtField) group_- where- typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs- typesigs _ = error "expected ValBindsOut"-- valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds- valbinds _ = error "expected ValBindsOut"----- | Take a field of declarations from a data structure and create HsDecls--- using the given constructor-mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]-mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]----- | Sort by source location-sortByLoc :: [Located a] -> [Located a]-sortByLoc = sortBy (comparing getLoc)-------------------------------------------------------------------------------------- Filtering of declarations------ We filter out declarations that we don't intend to handle later.-------------------------------------------------------------------------------------- | Filter out declarations that we don't handle in Haddock-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterDecls = filter (isHandled . unLoc . fst)- where- isHandled (ForD _ (ForeignImport {})) = True- isHandled (TyClD {}) = True- isHandled (InstD {}) = True- isHandled (DerivD {}) = True- isHandled (SigD _ d) = isUserLSig (noLoc d)- isHandled (ValD {}) = True- -- we keep doc declarations to be able to get at named docs- isHandled (DocD {}) = True- isHandled _ = False---- | Go through all class declarations and filter their sub-declarations-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x- | x@(L loc d, doc) <- decls ]- where- filterClass (TyClD x c) =- TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }- filterClass _ = error "expected TyClD"-------------------------------------------------------------------------------------- Collect docs------ To be able to attach the right Haddock comment to the right declaration,--- we sort the declarations by their SrcLoc and "collect" the docs for each--- declaration.-------------------------------------------------------------------------------------- | Collect docs and attach them to the right declarations.-collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]-collectDocs = go Nothing []- where- go Nothing _ [] = []- go (Just prev) docs [] = finished prev docs []- go prev docs (L _ (DocD _ (DocCommentNext str)) : ds)- | Nothing <- prev = go Nothing (str:docs) ds- | Just decl <- prev = finished decl docs (go Nothing [str] ds)- go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds- go Nothing docs (d:ds) = go (Just d) docs ds- go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)-- finished decl docs rest = (decl, reverse docs) : rest+mkFixMap group_ =+ M.fromList [ (n,f)+ | L _ (FixitySig _ ns f) <- hsGroupTopLevelFixitySigs group_,+ L _ n <- ns ] -- | Build the list of items that will become the documentation, from the@@ -659,7 +578,7 @@ -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems- :: HasCallStack+ :: (Monad m) => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package@@ -677,7 +596,7 @@ -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags- -> ErrMsgGhc [ExportItem GhcRn]+ -> IfM m [ExportItem GhcRn] mkExportItems is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps fixMap unrestricted_imp_mods splices exportList allExports@@ -719,25 +638,39 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail -availExportItem :: HasCallStack- => Bool -- is it a signature- -> IfaceMap- -> Module -- this module- -> Module -- semantic module- -> WarningMap- -> [Name] -- exported names (orig)- -> Maps- -> FixMap- -> [SrcSpan] -- splice locations- -> InstIfaceMap- -> DynFlags- -> AvailInfo- -> ErrMsgGhc [ExportItem GhcRn]++-- Extract the minimal complete definition of a Name, if one exists+minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef)+minimalDef n = do+ mty <- lookupName n+ case mty of+ Just (ATyCon (tyConClass_maybe -> Just c)) ->+ return . Just $ classMinimalDef c+ _ ->+ return Nothing+++availExportItem+ :: forall m+ . Monad m+ => Bool -- is it a signature+ -> IfaceMap+ -> Module -- this module+ -> Module -- semantic module+ -> WarningMap+ -> [Name] -- exported names (orig)+ -> Maps+ -> FixMap+ -> [SrcSpan] -- splice locations+ -> InstIfaceMap+ -> DynFlags+ -> AvailInfo+ -> IfM m [ExportItem GhcRn] availExportItem is_sig modMap thisMod semMod warnings exportedNames (docMap, argMap, declMap, _) fixMap splices instIfaceMap dflags availInfo = declWith availInfo where- declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ]+ declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ] declWith avail = do let t = availName avail r <- findDecl avail@@ -774,7 +707,7 @@ in availExportDecl avail newDecl docs_ L loc (TyClD _ cl@ClassDecl{}) -> do- mdef <- liftGhcToErrMsgGhc $ minimalDef t+ mdef <- minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_@@ -803,7 +736,7 @@ _ -> return [] -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails- availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn)+ availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn) availDecl declName parentDecl = case extractDecl declMap declName parentDecl of Right d -> pure d@@ -815,7 +748,7 @@ availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)])- -> ErrMsgGhc [ ExportItem GhcRn ]+ -> IfM m [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) | availExportsDecl avail = do extractedDecl <- availDecl (availName avail) decl@@ -861,7 +794,7 @@ exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))+ findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl avail | m == semMod = case M.lookup n declMap of@@ -876,11 +809,11 @@ Nothing -> return ([], (noDocForDecl, availNoDocs avail)) -- TODO: If we try harder, we might be able to find -- a Haddock! Look in the Haddocks for each thing in- -- requirementContext (pkgState)+ -- requirementContext (unitState) Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) | otherwise -> return ([], (noDocForDecl, availNoDocs avail))- | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap+ | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap , Just ds <- M.lookup n (ifaceDeclMap iface) = return (ds, lookupDocs avail warnings (ifaceDocMap iface)@@ -890,10 +823,10 @@ n = availName avail m = nameModule n - findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]+ findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)] findBundledPatterns avail = do patsyns <- for constructor_names $ \name -> do- mtyThing <- liftGhcToErrMsgGhc (lookupName name)+ mtyThing <- lookupName name case mtyThing of Just (AConLike PatSynCon{}) -> do export_items <- declWith (Avail.avail name)@@ -926,15 +859,15 @@ -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'.-semToIdMod :: UnitId -> Module -> Module+semToIdMod :: Unit -> Module -> Module semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m)- | otherwise = m+ | otherwise = m -- | Reify a declaration from the GHC internal 'TyThing' representation.-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))+hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do- mayTyThing <- liftGhcToErrMsgGhc $ lookupName t+ mayTyThing <- lookupName t case mayTyThing of Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]@@ -953,8 +886,9 @@ -- It gets the type signature from GHC and that means it's not going to -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here.-hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool- -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn)+hiValExportItem+ :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool+ -> Maybe Fixity -> IfM m (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of@@ -984,12 +918,14 @@ -- | Export the given module as `ExportModule`. We are not concerned with the -- single export items of the given module.-moduleExport :: Module -- ^ Module A (identity, NOT semantic)- -> DynFlags -- ^ The flags used when typechecking A- -> IfaceMap -- ^ Already created interfaces- -> InstIfaceMap -- ^ Interfaces in other packages- -> ModuleName -- ^ The exported module- -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items+moduleExport+ :: Monad m+ => Module -- ^ Module A (identity, NOT semantic)+ -> DynFlags -- ^ The flags used when typechecking A+ -> IfaceMap -- ^ Already created interfaces+ -> InstIfaceMap -- ^ Interfaces in other packages+ -> ModuleName -- ^ The exported module+ -> IfM m [ExportItem GhcRn] -- ^ Resulting export items moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap.@@ -1003,13 +939,11 @@ case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do- liftErrMsg $- tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++- "documentation for exported module: " ++ pretty dflags expMod]+ liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " +++ "documentation for exported module: " ++ pretty dflags expMod] return [] where- m = mkModule unitId expMod -- Identity module!- unitId = moduleUnitId thisMod+ m = mkModule (moduleUnit thisMod) expMod -- Identity module! -- Note [1]: ------------@@ -1032,22 +966,24 @@ -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations. -fullModuleContents :: Bool -- is it a signature- -> IfaceMap- -> Maybe Package -- this package- -> Module -- this module- -> Module -- semantic module- -> WarningMap- -> GlobalRdrEnv -- ^ The renaming environment- -> [Name] -- exported names (orig)- -> [LHsDecl GhcRn] -- renamed source declarations- -> Maps- -> FixMap- -> [SrcSpan] -- splice locations- -> InstIfaceMap- -> DynFlags- -> Avails- -> ErrMsgGhc [ExportItem GhcRn]+fullModuleContents+ :: Monad m+ => Bool -- is it a signature+ -> IfaceMap+ -> Maybe Package -- this package+ -> Module -- this module+ -> Module -- semantic module+ -> WarningMap+ -> GlobalRdrEnv -- ^ The renaming environment+ -> [Name] -- exported names (orig)+ -> [LHsDecl GhcRn] -- renamed source declarations+ -> Maps+ -> FixMap+ -> [SrcSpan] -- splice locations+ -> InstIfaceMap+ -> DynFlags+ -> Avails+ -> IfM m [ExportItem GhcRn] fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do let availEnv = availsToNameEnv (nubAvails avails)@@ -1182,9 +1118,9 @@ extract con = let args = case getConArgs con of- PrefixCon args' -> args'+ PrefixCon args' -> (map hsScaledThing args') RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields- InfixCon arg1 arg2 -> [arg1, arg2]+ InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] typ = longArrow args (data_ty con) typ' = case con of@@ -1194,7 +1130,7 @@ in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs+ longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con@@ -1211,7 +1147,7 @@ extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->- pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))))+ pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]@@ -1244,7 +1180,7 @@ where subs = map fst (expItemSubDocs e) patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of- InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap+ InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them.
src/Haddock/Interface/Json.hs view
@@ -5,11 +5,11 @@ , renderJson ) where -import BasicTypes-import Json-import Module-import Name-import Outputable+import GHC.Types.Basic+import GHC.Utils.Json+import GHC.Unit.Module+import GHC.Types.Name+import GHC.Utils.Outputable import Control.Arrow import Data.Map (Map)
src/Haddock/Interface/LexParseRn.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -25,17 +26,17 @@ import Data.List (maximumBy, (\\)) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat)-import DynFlags (languageExtensions)+import GHC.Driver.Session (languageExtensions) import qualified GHC.LanguageExtensions as LangExt import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types-import Name-import Outputable ( showPpr, showSDoc )-import RdrName-import RdrHsSyn (setRdrNameSpace)-import EnumSet+import GHC.Types.Name+import GHC.Parser.PostProcess+import GHC.Utils.Outputable ( showPpr, showSDoc )+import GHC.Types.Name.Reader+import GHC.Data.EnumSet as EnumSet processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name))
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE DeriveFunctor #-}+ ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader@@ -15,7 +16,7 @@ import Control.Applicative (Alternative (..)) import Control.Monad (ap) import Data.Char-import DynFlags+import GHC.Driver.Session import Haddock.Parser import Haddock.Types
src/Haddock/Interface/Rename.hs view
@@ -20,11 +20,11 @@ import Haddock.GhcUtils import Haddock.Types -import Bag (emptyBag)+import GHC.Data.Bag (emptyBag) import GHC hiding (NoLink)-import Name-import RdrName (RdrName(Exact))-import TysWiredIn (eqTyCon_RDR)+import GHC.Types.Name+import GHC.Types.Name.Reader (RdrName(Exact))+import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first )@@ -33,6 +33,7 @@ import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set import Prelude hiding (mapM)+import GHC.HsToCore.Docs -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to -- 'DocName'.@@ -232,7 +233,6 @@ renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr ; return (L loc (TyVarSig noExtField bndr')) }-renameFamilyResultSig (L _ (XFamilyResultSig nec)) = noExtCon nec renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))@@ -244,13 +244,18 @@ -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn +renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)+renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)+renameArrow (HsLinearArrow u) = return (HsLinearArrow u)+renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p+ renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of- HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do- tyvars' <- mapM renameLTyVarBndr tyvars- ltype' <- renameLType ltype- return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField- , hst_bndrs = tyvars', hst_body = ltype' })+ HsForAllTy { hst_tele = tele, hst_body = ltype } -> do+ tele' <- renameHsForAllTelescope tele+ ltype' <- renameLType ltype+ return (HsForAllTy { hst_xforall = noExtField+ , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext@@ -272,10 +277,11 @@ b' <- renameLKind b return (HsAppKindTy noExtField a' b') - HsFunTy _ a b -> do+ HsFunTy _ w a b -> do a' <- renameLType a b' <- renameLType b- return (HsFunTy noExtField a' b')+ w' <- renameArrow w+ return (HsFunTy noExtField w' a' b') HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty)@@ -326,17 +332,22 @@ = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) }-renameLHsQTyVars (XLHsQTyVars nec) = noExtCon nec -renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)-renameLTyVarBndr (L loc (UserTyVar x (L l n)))+renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)+renameHsForAllTelescope tele = case tele of+ HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+ pure $ HsForAllVis x bndrs'+ HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+ pure $ HsForAllInvis x bndrs'++renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)+renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) = do { n' <- rename n- ; return (L loc (UserTyVar x (L l n'))) }-renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))+ ; return (L loc (UserTyVar x fl (L l n'))) }+renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind- ; return (L loc (KindedTyVar x (L lv n') kind')) }-renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec+ ; return (L loc (KindedTyVar x fl (L lv n') kind')) } renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do@@ -427,7 +438,6 @@ , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField })- XTyClDecl nec -> noExtCon nec where renameLFunDep (L loc (xs, ys)) = do@@ -453,7 +463,6 @@ , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' })-renameFamilyDecl (XFamilyDecl nec) = noExtCon nec renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn@@ -483,7 +492,6 @@ , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] })-renameDataDefn (XHsDataDefn nec) = noExtCon nec renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars@@ -503,7 +511,7 @@ , con_res_ty = res_ty , con_doc = mbldoc }) = do lnames' <- mapM renameL lnames- ltyvars' <- renameLHsQTyVars ltyvars+ ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details res_ty' <- renameLType res_ty@@ -511,16 +519,21 @@ return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' })-renameCon (XConDecl nec) = noExtCon nec +renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)+ -> RnM (HsScaled DocNameI (LHsType DocNameI))+renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty+ renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields'))-renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps+ -- This causes an assertion failure+--renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps+renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps renameDetails (InfixCon a b) = do- a' <- renameLType a- b' <- renameLType b+ a' <- renameHsScaled a+ b' <- renameHsScaled b return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)@@ -529,13 +542,11 @@ t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField noExtField names' t' doc')-renameConDeclFieldField (L _ (XConDeclField nec)) = noExtCon nec renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel return $ L l (FieldOcc sel' lbl)-renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of@@ -570,7 +581,6 @@ lname' <- renameL lname ltype' <- renameLSigType ltype return (ForeignExport noExtField lname' ltype' x)-renameForD (XForeignDecl nec) = noExtCon nec renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)@@ -583,7 +593,6 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' })-renameInstD (XInstDecl nec) = noExtCon nec renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty@@ -595,7 +604,6 @@ , deriv_type = ty' , deriv_strategy = strat' , deriv_overlap_mode = omode })-renameDerivD (XDerivDecl nec) = noExtCon nec renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) renameDerivStrategy StockStrategy = pure StockStrategy@@ -614,7 +622,6 @@ , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })-renameClsInstD (XClsInstDecl nec) = noExtCon nec renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)@@ -642,7 +649,6 @@ , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) }- rename_ty_fam_eqn (XFamEqn nec) = noExtCon nec renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD@@ -668,7 +674,6 @@ , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) }- rename_data_fam_eqn (XFamEqn nec) = noExtCon nec renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing@@ -677,7 +682,6 @@ = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' , hsib_ext = noExtField }) }-renameImplicit _ (XHsImplicitBndrs nec) = noExtCon nec renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing@@ -686,7 +690,6 @@ = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' , hswc_ext = noExtField }) }-renameWc _ (XHsWildCardBndrs nec) = noExtCon nec renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do
src/Haddock/Interface/Specialize.hs view
@@ -15,10 +15,10 @@ import Haddock.Types import GHC-import Name-import FastString-import TysPrim ( funTyConName )-import TysWiredIn ( listTyConName )+import GHC.Types.Name+import GHC.Data.FastString+import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )+import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State@@ -134,7 +134,7 @@ sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb- | funTyConName == name' = HsFunTy noExtField la lb+ | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ@@ -204,12 +204,16 @@ everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType GhcRn) of- Just (HsForAllTy _ _ bndrs _) ->- (Set.empty, Set.union ctx (bndrsNames bndrs))+ Just (HsForAllTy _ tele _) ->+ (Set.empty, Set.union ctx (teleNames tele)) Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx)++ teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs+ teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs+ bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) @@ -242,9 +246,9 @@ renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)-renameType (HsForAllTy x fvf bndrs lt) =- HsForAllTy x fvf- <$> mapM (located renameBinder) bndrs+renameType (HsForAllTy x tele lt) =+ HsForAllTy x+ <$> renameForAllTelescope tele <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x@@ -254,7 +258,7 @@ renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk-renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr+renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt@@ -275,7 +279,11 @@ renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)+renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p+renameHsArrow mult = pure mult + renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType @@ -289,12 +297,21 @@ renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)-renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname-renameBinder (KindedTyVar x lname lkind) =- KindedTyVar x <$> located renameName lname <*> located renameType lkind-renameBinder (XTyVarBndr nec) = noExtCon nec+renameForAllTelescope :: HsForAllTelescope GhcRn+ -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn)+renameForAllTelescope (HsForAllVis x bndrs) =+ HsForAllVis x <$> mapM renameLBinder bndrs+renameForAllTelescope (HsForAllInvis x bndrs) =+ HsForAllInvis x <$> mapM renameLBinder bndrs +renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)+renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname+renameBinder (KindedTyVar x fl lname lkind) =+ KindedTyVar x fl <$> located renameName lname <*> located renameType lkind++renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)+renameLBinder = located renameBinder+ -- | Core renaming logic. renameName :: SetName name => name -> Rename name name renameName name = do@@ -345,5 +362,3 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e--
src/Haddock/InterfaceFile.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -31,19 +32,19 @@ import Data.Map (Map) import Data.Word -import BinIface (getSymtabName, getDictFastString)-import Binary-import FastMutInt-import FastString+import GHC.Iface.Binary (getSymtabName, getDictFastString)+import GHC.Utils.Binary+import GHC.Data.FastMutInt+import GHC.Data.FastString import GHC hiding (NoLink)-import GhcMonad (withSession)-import HscTypes-import NameCache-import IfaceEnv-import Name-import UniqFM-import UniqSupply-import Unique+import GHC.Driver.Monad (withSession)+import GHC.Driver.Types+import GHC.Types.Name.Cache+import GHC.Iface.Env+import GHC.Types.Name+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply+import GHC.Types.Unique data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv,@@ -57,11 +58,11 @@ [] -> error "empty InterfaceFile" iface:_ -> instMod iface -ifUnitId :: InterfaceFile -> UnitId+ifUnitId :: InterfaceFile -> Unit ifUnitId if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile"- iface:_ -> moduleUnitId $ instMod iface+ iface:_ -> moduleUnit $ instMod iface binaryInterfaceMagic :: Word32@@ -93,7 +94,7 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811)+#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16]@@ -169,7 +170,7 @@ type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: GhcMonad m => NameCacheAccessor m+nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do@@ -287,7 +288,7 @@ data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt, -- The next index to use- bin_symtab_map :: !(IORef (UniqFM (Int,Name)))+ bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) -- indexed by Name } @@ -297,24 +298,24 @@ bin_dict_map = out_r} bh f = do out <- readIORef out_r- let unique = getUnique f- case lookupUFM out unique of+ let !unique = getUnique f+ case lookupUFM_Directly out unique of Just (j, _) -> put_ bh (fromIntegral j :: Word32) Nothing -> do j <- readFastMutInt j_r put_ bh (fromIntegral j :: Word32) writeFastMutInt j_r (j + 1)- writeIORef out_r $! addToUFM out unique (j, f)+ writeIORef out_r $! addToUFM_Directly out unique (j, f) data BinDictionary = BinDictionary { bin_dict_next :: !FastMutInt, -- The next index to use- bin_dict_map :: !(IORef (UniqFM (Int,FastString)))+ bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString } -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()+putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () putSymbolTable bh next_off symtab = do put_ bh next_off let names = elems (array (0,next_off-1) (eltsUFM symtab))@@ -330,7 +331,7 @@ return (namecache', arr) -type OnDiskName = (UnitId, ModuleName, OccName)+type OnDiskName = (Unit, ModuleName, OccName) fromOnDiskName@@ -357,10 +358,10 @@ } -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()+serialiseName :: BinHandle -> Name -> UniqFM Name (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name- put_ bh (moduleUnitId modu, moduleName modu, nameOccName name)+ put_ bh (moduleUnit modu, moduleName modu, nameOccName name) -------------------------------------------------------------------------------
src/Haddock/ModuleTree.hs view
@@ -14,11 +14,9 @@ import Haddock.Types ( MDoc ) -import GHC ( Name )-import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString )-import DynFlags ( DynFlags )-import Packages ( lookupPackage )-import PackageConfig ( sourcePackageIdString )+import GHC ( Name )+import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString )+import GHC.Unit.State ( UnitState, lookupUnit, unitPackageIdString ) import qualified Control.Applicative as A @@ -26,14 +24,14 @@ data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]-mkModuleTree dflags showPkgs mods =+mkModuleTree :: UnitState -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]+mkModuleTree state showPkgs mods = foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where- modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_))+ modPkg mod_ | showPkgs = Just (unitString (moduleUnit mod_)) | otherwise = Nothing- modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString- (lookupPackage dflags (moduleUnitId mod_))+ modSrcPkg mod_ | showPkgs = fmap unitPackageIdString+ (lookupUnit state (moduleUnit mod_)) | otherwise = Nothing fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short
src/Haddock/Options.hs view
@@ -24,6 +24,7 @@ optSourceCssFile, sourceUrls, wikiUrls,+ optParCount, optDumpInterfaceFile, optShowInterfaceFile, optLaTeXStyle,@@ -44,11 +45,12 @@ import qualified Data.Char as Char import Data.Version import Control.Applicative-import FastString-import GHC ( DynFlags, Module, moduleUnitId )+import GHC.Data.FastString+import GHC ( DynFlags, Module, moduleUnit, unitState )+import GHC.Unit.Info ( PackageName(..), unitPackageName, unitPackageVersion )+import GHC.Unit.State ( lookupUnit ) import Haddock.Types import Haddock.Utils-import Packages import System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP @@ -110,6 +112,7 @@ | Flag_Reexport String | Flag_SinceQualification String | Flag_IgnoreLinkSymbol String+ | Flag_ParCount (Maybe Int) deriving (Eq, Show) @@ -223,7 +226,9 @@ Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL") "package qualification of @since, one of\n'always' (default) or 'only-external'", Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")- "name of a symbol which does not trigger a warning in case of link issue"+ "name of a symbol which does not trigger a warning in case of link issue",+ Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")+ "load modules in parallel" ] @@ -306,10 +311,11 @@ optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] - optMathjax :: [Flag] -> Maybe String optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ] +optParCount :: [Flag] -> Maybe (Maybe Int)+optParCount flags = optLast [ n | Flag_ParCount n <- flags ] qualification :: [Flag] -> Either String QualOption qualification flags =@@ -383,8 +389,8 @@ -> (Maybe PackageName, Maybe Data.Version.Version) modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) modulePackageInfo dflags flags (Just modu) =- ( optPackageName flags <|> fmap packageName pkgDb- , optPackageVersion flags <|> fmap packageVersion pkgDb+ ( optPackageName flags <|> fmap unitPackageName pkgDb+ , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where- pkgDb = lookupPackage dflags (moduleUnitId modu)+ pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)
src/Haddock/Parser.hs view
@@ -18,14 +18,14 @@ import Documentation.Haddock.Types import Haddock.Types -import DynFlags ( DynFlags )-import FastString ( fsLit )-import Lexer ( mkPState, unP, ParseResult(..) )-import OccName ( occNameString )-import Parser ( parseIdentifier )-import RdrName ( RdrName(Qual) )-import SrcLoc ( mkRealSrcLoc, GenLocated(..) )-import StringBuffer ( stringToStringBuffer )+import GHC.Driver.Session ( DynFlags )+import GHC.Data.FastString ( fsLit )+import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) )+import GHC.Parser ( parseIdentifier )+import GHC.Types.Name.Occurrence ( occNameString )+import GHC.Types.Name.Reader ( RdrName(..) )+import GHC.Types.SrcLoc ( mkRealSrcLoc, GenLocated(..) )+import GHC.Data.StringBuffer ( stringToStringBuffer ) parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
src/Haddock/Types.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -----------------------------------------------------------------------------@@ -25,26 +28,29 @@ , HsDocString, LHsDocString , Fixity(..) , module Documentation.Haddock.Types++ -- $ Reexports+ , runWriter+ , tell ) where -import Control.Exception-import Control.Arrow hiding ((<+>)) import Control.DeepSeq-import Control.Monad (ap)+import Control.Exception (throw)+import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) import Data.Void (Void) import Documentation.Haddock.Types-import BasicTypes (Fixity(..), PromotionFlag(..))+import GHC.Types.Basic (Fixity(..), PromotionFlag(..)) -import Exception (ExceptionMonad(..), ghandle) import GHC-import DynFlags (Language)+import GHC.Driver.Session (Language) import qualified GHC.LanguageExtensions as LangExt-import OccName-import Outputable hiding ((<>))+import GHC.Types.Name.Occurrence+import GHC.Utils.Outputable ----------------------------------------------------------------------------- -- * Convenient synonyms@@ -57,7 +63,7 @@ type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl GhcRn]-type InstMap = Map SrcSpan Name+type InstMap = Map RealSrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -307,6 +313,8 @@ type instance IdP DocNameI = DocName +instance CollectPass DocNameI where+ collectXXPat _ ext = noExtCon ext instance NamedThing DocName where getName (Documented name _) = name@@ -409,13 +417,12 @@ , pfdKindSig = fdResultSig } where- mkType (KindedTyVar _ (L loc name) lkind) =+ mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)+ mkType (KindedTyVar _ _ (L loc name) lkind) = HsKindSig noExtField tvar lkind where tvar = L loc (HsTyVar noExtField NotPromoted (L loc name))- mkType (UserTyVar _ name) = HsTyVar noExtField NotPromoted name- mkType (XTyVarBndr nec) = noExtCon nec-mkPseudoFamilyDecl (XFamilyDecl nec) = noExtCon nec+ mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name -- | An instance head that may have documentation and a source location.@@ -627,26 +634,7 @@ type ErrMsg = String-newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }---instance Functor ErrMsgM where- fmap f (Writer (a, msgs)) = Writer (f a, msgs)--instance Applicative ErrMsgM where- pure a = Writer (a, [])- (<*>) = ap--instance Monad ErrMsgM where- return = pure- m >>= k = Writer $ let- (a, w) = runWriter m- (b, w') = runWriter (k a)- in (b, w ++ w')---tell :: [ErrMsg] -> ErrMsgM ()-tell w = Writer ((), w)+type ErrMsgM = Writer [ErrMsg] -- Exceptions@@ -667,54 +655,44 @@ instance Exception HaddockException throwE str = throw (HaddockException str) -withExceptionContext :: ExceptionMonad m => String -> m a -> m a+withExceptionContext :: MonadCatch m => String -> m a -> m a withExceptionContext ctxt =- ghandle (\ex ->+ handle (\ex -> case ex of- HaddockException _ -> throw $ WithContext [ctxt] (toException ex)- WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se+ HaddockException _ -> throwM $ WithContext [ctxt] (toException ex)+ WithContext ctxts se -> throwM $ WithContext (ctxt:ctxts) se ) .- ghandle (throw . WithContext [ctxt])+ handle (throwM . WithContext [ctxt]) -- In "Haddock.Interface.Create", we need to gather -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the -- transformed monad to be MonadIO.-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }---instance MonadIO ErrMsgGhc where--- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO---er, implementing GhcMonad involves annoying ExceptionMonad and---WarnLogMonad classes, so don't bother.-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a-liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a-liftErrMsg = WriterGhc . return . runWriter--- for now, use (liftErrMsg . tell) for this---tell :: [ErrMsg] -> ErrMsgGhc ()---tell msgs = WriterGhc $ return ( (), msgs )+newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a } -instance Functor ErrMsgGhc where- fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)+deriving newtype instance Functor ErrMsgGhc+deriving newtype instance Applicative ErrMsgGhc+deriving newtype instance Monad ErrMsgGhc+deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc+deriving newtype instance MonadIO ErrMsgGhc -instance Applicative ErrMsgGhc where- pure a = WriterGhc (return (a, []))- (<*>) = ap -instance Monad ErrMsgGhc where- return = pure- m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->- fmap (second (msgs1 ++)) (runWriterGhc (k a))+runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg])+runWriterGhc = runWriterT . unErrMsgGhc -instance MonadIO ErrMsgGhc where- liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a+liftGhcToErrMsgGhc = ErrMsgGhc . lift -instance ExceptionMonad ErrMsgGhc where- gcatch act hand = WriterGhc $- runWriterGhc act `gcatch` (runWriterGhc . hand)- gmask act = WriterGhc $ gmask $ \mask' ->- runWriterGhc $ act (WriterGhc . mask' . runWriterGhc)+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a+liftErrMsg = writer . runWriter +instance MonadThrow ErrMsgGhc where+ throwM e = ErrMsgGhc (throwM e)++instance MonadCatch ErrMsgGhc where+ catch (ErrMsgGhc m) f = ErrMsgGhc (catch m (unErrMsgGhc . f))+ ----------------------------------------------------------------------------- -- * Pass sensitive types -----------------------------------------------------------------------------@@ -744,6 +722,10 @@ type instance XTyLit DocNameI = NoExtField type instance XWildCardTy DocNameI = NoExtField type instance XXType DocNameI = NewHsTypeX++type instance XHsForAllVis DocNameI = NoExtField+type instance XHsForAllInvis DocNameI = NoExtField+type instance XXHsForAllTelescope DocNameI = NoExtCon type instance XUserTyVar DocNameI = NoExtField type instance XKindedTyVar DocNameI = NoExtField
src/Haddock/Utils.hs view
@@ -50,13 +50,12 @@ import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types-import Haddock.GhcUtils -import Exception (ExceptionMonad) import GHC-import Name+import GHC.Types.Name import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Catch ( MonadMask, bracket_ ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map )@@ -74,7 +73,6 @@ import qualified System.Posix.Internals #endif - -------------------------------------------------------------------------------- -- * Logging --------------------------------------------------------------------------------@@ -278,9 +276,9 @@ hSetEncoding h utf8 hPutStr h contents -withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a-withTempDir dir = gbracket_ (liftIO $ createDirectory dir)- (liftIO $ removeDirectoryRecursive dir)+withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a+withTempDir dir = bracket_ (liftIO $ createDirectory dir)+ (liftIO $ removeDirectoryRecursive dir) ----------------------------------------------------------------------------- -- * HTML cross references
test/Haddock/Backends/Hyperlinker/ParserSpec.hs view
@@ -4,8 +4,8 @@ import Test.Hspec import Test.QuickCheck -import GHC ( runGhc, getSessionDynFlags )-import DynFlags ( DynFlags )+import GHC ( runGhc, getSessionDynFlags )+import GHC.Driver.Session ( DynFlags ) import Control.Monad.IO.Class import Data.String ( fromString )