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