{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Hoogle.Cabal.Command.Generate
  ( Log,
    command,
    Command,
    action,
  )
where

import Control.Exception (catch, throw)
import Control.Monad (unless)
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Data.Bifunctor (Bifunctor (second))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.List.NonEmpty.Extra as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import Data.String.Interpolate (i)
import qualified Data.Text as T
import Data.Traversable (forM)
import Distribution.Client.CmdBuild
  ( buildAction,
  )
import Distribution.Client.DistDirLayout (DistDirLayout (distBuildDirectory))
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.ProjectOrchestration
  ( ProjectBaseContext (distDirLayout),
    ProjectBuildContext (elaboratedPlanToExecute, elaboratedShared, targetsMap),
  )
import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage)
import Distribution.Client.ProjectPlanning.Types (elabDistDirParams)
import Distribution.InstalledPackageInfo (InstalledPackageInfo (haddockHTMLs, installedUnitId, pkgRoot))
import Distribution.Simple (UnitId)
import Distribution.Simple.Configure (ConfigStateFileError, tryGetPersistBuildConfig)
import Distribution.Simple.PackageIndex (allPackagesByName)
import Distribution.Types.LocalBuildInfo (LocalBuildInfo)
import qualified Distribution.Types.LocalBuildInfo as LocalBuildInfo
import qualified Distribution.Types.PackageDescription as PackageDescription
import qualified Distribution.Types.PackageId as PackageId
import Distribution.Types.PackageName (PackageName)
import qualified Distribution.Types.PackageName as PackageName
import qualified Hoogle
import Hoogle.Cabal.Command.Common (Context (..), GlobalOptions (..), hoogleDatabaseArg, readContext)
import Hoogle.Cabal.Logger
import qualified Options.Applicative as OptParse
import System.Directory
  ( createDirectoryIfMissing,
    createDirectoryLink,
    removeDirectoryLink,
    removeDirectoryRecursive,
    withCurrentDirectory,
  )
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import Prelude hiding (log)

data Log
  = LogBadInstallPlan UnitId (Maybe (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage))
  | LogCanNotReadSetupConfig String ConfigStateFileError
  | LogPkgMoreThan1Version PackageName (NonEmpty UnitId)
  | LogPkgBadHaddockHtml PackageName [FilePath]

instance Show Log where
  show :: Log -> String
