aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs35
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs64
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"
]