{-# LANGUAGE PatternSynonyms #-}

module Distribution.Client.ReplFlags (EnvFlags (..), ReplFlags (..), topReplOptions, multiReplOption, defaultReplFlags) where

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

import Distribution.Client.Setup
  ( liftOptions
  )
import Distribution.Parsec
  ( parsecCommaList
  )
import Distribution.ReadE
  ( ReadE
  , parsecToReadE
  )
import Distribution.Simple.Command
  ( OptionField
  , ShowOrParseArgs
  , liftOption
  , option
  , reqArg
  )
import Distribution.Simple.Setup
  ( Flag
  , ReplOptions (..)
  , boolOpt
  , falseArg
  , replOptions
  , toFlag
  , pattern NoFlag
  )
import Distribution.Types.Dependency
  ( Dependency (..)
  )

data EnvFlags = EnvFlags
  { EnvFlags -> [Dependency]
envPackages :: [Dependency]
  , EnvFlags -> Flag Bool
envIncludeTransitive :: Flag Bool
  }

instance Semigroup EnvFlags where
  (EnvFlags [Dependency]
a1 Flag Bool
a2) <> :: EnvFlags -> EnvFlags -> EnvFlags
<> (EnvFlags [Dependency]
b1 Flag Bool
b2) = [Dependency] -> Flag Bool -> EnvFlags
EnvFlags ([Dependency]
a1 [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> [Dependency]
b1) (Flag Bool
a2 Flag Bool -> Flag Bool -> Flag Bool
forall a. Semigroup a => a -> a -> a
<> Flag Bool
b2)

instance Monoid EnvFlags where
  mempty :: EnvFlags
mempty = EnvFlags
defaultEnvFlags

defaultEnvFlags :: EnvFlags
defaultEnvFlags :: EnvFlags
defaultEnvFlags =
  EnvFlags
    { envPackages :: [Dependency]
envPackages = []
    , envIncludeTransitive :: Flag Bool
envIncludeTransitive = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
True
    }

data ReplFlags = ReplFlags
  { ReplFlags -> ReplOptions
configureReplOptions :: ReplOptions
  , ReplFlags -> EnvFlags
replEnvFlags :: EnvFlags
  , ReplFlags -> Flag Bool
replUseMulti :: Flag Bool
  }

instance Semigroup ReplFlags where
  (ReplFlags ReplOptions
a1 EnvFlags
a2 Flag Bool
a3) <> :: ReplFlags -> ReplFlags -> ReplFlags
<> (ReplFlags ReplOptions
b1 EnvFlags
b2 Flag Bool
b3) = ReplOptions -> EnvFlags -> Flag Bool -> ReplFlags
ReplFlags (ReplOptions
a1 ReplOptions -> ReplOptions -> ReplOptions
forall a. Semigroup a => a -> a -> a
<> ReplOptions
b1) (EnvFlags
a2 EnvFlags -> EnvFlags -> EnvFlags
forall a. Semigroup a => a -> a -> a
<> EnvFlags
b2) (Flag Bool
a3 Flag Bool -> Flag Bool -> Flag Bool
forall a. Semigroup a => a -> a -> a
<> Flag Bool
b3)

instance Monoid ReplFlags where
  mempty :: ReplFlags
mempty = ReplFlags
defaultReplFlags

defaultReplFlags :: ReplFlags
defaultReplFlags :: ReplFlags
defaultReplFlags =
  ReplFlags
    { configureReplOptions :: ReplOptions
configureReplOptions = ReplOptions
forall a. Monoid a => a
mempty
    , replEnvFlags :: EnvFlags
replEnvFlags = EnvFlags
defaultEnvFlags
    , replUseMulti :: Flag Bool
replUseMulti = Flag Bool
forall a. Last a
NoFlag
    }

topReplOptions :: ShowOrParseArgs -> [OptionField ReplFlags]
topReplOptions :: ShowOrParseArgs -> [OptionField ReplFlags]
topReplOptions ShowOrParseArgs
showOrParseArgs =
  (ReplFlags -> ReplOptions)
-> (ReplOptions -> ReplFlags -> ReplFlags)
-> [OptionField ReplOptions]
-> [OptionField ReplFlags]
forall b a.
(b -> a) -> (a -> b -> b) -> [OptionField a] -> [OptionField b]
liftOptions ReplFlags -> ReplOptions
configureReplOptions ReplOptions -> ReplFlags -> ReplFlags
set1 (ShowOrParseArgs -> [OptionField ReplOptions]
replOptions ShowOrParseArgs
showOrParseArgs)
    [OptionField ReplFlags]
-> [OptionField ReplFlags] -> [OptionField ReplFlags]
forall a. [a] -> [a] -> [a]
++ (ReplFlags -> EnvFlags)
-> (EnvFlags -> ReplFlags -> ReplFlags)
-> [OptionField EnvFlags]
-> [OptionField ReplFlags]
forall b a.
(b -> a) -> (a -> b -> b) -> [OptionField a] -> [OptionField b]
liftOptions ReplFlags -> EnvFlags
replEnvFlags EnvFlags -> ReplFlags -> ReplFlags
set2 (ShowOrParseArgs -> [OptionField EnvFlags]
envOptions ShowOrParseArgs
showOrParseArgs)
    [OptionField ReplFlags]
-> [OptionField ReplFlags] -> [OptionField ReplFlags]
forall a. [a] -> [a] -> [a]
++ [ (ReplFlags -> Flag Bool)
-> (Flag Bool -> ReplFlags -> ReplFlags)
-> OptionField (Flag Bool)
-> OptionField ReplFlags
forall b a.
(b -> a) -> (a -> b -> b) -> OptionField a -> OptionField b
liftOption ReplFlags -> Flag Bool
replUseMulti Flag Bool -> ReplFlags -> ReplFlags
set3 OptionField (Flag Bool)
multiReplOption
       ]
  where
    set1 :: ReplOptions -> ReplFlags -> ReplFlags
set1 ReplOptions
a ReplFlags
x = ReplFlags
x{configureReplOptions = a}
    set2 :: EnvFlags -> ReplFlags -> ReplFlags
set2 EnvFlags
a ReplFlags
x = ReplFlags
x{replEnvFlags = a}
    set3 :: Flag Bool -> ReplFlags -> ReplFlags
set3 Flag Bool
a ReplFlags
x = ReplFlags
x{replUseMulti = a}

multiReplOption :: OptionField (Flag Bool)
multiReplOption :: OptionField (Flag Bool)
multiReplOption =
  SFlags
-> LFlags
-> SFlags
-> (Flag Bool -> Flag Bool)
-> (Flag Bool -> Flag Bool -> Flag Bool)
-> MkOptDescr
     (Flag Bool -> Flag Bool)
     (Flag Bool -> Flag Bool -> Flag Bool)
     (Flag Bool)
-> OptionField (Flag Bool)
forall get set a.
SFlags
-> LFlags
-> SFlags
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
    []
    [SFlags
"multi-repl"]
    SFlags
"multi-component repl sessions"
    Flag Bool -> Flag Bool
forall a. a -> a
id
    (\Flag Bool
v Flag Bool
_ -> Flag Bool
v)
    (SFlags
-> SFlags
-> MkOptDescr
     (Flag Bool -> Flag Bool)
     (Flag Bool -> Flag Bool -> Flag Bool)
     (Flag Bool)
forall a.
SFlags
-> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt [] [])

envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions ShowOrParseArgs
_ =
  [ SFlags
-> LFlags
-> SFlags
-> (EnvFlags -> [Dependency])
-> ([Dependency] -> EnvFlags -> EnvFlags)
-> MkOptDescr
     (EnvFlags -> [Dependency])
     ([Dependency] -> EnvFlags -> EnvFlags)
     EnvFlags
-> OptionField EnvFlags
forall get set a.
SFlags
-> LFlags
-> SFlags
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      [Char
'b']
      [SFlags
"build-depends"]
      SFlags
"Include additional packages in the environment presented to GHCi."
      EnvFlags -> [Dependency]
envPackages
      (\[Dependency]
p EnvFlags
flags -> EnvFlags
flags{envPackages = p ++ envPackages flags})
      (SFlags
-> ReadE [Dependency]
-> ([Dependency] -> LFlags)
-> MkOptDescr
     (EnvFlags -> [Dependency])
     ([Dependency] -> EnvFlags -> EnvFlags)
     EnvFlags
forall b a.
Monoid b =>
SFlags
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg SFlags
"DEPENDENCIES" ReadE [Dependency]
dependenciesReadE ((Dependency -> SFlags) -> [Dependency] -> LFlags
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dependency -> SFlags
forall a. Pretty a => a -> SFlags
prettyShow :: [Dependency] -> [String]))
  , SFlags
-> LFlags
-> SFlags
-> (EnvFlags -> Flag Bool)
-> (Flag Bool -> EnvFlags -> EnvFlags)
-> MkOptDescr
     (EnvFlags -> Flag Bool)
     (Flag Bool -> EnvFlags -> EnvFlags)
     EnvFlags
-> OptionField EnvFlags
forall get set a.
SFlags
-> LFlags
-> SFlags
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [SFlags
"no-transitive-deps"]
      SFlags
"Don't automatically include transitive dependencies of requested packages."
      EnvFlags -> Flag Bool
envIncludeTransitive
      (\Flag Bool
p EnvFlags
flags -> EnvFlags
flags{envIncludeTransitive = p})
      MkOptDescr
  (EnvFlags -> Flag Bool)
  (Flag Bool -> EnvFlags -> EnvFlags)
  EnvFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
falseArg
  ]
  where
    dependenciesReadE :: ReadE [Dependency]
    dependenciesReadE :: ReadE [Dependency]
dependenciesReadE =
      (SFlags -> SFlags)
-> ParsecParser [Dependency] -> ReadE [Dependency]
forall a. (SFlags -> SFlags) -> ParsecParser a -> ReadE a
parsecToReadE
        (SFlags
"couldn't parse dependencies: " SFlags -> SFlags -> SFlags
forall a. [a] -> [a] -> [a]
++)
        (ParsecParser Dependency -> ParsecParser [Dependency]
forall (m :: * -> *) a. CabalParsing m => m a -> m [a]
parsecCommaList ParsecParser Dependency
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m Dependency
parsec)