Merge branch 'ghc-head'

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