{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.CLI.App
  ( main,
  )
where

import Data.Text (pack)
import HWM.CLI.Command
  ( Command (..),
    Options (..),
    currentVersion,
    defaultOptions,
    runCommand,
  )
import HWM.CLI.Command.Init (InitOptions (..))
import HWM.CLI.Command.Run (ScriptOptions (..))
import HWM.Core.Common (Name)
import HWM.Core.Parsing (Parse (..), parseOptions)
import Options.Applicative
  ( Parser,
    argument,
    command,
    customExecParser,
    fullDesc,
    help,
    helper,
    info,
    long,
    metavar,
    prefs,
    progDesc,
    short,
    showHelpOnError,
    strArgument,
    subparser,
    switch,
  )
import Options.Applicative.Builder (str, strOption)
import Relude hiding (ByteString, fix)

-- Helper for building commands (unchanged, just added type signature clarity)
commands :: [(String, String, Parser a)] -> Parser a
commands :: forall a. [(String, String, Parser a)] -> Parser a
commands =
  Mod CommandFields a -> Parser a
forall a. Mod CommandFields a -> Parser a
subparser
    (Mod CommandFields a -> Parser a)
-> ([(String, String, Parser a)] -> Mod CommandFields a)
-> [(String, String, Parser a)]
-> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Mod CommandFields a] -> Mod CommandFields a
forall a. Monoid a => [a] -> a
mconcat
    ([Mod CommandFields a] -> Mod CommandFields a)
-> ([(String, String, Parser a)] -> [Mod CommandFields a])
-> [(String, String, Parser a)]
-> Mod CommandFields a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String, Parser a) -> Mod CommandFields a)
-> [(String, String, Parser a)] -> [Mod CommandFields a]
forall a b. (a -> b) -> [a] -> [b]
map
      ( \(String
name, String
desc, Parser a
value) ->
          String -> ParserInfo a -> Mod CommandFields a
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
name (Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (a -> a)
forall a. Parser (a -> a)
helper Parser (a -> a) -> Parser a -> Parser a
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
value) (InfoMod a
forall a. InfoMod a
fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
desc))
      )

flag :: Char -> String -> String -> Parser Bool
flag :: Char -> String -> String -> Parser Bool
flag Char
s String
l String
h = Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
l Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
s Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
h)

run :: Parser a -> IO a
run :: forall a. Parser a -> IO a
run Parser a
app =
  ParserPrefs -> ParserInfo a -> IO a
forall a. ParserPrefs -> ParserInfo a -> IO a
customExecParser
    (PrefsMod -> ParserPrefs
prefs PrefsMod
showHelpOnError)
    ( Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
info
        (Parser (a -> a)
forall a. Parser (a -> a)
helper Parser (a -> a) -> Parser a -> Parser a
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
app)
        (InfoMod a
forall a. InfoMod a
fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
"HWM - Haskell Workspace Manager for Monorepos")
    )

parseScriptOptions :: Parser Name -> Parser ScriptOptions
parseScriptOptions :: Parser Text -> Parser ScriptOptions
parseScriptOptions Parser Text
name =
  Text -> [Text] -> [Text] -> [Text] -> ScriptOptions
ScriptOptions
    (Text -> [Text] -> [Text] -> [Text] -> ScriptOptions)