show (LogBadInstallPlan UnitId
unitId Maybe
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
Nothing) = String
"can not find " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnitId -> String
forall a. Show a => a -> String
show UnitId
unitId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" from install plan"
  show (LogBadInstallPlan UnitId
unitId (Just (InstallPlan.PreExisting InstalledPackageInfo
_))) = UnitId -> String
forall a. Show a => a -> String
show UnitId
unitId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is PreExisting"
  show (LogBadInstallPlan UnitId
unitId (Just (InstallPlan.Configured ElaboratedConfiguredPackage
_))) = UnitId -> String
forall a. Show a => a -> String
show UnitId
unitId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is Configured"
  show (LogBadInstallPlan UnitId
unitId (Just (InstallPlan.Installed ElaboratedConfiguredPackage
_))) = UnitId -> String
forall a. Show a => a -> String
show UnitId
unitId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is Installed"
  show (LogCanNotReadSetupConfig String
pkg ConfigStateFileError
configStateFileErr) =
    [i|Can not read setup-config file from #{pkg}, error: #{configStateFileErr}|]
  show (LogPkgMoreThan1Version PackageName
pkgName NonEmpty UnitId
unitIds) =
    [i|Warning: package #{pkgName} has more than 1 version installed, this should not happen. all pkgs: #{unitIds}|]
  show (LogPkgBadHaddockHtml PackageName
name [String]
htmlDirs) =
    [i|Warning: package #{name} doesn't have exactly one haddock html directory, actual: #{htmlDirs}|]

newtype Command = Command
  { Command -> [String]
_targets :: [String]
  }
  deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Command -> ShowS
showsPrec :: Int -> Command -> ShowS
$cshow :: Command -> String
show :: Command -> String
$cshowList :: [Command] -> ShowS
showList :: [Command] -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
/= :: Command -> Command -> Bool
Eq)

command :: (Command -> a) -> OptParse.Mod OptParse.CommandFields a
command :: forall a. (Command -> a) -> Mod CommandFields a
command Command -> a
f =
  String -> ParserInfo a -> Mod CommandFields a
forall a. String -> ParserInfo a -> Mod CommandFields a
OptParse.command String
"generate" (ParserInfo a -> Mod CommandFields a)
-> ParserInfo a -> Mod CommandFields a
forall a b. (a -> b) -> a -> b
$
    Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
OptParse.info
      ((Command -> a) -> Parser Command -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Command -> a
f Parser Command
commandParser)
      (String -> InfoMod a
forall a. String -> InfoMod a
OptParse.progDesc String
"Generate hoogle database")

commandParser :: OptParse.Parser Command
commandParser :: Parser Command
commandParser =
  [String] -> Command
Command
    ([String] -> Command) -> Parser [String] -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
OptParse.many (Parser String -> Parser [String])
-> (Mod ArgumentFields String -> Parser String)
-> Mod ArgumentFields String
-> Parser [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
OptParse.strArgument) (String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
OptParse.metavar String
"TARGETS")

action :: Logger Log -> GlobalOptions -> Command -> IO ()
action :: Logger Log -> GlobalOptions -> Command -> IO ()
action Logger Log
logger GlobalOptions
globalOptions (Command [String]
targets) = do
  (Context ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx String
hoogleDir [String]
targetStrings NixStyleFlags BuildFlags
flags GlobalFlags
globalFlags) <- GlobalOptions -> [String] -> IO Context
readContext GlobalOptions
globalOptions [String]
targets
  NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()
buildAction NixStyleFlags BuildFlags
flags [String]
targetStrings GlobalFlags
globalFlags
  let targetIds :: [UnitId]
targetIds = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] -> [UnitId]
forall k a. Map k a -> [k]
Map.keys (ProjectBuildContext
-> Map UnitId [(ComponentTarget, NonEmpty TargetSelector)]
targetsMap ProjectBuildContext
buildCtx)
      installPlan :: ElaboratedInstallPlan
installPlan = ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanToExecute ProjectBuildContext
buildCtx
      hoogleLocalPackagesDir :: String
hoogleLocalPackagesDir = String
hoogleDir String -> ShowS
</> String
"local"
      hoogleDependenciesDir :: String
hoogleDependenciesDir = String
hoogleDir String -> ShowS
</> String
"dependencies"
  [String]
localPackages <- ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe String] -> IO [String])
-> ((UnitId -> IO (Maybe String)) -> IO [Maybe String])
-> (UnitId -> IO (Maybe String))
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> (UnitId -> IO (Maybe String)) -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnitId]
targetIds ((UnitId -> IO (Maybe String)) -> IO [String])
-> (UnitId -> IO (Maybe String)) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \UnitId
targetId ->
    let handlePkg :: ElaboratedConfiguredPackage -> f (Maybe String)
handlePkg ElaboratedConfiguredPackage
pkg = Maybe String -> f (Maybe String)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> f (Maybe String))
-> (String -> Maybe String) -> String -> f (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> f (Maybe String)) -> String -> f (Maybe String)
forall a b. (a -> b) -> a -> b
$ DistDirLayout -> DistDirParams -> String
distBuildDirectory (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) (DistDirParams -> String) -> DistDirParams -> String
forall a b. (a -> b) -> a -> b
$ ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams (ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared ProjectBuildContext
buildCtx) ElaboratedConfiguredPackage
pkg
     in case ElaboratedInstallPlan
-> UnitId
-> Maybe
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> UnitId -> Maybe (GenericPlanPackage ipkg srcpkg)
InstallPlan.lookup ElaboratedInstallPlan
installPlan UnitId
targetId of
          Just (InstallPlan.Installed ElaboratedConfiguredPackage
pkg) -> ElaboratedConfiguredPackage -> IO (Maybe String)
forall {f :: * -> *}.
Applicative f =>
ElaboratedConfiguredPackage -> f (Maybe String)
handlePkg ElaboratedConfiguredPackage
pkg
          Just (InstallPlan.Configured ElaboratedConfiguredPackage
pkg) -> ElaboratedConfiguredPackage -> IO (Maybe String)
forall {f :: * -> *}.
Applicative f =>
ElaboratedConfiguredPackage -> f (Maybe String)
handlePkg ElaboratedConfiguredPackage
pkg
          Maybe
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
pkg -> do
            Logger Log -> Severity -> Log -> IO ()
