{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
module Distribution.Client.CmdInstall.ClientInstallFlags
( InstallMethod(..)
, ClientInstallFlags(..)
, defaultClientInstallFlags
, clientInstallOptions
) where

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

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

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