cabal-install/src/Distribution/Client/CmdHaddockProject.hs

   1 module Distribution.Client.CmdHaddockProject
   2   ( haddockProjectCommand
   3   , haddockProjectAction
   4   ) where
   5
   6 import Control.Monad (mapM)
   7 import Distribution.Client.Compat.Prelude hiding (get)
   8 import Prelude ()
   9
  10 import qualified Distribution.Client.CmdBuild as CmdBuild
  11 import qualified Distribution.Client.CmdHaddock as CmdHaddock
  12
  13 import Distribution.Client.DistDirLayout
  14   ( CabalDirLayout (..)
  15   , StoreDirLayout (..)
  16   , distBuildDirectory
  17   )
  18 import Distribution.Client.InstallPlan (foldPlanPackage)
  19 import qualified Distribution.Client.InstallPlan as InstallPlan
  20 import qualified Distribution.Client.NixStyleOptions as NixStyleOptions
  21 import Distribution.Client.ProjectOrchestration
  22   ( AvailableTarget (..)
  23   , AvailableTargetStatus (..)
  24   , CurrentCommand (..)
  25   , ProjectBaseContext (..)
  26   , ProjectBuildContext (..)
  27   , TargetSelector (..)
  28   , pruneInstallPlanToTargets
  29   , resolveTargets
  30   , runProjectPreBuildPhase
  31   , selectComponentTargetBasic
  32   )
  33 import Distribution.Client.ProjectPlanning
  34   ( ElaboratedConfiguredPackage (..)
  35   , ElaboratedInstallPlan
  36   , ElaboratedSharedConfig (..)
  37   , TargetAction (..)
  38   )
  39 import Distribution.Client.ProjectPlanning.Types
  40   ( elabDistDirParams
  41   )
  42 import Distribution.Client.ScriptUtils
  43   ( AcceptNoTargets (..)
  44   , TargetContext (..)
  45   , updateContextAndWriteProjectFile
  46   , withContextAndSelectors
  47   )
  48 import Distribution.Client.Setup
  49   ( CommonSetupFlags (setupVerbosity)
  50   , ConfigFlags (..)
  51   , GlobalFlags (..)
  52   )
  53 import Distribution.Client.TargetProblem (TargetProblem (..))
  54
  55 import Distribution.Simple.BuildPaths
  56   ( haddockBenchmarkDirPath
  57   , haddockDirName
  58   , haddockLibraryDirPath
  59   , haddockLibraryPath
  60   , haddockPath
  61   , haddockTestDirPath
  62   )
  63 import Distribution.Simple.Command
  64   ( CommandUI (..)
  65   )
  66 import Distribution.Simple.Flag
  67   ( Flag (..)
  68   , fromFlag
  69   , fromFlagOrDefault
  70   )
  71 import Distribution.Simple.Haddock (createHaddockIndex)
  72 import Distribution.Simple.InstallDirs
  73   ( toPathTemplate
  74   )
  75 import Distribution.Simple.Program.Builtin
  76   ( haddockProgram
  77   )
  78 import Distribution.Simple.Program.Db
  79   ( addKnownProgram
  80   , reconfigurePrograms
  81   , requireProgramVersion
  82   )
  83 import Distribution.Simple.Setup
  84   ( HaddockFlags (..)
  85   , HaddockProjectFlags (..)
  86   , HaddockTarget (..)
  87   , Visibility (..)
  88   , defaultHaddockFlags
  89   , haddockProjectCommand
  90   )
  91 import Distribution.Simple.Utils
  92   ( copyDirectoryRecursive
  93   , createDirectoryIfMissingVerbose
  94   , dieWithException
  95   , info
  96   , warn
  97   )
  98 import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..))
  99 import Distribution.Types.PackageDescription (PackageDescription (benchmarks, subLibraries, testSuites))
 100 import Distribution.Types.PackageId (pkgName)
 101 import Distribution.Types.PackageName (unPackageName)
 102 import Distribution.Types.UnitId (unUnitId)
 103 import Distribution.Types.Version (mkVersion)
 104 import Distribution.Types.VersionRange (orLaterVersion)
 105 import Distribution.Verbosity as Verbosity
 106   ( normal
 107   )
 108
 109 import Distribution.Client.Errors
 110 import System.Directory (doesDirectoryExist, doesFileExist)
 111 import System.FilePath (normalise, takeDirectory, (</>))
 112
 113 haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO ()
 114 haddockProjectAction flags _extraArgs globalFlags = do
 115   -- create destination directory if it does not exist
 116   let outputDir = normalise $ fromFlag (haddockProjectDir flags)
 117   createDirectoryIfMissingVerbose verbosity True outputDir
 118
 119   warn verbosity "haddock-project command is experimental, it might break in the future"
 120
 121   --
 122   -- Construct the build plan and infer the list of packages which haddocks
 123   -- we need.
 124   --
 125
 126   withContextAndSelectors
 127     RejectNoTargets
 128     Nothing
 129     (commandDefaultFlags CmdBuild.buildCommand)
 130     ["all"]
 131     globalFlags
 132     HaddockCommand
 133     $ \targetCtx ctx targetSelectors -> do
 134       baseCtx <- case targetCtx of
 135         ProjectContext -> return ctx
 136         GlobalContext -> return ctx
 137         ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
 138       let distLayout = distDirLayout baseCtx
 139           cabalLayout = cabalDirLayout baseCtx
 140       buildCtx <-
 141         runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
 142           -- Interpret the targets on the command line as build targets
 143           -- (as opposed to say repl or haddock targets).
 144           targets <-
 145             either reportTargetProblems return $
 146               resolveTargets
 147                 selectPackageTargets
 148                 selectComponentTargetBasic
 149                 elaboratedPlan
 150                 Nothing
 151                 targetSelectors
 152
 153           let elaboratedPlan' =
 154                 pruneInstallPlanToTargets
 155                   TargetActionBuild
 156                   targets
 157                   elaboratedPlan
 158           return (elaboratedPlan', targets)
 159
 160       let elaboratedPlan :: ElaboratedInstallPlan
 161           elaboratedPlan = elaboratedPlanOriginal buildCtx
 162
 163           sharedConfig :: ElaboratedSharedConfig
 164           sharedConfig = elaboratedShared buildCtx
 165
 166           pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
 167           pkgs = matchingPackages elaboratedPlan
 168
 169       progs <-
 170         reconfigurePrograms
 171           verbosity
 172           (haddockProjectProgramPaths flags)
 173           (haddockProjectProgramArgs flags)
 174           -- we need to insert 'haddockProgram' before we reconfigure it,
 175           -- otherwise 'set
 176           . addKnownProgram haddockProgram
 177           . pkgConfigCompilerProgs
 178           $ sharedConfig
 179       let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
 180
 181       _ <-
 182         requireProgramVersion
 183           verbosity
 184           haddockProgram
 185           (orLaterVersion (mkVersion [2, 26, 1]))
 186           progs
 187
 188       --
 189       -- Build project; we need to build dependencies.
 190       -- Issue #8958.
 191       --
 192
 193       when localStyle $
 194         CmdBuild.buildAction
 195           (commandDefaultFlags CmdBuild.buildCommand)
 196           ["all"]
 197           globalFlags
 198
 199       --
 200       -- Build haddocks of each components
 201       --
 202
 203       CmdHaddock.haddockAction
 204         nixFlags
 205         ["all"]
 206         globalFlags
 207
 208       --
 209       -- Copy haddocks to the destination folder
 210       --
 211
 212       packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->
 213         case pkg of
 214           Left package | localStyle -> do
 215             let packageName = unPackageName (pkgName $ sourcePackageId package)
 216                 destDir = outputDir </> packageName
 217             fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do
 218               let docDir = takeDirectory interfacePath
 219               a <- doesFileExist interfacePath
 220               case a of
 221                 True -> do
 222                   copyDirectoryRecursive verbosity docDir destDir
 223                   return $ Just $ Right (packageName, interfacePath, Hidden)
 224                 False -> return Nothing
 225           Left _ -> return []
 226           Right package ->
 227             case elabLocalToProject package of
 228               True -> do
 229                 let distDirParams = elabDistDirParams sharedConfig' package
 230                     pkg_descr = elabPkgDescription package
 231
 232                     packageName = pkgName $ elabPkgSourceId package
 233                     unitId = elabUnitId package
 234                     packageDir = haddockDirName ForDevelopment pkg_descr
 235                     destDir = outputDir </> packageDir
 236                     interfacePath = destDir </> haddockPath pkg_descr
 237
 238                     buildDir = distBuildDirectory distLayout distDirParams
 239                     docDir =
 240                       buildDir
 241                         </> "doc"
 242                         </> "html"
 243                         </> packageDir
 244
 245                 a <- doesDirectoryExist docDir
 246                 if a
 247                   then do
 248                     copyDirectoryRecursive verbosity docDir destDir
 249                     let infos :: [(String, FilePath, Visibility)]
 250                         infos =
 251                           (unPackageName packageName, interfacePath, Visible)
 252                             : [ (sublibDirPath, sublibInterfacePath, Visible)
 253                               | lib <- subLibraries pkg_descr
 254                               , let sublibDirPath = haddockLibraryDirPath ForDevelopment pkg_descr lib
 255                                     sublibInterfacePath =
 256                                       outputDir
 257                                         </> sublibDirPath
 258                                         </> haddockLibraryPath pkg_descr lib
 259                               ]
 260                             ++ [ (testPath, testInterfacePath, Visible)
 261                                | test <- testSuites pkg_descr
 262                                , let testPath = haddockTestDirPath ForDevelopment pkg_descr test
 263                                      testInterfacePath =
 264                                       outputDir
 265                                         </> testPath
 266                                         </> haddockPath pkg_descr
 267                                ]
 268                             ++ [ (benchPath, benchInterfacePath, Visible)
 269                                | bench <- benchmarks pkg_descr
 270                                , let benchPath = haddockBenchmarkDirPath ForDevelopment pkg_descr bench
 271                                      benchInterfacePath =
 272                                       outputDir
 273                                         </> benchPath
 274                                         </> haddockPath pkg_descr
 275                                ]
 276                     infos' <-
 277                       mapM
 278                         ( \x@(_, path, _) -> do
 279                             e <- doesFileExist path
 280                             return $
 281                               if e
 282                                 then Right x
 283                                 else Left path
 284                         )
 285                         infos
 286                     return infos'
 287                   else do
 288                     warn
 289                       verbosity
 290                       ( "haddocks of "
 291                           ++ unUnitId unitId
 292                           ++ " not found in the store"
 293                       )
 294                     return []
 295               False
 296                 | not localStyle ->
 297                     return []
 298               False -> do
 299                 let pkg_descr = elabPkgDescription package
 300                     unitId = unUnitId (elabUnitId package)
 301                     packageDir =
 302                       storePackageDirectory
 303                         (cabalStoreDirLayout cabalLayout)
 304                         (pkgConfigCompiler sharedConfig')
 305                         (elabUnitId package)
 306                     -- TODO: use `InstallDirTemplates`
 307                     docDir = packageDir </> "share" </> "doc" </> "html"
 308                     destDir = outputDir </> haddockDirName ForDevelopment pkg_descr
 309                     interfacePath = destDir </> haddockPath pkg_descr
 310                 a <- doesDirectoryExist docDir
 311                 case a of
 312                   True -> do
 313                     copyDirectoryRecursive verbosity docDir destDir
 314                     -- non local packages will be hidden in haddock's
 315                     -- generated contents page
 316                     return [Right (unitId, interfacePath, Hidden)]
 317                   False -> do
 318                     return [Left unitId]
 319
 320       --
 321       -- generate index, content, etc.
 322       --
 323
 324       let (missingHaddocks, packageInfos') = partitionEithers packageInfos
 325       when (not (null missingHaddocks)) $ do
 326         warn verbosity "missing haddocks for some packages from the store"
 327         -- Show the package list if `-v1` is passed; it's usually a long list.
 328         -- One needs to add `package` stantza in `cabal.project` file for
 329         -- `cabal` to include a version which has haddocks (or set
 330         -- `documentation: True` in the global config).
 331         info verbosity (intercalate "\n" missingHaddocks)
 332
 333       let flags' =
 334             flags
 335               { haddockProjectDir = Flag outputDir
 336               , haddockProjectInterfaces =
 337                   Flag
 338                     [ ( interfacePath
 339                       , Just url
 340                       , Just url
 341                       , visibility
 342                       )
 343                     | (url, interfacePath, visibility) <- packageInfos'
 344                     ]
 345               , haddockProjectUseUnicode = NoFlag
 346               }
 347       createHaddockIndex
 348         verbosity
 349         (pkgConfigCompilerProgs sharedConfig')
 350         (pkgConfigCompiler sharedConfig')
 351         (pkgConfigPlatform sharedConfig')
 352         Nothing
 353         flags'
 354   where
 355     -- build all packages with appropriate haddock flags
 356     commonFlags = haddockProjectCommonFlags flags
 357
 358     verbosity = fromFlagOrDefault normal (setupVerbosity commonFlags)
 359
 360     haddockFlags =
 361       defaultHaddockFlags
 362         { haddockCommonFlags = commonFlags
 363         , haddockHtml = Flag True
 364         , -- one can either use `--haddock-base-url` or
 365           -- `--haddock-html-location`.
 366           haddockBaseUrl =
 367             if localStyle
 368               then Flag ".."
 369               else NoFlag
 370         , haddockProgramPaths = haddockProjectProgramPaths flags
 371         , haddockProgramArgs = haddockProjectProgramArgs flags
 372         , haddockHtmlLocation =
 373             if fromFlagOrDefault False (haddockProjectHackage flags)
 374               then Flag "https://hackage.haskell.org/package/$pkg-$version/docs"
 375               else haddockProjectHtmlLocation flags
 376         , haddockHoogle = haddockProjectHoogle flags
 377         , haddockExecutables = haddockProjectExecutables flags
 378         , haddockTestSuites = haddockProjectTestSuites flags
 379         , haddockBenchmarks = haddockProjectBenchmarks flags
 380         , haddockForeignLibs = haddockProjectForeignLibs flags
 381         , haddockInternal = haddockProjectInternal flags
 382         , haddockCss = haddockProjectCss flags
 383         , haddockLinkedSource = Flag True
 384         , haddockQuickJump = Flag True
 385         , haddockHscolourCss = haddockProjectHscolourCss flags
 386         , haddockContents =
 387             if localStyle
 388               then Flag (toPathTemplate "../index.html")
 389               else NoFlag
 390         , haddockIndex =
 391             if localStyle
 392               then Flag (toPathTemplate "../doc-index.html")
 393               else NoFlag
 394         , haddockResourcesDir = haddockProjectResourcesDir flags
 395         , haddockUseUnicode = haddockProjectUseUnicode flags
 396         -- NOTE: we don't pass `haddockOutputDir`. If we do, we'll need to
 397         -- make sure `InstalledPackageInfo` contains the right path to
 398         -- haddock interfaces.  Instead we build documentation inside
 399         -- `dist-newstyle` directory and copy it to the output directory.
 400         }
 401
 402     nixFlags =
 403       (commandDefaultFlags CmdHaddock.haddockCommand)
 404         { NixStyleOptions.haddockFlags = haddockFlags
 405         , NixStyleOptions.configFlags =
 406             (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand))
 407               { configCommonFlags = commonFlags
 408               }
 409         }
 410
 411     -- Build a self contained directory which contains haddocks of all
 412     -- transitive dependencies; or depend on `--haddocks-html-location` to
 413     -- provide location of the documentation of dependencies.
 414     localStyle =
 415       let hackage = fromFlagOrDefault False (haddockProjectHackage flags)
 416           location = fromFlagOrDefault False (const True <$> haddockProjectHtmlLocation flags)
 417        in not hackage && not location
 418
 419     reportTargetProblems :: Show x => [x] -> IO a
 420     reportTargetProblems =
 421       dieWithException verbosity . CmdHaddockReportTargetProblems . map show
 422
 423     -- TODO: this is just a sketch
 424     selectPackageTargets
 425       :: TargetSelector
 426       -> [AvailableTarget k]
 427       -> Either (TargetProblem ()) [k]
 428     selectPackageTargets _ ts =
 429       Right $
 430         mapMaybe
 431           ( \t -> case availableTargetStatus t of
 432               TargetBuildable k _
 433                 | availableTargetLocalToProject t ->
 434                     Just k
 435               _ -> Nothing
 436           )
 437           ts
 438
 439     matchingPackages
 440       :: ElaboratedInstallPlan
 441       -> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
 442     matchingPackages =
 443       fmap (foldPlanPackage Left Right)
 444         . InstallPlan.toList