{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

module Distribution.Client.ProjectFlags
  ( ProjectFlags (..)
  , defaultProjectFlags
  , projectFlagsOptions
  , removeIgnoreProjectOption
  ) where

import Distribution.Client.Compat.Prelude
import Distribution.Client.ProjectConfig.Types (ProjectFileParser (..), defaultProjectFileParser)
import Prelude ()

import Distribution.ReadE (ReadE (..), succeedReadE)
import Distribution.Simple.Command
  ( MkOptDescr
  , OptionField (optionName)
  , ShowOrParseArgs (..)
  , boolOpt'
  , option
  , reqArg
  )
import Distribution.Simple.Setup
  ( Flag
  , flagToList
  , flagToMaybe
  , toFlag
  , trueArg
  , pattern Flag
  , pattern NoFlag
  )

data ProjectFlags = ProjectFlags
  { ProjectFlags -> Flag String
flagProjectDir :: Flag FilePath
  -- ^ The project directory.
  , ProjectFlags -> Flag String
flagProjectFile :: Flag FilePath
  -- ^ The cabal project file path; defaults to @cabal.project@.
  -- This path, when relative, is relative to the project directory.
  -- The filename portion of the path denotes the cabal project file name, but it also
  -- is the base of auxiliary project files, such as
  -- @cabal.project.local@ and @cabal.project.freeze@ which are also
  -- read and written out in some cases.
  -- If a project directory was not specified, and the path is not found
  -- in the current working directory, we will successively probe
  -- relative to parent directories until this name is found.
  , ProjectFlags -> Flag Bool
flagIgnoreProject :: Flag Bool
  -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)
  -- The exact interpretation might be slightly different per command.
  , ProjectFlags -> Flag ProjectFileParser
flagProjectFileParser :: Flag ProjectFileParser
  -- ^ The parser to use for the project file.
  }
  deriving (Int -> ProjectFlags -> ShowS
[ProjectFlags] -> ShowS
ProjectFlags -> String
(Int -> ProjectFlags -> ShowS)
-> (ProjectFlags -> String)
-> ([ProjectFlags] -> ShowS)
-> Show ProjectFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProjectFlags -> ShowS
showsPrec :: Int -> ProjectFlags -> ShowS
$cshow :: ProjectFlags -> String
show :: ProjectFlags -> String
$cshowList :: [ProjectFlags] -> ShowS
showList :: [ProjectFlags] -> ShowS
Show, (forall x. ProjectFlags -> Rep ProjectFlags x)
-> (forall x. Rep ProjectFlags x -> ProjectFlags)
-> Generic ProjectFlags
forall x. Rep ProjectFlags x -> ProjectFlags
forall x. ProjectFlags -> Rep ProjectFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ProjectFlags -> Rep ProjectFlags x
from :: forall x. ProjectFlags -> Rep ProjectFlags x
$cto :: forall x. Rep ProjectFlags x -> ProjectFlags
to :: forall x. Rep ProjectFlags x -> ProjectFlags
Generic)

defaultProjectFlags :: ProjectFlags
defaultProjectFlags :: ProjectFlags
defaultProjectFlags =
  ProjectFlags
    { flagProjectDir :: Flag String
flagProjectDir = Flag String
forall a. Monoid a => a
mempty
    , flagProjectFile :: Flag String
flagProjectFile = Flag String
forall a. Monoid a => a
mempty
    , flagIgnoreProject :: Flag Bool
flagIgnoreProject = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False
    , flagProjectFileParser :: Flag ProjectFileParser
flagProjectFileParser = Flag ProjectFileParser
forall a. Monoid a => a
mempty
    }

projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]
projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]
projectFlagsOptions ShowOrParseArgs
showOrParseArgs =
  [ String
-> LFlags
-> String
-> (ProjectFlags -> Flag String)
-> (Flag String -> ProjectFlags -> ProjectFlags)
-> MkOptDescr
     (ProjectFlags -> Flag String)
     (Flag String -> ProjectFlags -> ProjectFlags)
     ProjectFlags
-> OptionField ProjectFlags
forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [String
"project-dir"]
      String
"Set the path of the project directory"
      ProjectFlags -> Flag String
flagProjectDir
      (\Flag String
path ProjectFlags
flags -> ProjectFlags
flags{flagProjectDir = path})
      (String
-> ReadE (Flag String)
-> (Flag String -> LFlags)
-> MkOptDescr
     (ProjectFlags -> Flag String)
     (Flag String -> ProjectFlags -> ProjectFlags)
     ProjectFlags
forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
"DIR" ((String -> Flag String) -> ReadE (Flag String)
forall a. (String -> a) -> ReadE a
succeedReadE String -> Flag String
forall a. a -> Flag a
Flag) Flag String -> LFlags
forall a. Flag a -> [a]
flagToList)
  , String
-> LFlags
-> String
-> (ProjectFlags -> Flag String)
-> (Flag String -> ProjectFlags -> ProjectFlags)
-> MkOptDescr
     (ProjectFlags -> Flag String)
     (Flag String -> ProjectFlags -> ProjectFlags)
     ProjectFlags
-> OptionField ProjectFlags
forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [String
"project-file"]
      String
"Set the path of the cabal.project file (relative to the project directory when relative)"
      ProjectFlags -> Flag String
flagProjectFile
      (\Flag String
pf ProjectFlags
flags -> ProjectFlags
flags{flagProjectFile = pf})
      (String
-> ReadE (Flag String)
-> (Flag String -> LFlags)
-> MkOptDescr
     (ProjectFlags -> Flag String)
     (Flag String -> ProjectFlags -> ProjectFlags)
     ProjectFlags
forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
"FILE" ((String -> Flag String) -> ReadE (Flag String)
forall a. (String -> a) -> ReadE a
succeedReadE String -> Flag String
forall a. a -> Flag a
Flag) Flag String -> LFlags
forall a. Flag a -> [a]
flagToList)
  , String
-> LFlags
-> String
-> (ProjectFlags -> Flag Bool)
-> (Flag Bool -> ProjectFlags -> ProjectFlags)
-> MkOptDescr
     (ProjectFlags -> Flag Bool)
     (Flag Bool -> ProjectFlags -> ProjectFlags)
     ProjectFlags
-> OptionField ProjectFlags
forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      [Char
'z']
      [String
"ignore-project"]
      String
"Ignore local project configuration (unless --project-dir or --project-file is also set)"
      ProjectFlags -> Flag Bool
flagIgnoreProject
      ( \Flag Bool
v ProjectFlags
flags ->
          ProjectFlags
flags
            { flagIgnoreProject = case v of
                Flag Bool
True -> Bool -> Flag Bool
forall a. a -> Flag a
toFlag (ProjectFlags -> Flag String
flagProjectDir ProjectFlags
flags Flag String -> Flag String -> Bool
forall a. Eq a => a -> a -> Bool
== Flag String
forall a. Last a
NoFlag Bool -> Bool -> Bool
&& ProjectFlags -> Flag String
flagProjectFile ProjectFlags
flags Flag String -> Flag String -> Bool
forall a. Eq a => a -> a -> Bool
== Flag String
forall a. Last a
NoFlag)
                Flag Bool
_ -> Flag Bool
v
            }
      )
      (ShowOrParseArgs
-> MkOptDescr
     (ProjectFlags -> Flag Bool)
     (Flag Bool -> ProjectFlags -> ProjectFlags)
     ProjectFlags
forall b.
ShowOrParseArgs
-> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
yesNoOpt ShowOrParseArgs
showOrParseArgs)
  , String
-> LFlags
-> String
-> (ProjectFlags -> Flag ProjectFileParser)
-> (Flag ProjectFileParser -> ProjectFlags -> ProjectFlags)
-> MkOptDescr
     (ProjectFlags -> Flag ProjectFileParser)
     (Flag ProjectFileParser -> ProjectFlags -> ProjectFlags)
     ProjectFlags
-> OptionField ProjectFlags
forall get set a.
String
-> LFlags
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [String
"project-file-parser"]
      String
"Set the parser to use for the project file"
      ProjectFlags -> Flag ProjectFileParser
flagProjectFileParser
      (\Flag ProjectFileParser
pf ProjectFlags
flags -> ProjectFlags
flags{flagProjectFileParser = pf})
      (String
-> ReadE (Flag ProjectFileParser)
-> (Flag ProjectFileParser -> LFlags)
-> MkOptDescr
     (ProjectFlags -> Flag ProjectFileParser)
     (Flag ProjectFileParser -> ProjectFlags -> ProjectFlags)
     ProjectFlags
forall b a.
Monoid b =>
String
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
"PARSER" ((ProjectFileParser -> Flag ProjectFileParser)
-> ReadE ProjectFileParser -> ReadE (Flag ProjectFileParser)
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectFileParser -> Flag ProjectFileParser
forall a. a -> Flag a
Flag (ReadE ProjectFileParser -> ReadE (Flag ProjectFileParser))
-> ReadE ProjectFileParser -> ReadE (Flag ProjectFileParser)
forall a b. (a -> b) -> a -> b
$ (String -> Either String ProjectFileParser)
-> ReadE ProjectFileParser
forall a. (String -> Either String a) -> ReadE a
ReadE String -> Either String ProjectFileParser
parseProjectFileParser) Flag ProjectFileParser -> LFlags
projectFileParserPrinter)
  ]

