{-# 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, padDots)
import HWM.Core.Options (Options (..))
import HWM.Core.Pkg (Pkg (..), scanPkgs)
import HWM.Core.Result (Issue)
import HWM.Core.Version (Version)
import HWM.Domain.Bounds (versionBounds)
import HWM.Domain.Config (Config (..), defaultScripts)
import HWM.Domain.ConfigT (resolveResultUI, saveConfig)
import HWM.Domain.Workspace (buildWorkspaceGroups)
import HWM.Integrations.Toolchain.Package (deriveRegistry)
import HWM.Integrations.Toolchain.Stack (buildMatrix, scanStackFiles)
import HWM.Runtime.Files (forbidOverride)
import HWM.Runtime.UI (MonadUI, putLine, runUI, section)
import Relude hiding (exitWith, notElem)
import System.Directory (getCurrentDirectory)
import System.FilePath
  ( normalise,
    takeFileName,
    (</>),
  )

size :: Int
size :: Int
size = Int
24

data InitOptions = InitOptions
  { InitOptions -> Bool
forceOverride :: Bool,
    InitOptions -> Maybe Name
projectName :: Maybe Text
  }
  deriving (Int -> InitOptions -> ShowS
[InitOptions] -> ShowS
InitOptions -> FilePath
(Int -> InitOptions -> ShowS)
-> (InitOptions -> FilePath)
-> ([InitOptions] -> ShowS)
-> Show InitOptions
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitOptions -> ShowS
showsPrec :: Int -> InitOptions -> ShowS
$cshow :: InitOptions -> FilePath
show :: InitOptions -> FilePath
$cshowList :: [InitOptions] -> ShowS
showList :: [InitOptions] -> ShowS
Show)

initWorkspace :: InitOptions -> Options -> IO ()
initWorkspace :: InitOptions -> Options -> IO ()
initWorkspace InitOptions {Bool
Maybe Name
forceOverride :: InitOptions -> Bool
projectName :: InitOptions -> Maybe Name
forceOverride :: Bool
projectName :: Maybe Name
..} Options
opts = UIT IO () -> IO ()
forall a. UIT IO a -> IO a
runUI (UIT IO () -> IO ()) -> UIT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ResultT (UIT IO) () -> UIT IO ()
forall a. ResultT (UIT IO) a -> UIT IO a
resolveResultUI (ResultT (UIT IO) () -> UIT IO ())
-> ResultT (UIT IO) () -> UIT IO ()
forall a b. (a -> b) -> a -> b
$ do
  FilePath
root <- IO FilePath -> ResultT (UIT IO) FilePath
forall a. IO a -> ResultT (UIT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCurrentDirectory
  let name :: Name
name = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Name
deriveName FilePath
root) Maybe Name
projectName
  Name -> ResultT (UIT IO) () -> ResultT (UIT IO) ()
forall (m :: * -> *) a. MonadUI m => Name -> m a -> m ()
section Name
"init" (ResultT (UIT IO) () -> ResultT (UIT IO) ())
-> ResultT (UIT IO) () -> ResultT (UIT IO) ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> ResultT (UIT IO) () -> ResultT (UIT IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
forceOverride (ResultT (UIT IO) () -> ResultT (UIT IO) ())
-> ResultT (UIT IO) () -> ResultT (UIT IO) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ResultT (UIT IO) ()
forall (m :: * -> *) e.
(MonadIO m, MonadError e m, IsString e) =>
FilePath -> m ()
forbidOverride (ShowS
normalise (FilePath
root FilePath -> ShowS
</> Options -> FilePath
hwm Options
opts))
    NonEmpty (Name, Stack)
stacks <- Options -> FilePath -> ResultT (UIT IO) (NonEmpty (Name, Stack))
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Options -> FilePath -> m (NonEmpty (Name, Stack))
scanStackFiles Options
opts FilePath
root
    Name -> NonEmpty (Name, Stack) -> ResultT (UIT IO) ()
forall (m :: * -> *) (t :: * -> *) a.
(MonadUI m, Foldable t) =>
Name -> t a -> m ()
scanning Name
"stack.yaml" NonEmpty (Name, Stack)
stacks
    [Pkg]
pkgs <- FilePath -> ResultT (UIT IO) [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
FilePath -> m [Pkg]
scanPkgs FilePath
root
    Name -> [Pkg] -> ResultT (UIT IO) ()
forall (m :: * -> *) (t :: * -> *) a.
(MonadUI m, Foldable t) =>
Name -> t a -> m ()
scanning Name
"packages" [Pkg]
pkgs
    Bool -> ResultT (UIT IO) () -> ResultT (UIT IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Pkg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pkg]
pkgs) (ResultT (UIT IO) () -> ResultT (UIT IO) ())
-> ResultT (UIT IO) () -> ResultT (UIT IO) ()
forall a b. (a -> b) -> a -> b
$ Issue -> ResultT (UIT IO) ()
forall a. Issue -> ResultT (UIT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Issue
"No packages listed in stack.yaml. Add at least one package before running 'hwm init'"
    (Dependencies
registry, DependencyGraph
graph) <- [Pkg] -> ResultT (UIT IO) (Dependencies, DependencyGraph)
forall (m :: * -> *).
(Monad m, MonadError Issue m, MonadIO m) =>
[Pkg] -> m (Dependencies, DependencyGraph)
deriveRegistry [Pkg]
pkgs
    Version
version <- [Version] -> ResultT (UIT IO) Version
forall (m :: * -> *). MonadError Issue m => [Version] -> m Version
deriveVersion ((Pkg -> Version) -> [Pkg] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map Pkg -> Version
pkgVersion [Pkg]
pkgs)
    Matrix
matrix <- [Pkg] -> NonEmpty (Name, Stack) -> ResultT (UIT IO) Matrix
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[Pkg] -> NonEmpty (Name, Stack) -> m Matrix
buildMatrix [Pkg]
pkgs NonEmpty (Name, Stack)
stacks
    [WorkspaceGroup]
workspace <- DependencyGraph -> [Pkg] -> ResultT (UIT IO) [WorkspaceGroup]
forall (m :: * -> *).
(Monad m, MonadError Issue m) =>
DependencyGraph -> [Pkg] -> m [WorkspaceGroup]
buildWorkspaceGroups DependencyGraph
graph [Pkg]
pkgs
    Config -> Options -> ResultT (UIT IO) ()
forall (m :: * -> *).
(MonadError Issue m, MonadIO m) =>
Config -> Options -> m ()
saveConfig
      Config
        { bounds :: Bounds
bounds = Version -> Bounds
versionBounds Version
version,
          scripts :: Map Name Name
scripts = Map Name Name
defaultScripts,
          [WorkspaceGroup]
Name
Version
Dependencies
Matrix
name :: Name
registry :: Dependencies
version :: Version
matrix :: Matrix
workspace :: [WorkspaceGroup]
registry :: Dependencies
matrix :: Matrix
workspace :: [WorkspaceGroup]
version :: Version
name :: Name
..
        }
      Options
opts
    Name -> ResultT (UIT IO) ()
forall (m :: * -> *). MonadUI m => Name -> m ()
putLine (Name -> ResultT (UIT IO) ()) -> Name -> ResultT (UIT IO) ()
forall a b. (a -> b) -> a -> b
$ Int -> Name -> Name
padDots Int
size Name
"save (config)" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Color -> Name -> Name
chalk Color
Cyan Name
"hwm.yaml"

scanning :: (MonadUI m, Foldable t) => Text -> t a -> m ()
scanning :: forall (m :: * -> *) (t :: * -> *) a.
(MonadUI m, Foldable t) =>
Name -> t a -> m ()
scanning Name
name t a
ls = Name -> m ()
forall (m :: * -> *). MonadUI m => Name -> m ()
putLine (Int -> Name -> Name
padDots Int
size (Name
"scan (" Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
")") Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Int -> Name
forall a. Format a => a -> Name
format (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls) Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" found")

deriveName :: FilePath -> Name
deriveName :: FilePath -> Name
deriveName FilePath
path =
  let candidate :: FilePath
candidate = ShowS
takeFileName FilePath
path
   in if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
candidate then Name
"workspace" else FilePath -> Name
forall a. ToText a => a -> Name
toText FilePath
candidate

deriveVersion :: (MonadError Issue m) => [Version] -> m Version
deriveVersion :: forall (m :: * -> *). MonadError Issue m => [Version] -> m Version
deriveVersion
  [Version]
versions
    | [Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
versions = Issue -> m Version
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Issue
"No package versions found for inference"
    | Bool
otherwise = Version -> m Version
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version -> m Version) -> Version -> m Version
forall a b. (a -> b) -> a -> b
$ [Version] -> Version
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Version]
versions