cabal-install/src/Distribution/Client/ProjectFlags.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3
   4 module Distribution.Client.ProjectFlags
   5   ( ProjectFlags (..)
   6   , defaultProjectFlags
   7   , projectFlagsOptions
   8   , removeIgnoreProjectOption
   9   ) where
  10
  11 import Distribution.Client.Compat.Prelude
  12 import Prelude ()
  13
  14 import Distribution.ReadE (succeedReadE)
  15 import Distribution.Simple.Command
  16   ( MkOptDescr
  17   , OptionField (optionName)
  18   , ShowOrParseArgs (..)
  19   , boolOpt'
  20   , option
  21   , reqArg
  22   )
  23 import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)
  24
  25 data ProjectFlags = ProjectFlags
  26   { flagProjectDir :: Flag FilePath
  27   -- ^ The project directory.
  28   , flagProjectFile :: Flag FilePath
  29   -- ^ The cabal project file path; defaults to @cabal.project@.
  30   -- This path, when relative, is relative to the project directory.
  31   -- The filename portion of the path denotes the cabal project file name, but it also
  32   -- is the base of auxiliary project files, such as
  33   -- @cabal.project.local@ and @cabal.project.freeze@ which are also
  34   -- read and written out in some cases.
  35   -- If a project directory was not specified, and the path is not found
  36   -- in the current working directory, we will successively probe
  37   -- relative to parent directories until this name is found.
  38   , flagIgnoreProject :: Flag Bool
  39   -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)
  40   -- The exact interpretation might be slightly different per command.
  41   }
  42   deriving (Show, Generic)
  43
  44 defaultProjectFlags :: ProjectFlags
  45 defaultProjectFlags =
  46   ProjectFlags
  47     { flagProjectDir = mempty
  48     , flagProjectFile = mempty
  49     , flagIgnoreProject = toFlag False
  50     -- Should we use 'Last' here?
  51     }
  52
  53 projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]
  54 projectFlagsOptions showOrParseArgs =
  55   [ option
  56       []
  57       ["project-dir"]
  58       "Set the path of the project directory"
  59       flagProjectDir
  60       (\path flags -> flags{flagProjectDir = path})
  61       (reqArg "DIR" (succeedReadE Flag) flagToList)
  62   , option
  63       []
  64       ["project-file"]
  65       "Set the path of the cabal.project file (relative to the project directory when relative)"
  66       flagProjectFile
  67       (\pf flags -> flags{flagProjectFile = pf})
  68       (reqArg "FILE" (succeedReadE Flag) flagToList)
  69   , option
  70       ['z']
  71       ["ignore-project"]
  72       "Ignore local project configuration (unless --project-dir or --project-file is also set)"
  73       flagIgnoreProject
  74       ( \v flags ->
  75           flags
  76             { flagIgnoreProject = case v of
  77                 Flag True -> toFlag (flagProjectDir flags == NoFlag && flagProjectFile flags == NoFlag)
  78                 _ -> v
  79             }
  80       )
  81       (yesNoOpt showOrParseArgs)
  82   ]
  83
  84 -- | As almost all commands use 'ProjectFlags' but not all can honour
  85 -- "ignore-project" flag, provide this utility to remove the flag
  86 -- parsing from the help message.
  87 removeIgnoreProjectOption :: [OptionField a] -> [OptionField a]
  88 removeIgnoreProjectOption = filter (\o -> optionName o /= "ignore-project")
  89
  90 instance Monoid ProjectFlags where
  91   mempty = gmempty
  92   mappend = (<>)
  93
  94 instance Semigroup ProjectFlags where
  95   (<>) = gmappend
  96
  97 yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
  98 yesNoOpt ShowArgs sf lf = trueArg sf lf
  99 yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf