{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.CLI.Command.Publish (publish) where

import Control.Monad.Error.Class (MonadError (..))
import qualified Data.Text as T
import HWM.Core.Common (Name)
import HWM.Core.Formatting
  ( Color (..),
    Format (..),
    chalk,
    genMaxLen,
    padDots,
    statusIcon,
  )
import HWM.Core.Pkg (Pkg (..))
import HWM.Core.Result (Issue)
import HWM.Domain.ConfigT (ConfigT, askVersion, askWorkspaceGroups)
import HWM.Domain.Workspace (WorkspaceGroup, canPublish, memberPkgs, pkgGroupName, selectGroup)
import HWM.Integrations.Toolchain.Stack (sdist, upload)
import HWM.Runtime.UI (printSummary, putLine, section, sectionTableM, sectionWorkspace)
import Relude hiding (intercalate)

failIssues :: [Issue] -> ConfigT ()
failIssues :: [Issue] -> ConfigT ()
failIssues [] = () -> ConfigT ()
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
failIssues [Issue]
issues = do
  [Issue] -> ConfigT ()
forall (m :: * -> *). MonadUI m => [Issue] -> m ()
printSummary [Issue]
issues
  IO () -> ConfigT ()
forall a. IO a -> ConfigT a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure

collectGroups :: Maybe Name -> [WorkspaceGroup] -> ConfigT [WorkspaceGroup]
collectGroups :: Maybe Name -> [WorkspaceGroup] -> ConfigT [WorkspaceGroup]
collectGroups Maybe Name
Nothing [WorkspaceGroup]
ws = [WorkspaceGroup] -> ConfigT [WorkspaceGroup]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([WorkspaceGroup] -> ConfigT [WorkspaceGroup])
-> [WorkspaceGroup] -> ConfigT [WorkspaceGroup]
forall a b. (a -> b) -> a -> b
$ (WorkspaceGroup -> Bool) -> [WorkspaceGroup] -> [WorkspaceGroup]
forall a. (a -> Bool) -> [a] -> [a]
filter WorkspaceGroup -> Bool
canPublish [WorkspaceGroup]
ws
collectGroups (Just Name
target) [WorkspaceGroup]
ws = do
  [WorkspaceGroup]
groups <- (Name -> ConfigT WorkspaceGroup)
-> [Name] -> ConfigT [WorkspaceGroup]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Name -> [WorkspaceGroup] -> ConfigT WorkspaceGroup
forall (m :: * -> *).
MonadError Issue m =>
Name -> [WorkspaceGroup] -> m WorkspaceGroup
`selectGroup` [WorkspaceGroup]
ws) [Name
target]
  let notPublishable :: [WorkspaceGroup]
notPublishable = (WorkspaceGroup -> Bool) -> [WorkspaceGroup] -> [WorkspaceGroup]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (WorkspaceGroup -> Bool) -> WorkspaceGroup -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceGroup -> Bool
canPublish) [WorkspaceGroup]
groups
  [WorkspaceGroup] -> (WorkspaceGroup -> ConfigT Any) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WorkspaceGroup]
notPublishable ((WorkspaceGroup -> ConfigT Any) -> ConfigT ())
-> (WorkspaceGroup -> ConfigT Any) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ \WorkspaceGroup
g ->
    Issue -> ConfigT Any
