Add.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.CLI.Command.Workspace.Add (WorkspaceAddOptions, runWorkspaceAdd) where

import Control.Monad.Error.Class (MonadError (throwError))
import qualified Data.Map as Map
import HWM.Core.Formatting (Color (..), Status (Checked), chalk, displayStatusM)
import HWM.Core.Parsing (ParseCLI (..))
import HWM.Core.Pkg (PkgName (..), mkPkgDirPath, resolvePrefix)
import HWM.Core.Result (Issue (..), MonadIssue (injectIssue), Severity (SeverityError, SeverityWarning))
import HWM.Domain.Config (Config (..))
import HWM.Domain.ConfigT (ConfigT, Env (config), updateConfig, updateConfigM)
import HWM.Domain.Workspace (WorkGroup (..), WorkspaceRef (..), addWorkgroupMember, parseWorkspaceRef)
import HWM.Integrations.Scaffold (scaffoldPackage)
import HWM.Integrations.Toolchain.Hie (syncHie)
import HWM.Integrations.Toolchain.Stack (syncStackYaml)
import HWM.Runtime.UI (minRowSize, putLine, sectionWorkspace, uiLabel, uiSpace, uiSubPathRow)
import Options.Applicative (help, long, metavar, strArgument, strOption)
import Relude

data WorkspaceAddOptions = WorkspaceAddOptions
  { opsWorkspaceId :: WorkspaceRef,
    opsWorkspaceDir :: Maybe FilePath,
    opsPrefix :: Maybe Text
  }
  deriving (Show)

instance ParseCLI WorkspaceAddOptions where
  parseCLI =
    (WorkspaceAddOptions . parseWorkspaceRef <$> strArgument (metavar "NAME" <> help "Name of the workspace to add"))
      <*> optional (strOption (long "dir" <> help "Directory for the workspace (defaults to group name)"))
      <*> optional (strOption (long "prefix" <> help "Prefix to add to all member package names"))

runWorkspaceAdd :: WorkspaceAddOptions -> ConfigT ()
runWorkspaceAdd (WorkspaceAddOptions {opsWorkspaceId = WorkspaceRef groupId Nothing, ..}) = do
  wss <- asks (cfgWorkspace . config)
  if Map.member groupId wss
    then
      throwError
        Issue
          { issueTopic = groupId,
            issueMessage = "A workspace group \"" <> groupId <> "\" already exists.",
            issueSeverity = SeverityError,
            issueDetails = Nothing
          }
    else do
      let ws = Map.insert groupId (WorkGroup opsWorkspaceDir [] opsPrefix) wss
      sectionWorkspace $ do
        uiSpace
        displayStatusM [("added", pure Checked)] >>= putLine . (("• " <> chalk Bold groupId <> " ") <>)
      updateConfig (\cfg -> pure $ cfg {cfgWorkspace = ws}) (pure ())
runWorkspaceAdd (WorkspaceAddOptions {opsWorkspaceId = WorkspaceRef groupId (Just memberId), ..}) = do
  when (isJust opsPrefix) $ injectIssue (noEffect "prefix")
  when (isJust opsWorkspaceDir) $ injectIssue (noEffect "dir")
  (ws, w) <- addWorkgroupMember groupId memberId
  sectionWorkspace
    $ do
      uiSpace
      uiLabel groupId
      xs <- scaffoldPackage (mkPkgDirPath (dir w) (prefix w) memberId) (PkgName $ resolvePrefix (prefix w) memberId)
      displayStatusM xs >>= uiSubPathRow minRowSize memberId

  updateConfigM (\cfg -> pure $ cfg {cfgWorkspace = ws}) [("stack.yaml", syncStackYaml), ("hie.yaml", syncHie)] $ pure ()
  where
    noEffect label =
      Issue
        { issueTopic = memberId,
          issueMessage = "option \"--" <> label <> "\" is only relevant when adding a workspace group. They have no effect when adding a member package.",
          issueSeverity = SeverityWarning,
          issueDetails = Nothing
        }