{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Cabal.Options (
  rejectUnsupportedOptions
, discardReplOptions

#ifdef TEST
, Option(..)
, pathOptions
, replOptions
, shouldReject
, Discard(..)
, shouldDiscard
#endif
) where

import           Imports

import           Data.List
import           System.Exit

import           Data.Set (Set)
import qualified Data.Set as Set

data Option = Option {
  Option -> [Char]
optionName :: String
, Option -> OptionArgument
_optionArgument :: OptionArgument
}

data OptionArgument = Argument | NoArgument

pathOptions :: [Option]
pathOptions :: [Option]
pathOptions = [
    [Char] -> OptionArgument -> Option
Option [Char]
"-z" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--ignore-project" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--output-format" OptionArgument
Argument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--compiler-info" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--cache-home" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--remote-repo-cache" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--logs-dir" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--store-dir" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--config-file" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--installdir" OptionArgument
NoArgument
  ]

replOptions :: [Option]
replOptions :: [Option]
replOptions = [
    [Char] -> OptionArgument -> Option
Option [Char]
"-z" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--ignore-project" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--repl-no-load" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--repl-options" OptionArgument
Argument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--repl-multi-file" OptionArgument
Argument
  , [Char] -> OptionArgument -> Option
Option [Char]
"-b" OptionArgument
Argument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--build-depends" OptionArgument
Argument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--no-transitive-deps" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--enable-multi-repl" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--disable-multi-repl" OptionArgument
NoArgument
  , [Char] -> OptionArgument -> Option
Option [Char]
"--keep-temp-files" OptionArgument
NoArgument
  ]

rejectUnsupportedOptions :: [String] -> IO ()
rejectUnsupportedOptions :: [[Char]] -> IO ()
rejectUnsupportedOptions = ([Char] -> IO ()) -> [[Char]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (([Char] -> IO ()) -> [[Char]] -> IO ())
-> ([Char] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$ \ [Char]
arg -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Char] -> Bool
shouldReject [Char]
arg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> IO ()
forall a. [Char] -> IO a
die [Char]
"Error: cabal: unrecognized 'doctest' option `--installdir'"

shouldReject :: String -> Bool
shouldReject :: [Char] -> Bool
shouldReject [Char]
arg =
     [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member [Char]
arg Set [Char]
rejectNames
  Bool -> Bool -> Bool
|| (([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
`any` [[Char]]
longOptionsWithArgument) ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
arg)
  where
    rejectNames :: Set String
    rejectNames :: Set [Char]
rejectNames = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList ((Option -> [Char]) -> [Option] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Option -> [Char]
optionName [Option]
pathOptions)

    longOptionsWithArgument :: [String]
    longOptionsWithArgument :: [[Char]]
longOptionsWithArgument = [[Char]
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"=" | Option name :: [Char]
name@(Char
'-':Char
'-':[Char]
_) OptionArgument
Argument <- [Option]
pathOptions]

discardReplOptions :: [String] -> [String]
discardReplOptions :: [[Char]] -> [[Char]]
discardReplOptions = [[Char]] -> [[Char]]
go
  where
    go :: [[Char]] -> [[Char]]
go = \ case
      [] -> []
      [Char]
arg : [[Char]]
args -> case [Char] -> Discard
shouldDiscard [Char]
arg of
        Discard
Keep -> [Char]
arg [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
go [[Char]]
args
        Discard
Discard -> [[Char]] -> [[Char]]
go [[Char]]
args
        Discard
DiscardWithArgument -> [[Char]] -> [[Char]]
go (Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop Int
1 [[Char]]
args)

data Discard = Keep | Discard | DiscardWithArgument
  deriving (Discard -> Discard -> Bool
(Discard -> Discard -> Bool)
-> (Discard -> Discard -> Bool) -> Eq Discard
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Discard -> Discard -> Bool
== :: Discard -> Discard -> Bool
$c/= :: Discard -> Discard -> Bool
/= :: Discard -> Discard -> Bool
Eq, Int -> Discard -> [Char] -> [Char]
[Discard] -> [Char] -> [Char]
Discard -> [Char]
(Int -> Discard -> [Char] -> [Char])
-> (Discard -> [Char])
-> ([Discard] -> [Char] -> [Char])
-> Show Discard
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Discard -> [Char] -> [Char]
showsPrec :: Int -> Discard -> [Char] -> [Char]
$cshow :: Discard -> [Char]
show :: Discard -> [Char]
$cshowList :: [Discard] -> [Char] -> [Char]
showList :: [Discard] -> [Char] -> [Char]
Show)

shouldDiscard :: String -> Discard
shouldDiscard :: [Char] -> Discard
shouldDiscard [Char]
arg
  | [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member [Char]
arg Set [Char]
flags = Discard
Discard
  | [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member [Char]
arg Set [Char]
options = Discard
DiscardWithArgument
  | Bool
isOptionWithArgument = Discard
Discard
  | Bool
otherwise = Discard
Keep
  where
    flags :: Set String
    flags :: Set [Char]
flags = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList [[Char]
name | Option [Char]
name OptionArgument
NoArgument <- [Option]
replOptions]

    options :: Set String
    options :: Set [Char]
options = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList ([[Char]]
longOptions [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
shortOptions)

    longOptions :: [String]
    longOptions :: [[Char]]
longOptions = [[Char]
name | Option name :: [Char]
name@(Char
'-':Char
'-':[Char]
_) OptionArgument
Argument <- [Option]
replOptions]

    shortOptions :: [String]
    shortOptions :: [[Char]]
shortOptions = [[Char]
name | Option name :: [Char]
name@[Char
'-', Char
_] OptionArgument
Argument <- [Option]
replOptions]

    isOptionWithArgument :: Bool
    isOptionWithArgument :: Bool
isOptionWithArgument = ([Char] -> Bool) -> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
arg) (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"=") [[Char]]
longOptions [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
shortOptions)