forall (m :: * -> *) msg.
MonadIO m =>
Logger msg -> Severity -> msg -> m ()
logWith Logger Log
logger Severity
Error (UnitId
-> Maybe
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
-> Log
LogBadInstallPlan UnitId
targetId Maybe
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
pkg)
            Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO ()
removeDirectoryRecursive String
hoogleDir) ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(IOError
err :: IOError) ->
    if IOError -> Bool
isDoesNotExistError IOError
err then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else IOError -> IO ()
forall a e. Exception e => e -> a
throw IOError
err
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
hoogleLocalPackagesDir
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
hoogleDependenciesDir
  [(String, LocalBuildInfo)]
localPackagesBuildInfo <- Logger Log -> [String] -> String -> IO [(String, LocalBuildInfo)]
symlinkLocalPackages Logger Log
logger [String]
localPackages String
hoogleLocalPackagesDir
  let localPkgsName :: [String]
localPkgsName = ((String, LocalBuildInfo) -> String)
-> [(String, LocalBuildInfo)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, LocalBuildInfo) -> String
forall a b. (a, b) -> a
fst [(String, LocalBuildInfo)]
localPackagesBuildInfo
  [PackageName]
dependenciesName <- Logger Log -> [LocalBuildInfo] -> String -> IO [PackageName]
symlinkDependencies Logger Log
logger (((String, LocalBuildInfo) -> LocalBuildInfo)
-> [(String, LocalBuildInfo)] -> [LocalBuildInfo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, LocalBuildInfo) -> LocalBuildInfo
forall a b. (a, b) -> b
snd [(String, LocalBuildInfo)]
localPackagesBuildInfo) String
hoogleDependenciesDir
  let nameStrs :: [String]
nameStrs = [String]
localPkgsName [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> String
PackageName.unPackageName [PackageName]
dependenciesName
  String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
hoogleDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    [String] -> IO ()
Hoogle.hoogle ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [String
"generate", String
hoogleDatabaseArg, String
"--local=local", String
"--local=dependencies"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
nameStrs

symlinkLocalPackages :: Logger Log -> [FilePath] -> FilePath -> IO [(String, LocalBuildInfo)]
symlinkLocalPackages :: Logger Log -> [String] -> String -> IO [(String, LocalBuildInfo)]
symlinkLocalPackages Logger Log
logger [String]
pkgsPath String
destDir = do
  ([Maybe (String, LocalBuildInfo)] -> [(String, LocalBuildInfo)])
-> IO [Maybe (String, LocalBuildInfo)]
-> IO [(String, LocalBuildInfo)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (String, LocalBuildInfo)] -> [(String, LocalBuildInfo)]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (String, LocalBuildInfo)]
 -> IO [(String, LocalBuildInfo)])
-> ((String -> IO (Maybe (String, LocalBuildInfo)))
    -> IO [Maybe (String, LocalBuildInfo)])
-> (String -> IO (Maybe (String, LocalBuildInfo)))
-> IO [(String, LocalBuildInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String]
-> (String -> IO (Maybe (String, LocalBuildInfo)))
-> IO [Maybe (String, LocalBuildInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
pkgsPath ((String -> IO (Maybe (String, LocalBuildInfo)))
 -> IO [(String, LocalBuildInfo)])
-> (String -> IO (Maybe (String, LocalBuildInfo)))
-> IO [(String, LocalBuildInfo)]
forall a b. (a -> b) -> a -> b
$ \String
pkgPath -> MaybeT IO (String, LocalBuildInfo)
-> IO (Maybe (String, LocalBuildInfo))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (String, LocalBuildInfo)
 -> IO (Maybe (String, LocalBuildInfo)))
-> MaybeT IO (String, LocalBuildInfo)
-> IO (Maybe (String, LocalBuildInfo))
forall a b. (a -> b) -> a -> b
$ do
    Either ConfigStateFileError LocalBuildInfo
lbiEither <- IO (Either ConfigStateFileError LocalBuildInfo)
-> MaybeT IO (Either ConfigStateFileError LocalBuildInfo)
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ConfigStateFileError LocalBuildInfo)
 -> MaybeT IO (Either ConfigStateFileError LocalBuildInfo))
