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 | 
