Skip to content

Commit 297dca5

Browse files
borsboomborsboom
committed
Haddock: use relative links and copy dependencies' docs (#143)
1 parent 2f3fb70 commit 297dca5

File tree

6 files changed

+179
-57
lines changed

6 files changed

+179
-57
lines changed

‎src/Stack/Build.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -26,12 +26,12 @@ import Control.Monad.Trans.Resource
2626
import Data.Function
2727
import Data.Map.Strict (Map)
2828
import qualified Data.Map as Map
29-
import Data.Maybe (fromMaybe)
3029
import Network.HTTP.Client.Conduit (HasHttpManager)
3130
import Path.IO
3231
import Prelude hiding (FilePath, writeFile)
3332
import Stack.Build.ConstructPlan
3433
import Stack.Build.Execute
34+
import Stack.Build.Haddock
3535
import Stack.Build.Installed
3636
import Stack.Build.Source
3737
import Stack.Build.Types
@@ -54,7 +54,7 @@ build bopts = do
5454
getInstalled menv
5555
GetInstalledOpts
5656
{ getInstalledProfiling = profiling
57-
, getInstalledHaddock = fromMaybe (boptsHaddock bopts) (boptsDepsHaddock bopts) }
57+
, getInstalledHaddock = shouldHaddockDeps bopts }
5858
sourceMap
5959

6060
baseConfigOpts <- mkBaseConfigOpts bopts
@@ -66,7 +66,7 @@ build bopts = do
6666

6767
if boptsDryrun bopts
6868
then printPlan (boptsFinalAction bopts) plan
69-
else executePlan menv bopts baseConfigOpts locals plan
69+
else executePlan menv bopts baseConfigOpts locals sourceMap plan
7070
where
7171
profiling = boptsLibProfile bopts || boptsExeProfile bopts
7272

‎src/Stack/Build/ConstructPlan.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ import Distribution.Version (anyVersion,
3333
import Network.HTTP.Client.Conduit (HasHttpManager)
3434
import Prelude hiding (FilePath, pi, writeFile)
3535
import Stack.Build.Cache
36+
import Stack.Build.Haddock
3637
import Stack.Build.Installed
3738
import Stack.Build.Source
3839
import Stack.Build.Types
@@ -368,7 +369,7 @@ checkDirtiness ps installed package present wanted = do
368369
PSLocal lp -> Set.map encodeUtf8 $ lpComponents lp
369370
PSUpstream _ _ _ -> Set.empty
370371
, configCacheHaddock =
371-
shouldBuildHaddock buildOpts wanted (packageName package) ||
372+
shouldHaddockPackage buildOpts wanted (packageName package) ||
372373
-- Disabling haddocks when old config had haddocks doesn't make dirty.
373374
maybe False configCacheHaddock moldOpts
374375
}

‎src/Stack/Build/Execute.hs‎

Lines changed: 28 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,6 @@ import qualified Data.Conduit.List as CL
3333
import Data.Function
3434
import Data.List
3535
import Data.Map.Strict (Map)
36-
import qualified Data.Map.Strict as M
3736
import qualified Data.Map.Strict as Map
3837
import Data.Maybe
3938
import Data.Set (Set)
@@ -51,7 +50,9 @@ import Path
5150
import Path.IO
5251
import Prelude hiding (FilePath, writeFile)
5352
import Stack.Build.Cache
53+
import Stack.Build.Haddock
5454
import Stack.Build.Installed
55+
import Stack.Build.Source
5556
import Stack.Build.Types
5657
import Stack.Fetch as Fetch
5758
import Stack.GhcPkg
@@ -176,6 +177,8 @@ data ExecuteEnv = ExecuteEnv
176177
, eeTotalWanted :: !Int
177178
, eeWanted :: !(Set PackageName)
178179
, eeLocals :: ![LocalPackage]
180+
, eeSourceMap :: !SourceMap
181+
, eeGlobalDB :: !(Path Abs Dir)
179182
}
180183

181184
-- | Perform the actual plan
@@ -184,17 +187,19 @@ executePlan :: M env m
184187
-> BuildOpts
185188
-> BaseConfigOpts
186189
-> [LocalPackage]
190+
-> SourceMap
187191
-> Plan
188192
-> m ()
189-
executePlan menv bopts baseConfigOpts locals plan = do
193+
executePlan menv bopts baseConfigOpts locals sourceMap plan = do
190194
withSystemTempDirectory stackProgName $ \tmpdir -> do
191195
tmpdir' <- parseAbsDir tmpdir
192196
configLock <- newMVar ()
193197
installLock <- newMVar ()
194-
idMap <- liftIO $ newTVarIO M.empty
198+
idMap <- liftIO $ newTVarIO Map.empty
195199
let setupHs = tmpdir' </> $(mkRelFile "Setup.hs")
196200
liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
197201
cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
202+
globalDB <- getGlobalDB menv
198203
executePlan' plan ExecuteEnv
199204
{ eeEnvOverride = menv
200205
, eeBuildOpts = bopts
@@ -212,6 +217,8 @@ executePlan menv bopts baseConfigOpts locals plan = do
212217
, eeTotalWanted = length $ filter lpWanted locals
213218
, eeWanted = wantedLocalPackages locals
214219
, eeLocals = locals
220+
, eeSourceMap = sourceMap
221+
, eeGlobalDB = globalDB
215222
}
216223

