aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorSebastian Méric de Bellefon <arnaudpourseb@gmail.com>2016-06-06 20:26:30 -0400
committerSebastian Méric de Bellefon <arnaudpourseb@gmail.com>2016-06-06 20:26:30 -0400
commitd6529419df9ef6f48d20c0a2c8e0f974fb2deb03 (patch)
treeb2efde46426a4f0174b83061a4d5c057c63e08b0 /haddock-api/src/Haddock/Backends
parent8d47c8b733a0b9406d99a97c7eaeba3d6b51ec7c (diff)
parent7c60df10642d90d7205cb9c4296903b8de094029 (diff)
Merge pull request #512 from phadej/oleg-fixes
Fixes for #508 and #510
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs3
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs3
3 files changed, 15 insertions, 3 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index e206413e..e4345602 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -31,12 +31,20 @@ chunk str@(c:_)
chunk str
| "--" `isPrefixOf` str = chunk' $ spanToNewline str
| "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
- | otherwise = case lex str of
+ | otherwise = case lex' str of
(tok:_) -> chunk' tok
[] -> [str]
where
chunk' (c, rest) = c:(chunk rest)
+-- | A bit better lexer then the default, i.e. handles DataKinds quotes
+lex' :: ReadS String
+lex' ('\'' : '\'' : rest) = [("''", rest)]
+lex' str@('\'' : '\\' : _ : '\'' : _) = lex str
+lex' str@('\'' : _ : '\'' : _) = lex str
+lex' ('\'' : rest) = [("'", rest)]
+lex' str = lex str
+
-- | Split input to "first line" string and the rest of it.
--
-- Ideally, this should be done simply with @'break' (== '\n')@. However,
@@ -124,6 +132,8 @@ classify str
| "--" `isPrefixOf` str = TkComment
| "{-#" `isPrefixOf` str = TkPragma
| "{-" `isPrefixOf` str = TkComment
+classify "''" = TkSpecial
+classify "'" = TkSpecial
classify str@(c:_)
| isSpace c = TkSpace
| isDigit c = TkNumber
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index 5f4dbc8c..b27ec4d8 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -12,16 +12,19 @@ data Token = Token
, tkValue :: String
, tkSpan :: Span
}
+ deriving (Show)
data Position = Position
{ posRow :: !Int
, posCol :: !Int
}
+ deriving (Show)
data Span = Span
{ spStart :: Position
, spEnd :: Position
}
+ deriving (Show)
data TokenType
= TkIdentifier
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 1d49807d..391bb50c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -75,8 +75,7 @@ spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
case span_ of
RealSrcSpan span__ ->
show $ srcSpanStartLine span__
- UnhelpfulSpan _ ->
- error "spliceURL UnhelpfulSpan"
+ UnhelpfulSpan _ -> ""
run "" = ""
run ('%':'M':rest) = mdl ++ run rest