aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Themes.hs7
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Types.hs11
2 files changed, 15 insertions, 3 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
index b1d64acd..08ef747a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
@@ -17,6 +17,7 @@ module Haddock.Backends.Xhtml.Themes (
where
import Haddock.Options
+import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL )
import Control.Monad (liftM)
import Data.Char (toLower)
@@ -176,13 +177,13 @@ cssFiles :: Themes -> [String]
cssFiles ts = nub $ concatMap themeFiles ts
-styleSheet :: Themes -> Html
-styleSheet ts = toHtml $ zipWith mkLink rels ts
+styleSheet :: BaseURL -> Themes -> Html
+styleSheet base_url ts = toHtml $ zipWith mkLink rels ts
where
rels = "stylesheet" : repeat "alternate stylesheet"
mkLink aRel t =
thelink
- ! [ href (themeHref t), rel aRel, thetype "text/css",
+ ! [ href (withBaseURL base_url (themeHref t)), rel aRel, thetype "text/css",
XHtml.title (themeName t)
]
<< noHtml
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
index e3fd2d5a..a68cb559 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
@@ -12,6 +12,8 @@
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Types (
SourceURLs, WikiURLs,
+ BaseURL,
+ withBaseURL,
LinksInfo,
Splice,
Unicode,
@@ -20,12 +22,21 @@ module Haddock.Backends.Xhtml.Types (
import Data.Map
import GHC
+import qualified System.FilePath as FilePath
-- the base, module and entity URLs for the source code and wiki links.
type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath)
type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
+-- | base url for loading js, json, css resources. The default is "."
+--
+type BaseURL = Maybe String
+
+-- TODO: we shouldn't use 'FilePath.</>'
+withBaseURL :: BaseURL -> String -> String
+withBaseURL Nothing uri = uri
+withBaseURL (Just baseUrl) uri = baseUrl FilePath.</> uri
-- The URL for source and wiki links
type LinksInfo = (SourceURLs, WikiURLs)