-> IO (Either ConfigStateFileError LocalBuildInfo)
-> MaybeT IO (Either ConfigStateFileError LocalBuildInfo)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetPersistBuildConfig String
pkgPath
    LocalBuildInfo
lbi <- IO (Maybe LocalBuildInfo) -> MaybeT IO LocalBuildInfo
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe LocalBuildInfo) -> MaybeT IO LocalBuildInfo)
-> IO (Maybe LocalBuildInfo) -> MaybeT IO LocalBuildInfo
forall a b. (a -> b) -> a -> b
$ case Either ConfigStateFileError LocalBuildInfo
lbiEither of
      Left ConfigStateFileError
configStateFileErr -> do
        Logger Log -> Severity -> Log -> IO ()
forall (m :: * -> *) msg.
MonadIO m =>
Logger msg -> Severity -> msg -> m ()
logWith Logger Log
logger Severity
Error (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ConfigStateFileError -> Log
LogCanNotReadSetupConfig String
pkgPath ConfigStateFileError
configStateFileErr
        Maybe LocalBuildInfo -> IO (Maybe LocalBuildInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LocalBuildInfo
forall a. Maybe a
Nothing
      Right LocalBuildInfo
lbi -> Maybe LocalBuildInfo -> IO (Maybe LocalBuildInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe LocalBuildInfo -> IO (Maybe LocalBuildInfo))
-> Maybe LocalBuildInfo -> IO (Maybe LocalBuildInfo)
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Maybe LocalBuildInfo
forall a. a -> Maybe a
Just LocalBuildInfo
lbi
    let pkgName :: String
pkgName =
          PackageName -> String
PackageName.unPackageName
            (PackageName -> String)
-> (LocalBuildInfo -> PackageName) -> LocalBuildInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
PackageId.pkgName
            (PackageIdentifier -> PackageName)
-> (LocalBuildInfo -> PackageIdentifier)
-> LocalBuildInfo
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageIdentifier
PackageDescription.package
            (PackageDescription -> PackageIdentifier)
-> (LocalBuildInfo -> PackageDescription)
-> LocalBuildInfo
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalBuildInfo -> PackageDescription
LocalBuildInfo.localPkgDescr
            (LocalBuildInfo -> String) -> LocalBuildInfo -> String
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo
lbi
    IO () -> MaybeT IO ()
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (String -> IO ()
removeDirectoryLink (String
destDir String -> ShowS
</> String
pkgName)) ((IOError -> IO ()) -> IO ()) -> (IOError -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(IOError
e :: IOError) ->
      if IOError -> Bool
isDoesNotExistError IOError
e then () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else IOError -> IO ()
forall a e. Exception e => e -> a
throw IOError
e
    IO () -> MaybeT IO ()
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
createDirectoryLink String
pkgPath (String
destDir String -> ShowS
</> String
pkgName)
    (String, LocalBuildInfo) -> MaybeT IO (String, LocalBuildInfo)
forall a. a -> MaybeT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
pkgName, LocalBuildInfo
lbi)

symlinkDependencies :: Logger Log -> [LocalBuildInfo] -> FilePath -> IO [PackageName]
symlinkDependencies :: Logger Log -> [LocalBuildInfo] -> String -> IO [PackageName]
symlinkDependencies Logger Log
logger [LocalBuildInfo]
localPackages String
hoogleDependenciesDir = do
  let nameToPkgs :: Map PackageName (NonEmpty InstalledPackageInfo)
nameToPkgs =
        (NonEmpty InstalledPackageInfo -> NonEmpty InstalledPackageInfo)
-> Map PackageName (NonEmpty InstalledPackageInfo)
-> Map PackageName (NonEmpty InstalledPackageInfo)
forall a b. (a -> b) -> Map PackageName a -> Map PackageName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InstalledPackageInfo -> UnitId)
-> NonEmpty InstalledPackageInfo -> NonEmpty InstalledPackageInfo
forall b a. Ord b => (a -> b) -> NonEmpty a -> NonEmpty a
NonEmpty.nubOrdOn InstalledPackageInfo -> UnitId
installedUnitId) (Map PackageName (NonEmpty InstalledPackageInfo)
 -> Map PackageName (NonEmpty InstalledPackageInfo))
-> ([(PackageName, NonEmpty InstalledPackageInfo)]
    -> Map PackageName (NonEmpty InstalledPackageInfo))