217224
unless (Map.null $ planInstallExes plan) $ do
@@ -335,7 +342,7 @@ executePlan' plan ee@ExecuteEnv {..} = do
335342
else return ()
336343
unless (null errs) $ throwM $ ExecutionFailure errs
337344
when (boptsHaddock eeBuildOpts && not (null actions))
338-
(generateHaddockIndex ee)
345+
(generateHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals)
339346

340347
toActions :: M env m
341348
=> (m () -> IO ())
@@ -425,7 +432,7 @@ ensureConfig pkgDir ExecuteEnv {..} Task {..} announce cabal cabalfp extra = do
425432
TTLocal lp -> Set.map encodeUtf8 $ lpComponents lp
426433
TTUpstream _ _ -> Set.empty
427434
, configCacheHaddock =
428-
shouldBuildHaddock eeBuildOpts eeWanted (packageIdentifierName taskProvides)
435+
shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)
429436
}
430437

431438
let needConfig = mOldConfigCache /= Just newConfigCache
@@ -479,7 +486,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} inner0 =
479486
TTUpstream package _ -> do
480487
mdist <- liftM Just distRelativeDir
481488
m <- unpackPackageIdents eeEnvOverride eeTempDir mdist $ Set.singleton taskProvides
482-
case M.toList m of
489+
case Map.toList m of
483490
[(ident, dir)]
484491
| ident == taskProvides -> do
485492
let name = packageIdentifierName taskProvides
@@ -606,13 +613,14 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =
606613
TTLocal lp -> "build" : map T.unpack (Set.toList $ lpComponents lp)
607614
TTUpstream _ _ -> ["build"]
608615

609-
when (shouldBuildHaddock eeBuildOpts eeWanted (packageName package) &&
610-
-- Works around haddock failing on bytestring-builder since it has no modules when
611-
-- bytestring is new enough.
612-
packageHasExposedModules package) $ do
616+
let doHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageName package) &&
617+
-- Works around haddock failing on bytestring-builder since it has no modules
618+
-- when bytestring is new enough.
619+
packageHasExposedModules package
620+
when doHaddock $ do
613621
announce "haddock"
614622
hscolourExists <- doesExecutableExist eeEnvOverride "hscolour"
615-
cabal False (concat [["haddock", "--html", "--hoogle"]
623+
cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"]
616624
,["--hyperlink-source" | hscolourExists]])
617625

618626
withMVar eeInstallLock $ \() -> do
@@ -638,6 +646,13 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =
638646
writeFlagCache mpkgid' cache
639647
liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides mpkgid'
640648

649+
when (doHaddock && shouldHaddockDeps eeBuildOpts) $
650+
copyDepHaddocks
651+
eeEnvOverride
652+
(pkgDbs ++ [eeGlobalDB])
653+
(PackageIdentifier (packageName package) (packageVersion package))
654+
Set.empty
655+
641656
singleTest :: M env m
642657
=> ActionContext
643658
-> ExecuteEnv
@@ -703,8 +718,8 @@ singleTest ac ee task =
703718
liftIO $ hClose inH
704719
ec <- liftIO $ waitForProcess ph
705720
return $ case ec of
706-
ExitSuccess -> M.empty
707-
_ -> M.singleton testName $ Just ec
721+
ExitSuccess -> Map.empty
722+
_ -> Map.singleton testName $ Just ec
708723
else do
709724
$logError $ T.concat
710725
[ "Test suite "
@@ -742,36 +757,6 @@ singleBench ac ee task =
742757
announce "benchmarks"
743758
cabal False ["bench"]
744759

745-
-- | Generate Haddock index and contents for local packages.
746-
generateHaddockIndex :: M env m
747-
=> ExecuteEnv
748-
-> m ()
749-
generateHaddockIndex ExecuteEnv {..} = do
750-
$logInfo ("Generating Haddock index/contents in\n" <>
751-
T.pack (toFilePath (docDir </> $(mkRelFile "index.html"))))
752-
interfaceArgs <- mapM (\LocalPackage {lpPackage = Package {..}} ->
753-
toInterfaceOpt (PackageIdentifier packageName packageVersion))
754-
eeLocals
755-
readProcessNull
756-
(Just docDir)
757-
eeEnvOverride
758-
"haddock"
759-
(["--gen-contents", "--gen-index"] ++ concat interfaceArgs)
760-
where
761-
docDir = bcoLocalInstallRoot eeBaseConfigOpts </> docdirSuffix
762-
toInterfaceOpt pid@(PackageIdentifier name _) = do
763-
interfaceRelFile <- parseRelFile (packageIdentifierString pid FP.</>
764-
packageNameString name FP.<.>
765-
"haddock")
766-
interfaceExists <- fileExists (docDir </> interfaceRelFile)
767-
return $ if interfaceExists
768-
then [ "-i"
769-
, concat
770-
[ packageIdentifierString pid
771-
, ","
772-
, toFilePath interfaceRelFile ] ]
773-
else []
774-
775760
-- | Grab all output from the given @Handle@ and print it to stdout, stripping
776761
-- Template Haskell "Loading package" lines. Does work in a separate thread.
777762
printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)

