-- |Combinators for @optparse-applicative@.
module Hix.Optparse where

import Data.Aeson (Value, eitherDecodeFileStrict', eitherDecodeStrict')
import Distribution.Parsec (eitherParsec)
import Exon (exon)
import Options.Applicative (ReadM, eitherReader)
import Path (
  Abs,
  Dir,
  File,
  Path,
  Rel,
  SomeBase (..),
  parseAbsDir,
  parseAbsFile,
  parseRelDir,
  parseRelFile,
  parseSomeFile,
  toFilePath,
  (</>),
  )
import qualified Text.Show as Show

import Hix.Data.OutputFormat (OutputFormat (..))
import Hix.Data.OutputTarget (OutputTarget (..))
import Hix.Managed.Cabal.Data.Config (HackageIndexState (HackageIndexState))
import Hix.Managed.Handlers.Build (SpecialBuildHandlers (TestBumpHandlers))

pathOption ::
  String ->
  (String -> Either e a) ->
  ReadM a
pathOption :: forall e a. String -> (String -> Either e a) -> ReadM a
pathOption String
desc String -> Either e a
parse =
  (String -> Either String a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
eitherReader \ String
raw ->
    (e -> String) -> Either e a -> Either String a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> e -> String
forall a b. a -> b -> a
const [exon|not a valid #{desc} path: #{raw}|]) (String -> Either e a
parse String
raw)

absPathOrCwdOption ::
  String ->
  (String -> Either e (SomeBase t)) ->
  Path Abs Dir ->
  ReadM (Path Abs t)
absPathOrCwdOption :: forall e t.
String
-> (String -> Either e (SomeBase t))
-> Path Abs Dir
-> ReadM (Path Abs t)
absPathOrCwdOption String
desc String -> Either e (SomeBase t)
parse Path Abs Dir
cwd =
  (String -> Either String (Path Abs t)) -> ReadM (Path Abs t)
forall a. (String -> Either String a) -> ReadM a
eitherReader \ String
raw ->
    (e -> String)
-> Either e (SomeBase t) -> Either String (SomeBase t)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> e -> String
forall a b. a -> b -> a
const [exon|not a valid #{desc} path: #{raw}|]) (String -> Either e (SomeBase t)
parse String
raw) Either String (SomeBase t)
-> (SomeBase t -> Path Abs t) -> Either String (Path Abs t)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Abs Path Abs t
p -> Path Abs t
p
      Rel Path Rel t
p -> Path Abs Dir
cwd Path Abs Dir -> Path Rel t -> Path Abs t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
p

-- | An absolute file path option for @optparse-applicative@.
absFileOption :: ReadM (Path Abs File)
absFileOption :: ReadM (Path Abs File)
absFileOption = String
-> (String -> Either SomeException (Path Abs File))
-> ReadM (Path Abs File)
forall e a. String -> (String -> Either e a) -> ReadM a
pathOption String
"absolute file" String -> Either SomeException (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile

-- | An absolute file path option for @optparse-applicative@.
absFileOrCwdOption :: Path Abs Dir -> ReadM (Path Abs File)
absFileOrCwdOption :: Path Abs Dir -> ReadM (Path Abs File)
absFileOrCwdOption = String
-> (String -> Either SomeException (SomeBase File))
-> Path Abs Dir
-> ReadM (Path Abs File)
forall e t.
String
-> (String -> Either e (SomeBase t))
-> Path Abs Dir
-> ReadM (Path Abs t)
absPathOrCwdOption String
"absolute or relative file" String -> Either SomeException (SomeBase File)
forall (m :: * -> *). MonadThrow m => String -> m (SomeBase File)
parseSomeFile

-- | A relative file path option for @optparse-applicative@.
relFileOption :: ReadM (Path Rel File)
relFileOption :: ReadM (Path Rel File)
relFileOption = String
-> (String -> Either SomeException (Path Rel File))
-> ReadM (Path Rel File)
forall e a. String -> (String -> Either e a) -> ReadM a
pathOption String
"relative file" String -> Either SomeException (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile

-- | A file path option for @optparse-applicative@.
someFileOption :: ReadM (SomeBase File)
someFileOption :: ReadM (SomeBase File)
someFileOption = String
-> (String -> Either SomeException (SomeBase File))
-> ReadM (SomeBase File)
forall e a. String -> (String -> Either e a) -> ReadM a
pathOption String
"some file" String -> Either SomeException (SomeBase File)
forall (m :: * -> *). MonadThrow m => String -> m (SomeBase File)
parseSomeFile

-- | A relative dir path option for @optparse-applicative@.
absDirOption :: ReadM (Path Abs Dir)
absDirOption :: ReadM (Path Abs Dir)
absDirOption = String
-> (String -> Either SomeException (Path Abs Dir))
-> ReadM (Path Abs Dir)
forall e a. String -> (String -> Either e a) -> ReadM a
pathOption String
"absolute dir" String -> Either SomeException (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir

-- | A relative dir path option for @optparse-applicative@.
relDirOption :: ReadM (Path Rel Dir)
relDirOption :: ReadM (Path Rel Dir)
relDirOption = String
-> (String -> Either SomeException (Path Rel Dir))
-> ReadM (Path Rel Dir)
forall e a. String -> (String -> Either e a) -> ReadM a
pathOption String
"relative dir" String -> Either SomeException (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir

newtype JsonConfig =
  JsonConfig { JsonConfig -> IO (Either String Value)
unJsonConfig :: IO (Either String Value) }
  deriving stock ((forall x. JsonConfig -> Rep JsonConfig x)
-> (forall x. Rep JsonConfig x -> JsonConfig) -> Generic JsonConfig
forall x. Rep JsonConfig x -> JsonConfig
forall x. JsonConfig -> Rep JsonConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JsonConfig -> Rep JsonConfig x
from :: forall x. JsonConfig -> Rep JsonConfig x
$cto :: forall x. Rep JsonConfig x -> JsonConfig
to :: forall x. Rep JsonConfig x -> JsonConfig
Generic)

instance Show JsonConfig where
  show :: JsonConfig -> String
show (JsonConfig IO (Either String Value)
_) = String
"JsonConfig"

jsonOption :: ReadM JsonConfig
jsonOption :: ReadM JsonConfig
jsonOption =
  (String -> Either String JsonConfig) -> ReadM JsonConfig
forall a. (String -> Either String a) -> ReadM a
eitherReader \ String
raw -> do
    JsonConfig -> Either String JsonConfig
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JsonConfig -> Either String JsonConfig)
-> JsonConfig -> Either String JsonConfig
forall a b. (a -> b) -> a -> b
$ IO (Either String Value) -> JsonConfig
JsonConfig (IO (Either String Value) -> JsonConfig)
-> IO (Either String Value) -> JsonConfig
forall a b. (a -> b) -> a -> b
$ case String -> Maybe (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
raw of
      Just Path Abs File
f -> String -> IO (Either String Value)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
f)
      Maybe (Path Abs File)
Nothing -> Either String Value -> IO (Either String Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' (String -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 String
raw))

buildHandlersOption :: ReadM SpecialBuildHandlers
buildHandlersOption :: ReadM SpecialBuildHandlers
buildHandlersOption =
  (String -> Either String SpecialBuildHandlers)
-> ReadM SpecialBuildHandlers
forall a. (String -> Either String a) -> ReadM a
eitherReader \case
    String
"test" -> SpecialBuildHandlers -> Either String SpecialBuildHandlers
forall a b. b -> Either a b
Right SpecialBuildHandlers
TestBumpHandlers
    String
h -> String -> Either String SpecialBuildHandlers
forall a b. a -> Either a b
Left [exon|Invalid value for build handlers: #{h}|]

outputFormatOption :: ReadM OutputFormat
outputFormatOption :: ReadM OutputFormat
outputFormatOption =
  (String -> Either String OutputFormat) -> ReadM OutputFormat
forall a. (String -> Either String a) -> ReadM a
eitherReader \case
    String
"none" -> OutputFormat -> Either String OutputFormat
forall a b. b -> Either a b
Right OutputFormat
OutputNone
    String
"json" -> OutputFormat -> Either String OutputFormat
forall a b. b -> Either a b
Right OutputFormat
OutputJson
    String
"commit-msg" -> OutputFormat -> Either String OutputFormat
forall a b. b -> Either a b
Right OutputFormat
OutputCommitMsg
    String
"ga-pr" -> OutputFormat -> Either String OutputFormat
forall a b. b -> Either a b
Right OutputFormat
OutputGaPr
    String
fmt -> String -> Either String OutputFormat
forall a b. a -> Either a b
Left [exon|Invalid output format: #{fmt}|]

outputTargetOption :: ReadM OutputTarget
outputTargetOption :: ReadM OutputTarget
outputTargetOption =
  (String -> Either String OutputTarget) -> ReadM OutputTarget
forall a. (String -> Either String a) -> ReadM a
eitherReader \case
    String
"default" -> OutputTarget -> Either String OutputTarget
forall a b. b -> Either a b
Right OutputTarget
OutputDefault
    String
"stdout" -> OutputTarget -> Either String OutputTarget
forall a b. b -> Either a b
Right OutputTarget
OutputStdout
    String
other -> Either String OutputTarget
-> (Path Abs File -> Either String OutputTarget)
-> Maybe (Path Abs File)
-> Either String OutputTarget
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String OutputTarget
forall {inner} {builder} {b}.
(ExonAppend inner builder, ExonString inner builder,
 ExonBuilder inner builder) =>
inner -> Either inner b
badFile String
other) (OutputTarget -> Either String OutputTarget
forall a b. b -> Either a b
Right (OutputTarget -> Either String OutputTarget)
-> (Path Abs File -> OutputTarget)
-> Path Abs File
-> Either String OutputTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> OutputTarget
OutputFile) (String -> Maybe (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
other)
  where
    badFile :: inner -> Either inner b
badFile inner
f = inner -> Either inner b
forall a b. a -> Either a b
Left [exon|Argument for --output is neither an absolute filepath nor 'default' or 'stdout': #{f}|]

indexStateOption :: ReadM HackageIndexState
indexStateOption :: ReadM HackageIndexState
indexStateOption =
  (String -> Either String HackageIndexState)
-> ReadM HackageIndexState
forall a. (String -> Either String a) -> ReadM a
eitherReader \ String
raw -> ShowS
-> (Timestamp -> HackageIndexState)
-> Either String Timestamp
-> Either String HackageIndexState
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> ShowS
forall {inner} {builder}.
(ExonAppend inner builder, ExonString inner builder,
 ExonBuilder inner builder) =>
inner -> inner -> inner
err String
raw) Timestamp -> HackageIndexState
HackageIndexState (String -> Either String Timestamp
forall a. Parsec a => String -> Either String a
eitherParsec String
raw)
  where
    err :: inner -> inner -> inner
err inner
raw inner
msg = [exon|Invalid index state string '#{raw}': #{msg}|]