From 2a2020c5331c593319bd196aadccdc46e7a3f779 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 28 Feb 2019 12:41:09 -0800 Subject: Disallow qualified uses of reserved identifiers This a GHC bug (https://gitlab.haskell.org/ghc/ghc/issues/14109) too, but it is a relatively easy fix in Haddock. Note that the fix must live in `haddock-api` instead of `haddock-library` because we can only really decide if an identifier is a reserved one by asking the GHC lexer. Fixes #952 --- haddock-api/src/Haddock/Parser.hs | 34 +++++++++++------- html-test/ref/Bug952.html | 76 +++++++++++++++++++++++++++++++++++++++ html-test/src/Bug952.hs | 5 +++ 3 files changed, 103 insertions(+), 12 deletions(-) create mode 100644 html-test/ref/Bug952.html create mode 100644 html-test/src/Bug952.hs diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 6d5dc103..05f3c7f0 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, @@ -19,8 +20,10 @@ import Haddock.Types import DynFlags ( DynFlags ) import FastString ( fsLit ) -import Lexer ( mkPState, unP, ParseResult(POk) ) +import Lexer ( mkPState, unP, ParseResult(..) ) +import OccName ( occNameString ) import Parser ( parseIdentifier ) +import RdrName ( RdrName(Qual) ) import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) @@ -33,14 +36,21 @@ parseString d = P.overIdentifier (parseIdent d) . P.parseString parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) parseIdent dflags ns str0 = - let buffer = stringToStringBuffer str1 - realSrcLc = mkRealSrcLoc (fsLit "") 0 0 - pstate = mkPState dflags buffer realSrcLc - (wrap,str1) = case str0 of - '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names - -> (Parenthesized, init s) - '`' : s@(_ : _) -> (Backticked, init s) - _ -> (Unadorned, str0) - in case unP parseIdentifier pstate of - POk _ (L _ name) -> Just (wrap (NsRdrName ns name)) - _ -> Nothing + case unP parseIdentifier (pstate str1) of + POk _ (L _ name) + -- Guards against things like 'Q.--', 'Q.case', etc. + -- See https://github.com/haskell/haddock/issues/952 and Trac #14109 + | Qual _ occ <- name + , PFailed{} <- unP parseIdentifier (pstate (occNameString occ)) + -> Nothing + | otherwise + -> Just (wrap (NsRdrName ns name)) + PFailed{} -> Nothing + where + realSrcLc = mkRealSrcLoc (fsLit "") 0 0 + pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) diff --git a/html-test/ref/Bug952.html b/html-test/ref/Bug952.html new file mode 100644 index 00000000..bd301bcd --- /dev/null +++ b/html-test/ref/Bug952.html @@ -0,0 +1,76 @@ +Bug952

Safe Haskell	Safe-Inferred

Bug952

Synopsis

foo :: ()

Documentation

foo :: () #

See 'case', 'of', '--' compared to 'Q.case', 'Q.of', 'Q.--'

diff --git a/html-test/src/Bug952.hs b/html-test/src/Bug952.hs new file mode 100644 index 00000000..09b365e4 --- /dev/null +++ b/html-test/src/Bug952.hs @@ -0,0 +1,5 @@ +module Bug952 where + +-- | See 'case', 'of', '--' compared to 'Q.case', 'Q.of', 'Q.--' +foo :: () +foo = () -- cgit v1.2.3