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

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