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

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