forall a. Issue -> ConfigT a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> ConfigT Any) -> Issue -> ConfigT Any
forall a b. (a -> b) -> a -> b
$ String -> Issue
forall a. IsString a => String -> a
fromString (String -> Issue) -> String -> Issue
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. ToString a => a -> String
toString (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name
"Target group \"" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> WorkspaceGroup -> Name
pkgGroupName WorkspaceGroup
g Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
"\" cannot be published. Check workspace group configuration."
  [WorkspaceGroup] -> ConfigT [WorkspaceGroup]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [WorkspaceGroup]
groups

publish :: Maybe Name -> ConfigT ()
publish :: Maybe Name -> ConfigT ()
publish Maybe Name
target = do
  [WorkspaceGroup]
ws <- ConfigT [WorkspaceGroup]
askWorkspaceGroups
  [WorkspaceGroup]
groups <- Maybe Name -> [WorkspaceGroup] -> ConfigT [WorkspaceGroup]
collectGroups Maybe Name
target [WorkspaceGroup]
ws
  Version
version <- ConfigT Version
forall env (m :: * -> *).
(MonadReader env m, Has env Version) =>
m Version
askVersion
  Bool -> ConfigT () -> ConfigT ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([WorkspaceGroup] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WorkspaceGroup]
groups) (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Issue -> ConfigT ()
forall a. Issue -> ConfigT a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Issue
"No publishable groups found. Check workspace group configuration."

  Int -> Name -> [(Name, ConfigT Name)] -> ConfigT ()
forall (m :: * -> *).
MonadUI m =>
Int -> Name -> [(Name, m Name)] -> m ()
sectionTableM
    Int
0
    Name
"publish"
    [ (Name
"version", Name -> ConfigT Name
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> ConfigT Name) -> Name -> ConfigT Name
forall a b. (a -> b) -> a -> b
$ Color -> Name -> Name
chalk Color
Magenta (Version -> Name
forall a. Format a => a -> Name
format Version
version)),
      (Name
"target", Name -> ConfigT Name
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> ConfigT Name) -> Name -> ConfigT Name
forall a b. (a -> b) -> a -> b
$ Color -> Name -> Name
chalk Color
Cyan (Name -> Name
forall a. Format a => a -> Name
format (Name -> [Name] -> Name
T.intercalate Name
", " ((WorkspaceGroup -> Name) -> [WorkspaceGroup] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map WorkspaceGroup -> Name
pkgGroupName [WorkspaceGroup]
groups)))),
      (Name
"registry", Name -> ConfigT Name
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
"hackage")
    ]

  [[Issue]]
issues <- (WorkspaceGroup -> ConfigT [Pkg])
-> [WorkspaceGroup] -> ConfigT [[Pkg]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse WorkspaceGroup -> ConfigT [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m [Pkg]
memberPkgs [WorkspaceGroup]
groups ConfigT [[Pkg]]
-> ([[Pkg]] -> ConfigT [[Issue]]) -> ConfigT [[Issue]]
forall a b. ConfigT a -> (a -> ConfigT b) -> ConfigT b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Pkg -> ConfigT [Issue]) -> [Pkg] -> ConfigT [[Issue]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Pkg -> ConfigT [Issue]
sdist ([Pkg] -> ConfigT [[Issue]])
-> ([[Pkg]] -> [Pkg]) -> [[Pkg]] -> ConfigT [[Issue]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Pkg]] -> [Pkg]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [Issue] -> ConfigT ()
failIssues ([[Issue]] -> [Issue]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Issue]]
issues)

  ConfigT () -> ConfigT ()
forall (m :: * -> *) a. MonadUI m => m a -> m ()
sectionWorkspace (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ [WorkspaceGroup] -> (WorkspaceGroup -> ConfigT ()) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WorkspaceGroup]
groups ((WorkspaceGroup -> ConfigT ()) -> ConfigT ())
-> (WorkspaceGroup -> ConfigT ()) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ \WorkspaceGroup
g ->
    Name -> ConfigT () -> ConfigT ()
forall (m :: * -> *) a. MonadUI m => Name -> m a -> m ()
section (Color -> Name -> Name
chalk Color
Bold (WorkspaceGroup -> Name
pkgGroupName WorkspaceGroup
g)) (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ do
      [Pkg]
pkgs <- WorkspaceGroup -> ConfigT [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m [Pkg]
memberPkgs WorkspaceGroup
g
      [Pkg] -> (Pkg -> ConfigT ()) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Pkg]
pkgs ((Pkg -> ConfigT ()) -> ConfigT ())
-> (Pkg -> ConfigT ()) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ \Pkg
pkg -> do
        (Status
status, [Issue]
publishIssues) <- Pkg -> ConfigT (Status, [Issue])
upload Pkg
pkg
        Name -> ConfigT ()
forall (m :: * -> *). MonadUI m => Name -> m ()
putLine (Name -> ConfigT ()) -> Name -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Name
"└── " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Int -> Name -> Name
padDots ([Name] -> Int
genMaxLen ((Pkg -> Name) -> [Pkg] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Pkg -> Name
pkgMemberId [Pkg]
pkgs)) (Pkg -> Name
pkgMemberId Pkg
pkg) Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Status -> Name
statusIcon Status
status
        [Issue] -> ConfigT ()
failIssues [Issue]
publishIssues