parseProjectFileParser :: String -> Either String ProjectFileParser
parseProjectFileParser :: String -> Either String ProjectFileParser
parseProjectFileParser String
"legacy" = ProjectFileParser -> Either String ProjectFileParser
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectFileParser
LegacyParser
parseProjectFileParser String
"fallback" = ProjectFileParser -> Either String ProjectFileParser
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectFileParser
FallbackParser
parseProjectFileParser String
"default" = ProjectFileParser -> Either String ProjectFileParser
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectFileParser
defaultProjectFileParser
parseProjectFileParser String
"parsec" = ProjectFileParser -> Either String ProjectFileParser
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectFileParser
ParsecParser
parseProjectFileParser String
"compare" = ProjectFileParser -> Either String ProjectFileParser
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectFileParser
CompareParser
parseProjectFileParser String
_ = String -> Either String ProjectFileParser
forall a b. a -> Either a b
Left String
"Invalid project file parser"

projectFileParserPrinter :: Flag ProjectFileParser -> [String]
projectFileParserPrinter :: Flag ProjectFileParser -> LFlags
projectFileParserPrinter (Flag ProjectFileParser
parser) =
  case ProjectFileParser
parser of
    ProjectFileParser
LegacyParser -> [String
"legacy"]
    ProjectFileParser
FallbackParser -> [String
"fallback"]
    ProjectFileParser
ParsecParser -> [String
"parsec"]
    ProjectFileParser
CompareParser -> [String
"compare"]
projectFileParserPrinter Flag ProjectFileParser
NoFlag = []

-- | As almost all commands use 'ProjectFlags' but not all can honour
-- "ignore-project" flag, provide this utility to remove the flag
-- parsing from the help message.
removeIgnoreProjectOption :: [OptionField a] -> [OptionField a]
removeIgnoreProjectOption :: forall a. [OptionField a] -> [OptionField a]
removeIgnoreProjectOption = (OptionField a -> Bool) -> [OptionField a] -> [OptionField a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\OptionField a
o -> OptionField a -> String
forall a. OptionField a -> String
optionName OptionField a
o String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"ignore-project")

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

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

yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
yesNoOpt :: forall b.
ShowOrParseArgs
-> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
yesNoOpt ShowOrParseArgs
ShowArgs String
sf LFlags
lf = MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg String
sf LFlags
lf
yesNoOpt ShowOrParseArgs
_ String
sf LFlags
lf = (Flag Bool -> Maybe Bool)
-> (Bool -> Flag Bool)
-> OptFlags
-> OptFlags
-> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
forall b a.
(b -> Maybe Bool)
-> (Bool -> b)
-> OptFlags
-> OptFlags
-> MkOptDescr (a -> b) (b -> a -> a) a
boolOpt' Flag Bool -> Maybe Bool
forall a. Flag a -> Maybe a
flagToMaybe Bool -> Flag Bool
forall a. a -> Flag a
Flag (String
sf, LFlags
lf) ([], ShowS -> LFlags -> LFlags
forall a b. (a -> b) -> [a] -> [b]
map (String
"no-" String -> ShowS
forall a. [a] -> [a] -> [a]
++) LFlags
lf) String
sf LFlags
lf