diff options
| author | alexbiehl-gc <72160047+alexbiehl-gc@users.noreply.github.com> | 2021-02-07 18:39:59 +0100 |
|---|---|---|
| committer | GitHub <noreply@github.com> | 2021-02-07 18:39:59 +0100 |
| commit | 786d3e69799398c3aac26fbd5017a127bc69cacc (patch) | |
| tree | 883ee3f8c0e195299925b790cba6f88a537200f6 | |
| parent | e90e79815960823a749287968fb1c6d09559a67f (diff) | |
| parent | 0f7ff041fb824653a7930e1292b81f34df1e967d (diff) | |
Merge branch 'ghc-head' into ghc-9.0
50 files changed, 1900 insertions, 1442 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index f3dbe2e2..e6de8b81 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -43,8 +43,8 @@ library default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base ^>= 4.15.0 - , ghc ^>= 9.0 + build-depends: base ^>= 4.16.0 + , ghc ^>= 9.1 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 @@ -60,6 +60,7 @@ library , exceptions , filepath , ghc-boot + , mtl , transformers hs-source-dirs: src @@ -173,7 +174,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 9.0 + build-depends: ghc ^>= 9.1 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 8dfee5bc..2b6e2d57 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -70,6 +70,7 @@ import GHC hiding (verbosity) import GHC.Settings.Config import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Utils.Outputable (defaultUserStyle, withPprStyle) +import GHC.Driver.Env import GHC.Utils.Error import GHC.Unit import GHC.Utils.Panic (handleGhcException) @@ -152,12 +153,17 @@ haddockWithGhc ghc args = handleTopExceptions $ do 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 @@ -179,6 +185,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do ghc flags' $ withDir $ do dflags <- getDynFlags + unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks @@ -196,7 +203,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags flags sinceQual qual packages ifaces + liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ @@ -206,7 +213,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags sinceQual qual packages [] + liftIO $ renderStep dflags unit_state flags sinceQual qual packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -255,9 +262,9 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption +renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags sinceQual nameQual pkgs interfaces = do +renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs @@ -266,12 +273,12 @@ renderStep dflags flags sinceQual nameQual pkgs interfaces = do ((_, Just path), ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap + render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface] +render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do +render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -284,7 +291,6 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do 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 @@ -298,7 +304,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod pkgStr = fmap unitString pkgKey - pkgNameVer = modulePackageInfo dflags flags pkgMod + pkgNameVer = modulePackageInfo unit_state flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of External -> pkgName @@ -343,7 +349,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++) @@ -374,7 +380,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_GenContents `elem` flags) $ do withTiming dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} - ppHtmlContents pkgs odir title pkgStr + ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual) @@ -384,7 +390,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_Html `elem` flags) $ do withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} - ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir + ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual @@ -404,7 +410,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do pkgVer = fromMaybe (makeVersion []) mpkgVer - in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) + in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces odir _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " @@ -494,9 +500,9 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] | otherwise = [Opt_Haddock] dynflags' = (foldl' gopt_set dynflags extra_opts) - { hscTarget = HscNothing - , ghcMode = CompManager - , ghcLink = NoLink + { backend = NoBackend + , ghcMode = CompManager + , ghcLink = NoLink } flags' = filterRtsFlags flags diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 9a304030..f7e1c77b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -18,8 +18,9 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..) - , PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), + PromotionFlag(..), TopLevelFlag(..) ) +import GHC.Types.SourceText import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils @@ -27,8 +28,11 @@ import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) import GHC +import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Unit.State import Data.Char import Data.List (intercalate, isPrefixOf) @@ -37,15 +41,14 @@ import Data.Version import System.Directory import System.FilePath - prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" ,""] -ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle dflags package version synopsis prologue ifaces odir = do +ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do let -- Since Hoogle is line based, we want to avoid breaking long lines. dflags' = dflags{ pprCols = maxBound } filename = package ++ ".txt" @@ -54,42 +57,46 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do ["@package " ++ package] ++ ["@version " ++ showVersion version | not (null (versionBranch version)) ] ++ - concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] + concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir writeUtf8File (odir </> filename) (unlines contents) -ppModule :: DynFlags -> Interface -> [String] -ppModule dflags iface = +ppModule :: DynFlags -> UnitState -> Interface -> [String] +ppModule dflags unit_state iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) + concatMap (ppInstance dflags unit_state) (ifaceInstances iface) --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType a -> HsType a -dropHsDocTy = f +dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p) +dropHsDocTy = drop_sig_ty where - g (L src x) = L src (f x) - 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 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) - f (HsParTy x a) = HsParTy x (g a) - f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unLoc a - f x = x - -outHsType :: (OutputableBndrId p) - => DynFlags -> HsType (GhcPass p) -> String -outHsType dflags = out dflags . reparenType . dropHsDocTy + drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b) + drop_sig_ty x@XHsSigType{} = x + + drop_lty (L src x) = L src (drop_ty x) + + drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e) + drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e) + drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b) + drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b) + drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b) + drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b) + drop_ty (HsListTy x a) = HsListTy x (drop_lty a) + drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b) + drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c) + drop_ty (HsParTy x a) = HsParTy x (drop_lty a) + drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b + drop_ty (HsDocTy _ a _) = drop_ty $ unL a + drop_ty x = x + +outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p) + => DynFlags -> HsSigType (GhcPass p) -> String +outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy dropComment :: String -> String @@ -106,14 +113,14 @@ outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr f [] = [] out :: Outputable a => DynFlags -> a -> String -out dflags = outWith $ showSDocUnqual dflags +out dflags = outWith $ showSDoc dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x commaSeparate :: Outputable a => DynFlags -> [a] -> String -commaSeparate dflags = showSDocUnqual dflags . interpp'SP +commaSeparate dflags = showSDoc dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export @@ -133,8 +140,8 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl f (TyClD _ d@SynDecl{}) = ppSynonym dflags d f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs f (TyClD _ (FamDecl _ d)) = ppFam dflags d - f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] f (SigD _ sig) = ppSig dflags sig f _ = [] @@ -143,8 +150,8 @@ ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of - TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names - PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names + TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names + PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names _ -> [] where mkDocSig leader typ n = mkSubdoc dflags n subdocs @@ -153,9 +160,9 @@ ppSigWithDoc dflags sig subdocs = case sig of ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String +pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) = - operator prettyNames ++ " :: " ++ outHsType dflags typ + operator prettyNames ++ " :: " ++ outHsSigType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names @@ -173,7 +180,7 @@ ppClass dflags decl subdocs = ppTyFams | null $ tcdATs decl = "" - | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat + | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat [ map pprTyFam (tcdATs decl) , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl) ] @@ -198,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = - [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] +ppInstance :: DynFlags -> UnitState -> ClsInst -> [String] +ppInstance dflags unit_state x = + [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls] where -- As per #168, we don't want safety information about the class -- in Hoogle output. The easiest way to achieve this is to set the @@ -234,13 +241,13 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of _ -> [] ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] -ppCtor dflags dat subdocs con@ConDeclH98 {} +ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args' where - f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] - f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat + f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] + 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] @@ -248,11 +255,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} 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 (unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ + outHsSigType dflags (unL $ mkEmptySigType $ 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 + name = commaSeparate dflags . map unL $ getConNames con tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty @@ -262,13 +270,23 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} (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 +ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names + , con_bndrs = L _ outer_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty }) + = concatMap (lookupCon dflags subdocs) names ++ [typeSig] where - f = [typeSig name (getGADTConTypeG con)] - - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty) - name = out dflags $ map unLoc $ getConNames con + typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty + name = out dflags $ map unL names + con_sig_ty = HsSig noExtField outer_bndrs theta_ty where + theta_ty = case mcxt of + Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) + Nothing -> tau_ty + tau_ty = foldr mkFunTy res_ty $ + case args of PrefixConGADT pos_args -> map hsScaledThing pos_args + RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 03be8c22..d85a3970 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -70,10 +70,10 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile -- Get the AST and tokens corresponding to the source file we want let fileFs = mkFastString file mast | M.size asts == 1 = snd <$> M.lookupMin asts - | otherwise = M.lookup fileFs asts + | otherwise = M.lookup (HiePath (mkFastString file)) asts + tokens = parse df file rawSrc ast = fromMaybe (emptyHieAst fileFs) mast fullAst = recoverFullIfaceTypes df types ast - tokens = parse df file rawSrc -- Warn if we didn't find an AST, but there were still ASTs if M.null asts diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 3db3c685..52d73265 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -10,15 +10,18 @@ import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import GHC.Types.Basic ( IntegralLit(..) ) +import GHC.Types.SourceText import GHC.Driver.Session -import GHC.Utils.Error ( pprLocErrMsg ) +import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString ) +import GHC.Parser.Errors.Ppr ( pprError ) import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..) - , mkPStatePure, lexer, mkParserFlags', getErrorMessages) + , initParserState, lexer, mkParserOpts, getErrorMessages) import GHC.Data.Bag ( bagToList ) -import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) ) +import GHC.Utils.Outputable ( text, ($$) ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr ( showSDoc ) import GHC.Types.SrcLoc import GHC.Data.StringBuffer ( StringBuffer, atEnd ) @@ -37,17 +40,16 @@ parse parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed pst -> - let err:_ = bagToList (getErrorMessages pst dflags) in + let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in panic $ showSDoc dflags $ - text "Hyperlinker parse error:" $$ pprLocErrMsg err + text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err where - initState = mkPStatePure pflags buf start + initState = initParserState pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 - pflags = mkParserFlags' (warningFlags dflags) + pflags = mkParserOpts (warningFlags dflags) (extensionFlags dflags) - (homeUnitId dflags) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens @@ -240,7 +242,6 @@ classify tok = ITline_prag {} -> TkPragma ITcolumn_prag {} -> TkPragma ITscc_prag {} -> TkPragma - ITgenerated_prag {} -> TkPragma ITunpack_prag {} -> TkPragma ITnounpack_prag {} -> TkPragma ITann_prag {} -> TkPragma @@ -381,7 +382,6 @@ inPragma False tok = ITline_prag {} -> True ITcolumn_prag {} -> True ITscc_prag {} -> True - ITgenerated_prag {} -> True ITunpack_prag {} -> True ITnounpack_prag {} -> True ITann_prag {} -> True diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index b093b5a4..5c3bddef 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -21,7 +21,7 @@ import GHC 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.Driver.Ppr ( showSDoc ) import GHC.Types.Var ( VarBndr(..) ) import System.FilePath.Posix ((</>), (<.>)) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index ac904273..df1f94e6 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -31,7 +31,7 @@ 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 GHC.Utils.Panic ( panic) import qualified Data.Map as Map import System.Directory @@ -108,7 +108,7 @@ type LaTeX = Pretty.Doc -- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 -- often overflows the line). latex2String :: LaTeX -> String -latex2String = fullRender PageMode 90 1 txtPrinter "" +latex2String = fullRender (PageMode True) 90 1 txtPrinter "" ppLaTeXTop :: String @@ -177,7 +177,7 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeUtf8File (odir </> moduleLaTeXFile mdl) (show tex) + writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -215,10 +215,10 @@ processExports (e : es) = processExport e $$ processExports es -isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) +isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) + | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing @@ -301,7 +301,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -313,7 +313,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode + ppFunSig Nothing doc [name] typ unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -350,9 +350,9 @@ ppFamDecl associated doc instances decl unicode = -- Individual equations of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX - ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n - , feqn_rhs = rhs - , feqn_pats = ts } }) + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) @@ -407,7 +407,7 @@ ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode - = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name @@ -426,7 +426,7 @@ ppFunSig :: Maybe LaTeX -- ^ a prefix to put right before the signature -> DocForDecl DocName -- ^ documentation -> [DocName] -- ^ pattern names in the pattern signature - -> LHsType DocNameI -- ^ type of the pattern synonym + -> LHsSigType DocNameI -- ^ type of the pattern synonym -> Bool -- ^ unicode -> LaTeX ppFunSig leader doc docnames (L _ typ) unicode = @@ -447,11 +447,11 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode + = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. -ppTypeOrFunSig :: HsType DocNameI +ppTypeOrFunSig :: HsSigType DocNameI -> DocForDecl DocName -- ^ documentation -> ( LaTeX -- first-line (no-argument docs only) , LaTeX -- first-line (argument docs only) @@ -471,13 +471,24 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool -- ^ unicode - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) -> LaTeX -- ^ seperator (beginning of first line) -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) -ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ +ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ where + do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> + [ ( decltt leader + , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode) + <+> ppLType unicode ltype + ) ] + HsOuterImplicit{} -> do_largs n leader ltype + + do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)] do_largs n leader (L _ t) = do_args n leader t arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs @@ -515,12 +526,16 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = char '{' -ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX +ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode - <+> ppType unicode ty + <+> ppSigType unicode ty +ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX +ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty +ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode = + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX ppHsForAllTelescope tele unicode = case tele of @@ -635,7 +650,7 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig leader doc names (hsSigTypeI typ) unicode + vcat [ ppFunSig leader doc names typ unicode | L _ (ClassOpSig _ is_def lnames typ) <- lsigs , let doc | is_def = noDocForDecl | otherwise = lookupAnySubdoc (head names) subdocs @@ -795,7 +810,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args + PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc @@ -819,23 +834,25 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode (getGADTConType con) + , ppLSigType unicode (getGADTConType con) ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> doRecordFields fields - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) - - _ -> empty + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> doConstrArgsWithDocs [] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + _ -> empty + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> doRecordFields fields + -- H98 prefix data constructors + PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) + _ -> empty doRecordFields fields = vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl @@ -892,18 +909,16 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppLType unicode (hsSigTypeI typ) + , ppLSigType unicode typ ] fieldPart | not hasArgDocs = empty | otherwise = vcat [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r - | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) + | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode) ] - patTy = hsSigTypeI typ - mDoc = fmap _doc $ combineDocumentation doc @@ -1024,12 +1039,18 @@ ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) +ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX +ppLSigType unicode y = ppSigType unicode (unLoc y) + ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode -ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode +ppSigType :: Bool -> HsSigType DocNameI -> LaTeX +ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode + ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> @@ -1061,6 +1082,11 @@ 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 +ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode + = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode + , ppr_mono_lty ltype unicode ] + ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode @@ -1090,7 +1116,7 @@ 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 ppr_mono_ty (HsRecTy {}) _ = text "{..}" -ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys @@ -1123,6 +1149,7 @@ ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n ppr_tylit (HsStrTy _ s) _ = text (show s) +ppr_tylit (HsCharTy _ c) _ = text (show c) -- XXX: Ok in verbatim, but not otherwise -- XXX: Do something with Unicode parameter? diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index f8c22e0a..1bdbf81b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -223,10 +223,7 @@ moduleInfo iface = ("Language", lg) ] ++ extsForm where - lg inf = case hmi_language inf of - Nothing -> Nothing - Just Haskell98 -> Just "Haskell98" - Just Haskell2010 -> Just "Haskell2010" + lg inf = fmap show (hmi_language inf) multilineRow :: String -> [String] -> HtmlTable multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 0b0050df..de37e42a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -63,9 +63,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigWcType lty) fixities splice unicode pkg qual + (dropWildCards lty) fixities splice unicode pkg qual SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - (hsSigTypeI lty) fixities splice unicode pkg qual + lty fixities splice unicode pkg qual ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual InstD _ _ -> noHtml DerivD _ _ -> noHtml @@ -73,25 +73,25 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> + [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where - pp_typ = ppLType unicode qual HideEmptyContexts typ + pp_typ = ppLSigType unicode qual HideEmptyContexts typ -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -- ^ names of patterns in declaration - -> LHsType DocNameI -- ^ type of patterns in declaration + -> LHsSigType DocNameI -- ^ type of patterns in declaration -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = @@ -102,7 +102,7 @@ ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> + [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg qual emptyCtxts = @@ -119,7 +119,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) | otherwise = html <+> ppFixities fixities qual -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI -> DocForDecl DocName -> (Html, Html, Html) -> Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html @@ -140,15 +140,24 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. ppSubSigLike :: Unicode -> Qualification - -> HsType DocNameI -- ^ type signature + -> HsSigType DocNameI -- ^ type signature -> FnArgsDoc DocName -- ^ docs to add -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when -- we expand an `HsRecTy`) -> Html -> HideEmptyContexts -> [SubDecl] -ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ where + do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype + HsOuterImplicit{} -> do_largs n leader ltype + where + leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs) + argDoc n = Map.lookup n argDocs + do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl] do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] @@ -222,7 +231,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -233,13 +242,14 @@ ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode pkg qual - = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc + = ppTypeOrFunSig summary links loc [name] sig_type doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) splice unicode pkg qual ShowEmptyToplevelContexts where + sig_type = mkHsImplicitSigTypeI ltype hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppPatSigType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type) occ = nameOccName . getName $ name fixs | summary = noHtml @@ -253,15 +263,14 @@ ppTypeSig summary nms pp_ty unicode = where htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan - -> [DocName] -> HsType DocNameI + -> [DocName] -> HsSigType DocNameI -> Html ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual emptyCtxts typ + ppTyp = ppSigType unicode qual emptyCtxts typ occNames = map getOccName names @@ -301,9 +310,9 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod -- Individual equation of a closed type family ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl - ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n - , feqn_rhs = rhs - , feqn_pats = ts } }) + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing @@ -497,7 +506,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ) + [ ppFunSig summary links loc noHtml doc names typ [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -561,14 +570,14 @@ ppClassDecl summary links instances fixities loc d subdocs lookupDAT name = Map.lookup (getName name) defaultAssocTys defaultAssocTys = Map.fromList [ (getName name, (vs, typ)) - | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ - , feqn_tycon = L _ name - , feqn_pats = vs }))) <- atsDefs + | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs })) <- atsDefs ] -- Methods methodBit = subMethods - [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) + [ ppFunSig summary links loc noHtml doc [name] typ subfixs splice unicode pkg qual <+> subDefaults (maybeToList defSigs) @@ -583,7 +592,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Default methods ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") - d' [n] (hsSigTypeI t) [] splice unicode pkg qual + d' [n] t [] splice unicode pkg qual lookupDM name = Map.lookup (getOccString name) defaultMethods defaultMethods = Map.fromList @@ -709,7 +718,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification ppInstanceSigs links splice unicode qual sigs = do TypeSig _ lnames typ <- sigs let names = map unLoc lnames - L _ rtyp = hsSigWcType typ + L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp @@ -772,7 +781,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ ] | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -851,7 +860,7 @@ ppShortConstrParts summary dataInst con unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args -> + PrefixCon _ args -> ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml @@ -878,7 +887,7 @@ ppShortConstrParts summary dataInst con unicode qual -- GADT constructor, e.g. 'Foo :: Int -> Foo' ConDeclGADT {} -> - ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ] + ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ] , noHtml , noHtml ) @@ -922,7 +931,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' - PrefixCon args + PrefixCon _ args | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) @@ -947,24 +956,26 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) | otherwise -> hsep [ ppOcc , dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - , ppLType unicode qual HideEmptyContexts (getGADTConType con) + , ppLSigType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] - fieldPart = case (con, getConArgsI con) of - -- Record style GADTs - (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] - - -- Regular record declarations - (_, RecCon (L _ fields)) -> [ doRecordFields fields ] - - -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] - - -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] - - _ -> [] + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ -> [ doConstrArgsWithDocs [] ] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] + _ -> [] + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> [ doRecordFields fields ] + -- H98 prefix data constructors + PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ] + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] + _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) @@ -1049,18 +1060,17 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = | otherwise = hsep [ keyword "pattern" , ppOcc , dcolon unicode - , ppPatSigType unicode qual (hsSigTypeI typ) + , ppPatSigType unicode qual typ , fixity ] fieldPart | not hasArgDocs = [] - | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy) + | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ) argDocs [] (dcolon unicode) emptyCtxt) ] - patTy = hsSigTypeI typ - emptyCtxt = patSigContext patTy + emptyCtxt = patSigContext typ -- | Print the LHS of a data\/newtype declaration. @@ -1114,6 +1124,9 @@ ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html +ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y) + ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts @@ -1122,6 +1135,9 @@ ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts +ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html +ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts + ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> @@ -1156,18 +1172,18 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -patSigContext :: LHsType name -> HideEmptyContexts -patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts - | otherwise = HideEmptyContexts +patSigContext :: LHsSigType DocNameI -> HideEmptyContexts +patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts where - hasNonEmptyContext :: LHsType name -> Bool + typ = sig_body (unLoc sig_typ) + 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 _ -> False - isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s @@ -1178,10 +1194,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in -- the right 'HideEmptyContext' value) -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html ppPatSigType unicode qual typ = - let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ +ppHsOuterTyVarBndrs :: RenderableBndrFlag flag + => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html +ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of + HsOuterImplicit{} -> noHtml + HsOuterExplicit{hso_bndrs = bndrs} -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of @@ -1191,6 +1213,10 @@ ppForAllPart unicode qual tele = case tele of HsForAllInvis { hsf_invis_bndrs = bndrs } -> hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot +ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts + = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts + ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) @@ -1236,7 +1262,7 @@ ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (XHsType {}) _ _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys @@ -1272,3 +1298,4 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) +ppr_tylit (HsCharTy _ c) = toHtml (show c) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 980af379..10e13152 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,8 +22,9 @@ module Haddock.Convert ( #include "HsVersions.h" import GHC.Data.Bag ( emptyBag ) -import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) - , PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.SourceText (SourceText(..)) +import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.ConLike @@ -31,6 +32,7 @@ import Data.Either (lefts, rights) import GHC.Core.DataCon import GHC.Core.FamInstEnv import GHC.Hs +import GHC.Types.TyThing import GHC.Types.Name import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual ) @@ -47,7 +49,7 @@ import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey import GHC.Types.Unique ( getUnique ) import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength , filterByList, filterOut ) -import GHC.Utils.Outputable ( assertPanic ) +import GHC.Utils.Panic ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc @@ -55,7 +57,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize -import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) +import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType ) import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) @@ -90,10 +92,11 @@ tyThingToLHsDecl prr t = case t of extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" + cvt :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p) + -- Without this signature, we trigger GHC#18932 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) @@ -101,15 +104,14 @@ tyThingToLHsDecl prr t = case t of extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs = - TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd) - , hsib_body = FamEqn + TyFamInstDecl $ FamEqn { feqn_ext = noExtField , feqn_tycon = fdLName fd - , feqn_bndrs = Nothing + , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)} , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ hsq_explicit $ fdTyVars fd , feqn_fixity = fdFixity fd - , feqn_rhs = synifyType WithinType [] rhs }} + , feqn_rhs = synifyType WithinType [] rhs } extractAtItem :: ClassATItem @@ -166,14 +168,14 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) typats = map (synifyType WithinType []) args_types_only annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs - in HsIB { hsib_ext = map tyVarName tkvs - , hsib_body = FamEqn { feqn_ext = noExtField - , feqn_tycon = name - , feqn_bndrs = Nothing + outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} -- TODO: this must change eventually - , feqn_pats = map HsValArg annot_typats - , feqn_fixity = synifyFixity name - , feqn_rhs = hs_rhs } } + in FamEqn { feqn_ext = noExtField + , feqn_tycon = name + , feqn_bndrs = outer_bndrs + , feqn_pats = map HsValArg annot_typats + , feqn_fixity = synifyFixity name + , feqn_rhs = hs_rhs } where args_poly = tyConArgsPolyKinded tc @@ -227,7 +229,7 @@ synifyTyCon prr _coax tc | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc) - tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind + tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind synifyTyCon _prr _coax tc | Just flav <- famTyConFlav_maybe tc @@ -367,6 +369,12 @@ synifyDataCon use_gadt_syntax dc = (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors + outer_bndrs | null user_tvbndrs + = HsOuterImplicit { hso_ximplicit = [] } + | otherwise + = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = map synifyTyVarBndr user_tvbndrs } + -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing | otherwise = Just $ synifyCtx theta @@ -383,34 +391,43 @@ synifyDataCon use_gadt_syntax dc = con_decl_field fl synTy = noLoc $ ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing - 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 (map hsUnrestricted linear_tys) - (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) - _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn) + mk_h98_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 noTypeArgs (map hsUnrestricted linear_tys) + (False,True) -> case linear_tys of + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) + _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn + mk_gadt_arg_tys + | use_named_field_syntax = RecConGADT (noLoc field_tys) + | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) + -- finally we get synifyDataCon's result! - in hs_arg_tys >>= - \hat -> - if use_gadt_syntax - then return $ noLoc $ - ConDeclGADT { con_g_ext = [] - , con_names = [name] - , 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 - , con_doc = Nothing } - else return $ noLoc $ - ConDeclH98 { con_ext = noExtField - , con_name = name - , con_forall = noLoc False - , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs - , con_mb_cxt = ctx - , con_args = hat - , con_doc = Nothing } + in if use_gadt_syntax + then do + let hat = mk_gadt_arg_tys + return $ noLoc $ ConDeclGADT + { con_g_ext = noExtField + , con_names = [name] + , con_bndrs = noLoc outer_bndrs + , con_mb_cxt = ctx + , con_g_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } + else do + hat <- mk_h98_arg_tys + return $ noLoc $ ConDeclH98 + { con_ext = noExtField + , con_name = name + , con_forall = noLoc False + , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) @@ -526,17 +543,17 @@ data SynifyTypeState synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn --- The empty binders is a bit suspicious; --- what if the type has free variables? -synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) +-- The use of mkEmptySigType (which uses empty binders in OuterImplicit) +-- is a bit suspicious; what if the type has free variables? +synifySigType s vs ty = mkEmptySigType (synifyType s vs ty) synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) -synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) +synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps) -- | Depending on the first argument, try to default all type variables of kind -- 'RuntimeRep' to 'LiftedType'. @@ -566,8 +583,8 @@ synifyType _ vs (TyConApp tc tys) , tyConArity tc == tys_len = noLoc $ HsTupleTy noExtField (case sort of - BoxedTuple -> HsBoxedTuple - ConstraintTuple -> HsConstraintTuple + BoxedTuple -> HsBoxedOrConstraintTuple + ConstraintTuple -> HsBoxedOrConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType vs) vis_tys) | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys) @@ -804,6 +821,7 @@ synifyPatSynType ps = synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s +synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType [] k diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 10725ee5..546e2941 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -26,14 +29,14 @@ import Data.Maybe ( mapMaybe ) import Haddock.Types( DocName, DocNameI ) import GHC.Utils.FV as FV -import GHC.Utils.Outputable ( Outputable, panic, showPpr ) -import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Utils.Outputable ( Outputable ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module -import GHC.Driver.Types import GHC -import GHC.Core.Class import GHC.Driver.Session +import GHC.Types.Basic import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder , tyVarKind, updateTyVarKind, isInvisibleArgFlag ) @@ -51,6 +54,8 @@ import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS +import GHC.HsToCore.Docs + moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -90,25 +95,12 @@ ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [IdP name] +sigName :: LSig GhcRn -> [IdP GhcRn] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [IdP name] -sigNameNoLoc (TypeSig _ ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns -sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] -sigNameNoLoc (InlineSig _ n _) = [unLoc n] -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns -sigNameNoLoc _ = [] - -- | Was this signature given by the user? -isUserLSig :: LSig name -> Bool -isUserLSig (L _ (TypeSig {})) = True -isUserLSig (L _ (ClassOpSig {})) = True -isUserLSig (L _ (PatSynSig {})) = True -isUserLSig _ = False - +isUserLSig :: forall p. UnXRec p => LSig p -> Bool +isUserLSig = isUserSig . unXRec @p isClassD :: HsDecl a -> Bool isClassD (TyClD _ d) = isClassDecl d @@ -123,10 +115,10 @@ pretty = showPpr -- instantiated at DocNameI instead of (GhcPass _). -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) -hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n -hsTyVarBndrName (UserTyVar _ _ name) = unLoc name -hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name -hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec +hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n) + => HsTyVarBndr flag n -> IdP n +hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name +hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName hsTyVarNameI (UserTyVar _ _ (L _ n)) = n @@ -139,33 +131,45 @@ getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names -hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing -hsImplicitBodyI (HsIB { hsib_body = body }) = body - hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI -hsSigTypeI = hsImplicitBodyI +hsSigTypeI = sig_body . unLoc + +mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigType lty@(L loc ty) = L loc $ case ty of + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = body } + -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = bndrs } + , sig_body = body } + _ -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = []} + , sig_body = lty } 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 +mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI +mkHsImplicitSigTypeI body = + HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField} + , sig_body = body } -getGADTConType :: ConDecl DocNameI -> LHsType DocNameI +getGADTConType :: ConDecl DocNameI -> LHsSigType 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 -- we are cavalier about locations and extensions, hence the -- 'undefined's -getGADTConType (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args +getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs + , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTeleI qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty + = noLoc (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) @@ -174,9 +178,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall -- tau_ty :: LHsType DocNameI tau_ty = case args of - 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) + RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) @@ -186,7 +189,7 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType" getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d] getMainDeclBinderI (ValD _ d) = - case collectHsBindBinders d of + case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] getMainDeclBinderI (SigD _ d) = sigNameNoLoc d @@ -206,73 +209,33 @@ tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI --- ------------------------------------- - -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 --- 'undefined's -getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall - , con_qvars = qtvs - , con_mb_cxt = mcxt, con_args = args - , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField - , hst_tele = mkHsForAllInvisTele qtvs - , hst_body = theta_ty }) - | otherwise = theta_ty - where - theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) - | otherwise - = tau_ty - --- tau_ty :: LHsType DocNameI - tau_ty = case args of - 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 :: 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 - - -mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn --- Dubious, because the implicit binders are empty even --- though the type might have free varaiables -mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) - - addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious + = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) where - 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 })) + go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty })) + = L loc (HsSig { sig_ext = noExtField + , sig_bndrs = bndrs, sig_body = go_ty ty }) + + go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) + = L loc (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele, hst_body = go_ty ty }) + go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) + go_ty (L loc ty) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - extra_pred :: LHsType GhcRn - extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0)) - - add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn + extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) add_ctxt (L loc preds) = L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) + = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -280,7 +243,6 @@ lHsQTyVarsToTypes tvs -- * Making abstract declarations -------------------------------------------------------------------------------- - restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of TyClD x d | isDataDecl d -> @@ -303,17 +265,27 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where - keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case con_args d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unLoc fields) -> Just d - | 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 - -- it's the best we can do. - InfixCon _ _ -> Just d + keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn) + keep d + | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case d of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon {} -> Just d + RecCon fields + | all field_avail (unLoc fields) -> Just d + | 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 + -- it's the best we can do. + InfixCon _ _ -> Just d + + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT {} -> Just d + RecConGADT fields + | all field_avail (unLoc fields) -> Just d + | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) }) + -- see above where field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) @@ -358,17 +330,19 @@ data Precedence -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(. -reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a +reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => Precedence -> HsType a -> HsType a reparenTypePrec = go where -- Shorter name for 'reparenType' - go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a + go :: Precedence -> HsType a -> HsType a go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) go _ (HsListTy x ty) = HsListTy x (reparenLType ty) - go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds) + go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds) go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) @@ -381,7 +355,8 @@ reparenTypePrec = go 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) + ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt + in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) 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) @@ -390,7 +365,7 @@ reparenTypePrec = go = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) go p (HsOpTy x ty1 op ty2) = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) - go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed + go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed go _ t@HsTyVar{} = t go _ t@HsStarTy{} = t go _ t@HsSpliceTy{} = t @@ -399,43 +374,68 @@ reparenTypePrec = go go _ t@XHsType{} = t -- Located variant of 'go' - goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a - goL ctxt_prec = fmap (go ctxt_prec) + goL :: Precedence -> LHsType a -> LHsType a + goL ctxt_prec = mapXRec @a (go ctxt_prec) -- Optionally wrap a type in parens - paren :: (XParTy a ~ NoExtField) - => Precedence -- Precedence of context + paren :: Precedence -- Precedence of context -> Precedence -- Precedence of top-level operator -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) - paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a | otherwise = id -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a +reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a -reparenLType = fmap reparenType +reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => LHsType a -> LHsType a +reparenLType = mapXRec @a reparenType + +-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec') +reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsSigType a -> HsSigType a +reparenSigType (HsSig x bndrs body) = + HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body) +reparenSigType v@XHsSigType{} = v + +-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec') +reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a +reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp +reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs) +reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -reparenHsForAllTelescope :: (XParTy a ~ NoExtField) +reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) = - HsForAllVis x (map (fmap reparenTyVar) bndrs) + HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope (HsForAllInvis x bndrs) = - HsForAllInvis x (map (fmap reparenTyVar) bndrs) + HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope v@XHsForAllTelescope{} = v -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => 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') -reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a +reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a + , MapXRec a, UnXRec a, WrapXRec a ) + => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c @@ -471,10 +471,9 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = - case con_args con of - RecCon fields -> map (extFieldOcc . unLoc) $ - concatMap (cd_fld_names . unLoc) (unLoc fields) - _ -> [] + case getRecConArgs_maybe con of + Nothing -> [] + Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) instance Parent (TyClDecl GhcRn) where children d @@ -526,14 +525,6 @@ modifySessionDynFlags f = do return () --- 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 ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index b68cc4a9..f1403def 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} +{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface @@ -29,7 +29,8 @@ -- using this environment. ----------------------------------------------------------------------------- module Haddock.Interface ( - processModules + plugin + , processModules ) where @@ -43,26 +44,34 @@ import Haddock.Types import Haddock.Utils import Control.Monad -import Control.Monad.IO.Class ( liftIO ) -import Control.Exception (evaluate) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Data.IORef import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map import qualified Data.Set as Set import Text.Printf import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Types import GHC.Data.Graph.Directed import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) -import GHC.Driver.Types +import GHC.Driver.Env +import GHC.Driver.Monad (Session(..), modifySession, reflectGhc) import GHC.Data.FastString (unpackFS) -import GHC.Tc.Types (tcg_rdr_env) +import GHC.Tc.Types (TcM, TcGblEnv(..)) +import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) +import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts) +import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts) import GHC.Utils.Error (withTimingD) import GHC.HsToCore.Docs import GHC.Runtime.Loader (initializePlugins) +import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..), + defaultPlugin, keepRenamedSource) #if defined(mingw32_HOST_OS) import System.IO @@ -88,8 +97,14 @@ processModules verbosity modules flags extIfaces = do #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 = @@ -125,98 +140,202 @@ processModules verbosity modules flags extIfaces = do 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 + , hsc_static_plugins = + haddockPlugin : hsc_static_plugins 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. - - -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) ++ "..." - - -- 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' } - - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum' - - case isBootSummary modsum of - IsBoot -> - return Nothing - NotBoot -> do - out verbosity verbose "Creating interface..." - (interface, msgs) <- {-# SCC createIterface #-} - withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface tm flags modMap instIfaceMap - - -- 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 = homeUnit (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 - - 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) ++ ")" - _ -> "" - - 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 - interface' <- liftIO $ evaluate interface - return (Just (interface', mods)) + 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 + + let + ifaces :: [Interface] + ifaces = + [ Map.findWithDefault + (error "haddock:iface") + (ms_mod (emsModSummary ems)) + ifaceMap + | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing + ] + + return (ifaces, moduleSet) + + +-- | 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 + + 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 + hsc_env <- getTopEnv + ifaces <- liftIO $ readIORef ifaceMapRef + (iface, modules) <- withTimingD "processModule" (const ()) $ + processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env + + liftIO $ do + atomicModifyIORef' ifaceMapRef $ \xs -> + (Map.insert (ms_mod mod_summary) iface xs, ()) + + atomicModifyIORef' moduleSetRef $ \xs -> + (modules `unionModuleSet` xs, ()) + + 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 + -> HscEnv + -> ModSummary + -> TcGblEnv + -> TcM (Interface, ModuleSet) +processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do + out verbosity verbose "Creating interface..." + + let + TcGblEnv { tcg_rdr_env } = tc_gbl_env + + unit_state = hsc_units hsc_env + + (!interface, messages) <- {-# SCC createInterface #-} + withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ + createInterface1 flags unit_state 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. + let + mods :: ModuleSet + !mods = mkModuleSet + [ nameModule name + | gre <- globalRdrEnvElts tcg_rdr_env + , let name = greMangledName gre + , nameIsFromExternalPackage (hsc_home_unit hsc_env) name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre -- In scope unqualified + ] + + liftIO $ mapM_ putStrLn (nub messages) + dflags <- getDynFlags + + let + (haddockable, haddocked) = + ifaceHaddockCoverage interface + + percentage :: Int + percentage = div (haddocked * 100) haddockable + + 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) -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c4988480..9a773b6c 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -18,234 +20,321 @@ -- 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.Types hiding (liftErrMsg) import Haddock.Options import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn -import Data.Bifunctor +import Control.Monad.Reader +import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable import qualified Data.Map as M -import qualified Data.Set as S import Data.Map (Map) -import Data.List (find, foldl') +import Data.List import Data.Maybe -import Control.Monad import Data.Traversable -import GHC.Stack (HasCallStack) +import GHC.Stack +import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import qualified GHC.Unit.Module as Module +import GHC.Unit.Module.ModSummary import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.SourceFile +import GHC.Core.Class import GHC.Core.ConLike (ConLike(..)) -import GHC -import GHC.Driver.Types +import GHC hiding (lookupName) +import GHC.Driver.Ppr import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Unit.State import GHC.Types.Name.Reader -import GHC.Tc.Types +import GHC.Tc.Types hiding (IfM) import GHC.Data.FastString ( unpackFS, bytesFS ) -import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) +import GHC.Types.Basic ( PromotionFlag(..) ) +import GHC.Types.SourceText import qualified GHC.Utils.Outputable as O +import GHC.Utils.Panic import GHC.HsToCore.Docs hiding (mkMaps) import GHC.Parser.Annotation (IsUnicodeSyntax(..)) +import GHC.Unit.Module.Warnings -mkExceptionContext :: TypecheckedModule -> String -mkExceptionContext = - ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module - --- | 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 - - (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." ] - - -- 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 - - opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl +newtype IfEnv m = IfEnv + { + -- | Lookup names in the enviroment. + ife_lookup_name :: Name -> m (Maybe TyThing) + } + + +-- | 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 } + + +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) + + +-- | 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) + + +liftErrMsg :: Monad m => ErrMsgM a -> IfM m a +liftErrMsg action = do + writer (runWriter action) + + +lookupName :: Monad m => Name -> IfM m (Maybe TyThing) +lookupName name = IfM $ do + lookup_name <- asks ife_lookup_name + lift $ lift (lookup_name name) + + +createInterface1 + :: MonadIO m + => [Flag] + -> UnitState + -> ModSummary + -> TcGblEnv + -> IfaceMap + -> InstIfaceMap + -> IfM m Interface +createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do + + 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 + + TcGblEnv + { + tcg_mod + , tcg_src + , tcg_semantic_mod + , tcg_rdr_env + , tcg_exports + , tcg_insts + , tcg_fam_insts + , tcg_warns + + -- Renamed source + , tcg_rn_imports + , tcg_rn_exports + , tcg_rn_decls + + , tcg_doc_hdr + } = tc_gbl_env + + dflags = ms_hspp_opts + + is_sig = tcg_src == HsigFile + + (pkg_name_fs, _) = + modulePackageInfo unit_state flags (Just tcg_mod) + + pkg_name :: Maybe Package + pkg_name = + let + unpack (PackageName name) = unpackFS name + in + fmap unpack pkg_name_fs + + 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. + exported_names :: [Name] + exported_names = + concatMap availNamesWithSelectors tcg_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, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader - - let declsWithDocs = topDecls group_ - - exports0 = fmap (map (first unLoc)) mayExports - (all_exports, exports) - | OptIgnoreExports `elem` opts = (all_local_avails, Nothing) - | otherwise = (all_exports0, exports0) - - 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 ] - - warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) - - maps@(!docMap, !argMap, !declMap, _) <- - liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs) - - let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - - -- 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 - - let !visibleNames = mkVisibleNames maps exportItems opts - - -- 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) - - -- 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' - - let !aliases = - mkAliasMap (unitState dflags) $ tm_renamed_source tm - - modWarn <- liftErrMsg (moduleWarning dflags gre warnings) - - -- 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 - - 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 - } + (!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 tcg_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 unit_state 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 :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap state mRenamedSource = - case mRenamedSource of - Nothing -> M.empty - Just (_,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 +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 @@ -257,7 +346,7 @@ mkAliasMap state mRenamedSource = -- -- With our mapping we know that we can display exported modules M1 and M2. -- -unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName] unrestrictedModuleImports idecls = M.map (map (unLoc . ideclName)) $ M.filter (all isInteresting) impModMap @@ -306,7 +395,7 @@ mkWarningMap dflags warnings gre exps = case warnings of let ws' = [ (n, w) | (occ, w) <- ws , elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] + , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) @@ -436,7 +525,7 @@ mkMaps dflags pkgName gre instances decls = do -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and -- get the identifier with the right location. - TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d')) + TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -470,7 +559,7 @@ mkFixMap group_ = -- 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 @@ -488,7 +577,7 @@ mkExportItems -> 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 @@ -509,7 +598,7 @@ mkExportItems return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $ - findNamedDoc str [ unLoc d | d <- decls ] >>= \case + findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags pkgName gre docStr @@ -530,25 +619,39 @@ mkExportItems 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 @@ -558,13 +661,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unLoc decl) + let declNames = getMainDeclBinder (unL decl) in case () of _ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, - Just p <- find isExported (parents t $ unLoc decl) -> + Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++ @@ -584,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD _ cl@ClassDecl{}) -> do - mdef <- liftGhcToErrMsgGhc $ minimalDef t + L loc (TyClD _ ClassDecl {..}) -> do + 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_ + (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ _ -> availExportDecl avail decl docs_ @@ -614,7 +717,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames _ -> 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 @@ -622,11 +725,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames synifiedDeclOpt <- hiDecl dflags declName case synifiedDeclOpt of Just synifiedDecl -> pure synifiedDecl - Nothing -> O.pprPanic "availExportItem" (O.text err) + Nothing -> pprPanic "availExportItem" (O.text err) 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 @@ -672,7 +775,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames 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 @@ -701,10 +804,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames 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) @@ -720,16 +823,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames constructor_names = filter isDataConName (availSubordinates avail) --- this heavily depends on the invariants stated in Avail -availExportsDecl :: AvailInfo -> Bool -availExportsDecl (AvailTC ty_name names _) - | n : _ <- names = ty_name == n - | otherwise = False -availExportsDecl _ = True - availSubordinates :: AvailInfo -> [Name] -availSubordinates avail = - filter (/= availName avail) (availNamesWithSelectors avail) +availSubordinates = map greNameMangledName . availSubordinateGreNames availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] availNoDocs avail = @@ -742,10 +837,9 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName 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] @@ -758,14 +852,15 @@ hiDecl dflags t = do warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> O.comma O.<+> O.quotes (O.ppr t) O.<+> O.text "-- Please report this on Haddock issue tracker!" - bugWarn = O.showSDoc dflags . warnLine + bugWarn = showSDoc dflags . warnLine -- | This function is called for top-level bindings without type signatures. -- 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 @@ -795,12 +890,14 @@ lookupDocs avail warnings docMap argMap = -- | 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. @@ -814,9 +911,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = 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 (moduleUnit thisMod) expMod -- Identity module! @@ -842,22 +938,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- 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) @@ -870,7 +968,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) - | name:_ <- collectHsBindBinders valDecl + | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ -> @@ -885,7 +983,6 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam isSigD (L _ SigD{}) = True isSigD _ = False - -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble @@ -936,7 +1033,7 @@ extractDecl declMap name decl TyClD _ d@DataDecl { tcdLName = L _ dataNm , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do - let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d)) + let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d) lsig <- if isDataConName name then extractPatternSyn name dataNm ty_args dataCons else extractRecSel name dataNm ty_args dataCons @@ -946,30 +1043,26 @@ extractDecl declMap name decl | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_tycon = L _ famName - , feqn_pats = ty_args - , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do - lsig <- if isDataConName name - then extractPatternSyn name famName ty_args dataCons - else extractRecSel name famName ty_args dataCons - pure (SigD noExtField <$> lsig) + InstD _ (DataFamInstD _ (DataFamInstDecl + (FamEqn { feqn_tycon = L _ n + , feqn_pats = tys + , feqn_rhs = defn }))) -> + if isDataConName name + then fmap (SigD noExtField) <$> extractPatternSyn name n tys (dd_cons defn) + else fmap (SigD noExtField) <$> extractRecSel name n tys (dd_cons defn) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons } - } - })) <- insts - , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons) + let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts + , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) _ -> Left "internal: extractDecl (ClsInstD)" | otherwise -> - let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + let matches = [ d' | L _ d'@(DataFamInstDecl d ) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) + , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , extFieldOcc n == name @@ -979,10 +1072,13 @@ extractDecl declMap name decl _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) +extractPatternSyn :: HasCallStack + => Name -> Name + -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] + -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of - [] -> Left . O.showSDocUnsafe $ + [] -> Left . O.showSDocOneLine O.defaultSDocContext $ O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t con:_ -> pure (extract <$> con) where @@ -991,17 +1087,21 @@ extractPatternSyn nm t tvs cons = extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = - case getConArgs con of - PrefixCon args' -> (map hsScaledThing args') - RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields - InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + case con of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon _ args' -> map hsScaledThing args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT args' -> map hsScaledThing args' + RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) _ -> typ typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') - in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') + in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs @@ -1019,9 +1119,9 @@ extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" 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 (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) + case getRecConArgs_maybe con of + Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> + pure (L l (TypeSig noExtField [noLoc nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 95889a63..92fb2e75 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -5,7 +5,7 @@ module Haddock.Interface.Json ( , renderJson ) where -import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Utils.Json import GHC.Unit.Module import GHC.Types.Name diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 87210273..6da89e7c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -21,8 +22,8 @@ module Haddock.Interface.LexParseRn import Control.Arrow import Control.Monad -import Data.Functor (($>)) -import Data.List (maximumBy, (\\)) +import Data.Functor +import Data.List ((\\), maximumBy) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions) @@ -32,8 +33,9 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types import GHC.Types.Name +import GHC.Types.Avail ( availName ) import GHC.Parser.PostProcess -import GHC.Utils.Outputable ( showPpr, showSDoc ) +import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet @@ -134,7 +136,7 @@ rename dflags gre = rn -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (i $> gre_name a)) + [a] -> pure $ DocIdentifier (i $> greMangledName a) -- There are multiple names available. gres -> ambiguous dflags i gres @@ -199,9 +201,10 @@ ambiguous :: DynFlags -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do - let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres + let noChildren = map availName (gresToAvailInfo gres) + dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to the one defined " ++ defnLoc dflt @@ -210,10 +213,12 @@ ambiguous dflags x gres = do -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. - when (length (gresToAvailInfo gres) > 1) $ tell [msg] - pure (DocIdentifier (x $> gre_name dflt)) + when (length noChildren > 1) $ tell [msg] + pure (DocIdentifier (x $> dflt)) where - defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name + isLocalName (nameSrcLoc -> RealSrcLoc {}) = True + isLocalName _ = False + defnLoc = showSDoc dflags . pprNameDefnLoc -- | Handle value-namespaced names that cannot be for values. -- diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index bb9cd02d..b212adce 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -213,10 +213,10 @@ renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) -renameLSigType = renameImplicit renameLType +renameLSigType = mapM renameSigType renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) -renameLSigWcType = renameWc (renameImplicit renameLType) +renameLSigWcType = renameWc renameLSigType renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType @@ -310,12 +310,18 @@ renameType t = case t of HsTyLit _ x -> return (HsTyLit noExtField x) HsRecTy _ a -> HsRecTy noExtField <$> mapM renameConDeclFieldField a - (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) + XHsType a -> pure (XHsType a) HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy a -> pure (HsWildCardTy a) +renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) +renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do + bndrs' <- renameOuterTyVarBndrs bndrs + body' <- renameLType body + pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' } + -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: -- @@ -496,46 +502,55 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_mb_cxt = lcontext, con_args = details - , con_doc = mbldoc }) = do + , con_doc = mbldoc + , con_forall = forall }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameH98Details details mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' + , con_forall = forall -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) -renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars - , con_mb_cxt = lcontext, con_args = details +renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs + , con_mb_cxt = lcontext, con_g_args = details , con_res_ty = res_ty - , con_doc = mbldoc }) = do + , con_doc = mbldoc } = do lnames' <- mapM renameL lnames - ltyvars' <- mapM renameLTyVarBndr ltyvars + bndrs' <- mapM renameOuterTyVarBndrs bndrs lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameGADTDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' - , con_mb_cxt = lcontext', con_args = details' + return (ConDeclGADT + { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs' + , con_mb_cxt = lcontext', con_g_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) 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 +renameH98Details :: HsConDeclH98Details GhcRn + -> RnM (HsConDeclH98Details DocNameI) +renameH98Details (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields')) - -- 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 +renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps +renameH98Details (InfixCon a b) = do a' <- renameHsScaled a b' <- renameHsScaled b return (InfixCon a' b') +renameGADTDetails :: HsConDeclGADTDetails GhcRn + -> RnM (HsConDeclGADTDetails DocNameI) +renameGADTDetails (RecConGADT (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecConGADT (L l fields')) +renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps + renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names @@ -630,32 +645,26 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) ; return (TyFamInstDecl { tfid_eqn = eqn' }) } renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) -renameTyFamInstEqn eqn - = renameImplicit rename_ty_fam_eqn eqn - where - rename_ty_fam_eqn - :: FamEqn GhcRn (LHsType GhcRn) - -> RnM (FamEqn DocNameI (LHsType DocNameI)) - rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs - , feqn_pats = pats, feqn_fixity = fixity - , feqn_rhs = rhs }) - = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs - ; pats' <- mapM renameLTypeArg pats - ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_ext = noExtField - , feqn_tycon = tc' - , feqn_bndrs = bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = rhs' }) } +renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) + = do { tc' <- renameL tc + ; bndrs' <- renameOuterTyVarBndrs bndrs + ; pats' <- mapM renameLTypeArg pats + ; rhs' <- renameLType rhs + ; return (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) - = do { eqn' <- renameImplicit rename_data_fam_eqn eqn + = do { eqn' <- rename_data_fam_eqn eqn ; return (DataFamInstDecl { dfid_eqn = eqn' }) } where rename_data_fam_eqn @@ -665,7 +674,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_pats = pats, feqn_fixity = fixity , feqn_rhs = defn }) = do { tc' <- renameL tc - ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; bndrs' <- renameOuterTyVarBndrs bndrs ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExtField @@ -675,13 +684,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_fixity = fixity , feqn_rhs = defn' }) } -renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs GhcRn in_thing - -> RnM (HsImplicitBndrs DocNameI out_thing) -renameImplicit rn_thing (HsIB { hsib_body = thing }) - = do { thing' <- rn_thing thing - ; return (HsIB { hsib_body = thing' - , hsib_ext = noExtField }) } +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> RnM (HsOuterTyVarBndrs flag DocNameI) +renameOuterTyVarBndrs (HsOuterImplicit{}) = + pure $ HsOuterImplicit{hso_ximplicit = noExtField} +renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) = + HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index ad2f61c2..f37e1da9 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize @@ -38,7 +39,7 @@ specialize specs = go spec_map0 go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map - strip_kind_sig :: HsType name -> HsType name + strip_kind_sig :: HsType GhcRn -> HsType GhcRn strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ @@ -57,7 +58,7 @@ specialize specs = go spec_map0 -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn +specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs @@ -74,13 +75,13 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) = - TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) + TypeSig noExtField lnames (typ {hswc_body = noLoc typ'}) where - true_type :: HsType GhcRn - true_type = unLoc (hsSigWcType typ) - typ' :: HsType GhcRn + true_type :: HsSigType GhcRn + true_type = unLoc (dropWildCards typ) + typ' :: HsSigType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type - fv = foldr Set.union Set.empty . map freeVariables $ typs + fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig @@ -121,7 +122,7 @@ sugarTuples typ = aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy _ (L _ typ')) = aux apps typ' aux apps (HsTyVar _ _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedOrConstraintTuple apps where name' = getName name strName = getOccString name @@ -176,19 +177,25 @@ parseTupleArity _ = Nothing -- not converted to 'String' or alike to avoid new allocations. Additionally, -- since it is stored mostly in 'Set', fast comparison of 'FastString' is also -- quite nice. -type NameRep = FastString +newtype NameRep + = NameRep FastString + deriving (Eq) + +instance Ord NameRep where + compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2 + getNameRep :: NamedThing name => name -> NameRep -getNameRep = getOccFS +getNameRep = NameRep . getOccFS nameRepString :: NameRep -> String -nameRepString = unpackFS +nameRepString (NameRep fs) = unpackFS fs stringNameRep :: String -> NameRep -stringNameRep = mkFastString +stringNameRep = NameRep . mkFastString setInternalNameRep :: SetName name => NameRep -> name -> name -setInternalNameRep = setInternalOccName . mkVarOccFS +setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs) setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name = @@ -198,23 +205,37 @@ setInternalOccName occ name = nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) --- | Compute set of free variables of given type. -freeVariables :: HsType GhcRn -> Set Name -freeVariables = - everythingWithState Set.empty Set.union query +-- | Compute set of free variables of a given 'HsType'. +freeVariablesType :: HsType GhcRn -> Set Name +freeVariablesType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType) + +-- | Compute set of free variables of a given 'HsType'. +freeVariablesSigType :: HsSigType GhcRn -> Set Name +freeVariablesSigType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType) + +queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name) +queryType term ctx = case term of + HsForAllTy _ tele _ -> + (Set.empty, Set.union ctx (teleNames tele)) + HsTyVar _ _ (L _ name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) + _ -> (Set.empty, ctx) where - query term ctx = case cast term :: Maybe (HsType GhcRn) of - 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 :: HsForAllTelescope GhcRn -> Set Name teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs - bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) +querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name) +querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx = + (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) + +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name +bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) -- | Make given type visually unambiguous. @@ -225,12 +246,12 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: Set Name -> HsType GhcRn -> HsType GhcRn -rename fv typ = evalState (renameType typ) env +rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn +rename fv typ = evalState (renameSigType typ) env where env = RenameEnv { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv - , rneSigFVs = Set.map getNameRep $ freeVariables typ + , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ , rneCtx = Map.empty } mkPair name = (getNameRep name, name) @@ -245,6 +266,17 @@ data RenameEnv name = RenameEnv } +renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn) +renameSigType (HsSig x bndrs body) = + HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body + +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn) +renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) = + HsOuterImplicit <$> mapM renameName imp_tvs +renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x <$> mapM renameLBinder exp_bndrs + renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) renameType (HsForAllTy x tele lt) = HsForAllTy x @@ -271,7 +303,7 @@ renameType t@(HsSpliceTy _ _) = pure t renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt renameType t@(HsRecTy _ _) = pure t -renameType t@(XHsType (NHsCoreTy _)) = pure t +renameType t@(XHsType _) = pure t renameType (HsExplicitListTy x ip ltys) = HsExplicitListTy x ip <$> renameLTypes ltys renameType (HsExplicitTupleTy x ltys) = @@ -362,3 +394,8 @@ alternativeNames name = located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e + + +tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn +tyVarName (UserTyVar _ _ name) = unLoc name +tyVarName (KindedTyVar _ _ (L _ name) _) = name diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 69201eb0..95bfc903 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -38,7 +38,7 @@ import GHC.Data.FastMutInt import GHC.Data.FastString import GHC hiding (NoLink) import GHC.Driver.Monad (withSession) -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Types.Name.Cache import GHC.Iface.Env import GHC.Types.Name @@ -94,7 +94,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) +#if MIN_VERSION_ghc(9,1,0) && !MIN_VERSION_ghc(9,2,0) binaryInterfaceVersion = 38 binaryInterfaceVersionCompatibility :: [Word16] diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 0b886d1a..4d22505f 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -24,6 +24,7 @@ module Haddock.Options ( optSourceCssFile, sourceUrls, wikiUrls, + optParCount, optDumpInterfaceFile, optShowInterfaceFile, optLaTeXStyle, @@ -45,10 +46,10 @@ import qualified Data.Char as Char import Data.Version import Control.Applicative import GHC.Data.FastString -import GHC ( DynFlags, Module, moduleUnit, unitState ) +import GHC ( Module, moduleUnit ) +import GHC.Unit.State import Haddock.Types import Haddock.Utils -import GHC.Unit.State import System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP @@ -110,6 +111,7 @@ data Flag | Flag_Reexport String | Flag_SinceQualification String | Flag_IgnoreLinkSymbol String + | Flag_ParCount (Maybe Int) deriving (Eq, Show) @@ -223,7 +225,9 @@ options backwardsCompat = 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 +310,11 @@ optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ] 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 = @@ -375,16 +380,16 @@ optLast xs = Just (last xs) -- -- The @--package-name@ and @--package-version@ Haddock flags allow the user to -- specify this information manually and it is returned here if present. -modulePackageInfo :: DynFlags +modulePackageInfo :: UnitState -> [Flag] -- ^ Haddock flags are checked as they may contain -- the package name or version provided by the user -- which we prioritise -> Maybe Module -> (Maybe PackageName, Maybe Data.Version.Version) -modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) -modulePackageInfo dflags flags (Just modu) = +modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing) +modulePackageInfo unit_state flags (Just modu) = ( optPackageName flags <|> fmap unitPackageName pkgDb , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where - pkgDb = lookupUnit (unitState dflags) (moduleUnit modu) + pkgDb = lookupUnit unit_state (moduleUnit modu) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index e335ee19..ab2fa549 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -19,8 +19,9 @@ import Documentation.Haddock.Types import Haddock.Types import GHC.Driver.Session ( DynFlags ) +import GHC.Driver.Config import GHC.Data.FastString ( fsLit ) -import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) ) +import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) import GHC.Parser ( parseIdentifier ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name.Reader ( RdrName(..) ) @@ -48,7 +49,7 @@ parseIdent dflags ns str0 = PFailed{} -> Nothing where realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0 - pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc + pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc (wrap,str1) = case str0 of '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names -> (Parenthesized, init s) diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 7e34ae8c..fc946c8e 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -6,7 +6,7 @@ module Haddock.Syb ( everything, everythingButType, everythingWithState , everywhere, everywhereButType - , mkT + , mkT, mkQ, extQ , combine ) where @@ -91,6 +91,21 @@ mkT f = case cast f of Just f' -> f' Nothing -> id +-- | Create generic query. +-- +-- Another function stolen from SYB package. +mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + +-- | Extend a generic query by a type-specific case. +-- +-- Another function stolen from SYB package. +extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q +extQ f g a = maybe (f a) g (cast a) + -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 53d01565..83c9dd72 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -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,20 +28,24 @@ module Haddock.Types ( , HsDocString, LHsDocString , Fixity(..) , module Documentation.Haddock.Types + + -- $ Reexports + , runWriter + , tell ) where -import Control.Arrow hiding ((<+>)) import Control.DeepSeq import Control.Exception (throw) -import Control.Monad (ap) 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 GHC.Types.Basic (Fixity(..), PromotionFlag(..)) +import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Types.Fixity (Fixity(..)) import GHC import GHC.Driver.Session (Language) @@ -305,10 +312,12 @@ data DocName data DocNameI +type instance NoGhcTc DocNameI = DocNameI + type instance IdP DocNameI = DocName instance CollectPass DocNameI where - collectXXPat _ ext = noExtCon ext + collectXXPat _ _ ext = noExtCon ext instance NamedThing DocName where getName (Documented name _) = name @@ -628,26 +637,7 @@ data SinceQual 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 @@ -681,46 +671,36 @@ withExceptionContext ctxt = -- @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)) - -instance MonadThrow ErrMsgGhc where - throwM e = WriterGhc (throwM e) +liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a +liftGhcToErrMsgGhc = ErrMsgGhc . lift -instance MonadCatch ErrMsgGhc where - catch (WriterGhc m) f = WriterGhc (catch m (runWriterGhc . f)) +liftErrMsg :: ErrMsgM a -> ErrMsgGhc a +liftErrMsg = writer . runWriter ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance XRec DocNameI f = Located (f DocNameI) +type instance XRec DocNameI a = Located a +instance UnXRec DocNameI where + unXRec = unLoc +instance MapXRec DocNameI where + mapXRec = fmap +instance WrapXRec DocNameI where + wrapXRec = noLoc type instance XForAllTy DocNameI = NoExtField type instance XQualTy DocNameI = NoExtField @@ -744,7 +724,7 @@ type instance XExplicitListTy DocNameI = NoExtField type instance XExplicitTupleTy DocNameI = NoExtField type instance XTyLit DocNameI = NoExtField type instance XWildCardTy DocNameI = NoExtField -type instance XXType DocNameI = NewHsTypeX +type instance XXType DocNameI = HsCoreTy type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField @@ -799,9 +779,14 @@ type instance XFamDecl DocNameI = NoExtField type instance XXFamilyDecl DocNameI = NoExtCon type instance XXTyClDecl DocNameI = NoExtCon -type instance XHsIB DocNameI _ = NoExtField -type instance XHsWC DocNameI _ = NoExtField -type instance XXHsImplicitBndrs DocNameI _ = NoExtCon +type instance XHsWC DocNameI _ = NoExtField + +type instance XHsOuterExplicit DocNameI _ = NoExtField +type instance XHsOuterImplicit DocNameI = NoExtField +type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon + +type instance XHsSig DocNameI = NoExtField +type instance XXHsSigType DocNameI = NoExtCon type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 0c9c6073..314b8db9 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 7b854553..490dff10 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -38,7 +38,7 @@ common lib-defaults default-language: Haskell2010 build-depends: - , base >= 4.5 && < 4.16 + , base >= 4.5 && < 4.17 , bytestring ^>= 0.9.2.1 || ^>= 0.10.0.0 , containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1 , transformers ^>= 0.3.0.0 || ^>= 0.4.1.0 || ^>= 0.5.0.0 diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index a484a8d9..df6c4474 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -1,3 +1,4 @@ +cabal-version: >= 1.10 name: haddock-test version: 0.0.1 synopsis: Test utilities for Haddock @@ -10,14 +11,13 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple tested-with: GHC==9.0.* -cabal-version: >= 1.10 stability: experimental library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - build-depends: base >= 4.3 && < 4.16, bytestring, directory, process, filepath, Cabal + build-depends: base >= 4.3 && < 4.17, bytestring, directory, process, filepath, Cabal exposed-modules: Test.Haddock diff --git a/haddock.cabal b/haddock.cabal index a24d3794..1993ead1 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -81,11 +81,12 @@ executable haddock xhtml >= 3000.2 && < 3000.3, ghc-boot, ghc-boot-th, - ghc == 9.0.*, + ghc == 9.1.*, bytestring, parsec, text, - transformers + transformers, + mtl other-modules: CompatPrelude diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html index b3bc60cc..b4ce3c88 100644 --- a/html-test/ref/Bug1004.html +++ b/html-test/ref/Bug1004.html @@ -116,12 +116,8 @@ >Type</a >)</span ></td - ><td class="doc" - ><p - ><em - >Since: base-4.9.0.0</em - ></p - ></td + ><td class="doc empty" + > </td ></tr ><tr ><td colspan="2" @@ -738,14 +734,14 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq1:8" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show1:8" ></span > (<a href="#" title="Data.Functor.Classes" - >Eq1</a + >Show1</a > f, <a href="#" title="Data.Functor.Classes" - >Eq1</a + >Show1</a > g) => <a href="#" title="Data.Functor.Classes" - >Eq1</a + >Show1</a > (<a href="#" title="Bug1004" >Product</a > f g)</span @@ -759,7 +755,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:Eq1:8" + ><details id="i:id:Product:Show1:8" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -771,67 +767,35 @@ >Methods</p ><p class="src" ><a href="#" - >liftEq</a - > :: (a -> b -> <a href="#" title="Data.Bool" - >Bool</a - >) -> <a href="#" title="Bug1004" - >Product</a - > f g a -> <a href="#" title="Bug1004" + >liftShowsPrec</a + > :: (<a href="#" title="Data.Int" + >Int</a + > -> a -> <a href="#" title="Text.Show" + >ShowS</a + >) -> ([a] -> <a href="#" title="Text.Show" + >ShowS</a + >) -> <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Bug1004" >Product</a - > f g b -> <a href="#" title="Data.Bool" - >Bool</a + > f g a -> <a href="#" title="Text.Show" + >ShowS</a > <a href="#" class="selflink" >#</a ></p - ></div - ></details - ></td - ></tr - ><tr - ><td class="src clearfix" - ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord1:9" - ></span - > (<a href="#" title="Data.Functor.Classes" - >Ord1</a - > f, <a href="#" title="Data.Functor.Classes" - >Ord1</a - > g) => <a href="#" title="Data.Functor.Classes" - >Ord1</a - > (<a href="#" title="Bug1004" - >Product</a - > f g)</span - ></td - ><td class="doc" - ><p - ><em - >Since: base-4.9.0.0</em - ></p - ></td - ></tr - ><tr - ><td colspan="2" - ><details id="i:id:Product:Ord1:9" - ><summary class="hide-when-js-enabled" - >Instance details</summary - ><p - >Defined in <a href="#" - >Data.Functor.Product</a - ></p - > <div class="subs methods" - ><p class="caption" - >Methods</p ><p class="src" ><a href="#" - >liftCompare</a - > :: (a -> b -> <a href="#" title="Data.Ord" - >Ordering</a - >) -> <a href="#" title="Bug1004" - >Product</a - > f g a -> <a href="#" title="Bug1004" + >liftShowList</a + > :: (<a href="#" title="Data.Int" + >Int</a + > -> a -> <a href="#" title="Text.Show" + >ShowS</a + >) -> ([a] -> <a href="#" title="Text.Show" + >ShowS</a + >) -> [<a href="#" title="Bug1004" >Product</a - > f g b -> <a href="#" title="Data.Ord" - >Ordering</a + > f g a] -> <a href="#" title="Text.Show" + >ShowS</a > <a href="#" class="selflink" >#</a ></p @@ -842,7 +806,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read1:10" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read1:9" ></span > (<a href="#" title="Data.Functor.Classes" >Read1</a @@ -863,7 +827,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:Read1:10" + ><details id="i:id:Product:Read1:9" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -942,14 +906,14 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show1:11" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord1:10" ></span > (<a href="#" title="Data.Functor.Classes" - >Show1</a + >Ord1</a > f, <a href="#" title="Data.Functor.Classes" - >Show1</a + >Ord1</a > g) => <a href="#" title="Data.Functor.Classes" - >Show1</a + >Ord1</a > (<a href="#" title="Bug1004" >Product</a > f g)</span @@ -963,7 +927,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:Show1:11" + ><details id="i:id:Product:Ord1:10" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -975,35 +939,67 @@ >Methods</p ><p class="src" ><a href="#" - >liftShowsPrec</a - > :: (<a href="#" title="Data.Int" - >Int</a - > -> a -> <a href="#" title="Text.Show" - >ShowS</a - >) -> ([a] -> <a href="#" title="Text.Show" - >ShowS</a - >) -> <a href="#" title="Data.Int" - >Int</a - > -> <a href="#" title="Bug1004" + >liftCompare</a + > :: (a -> b -> <a href="#" title="Data.Ord" + >Ordering</a + >) -> <a href="#" title="Bug1004" >Product</a - > f g a -> <a href="#" title="Text.Show" - >ShowS</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g b -> <a href="#" title="Data.Ord" + >Ordering</a > <a href="#" class="selflink" >#</a ></p + ></div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq1:11" + ></span + > (<a href="#" title="Data.Functor.Classes" + >Eq1</a + > f, <a href="#" title="Data.Functor.Classes" + >Eq1</a + > g) => <a href="#" title="Data.Functor.Classes" + >Eq1</a + > (<a href="#" title="Bug1004" + >Product</a + > f g)</span + ></td + ><td class="doc" + ><p + ><em + >Since: base-4.9.0.0</em + ></p + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:id:Product:Eq1:11" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >Data.Functor.Product</a + ></p + > <div class="subs methods" + ><p class="caption" + >Methods</p ><p class="src" ><a href="#" - >liftShowList</a - > :: (<a href="#" title="Data.Int" - >Int</a - > -> a -> <a href="#" title="Text.Show" - >ShowS</a - >) -> ([a] -> <a href="#" title="Text.Show" - >ShowS</a - >) -> [<a href="#" title="Bug1004" + >liftEq</a + > :: (a -> b -> <a href="#" title="Data.Bool" + >Bool</a + >) -> <a href="#" title="Bug1004" >Product</a - > f g a] -> <a href="#" title="Text.Show" - >ShowS</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g b -> <a href="#" title="Data.Bool" + >Bool</a > <a href="#" class="selflink" >#</a ></p @@ -1088,14 +1084,14 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Alternative:13" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:MonadPlus:13" ></span - > (<a href="#" title="Control.Applicative" - >Alternative</a - > f, <a href="#" title="Control.Applicative" - >Alternative</a - > g) => <a href="#" title="Control.Applicative" - >Alternative</a + > (<a href="#" title="Control.Monad" + >MonadPlus</a + > f, <a href="#" title="Control.Monad" + >MonadPlus</a + > g) => <a href="#" title="Control.Monad" + >MonadPlus</a > (<a href="#" title="Bug1004" >Product</a > f g)</span @@ -1109,7 +1105,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:Alternative:13" + ><details id="i:id:Product:MonadPlus:13" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -1121,7 +1117,7 @@ >Methods</p ><p class="src" ><a href="#" - >empty</a + >mzero</a > :: <a href="#" title="Bug1004" >Product</a > f g a <a href="#" class="selflink" @@ -1129,7 +1125,7 @@ ></p ><p class="src" ><a href="#" - >(<|>)</a + >mplus</a > :: <a href="#" title="Bug1004" >Product</a > f g a -> <a href="#" title="Bug1004" @@ -1139,26 +1135,6 @@ > f g a <a href="#" class="selflink" >#</a ></p - ><p class="src" - ><a href="#" - >some</a - > :: <a href="#" title="Bug1004" - >Product</a - > f g a -> <a href="#" title="Bug1004" - >Product</a - > f g [a] <a href="#" class="selflink" - >#</a - ></p - ><p class="src" - ><a href="#" - >many</a - > :: <a href="#" title="Bug1004" - >Product</a - > f g a -> <a href="#" title="Bug1004" - >Product</a - > f g [a] <a href="#" class="selflink" - >#</a - ></p ></div ></details ></td @@ -1166,14 +1142,14 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:MonadPlus:14" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Alternative:14" ></span - > (<a href="#" title="Control.Monad" - >MonadPlus</a - > f, <a href="#" title="Control.Monad" - >MonadPlus</a - > g) => <a href="#" title="Control.Monad" - >MonadPlus</a + > (<a href="#" title="Control.Applicative" + >Alternative</a + > f, <a href="#" title="Control.Applicative" + >Alternative</a + > g) => <a href="#" title="Control.Applicative" + >Alternative</a > (<a href="#" title="Bug1004" >Product</a > f g)</span @@ -1187,7 +1163,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:MonadPlus:14" + ><details id="i:id:Product:Alternative:14" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -1199,7 +1175,7 @@ >Methods</p ><p class="src" ><a href="#" - >mzero</a + >empty</a > :: <a href="#" title="Bug1004" >Product</a > f g a <a href="#" class="selflink" @@ -1207,7 +1183,7 @@ ></p ><p class="src" ><a href="#" - >mplus</a + >(<|>)</a > :: <a href="#" title="Bug1004" >Product</a > f g a -> <a href="#" title="Bug1004" @@ -1217,6 +1193,26 @@ > f g a <a href="#" class="selflink" >#</a ></p + ><p class="src" + ><a href="#" + >some</a + > :: <a href="#" title="Bug1004" + >Product</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g [a] <a href="#" class="selflink" + >#</a + ></p + ><p class="src" + ><a href="#" + >many</a + > :: <a href="#" title="Bug1004" + >Product</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g [a] <a href="#" class="selflink" + >#</a + ></p ></div ></details ></td @@ -1290,13 +1286,13 @@ ><span class="inst-left" ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Data:16" ></span - > (<a href="#" title="Type.Reflection" + > (<a href="#" title="Data.Typeable" >Typeable</a - > a, <a href="#" title="Type.Reflection" + > a, <a href="#" title="Data.Typeable" >Typeable</a - > f, <a href="#" title="Type.Reflection" + > f, <a href="#" title="Data.Typeable" >Typeable</a - > g, <a href="#" title="Type.Reflection" + > g, <a href="#" title="Data.Typeable" >Typeable</a > k, <a href="#" title="Data.Data" >Data</a @@ -1382,7 +1378,7 @@ ><p class="src" ><a href="#" >dataCast1</a - > :: <a href="#" title="Type.Reflection" + > :: <a href="#" title="Data.Typeable" >Typeable</a > t => (<span class="keyword" >forall</span @@ -1398,7 +1394,7 @@ ><p class="src" ><a href="#" >dataCast2</a - > :: <a href="#" title="Type.Reflection" + > :: <a href="#" title="Data.Typeable" >Typeable</a > t => (<span class="keyword" >forall</span @@ -1820,12 +1816,8 @@ >Product</a > f g a)</span ></td - ><td class="doc" - ><p - ><em - >Since: base-4.9.0.0</em - ></p - ></td + ><td class="doc empty" + > </td ></tr ><tr ><td colspan="2" @@ -1888,7 +1880,149 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep1:21" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Semigroup:21" + ></span + > (<a href="#" title="Prelude" + >Semigroup</a + > (f a), <a href="#" title="Prelude" + >Semigroup</a + > (g a)) => <a href="#" title="Prelude" + >Semigroup</a + > (<a href="#" title="Bug1004" + >Product</a + > f g a)</span + ></td + ><td class="doc" + ><p + ><em + >Since: base-4.16.0.0</em + ></p + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:id:Product:Semigroup:21" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >Data.Functor.Product</a + ></p + > <div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a href="#" + >(<>)</a + > :: <a href="#" title="Bug1004" + >Product</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g a <a href="#" class="selflink" + >#</a + ></p + ><p class="src" + ><a href="#" + >sconcat</a + > :: <a href="#" title="Data.List.NonEmpty" + >NonEmpty</a + > (<a href="#" title="Bug1004" + >Product</a + > f g a) -> <a href="#" title="Bug1004" + >Product</a + > f g a <a href="#" class="selflink" + >#</a + ></p + ><p class="src" + ><a href="#" + >stimes</a + > :: <a href="#" title="Prelude" + >Integral</a + > b => b -> <a href="#" title="Bug1004" + >Product</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g a <a href="#" class="selflink" + >#</a + ></p + ></div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Monoid:22" + ></span + > (<a href="#" title="Data.Monoid" + >Monoid</a + > (f a), <a href="#" title="Data.Monoid" + >Monoid</a + > (g a)) => <a href="#" title="Data.Monoid" + >Monoid</a + > (<a href="#" title="Bug1004" + >Product</a + > f g a)</span + ></td + ><td class="doc" + ><p + ><em + >Since: base-4.16.0.0</em + ></p + ></td + ></tr + ><tr + ><td colspan="2" + ><details id="i:id:Product:Monoid:22" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >Data.Functor.Product</a + ></p + > <div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a href="#" + >mempty</a + > :: <a href="#" title="Bug1004" + >Product</a + > f g a <a href="#" class="selflink" + >#</a + ></p + ><p class="src" + ><a href="#" + >mappend</a + > :: <a href="#" title="Bug1004" + >Product</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g a -> <a href="#" title="Bug1004" + >Product</a + > f g a <a href="#" class="selflink" + >#</a + ></p + ><p class="src" + ><a href="#" + >mconcat</a + > :: [<a href="#" title="Bug1004" + >Product</a + > f g a] -> <a href="#" title="Bug1004" + >Product</a + > f g a <a href="#" class="selflink" + >#</a + ></p + ></div + ></details + ></td + ></tr + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep1:23" ></span > <span class="keyword" >type</span @@ -1900,12 +2034,16 @@ >Type</a >)</span ></td - ><td class="doc empty" - > </td + ><td class="doc" + ><p + ><em + >Since: base-4.9.0.0</em + ></p + ></td ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:Rep1:21" + ><details id="i:id:Product:Rep1:23" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -1980,7 +2118,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep:22" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep:24" ></span > <span class="keyword" >type</span @@ -1990,12 +2128,16 @@ >Product</a > f g a)</span ></td - ><td class="doc empty" - > </td + ><td class="doc" + ><p + ><em + >Since: base-4.9.0.0</em + ></p + ></td ></tr ><tr ><td colspan="2" - ><details id="i:id:Product:Rep:22" + ><details id="i:id:Product:Rep:24" ><summary class="hide-when-js-enabled" >Instance details</summary ><p diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html index 736fb2ad..36254447 100644 --- a/html-test/ref/Bug1033.html +++ b/html-test/ref/Bug1033.html @@ -88,10 +88,8 @@ > <a href="#" class="selflink" >#</a ></td - ><td class="doc" - ><p - >This does some generic foos.</p - ></td + ><td class="doc empty" + > </td ></tr ><tr ><td colspan="2" @@ -166,8 +164,10 @@ > <a href="#" class="selflink" >#</a ></td - ><td class="doc empty" - > </td + ><td class="doc" + ><p + >This does some generic foos.</p + ></td ></tr ><tr ><td colspan="2" diff --git a/html-test/ref/Bug1035.html b/html-test/ref/Bug1035.html index 5e4d6f82..6594064e 100644 --- a/html-test/ref/Bug1035.html +++ b/html-test/ref/Bug1035.html @@ -132,7 +132,7 @@ ><p >A link to <code ><a href="#" title="Bug1035" - >Bar</a + >Foo</a ></code ></p ></div diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html index b8b8ff0f..da7ae1d2 100644 --- a/html-test/ref/Bug1050.html +++ b/html-test/ref/Bug1050.html @@ -95,7 +95,7 @@ >forall</span > {k} {f :: <span class="keyword" >forall</span - > k1. k1 -> <a href="#" title="Data.Kind" + > k. k -> <a href="#" title="Data.Kind" >Type</a >} {a :: k}. f a -> <a href="#" title="Bug1050" >T</a diff --git a/html-test/ref/Bug310.html b/html-test/ref/Bug310.html index 59faf609..65ec1cae 100644 --- a/html-test/ref/Bug310.html +++ b/html-test/ref/Bug310.html @@ -50,14 +50,14 @@ ><li class="src short" ><span class="keyword" >type family</span - > (a :: <a href="#" title="GHC.TypeNats" - >Nat</a + > (a :: <a href="#" title="Numeric.Natural" + >Natural</a >) <a href="#" >+</a - > (b :: <a href="#" title="GHC.TypeNats" - >Nat</a - >) :: <a href="#" title="GHC.TypeNats" - >Nat</a + > (b :: <a href="#" title="Numeric.Natural" + >Natural</a + >) :: <a href="#" title="Numeric.Natural" + >Natural</a > <span class="keyword" >where ...</span ></li @@ -71,14 +71,14 @@ ><p class="src" ><span class="keyword" >type family</span - > (a :: <a href="#" title="GHC.TypeNats" - >Nat</a + > (a :: <a href="#" title="Numeric.Natural" + >Natural</a >) <a id="t:-43-" class="def" >+</a - > (b :: <a href="#" title="GHC.TypeNats" - >Nat</a - >) :: <a href="#" title="GHC.TypeNats" - >Nat</a + > (b :: <a href="#" title="Numeric.Natural" + >Natural</a + >) :: <a href="#" title="Numeric.Natural" + >Natural</a > <span class="keyword" >where ...</span > <span class="fixity" diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html index dc2128ee..1ac40ae4 100644 --- a/html-test/ref/Bug548.html +++ b/html-test/ref/Bug548.html @@ -114,12 +114,8 @@ >Type</a >)</span ></td - ><td class="doc" - ><p - ><em - >Since: base-4.7.0.0</em - ></p - ></td + ><td class="doc empty" + > </td ></tr ><tr ><td colspan="2" @@ -418,12 +414,8 @@ >WrappedArrow</a > a b c)</span ></td - ><td class="doc" - ><p - ><em - >Since: base-4.7.0.0</em - ></p - ></td + ><td class="doc empty" + > </td ></tr ><tr ><td colspan="2" @@ -500,8 +492,12 @@ >Type</a >)</span ></td - ><td class="doc empty" - > </td + ><td class="doc" + ><p + ><em + >Since: base-4.7.0.0</em + ></p + ></td ></tr ><tr ><td colspan="2" @@ -568,8 +564,12 @@ >WrappedArrow</a > a b c)</span ></td - ><td class="doc empty" - > </td + ><td class="doc" + ><p + ><em + >Since: base-4.7.0.0</em + ></p + ></td ></tr ><tr ><td colspan="2" diff --git a/html-test/ref/Bug574.html b/html-test/ref/Bug574.html index 3c7cf13f..e2024f47 100644 --- a/html-test/ref/Bug574.html +++ b/html-test/ref/Bug574.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Bug679.html b/html-test/ref/Bug679.html index 2434a857..8814129d 100644 --- a/html-test/ref/Bug679.html +++ b/html-test/ref/Bug679.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html index 73890845..4d6fe69b 100644 --- a/html-test/ref/Bug8.html +++ b/html-test/ref/Bug8.html @@ -89,7 +89,7 @@ ><p class="src" ><a id="v:-45--45--62-" class="def" >(-->)</a - > :: p1 -> p2 -> <a href="#" title="Bug8" + > :: p -> p -> <a href="#" title="Bug8" >Typ</a > <span class="fixity" >infix 9</span diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html index fb6518af..af1a0265 100644 --- a/html-test/ref/BundledPatterns.html +++ b/html-test/ref/BundledPatterns.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" @@ -52,7 +52,7 @@ >data</span > <a href="#" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -82,7 +82,7 @@ >data</span > <a href="#" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -123,7 +123,7 @@ >data</span > <a id="t:Vec" class="def" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -146,7 +146,7 @@ > subscript starting from 0 and ending at <code ><code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >length</a ></code > - 1</code @@ -285,7 +285,7 @@ >data</span > <a id="t:RTree" class="def" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html index b680fe66..faca9016 100644 --- a/html-test/ref/BundledPatterns2.html +++ b/html-test/ref/BundledPatterns2.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" @@ -52,7 +52,7 @@ >data</span > <a href="#" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -84,7 +84,7 @@ >data</span > <a href="#" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -125,7 +125,7 @@ >data</span > <a id="t:Vec" class="def" >Vec</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span @@ -148,7 +148,7 @@ > subscript starting from 0 and ending at <code ><code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >length</a ></code > - 1</code @@ -283,7 +283,7 @@ >data</span > <a id="t:RTree" class="def" >RTree</a - > :: <a href="#" title="GHC.TypeNats" + > :: <a href="#" title="GHC.TypeLits" >Nat</a > -> * -> * <span class="keyword" >where</span diff --git a/html-test/ref/Identifiers.html b/html-test/ref/Identifiers.html index c89e7434..bd0f610e 100644 --- a/html-test/ref/Identifiers.html +++ b/html-test/ref/Identifiers.html @@ -140,7 +140,7 @@ >++</a ></code >, <code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >elem</a ></code ></li @@ -162,7 +162,7 @@ >, <code >++</code >, <code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >elem</a ></code >, <code @@ -231,7 +231,7 @@ ><li >Unqualified: <code >1 <code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >`elem`</a ></code > [-3..3]</code @@ -239,14 +239,14 @@ ><li >Qualified: <code >1 <code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >`elem`</a ></code > [-3..3]</code ></li ><li >Namespaced: <code - ><a href="#" title="Data.Foldable" + ><a href="#" title="Data.List" >`elem`</a ></code >, <code diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html index ccaffdad..f89e009e 100644 --- a/html-test/ref/IgnoreExports.html +++ b/html-test/ref/IgnoreExports.html @@ -52,8 +52,6 @@ >data</span > <a href="#" >Foo</a - > = <a href="#" - >Bar</a ></li ><li class="src short" ><a href="#" @@ -61,12 +59,6 @@ > :: <a href="#" title="Data.Int" >Int</a ></li - ><li class="src short" - ><a href="#" - >bar</a - > :: <a href="#" title="Data.Int" - >Int</a - ></li ></ul ></details ></div @@ -86,22 +78,6 @@ ><p >documentation for Foo</p ></div - ><div class="subs constructors" - ><p class="caption" - >Constructors</p - ><table - ><tr - ><td class="src" - ><a id="v:Bar" class="def" - >Bar</a - ></td - ><td class="doc" - ><p - >Documentation for Bar</p - ></td - ></tr - ></table - ></div ></div ><div class="top" ><p class="src" @@ -117,20 +93,6 @@ >documentation for foo</p ></div ></div - ><div class="top" - ><p class="src" - ><a id="v:bar" class="def" - >bar</a - > :: <a href="#" title="Data.Int" - >Int</a - > <a href="#" class="selflink" - >#</a - ></p - ><div class="doc" - ><p - >documentation for bar</p - ></div - ></div ></div ></div ></body diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html index 2eb2cda3..e3c7b6e7 100644 --- a/html-test/ref/QuasiExpr.html +++ b/html-test/ref/QuasiExpr.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/QuasiQuote.html b/html-test/ref/QuasiQuote.html index d828ea1d..1ea51099 100644 --- a/html-test/ref/QuasiQuote.html +++ b/html-test/ref/QuasiQuote.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/TH.html b/html-test/ref/TH.html index 8ef49ced..d44d5741 100644 --- a/html-test/ref/TH.html +++ b/html-test/ref/TH.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/TH2.html b/html-test/ref/TH2.html index f59629a2..1b47e640 100644 --- a/html-test/ref/TH2.html +++ b/html-test/ref/TH2.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html index 3277c468..8391431e 100644 --- a/html-test/ref/Threaded.html +++ b/html-test/ref/Threaded.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/Ticket112.html b/html-test/ref/Ticket112.html index 9d04e8c5..bd596be0 100644 --- a/html-test/ref/Ticket112.html +++ b/html-test/ref/Ticket112.html @@ -36,7 +36,7 @@ ><th >Safe Haskell</th ><td - >None</td + >Safe-Inferred</td ></tr ></table ><p class="caption" diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html index 998b6d8c..7ca50972 100644 --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -222,37 +222,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-62--60-:1" - ></span - > '<a href="#" title="TypeFamilies" - >XX</a - > <a href="#" title="TypeFamilies" - >><</a - > '<a href="#" title="TypeFamilies" - >XXX</a - ></span - > <a href="#" class="selflink" - >#</a - ></td - ><td class="doc empty" - > </td - ></tr - ><tr - ><td colspan="2" - ><details id="i:id:X:-62--60-:1" - ><summary class="hide-when-js-enabled" - >Instance details</summary - ><p - >Defined in <a href="#" - >TypeFamilies</a - ></p - ></details - ></td - ></tr - ><tr - ><td class="src clearfix" - ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Assoc:2" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Assoc:1" ></span > <a href="#" title="TypeFamilies" >Assoc</a @@ -269,7 +239,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:X:Assoc:2" + ><details id="i:id:X:Assoc:1" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -306,7 +276,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Test:3" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Test:2" ></span > <a href="#" title="TypeFamilies" >Test</a @@ -323,7 +293,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:X:Test:3" + ><details id="i:id:X:Test:2" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -336,68 +306,56 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:4" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-62--60-:3" ></span - > <span class="keyword" - >type</span - > <a href="#" title="TypeFamilies2" - >Foo</a + > '<a href="#" title="TypeFamilies" + >XX</a > <a href="#" title="TypeFamilies" - >X</a + >><</a + > '<a href="#" title="TypeFamilies" + >XXX</a ></span > <a href="#" class="selflink" >#</a ></td - ><td class="doc" - ><p - >External instance</p - ></td + ><td class="doc empty" + > </td ></tr ><tr ><td colspan="2" - ><details id="i:id:X:Foo:4" + ><details id="i:id:X:-62--60-:3" ><summary class="hide-when-js-enabled" >Instance details</summary ><p >Defined in <a href="#" >TypeFamilies</a ></p - > <div class="src" - ><span class="keyword" - >type</span - > <a href="#" title="TypeFamilies2" - >Foo</a - > <a href="#" title="TypeFamilies" - >X</a - > = <a href="#" title="TypeFamilies" - >Y</a - ></div ></details ></td ></tr ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-60--62-:5" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:4" ></span > <span class="keyword" >type</span - > '<a href="#" title="TypeFamilies" - >XXX</a + > <a href="#" title="TypeFamilies2" + >Foo</a > <a href="#" title="TypeFamilies" - ><></a - > '<a href="#" title="TypeFamilies" - >XX</a + >X</a ></span > <a href="#" class="selflink" >#</a ></td - ><td class="doc empty" - > </td + ><td class="doc" + ><p + >External instance</p + ></td ></tr ><tr ><td colspan="2" - ><details id="i:id:X:-60--62-:5" + ><details id="i:id:X:Foo:4" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -407,14 +365,12 @@ > <div class="src" ><span class="keyword" >type</span - > '<a href="#" title="TypeFamilies" - >XXX</a + > <a href="#" title="TypeFamilies2" + >Foo</a > <a href="#" title="TypeFamilies" - ><></a - > '<a href="#" title="TypeFamilies" - >XX</a - > = '<a href="#" title="TypeFamilies" >X</a + > = <a href="#" title="TypeFamilies" + >Y</a ></div ></details ></td @@ -422,7 +378,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocD:6" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocD:5" ></span > <span class="keyword" >data</span @@ -439,7 +395,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:X:AssocD:6" + ><details id="i:id:X:AssocD:5" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -462,7 +418,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocT:7" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:AssocT:6" ></span > <span class="keyword" >type</span @@ -479,7 +435,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:X:AssocT:7" + ><details id="i:id:X:AssocT:6" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -506,7 +462,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Bat:8" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Bat:7" ></span > <span class="keyword" >data</span @@ -525,7 +481,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:X:Bat:8" + ><details id="i:id:X:Bat:7" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -572,7 +528,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:9" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:Foo:8" ></span > <span class="keyword" >type</span @@ -591,7 +547,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:X:Foo:9" + ><details id="i:id:X:Foo:8" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -614,7 +570,7 @@ ><tr ><td class="src clearfix" ><span class="inst-left" - ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-60--62-:10" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-60--62-:9" ></span > <span class="keyword" >type</span @@ -633,7 +589,7 @@ ></tr ><tr ><td colspan="2" - ><details id="i:id:X:-60--62-:10" + ><details id="i:id:X:-60--62-:9" ><summary class="hide-when-js-enabled" >Instance details</summary ><p @@ -655,6 +611,50 @@ ></details ></td ></tr + ><tr + ><td class="src clearfix" + ><span class="inst-left" + ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:X:-60--62-:10" + ></span + > <span class="keyword" + >type</span + > '<a href="#" title="TypeFamilies" + >XXX</a + > <a href="#" title="TypeFamilies" + ><></a + > '<a href="#" title="TypeFamilies" + >XX</a + ></span + > <a href="#" class="selflink" + >#</a + ></td + ><td class="doc empty" + > </td + ></tr + ><tr + ><td colspan="2" + ><details id="i:id:X:-60--62-:10" + ><summary class="hide-when-js-enabled" + >Instance details</summary + ><p + >Defined in <a href="#" + >TypeFamilies</a + ></p + > <div class="src" + ><span class="keyword" + >type</span + > '<a href="#" title="TypeFamilies" + >XXX</a + > <a href="#" title="TypeFamilies" + ><></a + > '<a href="#" title="TypeFamilies" + >XX</a + > = '<a href="#" title="TypeFamilies" + >X</a + ></div + ></details + ></td + ></tr ></table ></details ></div @@ -1738,13 +1738,13 @@ ></span > <span class="keyword" >type</span - > '<a href="#" title="TypeFamilies" - >XXX</a + > <a href="#" title="TypeFamilies" + >Y</a > <a href="#" title="TypeFamilies" ><></a - > '<a href="#" title="TypeFamilies" - >XX</a - ></span + > (a :: <a href="#" title="Data.Kind" + >Type</a + >)</span > <a href="#" class="selflink" >#</a ></td @@ -1763,15 +1763,13 @@ > <div class="src" ><span class="keyword" >type</span - > '<a href="#" title="TypeFamilies" - >XXX</a + > <a href="#" title="TypeFamilies" + >Y</a > <a href="#" title="TypeFamilies" ><></a - > '<a href="#" title="TypeFamilies" - >XX</a - > = '<a href="#" title="TypeFamilies" - >X</a - ></div + > (a :: <a href="#" title="Data.Kind" + >Type</a + >) = a</div ></details ></td ></tr @@ -1783,7 +1781,7 @@ > <span class="keyword" >type</span > <a href="#" title="TypeFamilies" - >Y</a + >X</a > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" @@ -1808,12 +1806,14 @@ ><span class="keyword" >type</span > <a href="#" title="TypeFamilies" - >Y</a + >X</a > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" >Type</a - >) = a</div + >) = <a href="#" title="TypeFamilies" + >X</a + ></div ></details ></td ></tr @@ -1824,13 +1824,13 @@ ></span > <span class="keyword" >type</span - > <a href="#" title="TypeFamilies" - >X</a + > '<a href="#" title="TypeFamilies" + >XXX</a > <a href="#" title="TypeFamilies" ><></a - > (a :: <a href="#" title="Data.Kind" - >Type</a - >)</span + > '<a href="#" title="TypeFamilies" + >XX</a + ></span > <a href="#" class="selflink" >#</a ></td @@ -1849,13 +1849,13 @@ > <div class="src" ><span class="keyword" >type</span - > <a href="#" title="TypeFamilies" - >X</a + > '<a href="#" title="TypeFamilies" + >XXX</a > <a href="#" title="TypeFamilies" ><></a - > (a :: <a href="#" title="Data.Kind" - >Type</a - >) = <a href="#" title="TypeFamilies" + > '<a href="#" title="TypeFamilies" + >XX</a + > = '<a href="#" title="TypeFamilies" >X</a ></div ></details diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index 3477d89d..2a44be99 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -280,12 +280,12 @@ forall a. a -> a </span ><span id="line-12" ></span - ><span id="" ><span class="hs-keyword" - >instance</span - ><span - > </span - ><span class="annot" + >instance</span + ><span + > </span + ><span id="" + ><span class="annot" ><a href="Classes.html#Foo" ><span class="hs-identifier hs-type" >Foo</span @@ -303,93 +303,93 @@ forall a. a -> a ></span ><span class="hs-special" >]</span - ><span - > </span - ><span class="hs-keyword" - >where</span - ><span - > -</span - ><span id="line-13" ></span - ><span - > </span - ><span id="" - ><span class="annot" - ><span class="annottext" - >bar :: [a] -> Int + ><span + > </span + ><span class="hs-keyword" + >where</span + ><span + > </span - ><a href="#" - ><span class="hs-identifier hs-var hs-var hs-var hs-var" - >bar</span - ></a - ></span - ></span - ><span - > </span - ><span class="hs-glyph" - >=</span - ><span - > </span - ><span class="annot" + ><span id="line-13" + ></span + ><span + > </span + ><span id="" + ><span class="annot" ><span class="annottext" - >[a] -> Int -forall (t :: * -> *) a. Foldable t => t a -> Int + >bar :: [a] -> Int </span - ><span class="hs-identifier hs-var" - >length</span + ><a href="#" + ><span class="hs-identifier hs-var hs-var hs-var hs-var" + >bar</span + ></a ></span - ><span - > + ></span + ><span + > </span + ><span class="hs-glyph" + >=</span + ><span + > </span + ><span class="annot" + ><span class="annottext" + >[a] -> Int +forall (t :: * -> *) a. Foldable t => t a -> Int </span - ><span id="line-14" + ><span class="hs-identifier hs-var" + >length</span ></span - ><span - > </span - ><span id="" - ><span class="annot" - ><span class="annottext" - >baz :: Int -> ([a], [a]) + ><span + > </span - ><a href="#" - ><span class="hs-identifier hs-var hs-var hs-var hs-var" - >baz</span - ></a - ></span - ></span - ><span - > </span - ><span class="annot" + ><span id="line-14" + ></span + ><span + > </span + ><span id="" + ><span class="annot" ><span class="annottext" - >Int + >baz :: Int -> ([a], [a]) </span - ><span class="hs-identifier" - >_</span + ><a href="#" + ><span class="hs-identifier hs-var hs-var hs-var hs-var" + >baz</span + ></a ></span - ><span - > </span - ><span class="hs-glyph" - >=</span - ><span - > </span - ><span class="hs-special" - >(</span - ><span class="hs-special" - >[</span - ><span class="hs-special" - >]</span - ><span class="hs-special" - >,</span - ><span - > </span - ><span class="hs-special" - >[</span - ><span class="hs-special" - >]</span - ><span class="hs-special" - >)</span ></span ><span + > </span + ><span class="annot" + ><span class="annottext" + >Int +</span + ><span class="hs-identifier" + >_</span + ></span + ><span + > </span + ><span class="hs-glyph" + >=</span + ><span + > </span + ><span class="hs-special" + >(</span + ><span class="hs-special" + >[</span + ><span class="hs-special" + >]</span + ><span class="hs-special" + >,</span + ><span + > </span + ><span class="hs-special" + >[</span + ><span class="hs-special" + >]</span + ><span class="hs-special" + >)</span + ><span > </span ><span id="line-15" @@ -821,12 +821,12 @@ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a </span ><span id="line-27" ></span - ><span id="" ><span class="hs-keyword" - >instance</span - ><span - > </span - ><span id="" + >instance</span + ><span + > </span + ><span id="" + ><span id="" ><span class="annot" ><a href="Classes.html#Foo%27" ><span class="hs-identifier hs-type" @@ -846,52 +846,52 @@ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a ><span class="hs-special" >]</span ></span - ><span - > </span - ><span class="hs-keyword" - >where</span - ><span - > -</span - ><span id="line-28" ></span - ><span - > </span - ><span id="" - ><span class="annot" - ><span class="annottext" - >quux :: ([a], [a]) -> [a] + ><span + > </span + ><span class="hs-keyword" + >where</span + ><span + > </span - ><a href="#" - ><span class="hs-identifier hs-var hs-var hs-var hs-var" - >quux</span - ></a - ></span - ></span - ><span - > </span - ><span class="hs-glyph" - >=</span - ><span - > </span - ><span class="annot" + ><span id="line-28" + ></span + ><span + > </span + ><span id="" + ><span class="annot" ><span class="annottext" - >([a] -> [a] -> [a]) -> ([a], [a]) -> [a] -forall a b c. (a -> b -> c) -> (a, b) -> c + >quux :: ([a], [a]) -> [a] </span - ><span class="hs-identifier hs-var" - >uncurry</span + ><a href="#" + ><span class="hs-identifier hs-var hs-var hs-var hs-var" + >quux</span + ></a ></span - ><span - > </span - ><span class="annot" - ><span class="annottext" - >[a] -> [a] -> [a] + ></span + ><span + > </span + ><span class="hs-glyph" + >=</span + ><span + > </span + ><span class="annot" + ><span class="annottext" + >([a] -> [a] -> [a]) -> ([a], [a]) -> [a] +forall a b c. (a -> b -> c) -> (a, b) -> c +</span + ><span class="hs-identifier hs-var" + >uncurry</span + ></span + ><span + > </span + ><span class="annot" + ><span class="annottext" + >[a] -> [a] -> [a] forall a. [a] -> [a] -> [a] </span - ><span class="hs-operator hs-var" - >(++)</span - ></span + ><span class="hs-operator hs-var" + >(++)</span ></span ><span > @@ -941,23 +941,23 @@ forall a. [a] -> [a] -> [a] ></span ><span > </span + ><span id="plugh" + ><span class="annot" + ><a href="Classes.html#plugh" + ><span class="hs-identifier hs-type" + >plugh</span + ></a + ></span + ></span + ><span + > </span + ><span class="hs-glyph" + >::</span + ><span + > </span ><span id="" ><span id="" - ><span id="plugh" - ><span class="annot" - ><a href="Classes.html#plugh" - ><span class="hs-identifier hs-type" - >plugh</span - ></a - ></span - ></span - ><span - > </span - ><span class="hs-glyph" - >::</span - ><span - > </span - ><span class="annot" + ><span class="annot" ><a href="#" ><span class="hs-identifier hs-type" >p</span diff --git a/hypsrc-test/ref/src/Quasiquoter.html b/hypsrc-test/ref/src/Quasiquoter.html index ea111cad..867c78ca 100644 --- a/hypsrc-test/ref/src/Quasiquoter.html +++ b/hypsrc-test/ref/src/Quasiquoter.html @@ -119,14 +119,7 @@ ><span > </span ><span class="annot" - ><span class="annottext" - >QuasiQuoter :: (String -> Q Exp) --> (String -> Q Pat) --> (String -> Q Type) --> (String -> Q [Dec]) --> QuasiQuoter -</span - ><span class="hs-identifier hs-type" + ><span class="hs-identifier hs-type" >QuasiQuoter</span ></span ><span diff --git a/hypsrc-test/ref/src/Records.html b/hypsrc-test/ref/src/Records.html index 604ac6ca..7c5b2ff7 100644 --- a/hypsrc-test/ref/src/Records.html +++ b/hypsrc-test/ref/src/Records.html @@ -260,10 +260,7 @@ ><span > </span ><span class="annot" - ><span class="annottext" - >Point :: Int -> Int -> Point -</span - ><a href="Records.html#Point" + ><a href="Records.html#Point" ><span class="hs-identifier hs-type" >Point</span ></a @@ -877,7 +874,7 @@ forall a. Num a => a -> a -> a >Point -> Int </span ><a href="Records.html#x" - ><span class="hs-identifier hs-var hs-var" + ><span class="hs-identifier hs-var" >x</span ></a ></span @@ -1000,7 +997,7 @@ forall a. Num a => a -> a -> a >Point -> Int </span ><a href="Records.html#y" - ><span class="hs-identifier hs-var hs-var" + ><span class="hs-identifier hs-var" >y</span ></a ></span diff --git a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex index 053d2e41..c8e5271d 100644 --- a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex +++ b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex @@ -3,8 +3,8 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module ConstructorArgs ( - Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), - pattern Bo, pattern Bo' + Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), pattern Bo, + pattern Bo' ) where\end{verbatim}} \haddockendheader |