From 844c09d0c1d724e0f0f0698654f2f85f5f58be19 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:24:57 +0200 Subject: Create module with hyperlinker utility functions. --- haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs new file mode 100644 index 00000000..25ed942b --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -0,0 +1,18 @@ +module Haddock.Backends.Hyperlinker.Utils + ( srcModUrl + , srcNameUrlMap + ) where + +import Haddock.Utils +import Haddock.Backends.Xhtml.Types + +import GHC + +import Data.Maybe +import Data.Map (Map) + +srcModUrl :: SourceURLs -> String +srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl + +srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath +srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap -- 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/Utils.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 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/Utils.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 7e8330944666064f12f067970de2936b58589785 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Sat, 25 Jul 2015 18:54:30 +0200 Subject: Add some utility definitions for generating line anchors. --- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 25 ++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index db2bfc76..9de4a03d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -1,13 +1,18 @@ module Haddock.Backends.Hyperlinker.Utils ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' - , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl - , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat, + , hypSrcModuleUrl, hypSrcModuleUrl' + , hypSrcNameUrl + , hypSrcLineUrl + , hypSrcModuleNameUrl, hypSrcModuleLineUrl + , hypSrcModuleUrlFormat + , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat ) where import Haddock.Backends.Xhtml.Utils import GHC +import FastString import System.FilePath.Posix (()) @@ -31,17 +36,33 @@ hypSrcNameUrl :: Name -> String hypSrcNameUrl name = spliceURL Nothing Nothing (Just name) Nothing nameFormat +hypSrcLineUrl :: Int -> String +hypSrcLineUrl line = spliceURL + Nothing Nothing Nothing (Just spn) lineFormat + where + loc = mkSrcLoc nilFS line 1 + spn = mkSrcSpan loc loc + hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name +hypSrcModuleLineUrl :: Module -> Int -> String +hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line + hypSrcModuleUrlFormat :: String hypSrcModuleUrlFormat = hypSrcDir moduleFormat hypSrcModuleNameUrlFormat :: String hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat +hypSrcModuleLineUrlFormat :: String +hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat + moduleFormat :: String moduleFormat = "%{MODULE}.html" nameFormat :: String nameFormat = "%{NAME}" + +lineFormat :: String +lineFormat = "line-%{LINE}" -- cgit v1.2.3