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

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

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

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

data ProjectFlags = ProjectFlags
  { ProjectFlags -> Flag FilePath
flagProjectDir :: Flag FilePath
  -- ^ The project directory.
  , ProjectFlags -> Flag FilePath
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.
  }
  deriving (Int -> ProjectFlags -> ShowS
[ProjectFlags] -> ShowS
ProjectFlags -> FilePath
(Int -> ProjectFlags -> ShowS)
-> (ProjectFlags -> FilePath)
-> ([ProjectFlags] -> ShowS)
-> Show ProjectFlags
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProjectFlags -> ShowS
showsPrec :: Int -> ProjectFlags -> ShowS
$cshow :: ProjectFlags -> FilePath
show :: ProjectFlags -> FilePath
$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 FilePath
flagProjectDir = Flag FilePath
forall a. Monoid a => a
mempty
    , flagProjectFile :: Flag FilePath
flagProjectFile = Flag FilePath
forall a. Monoid a => a
mempty
    , flagIgnoreProject :: Flag Bool
flagIgnoreProject = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False
    -- Should we use 'Last' here?
    }

projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]
projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]
projectFlagsOptions ShowOrParseArgs
showOrParseArgs =
  [ FilePath
-> LFlags
-> FilePath
-> (ProjectFlags -> Flag FilePath)
-> (Flag FilePath -> ProjectFlags -> ProjectFlags)
-> MkOptDescr
     (ProjectFlags -> Flag FilePath)
     (Flag FilePath -> ProjectFlags -> ProjectFlags)
     ProjectFlags
-> OptionField ProjectFlags
forall get set a.
FilePath
-> LFlags
-> FilePath
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [FilePath
"project-dir"]
      FilePath
"Set the path of the project directory"
      ProjectFlags -> Flag FilePath
flagProjectDir
      (\Flag FilePath
path ProjectFlags
flags -> ProjectFlags
flags{flagProjectDir = path})
      (FilePath
-> ReadE (Flag FilePath)
-> (Flag FilePath -> LFlags)
-> MkOptDescr
     (ProjectFlags -> Flag FilePath)
     (Flag FilePath -> ProjectFlags -> ProjectFlags)
     ProjectFlags
forall b a.
Monoid b =>
FilePath
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg FilePath
"DIR" ((FilePath -> Flag FilePath) -> ReadE (Flag FilePath)
forall a. (FilePath -> a) -> ReadE a
succeedReadE FilePath -> Flag FilePath
forall a. a -> Flag a
Flag) Flag FilePath -> LFlags
forall a. Flag a -> [a]
flagToList)
  , FilePath
-> LFlags
-> FilePath
-> (ProjectFlags -> Flag FilePath)
-> (Flag FilePath -> ProjectFlags -> ProjectFlags)
-> MkOptDescr
     (ProjectFlags -> Flag FilePath)
     (Flag FilePath -> ProjectFlags -> ProjectFlags)
     ProjectFlags
-> OptionField ProjectFlags
forall get set a.
FilePath
-> LFlags
-> FilePath
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      []
      [FilePath
"project-file"]
      FilePath
"Set the path of the cabal.project file (relative to the project directory when relative)"
      ProjectFlags -> Flag FilePath
flagProjectFile
      (\Flag FilePath
pf ProjectFlags
flags -> ProjectFlags
flags{flagProjectFile = pf})
      (FilePath
-> ReadE (Flag FilePath)
-> (Flag FilePath -> LFlags)
-> MkOptDescr
     (ProjectFlags -> Flag FilePath)
     (Flag FilePath -> ProjectFlags -> ProjectFlags)
     ProjectFlags
forall b a.
Monoid b =>
FilePath
-> ReadE b -> (b -> LFlags) -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg FilePath
"FILE" ((FilePath -> Flag FilePath) -> ReadE (Flag FilePath)
forall a. (FilePath -> a) -> ReadE a
succeedReadE FilePath -> Flag FilePath
forall a. a -> Flag a
Flag) Flag FilePath -> LFlags
forall a. Flag a -> [a]
flagToList)
  , FilePath
-> LFlags
-> FilePath
-> (ProjectFlags -> Flag Bool)
-> (Flag Bool -> ProjectFlags -> ProjectFlags)
-> MkOptDescr
     (ProjectFlags -> Flag Bool)
     (Flag Bool -> ProjectFlags -> ProjectFlags)
     ProjectFlags
-> OptionField ProjectFlags
forall get set a.
FilePath
-> LFlags
-> FilePath
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      [Char
'z']
      [FilePath
"ignore-project"]
      FilePath
"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 FilePath
flagProjectDir ProjectFlags
flags Flag FilePath -> Flag FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Flag FilePath
forall a. Flag a
NoFlag Bool -> Bool -> Bool
&& ProjectFlags -> Flag FilePath
flagProjectFile ProjectFlags
flags Flag FilePath -> Flag FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Flag FilePath
forall a. Flag 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)
  ]

-- | 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 -> FilePath
forall a. OptionField a -> FilePath
optionName OptionField a
o FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"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 FilePath
sf LFlags
lf = MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg FilePath
sf LFlags
lf
yesNoOpt ShowOrParseArgs
_ FilePath
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 (FilePath
sf, LFlags
lf) ([], ShowS -> LFlags -> LFlags
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"no-" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) LFlags
lf) FilePath
sf LFlags
lf