From 666af8d2f29c05d22bb5930d115c42509528bb90 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 7 Jun 2015 21:35:55 +0200
Subject: Add support for type token recognition.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 35 +++++++++---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 64 ++++++++++++++--------
 2 files changed, 68 insertions(+), 31 deletions(-)

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index a24945ea..0ccf010b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -2,7 +2,7 @@
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
-    , RichToken(..)
+    , RichToken(..), RichTokenType(..), TokenDetails(..)
     ) where
 
 import Haddock.Backends.Hyperlinker.Parser
@@ -15,33 +15,52 @@ import Data.Maybe
 
 data RichToken = RichToken
     { rtkToken :: Token
-    , rtkName :: Maybe GHC.Name
+    , rtkDetails :: Maybe TokenDetails
     }
 
+data TokenDetails = TokenDetails
+    { rtkType :: RichTokenType
+    , rtkName :: GHC.Name
+    }
+
+data RichTokenType
+    = RtkVar
+    | RtkType
+
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
         { rtkToken = token
-        , rtkName = lookupBySpan (tkSpan token) nameMap
+        , rtkDetails = lookupBySpan (tkSpan token) detailsMap
         }
   where
-    nameMap = variables src
+    detailsMap = variables src ++ types src
 
-type NameMap = [(GHC.SrcSpan, GHC.Name)]
+type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
-lookupBySpan :: Span -> NameMap -> Maybe GHC.Name
+lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
 lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
 
 everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
            -> (forall a. Data a => a -> r)
 everything k f x = foldl k (f x) (gmapQ (everything k f) x)
 
-variables :: GHC.RenamedSource -> NameMap
+variables :: GHC.RenamedSource -> DetailsMap
 variables =
     everything (<|>) var
   where
     var term = case cast term of
-        (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid)
+        (Just (GHC.L sspan (GHC.HsVar name))) ->
+            pure (sspan, TokenDetails RtkVar name)
+        _ -> empty
+
+types :: GHC.RenamedSource -> DetailsMap
+types =
+    everything (<|>) ty
+  where
+    ty term = case cast term of
+        (Just (GHC.L sspan (GHC.HsTyVar name))) ->
+            pure (sspan, TokenDetails RtkType name)
         _ -> empty
 
 matches :: Span -> GHC.SrcSpan -> Bool
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 3c6fe14f..c2bca438 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -6,10 +6,14 @@ import Haddock.Backends.Hyperlinker.Ast
 import qualified GHC
 import qualified Name as GHC
 
+import Data.List
 import Data.Monoid
+
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
+type StyleClass = String
+
 render :: Maybe FilePath -> [RichToken] -> Html
 render css tokens = header css <> body tokens
 
@@ -28,29 +32,43 @@ header (Just css) =
         ]
 
 richToken :: RichToken -> Html
-richToken (RichToken t Nothing) = token t
-richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name
-
-token :: Token -> Html
-token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
-
-tokenAttrs :: TokenType -> [HtmlAttr]
-tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"]
-tokenAttrs TkKeyword = [Html.theclass "hs-keyword"]
-tokenAttrs TkString = [Html.theclass "hs-string"]
-tokenAttrs TkChar = [Html.theclass "hs-char"]
-tokenAttrs TkNumber = [Html.theclass "hs-number"]
-tokenAttrs TkOperator = [Html.theclass "hs-operator"]
-tokenAttrs TkGlyph = [Html.theclass "hs-glyph"]
-tokenAttrs TkSpecial = [Html.theclass "hs-special"]
-tokenAttrs TkSpace = []
-tokenAttrs TkComment = [Html.theclass "hs-comment"]
-tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
-tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
-tokenAttrs TkUnknown = []
-
-nameAttrs :: GHC.Name -> [HtmlAttr]
-nameAttrs name =
+richToken (RichToken tok Nothing) =
+    tokenSpan tok ! attrs
+  where
+    attrs = [ multiclass . tokenStyle . tkType $ tok ]
+richToken (RichToken tok (Just det)) =
+    Html.anchor content ! (anchorAttrs . rtkName) det
+  where
+    content = tokenSpan tok ! [ multiclass style]
+    style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
+
+tokenSpan :: Token -> Html
+tokenSpan = Html.thespan . Html.toHtml . tkValue
+
+richTokenStyle :: RichTokenType -> [StyleClass]
+richTokenStyle RtkVar = ["hs-var"]
+richTokenStyle RtkType = ["hs-type"]
+
+tokenStyle :: TokenType -> [StyleClass]
+tokenStyle TkIdentifier = ["hs-identifier"]
+tokenStyle TkKeyword = ["hs-keyword"]
+tokenStyle TkString = ["hs-string"]
+tokenStyle TkChar = ["hs-char"]
+tokenStyle TkNumber = ["hs-number"]
+tokenStyle TkOperator = ["hs-operator"]
+tokenStyle TkGlyph = ["hs-glyph"]
+tokenStyle TkSpecial = ["hs-special"]
+tokenStyle TkSpace = []
+tokenStyle TkComment = ["hs-comment"]
+tokenStyle TkCpp = ["hs-cpp"]
+tokenStyle TkPragma = ["hs-pragma"]
+tokenStyle TkUnknown = []
+
+multiclass :: [StyleClass] -> HtmlAttr
+multiclass = Html.theclass . intercalate " "
+
+anchorAttrs :: GHC.Name -> [HtmlAttr]
+anchorAttrs name =
     [ Html.href (maybe "" id mmod ++ "#" ++ ident)
     , Html.theclass "varid-reference"
     ]
-- 
cgit v1.2.3