From 5e904cb1c3d769d5b99d459838b4b5368c8c1fb7 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 12:59:10 +0200 Subject: Create simple HTML renderer for parsed source file. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 26 ++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs new file mode 100644 index 00000000..eaf5b37b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -0,0 +1,26 @@ +module Haddock.Backends.Hyperlinker.Renderer where + +import Haddock.Backends.Hyperlinker.Parser + +import Data.Monoid +import Text.XHtml + +render :: [Token] -> Html +render = body . pre . foldr (<>) noHtml . map renderToken + +renderToken :: Token -> Html +renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t + +tokenAttrs :: TokenType -> [HtmlAttr] +tokenAttrs TkIdentifier = [theclass "hs-identifier"] +tokenAttrs TkKeyword = [theclass "hs-keyword"] +tokenAttrs TkString = [theclass "hs-string"] +tokenAttrs TkChar = [theclass "hs-char"] +tokenAttrs TkNumber = [theclass "hs-number"] +tokenAttrs TkOperator = [theclass "hs-operator"] +tokenAttrs TkGlyph = [theclass "hs-glyph"] +tokenAttrs TkSpecial = [theclass "hs-special"] +tokenAttrs TkSpace = [] +tokenAttrs TkComment = [theclass "hs-comment"] +tokenAttrs TkCpp = [theclass "hs-cpp"] +tokenAttrs TkUnknown = [] -- cgit v1.2.3 From 1a43f35e2dacc9837f9762fd211d63ae6cc7b4a3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 13:58:47 +0200 Subject: Add support for specifying the CSS file path in HTML source renderer. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 45 ++++++++++++++-------- 1 file changed, 30 insertions(+), 15 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index eaf5b37b..9ebb8707 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -3,24 +3,39 @@ module Haddock.Backends.Hyperlinker.Renderer where import Haddock.Backends.Hyperlinker.Parser import Data.Monoid -import Text.XHtml +import Text.XHtml (Html, HtmlAttr, (!)) +import qualified Text.XHtml as Html -render :: [Token] -> Html -render = body . pre . foldr (<>) noHtml . map renderToken +render :: Maybe FilePath -> [Token] -> Html +render css tokens = header css <> body tokens -renderToken :: Token -> Html -renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t +body :: [Token] -> Html +body = Html.body . Html.pre . mconcat . map token + +header :: Maybe FilePath -> Html +header Nothing = Html.noHtml +header (Just css) = + Html.header $ Html.thelink Html.noHtml ! attrs + where + attrs = + [ Html.rel "stylesheet" + , Html.href css + , Html.thetype "text/css" + ] + +token :: Token -> Html +token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t tokenAttrs :: TokenType -> [HtmlAttr] -tokenAttrs TkIdentifier = [theclass "hs-identifier"] -tokenAttrs TkKeyword = [theclass "hs-keyword"] -tokenAttrs TkString = [theclass "hs-string"] -tokenAttrs TkChar = [theclass "hs-char"] -tokenAttrs TkNumber = [theclass "hs-number"] -tokenAttrs TkOperator = [theclass "hs-operator"] -tokenAttrs TkGlyph = [theclass "hs-glyph"] -tokenAttrs TkSpecial = [theclass "hs-special"] +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 = [theclass "hs-comment"] -tokenAttrs TkCpp = [theclass "hs-cpp"] +tokenAttrs TkComment = [Html.theclass "hs-comment"] +tokenAttrs TkCpp = [Html.theclass "hs-cpp"] tokenAttrs TkUnknown = [] -- cgit v1.2.3 From e5bd5d39550692f936c973637f8ec8d314919359 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 5 Jun 2015 15:12:40 +0200 Subject: Add support for recognizing compiler pragmas in source parser. --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 ++ haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 + 2 files changed, 3 insertions(+) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 29edb4c3..0e1ad5b2 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -35,6 +35,7 @@ data TokenType | TkSpace | TkComment | TkCpp + | TkPragma | TkUnknown parse :: String -> [Token] @@ -92,6 +93,7 @@ tokenize = classify :: String -> TokenType classify str | "--" `isPrefixOf` str = TkComment + | "{-#" `isPrefixOf` str = TkPragma | "{-" `isPrefixOf` str = TkComment classify (c:_) | isSpace c = TkSpace diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 9ebb8707..39d7d183 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -38,4 +38,5 @@ 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 = [] -- cgit v1.2.3 From cb3ece1a493eb444ccb61b6ad3c74e922184b63e Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 21:43:15 +0200 Subject: Add dummy support for hyperlinking named tokens. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 23 +++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 39d7d183..32d2c863 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,16 +1,20 @@ module Haddock.Backends.Hyperlinker.Renderer where import Haddock.Backends.Hyperlinker.Parser +import Haddock.Backends.Hyperlinker.Ast + +import qualified GHC +import qualified Name as GHC import Data.Monoid import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html -render :: Maybe FilePath -> [Token] -> Html +render :: Maybe FilePath -> [RichToken] -> Html render css tokens = header css <> body tokens -body :: [Token] -> Html -body = Html.body . Html.pre . mconcat . map token +body :: [RichToken] -> Html +body = Html.body . Html.pre . mconcat . map richToken header :: Maybe FilePath -> Html header Nothing = Html.noHtml @@ -23,6 +27,10 @@ header (Just css) = , Html.thetype "text/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 @@ -40,3 +48,12 @@ 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 = + [ Html.href (maybe "" id mmod ++ "#" ++ ident) + , Html.theclass "varid-reference" + ] + where + mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name + ident = GHC.occNameString . GHC.nameOccName $ name -- cgit v1.2.3 From 9a51a6d3f686736354e26137363ea979a5e38076 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 6 Jun 2015 23:40:36 +0200 Subject: Constrain elements exported by hyperlinker modules. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 5 ++++- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 7d88b7fb..a24945ea 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,6 +1,9 @@ {-# LANGUAGE RankNTypes #-} -module Haddock.Backends.Hyperlinker.Ast where +module Haddock.Backends.Hyperlinker.Ast + ( enrich + , RichToken(..) + ) where import Haddock.Backends.Hyperlinker.Parser diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 32d2c863..3c6fe14f 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,4 +1,4 @@ -module Haddock.Backends.Hyperlinker.Renderer where +module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast -- cgit v1.2.3 From 666af8d2f29c05d22bb5930d115c42509528bb90 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak 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(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') 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 From 70656933ca6935bde0a00310f37440e02c3f21ff Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 00:13:12 +0200 Subject: Add support for binding token recognition. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 +++++++++++++++++++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 + 2 files changed, 20 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 0ccf010b..19ebbe77 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Backends.Hyperlinker.Ast ( enrich @@ -26,6 +27,7 @@ data TokenDetails = TokenDetails data RichTokenType = RtkVar | RtkType + | RtkBind enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -34,7 +36,7 @@ enrich src = , rtkDetails = lookupBySpan (tkSpan token) detailsMap } where - detailsMap = variables src ++ types src + detailsMap = variables src ++ types src ++ binds src type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -45,6 +47,9 @@ 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) +combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) +combine f g x = f x <|> g x + variables :: GHC.RenamedSource -> DetailsMap variables = everything (<|>) var @@ -63,6 +68,19 @@ types = pure (sspan, TokenDetails RtkType name) _ -> empty +binds :: GHC.RenamedSource -> DetailsMap +binds = + everything (<|>) (fun `combine` pat) + where + fun term = case cast term of + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) -> + pure (sspan, TokenDetails RtkBind name) + _ -> empty + pat term = case cast term of + (Just (GHC.L sspan (GHC.VarPat name))) -> + pure (sspan, TokenDetails RtkBind name) + _ -> empty + matches :: Span -> GHC.SrcSpan -> Bool matches tspan (GHC.RealSrcSpan aspan) | rs && cs && re && ce = True diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index c2bca438..57851c22 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -48,6 +48,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] +richTokenStyle RtkBind = ["hs-bind"] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] -- cgit v1.2.3 From 21984e4cfcc076ce8cbee934028a1b37aaca930b Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 8 Jun 2015 00:54:58 +0200 Subject: Implement go-to-definition mechanism for local bindings. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 30 +++++++++++++++++----- 1 file changed, 23 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 57851c22..995e24e6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -5,6 +5,7 @@ import Haddock.Backends.Hyperlinker.Ast import qualified GHC import qualified Name as GHC +import qualified Unique as GHC import Data.List import Data.Monoid @@ -37,7 +38,7 @@ richToken (RichToken tok Nothing) = where attrs = [ multiclass . tokenStyle . tkType $ tok ] richToken (RichToken tok (Just det)) = - Html.anchor content ! (anchorAttrs . rtkName) det + internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det @@ -48,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] -richTokenStyle RtkBind = ["hs-bind"] +richTokenStyle RtkBind = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] @@ -68,11 +69,26 @@ 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" - ] +internalAnchor :: TokenDetails -> Html -> Html +internalAnchor (TokenDetails RtkBind name) content = + Html.anchor content ! [ Html.name $ internalAnchorIdent name ] +internalAnchor _ content = content + +internalAnchorIdent :: GHC.Name -> String +internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique + +hyperlink :: TokenDetails -> Html -> Html +hyperlink (TokenDetails _ name) = if GHC.isInternalName name + then internalHyperlink name + else externalHyperlink name + +internalHyperlink :: GHC.Name -> Html -> Html +internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] + +externalHyperlink :: GHC.Name -> Html -> Html +externalHyperlink name content = + Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name ident = GHC.occNameString . GHC.nameOccName $ name -- cgit v1.2.3 From 162b02ed6f50709ea203bf7706eee5804e455419 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 01:03:13 +0200 Subject: Add support for type declaration anchors. --- haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 21 ++++++++++++++++----- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 14 +++++++++++--- 2 files changed, 27 insertions(+), 8 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 2749096e..39bbacf5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -28,6 +28,7 @@ data RichTokenType = RtkVar | RtkType | RtkBind + | RtkDecl enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -36,11 +37,12 @@ enrich src = , rtkDetails = enrichToken token detailsMap } where - detailsMap = concat - [ variables src - , types src - , binds src - , imports src + detailsMap = concatMap ($ src) + [ variables + , types + , binds + , imports + , decls ] type DetailsMap = [(GHC.SrcSpan, TokenDetails)] @@ -91,6 +93,15 @@ binds = pure (sspan, TokenDetails RtkBind name) _ -> empty +decls :: GHC.RenamedSource -> DetailsMap +decls (group, _, _, _) = concatMap ($ group) + [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds + ] + where + typ (GHC.L _ t) = + let (GHC.L sspan name) = GHC.tcdLName t + in (sspan, TokenDetails RtkDecl name) + imports :: GHC.RenamedSource -> DetailsMap imports = everything (<|>) ie diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 995e24e6..b7cc5aeb 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -38,7 +38,7 @@ richToken (RichToken tok Nothing) = where attrs = [ multiclass . tokenStyle . tkType $ tok ] richToken (RichToken tok (Just det)) = - internalAnchor det . hyperlink det $ content + externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det @@ -49,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue richTokenStyle :: RichTokenType -> [StyleClass] richTokenStyle RtkVar = ["hs-var"] richTokenStyle RtkType = ["hs-type"] -richTokenStyle RtkBind = [] +richTokenStyle _ = [] tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] @@ -69,11 +69,19 @@ tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr multiclass = Html.theclass . intercalate " " +externalAnchor :: TokenDetails -> Html -> Html +externalAnchor (TokenDetails RtkDecl name) content = + Html.anchor content ! [ Html.name $ externalAnchorIdent name ] +externalAnchor _ content = content + internalAnchor :: TokenDetails -> Html -> Html internalAnchor (TokenDetails RtkBind name) content = Html.anchor content ! [ Html.name $ internalAnchorIdent name ] internalAnchor _ content = content +externalAnchorIdent :: GHC.Name -> String +externalAnchorIdent = GHC.occNameString . GHC.nameOccName + internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique @@ -91,4 +99,4 @@ externalHyperlink name content = Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name - ident = GHC.occNameString . GHC.nameOccName $ name + ident = externalAnchorIdent name -- cgit v1.2.3 From 1064953c6590c05303c6cbd2230b9e13d3ba1376 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 12 Jun 2015 10:57:30 +0200 Subject: Fix external anchors to contain HTML file extension. --- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index b7cc5aeb..99a0f337 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -96,7 +96,7 @@ internalHyperlink name content = externalHyperlink :: GHC.Name -> Html -> Html externalHyperlink name content = - Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ] + Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ] where mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name ident = externalAnchorIdent name -- cgit v1.2.3 From 60db14903e01f4c26f179230c7b6190a7b99fb51 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak 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/src/Haddock/Backends/Hyperlinker/Renderer.hs') 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 From a85224a68b51b70035446ad8e5565d571c4a10d4 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 17 Jun 2015 22:22:49 +0200 Subject: Implement hyperlinking of imported module names. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 19 +++++++++------ .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 28 +++++++++++++--------- 2 files changed, 29 insertions(+), 18 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3c07ff3c..10389958 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -24,12 +24,14 @@ data TokenDetails | RtkType GHC.Name | RtkBind GHC.Name | RtkDecl GHC.Name + | RtkModule GHC.ModuleName -rtkName :: TokenDetails -> GHC.Name -rtkName (RtkVar name) = name -rtkName (RtkType name) = name -rtkName (RtkBind name) = name -rtkName (RtkDecl name) = name +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name enrich :: GHC.RenamedSource -> [Token] -> [RichToken] enrich src = @@ -109,8 +111,8 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty imports :: GHC.RenamedSource -> DetailsMap -imports = - everything (<|>) ie +imports src@(_, imps, _, _) = + everything (<|>) ie src ++ map (imp . GHC.unLoc) imps where ie term = case cast term of (Just (GHC.IEVar v)) -> pure $ var v @@ -120,6 +122,9 @@ imports = _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) + imp idecl = + let (GHC.L sspan name) = GHC.ideclName idecl + in (sspan, RtkModule 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 e08d8974..70524759 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -8,6 +8,7 @@ import qualified Name as GHC import qualified Unique as GHC import Data.List +import Data.Maybe import Data.Monoid import Text.XHtml (Html, HtmlAttr, (!)) @@ -86,20 +87,25 @@ internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique hyperlink :: TokenDetails -> Html -> Html -hyperlink details = - if GHC.isInternalName $ name - then internalHyperlink name - else externalHyperlink name - where - name = rtkName details +hyperlink details = case rtkName details of + Left name -> + if GHC.isInternalName name + then internalHyperlink name + else externalHyperlink mname (Just name) + where + mname = GHC.moduleName <$> GHC.nameModule_maybe name + Right name -> externalHyperlink (Just name) Nothing internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: GHC.Name -> Html -> Html -externalHyperlink name content = - Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ] +externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html +externalHyperlink mmname miname content = + Html.anchor content ! [ Html.href $ path ++ anchor ] where - mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name - ident = externalAnchorIdent name + path = fromMaybe "" $ modulePath <$> mmname + anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + +modulePath :: GHC.ModuleName -> String +modulePath name = GHC.moduleNameString name ++ ".html" -- cgit v1.2.3 From a6bd86a8550d5d7e8bdb12e1d09036b9f88eed73 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 22 Jun 2015 17:41:31 +0200 Subject: Add support for fancy highlighting upon hovering over identifier. --- haddock-api/haddock-api.cabal | 1 + haddock-api/resources/html/highlight.js | 46 ++++++++++++++++++++++ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 10 ++++- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 23 +++++++---- 4 files changed, 70 insertions(+), 10 deletions(-) create mode 100644 haddock-api/resources/html/highlight.js (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 14656994..216627cc 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -21,6 +21,7 @@ data-files: html/solarized.css html/frames.html html/haddock-util.js + html/highlight.js html/Classic.theme/haskell_icon.gif html/Classic.theme/minus.gif html/Classic.theme/plus.gif diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js new file mode 100644 index 00000000..639cf5d5 --- /dev/null +++ b/haddock-api/resources/html/highlight.js @@ -0,0 +1,46 @@ + +var styleForRule = function (rule) { + var sheets = document.styleSheets; + for (var s = 0; s < sheets.length; s++) { + var rules = sheets[s].cssRules; + for (var r = 0; r < rules.length; r++) { + if (rules[r].selectorText == rule) { + return rules[r].style; + } + } + } +}; + +var highlight = function () { + var color = styleForRule("a:hover")["background-color"]; + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = color; + } + } +}; + +/* + * I have no idea what is the proper antonym for "highlight" in this + * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously + * so I like it. + */ +var lowlight = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + var that = links[i]; + if (this.href == that.href) { + that.style["background-color"] = ""; + } + } +}; + +window.onload = function () { + var links = document.getElementsByTagName('a'); + for (var i = 0; i < links.length; i++) { + links[i].onmouseover = highlight; + links[i].onmouseout = lowlight; + } +}; diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 66392a67..9337307c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -16,14 +16,17 @@ ppHyperlinkedSource outdir libdir mstyle ifaces = do createDirectoryIfMissing True $ srcPath outdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcPath outdir srcCssFile + copyFile (libdir "html" highlightScript) $ + srcPath outdir highlightScript mapM_ (ppHyperlinkedModuleSource outdir) ifaces ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens + Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where - mSrcCssFile = Just $ srcCssFile + mCssFile = Just $ srcCssFile + mJsFile = Just $ highlightScript path = srcPath outdir moduleSourceFile (ifaceMod iface) moduleSourceFile :: Module -> FilePath @@ -35,5 +38,8 @@ srcPath outdir = outdir "src" srcCssFile :: FilePath srcCssFile = "style.css" +highlightScript :: FilePath +highlightScript = "highlight.js" + defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 70524759..6d6d2012 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -16,21 +16,28 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> [RichToken] -> Html -render css tokens = header css <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html +render mcss mjs tokens = header mcss mjs <> body tokens body :: [RichToken] -> Html body = Html.body . Html.pre . mconcat . map richToken -header :: Maybe FilePath -> Html -header Nothing = Html.noHtml -header (Just css) = - Html.header $ Html.thelink Html.noHtml ! attrs +header :: Maybe FilePath -> Maybe FilePath -> Html +header mcss mjs + | isNothing mcss && isNothing mjs = Html.noHtml +header mcss mjs = + Html.header $ css mcss <> js mjs where - attrs = + css Nothing = Html.noHtml + css (Just cssFile) = Html.thelink Html.noHtml ! [ Html.rel "stylesheet" - , Html.href css , Html.thetype "text/css" + , Html.href cssFile + ] + js Nothing = Html.noHtml + js (Just jsFile) = Html.script Html.noHtml ! + [ Html.thetype "text/javascript" + , Html.src jsFile ] richToken :: RichToken -> Html -- cgit v1.2.3 From d58bcf24dfa4333e7893935eb86c036be28125b1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:41:07 +0200 Subject: Make external hyperlinks point to locations specified by source URLs. --- haddock-api/src/Haddock.hs | 7 ++- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 8 ++-- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 5 ++- 4 files changed, 44 insertions(+), 28 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 01e4cd45..3105edf5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -264,7 +264,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl | otherwise = Nothing - srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity + srcMap' + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap + | Flag_HyperlinkedSource `elem` flags = + Map.insert pkgKey defaultNameSourceUrl srcMap + | otherwise = srcMap + -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 2ed4dbdd..6c66e0c6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,10 +1,10 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types -import Haddock.Utils import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) @@ -29,7 +29,8 @@ ppHyperlinkedSource outdir libdir mstyle urls ifaces = do ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens + Just tokens -> + writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile @@ -49,6 +50,3 @@ highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" - -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 6d6d2012..2df62938 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -2,12 +2,16 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Utils +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import qualified GHC import qualified Name as GHC import qualified Unique as GHC import Data.List +import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -16,11 +20,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html +render mcss mjs urls tokens = header mcss mjs <> body urls tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: SourceURLs -> [RichToken] -> Html +body urls = Html.body . Html.pre . mconcat . map (richToken urls) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -40,13 +44,13 @@ header mcss mjs = , Html.src jsFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: SourceURLs -> RichToken -> Html +richToken _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken urls (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink urls det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -93,26 +97,32 @@ externalAnchorIdent = GHC.occNameString . GHC.nameOccName internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: SourceURLs -> TokenDetails -> Html -> Html +hyperlink urls details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalHyperlink mname (Just name) - where - mname = GHC.moduleName <$> GHC.nameModule_maybe name - Right name -> externalHyperlink (Just name) Nothing + else externalNameHyperlink urls name + Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html -externalHyperlink mmname miname content = - Html.anchor content ! [ Html.href $ path ++ anchor ] +externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html +externalNameHyperlink urls name = + case Map.lookup key $ srcNameUrlMap urls of + Just url -> externalNameHyperlink' url name + Nothing -> id where - path = fromMaybe "" $ modulePath <$> mmname - anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + key = GHC.modulePackageKey . GHC.nameModule $ name -modulePath :: GHC.ModuleName -> String -modulePath name = GHC.moduleNameString name ++ ".html" +externalNameHyperlink' :: String -> GHC.Name -> Html -> Html +externalNameHyperlink' url name content = + Html.anchor content ! [ Html.href $ href ] + where + mdl = GHC.nameModule name + href = spliceURL Nothing (Just mdl) (Just name) Nothing url + +externalModHyperlink :: GHC.ModuleName -> Html -> Html +externalModHyperlink _ = id -- TODO diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 78c78aca..047d9fd0 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, + defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -281,6 +281,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r defaultModuleSourceUrl :: String defaultModuleSourceUrl = "src/%{MODULE}.html" +defaultNameSourceUrl :: String +defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir -- cgit v1.2.3 From ab070206d67748232995a262b533957a5a7b9315 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 27 Jun 2015 18:03:56 +0200 Subject: Rewrite source generation to fixed links and directory structure. --- haddock-api/src/Haddock.hs | 11 +++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 29 +++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++------------- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 48 +++++++++++++++----- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 14 +++--- haddock-api/src/Haddock/Utils.hs | 8 ---- 6 files changed, 85 insertions(+), 77 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 3105edf5..d596c075 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -260,14 +260,13 @@ render dflags flags qual ifaces installedIfaces srcMap = do (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcModule' - | isJust srcModule = srcModule - | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl - | otherwise = Nothing + | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat + | otherwise = srcModule srcMap' - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey defaultNameSourceUrl srcMap + Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap | otherwise = srcMap -- TODO: Get these from the interface files as with srcMap @@ -322,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 6c66e0c6..f197eaa3 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,8 +1,9 @@ -module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where +module Haddock.Backends.Hyperlinker + ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Utils + ) where import Haddock.Types -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils @@ -14,36 +15,30 @@ import System.FilePath ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath - -> SourceURLs -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle urls ifaces = do +ppHyperlinkedSource outdir libdir mstyle ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir) ifaces where - srcdir = srcPath outdir urls + srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () -ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of +ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () +ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of Just tokens -> - writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens + writeFile path $ showHtml . render mCssFile mJsFile $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile mJsFile = Just $ highlightScript - srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $ - srcModUrl urls - path = outdir srcFile - -srcPath :: FilePath -> SourceURLs -> FilePath -srcPath outdir urls = outdir takeDirectory (srcModUrl urls) + path = srcdir hypSrcModuleFile (ifaceMod iface) srcCssFile :: FilePath -srcCssFile = "srcstyle.css" +srcCssFile = "style.css" highlightScript :: FilePath highlightScript = "highlight.js" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 2df62938..d8ea5ec7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -3,15 +3,12 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast import Haddock.Backends.Hyperlinker.Utils -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils import qualified GHC import qualified Name as GHC import qualified Unique as GHC import Data.List -import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -20,11 +17,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html -render mcss mjs urls tokens = header mcss mjs <> body urls tokens +render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html +render mcss mjs tokens = header mcss mjs <> body tokens -body :: SourceURLs -> [RichToken] -> Html -body urls = Html.body . Html.pre . mconcat . map (richToken urls) +body :: [RichToken] -> Html +body = Html.body . Html.pre . mconcat . map richToken header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -39,18 +36,18 @@ header mcss mjs = , Html.href cssFile ] js Nothing = Html.noHtml - js (Just jsFile) = Html.script Html.noHtml ! + js (Just scriptFile) = Html.script Html.noHtml ! [ Html.thetype "text/javascript" - , Html.src jsFile + , Html.src scriptFile ] -richToken :: SourceURLs -> RichToken -> Html -richToken _ (RichToken tok Nothing) = +richToken :: RichToken -> Html +richToken (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken urls (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink urls det $ content +richToken (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -92,37 +89,30 @@ internalAnchor (RtkBind name) content = internalAnchor _ content = content externalAnchorIdent :: GHC.Name -> String -externalAnchorIdent = GHC.occNameString . GHC.nameOccName +externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: SourceURLs -> TokenDetails -> Html -> Html -hyperlink urls details = case rtkName details of +hyperlink :: TokenDetails -> Html -> Html +hyperlink details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink urls name + else externalNameHyperlink name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html -externalNameHyperlink urls name = - case Map.lookup key $ srcNameUrlMap urls of - Just url -> externalNameHyperlink' url name - Nothing -> id +externalNameHyperlink :: GHC.Name -> Html -> Html +externalNameHyperlink name content = + Html.anchor content ! [ Html.href href ] where - key = GHC.modulePackageKey . GHC.nameModule $ name - -externalNameHyperlink' :: String -> GHC.Name -> Html -> Html -externalNameHyperlink' url name content = - Html.anchor content ! [ Html.href $ href ] - where - mdl = GHC.nameModule name - href = spliceURL Nothing (Just mdl) (Just name) Nothing url + href = hypSrcModuleNameUrl (GHC.nameModule name) name externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink _ = id -- TODO +externalModHyperlink mdl content = + Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] + diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 25ed942b..9ba8446d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -1,18 +1,46 @@ module Haddock.Backends.Hyperlinker.Utils - ( srcModUrl - , srcNameUrlMap + ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' + , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl + , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, ) where -import Haddock.Utils -import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import GHC +import System.FilePath.Posix (()) -import Data.Maybe -import Data.Map (Map) -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl +hypSrcDir :: FilePath +hypSrcDir = "src" -srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath -srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap +hypSrcModuleFile :: Module -> FilePath +hypSrcModuleFile = hypSrcModuleFile' . moduleName + +hypSrcModuleFile' :: ModuleName -> FilePath +hypSrcModuleFile' mdl = spliceURL' + Nothing (Just mdl) Nothing Nothing moduleFormat + +hypSrcModuleUrl :: Module -> String +hypSrcModuleUrl = hypSrcModuleFile + +hypSrcModuleUrl' :: ModuleName -> String +hypSrcModuleUrl' = hypSrcModuleFile' + +hypSrcNameUrl :: Name -> String +hypSrcNameUrl name = spliceURL + Nothing Nothing (Just name) Nothing nameFormat + +hypSrcModuleNameUrl :: Module -> Name -> String +hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name + +hypSrcModuleUrlFormat :: String +hypSrcModuleUrlFormat = hypSrcDir moduleFormat + +hypSrcModuleNameUrlFormat :: String +hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat + +moduleFormat :: String +moduleFormat = "%{MODULE}.html" + +nameFormat :: String +nameFormat = "%{NAME}" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index cbcbbd6d..36ecf863 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Utils ( renderToString, namedAnchor, linkedAnchor, - spliceURL, + spliceURL, spliceURL', groupId, (<+>), (<=>), char, @@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils ( ) where -import Haddock.GhcUtils import Haddock.Utils import Data.Maybe @@ -38,18 +37,23 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module ) +import Module ( Module, ModuleName, moduleName, moduleNameString ) import Name ( getOccString, nameOccName, isValOcc ) spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc = run +spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod) + + +spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of Nothing -> "" - Just m -> moduleString m + Just m -> moduleNameString m (name, kind) = case maybe_name of diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 047d9fd0..4fed3a1e 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,6 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -278,13 +277,6 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r -- NB: '-' is legal in IDs, but we use it as the escape char -defaultModuleSourceUrl :: String -defaultModuleSourceUrl = "src/%{MODULE}.html" - -defaultNameSourceUrl :: String -defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" - - ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir ------------------------------------------------------------------------------- -- cgit v1.2.3 From a6eb5a19b13bc4dfa79d0e55e5992dfa403aa3c3 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:00:55 +0200 Subject: Add basic support for cross-package hyperlink generation. --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 25 ++++++------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 42 +++++++++++++--------- 3 files changed, 40 insertions(+), 29 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d596c075..caaa1eef 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css visibleIfaces + ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap visibleIfaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f197eaa3..f2caa2c1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -8,33 +8,34 @@ import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) +import GHC import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath - -> Maybe FilePath - -> [Interface] +ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath + -> PackageKey -> SrcMap -> [Interface] -> IO () -ppHyperlinkedSource outdir libdir mstyle ifaces = do +ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces where srcdir = outdir hypSrcDir -ppHyperlinkedModuleSource :: FilePath -> Interface -> IO () -ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of - Just tokens -> - writeFile path $ showHtml . render mCssFile mJsFile $ tokens - Nothing -> return () +ppHyperlinkedModuleSource :: FilePath + -> PackageKey -> SrcMap -> Interface + -> IO () +ppHyperlinkedModuleSource srcdir pkg srcs iface = + case ifaceTokenizedSrc iface of + Just tokens -> writeFile path . showHtml . render' $ tokens + Nothing -> return () where - mCssFile = Just $ srcCssFile - mJsFile = Just $ highlightScript + render' = render (Just srcCssFile) (Just highlightScript) pkg srcs path = srcdir hypSrcModuleFile (ifaceMod iface) srcCssFile :: FilePath diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index d8ea5ec7..b05a5b8a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,5 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where +import Haddock.Types import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast import Haddock.Backends.Hyperlinker.Utils @@ -8,20 +9,25 @@ import qualified GHC import qualified Name as GHC import qualified Unique as GHC +import System.FilePath.Posix (()) + import Data.List import Data.Maybe import Data.Monoid +import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath + -> GHC.PackageKey -> SrcMap -> [RichToken] + -> Html +render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html +body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -41,13 +47,13 @@ header mcss mjs = , Html.src scriptFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html +richToken _ _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken pkg srcs (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -94,25 +100,29 @@ externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html +hyperlink pkg srcs details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink name + else externalNameHyperlink pkg srcs name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: GHC.Name -> Html -> Html -externalNameHyperlink name content = - Html.anchor content ! [ Html.href href ] +externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink pkg srcs name content + | namePkg == pkg = Html.anchor content ! + [ Html.href $ hypSrcModuleNameUrl mdl name ] + | Just path <- Map.lookup namePkg srcs = Html.anchor content ! + [ Html.href $ path hypSrcModuleNameUrl mdl name ] + | otherwise = content where - href = hypSrcModuleNameUrl (GHC.nameModule name) name + mdl = GHC.nameModule name + namePkg = GHC.modulePackageKey mdl externalModHyperlink :: GHC.ModuleName -> Html -> Html externalModHyperlink mdl content = Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] - -- cgit v1.2.3 From 98cb99c2398a2e2b4467da0a1755d24422384f14 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 28 Jun 2015 21:33:03 +0200 Subject: Disable generating hyperlinks for module references. --- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index b05a5b8a..89d9b60d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -123,6 +123,13 @@ externalNameHyperlink pkg srcs name content mdl = GHC.nameModule name namePkg = GHC.modulePackageKey mdl +-- TODO: Implement module hyperlinks. +-- +-- Unfortunately, 'ModuleName' is not enough to provide viable cross-package +-- hyperlink. And the problem is that GHC AST does not have other information +-- on imported modules, so for the time being, we do not provide such reference +-- either. externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink mdl content = - Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] +externalModHyperlink _ content = + content + --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] -- cgit v1.2.3 From 868248d5e847e29ffede5b6c7d20f08a3ec7eb47 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Wed, 1 Jul 2015 22:25:21 +0200 Subject: Make hyperlinker render qualified names as one entity. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 50 +++++++++++++++++++--- 2 files changed, 46 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 79e31db7..decb1206 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -25,6 +25,7 @@ data TokenDetails | RtkBind GHC.Name | RtkDecl GHC.Name | RtkModule GHC.ModuleName + deriving (Eq) rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName rtkName (RtkVar name) = Left name diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 89d9b60d..ddb2e5b9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -19,15 +19,46 @@ import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html + type StyleClass = String + render :: Maybe FilePath -> Maybe FilePath -> GHC.PackageKey -> SrcMap -> [RichToken] -> Html render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens + +data TokenGroup + = GrpNormal Token + | GrpRich TokenDetails [Token] + + +-- | Group consecutive tokens pointing to the same element. +-- +-- We want to render qualified identifiers as one entity. For example, +-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for +-- better user experience when highlighting and clicking links, these tokens +-- should be regarded as one identifier. Therefore, before rendering we must +-- group consecutive elements pointing to the same 'GHC.Name' (note that even +-- dot token has it if it is part of qualified name). +groupTokens :: [RichToken] -> [TokenGroup] +groupTokens [] = [] +groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest) +groupTokens ((RichToken tok (Just det)):rest) = + let (grp, rest') = span same rest + in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest') + where + same (RichToken _ (Just det')) = det == det' + same _ = False + + body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html -body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs) +body pkg srcs tokens = + Html.body . Html.pre $ hypsrc + where + hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens + header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -47,20 +78,29 @@ header mcss mjs = , Html.src scriptFile ] -richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html -richToken _ _ (RichToken tok Nothing) = + +tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html +tokenGroup _ _ (GrpNormal tok) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken pkg srcs (RichToken tok (Just det)) = +tokenGroup pkg srcs (GrpRich det tokens) = externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content where - content = tokenSpan tok ! [ multiclass style] + content = mconcat . map (richToken det) $ tokens + + +richToken :: TokenDetails -> Token -> Html +richToken det tok = + tokenSpan tok ! [ multiclass style ] + where style = (tokenStyle . tkType) tok ++ richTokenStyle det + tokenSpan :: Token -> Html tokenSpan = Html.thespan . Html.toHtml . tkValue + richTokenStyle :: TokenDetails -> [StyleClass] richTokenStyle (RtkVar _) = ["hs-var"] richTokenStyle (RtkType _) = ["hs-type"] -- cgit v1.2.3 From 99980dcc63d696c7912ff1f0d2faadcce169f184 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sun, 5 Jul 2015 17:06:36 +0200 Subject: Refactor source path mapping to use modules as indices. --- haddock-api/src/Haddock.hs | 27 ++++++++++------ haddock-api/src/Haddock/Backends/Hyperlinker.hs | 15 ++++----- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 36 ++++++++++------------ haddock-api/src/Haddock/InterfaceFile.hs | 11 ++++--- haddock-api/src/Haddock/Types.hs | 9 +++++- 5 files changed, 55 insertions(+), 43 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 5a1c6abe..5c48d28b 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -46,6 +46,7 @@ import Data.List (isPrefixOf) import Control.Exception import Data.Maybe import Data.IORef +import Data.Map (Map) import qualified Data.Map as Map import System.IO import System.Exit @@ -228,13 +229,14 @@ renderStep dflags flags qual pkgs interfaces = do let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ] - render dflags flags qual interfaces installedIfaces srcMap + extSrcMap = Map.fromList + [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ] + render dflags flags qual interfaces installedIfaces extSrcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render dflags flags qual ifaces installedIfaces srcMap = do +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () +render dflags flags qual ifaces installedIfaces extSrcMap = do let title = fromMaybe "" (optTitle flags) @@ -264,15 +266,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap' + srcMap = Map.union + (Map.map SrcExternal extSrcMap) + (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) + + pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap + pkgSrcMap' | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap - | otherwise = srcMap + Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap + | otherwise = pkgSrcMap -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity - sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') + sourceUrls' = (srcBase, srcModule', pkgSrcMap', srcLMap') libDir <- getHaddockLibDir flags prologue <- getPrologue dflags flags @@ -322,7 +329,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces + ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces -- | From GHC 7.10, this function has a potential to crash with a -- nasty message such as @expectJust getPackageDetails@ because diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 1fadef49..f007f970 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -8,7 +8,6 @@ import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) -import GHC import Data.Maybe import System.Directory @@ -24,30 +23,28 @@ ppHyperlinkedSource :: FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML - -> PackageKey -- ^ Package for which we create source - -> SrcMap -- ^ Paths to external sources + -> SrcMap -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces where srcdir = outdir hypSrcDir -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool - -> PackageKey -> SrcMap -> Interface +ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pretty pkg srcs iface = +ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceTokenizedSrc iface of Just tokens -> writeFile path . html . render' $ tokens Nothing -> return () where - render' = render (Just srcCssFile) (Just highlightScript) pkg srcs + render' = render (Just srcCssFile) (Just highlightScript) srcs html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index ddb2e5b9..a4d7bc2d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -23,10 +23,9 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath - -> GHC.PackageKey -> SrcMap -> [RichToken] +render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] -> Html -render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens +render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens data TokenGroup @@ -53,11 +52,11 @@ groupTokens ((RichToken tok (Just det)):rest) = same _ = False -body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html -body pkg srcs tokens = +body :: SrcMap -> [RichToken] -> Html +body srcs tokens = Html.body . Html.pre $ hypsrc where - hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens + hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens header :: Maybe FilePath -> Maybe FilePath -> Html @@ -79,13 +78,13 @@ header mcss mjs = ] -tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html -tokenGroup _ _ (GrpNormal tok) = +tokenGroup :: SrcMap -> TokenGroup -> Html +tokenGroup _ (GrpNormal tok) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -tokenGroup pkg srcs (GrpRich det tokens) = - externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content +tokenGroup srcs (GrpRich det tokens) = + externalAnchor det . internalAnchor det . hyperlink srcs det $ content where content = mconcat . map (richToken det) $ tokens @@ -140,28 +139,27 @@ externalAnchorIdent = hypSrcNameUrl internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html -hyperlink pkg srcs details = case rtkName details of +hyperlink :: SrcMap -> TokenDetails -> Html -> Html +hyperlink srcs details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalNameHyperlink pkg srcs name + else externalNameHyperlink srcs name Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink pkg srcs name content - | namePkg == pkg = Html.anchor content ! +externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html +externalNameHyperlink srcs name content = case Map.lookup mdl srcs of + Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] - | Just path <- Map.lookup namePkg srcs = Html.anchor content ! + Just (SrcExternal path) -> Html.anchor content ! [ Html.href $ path hypSrcModuleNameUrl mdl name ] - | otherwise = content + Nothing -> content where mdl = GHC.nameModule name - namePkg = GHC.modulePackageKey mdl -- TODO: Implement module hyperlinks. -- diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 4b39d315..d5762ce8 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageKey, + InterfaceFile(..), ifModule, ifPackageKey, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -51,11 +51,14 @@ data InterfaceFile = InterfaceFile { } -ifPackageKey :: InterfaceFile -> PackageKey -ifPackageKey if_ = +ifModule :: InterfaceFile -> Module +ifModule if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> modulePackageKey $ instMod iface + iface:_ -> instMod iface + +ifPackageKey :: InterfaceFile -> PackageKey +ifPackageKey = modulePackageKey . ifModule binaryInterfaceMagic :: Word32 diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index fbb5f44c..da4b3eec 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -50,7 +50,7 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map PackageKey FilePath +type SrcMap = Map Module SrcPath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -271,6 +271,13 @@ unrenameDocForDecl (doc, fnArgsDoc) = -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | SrcLocal -- | Extends 'Name' with cross-reference information. data DocName -- cgit v1.2.3 From fcaa46b054fc3b5a5535a748d3c3283629e3eadf Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:39:57 +0200 Subject: Extract main hyperlinker types to separate module. --- haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock/Backends/Hyperlinker.hs | 1 + .../src/Haddock/Backends/Hyperlinker/Ast.hs | 27 ++-------- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 40 ++------------- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Types.hs | 59 ++++++++++++++++++++++ .../src/Haddock/Backends/Hyperlinker/Utils.hs | 1 + haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/Types.hs | 3 +- haddock.cabal | 5 ++ 10 files changed, 79 insertions(+), 63 deletions(-) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 11567f99..3838c3d8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -85,6 +85,7 @@ library Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index f007f970..4b58190c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -3,6 +3,7 @@ module Haddock.Backends.Hyperlinker , module Haddock.Backends.Hyperlinker.Utils ) where + import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 9d5c127d..28fdc3f5 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -3,12 +3,10 @@ {-# LANGUAGE RecordWildCards #-} -module Haddock.Backends.Hyperlinker.Ast - ( enrich - , RichToken(..), TokenDetails(..), rtkName - ) where +module Haddock.Backends.Hyperlinker.Ast (enrich) where -import Haddock.Backends.Hyperlinker.Parser + +import Haddock.Backends.Hyperlinker.Types import qualified GHC @@ -16,25 +14,6 @@ import Control.Applicative import Data.Data import Data.Maybe -data RichToken = RichToken - { rtkToken :: Token - , rtkDetails :: Maybe TokenDetails - } - -data TokenDetails - = RtkVar GHC.Name - | RtkType GHC.Name - | RtkBind GHC.Name - | RtkDecl GHC.Name - | RtkModule GHC.ModuleName - deriving (Eq) - -rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName -rtkName (RtkVar name) = Left name -rtkName (RtkType name) = Left name -rtkName (RtkBind name) = Left name -rtkName (RtkDecl name) = Left name -rtkName (RtkModule name) = Right name -- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index d927aa08..e206413e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,44 +1,12 @@ -module Haddock.Backends.Hyperlinker.Parser - ( parse - , Token(..), TokenType(..) - , Position(..), Span(..) - ) where +module Haddock.Backends.Hyperlinker.Parser (parse) where + import Data.Char import Data.List import Data.Maybe -data Token = Token - { tkType :: TokenType - , tkValue :: String - , tkSpan :: Span - } - -data Position = Position - { posRow :: !Int - , posCol :: !Int - } - -data Span = Span - { spStart :: Position - , spEnd :: Position - } - -data TokenType - = TkIdentifier - | TkKeyword - | TkString - | TkChar - | TkNumber - | TkOperator - | TkGlyph - | TkSpecial - | TkSpace - | TkComment - | TkCpp - | TkPragma - | TkUnknown - deriving (Show, Eq) +import Haddock.Backends.Hyperlinker.Types + -- | Turn source code string into a stream of more descriptive tokens. -- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index a4d7bc2d..add1465b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,8 +1,8 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where + import Haddock.Types -import Haddock.Backends.Hyperlinker.Parser -import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import qualified GHC diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs new file mode 100644 index 00000000..19cc5288 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -0,0 +1,59 @@ +module Haddock.Backends.Hyperlinker.Types where + + +import qualified GHC + + +data Token = Token + { tkType :: TokenType + , tkValue :: String + , tkSpan :: Span + } + +data Position = Position + { posRow :: !Int + , posCol :: !Int + } + +data Span = Span + { spStart :: Position + , spEnd :: Position + } + +data TokenType + = TkIdentifier + | TkKeyword + | TkString + | TkChar + | TkNumber + | TkOperator + | TkGlyph + | TkSpecial + | TkSpace + | TkComment + | TkCpp + | TkPragma + | TkUnknown + deriving (Show, Eq) + + +data RichToken = RichToken + { rtkToken :: Token + , rtkDetails :: Maybe TokenDetails + } + +data TokenDetails + = RtkVar GHC.Name + | RtkType GHC.Name + | RtkBind GHC.Name + | RtkDecl GHC.Name + | RtkModule GHC.ModuleName + deriving (Eq) + + +rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName +rtkName (RtkVar name) = Left name +rtkName (RtkType name) = Left name +rtkName (RtkBind name) = Left name +rtkName (RtkDecl name) = Left name +rtkName (RtkModule name) = Right name diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 9ba8446d..db2bfc76 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Utils , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, ) where + import Haddock.Backends.Xhtml.Utils import GHC diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 59f7076f..0599151e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -21,6 +21,7 @@ import Haddock.GhcUtils import Haddock.Utils import Haddock.Convert import Haddock.Interface.LexParseRn +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index da4b3eec..90dbb4d4 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,7 +35,8 @@ import DynFlags (ExtensionFlag, Language) import OccName import Outputable import Control.Monad (ap) -import Haddock.Backends.Hyperlinker.Ast + +import Haddock.Backends.Hyperlinker.Types ----------------------------------------------------------------------------- -- * Convenient synonyms diff --git a/haddock.cabal b/haddock.cabal index 2a1caee7..8fa9f33d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -104,6 +104,11 @@ executable haddock Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Ast + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Types + Haddock.Backends.Hyperlinker.Utils Haddock.ModuleTree Haddock.Types Haddock.Doc -- cgit v1.2.3 From 13254609062a16e010d1c5a24e571dfe98ab6f69 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 16:52:13 +0200 Subject: Move source paths types to hyperlinker types module. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 ++ haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 - haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 13 +++++++++++++ haddock-api/src/Haddock/Types.hs | 9 --------- 4 files changed, 15 insertions(+), 10 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 4b58190c..248a8a54 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,11 +1,13 @@ module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource + , module Haddock.Backends.Hyperlinker.Types , module Haddock.Backends.Hyperlinker.Utils ) where import Haddock.Types import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index add1465b..1065897d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,7 +1,6 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where -import Haddock.Types import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index 19cc5288..ecb51a07 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -3,6 +3,8 @@ module Haddock.Backends.Hyperlinker.Types where import qualified GHC +import Data.Map (Map) + data Token = Token { tkType :: TokenType @@ -57,3 +59,14 @@ rtkName (RtkType name) = Left name rtkName (RtkBind name) = Left name rtkName (RtkDecl name) = Left name rtkName (RtkModule name) = Right name + + +-- | Path for making cross-package hyperlinks in generated sources. +-- +-- Used in 'SrcMap' to determine whether module originates in current package +-- or in an external package. +data SrcPath + = SrcExternal FilePath + | SrcLocal + +type SrcMap = Map GHC.Module SrcPath diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 90dbb4d4..6dd64506 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -51,7 +51,6 @@ type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity -type SrcMap = Map Module SrcPath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -272,14 +271,6 @@ unrenameDocForDecl (doc, fnArgsDoc) = -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module --- | Path for making cross-package hyperlinks in generated sources. --- --- Used in 'SrcMap' to determine whether module originates in current package --- or in an external package. -data SrcPath - = SrcExternal FilePath - | SrcLocal - -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module -- cgit v1.2.3 From bbd036ad309c95ce70affa5aa0a77a61aa5569c8 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Mon, 6 Jul 2015 17:06:19 +0200 Subject: Add support for hyperlinking modules in import lists. --- haddock-api/src/Haddock.hs | 2 +- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 21 +++++++++------------ .../src/Haddock/Backends/Hyperlinker/Types.hs | 10 +++++++--- 3 files changed, 17 insertions(+), 16 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d4d8e3e6..350a73ea 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -268,7 +268,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap = Map.union + srcMap = mkSrcMap $ Map.union (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 1065897d..5037421a 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -144,14 +144,14 @@ hyperlink srcs details = case rtkName details of if GHC.isInternalName name then internalHyperlink name else externalNameHyperlink srcs name - Right name -> externalModHyperlink name + Right name -> externalModHyperlink srcs name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink srcs name content = case Map.lookup mdl srcs of +externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] Just (SrcExternal path) -> Html.anchor content ! @@ -160,13 +160,10 @@ externalNameHyperlink srcs name content = case Map.lookup mdl srcs of where mdl = GHC.nameModule name --- TODO: Implement module hyperlinks. --- --- Unfortunately, 'ModuleName' is not enough to provide viable cross-package --- hyperlink. And the problem is that GHC AST does not have other information --- on imported modules, so for the time being, we do not provide such reference --- either. -externalModHyperlink :: GHC.ModuleName -> Html -> Html -externalModHyperlink _ content = - content - --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ] +externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html +externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleUrl' name ] + Just (SrcExternal path) -> Html.anchor content ! + [ Html.href $ path hypSrcModuleUrl' name ] + Nothing -> content diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs index ecb51a07..c3954dc9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs @@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Types where import qualified GHC import Data.Map (Map) +import qualified Data.Map as Map data Token = Token @@ -66,7 +67,10 @@ rtkName (RtkModule name) = Right name -- Used in 'SrcMap' to determine whether module originates in current package -- or in an external package. data SrcPath - = SrcExternal FilePath - | SrcLocal + = SrcExternal FilePath + | SrcLocal -type SrcMap = Map GHC.Module SrcPath +type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) + +mkSrcMap :: Map GHC.Module SrcPath -> SrcMap +mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) -- cgit v1.2.3 From 241346e4e275bdde2d28f90df3225057f4a09cfc Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 25 Jul 2015 19:48:08 +0200 Subject: Make hyperlinked source renderer generate line anchors. --- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 26 +++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 5037421a..15793f0c 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE RecordWildCards #-} + + module Haddock.Backends.Hyperlinker.Renderer (render) where @@ -78,10 +81,11 @@ header mcss mjs = tokenGroup :: SrcMap -> TokenGroup -> Html -tokenGroup _ (GrpNormal tok) = - tokenSpan tok ! attrs +tokenGroup _ (GrpNormal tok@(Token { .. })) + | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue + | otherwise = tokenSpan tok ! attrs where - attrs = [ multiclass . tokenStyle . tkType $ tok ] + attrs = [ multiclass . tokenStyle $ tkType ] tokenGroup srcs (GrpRich det tokens) = externalAnchor det . internalAnchor det . hyperlink srcs det $ content where @@ -167,3 +171,19 @@ externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of Just (SrcExternal path) -> Html.anchor content ! [ Html.href $ path hypSrcModuleUrl' name ] Nothing -> content + + +renderSpace :: Int -> String -> Html +renderSpace _ [] = Html.noHtml +renderSpace line ('\n':rest) = mconcat + [ Html.thespan . Html.toHtml $ "\n" + , lineAnchor (line + 1) + , renderSpace (line + 1) rest + ] +renderSpace line space = + let (hspace, rest) = span (/= '\n') space + in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest + + +lineAnchor :: Int -> Html +lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ] -- cgit v1.2.3