Init.hs

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

module HWM.CLI.Command.Init (initWorkspace, InitOptions (..)) where

import Control.Monad.Except (MonadError (..))
import Data.List
import HWM.Core.Common (Name)
import HWM.Core.Formatting (Color (Cyan), Format (format), chalk)
import HWM.Core.Options (Options (..))
import HWM.Core.Parsing (ParseCLI (..), flag)
import HWM.Core.Pkg (IsPkg (..), scanPkgs)
import HWM.Core.Result (Issue)
import HWM.Core.Version (Version)
import HWM.Domain.Config (Config (..), defaultScripts)
import HWM.Domain.ConfigT (resolveResultUI, saveConfig)
import HWM.Domain.Registry (deriveRegistry)
import HWM.Domain.Workspace (buildWorkspace)
import HWM.Integrations.Toolchain.Cabal (readCabalPackage)
import HWM.Integrations.Toolchain.Stack (buildMatrix, scanStackFiles)
import HWM.Runtime.Files (forbidOverride)
import HWM.Runtime.UI (MonadUI, runUI, section, uiRow)
import Options.Applicative (argument, help, metavar, str)
import Relude hiding (exitWith, notElem)
import System.Directory (getCurrentDirectory)
import System.FilePath
  ( normalise,
    takeFileName,
    (</>),
  )

size :: Int
size = 24

data InitOptions = InitOptions
  { forceOverride :: Bool,
    projectName :: Maybe Text
  }
  deriving (Show)

instance ParseCLI InitOptions where
  parseCLI =
    InitOptions
      <$> flag 'f' "force" "Force override existing hwm.yaml"
      <*> optional (argument str (metavar "NAME" <> help "Optional project name (defaults to current directory name)"))

initWorkspace :: InitOptions -> Options -> IO ()
initWorkspace InitOptions {..} opts = runUI $ resolveResultUI $ do
  root <- liftIO getCurrentDirectory
  let cfgName = fromMaybe (deriveName root) projectName
  section "init" $ do
    unless forceOverride $ forbidOverride (normalise (root </> optionsHwm opts))
    stacks <- scanStackFiles opts root
    scanning "stack.yaml" stacks
    pkgs <- scanPkgs root
    scanning "packages" pkgs
    when (null pkgs)
      $ throwError
        "No Haskell packages detected in the current directory.\n\
        \Please ensure you are in the project's root and that your packages are discoverable.\n\
        \Try running 'hwm init' from the root directory containing your package sources."
    packages <- traverse readCabalPackage pkgs
    cfgVersion <- deriveVersion (map getPkgVersion packages)
    cfgEnvironments <- buildMatrix pkgs stacks
    cfgWorkspace <- buildWorkspace pkgs
    saveConfig
      Config
        { cfgGithub = Nothing,
          cfgBounds = Nothing,
          cfgScripts = Just defaultScripts,
          cfgRelease = Nothing,
          cfgRegistry = Just (deriveRegistry packages),
          ..
        }
      opts
    uiRow size "save (config)" (chalk Cyan "hwm.yaml")

scanning :: (MonadUI m, Foldable t) => Text -> t a -> m ()
scanning name ls = uiRow size ("scan (" <> name <> ")") (format (length ls) <> " found")

deriveName :: FilePath -> Name
deriveName path =
  let candidate = takeFileName path
   in if null candidate then "workspace" else toText candidate

deriveVersion :: (MonadError Issue m) => [Version] -> m Version
deriveVersion
  versions
    | null versions = throwError "No package versions found for inference"
    | otherwise = pure $ maximum versions