diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 38 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 29 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 102 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 46 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 18 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 103 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 19 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 128 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 10 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 6 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 8 |
13 files changed, 264 insertions, 247 deletions
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 _ -> "" |