{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}

module Distribution.Client.CmdInstall.ClientInstallFlags
  ( InstallMethod (..)
  , ClientInstallFlags (..)
  , defaultClientInstallFlags
  , clientInstallOptions
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.ReadE
  ( parsecToReadE
  , succeedReadE
  )
import Distribution.Simple.Command
  ( OptionField (..)
  , ShowOrParseArgs (..)
  , option
  , reqArg
  )
import Distribution.Simple.Setup
  ( Flag (..)
  , flagToList
  , toFlag
  , trueArg
  )

import Distribution.Client.Types.InstallMethod
  ( InstallMethod (..)
  )
import Distribution.Client.Types.OverwritePolicy
  ( OverwritePolicy (..)
  )

import qualified Distribution.Compat.CharParsing as P

data ClientInstallFlags = ClientInstallFlags
  { ClientInstallFlags -> Flag Bool
cinstInstallLibs :: Flag Bool
  , ClientInstallFlags -> Flag Description
cinstEnvironmentPath :: Flag FilePath
  , ClientInstallFlags -> Flag OverwritePolicy
cinstOverwritePolicy :: Flag OverwritePolicy
  , ClientInstallFlags -> Flag InstallMethod
cinstInstallMethod :: Flag InstallMethod
  , ClientInstallFlags -> Flag Description
cinstInstalldir :: Flag FilePath
  }
  deriving (ClientInstallFlags -> ClientInstallFlags -> Bool
(ClientInstallFlags -> ClientInstallFlags -> Bool)
-> (ClientInstallFlags -> ClientInstallFlags -> Bool)
-> Eq ClientInstallFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientInstallFlags -> ClientInstallFlags -> Bool
== :: ClientInstallFlags -> ClientInstallFlags -> Bool
$c/= :: ClientInstallFlags -> ClientInstallFlags -> Bool
/= :: ClientInstallFlags -> ClientInstallFlags -> Bool
Eq, Int -> ClientInstallFlags -> ShowS
[ClientInstallFlags] -> ShowS
ClientInstallFlags -> Description
(Int -> ClientInstallFlags -> ShowS)
-> (ClientInstallFlags -> Description)
-> ([ClientInstallFlags] -> ShowS)
-> Show ClientInstallFlags
forall a.
(Int -> a -> ShowS)
-> (a -> Description) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientInstallFlags -> ShowS
showsPrec :: Int -> ClientInstallFlags -> ShowS
$cshow :: ClientInstallFlags -> Description
show :: ClientInstallFlags -> Description
$cshowList :: [ClientInstallFlags] -> ShowS
showList :: [ClientInstallFlags] -> ShowS
Show, (forall x. ClientInstallFlags -> Rep ClientInstallFlags x)
-> (forall x. Rep ClientInstallFlags x -> ClientInstallFlags)
-> Generic ClientInstallFlags
forall x. Rep ClientInstallFlags x -> ClientInstallFlags
forall x. ClientInstallFlags -> Rep ClientInstallFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClientInstallFlags -> Rep ClientInstallFlags x
from :: forall x. ClientInstallFlags -> Rep ClientInstallFlags x
$cto :: forall x. Rep ClientInstallFlags x -> ClientInstallFlags
to :: forall x. Rep ClientInstallFlags x -> ClientInstallFlags
Generic)

instance Monoid ClientInstallFlags where
  mempty :: ClientInstallFlags
mempty = ClientInstallFlags
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
  mappend :: ClientInstallFlags -> ClientInstallFlags -> ClientInstallFlags
mappend = ClientInstallFlags -> ClientInstallFlags -> ClientInstallFlags
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup ClientInstallFlags where
  <> :: ClientInstallFlags -> ClientInstallFlags -> ClientInstallFlags
(<>) = ClientInstallFlags -> ClientInstallFlags -> ClientInstallFlags
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend

instance Binary ClientInstallFlags
instance Structured ClientInstallFlags

defaultClientInstallFlags :: ClientInstallFlags
defaultClientInstallFlags :: ClientInstallFlags
defaultClientInstallFlags =
  ClientInstallFlags
    { cinstInstallLibs :: Flag Bool
cinstInstallLibs = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False
    , cinstEnvironmentPath :: Flag Description
cinstEnvironmentPath = Flag Description
forall a. Monoid a => a
mempty
    , cinstOverwritePolicy :: Flag OverwritePolicy
cinstOverwritePolicy = Flag OverwritePolicy
forall a. Monoid a => a
mempty
    , cinstInstallMethod :: Flag InstallMethod
cinstInstallMethod = Flag InstallMethod
forall a. Monoid a => a
mempty
    , cinstInstalldir :: Flag Description
cinstInstalldir = Flag Description
forall a. Monoid a => a
mempty
    }

clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions ShowOrParseArgs
_ =
  [ Description
-> LFlags
-> Description
-> (ClientInstallFlags -> Flag Bool)
-> (Flag Bool -> ClientInstallFlags -> ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag Bool)
     (Flag Bool -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall get set a.
Description
-> LFlags
-> Description
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [Description
"lib"]
      ( Description
"Install libraries rather than executables from the target package "
          Description -> ShowS
forall a. Semigroup a => a -> a -> a
<> Description
"(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)."
      )
      ClientInstallFlags -> Flag Bool
cinstInstallLibs
      (\Flag Bool
v ClientInstallFlags
flags -> ClientInstallFlags
flags{cinstInstallLibs = v})
      MkOptDescr
  (ClientInstallFlags -> Flag Bool)
  (Flag Bool -> ClientInstallFlags -> ClientInstallFlags)
  ClientInstallFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
  , Description
-> LFlags
-> Description
-> (ClientInstallFlags -> Flag Description)
-> (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag Description)
     (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall get set a.
Description
-> LFlags
-> Description
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [Description
"package-env", Description
"env"]
      Description
"Set the environment file that may be modified."
      ClientInstallFlags -> Flag Description
cinstEnvironmentPath
      (\Flag Description
pf ClientInstallFlags
flags -> ClientInstallFlags
flags{cinstEnvironmentPath = pf})
      (Description
-> ReadE (Flag Description)
-> (Flag Description -> LFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag Description)
     (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
forall b a.
Monoid b =>
Description
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg Description
"ENV" ((Description -> Flag Description) -> ReadE (Flag Description)
forall a. (Description -> a) -> ReadE a
succeedReadE Description -> Flag Description
forall a. a -> Flag a
Flag) Flag Description -> LFlags
forall a. Flag a -> [a]
flagToList)
  , Description
-> LFlags
-> Description
-> (ClientInstallFlags -> Flag OverwritePolicy)
-> (Flag OverwritePolicy
    -> ClientInstallFlags -> ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag OverwritePolicy)
     (Flag OverwritePolicy -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall get set a.
Description
-> LFlags
-> Description
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [Description
"overwrite-policy"]
      Description
"How to handle already existing symlinks."
      ClientInstallFlags -> Flag OverwritePolicy
cinstOverwritePolicy
      (\Flag OverwritePolicy
v ClientInstallFlags
flags -> ClientInstallFlags
flags{cinstOverwritePolicy = v})
      (MkOptDescr
   (ClientInstallFlags -> Flag OverwritePolicy)
   (Flag OverwritePolicy -> ClientInstallFlags -> ClientInstallFlags)
   ClientInstallFlags
 -> OptionField ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag OverwritePolicy)
     (Flag OverwritePolicy -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall a b. (a -> b) -> a -> b
$ Description
-> ReadE (Flag OverwritePolicy)
-> (Flag OverwritePolicy -> LFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag OverwritePolicy)
     (Flag OverwritePolicy -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
forall b a.
Monoid b =>
Description
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg
        Description
"always|never|prompt"
        (ShowS
-> ParsecParser (Flag OverwritePolicy)
-> ReadE (Flag OverwritePolicy)
forall a. ShowS -> ParsecParser a -> ReadE a
parsecToReadE (\Description
err -> Description
"Error parsing overwrite-policy: " Description -> ShowS
forall a. [a] -> [a] -> [a]
++ Description
err) (OverwritePolicy -> Flag OverwritePolicy
forall a. a -> Flag a
toFlag (OverwritePolicy -> Flag OverwritePolicy)
-> ParsecParser OverwritePolicy
-> ParsecParser (Flag OverwritePolicy)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser OverwritePolicy
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m OverwritePolicy
parsec))
        ((OverwritePolicy -> Description) -> [OverwritePolicy] -> LFlags
forall a b. (a -> b) -> [a] -> [b]
map OverwritePolicy -> Description
forall a. Pretty a => a -> Description
prettyShow ([OverwritePolicy] -> LFlags)
-> (Flag OverwritePolicy -> [OverwritePolicy])
-> Flag OverwritePolicy
-> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag OverwritePolicy -> [OverwritePolicy]
forall a. Flag a -> [a]
flagToList)
  , Description
-> LFlags
-> Description
-> (ClientInstallFlags -> Flag InstallMethod)
-> (Flag InstallMethod -> ClientInstallFlags -> ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag InstallMethod)
     (Flag InstallMethod -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall get set a.
Description
-> LFlags
-> Description
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [Description
"install-method"]
      Description
"How to install the executables."
      ClientInstallFlags -> Flag InstallMethod
cinstInstallMethod
      (\Flag InstallMethod
v ClientInstallFlags
flags -> ClientInstallFlags
flags{cinstInstallMethod = v})
      (MkOptDescr
   (ClientInstallFlags -> Flag InstallMethod)
   (Flag InstallMethod -> ClientInstallFlags -> ClientInstallFlags)
   ClientInstallFlags
 -> OptionField ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag InstallMethod)
     (Flag InstallMethod -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall a b. (a -> b) -> a -> b
$ Description
-> ReadE (Flag InstallMethod)
-> (Flag InstallMethod -> LFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag InstallMethod)
     (Flag InstallMethod -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
forall b a.
Monoid b =>
Description
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg
        Description
"default|copy|symlink"
        (ShowS
-> ParsecParser (Flag InstallMethod) -> ReadE (Flag InstallMethod)
forall a. ShowS -> ParsecParser a -> ReadE a
parsecToReadE (\Description
err -> Description
"Error parsing install-method: " Description -> ShowS
forall a. [a] -> [a] -> [a]
++ Description
err) (InstallMethod -> Flag InstallMethod
forall a. a -> Flag a
toFlag (InstallMethod -> Flag InstallMethod)
-> ParsecParser InstallMethod -> ParsecParser (Flag InstallMethod)
forall a b. (a -> b) -> ParsecParser a -> ParsecParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ParsecParser InstallMethod
forall (m :: * -> *). CabalParsing m => m InstallMethod
parsecInstallMethod))
        ((InstallMethod -> Description) -> [InstallMethod] -> LFlags
forall a b. (a -> b) -> [a] -> [b]
map InstallMethod -> Description
forall a. Pretty a => a -> Description
prettyShow ([InstallMethod] -> LFlags)
-> (Flag InstallMethod -> [InstallMethod])
-> Flag InstallMethod
-> LFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag InstallMethod -> [InstallMethod]
forall a. Flag a -> [a]
flagToList)
  , Description
-> LFlags
-> Description
-> (ClientInstallFlags -> Flag Description)
-> (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag Description)
     (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall get set a.
Description
-> LFlags
-> Description
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [Description
"installdir"]
      Description
"Where to install (by symlinking or copying) the executables in."
      ClientInstallFlags -> Flag Description
cinstInstalldir
      (\Flag Description
v ClientInstallFlags
flags -> ClientInstallFlags
flags{cinstInstalldir = v})
      (MkOptDescr
   (ClientInstallFlags -> Flag Description)
   (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
   ClientInstallFlags
 -> OptionField ClientInstallFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag Description)
     (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
-> OptionField ClientInstallFlags
forall a b. (a -> b) -> a -> b
$ Description
-> ReadE (Flag Description)
-> (Flag Description -> LFlags)
-> MkOptDescr
     (ClientInstallFlags -> Flag Description)
     (Flag Description -> ClientInstallFlags -> ClientInstallFlags)
     ClientInstallFlags
forall b a.
Monoid b =>
Description
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg Description
"DIR" ((Description -> Flag Description) -> ReadE (Flag Description)
forall a. (Description -> a) -> ReadE a
succeedReadE Description -> Flag Description
forall a. a -> Flag a
Flag) Flag Description -> LFlags
forall a. Flag a -> [a]
flagToList
  ]

parsecInstallMethod :: CabalParsing m => m InstallMethod
parsecInstallMethod :: forall (m :: * -> *). CabalParsing m => m InstallMethod
parsecInstallMethod = do
  Description
name <- (Char -> Bool) -> m Description
forall (m :: * -> *).
CharParsing m =>
(Char -> Bool) -> m Description
P.munch1 Char -> Bool
isAlpha
  case Description
name of
    Description
"copy" -> InstallMethod -> m InstallMethod
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InstallMethod
InstallMethodCopy
    Description
"symlink" -> InstallMethod -> m InstallMethod
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InstallMethod
InstallMethodSymlink
    Description
_ -> Description -> m InstallMethod
forall a. Description -> m a
forall (m :: * -> *) a. Parsing m => Description -> m a
P.unexpected (Description -> m InstallMethod) -> Description -> m InstallMethod
forall a b. (a -> b) -> a -> b
$ Description
"InstallMethod: " Description -> ShowS
forall a. [a] -> [a] -> [a]
++ Description
name