From 97b0189927924b82ee26f762c88ccd965eee8d80 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Mon, 22 Jan 2018 11:44:04 -0800
Subject: Properly color pragma contents in hyperlinker

The hyperlinker backend now classifies the content of pragmas as
'TkPragma'. That means that in something like '{-# INLINE foo #-}',
'foo' still gets classified as a pragma token.
---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 78 ++++++++++++++++++----
 1 file changed, 65 insertions(+), 13 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 0ea3eba2..cd2237e9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -136,22 +136,35 @@ spanToNewline n (c:str) =
 -- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of
 -- Haddock's 'T.Token'.
 ghcToks :: [(Located L.Token, String)] -> [T.Token]
-ghcToks = reverse . snd . foldl' go (start, [])
+ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)
   where
     start = mkRealSrcLoc (mkFastString "lexing") 1 1
 
-    go :: (RealSrcLoc, [T.Token])    -- ^ current position, tokens accumulated
-       -> (Located L.Token, String)  -- ^ next token, its content
-       -> (RealSrcLoc, [T.Token])    -- ^ new position, new tokens accumulated
-    go (pos, toks) (L l tok, raw) = ( next_pos
-                                    , classifiedTok ++ maybeToList white ++ toks
-                                    )
+    go :: (RealSrcLoc, [T.Token], Bool)
+       -- ^ current position, tokens accumulated, currently in pragma (or not)
+       
+       -> (Located L.Token, String)
+       -- ^ next token, its content
+       
+       -> (RealSrcLoc, [T.Token], Bool)
+       -- ^ new position, new tokens accumulated, currently in pragma (or not)
+
+    go (pos, toks, in_prag) (L l tok, raw) =
+        ( next_pos
+        , classifiedTok ++ maybeToList white ++ toks
+        , inPragma in_prag tok
+        )
        where
          (next_pos, white) = mkWhitespace pos l
-         classifiedTok = [ Token (classify tok) raw rss
+         
+         classifiedTok = [ Token (classify' tok) raw rss
                          | RealSrcSpan rss <- [l]
                          , not (null raw)
                          ]
+         
+         classify' | in_prag = const TkPragma
+                   | otherwise = classify
+
 
 -- | Find the correct amount of whitespace between tokens.
 mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token)
@@ -170,7 +183,7 @@ mkWhitespace prev spn =
         wsstring = replicate nls '\n' ++ replicate spaces ' '
 
 
--- | Classify given string as appropriate Haskell token.
+-- | Classify given tokens as appropriate Haskell token type.
 classify :: L.Token -> TokenType
 classify tok =
   case tok of
@@ -200,7 +213,7 @@ classify tok =
     ITtype                 -> TkKeyword
     ITwhere                -> TkKeyword
 
-    ITforall {}            -> TkKeyword
+    ITforall            {} -> TkKeyword
     ITexport               -> TkKeyword
     ITlabel                -> TkKeyword
     ITdynamic              -> TkKeyword
@@ -235,7 +248,7 @@ classify tok =
     ITrules_prag        {} -> TkPragma
     ITwarning_prag      {} -> TkPragma
     ITdeprecated_prag   {} -> TkPragma
-    ITline_prag            -> TkPragma
+    ITline_prag         {} -> TkPragma
     ITscc_prag          {} -> TkPragma
     ITgenerated_prag    {} -> TkPragma
     ITcore_prag         {} -> TkPragma
@@ -331,8 +344,8 @@ classify tok =
     ITidTyEscape        {} -> TkUnknown
     ITparenTyEscape        -> TkSpecial
     ITtyQuote              -> TkSpecial
-    ITquasiQuote {}        -> TkUnknown
-    ITqQuasiQuote {}       -> TkUnknown
+    ITquasiQuote        {} -> TkUnknown
+    ITqQuasiQuote       {} -> TkUnknown
 
     ITproc                 -> TkKeyword
     ITrec                  -> TkKeyword
@@ -366,3 +379,42 @@ classify tok =
       | isPrefixOf "{-#" c
       , isSuffixOf "#-}" c -> TkPragma
       | otherwise          -> TkComment
+
+-- | Classify given tokens as beginning pragmas (or not).
+inPragma :: Bool     -- ^ currently in pragma
+         -> L.Token  -- ^ current token
+         -> Bool     -- ^ new information about whether we are in a pragma
+inPragma _ ITclose_prag = False
+inPragma True _ = True
+inPragma False tok =
+  case tok of
+    ITinline_prag       {} -> True
+    ITspec_prag         {} -> True
+    ITspec_inline_prag  {} -> True
+    ITsource_prag       {} -> True
+    ITrules_prag        {} -> True
+    ITwarning_prag      {} -> True
+    ITdeprecated_prag   {} -> True
+    ITline_prag         {} -> True
+    ITscc_prag          {} -> True
+    ITgenerated_prag    {} -> True
+    ITcore_prag         {} -> True
+    ITunpack_prag       {} -> True
+    ITnounpack_prag     {} -> True
+    ITann_prag          {} -> True
+    ITcomplete_prag     {} -> True
+    IToptions_prag      {} -> True
+    ITinclude_prag      {} -> True
+    ITlanguage_prag        -> True
+    ITvect_prag         {} -> True
+    ITvect_scalar_prag  {} -> True
+    ITnovect_prag       {} -> True
+    ITminimal_prag      {} -> True
+    IToverlappable_prag {} -> True
+    IToverlapping_prag  {} -> True
+    IToverlaps_prag     {} -> True
+    ITincoherent_prag   {} -> True
+    ITctype             {} -> True
+
+    _                      -> False
+
-- 
cgit v1.2.3