diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')
3 files changed, 88 insertions, 78 deletions
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) |