-> [(PackageName, NonEmpty InstalledPackageInfo)]
-> Map PackageName (NonEmpty InstalledPackageInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty InstalledPackageInfo
 -> NonEmpty InstalledPackageInfo -> NonEmpty InstalledPackageInfo)
-> [(PackageName, NonEmpty InstalledPackageInfo)]
-> Map PackageName (NonEmpty InstalledPackageInfo)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith NonEmpty InstalledPackageInfo
-> NonEmpty InstalledPackageInfo -> NonEmpty InstalledPackageInfo
forall a. Semigroup a => a -> a -> a
(<>) ([(PackageName, NonEmpty InstalledPackageInfo)]
 -> Map PackageName (NonEmpty InstalledPackageInfo))
-> [(PackageName, NonEmpty InstalledPackageInfo)]
-> Map PackageName (NonEmpty InstalledPackageInfo)
forall a b. (a -> b) -> a -> b
$
          (LocalBuildInfo -> [(PackageName, NonEmpty InstalledPackageInfo)])
-> [LocalBuildInfo]
-> [(PackageName, NonEmpty InstalledPackageInfo)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LocalBuildInfo -> [(PackageName, NonEmpty InstalledPackageInfo)]
collectDependenciesForPkg [LocalBuildInfo]
localPackages
  [(PackageName, String)]
pkgs <- ([Maybe (PackageName, String)] -> [(PackageName, String)])
-> IO [Maybe (PackageName, String)] -> IO [(PackageName, String)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (PackageName, String)] -> [(PackageName, String)]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (PackageName, String)] -> IO [(PackageName, String)])
-> (((PackageName, NonEmpty InstalledPackageInfo)
     -> IO (Maybe (PackageName, String)))
    -> IO [Maybe (PackageName, String)])
-> ((PackageName, NonEmpty InstalledPackageInfo)
    -> IO (Maybe (PackageName, String)))
-> IO [(PackageName, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PackageName, NonEmpty InstalledPackageInfo)]
-> ((PackageName, NonEmpty InstalledPackageInfo)
    -> IO (Maybe (PackageName, String)))
-> IO [Maybe (PackageName, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map PackageName (NonEmpty InstalledPackageInfo)
-> [(PackageName, NonEmpty InstalledPackageInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (NonEmpty InstalledPackageInfo)
nameToPkgs) (((PackageName, NonEmpty InstalledPackageInfo)
  -> IO (Maybe (PackageName, String)))
 -> IO [(PackageName, String)])
-> ((PackageName, NonEmpty InstalledPackageInfo)
    -> IO (Maybe (PackageName, String)))
-> IO [(PackageName, String)]
forall a b. (a -> b) -> a -> b
$ \(PackageName
name, allPkgs :: NonEmpty InstalledPackageInfo
allPkgs@(InstalledPackageInfo
pkg NonEmpty.:| [InstalledPackageInfo]
pkgs)) -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstalledPackageInfo]
pkgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Logger Log -> Severity -> Log -> IO ()
forall (m :: * -> *) msg.
MonadIO m =>
Logger msg -> Severity -> msg -> m ()
logWith Logger Log
logger Severity
Warning (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$
        PackageName -> NonEmpty UnitId -> Log
LogPkgMoreThan1Version PackageName
name ((InstalledPackageInfo -> UnitId)
-> NonEmpty InstalledPackageInfo -> NonEmpty UnitId
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InstalledPackageInfo -> UnitId
installedUnitId NonEmpty InstalledPackageInfo
allPkgs)
    case InstalledPackageInfo -> [String]
haddockHTMLs' InstalledPackageInfo
pkg of
      [String
htmlDir] -> Maybe (PackageName, String) -> IO (Maybe (PackageName, String))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PackageName, String) -> IO (Maybe (PackageName, String)))
-> Maybe (PackageName, String) -> IO (Maybe (PackageName, String))
forall a b. (a -> b) -> a -> b
$ (PackageName, String) -> Maybe (PackageName, String)
forall a. a -> Maybe a
Just (PackageName
name, String
htmlDir)
      [String]
htmlDirs -> do
        Logger Log -> Severity -> Log -> IO ()
forall (m :: * -> *) msg.
MonadIO m =>
Logger msg -> Severity -> msg -> m ()
logWith Logger Log
logger Severity
Warning (Log -> IO ()) -> Log -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageName -> [String] -> Log
LogPkgBadHaddockHtml PackageName
name [String]
htmlDirs
        Maybe (PackageName, String) -> IO (Maybe (PackageName, String))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PackageName, String)
