diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 17 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 4 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 4 |
3 files changed, 14 insertions, 11 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0bd467e1..0247d567 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -9,11 +9,12 @@ import qualified Data.ByteString as BS import BasicTypes ( IntegralLit(..) ) import DynFlags -import ErrUtils ( emptyMessages ) +import ErrUtils ( pprLocErrMsg ) import FastString ( mkFastString ) import Lexer ( P(..), ParseResult(..), PState(..), Token(..) - , mkPStatePure, lexer, mkParserFlags' ) -import Outputable ( showSDoc, panic ) + , mkPStatePure, lexer, mkParserFlags', getErrorMessages, addFatalError ) +import Bag ( bagToList ) +import Outputable ( showSDoc, panic, text, ($$) ) import SrcLoc import StringBuffer ( StringBuffer, atEnd ) @@ -31,8 +32,10 @@ parse -> [T.Token] parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks - PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++ - ": " ++ showSDoc dflags errMsg + PFailed pst -> + let err:_ = bagToList (getErrorMessages pst dflags) in + panic $ showSDoc dflags $ + text "Hyperlinker parse error:" $$ pprLocErrMsg err where initState = mkPStatePure pflags buf start @@ -145,7 +148,7 @@ 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, srcLoc) -- | Set the input setInput :: (StringBuffer, RealSrcLoc) -> P () @@ -154,7 +157,7 @@ setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) () -- | Orphan instance that adds backtracking to 'P' instance Alternative P where - empty = P $ \_ -> PFailed (const emptyMessages) noSrcSpan "Alterative.empty" + empty = addFatalError noSrcSpan (text "Alterative.empty") P x <|> P y = P $ \s -> case x s of { p@POk{} -> p ; _ -> y s } diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index a4dcb77b..404cb9d0 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -88,14 +88,14 @@ renderWithAst srcs Node{..} toks = anchored $ case toks of -- order to make sure these get hyperlinked properly, we intercept these -- special sequences of tokens and merge them into just one identifier or -- operator token. - [BacktickTok s1, tok @ Token{ tkType = TkIdentifier }, BacktickTok s2] + [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2] | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken srcs nodeInfo (Token{ tkValue = "`" <> tkValue tok <> "`" , tkType = TkOperator , tkSpan = nodeSpan }) - [OpenParenTok s1, tok @ Token{ tkType = TkOperator }, CloseParenTok s2] + [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2] | realSrcSpanStart s1 == realSrcSpanStart nodeSpan , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan -> richToken srcs nodeInfo diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 2c48e00b..612f3f08 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -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 a b - go (HQualTy con b) = IfaceDFunTy con b + go (HFunTy a b) = IfaceFunTy VisArg a b + go (HQualTy con b) = IfaceFunTy InvisArg con b go (HCastTy a) = a go HCoercionTy = IfaceTyVar "<coercion type>" go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) |