{-# 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)