diff options
51 files changed, 976 insertions, 1057 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 982d6145..93f59c1f 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -13,7 +13,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.10.* +tested-with: GHC==9.0.* extra-source-files: CHANGES.md @@ -43,8 +43,8 @@ library default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base ^>= 4.14.0 - , ghc ^>= 8.10 + build-depends: base ^>= 4.15.0 + , ghc ^>= 9.0 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 @@ -57,6 +57,7 @@ library , containers , deepseq , directory + , exceptions , filepath , ghc-boot , transformers @@ -172,7 +173,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 8.10 + build-depends: ghc ^>= 9.0 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 0b5e33a3..8dfee5bc 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -55,27 +55,25 @@ import Data.Version (makeVersion) import qualified Data.Map as Map import System.IO import System.Exit +import System.FilePath #ifdef IN_GHC_TREE -import System.FilePath import System.Environment (getExecutablePath) #else import qualified GHC.Paths as GhcPaths import Paths_haddock_api (getDataDir) #endif import System.Directory (doesDirectoryExist, getTemporaryDirectory) -import System.FilePath ((</>)) import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) -import Config -import DynFlags hiding (projectVersion, verbosity) -import ErrUtils -import Packages -import Panic (handleGhcException) -import Module -import FastString -import Outputable (defaultUserStyle) +import GHC.Settings.Config +import GHC.Driver.Session hiding (projectVersion, verbosity) +import GHC.Utils.Outputable (defaultUserStyle, withPprStyle) +import GHC.Utils.Error +import GHC.Unit +import GHC.Utils.Panic (handleGhcException) +import GHC.Data.FastString -------------------------------------------------------------------------------- -- * Exception handling @@ -185,7 +183,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do - logOutput dflags (defaultUserStyle dflags) (renderJson (jsonInterfaceFile ifaceFile)) + logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile)) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -286,6 +284,7 @@ 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 @@ -297,8 +296,8 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = fmap ifaceMod (listToMaybe ifaces) - pkgKey = fmap moduleUnitId pkgMod - pkgStr = fmap unitIdString pkgKey + pkgKey = fmap moduleUnit pkgMod + pkgStr = fmap unitString pkgKey pkgNameVer = modulePackageInfo dflags flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of @@ -315,7 +314,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) - pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap + pkgSrcMap = Map.mapKeys moduleUnit extSrcMap pkgSrcMap' | Flag_HyperlinkedSource `elem` flags , Just k <- pkgKey @@ -344,11 +343,11 @@ 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 { moduleUnitId = unwireUnitId dflags (moduleUnitId m) } + unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn = hPutStrLn stderr . ("Warning: " ++) - case readP_to_S parseModuleId mod_str of + case readP_to_S parseHoleyModule mod_str of [(m, "")] | Just iface <- Map.lookup m installedMap -> return [iface] @@ -375,7 +374,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_GenContents `elem` flags) $ do withTiming dflags' "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} - ppHtmlContents dflags' odir title pkgStr + ppHtmlContents pkgs odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty sincePkg (makeContentsQual qual) @@ -385,7 +384,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_Html `elem` flags) $ do withTiming dflags' "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} - ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir + ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode sincePkg qual diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 4961edc2..c114e84d 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -18,19 +18,20 @@ module Haddock.Backends.Hoogle ( ppHoogle ) where -import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..) +import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..) , PromotionFlag(..), TopLevelFlag(..) ) -import InstEnv (ClsInst(..)) +import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) import GHC -import Outputable +import GHC.Utils.Outputable as Outputable +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Data.Char -import Data.List (isPrefixOf, intercalate) +import Data.List import Data.Maybe import Data.Version @@ -72,12 +73,12 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy x fvf a e) = HsForAllTy x fvf a (g e) + f (HsForAllTy x a e) = HsForAllTy x a (g e) f (HsQualTy x a e) = HsQualTy x a (g e) f (HsBangTy x a b) = HsBangTy x a (g b) f (HsAppTy x a b) = HsAppTy x (g a) (g b) f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b) - f (HsFunTy x a b) = HsFunTy x (g a) (g b) + f (HsFunTy x w a b) = HsFunTy x w (g a) (g b) f (HsListTy x a) = HsListTy x (g a) f (HsTupleTy x a b) = HsTupleTy x a (map g b) f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) @@ -196,7 +197,6 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl -ppFam _ (XFamilyDecl nec) = noExtCon nec ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = @@ -238,30 +238,29 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where - f (PrefixCon args) = [typeSig name $ args ++ [resType]] + f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat + f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> noLoc $ HsFunTy noExtField x y) - apps = foldl1 (\x y -> noLoc $ HsAppTy noExtField x y) + funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) + apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unLoc $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unLoc $ getConNames con - resType = let c = HsTyVar noExtField NotPromoted (noLoc (tcdName dat)) - as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) - in apps (map noLoc (c : as)) + tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n + tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty + tyVarArg _ = panic "ppCtor" - tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn - tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (noLoc (HsTyVar noExtField NotPromoted n)) k - tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec + resType = apps $ map reL $ + (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : + map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f @@ -270,7 +269,6 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty) name = out dflags $ map unLoc $ getConNames con -ppCtor _ _ _ (XConDecl nec) = noExtCon nec ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 3f5483fe..6ef07434 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -18,14 +18,14 @@ import Data.Maybe import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieAST(..), HieASTs(..), NodeInfo(..) ) -import HieBin ( readHieFile, hie_file_result) +import GHC.Iface.Ext.Types ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..), SourcedNodeInfo(..) ) +import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) +import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M -import FastString ( mkFastString ) -import Module ( Module, moduleName ) -import NameCache ( initNameCache ) -import SrcLoc ( mkRealSrcLoc, realSrcLocSpan ) -import UniqSupply ( mkSplitUniqSupply ) +import GHC.Data.FastString ( mkFastString ) +import GHC.Unit.Module ( Module, moduleName ) +import GHC.Types.Name.Cache ( initNameCache ) +import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -- | Generate hyperlinked source for given interfaces. @@ -58,12 +58,14 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile Just hfp -> do -- Parse the GHC-produced HIE file u <- mkSplitUniqSupply 'a' + let nc = (initNameCache u []) + ncu = NCU $ \f -> pure $ snd $ f nc HieFile { hie_hs_file = file , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc - } <- (hie_file_result . fst) - <$> (readHieFile (initNameCache u []) hfp) + } <- hie_file_result + <$> (readHieFile ncu hfp) -- Get the AST and tokens corresponding to the source file we want let fileFs = mkFastString file @@ -87,15 +89,10 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir </> hypSrcModuleFile (ifaceMod iface) - emptyNodeInfo = NodeInfo - { nodeAnnotations = mempty - , nodeType = [] - , nodeIdentifiers = mempty - } emptyHieAst fileFs = Node - { nodeInfo = emptyNodeInfo - , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) , nodeChildren = [] + , sourcedNodeInfo = SourcedNodeInfo mempty } -- | Name of CSS file in output directory. diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 285b0ee7..3db3c685 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -3,21 +3,24 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class import Control.Applicative ( Alternative(..) ) import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import BasicTypes ( IntegralLit(..) ) -import DynFlags -import ErrUtils ( pprLocErrMsg ) -import FastString ( mkFastString ) -import Lexer ( P(..), ParseResult(..), PState(..), Token(..) - , mkPStatePure, lexer, mkParserFlags', getErrorMessages, addFatalError ) -import Bag ( bagToList ) -import Outputable ( showSDoc, panic, text, ($$) ) -import SrcLoc -import StringBuffer ( StringBuffer, atEnd ) +import GHC.Types.Basic ( IntegralLit(..) ) +import GHC.Driver.Session +import GHC.Utils.Error ( pprLocErrMsg ) +import GHC.Data.FastString ( mkFastString ) +import GHC.Parser.Lexer as Lexer + ( P(..), ParseResult(..), PState(..), Token(..) + , mkPStatePure, lexer, mkParserFlags', getErrorMessages) +import GHC.Data.Bag ( bagToList ) +import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) ) +import GHC.Types.SrcLoc +import GHC.Data.StringBuffer ( StringBuffer, atEnd ) import Haddock.Backends.Hyperlinker.Types as T import Haddock.GhcUtils @@ -44,7 +47,7 @@ parse dflags fpath bs = case unP (go False []) initState of start = mkRealSrcLoc (mkFastString fpath) 1 1 pflags = mkParserFlags' (warningFlags dflags) (extensionFlags dflags) - (thisPackage dflags) + (homeUnitId dflags) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens @@ -57,7 +60,10 @@ parse dflags fpath bs = case unP (go False []) initState of (b, _) <- getInput if not (atEnd b) then do - (newToks, inPrag') <- parseCppLine <|> parsePlainTok inPrag <|> unknownLine + mtok <- runMaybeT (parseCppLine <|> parsePlainTok inPrag) + (newToks, inPrag') <- case mtok of + Nothing -> unknownLine + Just a -> pure a go inPrag' (newToks ++ toks) else pure toks @@ -65,36 +71,36 @@ parse dflags fpath bs = case unP (go False []) initState of -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens wrappedLexer :: P (RealLocated Lexer.Token) wrappedLexer = Lexer.lexer False andThen - where andThen (L (RealSrcSpan s) t) + where andThen (L (RealSrcSpan s _) t) | srcSpanStartLine s /= srcSpanEndLine s || srcSpanStartCol s /= srcSpanEndCol s = pure (L s t) - andThen (L (RealSrcSpan s) ITeof) = pure (L s ITeof) + andThen (L (RealSrcSpan s _) ITeof) = pure (L s ITeof) andThen _ = wrappedLexer -- | Try to parse a CPP line (can fail) - parseCppLine :: P ([T.Token], Bool) - parseCppLine = do + parseCppLine :: MaybeT P ([T.Token], Bool) + parseCppLine = MaybeT $ do (b, l) <- getInput case tryCppLine l b of Just (cppBStr, l', b') -> let cppTok = T.Token { tkType = TkCpp , tkValue = cppBStr , tkSpan = mkRealSrcSpan l l' } - in setInput (b', l') *> pure ([cppTok], False) - _ -> empty + in setInput (b', l') *> pure (Just ([cppTok], False)) + _ -> return Nothing -- | Try to parse a regular old token (can fail) - parsePlainTok :: Bool -> P ([T.Token], Bool) -- return list is only ever 0-2 elements + parsePlainTok :: Bool -> MaybeT P ([T.Token], Bool) -- return list is only ever 0-2 elements parsePlainTok inPrag = do - (bInit, lInit) <- getInput - L sp tok <- Lexer.lexer False return - (bEnd, _) <- getInput + (bInit, lInit) <- lift getInput + L sp tok <- tryP (Lexer.lexer False return) + (bEnd, _) <- lift getInput case sp of UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed - RealSrcSpan rsp -> do + RealSrcSpan rsp _ -> do let typ = if inPrag then TkPragma else classify tok - RealSrcLoc lStart = srcSpanStart sp -- safe since @sp@ is real + RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real (spaceBStr, bStart) = spanPosition lInit lStart bInit inPragDef = inPragma inPrag tok @@ -102,24 +108,24 @@ parse dflags fpath bs = case unP (go False []) initState of -- Update internal line + file position if this is a LINE pragma ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do - L _ (ITinteger (IL { il_value = line })) <- wrappedLexer - L _ (ITstring _ file) <- wrappedLexer - L spF ITclose_prag <- wrappedLexer + L _ (ITinteger (IL { il_value = line })) <- tryP wrappedLexer + L _ (ITstring _ file) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) - (bEnd'', _) <- getInput - setInput (bEnd'', newLoc) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) pure (bEnd'', False) -- Update internal column position if this is a COLUMN pragma ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do - L _ (ITinteger (IL { il_value = col })) <- wrappedLexer - L spF ITclose_prag <- wrappedLexer + L _ (ITinteger (IL { il_value = col })) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) - (bEnd'', _) <- getInput - setInput (bEnd'', newLoc) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) pure (bEnd'', False) @@ -149,21 +155,20 @@ parse dflags fpath bs = case unP (go False []) initState of -- | Get the input getInput :: P (StringBuffer, RealSrcLoc) -getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) +getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, psRealLoc srcLoc) -- | Set the input setInput :: (StringBuffer, RealSrcLoc) -> P () -setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) () +setInput (buf, srcLoc) = + P $ \p@PState{ loc = PsLoc _ buf_loc } -> + POk (p { buffer = buf, loc = PsLoc srcLoc buf_loc }) () +tryP :: P a -> MaybeT P a +tryP (P f) = MaybeT $ P $ \s -> case f s of + POk s' a -> POk s' (Just a) + PFailed _ -> POk s Nothing --- | Orphan instance that adds backtracking to 'P' -instance Alternative P where - empty = addFatalError noSrcSpan (text "Alterative.empty") - P x <|> P y = P $ \s -> case x s of { p@POk{} -> p - ; _ -> y s } - --- | Try a parser. If it fails, backtrack and return the pure value. -tryOrElse :: a -> P a -> P a +tryOrElse :: Alternative f => a -> f a -> f a tryOrElse x p = p <|> pure x -- | Classify given tokens as appropriate Haskell token type. @@ -236,7 +241,6 @@ classify tok = ITcolumn_prag {} -> TkPragma ITscc_prag {} -> TkPragma ITgenerated_prag {} -> TkPragma - ITcore_prag {} -> TkPragma ITunpack_prag {} -> TkPragma ITnounpack_prag {} -> TkPragma ITann_prag {} -> TkPragma @@ -261,14 +265,17 @@ classify tok = ITvbar -> TkGlyph ITlarrow {} -> TkGlyph ITrarrow {} -> TkGlyph + ITlolly {} -> TkGlyph ITat -> TkGlyph ITtilde -> TkGlyph ITdarrow {} -> TkGlyph ITminus -> TkGlyph + ITprefixminus -> TkGlyph ITbang -> TkGlyph ITdot -> TkOperator ITstar {} -> TkOperator ITtypeApp -> TkGlyph + ITpercent -> TkGlyph ITbiglam -> TkGlyph @@ -321,10 +328,8 @@ classify tok = ITcloseQuote {} -> TkSpecial ITopenTExpQuote {} -> TkSpecial ITcloseTExpQuote -> TkSpecial - ITidEscape {} -> TkUnknown - ITparenEscape -> TkSpecial - ITidTyEscape {} -> TkUnknown - ITparenTyEscape -> TkSpecial + ITdollar -> TkSpecial + ITdollardollar -> TkSpecial ITtyQuote -> TkSpecial ITquasiQuote {} -> TkUnknown ITqQuasiQuote {} -> TkUnknown @@ -377,7 +382,6 @@ inPragma False tok = ITcolumn_prag {} -> True ITscc_prag {} -> True ITgenerated_prag {} -> True - ITcore_prag {} -> True ITunpack_prag {} -> True ITnounpack_prag {} -> True ITann_prag {} -> True diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 404cb9d0..12f37ced 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -12,12 +12,13 @@ import Haddock.Backends.Hyperlinker.Utils import qualified Data.ByteString as BS -import HieTypes -import Module ( ModuleName, moduleNameString ) -import Name ( getOccString, isInternalName, Name, nameModule, nameUnique ) -import SrcLoc -import Unique ( getKey ) -import Encoding ( utf8DecodeByteString ) +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils ( isEvidenceContext , emptyNodeInfo ) +import GHC.Unit.Module ( ModuleName, moduleNameString ) +import GHC.Types.Name ( getOccString, isInternalName, Name, nameModule, nameUnique ) +import GHC.Types.SrcLoc +import GHC.Types.Unique ( getKey ) +import GHC.Utils.Encoding ( utf8DecodeByteString ) import System.FilePath.Posix ((</>)) @@ -105,6 +106,7 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of _ -> go nodeChildren toks where + nodeInfo = maybe emptyNodeInfo id (Map.lookup SourceInfo $ getSourcedNodeInfo sourcedNodeInfo) go _ [] = mempty go [] xs = foldMap renderToken xs go (cur:rest) xs = @@ -139,8 +141,9 @@ richToken srcs details Token{..} contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details - -- pick an arbitary identifier to hyperlink with - identDet = Map.lookupMin . nodeIdentifiers $ details + -- pick an arbitary non-evidence identifier to hyperlink with + identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details + notEvidence = not . any isEvidenceContext . identInfo -- If we have name information, we can make links linked = case identDet of @@ -163,7 +166,8 @@ annotate ni content = | otherwise = mempty annotation = typ ++ identTyps typ = unlines (nodeType ni) - typedIdents = [ (n,t) | (n, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ] + typedIdents = [ (n,t) | (n, c@(identType -> Just t)) <- Map.toList $ nodeIdentifiers ni + , not (any isEvidenceContext $ identInfo c) ] identTyps | length typedIdents > 1 || null (nodeType ni) = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents @@ -176,17 +180,19 @@ richTokenStyle :: Bool -- ^ are we lacking a type annotation? -> ContextInfo -- ^ in what context did this token show up? -> [StyleClass] -richTokenStyle True Use = ["hs-type"] -richTokenStyle False Use = ["hs-var"] -richTokenStyle _ RecField{} = ["hs-var"] -richTokenStyle _ PatternBind{} = ["hs-var"] -richTokenStyle _ MatchBind{} = ["hs-var"] -richTokenStyle _ TyVarBind{} = ["hs-type"] -richTokenStyle _ ValBind{} = ["hs-var"] -richTokenStyle _ TyDecl = ["hs-type"] -richTokenStyle _ ClassTyDecl{} = ["hs-type"] -richTokenStyle _ Decl{} = ["hs-var"] -richTokenStyle _ IEThing{} = [] -- could be either a value or type +richTokenStyle True Use = ["hs-type"] +richTokenStyle False Use = ["hs-var"] +richTokenStyle _ RecField{} = ["hs-var"] +richTokenStyle _ PatternBind{} = ["hs-var"] +richTokenStyle _ MatchBind{} = ["hs-var"] +richTokenStyle _ TyVarBind{} = ["hs-type"] +richTokenStyle _ ValBind{} = ["hs-var"] +richTokenStyle _ TyDecl = ["hs-type"] +richTokenStyle _ ClassTyDecl{} = ["hs-type"] +richTokenStyle _ Decl{} = ["hs-var"] +richTokenStyle _ IEThing{} = [] -- could be either a value or type +richTokenStyle _ EvidenceVarBind{} = [] +richTokenStyle _ EvidenceVarUse{} = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 612f3f08..b093b5a4 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -18,11 +18,11 @@ import Haddock.Utils import Haddock.Backends.Xhtml.Utils import GHC -import HieTypes ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) -import IfaceType -import Name ( getOccFS, getOccString ) -import Outputable ( showSDoc ) -import Var ( VarBndr(..) ) +import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) +import GHC.Iface.Type +import GHC.Types.Name ( getOccFS, getOccString ) +import GHC.Utils.Outputable( showSDoc ) +import GHC.Types.Var ( VarBndr(..) ) import System.FilePath.Posix ((</>), (<.>)) @@ -82,9 +82,9 @@ lineFormat :: String lineFormat = "line-%{LINE}" --- * HIE file procesddsing +-- * HIE file processing --- This belongs in GHC's HieUtils... +-- This belongs in GHC.Iface.Ext.Utils... -- | Pretty-printed type, ready to be turned into HTML by @xhtml@ type PrintedType = String @@ -129,8 +129,8 @@ recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t - go (HFunTy a b) = IfaceFunTy VisArg a b - go (HQualTy con b) = IfaceFunTy InvisArg con b + go (HFunTy w a b) = IfaceFunTy VisArg w a b + go (HQualTy con b) = IfaceFunTy InvisArg many_ty con b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 024a6c51..df81fd6e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -21,16 +21,17 @@ import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils -import Pretty hiding (Doc, quote) -import qualified Pretty +import GHC.Utils.Ppr hiding (Doc, quote) +import qualified GHC.Utils.Ppr as Pretty -import BasicTypes ( PromotionFlag(..) ) +import GHC.Types.Basic ( PromotionFlag(..) ) import GHC -import OccName -import Name ( nameOccName ) -import RdrName ( rdrNameOcc ) -import FastString ( unpackFS ) -import Outputable ( panic) +import GHC.Types.Name.Occurrence +import GHC.Types.Name ( nameOccName ) +import GHC.Types.Name.Reader ( rdrNameOcc ) +import GHC.Core.Type ( Specificity(..) ) +import GHC.Data.FastString ( unpackFS ) +import GHC.Utils.Outputable ( panic) import qualified Data.Map as Map import System.Directory @@ -356,8 +357,6 @@ ppFamDecl associated doc instances decl unicode = , equals , ppType unicode (unLoc rhs) ] - ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec - ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec instancesBit = ppDocInstances unicode instances @@ -366,7 +365,6 @@ ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print -> Bool -- ^ unicode -> Bool -- ^ is the family associated? -> LaTeX -ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info @@ -389,7 +387,6 @@ ppFamHeader (FamilyDecl { fdLName = L _ name NoSig _ -> empty KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr - XFamilyResultSig nec -> noExtCon nec injAnn = case injectivity of Nothing -> empty @@ -486,9 +483,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args _n leader (HsForAllTy _ fvf tvs ltype) + do_args _n leader (HsForAllTy _ tele ltype) = [ ( decltt leader - , decltt (ppForAllPart unicode tvs fvf) + , decltt (ppHsForAllTelescope tele unicode) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) @@ -496,13 +493,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ , decltt (ppLContextNoArrow lctxt unicode) <+> nl ) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) + do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let latex = ppSideBySideField subdocs unicode field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy _ lt r) + do_args n leader (HsFunTy _ _w lt r) = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) : do_largs (n+1) (arrow unicode) r do_args n leader t @@ -525,13 +522,20 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty --- | Pretty-print type variables. -ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) +ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX +ppHsForAllTelescope tele unicode = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot + + +ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarNameI) tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit +tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -743,7 +747,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: Bool -- ^ print explicit foralls - -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables -> HsContext DocNameI -- ^ context -> Bool -- ^ unicode -> LaTeX @@ -751,7 +755,7 @@ ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where ppForall | null tvs || not forall_ = empty - | otherwise = ppForAllPart unicode tvs ForallInvis + | otherwise = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode ppCtxt | null ctxt = empty @@ -795,7 +799,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc - , hsep (map (ppLParendType unicode) args) + , hsep (map (ppLParendType unicode . hsScaledThing) args) ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' @@ -805,9 +809,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = InfixCon arg1 arg2 | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ - , ppLParendType unicode arg1 + , ppLParendType unicode (hsScaledThing arg1) , ppOccInfix - , ppLParendType unicode arg2 + , ppLParendType unicode (hsScaledThing arg2) ] ConDeclGADT{} @@ -817,9 +821,8 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ] - XConDecl nec -> noExtCon nec - fieldPart = case (con, getConArgs con) of + fieldPart = case (con, getConArgsI con) of -- Record style GADTs (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] @@ -827,10 +830,10 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = (_, RecCon (L _ fields)) -> doRecordFields fields -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args + (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2] + (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) _ -> empty @@ -851,7 +854,6 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ] - XConDecl nec -> noExtCon nec -- don't use "con_doc con", in case it's reconstructed from a .hi file, @@ -871,7 +873,6 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -ppSideBySideField _ _ (XConDeclField nec) = noExtCon nec -- | Pretty-print a bundled pattern synonym @@ -924,7 +925,8 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument" -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX +ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => + Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX ppAppDocNameTyVarBndrs unicode n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc) where @@ -1034,11 +1036,21 @@ ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode ki ppLHsTypeArg _ (HsArgPar _) = text "" -ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX -ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name -ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind) -ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec +class RenderableBndrFlag flag where + ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX + +instance RenderableBndrFlag () where + ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + +instance RenderableBndrFlag Specificity where + ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name + ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) = + braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) @@ -1046,30 +1058,21 @@ ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocNameI -> LaTeX ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode - -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX -ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv - where - tvs' = ppTyVars unicode tvs - fv = case fvf of - ForallVis -> text "\\ " <> arrow unicode - ForallInvis -> dot - ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode - = sep [ ppForAllPart unicode tvs fvf +ppr_mono_ty (HsForAllTy _ tele ty) unicode + = sep [ ppHsForAllTelescope tele unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode , ppr_mono_lty ty unicode ] -ppr_mono_ty (HsFunTy _ ty1 ty2) u +ppr_mono_ty (HsFunTy _ _ ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arrow u <+> ppr_mono_lty ty2 u ] @@ -1078,7 +1081,7 @@ ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind +ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy v _) _ = absurd v diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 541f40c4..f8c22e0a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -49,15 +49,16 @@ import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) import Data.Ord ( comparing ) -import DynFlags (Language(..)) +import GHC.Driver.Session (Language(..)) import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) -import Name +import GHC.Types.Name +import GHC.Unit.State -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- -ppHtml :: DynFlags +ppHtml :: UnitState -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] @@ -77,7 +78,7 @@ ppHtml :: DynFlags -> Bool -- ^ Also write Quickjump index -> IO () -ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue +ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode pkg qual debug withQuickjump = do @@ -86,7 +87,7 @@ ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue visible i = OptHide `notElem` ifaceOptions i when (isNothing maybe_contents_url) $ - ppHtmlContents dflags odir doctitle maybe_package + ppHtmlContents state odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents @@ -258,7 +259,7 @@ moduleInfo iface = ppHtmlContents - :: DynFlags + :: UnitState -> FilePath -> String -> Maybe String @@ -272,14 +273,14 @@ ppHtmlContents -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () -ppHtmlContents dflags odir doctitle _maybe_package +ppHtmlContents state odir doctitle _maybe_package themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do - let tree = mkModuleTree dflags showPkgs + let tree = mkModuleTree state showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces , not (instIsSig iface)] - sig_tree = mkModuleTree dflags showPkgs + sig_tree = mkModuleTree state showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces , instIsSig iface] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 30b8d43e..eeb9fa94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -35,12 +35,13 @@ import Data.Maybe import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) -import BasicTypes (PromotionFlag(..), isPromoted) +import GHC.Core.Type ( Specificity(..) ) +import GHC.Types.Basic (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) import GHC.Exts -import Name -import BooleanFormula -import RdrName ( rdrNameOcc ) +import GHC.Types.Name +import GHC.Data.BooleanFormula +import GHC.Types.Name.Reader ( rdrNameOcc ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -151,8 +152,10 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy _ fvf tvs ltype) - = do_largs n (leader <+> ppForAllPart unicode qual tvs fvf) ltype + do_args n leader (HsForAllTy _ tele ltype) + = do_largs n leader' ltype + where + leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -161,14 +164,14 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) + do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (ldr <+> html, mdoc, subs) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy _ lt r) + do_args n leader (HsFunTy _ _w lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r @@ -209,7 +212,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge -- | Pretty-print type variables. -ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html] +ppTyVars :: RenderableBndrFlag flag => + Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs @@ -305,8 +309,6 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod , Nothing , [] ) - ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec - ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec -- | Print a pseudo family declaration @@ -331,7 +333,6 @@ ppFamHeader :: Bool -- ^ is a summary -> Bool -- ^ is an associated type -> FamilyDecl DocNameI -- ^ family declaration -> Unicode -> Qualification -> Html -ppFamHeader _ _ (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader summary associated (FamilyDecl { fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity @@ -371,7 +372,6 @@ ppResultSig result unicode qual = case result of NoSig _ -> noHtml KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr - XFamilyResultSig nec -> noExtCon nec -------------------------------------------------------------------------------- @@ -390,7 +390,8 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html +ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => + Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where @@ -492,7 +493,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t +++ shortSubDecls False ( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats - , let doc = lookupAnySubdoc (unLoc $ fdLName $ unLoc at) subdocs ] ++ + , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ -- ToDo: add associated type defaults @@ -517,9 +518,8 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) - , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs - , tcdATs = ats, tcdATDefs = atsDefs }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection curname pkg qual d @@ -603,7 +603,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] + [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -768,7 +768,6 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False - XConDecl{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames @@ -802,7 +801,6 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False - XConDecl{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -854,14 +852,14 @@ ppShortConstrParts summary dataInst con unicode qual -- Prefix constructor, e.g. 'Just a' PrefixCon args -> - ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) -> - ( header_ <+> ppOcc <+> char '{' + ( header_ +++ ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ] @@ -870,9 +868,9 @@ ppShortConstrParts summary dataInst con unicode qual -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> - ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix - , ppLParendType unicode qual HideEmptyContexts arg2 + , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) ] , noHtml , noHtml @@ -884,7 +882,6 @@ ppShortConstrParts summary dataInst con unicode qual , noHtml , noHtml ) - XConDecl nec -> noExtCon nec where occ = map (nameOccName . getName . unLoc) $ getConNamesI con @@ -928,7 +925,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) PrefixCon args | hasArgDocs -> header_ <+> ppOcc <+> fixity | otherwise -> hsep [ header_ <+> ppOcc - , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) + , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) , fixity ] @@ -938,9 +935,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 | hasArgDocs -> header_ <+> ppOcc <+> fixity - | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1 + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) , ppOccInfix - , ppLParendType unicode qual HideEmptyContexts arg2 + , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) , fixity ] @@ -953,9 +950,8 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] - XConDecl nec -> noExtCon nec - fieldPart = case (con, getConArgs con) of + fieldPart = case (con, getConArgsI con) of -- Record style GADTs (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] @@ -976,13 +972,12 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) doConstrArgsWithDocs args = subFields pkg qual $ case con of ConDeclH98{} -> [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, []) - | (i, arg) <- zip [0..] args + | (i, arg) <- zip [0..] (map hsScaledThing args) , let mdoc = Map.lookup i argDocs ] ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts - XConDecl nec -> noExtCon nec -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. @@ -993,7 +988,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: Bool -- ^ print explicit foralls - -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables -> HsContext DocNameI -- ^ context -> Unicode -> Qualification -> Html @@ -1001,7 +996,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt where ppForall | null tvs || not forall_ = noHtml - | otherwise = ppForAllPart unicode qual tvs ForallInvis + | otherwise = ppForAllPart unicode qual (HsForAllInvis noExtField tvs) ppCtxt | null ctxt = noHtml @@ -1026,14 +1021,12 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst -ppSideBySideField _ _ _ (XConDeclField nec) = noExtCon nec ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -ppShortField _ _ _ (XConDeclField nec) = noExtCon nec -- | Pretty print an expanded pattern (for bundled patterns) @@ -1134,13 +1127,28 @@ ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode qual emptyCtxts ki ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" -ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html -ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = - ppDocName qual Raw False name -ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> - ppLKind unicode qual kind) -ppHsTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec + +class RenderableBndrFlag flag where + ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html + +instance RenderableBndrFlag () where + ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) = + ppDocName qual Raw False name + ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + +instance RenderableBndrFlag Specificity where + ppHsTyVarBndr _ qual (UserTyVar _ SpecifiedSpec (L _ name)) = + ppDocName qual Raw False name + ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = + braces $ ppDocName qual Raw False name + ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = + parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = + braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> + ppLKind unicode qual kind) ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) @@ -1155,16 +1163,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = case unLoc t of - HsForAllTy _ _ _ s -> hasNonEmptyContext s - HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True - HsFunTy _ _ s -> hasNonEmptyContext s + HsForAllTy _ _ s -> hasNonEmptyContext s + HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of - HsForAllTy _ _ _ s -> isFirstContextEmpty s - HsQualTy _ cxt _ -> null (unLoc cxt) - HsFunTy _ _ s -> isFirstContextEmpty s + HsForAllTy _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False @@ -1175,21 +1183,21 @@ ppPatSigType unicode qual typ = let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ -ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> Html -ppForAllPart unicode qual tvs fvf = hsep (forallSymbol unicode : tvs') +++ fv - where - tvs' = ppTyVars unicode qual tvs - fv = case fvf of - ForallVis -> spaceHtml +++ arrow unicode - ForallInvis -> dot +ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html +ppForAllPart unicode qual tele = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ + spaceHtml +++ arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode qual emptyCtxts - = ppForAllPart unicode qual tvs fvf <+> ppr_mono_lty ty unicode qual emptyCtxts +ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts + = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts @@ -1205,7 +1213,7 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ | otherwise = ppDocName q Prefix True name ppr_mono_ty (HsStarTy _ isUni) u _ _ = toHtml (if u || isUni then "★" else "*") -ppr_mono_ty (HsFunTy _ ty1 ty2) u q e = +ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e = hsep [ ppr_mono_lty ty1 u q HideEmptyContexts , arrow u <+> ppr_mono_lty ty2 u q e ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 0d7accfc..378d0559 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -32,7 +32,7 @@ import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) import GHC -import Name +import GHC.Types.Name parHtmlMarkup :: Qualification -> Bool diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 4535b897..d61d6d9b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -50,9 +50,9 @@ import qualified Data.Map as Map import Text.XHtml hiding ( name, title, quote ) import Data.Maybe (fromMaybe) -import FastString ( unpackFS ) +import GHC.Data.FastString ( unpackFS ) import GHC -import Name (nameOccName) +import GHC.Types.Name (nameOccName) -------------------------------------------------------------------------------- -- * Sections of the document @@ -167,7 +167,7 @@ subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRo : map (cell . (td <<)) subs linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html - linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn + linkHtml loc@(RealSrcSpan _ _) mdl dn = links lnks loc splice mdl dn linkHtml _ _ _ = noHtml subBlock :: [Html] -> Maybe Html @@ -310,9 +310,9 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(D -- 'mdl'' is a way of "overriding" the module. Without it, instances -- will point to the module defining the class/family, which is wrong. origMod = fromMaybe (nameModule n) mdl' - origPkg = moduleUnitId origMod + origPkg = moduleUnit origMod fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) + RealSrcSpan l _ -> unpackFS (srcSpanFile l) UnhelpfulSpan _ -> error "links: UnhelpfulSpan" links _ _ _ _ _ = noHtml diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 6a047747..8553cdfb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -28,9 +28,9 @@ import qualified Data.Map as M import Data.List ( stripPrefix ) import GHC hiding (LexicalFixity(..)) -import Name -import RdrName -import FastString (unpackFS) +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Data.FastString (unpackFS) -- | Indicator of how to render a 'DocName' into 'Html' diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs index d1561791..e3fd2d5a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -23,7 +23,7 @@ import GHC -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index c3acb6df..f5f64f51 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -38,9 +38,9 @@ import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml -import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module, ModuleName, moduleName, moduleNameString ) -import Name ( getOccString, nameOccName, isValOcc ) +import GHC ( SrcSpan(..), srcSpanStartLine, Name ) +import GHC.Unit.Module ( Module, ModuleName, moduleName, moduleNameString ) +import GHC.Types.Name ( getOccString, nameOccName, isValOcc ) -- | Replace placeholder string elements with provided values. @@ -75,7 +75,7 @@ spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run Nothing -> "" Just span_ -> case span_ of - RealSrcSpan span__ -> + RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 1a1e95bd..980af379 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -19,44 +19,49 @@ module Haddock.Convert ( PrintRuntimeReps(..), ) where -import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) +#include "HsVersions.h" + +import GHC.Data.Bag ( emptyBag ) +import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..) , PromotionFlag(..), DefMethSpec(..) ) -import Class -import CoAxiom -import ConLike +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike import Data.Either (lefts, rights) -import DataCon -import FamInstEnv +import GHC.Core.DataCon +import GHC.Core.FamInstEnv import GHC.Hs -import Name -import NameSet ( emptyNameSet ) -import RdrName ( mkVarUnqual ) -import PatSyn -import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan ) -import TcType -import TyCon -import Type -import TyCoRep -import TysPrim ( alphaTyVars ) -import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName +import GHC.Types.Name +import GHC.Types.Name.Set ( emptyNameSet ) +import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Core.PatSyn +import GHC.Tc.Utils.TcType +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Builtin.Types.Prim ( alphaTyVars ) +import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName , unitTy, promotedNilDataCon, promotedConsDataCon ) -import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey +import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) -import Unique ( getUnique ) -import Util ( chkAppend, dropList, filterByList, filterOut ) -import Var -import VarSet +import GHC.Types.Unique ( getUnique ) +import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength + , filterByList, filterOut ) +import GHC.Utils.Outputable ( assertPanic ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.SrcLoc +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) -import Data.Maybe ( catMaybes, maybeToList ) +import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) -- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check --- out Note [Defaulting RuntimeRep variables] in IfaceType.hs for the +-- out Note [Defaulting RuntimeRep variables] in GHC.Iface.Type for the -- motivation. data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show @@ -85,6 +90,15 @@ tyThingToLHsDecl prr t = case t of extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" + cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n + cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField + (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind + cvt (XTyVarBndr nec) = noExtCon nec + + -- | Convert a LHsTyVarBndr to an equivalent LHsType. + hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) + hsLTyVarBndrToType = mapLoc cvt + extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn extractFamDefDecl fd rhs = TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd) @@ -127,7 +141,7 @@ tyThingToLHsDecl prr t = case t of , tcdATs = atFamDecls , tcdATDefs = catMaybes atDefFamDecls , tcdDocs = [] --we don't have any docs at this point - , tcdCExt = placeHolderNamesTc } + , tcdCExt = emptyNameSet } | otherwise -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField @@ -137,7 +151,7 @@ tyThingToLHsDecl prr t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] - (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) @@ -190,7 +204,7 @@ synifyTyCon prr _coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv - tyVarKinds + (map scaledThing tyVarKinds) alphaTyVars --a, b, c... which are unfortunately all kind * } @@ -205,12 +219,12 @@ synifyTyCon prr _coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } - , tcdDExt = DataDeclRn False placeHolderNamesTc } + , tcdDExt = DataDeclRn False emptyNameSet } where -- tyConTyVars doesn't work on fun/prim, but we can make them up: mk_hs_tv realKind fakeTyVar - | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField (noLoc (getName fakeTyVar)) - | otherwise = noLoc $ KindedTyVar noExtField (noLoc (getName fakeTyVar)) (synifyKindSig realKind) + | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar)) + | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind) conKind = defaultType prr (tyConKind tc) tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind @@ -298,7 +312,7 @@ synifyTyCon _prr coax tc DataDecl { tcdLName = name, tcdTyVars = tyvars , tcdFixity = synifyFixity name , tcdDataDefn = defn - , tcdDExt = DataDeclRn False placeHolderNamesTc } + , tcdDExt = DataDeclRn False emptyNameSet } dataConErrs -> Left $ unlines dataConErrs -- | In this module, every TyCon being considered has come from an interface @@ -334,7 +348,7 @@ synifyFamilyResultSig Nothing kind | isLiftedTypeKind kind = noLoc $ NoSig noExtField | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -351,7 +365,7 @@ synifyDataCon use_gadt_syntax dc = name = synifyName dc -- con_qvars means a different thing depending on gadt-syntax (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc - user_tvs = dataConUserTyVars dc -- Used for GADT data constructors + user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing @@ -359,7 +373,7 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType [] ty + let tySyn = synifyType WithinType [] (scaledThing ty) in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExtField bang' tySyn) @@ -372,19 +386,19 @@ synifyDataCon use_gadt_syntax dc = hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" (True,False) -> return $ RecCon (noLoc field_tys) - (False,False) -> return $ PrefixCon linear_tys + (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys) (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon a b + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) _ -> Left "synifyDataCon: infix with non-2 args?" -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_g_ext = noExtField + ConDeclGADT { con_g_ext = [] , con_names = [name] - , con_forall = noLoc $ not $ null user_tvs - , con_qvars = synifyTyVars user_tvs + , con_forall = noLoc $ not $ null user_tvbndrs + , con_qvars = map synifyTyVarBndr user_tvbndrs , con_mb_cxt = ctx , con_args = hat , con_res_ty = synifyType WithinType [] res_ty @@ -393,7 +407,7 @@ synifyDataCon use_gadt_syntax dc = ConDeclH98 { con_ext = noExtField , con_name = name , con_forall = noLoc False - , con_ex_tvs = map synifyTyVar ex_tvs + , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } @@ -438,21 +452,26 @@ synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = HsQTvs { hsq_ext = [] , hsq_explicit = map synifyTyVar ktvs } -synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn -synifyTyVar = synifyTyVar' emptyVarSet +synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn +synifyTyVar = synify_ty_var emptyVarSet () + +synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr = synifyTyVarBndr' emptyVarSet --- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind +synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv + +-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind -- signatures (even if they don't have the lifted type kind). -synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn -synifyTyVar' no_kinds tv +synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn +synify_ty_var no_kinds flag tv | isLiftedTypeKind kind || tv `elemVarSet` no_kinds - = noLoc (UserTyVar noExtField (noLoc name)) - | otherwise = noLoc (KindedTyVar noExtField (noLoc name) (synifyKindSig kind)) + = noLoc (UserTyVar noExtField flag (noLoc name)) + | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv - -- | Annotate (with HsKingSig) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to synify type patterns for poly-kinded tyvars in @@ -620,38 +639,57 @@ synifyType _ vs ty@(AppTy {}) = let filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) ty_args in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' -synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty -synifyType _ vs (FunTy VisArg t1 t2) = let +synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty +synifyType _ vs (FunTy VisArg w t1 t2) = let s1 = synifyType WithinType vs t1 s2 = synifyType WithinType vs t2 - in noLoc $ HsFunTy noExtField s1 s2 + w' = synifyMult vs w + in noLoc $ HsFunTy noExtField w' s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = - synifyForAllType s argf vs forallty + case argf of + Required -> synifyVisForAllType vs forallty + Invisible _ -> synifySigmaType s vs forallty synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" --- | Process a 'Type' which starts with a forall or a constraint into --- an 'HsType' -synifyForAllType +-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType' +synifyVisForAllType + :: [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyVisForAllType vs ty = + let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty + + sTvs = map synifyTyVarBndr tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) [rho] + + in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs + , hst_xforall = noExtField + , hst_body = synifyType WithinType (tvs' ++ vs) rho } + +-- | Process a 'Type' which starts with an invisible @forall@ or a constraint +-- into an 'HsType' +synifySigmaType :: SynifyTypeState -- ^ what to do with the 'forall' - -> ArgFlag -- ^ the visibility of the @forall@ -> [TyVar] -- ^ free variables in the type to convert -> Type -- ^ the forall type to convert -> LHsType GhcRn -synifyForAllType s argf vs ty = - let (tvs, ctx, tau) = tcSplitSigmaTySameVisPreserveSynonyms argf ty +synifySigmaType s vs ty = + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synifyType WithinType (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_fvf = argToForallVisFlag argf - , hst_bndrs = sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } - sTvs = map synifyTyVar tvs + sTvs = map synifyTyVarBndr tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall @@ -667,21 +705,20 @@ synifyForAllType s argf vs ty = ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau - -- | Put a forall in if there are any type variables which require -- explicit kind annotations or if the inferred type variable order -- would be different. implicitForAll :: [TyCon] -- ^ type constructors that determine their args kinds -> [TyVar] -- ^ free variables in the type to convert - -> [TyVar] -- ^ type variable binders in the forall + -> [InvisTVBinder] -- ^ type variable binders in the forall -> ThetaType -- ^ constraints right after the forall -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type -> Type -- ^ inner type -> LHsType GhcRn implicitForAll tycons vs tvs ctx synInner tau | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy - | tvs' /= tvs = noLoc sTy + | tvs' /= (binderVars tvs) = noLoc sTy | otherwise = noLoc sPhi where sRho = synInner (tvs' ++ vs) tau @@ -690,13 +727,12 @@ implicitForAll tycons vs tvs ctx synInner tau = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExtField , hst_body = synInner (tvs' ++ vs) tau } - sTy = HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = sTvs + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs , hst_xforall = noExtField , hst_body = noLoc sPhi } no_kinds_needed = noKindTyVars tycons tau - sTvs = map (synifyTyVar' no_kinds_needed) tvs + sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall @@ -725,7 +761,7 @@ noKindTyVars ts ty = let args = map (noKindTyVars ts) xs func = case f of TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var) - , xsKinds `eqTypes` map typeKind xs + , map scaledThing xsKinds `eqTypes` map typeKind xs , isLiftedTypeKind outKind -> unitVarSet var TyConApp t ks | t `elem` ts @@ -734,13 +770,23 @@ noKindTyVars ts ty _ -> noKindTyVars ts f in unionVarSets (func : args) noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t -noKindTyVars ts (FunTy _ t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 +noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet` + noKindTyVars ts t1 `unionVarSet` + noKindTyVars ts t2 noKindTyVars ts (CastTy t _) = noKindTyVars ts t noKindTyVars _ _ = emptyVarSet +synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn +synifyMult vs t = case t of + One -> HsLinearArrow NormalSyntax + Many -> HsUnrestrictedArrow NormalSyntax + ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) + + + synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = - let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps ts = maybeToList (tyConAppTyCon_maybe res_ty) -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", @@ -811,7 +857,7 @@ synifyFamInst fi opaque = do eta_expanded_lhs -- eta-expand lhs types, because sometimes data/newtype -- instances are eta-reduced; See Trac #9692 - -- See Note [Eta reduction for data family axioms] in TcInstDcls in GHC + -- See Note [Eta reduction for data family axioms] in GHC.Tc.TyCl.Instance in GHC | DataFamilyInst rep_tc <- fam_flavor = let (_, rep_tc_args) = splitTyConApp fam_rhs etad_tyvars = dropList rep_tc_args $ tyConTyVars rep_tc @@ -839,22 +885,54 @@ See https://github.com/haskell/haddock/issues/879 for a bug where this invariant didn't hold. -} --- | A version of 'TcType.tcSplitSigmaTySameVis' that preserves type synonyms. +-- | A version of 'TcType.tcSplitSigmaTy' that: +-- +-- 1. Preserves type synonyms. +-- 2. Returns 'InvisTVBinder's instead of 'TyVar's. -- -- See Note [Invariant: Never expand type synonyms] -tcSplitSigmaTySameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], ThetaType, Type) -tcSplitSigmaTySameVisPreserveSynonyms argf ty = - case tcSplitForAllTysSameVisPreserveSynonyms argf ty of +tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type) +tcSplitSigmaTyPreserveSynonyms ty = + case tcSplitForAllTysInvisPreserveSynonyms ty of (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of (theta, tau) -> (tvs, theta, tau) -- | See Note [Invariant: Never expand type synonyms] -tcSplitForAllTysSameVisPreserveSynonyms :: ArgFlag -> Type -> ([TyVar], Type) -tcSplitForAllTysSameVisPreserveSynonyms supplied_argf ty = split ty ty [] +tcSplitSomeForAllTysPreserveSynonyms :: + (ArgFlag -> Bool) -> Type -> ([TyCoVarBinder], Type) +tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty [] where - split _ (ForAllTy (Bndr tv argf) ty') tvs - | argf `sameVis` supplied_argf = split ty' ty' (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs + | argf_pred argf = split ty' ty' (tvb:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type) +tcSplitForAllTysReqPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty + req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in + ASSERT( req_bndrs `equalLength` all_bndrs ) + (req_bndrs, body) + where + mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder + mk_req_bndr_maybe (Bndr tv argf) = case argf of + Required -> Just $ Bndr tv () + Invisible _ -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type) +tcSplitForAllTysInvisPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty + inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in + ASSERT( inv_bndrs `equalLength` all_bndrs ) + (inv_bndrs, body) + where + mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder + mk_inv_bndr_maybe (Bndr tv argf) = case argf of + Invisible s -> Just $ Bndr tv s + Required -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) @@ -867,5 +945,5 @@ tcSplitPhiTyPreserveSynonyms ty0 = split ty0 [] -- | See Note [Invariant: Never expand type synonyms] tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type) -tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg arg res) = Just (arg, res) +tcSplitPredFunTyPreserveSynonyms_maybe (FunTy InvisArg _ arg res) = Just (arg, res) tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 43fe3e77..10725ee5 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -25,28 +25,27 @@ import Data.Maybe ( mapMaybe ) import Haddock.Types( DocName, DocNameI ) -import BasicTypes ( PromotionFlag(..) ) -import Exception -import FV -import Outputable ( Outputable, panic, showPpr ) -import Name -import NameSet -import Module -import HscTypes +import GHC.Utils.FV as FV +import GHC.Utils.Outputable ( Outputable, panic, showPpr ) +import GHC.Types.Basic (PromotionFlag(..)) +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Driver.Types import GHC -import Class -import DynFlags -import SrcLoc ( advanceSrcLoc ) -import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, - isInvisibleArgFlag ) -import VarSet ( VarSet, emptyVarSet ) -import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) -import TyCoRep ( Type(..) ) -import Type ( isRuntimeRepVar ) -import TysWiredIn( liftedRepDataConTyCon ) - -import StringBuffer ( StringBuffer ) -import qualified StringBuffer as S +import GHC.Core.Class +import GHC.Driver.Session +import GHC.Types.SrcLoc ( advanceSrcLoc ) +import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder + , tyVarKind, updateTyVarKind, isInvisibleArgFlag ) +import GHC.Types.Var.Set ( VarSet, emptyVarSet ) +import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) +import GHC.Core.TyCo.Rep ( Type(..) ) +import GHC.Core.Type ( isRuntimeRepVar ) +import GHC.Builtin.Types( liftedRepDataConTyCon ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) + +import GHC.Data.StringBuffer ( StringBuffer ) +import qualified GHC.Data.StringBuffer as S import Data.ByteString ( ByteString ) import qualified Data.ByteString as BS @@ -58,38 +57,6 @@ moduleString = moduleNameString . moduleName isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] -getMainDeclBinder (TyClD _ d) = [tcdName d] -getMainDeclBinder (ValD _ d) = - case collectHsBindBinders d of - [] -> [] - (name:_) -> [name] -getMainDeclBinder (SigD _ d) = sigNameNoLoc d -getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] -getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - --- Extract the source location where an instance is defined. This is used --- to correlate InstDecls with their Instance/CoAxiom Names, via the --- instanceMap. -getInstLoc :: InstDecl (GhcPass p) -> SrcSpan -getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l -getInstLoc (TyFamInstD _ (TyFamInstDecl - -- Since CoAxioms' Names refer to the whole line for type family instances - -- in particular, we need to dig a bit deeper to pull out the entire - -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l -getInstLoc (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec -getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec -getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn nec)))) = noExtCon nec -getInstLoc (XInstDecl nec) = noExtCon nec -getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec -getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs nec))) = noExtCon nec - - - -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the @@ -147,48 +114,45 @@ isClassD :: HsDecl a -> Bool isClassD (TyClD _ d) = isClassDecl d isClassD _ = False -isValD :: HsDecl a -> Bool -isValD (ValD _ _) = True -isValD _ = False - pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr -nubByName :: (a -> Name) -> [a] -> [a] -nubByName f ns = go emptyNameSet ns - where - go !_ [] = [] - go !s (x:xs) - | y `elemNameSet` s = go s xs - | otherwise = let !s' = extendNameSet s y - in x : go s' xs - where - y = f x - - -- --------------------------------------------------------------------- -- These functions are duplicated from the GHC API, as they must be -- instantiated at DocNameI instead of (GhcPass _). -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) -hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n -hsTyVarBndrName (UserTyVar _ name) = unLoc name -hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name +hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n +hsTyVarBndrName (UserTyVar _ _ name) = unLoc name +hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec +hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName +hsTyVarNameI (UserTyVar _ _ (L _ n)) = n +hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n + +hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName +hsLTyVarNameI = hsTyVarNameI . unLoc + getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] getConNamesI ConDeclGADT {con_names = names} = names -getConNamesI (XConDecl nec) = noExtCon nec hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing hsImplicitBodyI (HsIB { hsib_body = body }) = body -hsImplicitBodyI (XHsImplicitBndrs nec) = noExtCon nec hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI hsSigTypeI = hsImplicitBodyI +mkHsForAllInvisTeleI :: + [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI +mkHsForAllInvisTeleI invis_bndrs = + HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } + +getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI +getConArgsI d = con_args d + getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So @@ -198,9 +162,8 @@ getGADTConType (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_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = hsQTvExplicit qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTeleI qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -209,16 +172,16 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr mkFunTy res_ty pos_args - InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) + InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT -getGADTConType (XConDecl nec) = noExtCon nec getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d] @@ -233,21 +196,19 @@ getMainDeclBinderI _ = [] familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName familyDeclLNameI (FamilyDecl { fdLName = n }) = n -familyDeclLNameI (XFamilyDecl nec) = noExtCon nec tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln -tyClDeclLNameI (XTyClDecl nec) = noExtCon nec tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI -- ------------------------------------- -getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p) +getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the @@ -256,9 +217,8 @@ 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_fvf = ForallInvis - , hst_xforall = noExtField - , hst_bndrs = hsQTvExplicit qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField + , hst_tele = mkHsForAllInvisTele qtvs , hst_body = theta_ty }) | otherwise = theta_ty where @@ -267,16 +227,17 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty +-- tau_ty :: LHsType DocNameI tau_ty = case args of - RecCon flds -> noLoc (HsFunTy noExtField (noLoc (HsRecTy noExtField (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr mkFunTy res_ty pos_args - InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty + PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) + InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField a b) + -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT -getGADTConTypeG (XConDecl nec) = noExtCon nec mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn @@ -291,9 +252,9 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where - go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) + = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField + , hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt ctxt, hst_body = ty }) @@ -301,7 +262,10 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) = L loc (HsQualTy { hst_xqual = noExtField , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + extra_pred :: LHsType GhcRn + extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0)) + + add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn add_ctxt (L loc preds) = L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine @@ -335,7 +299,6 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] @@ -345,7 +308,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] PrefixCon _ -> Just d RecCon fields | all field_avail (unLoc fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) }) + | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc fields) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but @@ -355,8 +318,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_avail (L _ (XConDeclField nec)) = noExtCon nec - field_types flds = [ t | ConDeclField _ _ t _ <- flds ] + + field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ] keep _ = Nothing @@ -413,14 +376,14 @@ reparenTypePrec = go = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) - go p (HsForAllTy x fvf tvs ty) - = paren p PREC_CTX $ HsForAllTy x fvf (map (fmap reparenTyVar) tvs) (reparenLType ty) + go p (HsForAllTy x tele ty) + = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later... in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty) - go p (HsFunTy x ty1 ty2) - = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) + go p (HsFunTy x w ty1 ty2) + = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) go p (HsAppKindTy x fun_ty arg_ki) @@ -456,10 +419,19 @@ reparenType = reparenTypePrec PREC_TOP reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a reparenLType = fmap reparenType +-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') +reparenHsForAllTelescope :: (XParTy a ~ NoExtField) + => HsForAllTelescope a -> HsForAllTelescope a +reparenHsForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x (map (fmap reparenTyVar) bndrs) +reparenHsForAllTelescope v@XHsForAllTelescope{} = v + -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr a -> HsTyVarBndr a -reparenTyVar (UserTyVar x n) = UserTyVar x n -reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind) +reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n +reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') @@ -469,6 +441,18 @@ reparenConDeclField c@XConDeclField{} = c ------------------------------------------------------------------------------- +-- * Located +------------------------------------------------------------------------------- + + +unL :: Located a -> a +unL (L _ x) = x + + +reL :: a -> Located a +reL = L undefined + +------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -542,11 +526,6 @@ modifySessionDynFlags f = do return () --- | A variant of 'gbracket' where the return value from the first computation --- is not required. -gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c -gbracket_ before_ after thing = gbracket before_ (const after) (const thing) - -- Extract the minimal complete definition of a Name, if one exists minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) minimalDef n = do @@ -706,10 +685,10 @@ orderedFVs vs tys = -- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type -- of 'const :: a -> b -> a': -- --- >>> import Name +-- >>> import GHC.Types.Name -- >>> import TyCoRep --- >>> import TysPrim --- >>> import Var +-- >>> import GHC.Builtin.Types.Prim +-- >>> import GHC.Types.Var -- >>> a = TyVarTy alphaTyVar -- >>> b = TyVarTy betaTyVar -- >>> constTy = mkFunTys [a, b] a @@ -728,7 +707,9 @@ tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c -tyCoFVsOfType' (FunTy _ arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c +tyCoFVsOfType' (FunTy _ w arg res) a b c = (tyCoFVsOfType' w `unionFV` + tyCoFVsOfType' res `unionFV` + tyCoFVsOfType' arg) a b c tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c @@ -750,7 +731,7 @@ tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKi ------------------------------------------------------------------------------- -- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to --- 'LiftedType'. See 'defaultRuntimeRepVars' in IfaceType.hs the original such +-- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such -- function working over `IfaceType`'s. defaultRuntimeRepVars :: Type -> Type defaultRuntimeRepVars = go emptyVarEnv @@ -774,8 +755,8 @@ defaultRuntimeRepVars = go emptyVarEnv go subs (TyConApp tc tc_args) = TyConApp tc (map (go subs) tc_args) - go subs (FunTy af arg res) - = FunTy af (go subs arg) (go subs res) + go subs (FunTy af w arg res) + = FunTy af (go subs w) (go subs arg) (go subs res) go subs (AppTy t u) = AppTy (go subs t) (go subs u) @@ -785,3 +766,4 @@ defaultRuntimeRepVars = go emptyVarEnv go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty + diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 6dcfa594..1501919b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -50,18 +50,19 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Text.Printf -import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) -import Digraph -import DynFlags hiding (verbosity) +import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) +import GHC.Data.Graph.Directed +import GHC.Driver.Session hiding (verbosity) import GHC hiding (verbosity) -import HscTypes -import FastString (unpackFS) -import TcRnTypes (tcg_rdr_env) -import Name (nameIsFromExternalPackage, nameOccName) -import OccName (isTcOcc) -import RdrName (unQualOK, gre_name, globalRdrEnvElts) -import ErrUtils (withTimingD) -import DynamicLoading (initializePlugins) +import GHC.Driver.Types +import GHC.Data.FastString (unpackFS) +import GHC.Tc.Types (tcg_rdr_env) +import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) +import GHC.Types.Name.Occurrence (isTcOcc) +import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts) +import GHC.Utils.Error (withTimingD) +import GHC.HsToCore.Docs +import GHC.Runtime.Loader (initializePlugins) #if defined(mingw32_HOST_OS) import System.IO @@ -159,62 +160,63 @@ processModule verbosity modsum flags modMap instIfaceMap = do tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum' - if not $ isBootSummary modsum then do - out verbosity verbose "Creating interface..." - (interface, msgs) <- {-# SCC createIterface #-} - withTimingD "createInterface" (const ()) $ do - runWriterGhc $ createInterface tm flags modMap instIfaceMap - - -- We need to keep track of which modules were somehow in scope so that when - -- Haddock later looks for instances, it also looks in these modules too. - -- - -- See https://github.com/haskell/haddock/issues/469. - hsc_env <- getSession - let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - this_pkg = thisPackage (hsc_dflags hsc_env) - !mods = mkModuleSet [ nameModule name - | gre <- globalRdrEnvElts new_rdr_env - , let name = gre_name gre - , nameIsFromExternalPackage this_pkg name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - - 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)) - else - return Nothing + 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 = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + 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)) -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index ce987b76..6ef0ed19 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -19,7 +19,6 @@ module Haddock.Interface.AttachInstances (attachInstances) where import Haddock.Types import Haddock.Convert -import Haddock.GhcUtils import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) @@ -29,23 +28,24 @@ import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set -import Class -import DynFlags -import CoreSyn (isOrphan) -import ErrUtils -import FamInstEnv +import GHC.Core.Class +import GHC.Driver.Session +import GHC.Core (isOrphan) +import GHC.Utils.Error +import GHC.Core.FamInstEnv import GHC -import InstEnv -import Module ( ModuleSet, moduleSetElts ) -import MonadUtils (liftIO) -import Name -import NameEnv -import Outputable (text, sep, (<+>)) -import SrcLoc -import TyCon -import TyCoRep -import TysPrim( funTyConName ) -import Var hiding (varName) +import GHC.Core.InstEnv +import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts ) +import GHC.Utils.Monad (liftIO) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable (text, sep, (<+>)) +import GHC.Types.SrcLoc +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Builtin.Types.Prim( funTyConName ) +import GHC.Types.Var hiding (varName) +import GHC.HsToCore.Docs type ExportedNames = Set.Set Name type Modules = Set.Set Module @@ -196,13 +196,13 @@ instHead (_, _, cls, args) argCount :: Type -> Int argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ _) = 2 +argCount (FunTy _ _ _ _) = 2 argCount (ForAllTy _ t) = argCount t argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType -simplify (FunTy _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (FunTy _ _ t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 @@ -257,7 +257,7 @@ isTypeHidden expInfo = typeHidden case t of TyVarTy {} -> False AppTy t1 t2 -> typeHidden t1 || typeHidden t2 - FunTy _ t1 t2 -> typeHidden t1 || typeHidden t2 + FunTy _ _ t1 t2 -> typeHidden t1 || typeHidden t2 TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty LitTy _ -> False diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d554eeb3..7fb71d4b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -33,31 +33,30 @@ import Data.Bitraversable import qualified Data.Map as M import qualified Data.Set as S import Data.Map (Map) -import Data.List (find, foldl', sortBy) +import Data.List (find, foldl') import Data.Maybe -import Data.Ord -import Control.Applicative import Control.Monad import Data.Traversable import GHC.Stack (HasCallStack) -import Avail hiding (avail) -import qualified Avail -import qualified Module -import qualified SrcLoc -import ConLike (ConLike(..)) +import GHC.Types.Avail hiding (avail) +import qualified GHC.Types.Avail as Avail +import qualified GHC.Unit.Module as Module +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Core.ConLike (ConLike(..)) import GHC -import HscTypes -import Name -import NameSet -import NameEnv -import Packages ( lookupModuleInAllPackages, PackageName(..) ) -import Bag -import RdrName -import TcRnTypes -import FastString ( unpackFS, bytesFS ) -import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) -import qualified Outputable as O +import GHC.Driver.Types +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.Data.FastString ( unpackFS, bytesFS ) +import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) +import qualified GHC.Utils.Outputable as O +import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) mkExceptionContext :: TypecheckedModule -> String mkExceptionContext = @@ -168,7 +167,7 @@ createInterface tm flags modMap instIfaceMap = !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' let !aliases = - mkAliasMap dflags $ tm_renamed_source tm + mkAliasMap (unitState dflags) $ tm_renamed_source tm modWarn <- liftErrMsg (moduleWarning dflags gre warnings) @@ -213,12 +212,13 @@ createInterface tm flags modMap instIfaceMap = , ifaceDynFlags = dflags } + -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This -- will go in 'ifaceModuleAliases'. -mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap dflags mRenamedSource = +mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap state mRenamedSource = case mRenamedSource of Nothing -> M.empty Just (_,impDecls,_,_) -> @@ -226,7 +226,7 @@ mkAliasMap dflags mRenamedSource = mapMaybe (\(SrcLoc.L _ impDecl) -> do SrcLoc.L _ alias <- ideclAs impDecl return $ - (lookupModuleDyn dflags + (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 @@ -241,7 +241,7 @@ mkAliasMap dflags mRenamedSource = -- them to the user. We should reuse that information; -- or at least reuse the renamed imports, which know what -- they import! - (fmap Module.fsToUnitId $ + (fmap Module.fsToUnit $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) @@ -285,13 +285,13 @@ unrestrictedModuleImports idecls = -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: - DynFlags -> Maybe UnitId -> ModuleName -> Module + UnitState -> Maybe Unit -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = Module.mkModule pkgId mdlName -lookupModuleDyn dflags Nothing mdlName = - case lookupModuleInAllPackages dflags mdlName of +lookupModuleDyn state Nothing mdlName = + case lookupModuleInAllUnits state mdlName of (m,_):_ -> m - [] -> Module.mkModule Module.mainUnitId mdlName + [] -> Module.mkModule Module.mainUnit mdlName ------------------------------------------------------------------------------- @@ -396,9 +396,8 @@ mkMaps dflags pkgName gre instances decls = do , [(Name, Map Int (MDoc Name))] , [(Name, [LHsDecl GhcRn])] ) - mappings (ldecl, docStrs) = do - let L l decl = ldecl - declDoc :: [HsDocString] -> Map Int HsDocString + mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do + let declDoc :: [HsDocString] -> Map Int HsDocString -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs @@ -426,12 +425,13 @@ mkMaps dflags pkgName gre instances decls = do seqList subDocs `seq` seqList subArgs `seq` pure (dm, am, cm) + mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], []) - instanceMap :: Map SrcSpan Name - instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] + instanceMap :: Map RealSrcSpan Name + instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] - names :: SrcSpan -> HsDecl GhcRn -> [Name] - names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + names :: RealSrcSpan -> HsDecl GhcRn -> [Name] + names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2]. where loc = case d of -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and @@ -454,200 +454,13 @@ mkMaps dflags pkgName gre instances decls = do -------------------------------------------------------------------------------- --- | Get all subordinate declarations inside a declaration, and their docs. --- A subordinate declaration is something like the associate type or data --- family of a type class. -subordinates :: InstMap - -> HsDecl GhcRn - -> [(Name, [HsDocString], Map Int HsDocString)] -subordinates instMap decl = case decl of - InstD _ (ClsInstD _ d) -> do - DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = L l _ - , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - - InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) - -> dataSubs (feqn_rhs d) - TyClD _ d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) - _ -> [] - where - classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) - ] - dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] - dataSubs dd = constrs ++ fields ++ derivs - where - cons = map unLoc $ (dd_cons dd) - constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c) - | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) - | RecCon flds <- map getConArgs cons - , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) - , L _ n <- ns ] - derivs = [ (instName, [unLoc doc], M.empty) - | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ - concatMap (unLoc . deriv_clause_tys . unLoc) $ - unLoc $ dd_derivs dd - , Just instName <- [M.lookup l instMap] ] - - extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) - extract_deriv_ty ty = - case dL ty of - -- deriving (forall a. C a {- ^ Doc comment -}) - L l (HsForAllTy{ hst_fvf = ForallInvis - , hst_body = dL->L _ (HsDocTy _ _ doc) }) - -> Just (l, doc) - -- deriving (C a {- ^ Doc comment -}) - L l (HsDocTy _ _ doc) -> Just (l, doc) - _ -> Nothing - --- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> Map Int HsDocString -conArgDocs con = case getConArgs con of - PrefixCon args -> go 0 (map unLoc args ++ ret) - InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) - RecCon _ -> go 1 ret - where - go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys - go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys - go n (_ : tys) = go (n+1) tys - go _ [] = M.empty - - ret = case con of - ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] - _ -> [] - --- | Extract function argument docs from inside top-level decls. -declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString -declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) -declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) -declTypeDocs _ = M.empty - --- | Extract function argument docs from inside types. -typeDocs :: HsType GhcRn -> Map Int HsDocString -typeDocs = go 0 - where - go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) - go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc - go _ _ = M.empty - --- | All the sub declarations of a class (that we handle), ordered by --- source location, with documentation attached if it exists. -classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls - where - decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs (DocD noExtField) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ - sigs = mkDecls tcdSigs (SigD noExtField) class_ - ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ - - --- | The top-level declarations of a module that we care about, --- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -topDecls = - filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap -mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig _ ns f) <- hs_fixds group_, - L _ n <- ns ] - - --- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] -ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ - mkDecls hs_derivds (DerivD noExtField) group_ ++ - mkDecls hs_defds (DefD noExtField) group_ ++ - mkDecls hs_fords (ForD noExtField) group_ ++ - mkDecls hs_docs (DocD noExtField) group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ - mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ - mkDecls (valbinds . hs_valds) (ValD noExtField) group_ - where - typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs - typesigs _ = error "expected ValBindsOut" - - valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds - valbinds _ = error "expected ValBindsOut" - - --- | Take a field of declarations from a data structure and create HsDecls --- using the given constructor -mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] -mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] - - --- | Sort by source location -sortByLoc :: [Located a] -> [Located a] -sortByLoc = sortBy (comparing getLoc) - - --------------------------------------------------------------------------------- --- Filtering of declarations --- --- We filter out declarations that we don't intend to handle later. --------------------------------------------------------------------------------- - - --- | Filter out declarations that we don't handle in Haddock -filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unLoc . fst) - where - isHandled (ForD _ (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True - isHandled (DerivD {}) = True - isHandled (SigD _ d) = isUserLSig (noLoc d) - isHandled (ValD {}) = True - -- we keep doc declarations to be able to get at named docs - isHandled (DocD {}) = True - isHandled _ = False - --- | Go through all class declarations and filter their sub-declarations -filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x - | x@(L loc d, doc) <- decls ] - where - filterClass (TyClD x c) = - TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } - filterClass _ = error "expected TyClD" - - --------------------------------------------------------------------------------- --- Collect docs --- --- To be able to attach the right Haddock comment to the right declaration, --- we sort the declarations by their SrcLoc and "collect" the docs for each --- declaration. --------------------------------------------------------------------------------- - - --- | Collect docs and attach them to the right declarations. -collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] -collectDocs = go Nothing [] - where - go Nothing _ [] = [] - go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) - | Nothing <- prev = go Nothing (str:docs) ds - | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds - go Nothing docs (d:ds) = go (Just d) docs ds - go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) - - finished decl docs rest = (decl, reverse docs) : rest +mkFixMap group_ = + M.fromList [ (n,f) + | L _ (FixitySig _ ns f) <- hsGroupTopLevelFixitySigs group_, + L _ n <- ns ] -- | Build the list of items that will become the documentation, from the @@ -874,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Nothing -> return ([], (noDocForDecl, availNoDocs avail)) -- TODO: If we try harder, we might be able to find -- a Haddock! Look in the Haddocks for each thing in - -- requirementContext (pkgState) + -- requirementContext (unitState) Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) | otherwise -> return ([], (noDocForDecl, availNoDocs avail)) - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap + | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap , Just ds <- M.lookup n (ifaceDeclMap iface) = return (ds, lookupDocs avail warnings (ifaceDocMap iface) @@ -924,10 +737,10 @@ availNoDocs avail = -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. -semToIdMod :: UnitId -> Module -> Module +semToIdMod :: Unit -> Module -> Module semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) - | otherwise = m + | otherwise = m -- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) @@ -1006,8 +819,7 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod = "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule unitId expMod -- Identity module! - unitId = moduleUnitId thisMod + m = mkModule (moduleUnit thisMod) expMod -- Identity module! -- Note [1]: ------------ @@ -1180,9 +992,9 @@ extractPatternSyn nm t tvs cons = extract con = let args = case getConArgs con of - PrefixCon args' -> args' + PrefixCon args' -> (map hsScaledThing args') RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields - InfixCon arg1 arg2 -> [arg1, arg2] + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] typ = longArrow args (data_ty con) typ' = case con of @@ -1192,7 +1004,7 @@ extractPatternSyn nm t tvs cons = in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField x y)) output inputs + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -1209,7 +1021,7 @@ 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 data_ty (getBangType ty)))))) + pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1242,7 +1054,7 @@ mkVisibleNames (_, _, _, instMap) exports opts where subs = map fst (expItemSubDocs e) patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of - InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap + InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 2cacabe1..4e271602 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -5,11 +5,11 @@ module Haddock.Interface.Json ( , renderJson ) where -import BasicTypes -import Json -import Module -import Name -import Outputable +import GHC.Types.Basic +import GHC.Utils.Json +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Utils.Outputable import Control.Arrow import Data.Map (Map) diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 08a3c0f8..d1d6bb31 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -25,17 +25,17 @@ import Data.Functor (($>)) import Data.List (maximumBy, (\\)) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (languageExtensions) +import GHC.Driver.Session (languageExtensions) import qualified GHC.LanguageExtensions as LangExt import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types -import Name -import Outputable ( showPpr, showSDoc ) -import RdrName -import RdrHsSyn (setRdrNameSpace) -import EnumSet +import GHC.Types.Name +import GHC.Parser.PostProcess +import GHC.Utils.Outputable ( showPpr, showSDoc ) +import GHC.Types.Name.Reader +import GHC.Data.EnumSet as EnumSet processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 37813d16..3e464fbc 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE DeriveFunctor #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader @@ -15,7 +16,7 @@ module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where import Control.Applicative (Alternative (..)) import Control.Monad (ap) import Data.Char -import DynFlags +import GHC.Driver.Session import Haddock.Parser import Haddock.Types diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 4d9eadac..bb9cd02d 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -20,11 +20,11 @@ import Data.Traversable (mapM) import Haddock.GhcUtils import Haddock.Types -import Bag (emptyBag) +import GHC.Data.Bag (emptyBag) import GHC hiding (NoLink) -import Name -import RdrName (RdrName(Exact)) -import TysWiredIn (eqTyCon_RDR) +import GHC.Types.Name +import GHC.Types.Name.Reader (RdrName(Exact)) +import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) @@ -33,6 +33,7 @@ import Data.List (intercalate) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set import Prelude hiding (mapM) +import GHC.HsToCore.Docs -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to -- 'DocName'. @@ -232,7 +233,6 @@ renameFamilyResultSig (L loc (KindSig _ ki)) renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr ; return (L loc (TyVarSig noExtField bndr')) } -renameFamilyResultSig (L _ (XFamilyResultSig nec)) = noExtCon nec renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -244,13 +244,18 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn +renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) +renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) +renameArrow (HsLinearArrow u) = return (HsLinearArrow u) +renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p + renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of - HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- mapM renameLTyVarBndr tyvars - ltype' <- renameLType ltype - return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tyvars', hst_body = ltype' }) + HsForAllTy { hst_tele = tele, hst_body = ltype } -> do + tele' <- renameHsForAllTelescope tele + ltype' <- renameLType ltype + return (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext @@ -272,10 +277,11 @@ renameType t = case t of b' <- renameLKind b return (HsAppKindTy noExtField a' b') - HsFunTy _ a b -> do + HsFunTy _ w a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy noExtField a' b') + w' <- renameArrow w + return (HsFunTy noExtField w' a' b') HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) @@ -326,17 +332,22 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_ext = noExtField , hsq_explicit = tvs' }) } -renameLHsQTyVars (XLHsQTyVars nec) = noExtCon nec -renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) -renameLTyVarBndr (L loc (UserTyVar x (L l n))) +renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) +renameHsForAllTelescope tele = case tele of + HsForAllVis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllVis x bndrs' + HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllInvis x bndrs' + +renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) +renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar x (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) + ; return (L loc (UserTyVar x fl (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar x (L lv n') kind')) } -renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec + ; return (L loc (KindedTyVar x fl (L lv n') kind')) } renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -427,7 +438,6 @@ renameTyClD d = case d of , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField }) - XTyClDecl nec -> noExtCon nec where renameLFunDep (L loc (xs, ys)) = do @@ -453,7 +463,6 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) -renameFamilyDecl (XFamilyDecl nec) = noExtCon nec renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -483,7 +492,6 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameDataDefn (XHsDataDefn nec) = noExtCon nec renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -503,7 +511,7 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars , con_res_ty = res_ty , con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - ltyvars' <- renameLHsQTyVars ltyvars + ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details res_ty' <- renameLType res_ty @@ -511,16 +519,21 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) -renameCon (XConDecl nec) = noExtCon nec + +renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) + -> RnM (HsScaled DocNameI (LHsType DocNameI)) +renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do fields' <- mapM renameConDeclFieldField fields return (RecCon (L l fields')) -renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps + -- This causes an assertion failure +--renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps +renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b + a' <- renameHsScaled a + b' <- renameHsScaled b return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) @@ -529,13 +542,11 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField noExtField names' t' doc') -renameConDeclFieldField (L _ (XConDeclField nec)) = noExtCon nec renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel return $ L l (FieldOcc sel' lbl) -renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of @@ -570,7 +581,6 @@ renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype return (ForeignExport noExtField lname' ltype' x) -renameForD (XForeignDecl nec) = noExtCon nec renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) @@ -583,7 +593,6 @@ renameInstD (TyFamInstD { tfid_inst = d }) = do renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' }) -renameInstD (XInstDecl nec) = noExtCon nec renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty @@ -595,7 +604,6 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_type = ty' , deriv_strategy = strat' , deriv_overlap_mode = omode }) -renameDerivD (XDerivDecl nec) = noExtCon nec renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) renameDerivStrategy StockStrategy = pure StockStrategy @@ -614,7 +622,6 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameClsInstD (XClsInstDecl nec) = noExtCon nec renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -642,7 +649,6 @@ renameTyFamInstEqn eqn , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } - rename_ty_fam_eqn (XFamEqn nec) = noExtCon nec renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD @@ -668,7 +674,6 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } - rename_data_fam_eqn (XFamEqn nec) = noExtCon nec renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -677,7 +682,6 @@ renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' , hsib_ext = noExtField }) } -renameImplicit _ (XHsImplicitBndrs nec) = noExtCon nec renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -686,7 +690,6 @@ renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' , hswc_ext = noExtField }) } -renameWc _ (XHsWildCardBndrs nec) = noExtCon nec renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 6e11a859..a084af90 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -15,10 +15,10 @@ import Haddock.Syb import Haddock.Types import GHC -import Name -import FastString -import TysPrim ( funTyConName ) -import TysWiredIn ( listTyConName ) +import GHC.Types.Name +import GHC.Data.FastString +import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State @@ -134,7 +134,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | funTyConName == name' = HsFunTy noExtField la lb + | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ @@ -204,12 +204,16 @@ freeVariables = everythingWithState Set.empty Set.union query where query term ctx = case cast term :: Maybe (HsType GhcRn) of - Just (HsForAllTy _ _ bndrs _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) + Just (HsForAllTy _ tele _) -> + (Set.empty, Set.union ctx (teleNames tele)) Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) + + teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs + teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs + bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) @@ -242,9 +246,9 @@ data RenameEnv name = RenameEnv renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) -renameType (HsForAllTy x fvf bndrs lt) = - HsForAllTy x fvf - <$> mapM (located renameBinder) bndrs +renameType (HsForAllTy x tele lt) = + HsForAllTy x + <$> renameForAllTelescope tele <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x @@ -254,7 +258,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk -renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr +renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt @@ -275,6 +279,10 @@ renameType (HsExplicitTupleTy x ltys) = renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) +renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) +renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameHsArrow mult = pure mult + renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType @@ -289,14 +297,23 @@ renameLTypes = mapM renameLType renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) -renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname -renameBinder (KindedTyVar x lname lkind) = - KindedTyVar x <$> located renameName lname <*> located renameType lkind -renameBinder (XTyVarBndr nec) = noExtCon nec +renameForAllTelescope :: HsForAllTelescope GhcRn + -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn) +renameForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x <$> mapM renameLBinder bndrs +renameForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x <$> mapM renameLBinder bndrs + +renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) +renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname +renameBinder (KindedTyVar x fl lname lkind) = + KindedTyVar x fl <$> located renameName lname <*> located renameType lkind + +renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) +renameLBinder = located renameBinder -- | Core renaming logic. -renameName :: SetName name => name -> Rename name name +renameName :: (Eq name, SetName name) => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of @@ -345,5 +362,3 @@ alternativeNames name = located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e - - diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index cb60fb00..0b8bb9f2 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -31,19 +32,19 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.Word -import BinIface (getSymtabName, getDictFastString) -import Binary -import FastMutInt -import FastString +import GHC.Iface.Binary (getSymtabName, getDictFastString) +import GHC.Utils.Binary +import GHC.Data.FastMutInt +import GHC.Data.FastString import GHC hiding (NoLink) -import GhcMonad (withSession) -import HscTypes -import NameCache -import IfaceEnv -import Name -import UniqFM -import UniqSupply -import Unique +import GHC.Driver.Monad (withSession) +import GHC.Driver.Types +import GHC.Types.Name.Cache +import GHC.Iface.Env +import GHC.Types.Name +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Types.Unique data InterfaceFile = InterfaceFile { @@ -58,11 +59,11 @@ ifModule if_ = [] -> error "empty InterfaceFile" iface:_ -> instMod iface -ifUnitId :: InterfaceFile -> UnitId +ifUnitId :: InterfaceFile -> Unit ifUnitId if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> moduleUnitId $ instMod iface + iface:_ -> moduleUnit $ instMod iface binaryInterfaceMagic :: Word32 @@ -82,8 +83,8 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811) -binaryInterfaceVersion = 36 +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) +binaryInterfaceVersion = 37 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -158,7 +159,7 @@ writeInterfaceFile filename iface = do type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: GhcMonad m => NameCacheAccessor m +nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do @@ -276,7 +277,7 @@ putName BinSymbolTable{ data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt, -- The next index to use - bin_symtab_map :: !(IORef (UniqFM (Int,Name))) + bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) -- indexed by Name } @@ -286,24 +287,24 @@ putFastString BinDictionary { bin_dict_next = j_r, bin_dict_map = out_r} bh f = do out <- readIORef out_r - let unique = getUnique f - case lookupUFM out unique of + let !unique = getUnique f + case lookupUFM_Directly out unique of Just (j, _) -> put_ bh (fromIntegral j :: Word32) Nothing -> do j <- readFastMutInt j_r put_ bh (fromIntegral j :: Word32) writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out unique (j, f) + writeIORef out_r $! addToUFM_Directly out unique (j, f) data BinDictionary = BinDictionary { bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM (Int,FastString))) + bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString } -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () +putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () putSymbolTable bh next_off symtab = do put_ bh next_off let names = elems (array (0,next_off-1) (eltsUFM symtab)) @@ -319,7 +320,7 @@ getSymbolTable bh namecache = do return (namecache', arr) -type OnDiskName = (UnitId, ModuleName, OccName) +type OnDiskName = (Unit, ModuleName, OccName) fromOnDiskName @@ -346,10 +347,10 @@ fromOnDiskName _ nc (pid, mod_name, occ) = } -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +serialiseName :: BinHandle -> Name -> UniqFM Name (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name - put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) + put_ bh (moduleUnit modu, moduleName modu, nameOccName name) ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index a0be820a..d0a39322 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -14,11 +14,9 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where import Haddock.Types ( MDoc ) -import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) -import DynFlags ( DynFlags ) -import Packages ( lookupPackage ) -import PackageConfig ( sourcePackageIdString ) +import GHC ( Name ) +import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString ) +import GHC.Unit.State ( UnitState, lookupUnit, unitPackageIdString ) import qualified Control.Applicative as A @@ -26,14 +24,14 @@ import qualified Control.Applicative as A data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] -mkModuleTree dflags showPkgs mods = +mkModuleTree :: UnitState -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] +mkModuleTree state showPkgs mods = foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) + modPkg mod_ | showPkgs = Just (unitString (moduleUnit mod_)) | otherwise = Nothing - modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (moduleUnitId mod_)) + modSrcPkg mod_ | showPkgs = fmap unitPackageIdString + (lookupUnit state (moduleUnit mod_)) | otherwise = Nothing fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 8a18a60d..0b886d1a 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -44,11 +44,11 @@ module Haddock.Options ( import qualified Data.Char as Char import Data.Version import Control.Applicative -import FastString -import GHC ( DynFlags, Module, moduleUnitId ) +import GHC.Data.FastString +import GHC ( DynFlags, Module, moduleUnit, unitState ) import Haddock.Types import Haddock.Utils -import Packages +import GHC.Unit.State import System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP @@ -383,8 +383,8 @@ modulePackageInfo :: DynFlags -> (Maybe PackageName, Maybe Data.Version.Version) modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) modulePackageInfo dflags flags (Just modu) = - ( optPackageName flags <|> fmap packageName pkgDb - , optPackageVersion flags <|> fmap packageVersion pkgDb + ( optPackageName flags <|> fmap unitPackageName pkgDb + , optPackageVersion flags <|> fmap unitPackageVersion pkgDb ) where - pkgDb = lookupPackage dflags (moduleUnitId modu) + pkgDb = lookupUnit (unitState dflags) (moduleUnit modu) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 05f3c7f0..0604a831 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -18,14 +18,14 @@ import qualified Documentation.Haddock.Parser as P import Documentation.Haddock.Types import Haddock.Types -import DynFlags ( DynFlags ) -import FastString ( fsLit ) -import Lexer ( mkPState, unP, ParseResult(..) ) -import OccName ( occNameString ) -import Parser ( parseIdentifier ) -import RdrName ( RdrName(Qual) ) -import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) -import StringBuffer ( stringToStringBuffer ) +import GHC.Driver.Session ( DynFlags ) +import GHC.Data.FastString ( fsLit ) +import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) ) +import GHC.Parser ( parseIdentifier ) +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name.Reader ( RdrName(..) ) +import GHC.Types.SrcLoc ( mkRealSrcLoc, GenLocated(..), unLoc ) +import GHC.Data.StringBuffer ( stringToStringBuffer ) parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 853f4b1b..aa76f8f6 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -27,24 +27,24 @@ module Haddock.Types ( , module Documentation.Haddock.Types ) where -import Control.Exception 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 Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) import Data.Void (Void) import Documentation.Haddock.Types -import BasicTypes (Fixity(..), PromotionFlag(..)) +import GHC.Types.Basic (Fixity(..), PromotionFlag(..)) -import Exception (ExceptionMonad(..), ghandle) import GHC -import DynFlags (Language) +import GHC.Driver.Session (Language) import qualified GHC.LanguageExtensions as LangExt -import OccName -import Outputable hiding ((<>)) +import GHC.Types.Name.Occurrence +import GHC.Utils.Outputable ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -57,7 +57,7 @@ type DocMap a = Map Name (MDoc a) type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl GhcRn] -type InstMap = Map SrcSpan Name +type InstMap = Map RealSrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -307,6 +307,8 @@ data DocNameI type instance IdP DocNameI = DocName +instance CollectPass DocNameI where + collectXXPat _ ext = noExtCon ext instance NamedThing DocName where getName (Documented name _) = name @@ -409,13 +411,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl , pfdKindSig = fdResultSig } where - mkType (KindedTyVar _ (L loc name) lkind) = + mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p) + mkType (KindedTyVar _ _ (L loc name) lkind) = HsKindSig noExtField tvar lkind where tvar = L loc (HsTyVar noExtField NotPromoted (L loc name)) - mkType (UserTyVar _ name) = HsTyVar noExtField NotPromoted name - mkType (XTyVarBndr nec) = noExtCon nec -mkPseudoFamilyDecl (XFamilyDecl nec) = noExtCon nec + mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name -- | An instance head that may have documentation and a source location. @@ -664,14 +665,14 @@ throwE :: String -> a instance Exception HaddockException throwE str = throw (HaddockException str) -withExceptionContext :: ExceptionMonad m => String -> m a -> m a +withExceptionContext :: MonadCatch m => String -> m a -> m a withExceptionContext ctxt = - ghandle (\ex -> + handle (\ex -> case ex of - HaddockException e -> throw $ WithContext [ctxt] (toException ex) - WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se + HaddockException _ -> throwM $ WithContext [ctxt] (toException ex) + WithContext ctxts se -> throwM $ WithContext (ctxt:ctxts) se ) . - ghandle (throw . WithContext [ctxt]) + handle (throwM . WithContext [ctxt]) -- In "Haddock.Interface.Create", we need to gather -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, @@ -706,11 +707,11 @@ instance Monad ErrMsgGhc where instance MonadIO ErrMsgGhc where liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) -instance ExceptionMonad ErrMsgGhc where - gcatch act hand = WriterGhc $ - runWriterGhc act `gcatch` (runWriterGhc . hand) - gmask act = WriterGhc $ gmask $ \mask -> - runWriterGhc $ act (WriterGhc . mask . runWriterGhc) +instance MonadThrow ErrMsgGhc where + throwM e = WriterGhc (throwM e) + +instance MonadCatch ErrMsgGhc where + catch (WriterGhc m) f = WriterGhc (catch m (runWriterGhc . f)) ----------------------------------------------------------------------------- -- * Pass sensitive types @@ -742,6 +743,10 @@ type instance XTyLit DocNameI = NoExtField type instance XWildCardTy DocNameI = NoExtField type instance XXType DocNameI = NewHsTypeX +type instance XHsForAllVis DocNameI = NoExtField +type instance XHsForAllInvis DocNameI = NoExtField +type instance XXHsForAllTelescope DocNameI = NoExtCon + type instance XUserTyVar DocNameI = NoExtField type instance XKindedTyVar DocNameI = NoExtField type instance XXTyVarBndr DocNameI = NoExtCon diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 1d213420..0c9c6073 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -50,13 +50,12 @@ module Haddock.Utils ( import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types -import Haddock.GhcUtils -import Exception (ExceptionMonad) import GHC -import Name +import GHC.Types.Name import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Catch ( MonadMask, bracket_ ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) @@ -74,7 +73,6 @@ import qualified System.FilePath.Posix as HtmlPath import qualified System.Posix.Internals #endif - -------------------------------------------------------------------------------- -- * Logging -------------------------------------------------------------------------------- @@ -278,9 +276,9 @@ writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do hSetEncoding h utf8 hPutStr h contents -withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a -withTempDir dir = gbracket_ (liftIO $ createDirectory dir) - (liftIO $ removeDirectoryRecursive dir) +withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a +withTempDir dir = bracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) ----------------------------------------------------------------------------- -- * HTML cross references diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index 6e065dfb..3b4cbb96 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -4,8 +4,8 @@ module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where import Test.Hspec import Test.QuickCheck -import GHC ( runGhc, getSessionDynFlags ) -import DynFlags ( DynFlags ) +import GHC ( runGhc, getSessionDynFlags ) +import GHC.Driver.Session ( DynFlags ) import Control.Monad.IO.Class import Data.String ( fromString ) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 9e707f1b..7b854553 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -27,6 +27,7 @@ tested-with: GHC == 7.4.2 , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1 + , GHC == 9.0.1 extra-source-files: CHANGES.md @@ -37,7 +38,7 @@ common lib-defaults default-language: Haskell2010 build-depends: - , base >= 4.5 && < 4.15 + , base >= 4.5 && < 4.16 , 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 a722c30e..a484a8d9 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -9,7 +9,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.10.* +tested-with: GHC==9.0.* cabal-version: >= 1.10 stability: experimental @@ -17,7 +17,7 @@ library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - build-depends: base >= 4.3 && < 4.15, bytestring, directory, process, filepath, Cabal + build-depends: base >= 4.3 && < 4.16, bytestring, directory, process, filepath, Cabal exposed-modules: Test.Haddock diff --git a/haddock.cabal b/haddock.cabal index 0bf99950..a24d3794 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -33,7 +33,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.10.* +tested-with: GHC==9.0.* extra-source-files: CHANGES.md @@ -66,7 +66,7 @@ executable haddock -- haddock typically only supports a single GHC major version build-depends: - base ^>= 4.14.0.0 + base ^>= 4.13.0.0 || ^>= 4.14.0.0 || ^>= 4.15.0.0 || ^>= 4.16.0.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/src @@ -76,11 +76,12 @@ executable haddock directory, containers, deepseq, + exceptions, array, xhtml >= 3000.2 && < 3000.3, ghc-boot, ghc-boot-th, - ghc == 8.10.*, + ghc == 9.0.*, bytestring, parsec, text, diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html index 2d938656..b8b8ff0f 100644 --- a/html-test/ref/Bug1050.html +++ b/html-test/ref/Bug1050.html @@ -93,11 +93,11 @@ >mkT</a > :: <span class="keyword" >forall</span - > k (f :: <span class="keyword" + > {k} {f :: <span class="keyword" >forall</span > k1. k1 -> <a href="#" title="Data.Kind" >Type</a - >) (a :: k). f a -> <a href="#" title="Bug1050" + >} {a :: k}. f a -> <a href="#" title="Bug1050" >T</a > f a <a href="#" class="selflink" >#</a diff --git a/html-test/ref/Bug280.html b/html-test/ref/Bug280.html index 6a4aa63e..57e265f4 100644 --- a/html-test/ref/Bug280.html +++ b/html-test/ref/Bug280.html @@ -65,9 +65,9 @@ ><p class="src" ><a id="v:x" class="def" >x</a - > :: [<a href="#" title="Data.Char" - >Char</a - >] <a href="#" class="selflink" + > :: <a href="#" title="Data.String" + >String</a + > <a href="#" class="selflink" >#</a ></p ></div diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html index 4ed71a4b..c6a6b5ca 100644 --- a/html-test/ref/Instances.html +++ b/html-test/ref/Instances.html @@ -594,11 +594,7 @@ ></span > <a href="#" title="Instances" >Foo</a - > ((->) a :: <a href="#" title="Data.Kind" - >Type</a - > -> <a href="#" title="Data.Kind" - >Type</a - >)</span + > ((->) a)</span > <a href="#" class="selflink" >#</a ></td diff --git a/html-test/ref/SectionLabels.html b/html-test/ref/SectionLabels.html index 4581082e..8b571b42 100644 --- a/html-test/ref/SectionLabels.html +++ b/html-test/ref/SectionLabels.html @@ -1,4 +1,3 @@ -<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" ><head ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" diff --git a/html-test/run b/html-test/run index 3e72be80..c14ab7b5 100755 --- a/html-test/run +++ b/html-test/run @@ -3,4 +3,5 @@ export HADDOCK_PATH=$(which haddock) LIB_PATH="$(dirname "$BASH_SOURCE")/../haddock-test/src/" MAIN_PATH="$(dirname "$BASH_SOURCE")/Main.hs" -runhaskell -i:"$LIB_PATH" $MAIN_PATH $@ +if [ -z "$RUNHASKELL" ]; then RUNHASKELL=runhaskell; fi +$RUNHASKELL -i:"$LIB_PATH" $MAIN_PATH $@ diff --git a/html-test/src/Bug679.hs b/html-test/src/Bug679.hs index dba194c4..0a321ec5 100644 --- a/html-test/src/Bug679.hs +++ b/html-test/src/Bug679.hs @@ -13,7 +13,7 @@ $(do let methodN = mkName "foo" methodTy <- [t| $(varT a) -> $(varT a) |] - let cla = ClassD [] classN [PlainTV a] [] [SigD methodN methodTy] + let cla = ClassD [] classN [PlainTV a ()] [] [SigD methodN methodTy] -- Note that we are /reusing/ the same type variable 'a' as in the class instanceHead <- [t| $(conT classN) (Bar $(varT a)) |] diff --git a/html-test/src/FunArgs.hs b/html-test/src/FunArgs.hs index 24e1ccff..e20bcda7 100644 --- a/html-test/src/FunArgs.hs +++ b/html-test/src/FunArgs.hs @@ -22,7 +22,7 @@ h :: forall a b c -> b -- ^ Second argument -> c -- ^ Third argument -> forall d. d -- ^ Result -h = undefined +h _ _ _ = undefined i :: forall a (b :: ()) d. (d ~ '()) diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index 48218a32..3477d89d 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -1109,7 +1109,7 @@ forall a. [a] -> [a] -> [a] ><span id="" ><span class="annot" ><span class="annottext" - >plugh :: Either a a -> Either b b -> Either (a -> b) (b -> a) + >plugh :: forall a b. Either a a -> Either b b -> Either (a -> b) (b -> a) </span ><a href="#" ><span class="hs-identifier hs-var hs-var hs-var hs-var" diff --git a/hypsrc-test/ref/src/Literals.html b/hypsrc-test/ref/src/Literals.html index 0c7ddf9e..db6d37b3 100644 --- a/hypsrc-test/ref/src/Literals.html +++ b/hypsrc-test/ref/src/Literals.html @@ -132,7 +132,7 @@ ><span id="num" ><span class="annot" ><span class="annottext" - >num :: a + >num :: forall a. Num a => a </span ><a href="Literals.html#num" ><span class="hs-identifier hs-var hs-var" @@ -285,7 +285,7 @@ forall a. Num a => a -> a -> a ><span id="frac" ><span class="annot" ><span class="annottext" - >frac :: a + >frac :: forall a. Fractional a => a </span ><a href="Literals.html#frac" ><span class="hs-identifier hs-var hs-var" @@ -360,7 +360,7 @@ forall a. Num a => a -> a -> a ><span id="list" ><span class="annot" ><span class="annottext" - >list :: [[[[a]]]] + >list :: forall a. [[[[a]]]] </span ><a href="Literals.html#list" ><span class="hs-identifier hs-var hs-var" diff --git a/hypsrc-test/ref/src/Operators.html b/hypsrc-test/ref/src/Operators.html index 289684a0..2ce87a6e 100644 --- a/hypsrc-test/ref/src/Operators.html +++ b/hypsrc-test/ref/src/Operators.html @@ -108,7 +108,7 @@ ><span id="%2B%2B%2B" ><span class="annot" ><span class="annottext" - >+++ :: [a] -> [a] -> [a] + >+++ :: forall a. [a] -> [a] -> [a] </span ><a href="Operators.html#%2B%2B%2B" ><span class="hs-operator hs-var hs-var" @@ -273,7 +273,7 @@ forall a. [a] -> [a] -> [a] ><span id="%24%24%24" ><span class="annot" ><span class="annottext" - >$$$ :: [a] -> [a] -> [a] + >$$$ :: forall a. [a] -> [a] -> [a] </span ><a href="Operators.html#%24%24%24" ><span class="hs-operator hs-var hs-var" @@ -406,7 +406,7 @@ forall a. [a] -> [a] -> [a] ><span id="%2A%2A%2A" ><span class="annot" ><span class="annottext" - >*** :: [a] -> [a] -> [a] + >*** :: forall a. [a] -> [a] -> [a] </span ><a href="Operators.html#%2A%2A%2A" ><span class="hs-operator hs-var hs-var" @@ -656,7 +656,7 @@ forall a. [a] -> [a] -> [a] ><span id="%2A%2F%5C%2A" ><span class="annot" ><span class="annottext" - >*/\* :: [[a]] -> [a] -> [a] + >*/\* :: forall a. [[a]] -> [a] -> [a] </span ><a href="Operators.html#%2A%2F%5C%2A" ><span class="hs-operator hs-var hs-var" @@ -828,7 +828,7 @@ forall a. [a] -> [a] -> [a] ><span id="%2A%2A%2F%5C%2A%2A" ><span class="annot" ><span class="annottext" - >**/\** :: [[a]] -> [[a]] -> [[a]] + >**/\** :: forall a. [[a]] -> [[a]] -> [[a]] </span ><a href="Operators.html#%2A%2A%2F%5C%2A%2A" ><span class="hs-operator hs-var hs-var" @@ -1065,7 +1065,7 @@ forall a. [a] -> [a] -> [a] ><span id="%23.%23" ><span class="annot" ><span class="annottext" - >#.# :: a -> b -> c -> (a, b) + >#.# :: forall a b c. a -> b -> c -> (a, b) </span ><a href="Operators.html#%23.%23" ><span class="hs-operator hs-var hs-var" diff --git a/hypsrc-test/ref/src/Polymorphism.html b/hypsrc-test/ref/src/Polymorphism.html index 9f8a1850..1b166aff 100644 --- a/hypsrc-test/ref/src/Polymorphism.html +++ b/hypsrc-test/ref/src/Polymorphism.html @@ -107,7 +107,7 @@ ><span id="foo" ><span class="annot" ><span class="annottext" - >foo :: a -> a -> a + >foo :: forall a. a -> a -> a </span ><a href="Polymorphism.html#foo" ><span class="hs-identifier hs-var hs-var" @@ -205,7 +205,7 @@ forall a. HasCallStack => a ><span id="foo%27" ><span class="annot" ><span class="annottext" - >foo' :: a -> a -> a + >foo' :: forall a. a -> a -> a </span ><a href="Polymorphism.html#foo%27" ><span class="hs-identifier hs-var hs-var" @@ -305,7 +305,7 @@ forall a. HasCallStack => a ><span id="bar" ><span class="annot" ><span class="annottext" - >bar :: a -> b -> (a, b) + >bar :: forall a b. a -> b -> (a, b) </span ><a href="Polymorphism.html#bar" ><span class="hs-identifier hs-var hs-var" @@ -427,7 +427,7 @@ forall a. HasCallStack => a ><span id="bar%27" ><span class="annot" ><span class="annottext" - >bar' :: a -> b -> (a, b) + >bar' :: forall a b. a -> b -> (a, b) </span ><a href="Polymorphism.html#bar%27" ><span class="hs-identifier hs-var hs-var" @@ -557,7 +557,7 @@ forall a. HasCallStack => a ><span id="baz" ><span class="annot" ><span class="annottext" - >baz :: a -> (a -> [a -> a] -> b) -> b + >baz :: forall a b. a -> (a -> [a -> a] -> b) -> b </span ><a href="Polymorphism.html#baz" ><span class="hs-identifier hs-var hs-var" @@ -709,7 +709,7 @@ forall a. HasCallStack => a ><span id="baz%27" ><span class="annot" ><span class="annottext" - >baz' :: a -> (a -> [a -> a] -> b) -> b + >baz' :: forall a b. a -> (a -> [a -> a] -> b) -> b </span ><a href="Polymorphism.html#baz%27" ><span class="hs-identifier hs-var hs-var" @@ -825,7 +825,7 @@ forall a. HasCallStack => a ><span id="quux" ><span class="annot" ><span class="annottext" - >quux :: a -> (forall a. a -> a) -> a + >quux :: forall a. a -> (forall a. a -> a) -> a </span ><a href="Polymorphism.html#quux" ><span class="hs-identifier hs-var hs-var" @@ -994,7 +994,7 @@ forall a. a -> a ><span id="quux%27" ><span class="annot" ><span class="annottext" - >quux' :: a -> (forall a. a -> a) -> a + >quux' :: forall a. a -> (forall a. a -> a) -> a </span ><a href="Polymorphism.html#quux%27" ><span class="hs-identifier hs-var hs-var" @@ -1140,7 +1140,7 @@ forall a. a -> a ><span id="num" ><span class="annot" ><span class="annottext" - >num :: a -> a -> a + >num :: forall a. Num a => a -> a -> a </span ><a href="Polymorphism.html#num" ><span class="hs-identifier hs-var hs-var" @@ -1256,7 +1256,7 @@ forall a. HasCallStack => a ><span id="num%27" ><span class="annot" ><span class="annottext" - >num' :: a -> a -> a + >num' :: forall a. Num a => a -> a -> a </span ><a href="Polymorphism.html#num%27" ><span class="hs-identifier hs-var hs-var" @@ -1402,7 +1402,7 @@ forall a. HasCallStack => a ><span id="eq" ><span class="annot" ><span class="annottext" - >eq :: [a] -> [b] -> (a, b) + >eq :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) </span ><a href="Polymorphism.html#eq" ><span class="hs-identifier hs-var hs-var" @@ -1570,7 +1570,7 @@ forall a. HasCallStack => a ><span id="eq%27" ><span class="annot" ><span class="annottext" - >eq' :: [a] -> [b] -> (a, b) + >eq' :: forall a b. (Eq a, Eq b) => [a] -> [b] -> (a, b) </span ><a href="Polymorphism.html#eq%27" ><span class="hs-identifier hs-var hs-var" @@ -1694,7 +1694,7 @@ forall a. HasCallStack => a ><span id="mon" ><span class="annot" ><span class="annottext" - >mon :: (a -> m a) -> m a + >mon :: forall (m :: * -> *) a. Monad m => (a -> m a) -> m a </span ><a href="Polymorphism.html#mon" ><span class="hs-identifier hs-var hs-var" @@ -1840,7 +1840,7 @@ forall a. HasCallStack => a ><span id="mon%27" ><span class="annot" ><span class="annottext" - >mon' :: (a -> m a) -> m a + >mon' :: forall (m :: * -> *) a. Monad m => (a -> m a) -> m a </span ><a href="Polymorphism.html#mon%27" ><span class="hs-identifier hs-var hs-var" @@ -1979,7 +1979,7 @@ forall a. HasCallStack => a ><span id="norf" ><span class="annot" ><span class="annottext" - >norf :: a -> (forall a. Ord a => a -> a) -> a + >norf :: forall a. a -> (forall a. Ord a => a -> a) -> a </span ><a href="Polymorphism.html#norf" ><span class="hs-identifier hs-var hs-var" @@ -2154,7 +2154,7 @@ forall a. HasCallStack => a ><span id="norf%27" ><span class="annot" ><span class="annottext" - >norf' :: a -> (forall a. Ord a => a -> a) -> a + >norf' :: forall a. a -> (forall a. Ord a => a -> a) -> a </span ><a href="Polymorphism.html#norf%27" ><span class="hs-identifier hs-var hs-var" @@ -2272,7 +2272,7 @@ forall a. HasCallStack => a ><span id="plugh" ><span class="annot" ><span class="annottext" - >plugh :: a -> a + >plugh :: forall a. a -> a </span ><a href="Polymorphism.html#plugh" ><span class="hs-identifier hs-var hs-var" @@ -2436,7 +2436,7 @@ forall a. HasCallStack => a ><span id="thud" ><span class="annot" ><span class="annottext" - >thud :: (a -> b) -> a -> (a, b) + >thud :: forall a b. (a -> b) -> a -> (a, b) </span ><a href="Polymorphism.html#thud" ><span class="hs-identifier hs-var hs-var" diff --git a/hypsrc-test/ref/src/Quasiquoter.html b/hypsrc-test/ref/src/Quasiquoter.html index f53219d7..ea111cad 100644 --- a/hypsrc-test/ref/src/Quasiquoter.html +++ b/hypsrc-test/ref/src/Quasiquoter.html @@ -372,7 +372,7 @@ forall a. String -> Q a ><span id="" ><span class="annot" ><span class="annottext" - >invalidDomain :: String -> Q a + >invalidDomain :: forall a. String -> Q a </span ><a href="#" ><span class="hs-identifier hs-var hs-var" diff --git a/hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html b/hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html index 68c7b754..38dfb97e 100644 --- a/hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html +++ b/hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html @@ -111,8 +111,10 @@ >::</span ><span > </span - ><span class="" - >$aType</span + ><span class="hs-special" + >$</span + ><span class="hs-identifier" + >aType</span ><span > </span ><span class="hs-glyph" @@ -150,16 +152,20 @@ >bar</span ><span > </span - ><span class="" - >$aPattern</span + ><span class="hs-special" + >$</span + ><span class="hs-identifier" + >aPattern</span ><span > </span ><span class="hs-glyph" >=</span ><span > </span - ><span class="" - >$anExpression</span + ><span class="hs-special" + >$</span + ><span class="hs-identifier" + >anExpression</span ><span > </span @@ -283,8 +289,10 @@ >(</span ><span > </span - ><span class="" - >$aNumberPattern</span + ><span class="hs-special" + >$</span + ><span class="hs-identifier" + >aNumberPattern</span ><span class="hs-special" >,</span ><span @@ -370,20 +378,12 @@ > </span ><span class="hs-identifier" >w</span - ><span - > </span ><span class="hs-glyph" >@</span - ><span - > </span ><span class="hs-identifier" >v</span - ><span - > </span ><span class="hs-glyph" >@</span - ><span - > </span ><span class="hs-number" >4.5</span ><span @@ -476,8 +476,10 @@ >+</span ><span > </span - ><span class="" - >$anExpression2</span + ><span class="hs-special" + >$</span + ><span class="hs-identifier" + >anExpression2</span ><span class="hs-special" >,</span ><span diff --git a/hypsrc-test/ref/src/TemplateHaskellSplices.html b/hypsrc-test/ref/src/TemplateHaskellSplices.html index 6586d299..63b0025d 100644 --- a/hypsrc-test/ref/src/TemplateHaskellSplices.html +++ b/hypsrc-test/ref/src/TemplateHaskellSplices.html @@ -54,20 +54,15 @@ ><span id="line-6" ></span ><span class="hs-special" - >$(</span + >$</span ><span id="bar" - ><span class="annot" - ><span class="annottext" - >[(Double, String)] -> [(Int, String)] -</span - ><a href="TemplateHaskellSplices.html#bar" - ><span class="hs-identifier hs-type hs-var" - >aDecl</span - ></a - ></span - ></span ><span class="hs-special" - >)</span + >(</span + ><span class="hs-identifier" + >aDecl</span + ><span class="hs-special" + >)</span + ></span ><span > </span @@ -106,23 +101,11 @@ forall a. a -> a ><span > </span ><span class="hs-special" - >$(</span - ><span class="annot" - ><span class="annottext" - >Double -Integer -Double -> Integer -Integer -> Integer -> Integer -forall a. Floating a => a -forall a. Num a => a -> a -> a -forall a b. (RealFrac a, Integral b) => a -> b -+ :: forall a. Num a => a -> a -> a -round :: forall a b. (RealFrac a, Integral b) => a -> b -pi :: forall a. Floating a => a -</span - ><span class="hs-identifier hs-var hs-var hs-var" - >anExpression2</span - ></span + >$</span + ><span class="hs-special" + >(</span + ><span class="hs-identifier" + >anExpression2</span ><span class="hs-special" >)</span ><span diff --git a/hypsrc-test/ref/src/Types.html b/hypsrc-test/ref/src/Types.html index e08382dd..835fafb0 100644 --- a/hypsrc-test/ref/src/Types.html +++ b/hypsrc-test/ref/src/Types.html @@ -699,8 +699,11 @@ ><span > </span ><span class="annot" - ><a href="Types.html#Bar" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Bar" + ><span class="hs-identifier hs-var" >Bar</span ></a ></span @@ -761,8 +764,11 @@ ><span > </span ><span class="annot" - ><a href="Types.html#Baz" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Baz" + ><span class="hs-identifier hs-var" >Baz</span ></a ></span @@ -864,8 +870,11 @@ ><span > </span ><span class="annot" - ><a href="Types.html#Bar" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Bar" + ><span class="hs-identifier hs-var" >Bar</span ></a ></span @@ -926,8 +935,11 @@ ><span > </span ><span class="annot" - ><a href="Types.html#Baz" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Baz" + ><span class="hs-identifier hs-var" >Baz</span ></a ></span @@ -1060,8 +1072,11 @@ ><span > </span ><span class="annot" - ><a href="Types.html#Bar" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Bar" + ><span class="hs-identifier hs-var" >Bar</span ></a ></span @@ -1112,8 +1127,11 @@ ><span > </span ><span class="annot" - ><a href="Types.html#Baz" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Baz" + ><span class="hs-identifier hs-var" >Baz</span ></a ></span @@ -1207,8 +1225,11 @@ ><span class="hs-special" >(</span ><span class="annot" - ><a href="Types.html#Bar" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Bar" + ><span class="hs-identifier hs-var" >Bar</span ></a ></span @@ -1259,8 +1280,11 @@ ><span class="hs-special" >(</span ><span class="annot" - ><a href="Types.html#Baz" - ><span class="hs-identifier hs-type" + ><span class="annottext" + >Quux +</span + ><a href="Types.html#Baz" + ><span class="hs-identifier hs-var" >Baz</span ></a ></span diff --git a/hypsrc-test/src/TemplateHaskellQuasiquotes.hs b/hypsrc-test/src/TemplateHaskellQuasiquotes.hs index a1661895..6d404921 100644 --- a/hypsrc-test/src/TemplateHaskellQuasiquotes.hs +++ b/hypsrc-test/src/TemplateHaskellQuasiquotes.hs @@ -21,7 +21,7 @@ aPattern = [p| aNumberPattern :: PatQ aNumberPattern = [p| - w @ v @ 4.5 + w@v@4.5 |] anExpression, anExpression2 :: ExpQ |