diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 12 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 12 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 3 |
3 files changed, 20 insertions, 7 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index be17cb8b..b97f0ead 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -72,7 +72,7 @@ types = everything (<|>) ty where ty term = case cast term of - (Just (GHC.L sspan (GHC.HsTyVar name))) -> + (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty @@ -118,7 +118,7 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ -> pure . decl $ name + GHC.SynDecl name _ _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of @@ -152,11 +152,11 @@ imports src@(_, imps, _, _) = everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just (GHC.IEVar v)) -> pure $ var v - (Just (GHC.IEThingAbs t)) -> pure $ typ t - (Just (GHC.IEThingAll t)) -> pure $ typ t + (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) -> - [typ t] ++ map var vs + [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) 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 |