‎src/Stack/Build/Haddock.hs‎

Lines changed: 143 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,143 @@
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE MultiParamTypeClasses #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE RecordWildCards #-}
6+
{-# LANGUAGE TemplateHaskell #-}
7+
8+
-- | Generate haddocks
9+
module Stack.Build.Haddock
10+
( copyDepHaddocks
11+
, generateHaddockIndex
12+
, shouldHaddockPackage
13+
, shouldHaddockDeps
14+
) where
15+
16+
import Control.Monad
17+
import Control.Monad.Catch (MonadCatch)
18+
import Control.Monad.IO.Class
19+
import Control.Monad.Logger
20+
import Control.Monad.Trans.Resource
21+
import Control.Monad.Writer
22+
import Data.Function
23+
import Data.List
24+
import Data.Maybe
25+
import Data.Set (Set)
26+
import qualified Data.Set as Set
27+
import qualified Data.Text as T
28+
import Path
29+
import Path.IO
30+
import Prelude hiding (FilePath, writeFile)
31+
import Stack.Build.Types
32+
import Stack.GhcPkg
33+
import Stack.Package
34+
import Stack.Types
35+
import System.Directory hiding (findExecutable,
36+
findFiles)
37+
import qualified System.FilePath as FP
38+
import System.Process.Read
39+
40+
-- | Determine whether we should haddock for a package.
41+
shouldHaddockPackage :: BuildOpts -> Set PackageName -> PackageName -> Bool
42+
shouldHaddockPackage bopts wanted name =
43+
if Set.member name wanted
44+
then boptsHaddock bopts
45+
else shouldHaddockDeps bopts
46+
47+
-- | Determine whether to build haddocks for dependencies.
48+
shouldHaddockDeps :: BuildOpts -> Bool
49+
shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts)
50+
51+
-- | Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@
52+
-- links work and it's easy to upload docs to a web server or otherwise view them in a
53+
-- non-local-filesystem context. We copy instead of symlink for two reasons: (1) symlinks aren't
54+
-- reliably supported on Windows, and (2) the filesystem containing dependencies' docs may not be
55+
-- available where viewing the docs (e.g. if building in a Docker container).
56+
copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m)
57+
=> EnvOverride
58+
-> [Path Abs Dir]
59+
-> PackageIdentifier
60+
-> Set (Path Abs Dir)
61+
-> m ()
62+
copyDepHaddocks envOverride pkgDbs pkgId extraDestDirs = do
63+
mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride pkgDbs pkgId
64+
case mpkgHtmlDir of
65+
Nothing -> return ()
66+
Just pkgHtmlDir -> do
67+
depGhcIds <- findGhcPkgDepends envOverride pkgDbs pkgId
68+
forM_ (map ghcPkgIdPackageIdentifier depGhcIds) $
69+
copyDepWhenNeeded pkgHtmlDir
70+
where
71+
copyDepWhenNeeded pkgHtmlDir depId = do
72+
mDepOrigDir <- findGhcPkgHaddockHtml envOverride pkgDbs depId
73+
case mDepOrigDir of
74+
Nothing -> return ()
75+
Just depOrigDir ->
76+
copyWhenNeeded (Set.insert (parent pkgHtmlDir) extraDestDirs)
77+
depId depOrigDir
78+
copyWhenNeeded destDirs depId depOrigDir = do
79+
depRelDir <- parseRelDir (packageIdentifierString depId)
80+
copied <- forM (Set.toList destDirs) $ \destDir -> do
81+
let depCopyDir = destDir </> depRelDir
82+
if depCopyDir == depOrigDir
83+
then return False
84+
else do
85+
needCopy <- getNeedCopy depOrigDir depCopyDir
86+
when needCopy $ doCopy depOrigDir depCopyDir
87+
return needCopy
88+
when (or copied) $
89+
copyDepHaddocks envOverride pkgDbs depId destDirs
90+
getNeedCopy depOrigDir depCopyDir = do
91+
let depOrigIndex = haddockIndexFile depOrigDir
92+
depCopyIndex = haddockIndexFile depCopyDir
93+
depOrigExists <- fileExists depOrigIndex
94+
depCopyExists <- fileExists depCopyIndex
95+
case (depOrigExists, depCopyExists) of
96+
(False, _) -> return False
97+
(True, False) -> return True
98+
(True, True) -> do
99+
copyMod <- liftIO $ getModificationTime (toFilePath depCopyIndex)
100+
origMod <- liftIO $ getModificationTime (toFilePath depOrigIndex)
101+
return (copyMod <= origMod)
102+
doCopy depOrigDir depCopyDir = do
103+
depCopyDirExists <- dirExists depCopyDir
104+
liftIO $ do
105+
when depCopyDirExists $
106+
removeDirectoryRecursive (toFilePath depCopyDir)
107+
createDirectoryIfMissing True (toFilePath depCopyDir)
108+
copyDirectoryRecursive depOrigDir depCopyDir
109+
110+
-- | Generate Haddock index and contents for local packages.
111+
generateHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
112+
=> EnvOverride
113+
-> BaseConfigOpts
114+
-> [LocalPackage]
115+
-> m ()
116+
generateHaddockIndex envOverride bco locals = do
117+
$logInfo ("Generating Haddock index in\n" <>
118+
T.pack (toFilePath (haddockIndexFile docDir)))
119+
interfaceArgs <- mapM (\LocalPackage {lpPackage = Package {..}} ->
120+
toInterfaceOpt (PackageIdentifier packageName packageVersion))
121+
locals
122+
readProcessNull
123+
(Just docDir)
124+
envOverride
125+
"haddock"
126+
(["--gen-contents", "--gen-index"] ++ concat interfaceArgs)
127+
where
128+
docDir = bcoLocalInstallRoot bco </> docdirSuffix
129+
toInterfaceOpt pid@(PackageIdentifier name _) = do
130+
interfaceRelFile <- parseRelFile (packageIdentifierString pid FP.</>
131+
packageNameString name FP.<.>
132+
"haddock")
133+
interfaceExists <- fileExists (docDir </> interfaceRelFile)
134+
return $ if interfaceExists
135+
then [ "-i"
136+
, concat
137+
[ packageIdentifierString pid
138+
, ","
139+
, toFilePath interfaceRelFile ] ]
140+
else []
141+
142+
haddockIndexFile :: Path Abs Dir -> Path Abs File
143+
haddockIndexFile docDir = docDir </> $(mkRelFile "index.html")

