Rewrite source generation to fixed links and directory structure.

6 files changed, 85 insertions, 77 deletions

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
 -------------------------------------------------------------------------------