From 60db14903e01f4c26f179230c7b6190a7b99fb51 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 21:49:46 +0200
Subject: Refactor the way AST names are handled within detailed tokens.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 37 +++++++++++-----------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 17 ++++++----
 2 files changed, 29 insertions(+), 25 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index cb9508ef..3c07ff3c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -3,7 +3,7 @@
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
-    , RichToken(..), RichTokenType(..), TokenDetails(..)
+    , RichToken(..), TokenDetails(..), rtkName
     ) where
 
 import Haddock.Backends.Hyperlinker.Parser
@@ -19,16 +19,17 @@ data RichToken = RichToken
     , rtkDetails :: Maybe TokenDetails
     }
 
-data TokenDetails = TokenDetails
-    { rtkType :: RichTokenType
-    , rtkName :: GHC.Name
-    }
+data TokenDetails
+    = RtkVar GHC.Name
+    | RtkType GHC.Name
+    | RtkBind GHC.Name
+    | RtkDecl GHC.Name
 
-data RichTokenType
-    = RtkVar
-    | RtkType
-    | RtkBind
-    | RtkDecl
+rtkName :: TokenDetails -> GHC.Name
+rtkName (RtkVar name) = name
+rtkName (RtkType name) = name
+rtkName (RtkBind name) = name
+rtkName (RtkDecl name) = name
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -68,7 +69,7 @@ variables =
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
-            pure (sspan, TokenDetails RtkVar name)
+            pure (sspan, RtkVar name)
         _ -> empty
 
 types :: GHC.RenamedSource -> DetailsMap
@@ -77,7 +78,7 @@ types =
   where
     ty term = case cast term of
         (Just (GHC.L sspan (GHC.HsTyVar name))) ->
-            pure (sspan, TokenDetails RtkType name)
+            pure (sspan, RtkType name)
         _ -> empty
 
 binds :: GHC.RenamedSource -> DetailsMap
@@ -86,11 +87,11 @@ binds =
   where
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
-            pure (sspan, TokenDetails RtkBind name)
+            pure (sspan, RtkBind name)
         _ -> empty
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
-            pure (sspan, TokenDetails RtkBind name)
+            pure (sspan, RtkBind name)
         _ -> empty
 
 decls :: GHC.RenamedSource -> DetailsMap
@@ -101,10 +102,10 @@ decls (group, _, _, _) = concatMap ($ group)
   where
     typ (GHC.L _ t) =
         let (GHC.L sspan name) = GHC.tcdLName t
-        in (sspan, TokenDetails RtkDecl name)
+        in (sspan, RtkDecl name)
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
-            | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name)
+            | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
 
 imports :: GHC.RenamedSource -> DetailsMap
@@ -117,8 +118,8 @@ imports =
         (Just (GHC.IEThingAll t)) -> pure $ typ t
         (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
         _ -> empty
-    typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name)
-    var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name)
+    typ (GHC.L sspan name) = (sspan, RtkType name)
+    var (GHC.L sspan name) = (sspan, RtkVar name)
 
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 99a0f337..e08d8974 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -41,14 +41,14 @@ richToken (RichToken tok (Just det)) =
     externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
-    style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
+    style = (tokenStyle . tkType) tok ++ richTokenStyle det
 
 tokenSpan :: Token -> Html
 tokenSpan = Html.thespan . Html.toHtml . tkValue
 
-richTokenStyle :: RichTokenType -> [StyleClass]
-richTokenStyle RtkVar = ["hs-var"]
-richTokenStyle RtkType = ["hs-type"]
+richTokenStyle :: TokenDetails -> [StyleClass]
+richTokenStyle (RtkVar _) = ["hs-var"]
+richTokenStyle (RtkType _) = ["hs-type"]
 richTokenStyle _ = []
 
 tokenStyle :: TokenType -> [StyleClass]
@@ -70,12 +70,12 @@ multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
 externalAnchor :: TokenDetails -> Html -> Html
-externalAnchor (TokenDetails RtkDecl name) content =
+externalAnchor (RtkDecl name) content =
     Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
 externalAnchor _ content = content
 
 internalAnchor :: TokenDetails -> Html -> Html
-internalAnchor (TokenDetails RtkBind name) content =
+internalAnchor (RtkBind name) content =
     Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
 internalAnchor _ content = content
 
@@ -86,9 +86,12 @@ internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
 hyperlink :: TokenDetails -> Html -> Html
-hyperlink (TokenDetails _ name) = if GHC.isInternalName name
+hyperlink details =
+    if GHC.isInternalName $ name
     then internalHyperlink name
     else externalHyperlink name
+  where
+    name = rtkName details
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
-- 
cgit v1.2.3