‎src/Stack/Build/Types.hs‎

Lines changed: 2 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,7 @@ module Stack.Build.Types
2828
,ConstructPlanException(..)
2929
,configureOpts
3030
,BadDependency(..)
31-
,wantedLocalPackages
32-
,shouldBuildHaddock)
31+
,wantedLocalPackages)
3332
where
3433

3534
import Control.DeepSeq
@@ -268,7 +267,7 @@ data BuildOpts =
268267
,boptsEnableOptimizations :: !(Maybe Bool)
269268
,boptsHaddock :: !Bool
270269
-- ^ Build haddocks?
271-
,boptsDepsHaddock :: !(Maybe Bool)
270+
,boptsHaddockDeps :: !(Maybe Bool)
272271
-- ^ Build haddocks for dependencies?
273272
,boptsFinalAction :: !FinalAction
274273
,boptsDryrun :: !Bool
@@ -475,13 +474,6 @@ configureOpts econfig bco deps wanted loc package = map T.pack $ concat
475474
wantedLocalPackages :: [LocalPackage] -> Set PackageName
476475
wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted
477476

478-
-- | Determine whether we should build haddocks for a package.
479-
shouldBuildHaddock :: BuildOpts -> Set PackageName -> PackageName -> Bool
480-
shouldBuildHaddock bopts wanted name =
481-
if Set.member name wanted
482-
then boptsHaddock bopts
483-
else fromMaybe (boptsHaddock bopts) (boptsDepsHaddock bopts)
484-
485477
-- | Used for storage and comparison.
486478
newtype ModTime = ModTime (Integer,Rational)
487479
deriving (Ord,Show,Generic,Eq)

0 commit comments

Comments
 (0)