forall a. Maybe a
Nothing
  [(PackageName, String)]
-> ((PackageName, String) -> IO PackageName) -> IO [PackageName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PackageName, String)]
pkgs (((PackageName, String) -> IO PackageName) -> IO [PackageName])
-> ((PackageName, String) -> IO PackageName) -> IO [PackageName]
forall a b. (a -> b) -> a -> b
$ \(PackageName
name, String
dir) -> do
    String -> String -> IO ()
createDirectoryLink String
dir (String
hoogleDependenciesDir String -> ShowS
</> PackageName -> String
PackageName.unPackageName PackageName
name)
    PackageName -> IO PackageName
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageName
name
  where
    collectDependenciesForPkg :: LocalBuildInfo -> [(PackageName, NonEmpty InstalledPackageInfo)]
    collectDependenciesForPkg :: LocalBuildInfo -> [(PackageName, NonEmpty InstalledPackageInfo)]
collectDependenciesForPkg LocalBuildInfo
pkg =
      let depsWithName :: [(PackageName, [InstalledPackageInfo])]
depsWithName = PackageIndex InstalledPackageInfo
-> [(PackageName, [InstalledPackageInfo])]
forall a. PackageIndex a -> [(PackageName, [a])]
allPackagesByName (LocalBuildInfo -> PackageIndex InstalledPackageInfo
LocalBuildInfo.installedPkgs LocalBuildInfo
pkg)
       in ((PackageName, InstalledPackageInfo)
 -> (PackageName, NonEmpty InstalledPackageInfo))
-> [(PackageName, InstalledPackageInfo)]
-> [(PackageName, NonEmpty InstalledPackageInfo)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((InstalledPackageInfo -> NonEmpty InstalledPackageInfo)
-> (PackageName, InstalledPackageInfo)
-> (PackageName, NonEmpty InstalledPackageInfo)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (InstalledPackageInfo
-> [InstalledPackageInfo] -> NonEmpty InstalledPackageInfo
forall a. a -> [a] -> NonEmpty a
NonEmpty.:| []))
            ([(PackageName, InstalledPackageInfo)]
 -> [(PackageName, NonEmpty InstalledPackageInfo)])
-> ([(PackageName, [InstalledPackageInfo])]
    -> [(PackageName, InstalledPackageInfo)])
-> [(PackageName, [InstalledPackageInfo])]
-> [(PackageName, NonEmpty InstalledPackageInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, [InstalledPackageInfo])
 -> [(PackageName, InstalledPackageInfo)])
-> [(PackageName, [InstalledPackageInfo])]
-> [(PackageName, InstalledPackageInfo)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PackageName
name, [InstalledPackageInfo]
pkgs) -> (InstalledPackageInfo -> (PackageName, InstalledPackageInfo))
-> [InstalledPackageInfo] -> [(PackageName, InstalledPackageInfo)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageName
name,) [InstalledPackageInfo]
pkgs)
            ([(PackageName, [InstalledPackageInfo])]
 -> [(PackageName, NonEmpty InstalledPackageInfo)])
-> [(PackageName, [InstalledPackageInfo])]
-> [(PackageName, NonEmpty InstalledPackageInfo)]
forall a b. (a -> b) -> a -> b
$ [(PackageName, [InstalledPackageInfo])]
depsWithName

haddockHTMLs' :: InstalledPackageInfo -> [FilePath]
haddockHTMLs' :: InstalledPackageInfo -> [String]
haddockHTMLs' InstalledPackageInfo
pkg =
  ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( case InstalledPackageInfo -> Maybe String
pkgRoot InstalledPackageInfo
pkg of
        Maybe String
Nothing -> ShowS
forall a. a -> a
id
        Just String
pkgRoot' -> Text -> String
T.unpack (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"${pkgroot}" (String -> Text
T.pack String
pkgRoot') (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    )
    ([String] -> [String])
-> (InstalledPackageInfo -> [String])
-> InstalledPackageInfo
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> [String]
haddockHTMLs
    (InstalledPackageInfo -> [String])
-> InstalledPackageInfo -> [String]
forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo
pkg