1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE OverloadedStrings #-} 6{-# LANGUAGE RecordWildCards #-} 7{-# LANGUAGE ScopedTypeVariables #-} 8 9-- | Generate haddocks 10module Stack.Build.Haddock 11 ( generateLocalHaddockIndex 12 , generateDepsHaddockIndex 13 , generateSnapHaddockIndex 14 , openHaddocksInBrowser 15 , shouldHaddockPackage 16 , shouldHaddockDeps 17 ) where 18 19import Stack.Prelude 20import qualified Data.Foldable as F 21import qualified Data.HashSet as HS 22import qualified Data.Map.Strict as Map 23import qualified Data.Set as Set 24import Data.Time (UTCTime) 25import Path 26import Path.Extra 27import Path.IO 28import RIO.List (intercalate) 29import RIO.PrettyPrint 30import Stack.Constants 31import Stack.PackageDump 32import Stack.Types.Build 33import Stack.Types.Config 34import Stack.Types.GhcPkgId 35import Stack.Types.Package 36import qualified System.FilePath as FP 37import RIO.Process 38import Web.Browser (openBrowser) 39 40openHaddocksInBrowser 41 :: HasTerm env 42 => BaseConfigOpts 43 -> Map PackageName (PackageIdentifier, InstallLocation) 44 -- ^ Available packages and their locations for the current project 45 -> Set PackageName 46 -- ^ Build targets as determined by 'Stack.Build.Source.loadSourceMap' 47 -> RIO env () 48openHaddocksInBrowser bco pkgLocations buildTargets = do 49 let cliTargets = (boptsCLITargets . bcoBuildOptsCLI) bco 50 getDocIndex = do 51 let localDocs = haddockIndexFile (localDepsDocDir bco) 52 localExists <- doesFileExist localDocs 53 if localExists 54 then return localDocs 55 else do 56 let snapDocs = haddockIndexFile (snapDocDir bco) 57 snapExists <- doesFileExist snapDocs 58 if snapExists 59 then return snapDocs 60 else throwString "No local or snapshot doc index found to open." 61 docFile <- 62 case (cliTargets, map (`Map.lookup` pkgLocations) (Set.toList buildTargets)) of 63 ([_], [Just (pkgId, iloc)]) -> do 64 pkgRelDir <- (parseRelDir . packageIdentifierString) pkgId 65 let docLocation = 66 case iloc of 67 Snap -> snapDocDir bco 68 Local -> localDocDir bco 69 let docFile = haddockIndexFile (docLocation </> pkgRelDir) 70 exists <- doesFileExist docFile 71 if exists 72 then return docFile 73 else do 74 logWarn $ 75 "Expected to find documentation at " <> 76 fromString (toFilePath docFile) <> 77 ", but that file is missing. Opening doc index instead." 78 getDocIndex 79 _ -> getDocIndex 80 prettyInfo $ "Opening" <+> pretty docFile <+> "in the browser." 81 _ <- liftIO $ openBrowser (toFilePath docFile) 82 return () 83 84-- | Determine whether we should haddock for a package. 85shouldHaddockPackage :: BuildOpts 86 -> Set PackageName -- ^ Packages that we want to generate haddocks for 87 -- in any case (whether or not we are going to generate 88 -- haddocks for dependencies) 89 -> PackageName 90 -> Bool 91shouldHaddockPackage bopts wanted name = 92 if Set.member name wanted 93 then boptsHaddock bopts 94 else shouldHaddockDeps bopts 95 96-- | Determine whether to build haddocks for dependencies. 97shouldHaddockDeps :: BuildOpts -> Bool 98shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts) 99 100-- | Generate Haddock index and contents for local packages. 101generateLocalHaddockIndex 102 :: (HasProcessContext env, HasLogFunc env, HasCompiler env) 103 => BaseConfigOpts 104 -> Map GhcPkgId DumpPackage -- ^ Local package dump 105 -> [LocalPackage] 106 -> RIO env () 107generateLocalHaddockIndex bco localDumpPkgs locals = do 108 let dumpPackages = 109 mapMaybe 110 (\LocalPackage{lpPackage = Package{..}} -> 111 F.find 112 (\dp -> dpPackageIdent dp == PackageIdentifier packageName packageVersion) 113 localDumpPkgs) 114 locals 115 generateHaddockIndex 116 "local packages" 117 bco 118 dumpPackages 119 "." 120 (localDocDir bco) 121 122-- | Generate Haddock index and contents for local packages and their dependencies. 123generateDepsHaddockIndex 124 :: (HasProcessContext env, HasLogFunc env, HasCompiler env) 125 => BaseConfigOpts 126 -> Map GhcPkgId DumpPackage -- ^ Global dump information 127 -> Map GhcPkgId DumpPackage -- ^ Snapshot dump information 128 -> Map GhcPkgId DumpPackage -- ^ Local dump information 129 -> [LocalPackage] 130 -> RIO env () 131generateDepsHaddockIndex bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do 132 let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals 133 depDocDir = localDepsDocDir bco 134 generateHaddockIndex 135 "local packages and dependencies" 136 bco 137 deps 138 ".." 139 depDocDir 140 where 141 getGhcPkgId :: LocalPackage -> Maybe GhcPkgId 142 getGhcPkgId LocalPackage{lpPackage = Package{..}} = 143 let pkgId = PackageIdentifier packageName packageVersion 144 mdpPkg = F.find (\dp -> dpPackageIdent dp == pkgId) localDumpPkgs 145 in fmap dpGhcPkgId mdpPkg 146 findTransitiveDepends :: [GhcPkgId] -> [GhcPkgId] 147 findTransitiveDepends = (`go` HS.empty) . HS.fromList 148 where 149 go todo checked = 150 case HS.toList todo of 151 [] -> HS.toList checked 152 (ghcPkgId:_) -> 153 let deps = 154 case lookupDumpPackage ghcPkgId allDumpPkgs of 155 Nothing -> HS.empty 156 Just pkgDP -> HS.fromList (dpDepends pkgDP) 157 deps' = deps `HS.difference` checked 158 todo' = HS.delete ghcPkgId (deps' `HS.union` todo) 159 checked' = HS.insert ghcPkgId checked 160 in go todo' checked' 161 allDumpPkgs = [localDumpPkgs, snapshotDumpPkgs, globalDumpPkgs] 162 163-- | Generate Haddock index and contents for all snapshot packages. 164generateSnapHaddockIndex 165 :: (HasProcessContext env, HasLogFunc env, HasCompiler env) 166 => BaseConfigOpts 167 -> Map GhcPkgId DumpPackage -- ^ Global package dump 168 -> Map GhcPkgId DumpPackage -- ^ Snapshot package dump 169 -> RIO env () 170generateSnapHaddockIndex bco globalDumpPkgs snapshotDumpPkgs = 171 generateHaddockIndex 172 "snapshot packages" 173 bco 174 (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) 175 "." 176 (snapDocDir bco) 177 178-- | Generate Haddock index and contents for specified packages. 179generateHaddockIndex 180 :: (HasProcessContext env, HasLogFunc env, HasCompiler env) 181 => Text 182 -> BaseConfigOpts 183 -> [DumpPackage] 184 -> FilePath 185 -> Path Abs Dir 186 -> RIO env () 187generateHaddockIndex descr bco dumpPackages docRelFP destDir = do 188 ensureDir destDir 189 interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages 190 unless (null interfaceOpts) $ do 191 let destIndexFile = haddockIndexFile destDir 192 eindexModTime <- liftIO (tryGetModificationTime destIndexFile) 193 let needUpdate = 194 case eindexModTime of 195 Left _ -> True 196 Right indexModTime -> 197 or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts] 198 if needUpdate 199 then do 200 logInfo $ 201 "Updating Haddock index for " <> 202 Stack.Prelude.display descr <> 203 " in\n" <> 204 fromString (toFilePath destIndexFile) 205 liftIO (mapM_ copyPkgDocs interfaceOpts) 206 haddockExeName <- view $ compilerPathsL.to (toFilePath . cpHaddock) 207 withWorkingDir (toFilePath destDir) $ readProcessNull 208 haddockExeName 209 (map (("--optghc=-package-db=" ++ ) . toFilePathNoTrailingSep) 210 [bcoSnapDB bco, bcoLocalDB bco] ++ 211 hoAdditionalArgs (boptsHaddockOpts (bcoBuildOpts bco)) ++ 212 ["--gen-contents", "--gen-index"] ++ 213 [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) 214 else 215 logInfo $ 216 "Haddock index for " <> 217 Stack.Prelude.display descr <> 218 " already up to date at:\n" <> 219 fromString (toFilePath destIndexFile) 220 where 221 toInterfaceOpt :: DumpPackage -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)) 222 toInterfaceOpt DumpPackage {..} = 223 case dpHaddockInterfaces of 224 [] -> return Nothing 225 srcInterfaceFP:_ -> do 226 srcInterfaceAbsFile <- parseCollapsedAbsFile srcInterfaceFP 227 let (PackageIdentifier name _) = dpPackageIdent 228 destInterfaceRelFP = 229 docRelFP FP.</> 230 packageIdentifierString dpPackageIdent FP.</> 231 (packageNameString name FP.<.> "haddock") 232 docPathRelFP = 233 fmap ((docRelFP FP.</>) . FP.takeFileName) dpHaddockHtml 234 interfaces = intercalate "," $ 235 maybeToList docPathRelFP ++ [srcInterfaceFP] 236 237 destInterfaceAbsFile <- parseCollapsedAbsFile (toFilePath destDir FP.</> destInterfaceRelFP) 238 esrcInterfaceModTime <- tryGetModificationTime srcInterfaceAbsFile 239 return $ 240 case esrcInterfaceModTime of 241 Left _ -> Nothing 242 Right srcInterfaceModTime -> 243 Just 244 ( [ "-i", interfaces ] 245 , srcInterfaceModTime 246 , srcInterfaceAbsFile 247 , destInterfaceAbsFile ) 248 copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO () 249 copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do 250 -- Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@ 251 -- links work and it's easy to upload docs to a web server or otherwise view them in a 252 -- non-local-filesystem context. We copy instead of symlink for two reasons: (1) symlinks 253 -- aren't reliably supported on Windows, and (2) the filesystem containing dependencies' 254 -- docs may not be available where viewing the docs (e.g. if building in a Docker 255 -- container). 256 edestInterfaceModTime <- tryGetModificationTime destInterfaceAbsFile 257 case edestInterfaceModTime of 258 Left _ -> doCopy 259 Right destInterfaceModTime 260 | destInterfaceModTime < srcInterfaceModTime -> doCopy 261 | otherwise -> return () 262 where 263 doCopy = do 264 ignoringAbsence (removeDirRecur destHtmlAbsDir) 265 ensureDir destHtmlAbsDir 266 onException 267 (copyDirRecur' (parent srcInterfaceAbsFile) destHtmlAbsDir) 268 (ignoringAbsence (removeDirRecur destHtmlAbsDir)) 269 destHtmlAbsDir = parent destInterfaceAbsFile 270 271-- | Find first DumpPackage matching the GhcPkgId 272lookupDumpPackage :: GhcPkgId 273 -> [Map GhcPkgId DumpPackage] 274 -> Maybe DumpPackage 275lookupDumpPackage ghcPkgId dumpPkgs = 276 listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs 277 278-- | Path of haddock index file. 279haddockIndexFile :: Path Abs Dir -> Path Abs File 280haddockIndexFile destDir = destDir </> relFileIndexHtml 281 282-- | Path of local packages documentation directory. 283localDocDir :: BaseConfigOpts -> Path Abs Dir 284localDocDir bco = bcoLocalInstallRoot bco </> docDirSuffix 285 286-- | Path of documentation directory for the dependencies of local packages 287localDepsDocDir :: BaseConfigOpts -> Path Abs Dir 288localDepsDocDir bco = localDocDir bco </> relDirAll 289 290-- | Path of snapshot packages documentation directory. 291snapDocDir :: BaseConfigOpts -> Path Abs Dir 292snapDocDir bco = bcoSnapInstallRoot bco </> docDirSuffix 293