-> Parser Text
-> Parser ([Text] -> [Text] -> [Text] -> ScriptOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
name
    Parser ([Text] -> [Text] -> [Text] -> ScriptOptions)
-> Parser [Text] -> Parser ([Text] -> [Text] -> ScriptOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Text] -> [Text]) -> Parser [Text] -> Parser [Text]
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> [Text]
parseOptions (Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"target" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
't' Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"TARGET" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Limit to package (core) or group (libs)")))
    Parser ([Text] -> [Text] -> ScriptOptions)
-> Parser [Text] -> Parser ([Text] -> ScriptOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([Text] -> [Text]) -> Parser [Text] -> Parser [Text]
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> [Text]
parseOptions (Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
strOption (String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"env" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'e' Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"ENV" Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Run in specific env (use 'all' for full matrix)")))
    Parser ([Text] -> ScriptOptions)
-> Parser [Text] -> Parser ScriptOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text -> Parser [Text]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (String -> Text
pack (String -> Text) -> ReadM String -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String
forall s. IsString s => ReadM s
str) (String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"ARGS..." Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Arguments to forward to the script"))

parseInitOptions :: Parser InitOptions
parseInitOptions :: Parser InitOptions
parseInitOptions =
  Bool -> Maybe Text -> InitOptions
InitOptions
    (Bool -> Maybe Text -> InitOptions)
-> Parser Bool -> Parser (Maybe Text -> InitOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> String -> Parser Bool
flag Char
'f' String
"force" String
"Force override existing hwm.yaml"
    Parser (Maybe Text -> InitOptions)
-> Parser (Maybe Text) -> Parser InitOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM Text
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"NAME" Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Optional project name (defaults to current directory name)"))

parseCommand :: Parser Command
parseCommand :: Parser Command
parseCommand =
  [(String, String, Parser Command)] -> Parser Command
forall a. [(String, String, Parser a)] -> Parser a
commands
    [ ( String
"sync",
        String
"Regenerate stack.yaml and .cabal files. Optional: switch environment.",
        Maybe Text -> Command
Sync (Maybe Text -> Command) -> Parser (Maybe Text) -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM Text
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"ENV" Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Switch to a specific environment (e.g., legacy, stable)"))
      ),
      ( String
"version",
        String
"Show version or bump it (patch | minor | major).",
        Maybe Bump -> Command
Version (Maybe Bump -> Command) -> Parser (Maybe Bump) -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bump -> Parser (Maybe Bump)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM Bump -> Mod ArgumentFields Bump -> Parser Bump
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (ReadM Text
forall s. IsString s => ReadM s
str ReadM Text -> (Text -> ReadM Bump) -> ReadM Bump
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> ReadM Bump
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Bump
parse) (String -> Mod ArgumentFields Bump
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"BUMP" Mod ArgumentFields Bump
-> Mod ArgumentFields Bump -> Mod ArgumentFields Bump
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Bump
forall (f :: * -> *) a. String -> Mod f a
help String
"Version bump type or specific version number"))
      ),
      ( String
"outdated",
        String
"Check for newer dependencies on Hackage.",
        Bool -> Command
Outdated (Bool -> Command) -> Parser Bool -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"fix" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Write changes to hwm.yaml")
      ),
      ( String
"publish",
        String
"Upload packages to Hackage/Registry.",
        Maybe Text -> Command
Publish (Maybe Text -> Command) -> Parser (Maybe Text) -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ReadM Text
forall s. IsString s => ReadM s
str (String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"GROUP" Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Name of the workspace group to publish (default: all)"))
      ),
      ( String
"run",
        String
"Run a script defined in hwm.yaml",
        ScriptOptions -> Command
Run (ScriptOptions -> Command)
-> Parser ScriptOptions -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser ScriptOptions
parseScriptOptions (ReadM Text -> Mod ArgumentFields Text -> Parser Text
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument (String -> Text
pack (String -> Text) -> ReadM String -> ReadM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String
forall s. IsString s => ReadM s
str) (String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"SCRIPT" Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
help String
"Name of the script to run"))
      ),
      ( String
"status",
        String
"Show the current environment, version, and sync status.",
        Command -> Parser Command
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
Status
      ),
      ( String
"init",
        String
"Initialize a new HWM workspace by scanning the current directory.",
        InitOptions -> Command
Init (InitOptions -> Command) -> Parser InitOptions -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser InitOptions
parseInitOptions
      )
    ]
    Parser Command -> Parser Command -> Parser Command
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ScriptOptions -> Command
Run (ScriptOptions -> Command)
-> Parser ScriptOptions -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser ScriptOptions
parseScriptOptions (Mod ArgumentFields Text -> Parser Text
forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"SCRIPT")))

data Input = Input
  { Input -> Bool
v :: Bool,
    Input -> Bool
q :: Bool,
    Input -> Maybe Command
cmd :: Maybe Command
  }
  deriving (Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
(Int -> Input -> ShowS)
-> (Input -> String) -> ([Input] -> ShowS) -> Show Input
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Input -> ShowS
showsPrec :: Int -> Input -> ShowS
$cshow :: Input -> String
show :: Input -> String
$cshowList :: [Input] -> ShowS
showList :: [Input] -> ShowS
Show)

parseInput :: IO Input
parseInput :: IO Input
parseInput =
  Parser Input -> IO Input
forall a. Parser a -> IO a
run
    (Parser Input -> IO Input) -> Parser Input -> IO Input
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Maybe Command -> Input
Input
    (Bool -> Bool -> Maybe Command -> Input)
-> Parser Bool -> Parser (Bool -> Maybe Command -> Input)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> String -> String -> Parser Bool
flag Char
'v' String
"version" String
"Show HWM version number"
    Parser (Bool -> Maybe Command -> Input)
-> Parser Bool -> Parser (Maybe Command -> Input)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> String -> String -> Parser Bool
flag Char
'q' String
"quiet" String
"Run quietly with minimal output"
    Parser (Maybe Command -> Input)
-> Parser (Maybe Command) -> Parser Input
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Command -> Parser (Maybe Command)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Command
parseCommand

main :: IO ()
main :: IO ()
main = do
  Input {Bool
v :: Input -> Bool
v :: Bool
v, Bool
q :: Input -> Bool
q :: Bool
q, Maybe Command
cmd :: Input -> Maybe Command
cmd :: Maybe Command
cmd} <- IO Input
parseInput
  if Bool
v
    then String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String
"HWM v" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
currentVersion)
    else case Maybe Command
cmd of
      Just Command
c -> Command -> Options -> IO ()
runCommand Command
c (Options
defaultOptions {quiet = q})
      Maybe Command
Nothing -> do
        String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
"HWM: Missing command.\nTry 'hwm --help' for usage."
        IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure