diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,49 @@ +# getopt-generics + +## Status + +This library is experimental. + +## Usage + +`getopt-generics` tries to make it very simple to create command line +interfaces. Here's an example: + + + +``` haskell +import WithCli + +main :: IO () +main = withCli run + +run :: String -> Int -> Bool -> IO () +run s i b = print (s, i, b) +``` + + + +This is how the program behaves in a shell: + + + +``` shell +$ program foo 42 true +("foo",42,True) +$ program --help +program [OPTIONS] STRING INTEGER BOOL + -h --help show help and exit +$ program foo 42 bar +cannot parse as BOOL: bar +# exit-code 1 +$ program +missing argument of type STRING +missing argument of type INTEGER +missing argument of type BOOL +# exit-code 1 +$ program foo 42 yes bar +unknown argument: bar +# exit-code 1 +``` + + diff --git a/docs/CustomOption.hs b/docs/CustomOption.hs new file mode 100644 --- /dev/null +++ b/docs/CustomOption.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module CustomOption where + +import WithCli + +data File = File FilePath + deriving (Show, Typeable) + +instance Argument File where + argumentType Proxy = "custom-file-type" + parseArgument f = Just (File f) + +instance HasArguments File where + argumentsParser = atomicArgumentsParser + +main :: IO () +main = withCli run + +run :: File -> IO () +run = print diff --git a/docs/CustomOption.shell-protocol b/docs/CustomOption.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/CustomOption.shell-protocol @@ -0,0 +1,5 @@ +$ program --help +program [OPTIONS] custom-file-type + -h --help show help and exit +$ program some/file +File "some/file" diff --git a/docs/CustomOptionRecord.hs b/docs/CustomOptionRecord.hs new file mode 100644 --- /dev/null +++ b/docs/CustomOptionRecord.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + +module CustomOptionRecord where + +import qualified GHC.Generics +import WithCli + +data File = File FilePath + deriving (Show, Typeable) + +instance Argument File where + argumentType Proxy = "custom-file-type" + parseArgument f = Just (File f) + +data Options + = Options { + file :: File + } + deriving (Show, GHC.Generics.Generic) + +instance Generic Options +instance HasDatatypeInfo Options +instance HasArguments Options +instance HasArguments File where + argumentsParser = atomicArgumentsParser + +main :: IO () +main = withCli run + +run :: Options -> IO () +run = print diff --git a/docs/CustomOptionRecord.shell-protocol b/docs/CustomOptionRecord.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/CustomOptionRecord.shell-protocol @@ -0,0 +1,6 @@ +$ program --file some/file +Options {file = File "some/file"} +$ program --help +program [OPTIONS] + --file=custom-file-type + -h --help show help and exit diff --git a/docs/CustomOptionsExample.bash-protocol b/docs/CustomOptionsExample.bash-protocol deleted file mode 100644 --- a/docs/CustomOptionsExample.bash-protocol +++ /dev/null @@ -1,5 +0,0 @@ -$ program some/file -File "some/file" -$ program --help -program [OPTIONS] custom-file-type - -h --help show help and exit diff --git a/docs/CustomOptionsExample.hs b/docs/CustomOptionsExample.hs deleted file mode 100644 --- a/docs/CustomOptionsExample.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -import Data.Typeable -import System.Console.GetOpt.Generics - -data File = File FilePath - deriving (Show, Typeable) - -instance Option File where - argumentType Proxy = "custom-file-type" - parseArgument f = Just (File f) - -main :: IO () -main = simpleCLI $ \ file -> do - print (file :: File) diff --git a/docs/Example.hs b/docs/Example.hs deleted file mode 100644 --- a/docs/Example.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -import qualified GHC.Generics -import System.Console.GetOpt.Generics - --- we specify a data type that maps to the commandline arguments - -data Foo - = Foo { - bar :: String - , baz :: Maybe String - , qux :: Int - } - deriving (Eq, Show, GHC.Generics.Generic) - -instance Generic Foo -instance HasDatatypeInfo Foo - --- give it go - -main :: IO () -main = do - myFoo <- getArguments - print $ bar myFoo - print $ baz myFoo - print $ qux myFoo diff --git a/docs/RecordType.hs b/docs/RecordType.hs new file mode 100644 --- /dev/null +++ b/docs/RecordType.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} + +module RecordType where + +import qualified GHC.Generics +import System.Console.GetOpt.Generics + +-- All you have to do is to define a type and derive some instances: + +data Options + = Options { + port :: Int, + daemonize :: Bool, + config :: Maybe FilePath + } + deriving (Show, GHC.Generics.Generic) + +instance Generic Options +instance HasDatatypeInfo Options + +-- Then you can use `getArguments` to create a command-line argument parser: + +main :: IO () +main = do + options <- getArguments + print (options :: Options) diff --git a/docs/RecordType.shell-protocol b/docs/RecordType.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/RecordType.shell-protocol @@ -0,0 +1,16 @@ +$ program --port 8080 --config some/path +Options {port = 8080, daemonize = False, config = Just "some/path"} +$ program --port 8080 --daemonize +Options {port = 8080, daemonize = True, config = Nothing} +$ program --port foo +cannot parse as INTEGER: foo +# exit-code 1 +$ program +missing option: --port=INTEGER +# exit-code 1 +$ program --help +program [OPTIONS] + --port=INTEGER + --daemonize + --config=STRING (optional) + -h --help show help and exit diff --git a/docs/RecordTypeExample.bash-protocol b/docs/RecordTypeExample.bash-protocol deleted file mode 100644 --- a/docs/RecordTypeExample.bash-protocol +++ /dev/null @@ -1,14 +0,0 @@ -$ program --port 8080 --config some/path -Options {port = 8080, daemonize = False, config = Just "some/path"} -$ program --port 8080 --daemonize -Options {port = 8080, daemonize = True, config = Nothing} -$ program --port foo -cannot parse as INTEGER: foo -$ program -missing option: --port=INTEGER -$ program --help -program [OPTIONS] - --port=INTEGER - --daemonize - --config=STRING (optional) - -h --help show help and exit diff --git a/docs/RecordTypeExample.hs b/docs/RecordTypeExample.hs deleted file mode 100644 --- a/docs/RecordTypeExample.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -import GHC.Generics -import System.Console.GetOpt.Generics - --- All you have to do is to define a type and derive some instances: - -data Options - = Options { - port :: Int, - daemonize :: Bool, - config :: Maybe FilePath - } - deriving (Show, GHC.Generics.Generic) - -instance System.Console.GetOpt.Generics.Generic Options -instance HasDatatypeInfo Options - --- Then you can use `getArguments` to create a command-line argument parser: - -main :: IO () -main = do - options <- getArguments - print (options :: Options) diff --git a/docs/Simple.hs b/docs/Simple.hs new file mode 100644 --- /dev/null +++ b/docs/Simple.hs @@ -0,0 +1,9 @@ +module Simple where + +import WithCli + +main :: IO () +main = withCli run + +run :: String -> Int -> Bool -> IO () +run s i b = print (s, i, b) diff --git a/docs/Simple.shell-protocol b/docs/Simple.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/Simple.shell-protocol @@ -0,0 +1,16 @@ +$ program foo 42 true +("foo",42,True) +$ program --help +program [OPTIONS] STRING INTEGER BOOL + -h --help show help and exit +$ program foo 42 bar +cannot parse as BOOL: bar +# exit-code 1 +$ program +missing argument of type STRING +missing argument of type INTEGER +missing argument of type BOOL +# exit-code 1 +$ program foo 42 yes bar +unknown argument: bar +# exit-code 1 diff --git a/docs/SimpleExample.bash-protocol b/docs/SimpleExample.bash-protocol deleted file mode 100644 --- a/docs/SimpleExample.bash-protocol +++ /dev/null @@ -1,7 +0,0 @@ -$ program foo 42 true -("foo",42,True) -$ program foo 42 bar -cannot parse as BOOL: bar -$ program --help -program [OPTIONS] STRING INTEGER BOOL - -h --help show help and exit diff --git a/docs/SimpleExample.hs b/docs/SimpleExample.hs deleted file mode 100644 --- a/docs/SimpleExample.hs +++ /dev/null @@ -1,7 +0,0 @@ -import System.Console.GetOpt.Generics - -main :: IO () -main = simpleCLI myMain - -myMain :: String -> Int -> Bool -> IO () -myMain s i b = print (s, i, b) diff --git a/docs/SimpleRecord.hs b/docs/SimpleRecord.hs new file mode 100644 --- /dev/null +++ b/docs/SimpleRecord.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SimpleRecord where + +import qualified GHC.Generics +import System.Console.GetOpt.Generics + +data Options + = Options { + port :: Int, + daemonize :: Bool, + config :: Maybe FilePath + } + deriving (Show, GHC.Generics.Generic) + +instance Generic Options +instance HasDatatypeInfo Options +instance HasArguments Options + +main :: IO () +main = withCli run + +run :: Options -> IO () +run = print diff --git a/docs/SimpleRecord.shell-protocol b/docs/SimpleRecord.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/SimpleRecord.shell-protocol @@ -0,0 +1,16 @@ +$ program --port 8080 --config some/path +Options {port = 8080, daemonize = False, config = Just "some/path"} +$ program --port 8080 --daemonize +Options {port = 8080, daemonize = True, config = Nothing} +$ program --port foo +cannot parse as INTEGER: foo +# exit-code 1 +$ program +missing option: --port=INTEGER +# exit-code 1 +$ program --help +program [OPTIONS] + --port=INTEGER + --daemonize + --config=STRING (optional) + -h --help show help and exit diff --git a/docs/Test01.hs b/docs/Test01.hs new file mode 100644 --- /dev/null +++ b/docs/Test01.hs @@ -0,0 +1,10 @@ + +module Test01 where + +import WithCli + +main :: IO () +main = withCli run + +run :: Int -> Bool -> IO () +run = curry print diff --git a/docs/Test01.shell-protocol b/docs/Test01.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/Test01.shell-protocol @@ -0,0 +1,7 @@ +$ program 42 +missing argument of type BOOL +# exit-code 1 +$ program +missing argument of type INTEGER +missing argument of type BOOL +# exit-code 1 diff --git a/docs/Test02.hs b/docs/Test02.hs new file mode 100644 --- /dev/null +++ b/docs/Test02.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + +module Test02 where + +import qualified GHC.Generics +import WithCli + +data Options + = Options { + port :: Int, + daemonize :: Bool, + config :: Maybe FilePath, + args :: [String] + } + deriving (Show, GHC.Generics.Generic) + +instance Generic Options +instance HasDatatypeInfo Options +instance HasArguments Options + +main :: IO () +main = withCli run + +run :: Options -> IO () +run = print diff --git a/docs/Test02.shell-protocol b/docs/Test02.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/Test02.shell-protocol @@ -0,0 +1,21 @@ +$ program --port 8080 --config some/path +Options {port = 8080, daemonize = False, config = Just "some/path", args = []} +$ program --port 8080 --config some/path --foo true +unrecognized option `--foo' +unknown argument: true +# exit-code 1 +$ program --port 8080 --daemonize --config some +Options {port = 8080, daemonize = True, config = Just "some", args = []} +$ program --port foo +cannot parse as INTEGER: foo +# exit-code 1 +$ program +missing option: --port=INTEGER +# exit-code 1 +$ program --help +program [OPTIONS] + --port=INTEGER + --daemonize + --config=STRING (optional) + --args=STRING (multiple possible) + -h --help show help and exit diff --git a/docs/Test03.hs b/docs/Test03.hs new file mode 100644 --- /dev/null +++ b/docs/Test03.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module Test03 where + +import qualified GHC.Generics +import WithCli + +main :: IO () +main = withCli run + +run :: (A, B) -> IO () +run options = do + print (options :: (A, B)) + +data A + = A { + aa :: String + } + deriving (Show, GHC.Generics.Generic) + +instance Generic A +instance HasDatatypeInfo A +instance HasArguments A + +data B + = B { + bb :: String + } + deriving (Show, GHC.Generics.Generic) + +instance Generic B +instance HasDatatypeInfo B +instance HasArguments B diff --git a/docs/Test03.shell-protocol b/docs/Test03.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/Test03.shell-protocol @@ -0,0 +1,7 @@ +$ program --aa foo --bb bar +(A {aa = "foo"},B {bb = "bar"}) +$ program --help +program [OPTIONS] + --aa=STRING + --bb=STRING + -h --help show help and exit diff --git a/docs/Test04.hs b/docs/Test04.hs new file mode 100644 --- /dev/null +++ b/docs/Test04.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} + +module Test04 where + +import qualified GHC.Generics +import WithCli + +main :: IO () +main = withCli run + +run :: A -> B -> IO () +run a b = do + print (a, b) + +data A + = A { + aa :: String + } + deriving (Show, GHC.Generics.Generic) + +instance Generic A +instance HasDatatypeInfo A +instance HasArguments A + +data B + = B { + bb :: String + } + deriving (Show, GHC.Generics.Generic) + +instance Generic B +instance HasDatatypeInfo B +instance HasArguments B diff --git a/docs/Test04.shell-protocol b/docs/Test04.shell-protocol new file mode 100644 --- /dev/null +++ b/docs/Test04.shell-protocol @@ -0,0 +1,7 @@ +$ program --aa foo --bb bar +(A {aa = "foo"},B {bb = "bar"}) +$ program --help +program [OPTIONS] + --aa=STRING + --bb=STRING + -h --help show help and exit diff --git a/getopt-generics.cabal b/getopt-generics.cabal --- a/getopt-generics.cabal +++ b/getopt-generics.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: getopt-generics -version: 0.10.0.1 +version: 0.11 synopsis: Create command line interfaces with ease description: Create command line interfaces with ease category: Console, System @@ -18,13 +18,25 @@ cabal-version: >= 1.10 extra-source-files: - docs/CustomOptionsExample.bash-protocol - docs/CustomOptionsExample.hs - docs/Example.hs - docs/RecordTypeExample.bash-protocol - docs/RecordTypeExample.hs - docs/SimpleExample.bash-protocol - docs/SimpleExample.hs + docs/CustomOption.hs + docs/CustomOption.shell-protocol + docs/CustomOptionRecord.hs + docs/CustomOptionRecord.shell-protocol + docs/RecordType.hs + docs/RecordType.shell-protocol + docs/Simple.hs + docs/Simple.shell-protocol + docs/SimpleRecord.hs + docs/SimpleRecord.shell-protocol + docs/Test01.hs + docs/Test01.shell-protocol + docs/Test02.hs + docs/Test02.shell-protocol + docs/Test03.hs + docs/Test03.shell-protocol + docs/Test04.hs + docs/Test04.shell-protocol + README.md source-repository head type: git @@ -41,45 +53,17 @@ , generics-sop , tagged exposed-modules: + WithCli System.Console.GetOpt.Generics other-modules: - System.Console.GetOpt.Generics.FieldString - System.Console.GetOpt.Generics.GetArguments System.Console.GetOpt.Generics.Modifier - System.Console.GetOpt.Generics.Result - System.Console.GetOpt.Generics.Simple - default-language: Haskell2010 - -test-suite examples - type: exitcode-stdio-1.0 - main-is: Examples.hs - hs-source-dirs: - test - ghc-options: -Wall -fno-warn-name-shadowing -threaded -O0 - build-depends: - base == 4.* - , base-compat >= 0.8 - , base-orphans - , generics-sop - , tagged - , hspec >= 2.1.8 - , temporary - , directory - , filepath - , process - , silently - other-modules: - BashProtocol - ModifiersSpec - ModifiersSpec.RenameOptionsSpec - ModifiersSpec.UseForPositionalArgumentsSpec - Spec - System.Console.GetOpt.Generics.FieldStringSpec - System.Console.GetOpt.Generics.ModifierSpec - System.Console.GetOpt.Generics.ResultSpec - System.Console.GetOpt.Generics.SimpleSpec - System.Console.GetOpt.GenericsSpec - Util + System.Console.GetOpt.Generics.Modifier.Types + WithCli.Argument + WithCli.Flag + WithCli.HasArguments + WithCli.Normalize + WithCli.Parser + WithCli.Result default-language: Haskell2010 test-suite spec @@ -88,6 +72,7 @@ hs-source-dirs: src , test + , docs ghc-options: -Wall -fno-warn-name-shadowing -threaded -O0 build-depends: base == 4.* @@ -98,22 +83,40 @@ , hspec >= 2.1.8 , QuickCheck , silently + , filepath + , safe other-modules: System.Console.GetOpt.Generics - System.Console.GetOpt.Generics.FieldString - System.Console.GetOpt.Generics.GetArguments System.Console.GetOpt.Generics.Modifier - System.Console.GetOpt.Generics.Result - System.Console.GetOpt.Generics.Simple - BashProtocol - Examples + System.Console.GetOpt.Generics.Modifier.Types + WithCli + WithCli.Argument + WithCli.Flag + WithCli.HasArguments + WithCli.Normalize + WithCli.Parser + WithCli.Result + ExamplesSpec ModifiersSpec ModifiersSpec.RenameOptionsSpec ModifiersSpec.UseForPositionalArgumentsSpec - System.Console.GetOpt.Generics.FieldStringSpec + ShellProtocol System.Console.GetOpt.Generics.ModifierSpec - System.Console.GetOpt.Generics.ResultSpec - System.Console.GetOpt.Generics.SimpleSpec System.Console.GetOpt.GenericsSpec Util + WithCli.ArgumentSpec + WithCli.HasArgumentsSpec + WithCli.NormalizeSpec + WithCli.ParserSpec + WithCli.ResultSpec + WithCliSpec + CustomOption + CustomOptionRecord + RecordType + Simple + SimpleRecord + Test01 + Test02 + Test03 + Test04 default-language: Haskell2010 diff --git a/src/System/Console/GetOpt/Generics.hs b/src/System/Console/GetOpt/Generics.hs --- a/src/System/Console/GetOpt/Generics.hs +++ b/src/System/Console/GetOpt/Generics.hs @@ -1,31 +1,123 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module System.Console.GetOpt.Generics ( + -- * Simple IO API + withCli, + WithCli(), + HasArguments, + WithCli.Argument(argumentType, parseArgument), + -- * Customizing the CLI + withCliModified, + Modifier(..), -- * IO API - simpleCLI, - SimpleCLI, - ArgumentTypes, getArguments, modifiedGetArguments, -- * Pure API parseArguments, Result(..), - -- * Customizing the CLI - Modifier(..), - deriveShortOptions, - -- * Available Field Types - Option(argumentType, parseArgument), -- * Re-exports from "Generics.SOP" - Generic, + Generics.SOP.Generic, HasDatatypeInfo, Code, All2, - SingI, - Proxy(..), ) where import Generics.SOP +import System.Environment -import System.Console.GetOpt.Generics.GetArguments +import WithCli +import WithCli.Parser +import WithCli.HasArguments +import WithCli.Result import System.Console.GetOpt.Generics.Modifier -import System.Console.GetOpt.Generics.Result -import System.Console.GetOpt.Generics.Simple + +-- | Parses command line arguments (gotten from 'withArgs') and returns the +-- parsed value. This function should be enough for simple use-cases. +-- +-- Throws the same exceptions as 'withCli'. +-- +-- Here's an example: + +-- ### Start "docs/RecordType.hs" "" Haddock ### + +-- | +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > module RecordType where +-- > +-- > import qualified GHC.Generics +-- > import System.Console.GetOpt.Generics +-- > +-- > -- All you have to do is to define a type and derive some instances: +-- > +-- > data Options +-- > = Options { +-- > port :: Int, +-- > daemonize :: Bool, +-- > config :: Maybe FilePath +-- > } +-- > deriving (Show, GHC.Generics.Generic) +-- > +-- > instance Generic Options +-- > instance HasDatatypeInfo Options +-- > +-- > -- Then you can use `getArguments` to create a command-line argument parser: +-- > +-- > main :: IO () +-- > main = do +-- > options <- getArguments +-- > print (options :: Options) + +-- ### End ### + +-- | And this is how the above program behaves: + +-- ### Start "docs/RecordType.shell-protocol" "" Haddock ### + +-- | +-- > $ program --port 8080 --config some/path +-- > Options {port = 8080, daemonize = False, config = Just "some/path"} +-- > $ program --port 8080 --daemonize +-- > Options {port = 8080, daemonize = True, config = Nothing} +-- > $ program --port foo +-- > cannot parse as INTEGER: foo +-- > # exit-code 1 +-- > $ program +-- > missing option: --port=INTEGER +-- > # exit-code 1 +-- > $ program --help +-- > program [OPTIONS] +-- > --port=INTEGER +-- > --daemonize +-- > --config=STRING (optional) +-- > -h --help show help and exit + +-- ### End ### + +getArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) => + IO a +getArguments = modifiedGetArguments [] + +-- | Like 'getArguments` but allows you to pass in 'Modifier's. +modifiedGetArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) => + [Modifier] -> IO a +modifiedGetArguments modifiers = do + args <- getArgs + progName <- getProgName + handleResult $ parseArguments progName modifiers args + +-- | Pure variant of 'modifiedGetArguments'. +-- +-- Does not throw any exceptions. +parseArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) => + String -- ^ Name of the program (e.g. from 'getProgName'). + -> [Modifier] -- ^ List of 'Modifier's to manually tweak the command line interface. + -> [String] -- ^ List of command line arguments to parse (e.g. from 'getArgs'). + -> Result a +parseArguments progName mods args = do + modifiers <- mkModifiers mods + parser <- genericParser modifiers + runParser progName modifiers + (normalizeParser (applyModifiers modifiers parser)) args diff --git a/src/System/Console/GetOpt/Generics/FieldString.hs b/src/System/Console/GetOpt/Generics/FieldString.hs deleted file mode 100644 --- a/src/System/Console/GetOpt/Generics/FieldString.hs +++ /dev/null @@ -1,48 +0,0 @@ - -module System.Console.GetOpt.Generics.FieldString ( - FieldString, - mkFieldString, - normalized, - matches, - renameUnnormalized, - ) where - -import Data.Char - -data FieldString = FieldString String - deriving (Show) - -normalized :: FieldString -> String -normalized (FieldString s) = normalize s - -mkFieldString :: String -> FieldString -mkFieldString = FieldString - -matches :: String -> FieldString -> Bool -matches s field = - normalize s == normalized field - -renameUnnormalized :: (String -> Maybe String) -> (FieldString -> FieldString) -renameUnnormalized f input@(FieldString unnormalized) = - maybe input FieldString (f unnormalized) - -normalize :: String -> String -normalize s = - if all (not . isAllowedChar) s - then s - else - slugify $ - dropWhile (== '-') $ - filter isAllowedChar $ - map (\ c -> if c == '_' then '-' else c) $ - s - where - slugify (a : r) - | isUpper a = slugify (toLower a : r) - slugify (a : b : r) - | isUpper b = a : '-' : slugify (toLower b : r) - | otherwise = a : slugify (b : r) - slugify x = x - -isAllowedChar :: Char -> Bool -isAllowedChar c = (isAscii c && isAlphaNum c) || (c `elem` "-_") diff --git a/src/System/Console/GetOpt/Generics/GetArguments.hs b/src/System/Console/GetOpt/Generics/GetArguments.hs deleted file mode 100644 --- a/src/System/Console/GetOpt/Generics/GetArguments.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-deprecated-flags #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} - --- | @getopt-generics@ tries to make it very simple to create command line --- argument parsers. -module System.Console.GetOpt.Generics.GetArguments where - -import Data.Orphans () -import Prelude () -import Prelude.Compat - -import Data.Char -import Data.List.Compat -import Data.Maybe -import Data.Proxy -import Data.Typeable -import Generics.SOP -import System.Console.GetOpt -import System.Environment -import Text.Read.Compat - -import System.Console.GetOpt.Generics.FieldString -import System.Console.GetOpt.Generics.Modifier -import System.Console.GetOpt.Generics.Result - --- | Parses command line arguments (gotten from 'withArgs') and returns the --- parsed value. This function should be enough for simple use-cases. --- --- Throws the same exceptions as 'simpleCLI'. --- --- Here's an example: - --- ### Start "docs/RecordTypeExample.hs" Haddock ### - --- | --- > {-# LANGUAGE DeriveGeneric #-} --- > --- > import GHC.Generics --- > import System.Console.GetOpt.Generics --- > --- > -- All you have to do is to define a type and derive some instances: --- > --- > data Options --- > = Options { --- > port :: Int, --- > daemonize :: Bool, --- > config :: Maybe FilePath --- > } --- > deriving (Show, GHC.Generics.Generic) --- > --- > instance System.Console.GetOpt.Generics.Generic Options --- > instance HasDatatypeInfo Options --- > --- > -- Then you can use `getArguments` to create a command-line argument parser: --- > --- > main :: IO () --- > main = do --- > options <- getArguments --- > print (options :: Options) - --- ### End ### - --- | And this is how the above program behaves: - --- ### Start "docs/RecordTypeExample.bash-protocol" Haddock ### - --- | --- > $ program --port 8080 --config some/path --- > Options {port = 8080, daemonize = False, config = Just "some/path"} --- > $ program --port 8080 --daemonize --- > Options {port = 8080, daemonize = True, config = Nothing} --- > $ program --port foo --- > cannot parse as INTEGER: foo --- > $ program --- > missing option: --port=INTEGER --- > $ program --help --- > program [OPTIONS] --- > --port=INTEGER --- > --daemonize --- > --config=STRING (optional) --- > -h --help show help and exit - --- ### End ### - -getArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) => - IO a -getArguments = modifiedGetArguments [] - --- | Like 'getArguments` but allows you to pass in 'Modifier's. -modifiedGetArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) => - [Modifier] -> IO a -modifiedGetArguments modifiers = do - args <- getArgs - progName <- getProgName - handleResult $ parseArguments progName modifiers args - --- | Pure variant of 'modifiedGetArguments'. --- --- Does not throw any exceptions. -parseArguments :: forall a . (Generic a, HasDatatypeInfo a, All2 Option (Code a)) => - String -- ^ Name of the program (e.g. from 'getProgName'). - -> [Modifier] -- ^ List of 'Modifier's to manually tweak the command line interface. - -> [String] -- ^ List of command line arguments to parse (e.g. from 'getArgs'). - -> Result a -parseArguments progName modifiersList args = do - let modifiers = mkModifiers modifiersList - case datatypeInfo (Proxy :: Proxy a) of - ADT typeName _ (constructorInfo :* Nil) -> - case constructorInfo of - (Record _ fields) -> processFields progName modifiers args - (hliftA (Comp . Selector) fields) - Constructor{} -> - processFields progName modifiers args (hpure (Comp NoSelector)) - Infix{} -> - err typeName "infix constructors" - ADT typeName _ Nil -> - err typeName "empty data types" - ADT typeName _ (_ :* _ :* _) -> - err typeName "sum types" - Newtype _ _ (Record _ fields) -> - processFields progName modifiers args - (hliftA (Comp . Selector) fields) - Newtype typeName _ (Constructor _) -> - err typeName "constructors without field labels" - where - err typeName message = - errors ["getopt-generics doesn't support " ++ message ++ - " (" ++ typeName ++ ")."] - -data Field a - = NoSelector - | Selector a - -processFields :: forall a xs . - (Generic a, Code a ~ '[xs], SingI xs, All Option xs) => - String -> Modifiers -> [String] -> NP (Field :.: FieldInfo) xs -> Result a -processFields progName modifiers args fields = do - initialFieldStates <- mkInitialFieldStates modifiers fields - - showOutputInfo - - let (options, arguments, parseErrors) = - getOpt Permute (mkOptDescrs modifiers fields) args - - reportGetOptErrors parseErrors - - withPositionalArguments <- fillInPositionalArguments arguments $ - project options initialFieldStates - - to . SOP . Z <$> collectResult withPositionalArguments - where - showOutputInfo :: Result () - showOutputInfo = outputInfo progName modifiers args fields - - reportGetOptErrors :: [String] -> Result () - reportGetOptErrors parseErrors = case parseErrors of - [] -> pure () - errs -> errors errs - --- Creates a list of NS where every element corresponds to one field. To be --- used by 'getOpt'. -mkOptDescrs :: forall xs . (SingI xs, All Option xs) => - Modifiers -> NP (Field :.: FieldInfo) xs -> [OptDescr (NS FieldState xs)] -mkOptDescrs modifiers = - mapMaybe toOptDescr . apInjs_NP . hcliftA (Proxy :: Proxy Option) (mkOptDescr modifiers) - -newtype OptDescrE a = OptDescrE (Maybe (OptDescr (FieldState a))) - -mkOptDescr :: forall a . Option a => Modifiers -> (Field :.: FieldInfo) a -> OptDescrE a -mkOptDescr _modifiers (Comp NoSelector) = OptDescrE Nothing -mkOptDescr modifiers (Comp (Selector (FieldInfo (mkFieldString -> name)))) = OptDescrE $ - if isPositionalArgumentsField modifiers name - then Nothing - else Just $ Option - (mkShortOptions modifiers name) - [mkLongOption modifiers name] - _toOption - (getHelpText modifiers name) - -toOptDescr :: NS OptDescrE xs -> Maybe (OptDescr (NS FieldState xs)) -toOptDescr (Z (OptDescrE (Just a))) = Just $ fmap Z a -toOptDescr (Z (OptDescrE Nothing)) = Nothing -toOptDescr (S a) = fmap (fmap S) (toOptDescr a) - --- Initializes an NP of empty fields to be filled in later. --- Contains only default values. -mkInitialFieldStates :: forall xs . (SingI xs, All Option xs) => - Modifiers -> NP (Field :.: FieldInfo) xs -> Result (NP FieldState xs) -mkInitialFieldStates modifiers fields = case (sing :: Sing xs, fields) of - (SNil, Nil) -> return Nil - (SCons, Comp (Selector (FieldInfo (mkFieldString -> name))) :* r) -> - (:*) <$> inner name <*> mkInitialFieldStates modifiers r - (SCons, Comp NoSelector :* r) -> - (:*) <$> Success PositionalArgument <*> mkInitialFieldStates modifiers r - _ -> uninhabited "mkInitialFieldStates" - - where - inner :: forall x . Option x => FieldString -> Result (FieldState x) - inner name = if isPositionalArgumentsField modifiers name - then case cast (id :: FieldState x -> FieldState x) of - (Just id' :: Maybe (FieldState [String] -> FieldState x)) -> - Success $ id' PositionalArguments - Nothing -> errors - ["UseForPositionalArguments can only be used " ++ - "for fields of type [String] not " ++ - show (typeOf (impossible "mkInitialFieldStates" :: x))] - else return $ _emptyOption modifiers name - --- * showing output information - -data OutputInfoFlag - = HelpFlag - | VersionFlag String - deriving (Eq, Ord) - --- Outputs the help or version information if the corresponding flags are given. -outputInfo :: (SingI xs, All Option xs) => - String -> Modifiers -> [String] -> NP (Field :.: FieldInfo) xs -> Result () -outputInfo progName modifiers args fields = - case (\ (a, b, c) -> (sort a, b, c)) (getOpt Permute options args) of - ([], _, _) -> return () - -- no help or version flag given - (HelpFlag : _, _, _) -> outputAndExit $ - usageInfo header $ - toOptDescrUnit (mkOptDescrs modifiers fields) ++ - toOptDescrUnit options - (VersionFlag version : _, _, _) -> outputAndExit $ - progName ++ " version " ++ version ++ "\n" - where - options :: [OptDescr OutputInfoFlag] - options = helpOption : maybeToList versionOption - - helpOption :: OptDescr OutputInfoFlag - helpOption = Option ['h'] ["help"] (NoArg HelpFlag) "show help and exit" - - versionOption :: Maybe (OptDescr OutputInfoFlag) - versionOption = case getVersion modifiers of - Just version -> Just $ Option [] ["version"] (NoArg (VersionFlag version)) "show version and exit" - Nothing -> Nothing - - toOptDescrUnit :: [OptDescr a] -> [OptDescr ()] - toOptDescrUnit = map (fmap (const ())) - - header :: String - header = unwords $ - progName : - "[OPTIONS]" : - positionalArgumentHelp fields ++ - maybe [] (\ t -> ["[" ++ t ++ "]"]) - (getPositionalArgumentType modifiers) ++ - [] - -positionalArgumentHelp :: (All Option xs) => NP (Field :.: FieldInfo) xs -> [String] -positionalArgumentHelp (p@(Comp NoSelector) :* r) = - argumentType (toProxy p) : positionalArgumentHelp r -positionalArgumentHelp (_ :* r) = positionalArgumentHelp r -positionalArgumentHelp Nil = [] - --- Fills in the positional arguments in the NP that already contains the flag --- values. Fills in FieldErrors in case of --- - parse errors and --- - missing positional arguments. --- The returned Either contains errors in case of too many positional arguments. -fillInPositionalArguments :: (All Option xs) => - [String] -> NP FieldState xs -> Result (NP FieldState xs) -fillInPositionalArguments args inputFieldStates = do - let (result, errs) = inner (Just args) inputFieldStates - either errors return errs - Success result - where - inner :: All Option xs => - Maybe [String] -> NP FieldState xs -> (NP FieldState xs, Either [String] ()) - inner arguments fields = case (arguments, fields) of - (Just arguments, PositionalArguments :* r) -> - FieldSuccess arguments `cons` inner Nothing r - (Nothing, PositionalArguments :* r) -> - FieldErrors ["UseForPositionalArguments can only be used once"] `cons` inner Nothing r - - (Just (argument : arguments), PositionalArgument :* r) -> - case parseArgumentEither argument of - Right a -> FieldSuccess a `cons` inner (Just arguments) r - Left err -> FieldErrors [err] `cons` inner (Just arguments) r - (Just [], p@PositionalArgument :* r) -> - FieldErrors ["missing argument of type " ++ argumentType (toProxy p)] - `cons` inner (Just []) r - (Nothing, PositionalArgument :* _) -> - impossible "fillInPositionalArguments" - - (arguments, a :* r) -> a `cons` inner arguments r - (Just [], Nil) -> (Nil, Right ()) - (Nothing, Nil) -> (Nil, Right ()) - (Just arguments@(_ : _), Nil) -> - (Nil, Left (map (\ arg -> "unknown argument: " ++ arg) arguments)) - - cons :: FieldState x -> (NP FieldState xs, r) -> (NP FieldState (x ': xs), r) - cons fieldState (arguments, r) = (fieldState :* arguments, r) - --- Collects all FieldStates into a Result NP. If any errors are contained they --- will be accumulated. -collectResult :: (SingI xs) => NP FieldState xs -> Result (NP I xs) -collectResult input = - hsequence $ hliftA inner input - where - inner :: FieldState x -> Result x - inner s = case s of - FieldSuccess v -> Success v - FieldErrors errs -> errors errs - Unset err -> errors [err] - PositionalArguments -> impossible "collectResult" - PositionalArgument -> impossible "collectResult" - --- * helper functions for NS and NP - -project :: (SingI xs, All Option xs) => - [NS FieldState xs] -> NP FieldState xs -> NP FieldState xs -project sums start = - foldl' inner start sums - where - inner :: (All Option xs) => - NP FieldState xs -> NS FieldState xs -> NP FieldState xs - inner (a :* r) (Z b) = combine a b :* r - inner (a :* r) (S rSum) = a :* inner r rSum - inner Nil _ = uninhabited "project" - -impossible :: String -> a -impossible name = error ("System.Console.GetOpt.Generics." ++ name ++ ": This should never happen!") - -uninhabited :: String -> a -uninhabited = impossible - -toProxy :: f a -> Proxy a -toProxy = const Proxy - --- * possible field types - -data FieldState a where - Unset :: String -> FieldState a - FieldErrors :: [String] -> FieldState a - FieldSuccess :: a -> FieldState a - PositionalArguments :: FieldState [String] - PositionalArgument :: FieldState a - deriving (Typeable) - --- | Type class for all allowed field types. --- --- If you want to use custom field types you should implement an --- @instance Option YourCustomType@ containing implementations of --- 'argumentType' and 'parseArgument' (the minimal complete definition). --- --- Here's an example: - --- ### Start "docs/CustomOptionsExample.hs" Haddock ### - --- | --- > {-# LANGUAGE DeriveDataTypeable #-} --- > --- > import Data.Typeable --- > import System.Console.GetOpt.Generics --- > --- > data File = File FilePath --- > deriving (Show, Typeable) --- > --- > instance Option File where --- > argumentType Proxy = "custom-file-type" --- > parseArgument f = Just (File f) --- > --- > main :: IO () --- > main = simpleCLI $ \ file -> do --- > print (file :: File) - --- ### End ### - --- | This would give you: - --- ### Start "docs/CustomOptionsExample.bash-protocol" Haddock ### - --- | --- > $ program some/file --- > File "some/file" --- > $ program --help --- > program [OPTIONS] custom-file-type --- > -h --help show help and exit - --- ### End ### - -class Typeable a => Option a where - {-# MINIMAL argumentType, parseArgument #-} - -- | Name of the argument type, e.g. "bool" or "integer". - argumentType :: Proxy a -> String - - -- | Parses a 'String' into an argument. Returns 'Nothing' on parse errors. - parseArgument :: String -> Maybe a - - -- | This is meant to be an internal function. - _toOption :: ArgDescr (FieldState a) - _toOption = ReqArg parseAsFieldState (argumentType (Proxy :: Proxy a)) - - -- | This is meant to be an internal function. - _emptyOption :: Modifiers -> FieldString -> FieldState a - _emptyOption modifiers flagName = Unset - ("missing option: --" ++ mkLongOption modifiers flagName ++ - "=" ++ argumentType (Proxy :: Proxy a)) - - -- | This is meant to be an internal function. - _accumulate :: a -> a -> a - _accumulate _ x = x - -parseArgumentEither :: forall a . Option a => String -> Either String a -parseArgumentEither s = - maybe - (Left ("cannot parse as " ++ argumentType (Proxy :: Proxy a) ++ ": " ++ s)) - Right - (parseArgument s) - -parseAsFieldState :: forall a . Option a => String -> FieldState a -parseAsFieldState s = either - (\ err -> FieldErrors [err]) - FieldSuccess - (parseArgumentEither s) - -combine :: Option a => FieldState a -> FieldState a -> FieldState a -combine _ (Unset _) = impossible "combine" -combine _ PositionalArguments = impossible "combine" -combine _ PositionalArgument = impossible "combine" -combine (FieldErrors e) (FieldErrors f) = FieldErrors (e ++ f) -combine (FieldErrors e) _ = FieldErrors e -combine (Unset _) x = x -combine (FieldSuccess _) (FieldErrors e) = FieldErrors e -combine (FieldSuccess a) (FieldSuccess b) = FieldSuccess (_accumulate a b) -combine PositionalArguments _ = PositionalArguments -combine PositionalArgument _ = PositionalArgument - -instance Option a => Option [a] where - argumentType Proxy = argumentType (Proxy :: Proxy a) ++ " (multiple possible)" - parseArgument x = case parseArgument x of - Just (x :: a) -> Just [x] - Nothing -> Nothing - _emptyOption _ _ = FieldSuccess [] - _accumulate = (++) - -instance Option a => Option (Maybe a) where - argumentType Proxy = argumentType (Proxy :: Proxy a) ++ " (optional)" - parseArgument x = case parseArgument x of - Just (x :: a) -> Just (Just x) - Nothing -> Nothing - _emptyOption _ _ = FieldSuccess Nothing - -instance Option Bool where - argumentType _ = "BOOL" - - parseArgument :: String -> Maybe Bool - parseArgument s - | map toLower s `elem` ["true", "yes", "on"] = Just True - | map toLower s `elem` ["false", "no", "off"] = Just False - | otherwise = case readMaybe s of - Just (n :: Integer) -> Just (n > 0) - Nothing -> Nothing - - _toOption = NoArg (FieldSuccess True) - _emptyOption _ _ = FieldSuccess False - -instance Option String where - argumentType Proxy = "STRING" - parseArgument = Just - -instance Option Int where - argumentType _ = "INTEGER" - parseArgument = readMaybe - -instance Option Integer where - argumentType _ = "INTEGER" - parseArgument = readMaybe - -readNumber :: (RealFloat n, Read n) => String -> Maybe n -readNumber s = case readMaybe s of - Just n -> Just n - Nothing - | "." `isPrefixOf` s -> readMaybe ("0" ++ s) - | otherwise -> Nothing - -instance Option Float where - argumentType _ = "NUMBER" - parseArgument = readNumber - -instance Option Double where - argumentType _ = "NUMBER" - parseArgument = readNumber diff --git a/src/System/Console/GetOpt/Generics/Modifier.hs b/src/System/Console/GetOpt/Generics/Modifier.hs --- a/src/System/Console/GetOpt/Generics/Modifier.hs +++ b/src/System/Console/GetOpt/Generics/Modifier.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} @@ -7,30 +8,31 @@ Modifier(..), Modifiers, mkModifiers, - mkShortOptions, - mkLongOption, - hasPositionalArgumentsField, isPositionalArgumentsField, getPositionalArgumentType, - getHelpText, getVersion, - deriveShortOptions, + applyModifiers, + applyModifiersLong, -- exported for testing - mkShortModifiers, insertWith, ) where import Prelude () import Prelude.Compat +import Control.Arrow +import Control.Monad import Data.Char -import Data.List (find, foldl') +import Data.List (foldl') import Data.Maybe -import Generics.SOP +import System.Console.GetOpt -import System.Console.GetOpt.Generics.FieldString +import System.Console.GetOpt.Generics.Modifier.Types +import WithCli.Parser +import WithCli.Normalize +import WithCli.Result -- | 'Modifier's can be used to customize the command line parser. data Modifier @@ -59,116 +61,34 @@ | AddVersionFlag String -- ^ @AddVersionFlag version@ adds a @--version@ flag. -data Modifiers = Modifiers { - _shortOptions :: [(String, [Char])], - _renaming :: FieldString -> FieldString, - positionalArgumentsField :: [(String, String)], - helpTexts :: [(String, String)], - version :: Maybe String - } - -mkModifiers :: [Modifier] -> Modifiers -mkModifiers = foldl' inner empty +mkModifiers :: [Modifier] -> Result Modifiers +mkModifiers = foldM inner empty where empty :: Modifiers - empty = Modifiers [] id [] [] Nothing + empty = Modifiers [] id Nothing [] Nothing - inner :: Modifiers -> Modifier -> Modifiers + inner :: Modifiers -> Modifier -> Result Modifiers inner (Modifiers shorts renaming args help version) modifier = case modifier of (AddShortOption option short) -> - Modifiers (insertWith (++) option [short] shorts) renaming args help version + return $ Modifiers (insertWith (++) option [short] shorts) renaming args help version (RenameOption from to) -> - let newRenaming :: FieldString -> FieldString + let newRenaming :: String -> String newRenaming option = if from `matches` option - then mkFieldString to + then to else option - in Modifiers shorts (renaming . newRenaming) args help version + in return $ Modifiers shorts (renaming . newRenaming) args help version (RenameOptions newRenaming) -> - Modifiers shorts (renaming `combineRenamings` newRenaming) args help version - (UseForPositionalArguments option typ) -> - Modifiers shorts renaming ((option, map toUpper typ) : args) help version + return $ Modifiers shorts (renaming `combineRenamings` newRenaming) args help version + (UseForPositionalArguments option typ) -> case args of + Nothing -> return $ Modifiers shorts renaming (Just (option, map toUpper typ)) help version + Just _ -> Errors ["UseForPositionalArguments can only be used once"] (AddOptionHelp option helpText) -> - Modifiers shorts renaming args (insert option helpText help) version + return $ Modifiers shorts renaming args (insert option helpText help) version (AddVersionFlag v) -> - Modifiers shorts renaming args help (Just v) - - combineRenamings :: (FieldString -> FieldString) -> (String -> Maybe String) - -> FieldString -> FieldString - combineRenamings old new fieldString = - (old . renameUnnormalized new) fieldString - -lookupMatching :: [(String, a)] -> FieldString -> Maybe a -lookupMatching list option = fmap snd $ find (\ (from, _) -> from `matches` option) list - -mkShortOptions :: Modifiers -> FieldString -> [Char] -mkShortOptions (Modifiers shortMap _ _ _ _) option = fromMaybe [] (lookupMatching shortMap option) - -mkLongOption :: Modifiers -> FieldString -> String -mkLongOption (Modifiers _ renaming _ _ _) option = - normalized (renaming option) - -hasPositionalArgumentsField :: Modifiers -> Bool -hasPositionalArgumentsField = not . null . positionalArgumentsField - -isPositionalArgumentsField :: Modifiers -> FieldString -> Bool -isPositionalArgumentsField modifiers field = - any (`matches` field) (map fst (positionalArgumentsField modifiers)) - -getPositionalArgumentType :: Modifiers -> Maybe String -getPositionalArgumentType = fmap snd . listToMaybe . positionalArgumentsField - -getHelpText :: Modifiers -> FieldString -> String -getHelpText modifiers field = fromMaybe "" $ lookupMatching (helpTexts modifiers) field - -getVersion :: Modifiers -> Maybe String -getVersion modifiers = version modifiers - --- * deriving Modifiers - --- | Derives 'AddShortOption's for all fields of the datatype that start with a --- unique character. -deriveShortOptions :: (HasDatatypeInfo a, SingI (Code a)) => - Proxy a -> [Modifier] -deriveShortOptions proxy = - mkShortModifiers (flags proxy) - -flags :: (SingI (Code a), HasDatatypeInfo a) => - Proxy a -> [String] -flags proxy = case datatypeInfo proxy of - ADT _ _ ci -> fromNPConstructorInfo ci - Newtype _ _ ci -> fromConstructorInfo ci - where - fromNPConstructorInfo :: NP ConstructorInfo xs -> [String] - fromNPConstructorInfo Nil = [] - fromNPConstructorInfo (a :* r) = - fromConstructorInfo a ++ fromNPConstructorInfo r - - fromConstructorInfo :: ConstructorInfo x -> [String] - fromConstructorInfo (Constructor _) = [] - fromConstructorInfo (Infix _ _ _) = [] - fromConstructorInfo (Record _ fields) = - fromFields fields - - fromFields :: NP FieldInfo xs -> [String] - fromFields (FieldInfo name :* r) = name : fromFields r - fromFields Nil = [] + return $ Modifiers shorts renaming args help (Just v) -mkShortModifiers :: [String] -> [Modifier] -mkShortModifiers fields = - let withShorts = mapMaybe (\ field -> (field, ) <$> toShort field) fields - allShorts = map snd withShorts - isUnique c = case filter (== c) allShorts of - [_] -> True - _ -> False - in (flip mapMaybe) withShorts $ \ (field, short) -> - if isUnique short - then Just (AddShortOption field short) - else Nothing - where - toShort :: String -> Maybe Char - toShort s = case dropWhile (\ c -> not (isAscii c && isAlpha c)) s of - [] -> Nothing - (a : _) -> Just (toLower a) + combineRenamings :: (a -> a) -> (a -> Maybe a) -> (a -> a) + combineRenamings old new x = old (fromMaybe x (new x)) -- * list utils to replace Data.Map @@ -185,3 +105,33 @@ if a == key then (key, value) : r else (a, b) : insert key value r + +-- * transforming Parsers + +applyModifiers :: Modifiers -> Parser Unnormalized a -> Parser Unnormalized a +applyModifiers modifiers = + addShortOptions >>> + renameOptions + where + addShortOptions = modParserOptions $ map $ + \ option -> + case filter (\ (needle, _) -> needle `elem` longs option) (shortOptions modifiers) of + [] -> option + (concat . map snd -> newShorts) -> + foldl' (flip addShort) option newShorts + renameOptions = + modParserOptions $ map $ modLongs $ renaming modifiers + +applyModifiersLong :: Modifiers -> String -> String +applyModifiersLong modifiers long = (renaming modifiers) long + +longs :: OptDescr a -> [String] +longs (Option _ ls _ _) = ls + +addShort :: Char -> OptDescr a -> OptDescr a +addShort short (Option shorts longs argDescrs help) = + Option (shorts ++ [short]) longs argDescrs help + +modLongs :: (String -> String) -> OptDescr a -> OptDescr a +modLongs f (Option shorts longs descrs help) = + Option shorts (map f longs) descrs help diff --git a/src/System/Console/GetOpt/Generics/Modifier/Types.hs b/src/System/Console/GetOpt/Generics/Modifier/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/GetOpt/Generics/Modifier/Types.hs @@ -0,0 +1,20 @@ + +module System.Console.GetOpt.Generics.Modifier.Types where + +data Modifiers = Modifiers { + shortOptions :: [(String, [Char])], + renaming :: String -> String, + positionalArgumentsField :: Maybe (String, String), + _helpTexts :: [(String, String)], + version :: Maybe String + } + +getVersion :: Modifiers -> Maybe String +getVersion modifiers = version modifiers + +isPositionalArgumentsField :: Modifiers -> String -> Bool +isPositionalArgumentsField modifiers field = + maybe False ((field ==) . fst) (positionalArgumentsField modifiers) + +getPositionalArgumentType :: Modifiers -> Maybe String +getPositionalArgumentType = fmap snd . positionalArgumentsField diff --git a/src/System/Console/GetOpt/Generics/Result.hs b/src/System/Console/GetOpt/Generics/Result.hs deleted file mode 100644 --- a/src/System/Console/GetOpt/Generics/Result.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} - -module System.Console.GetOpt.Generics.Result ( - Result(..), - errors, - outputAndExit, - handleResult, - ) where - -import Prelude () -import Prelude.Compat - -import Data.List -import System.Exit -import System.IO - --- | Type to wrap results from the pure parsing functions. -data Result a - = Success a - -- ^ The CLI was used correctly and a value of type @a@ was - -- successfully constructed. - | Errors [String] - -- ^ The CLI was used incorrectly. The 'Result' contains a list of error - -- messages. - -- - -- It can also happen that the data type you're trying to use isn't - -- supported. See the - -- for - -- details. - | OutputAndExit String - -- ^ The CLI was used with @--help@. The 'Result' contains the help message. - deriving (Show, Eq, Ord, Functor) - -errors :: [String] -> Result a -errors = Errors . map removeTrailingNewline - -outputAndExit :: String -> Result a -outputAndExit = OutputAndExit . stripTrailingSpaces - -instance Applicative Result where - pure = Success - OutputAndExit message <*> _ = OutputAndExit message - _ <*> OutputAndExit message = OutputAndExit message - Success f <*> Success x = Success (f x) - Errors a <*> Errors b = Errors (a ++ b) - Errors errs <*> Success _ = Errors errs - Success _ <*> Errors errs = Errors errs - -instance Monad Result where - return = pure - Success a >>= b = b a - Errors errs >>= _ = Errors errs - OutputAndExit message >>= _ = OutputAndExit message - - (>>) = (*>) - -handleResult :: Result a -> IO a -handleResult result = case result of - Success a -> return a - OutputAndExit message -> do - putStr message - exitWith ExitSuccess - Errors errs -> do - mapM_ (hPutStr stderr . addNewlineIfMissing) errs - exitWith $ ExitFailure 1 - -addNewlineIfMissing :: String -> String -addNewlineIfMissing s - | "\n" `isSuffixOf` s = s - | otherwise = s ++ "\n" - -removeTrailingNewline :: String -> String -removeTrailingNewline s - | "\n" `isSuffixOf` s = init s - | otherwise = s - -stripTrailingSpaces :: String -> String -stripTrailingSpaces = reverse . inner . dropWhile (== ' ') . reverse - where - inner s = case s of - ('\n' : ' ' : r) -> inner ('\n' : r) - (a : r) -> a : inner r - [] -> [] diff --git a/src/System/Console/GetOpt/Generics/Simple.hs b/src/System/Console/GetOpt/Generics/Simple.hs deleted file mode 100644 --- a/src/System/Console/GetOpt/Generics/Simple.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} - -module System.Console.GetOpt.Generics.Simple where - -import Generics.SOP -import System.Environment - -import System.Console.GetOpt.Generics.GetArguments -import System.Console.GetOpt.Generics.Modifier -import System.Console.GetOpt.Generics.Result - -class SingI (ArgumentTypes main) => SimpleCLI main where - {-# MINIMAL _initialFieldStates, _run #-} - type ArgumentTypes main :: [*] - _initialFieldStates :: Proxy main -> NP FieldState (ArgumentTypes main) - _run :: NP I (ArgumentTypes main) -> main -> IO () - --- | 'simpleCLI' converts an IO operation into a program with a proper CLI. --- Retrieves command line arguments through 'withArgs'. --- @main@ (the given IO operation) can have arbitrarily many parameters --- provided all parameters have an instance for 'Option'. --- --- May throw the following exceptions: --- --- - @'ExitFailure' 1@ in case of invalid options. Error messages are written --- to @stderr@. --- - @'ExitSuccess'@ in case @--help@ is given. (@'ExitSuccess'@ behaves like --- a normal exception, except that -- if uncaught -- the process will exit --- with exit-code @0@.) Help output is written to @stdout@. --- --- Example: - --- ### Start "docs/SimpleExample.hs" Haddock ### - --- | --- > import System.Console.GetOpt.Generics --- > --- > main :: IO () --- > main = simpleCLI myMain --- > --- > myMain :: String -> Int -> Bool -> IO () --- > myMain s i b = print (s, i, b) - --- ### End ### - --- | Using the above program in bash: - --- ### Start "docs/SimpleExample.bash-protocol" Haddock ### - --- | --- > $ program foo 42 true --- > ("foo",42,True) --- > $ program foo 42 bar --- > cannot parse as BOOL: bar --- > $ program --help --- > program [OPTIONS] STRING INTEGER BOOL --- > -h --help show help and exit - --- ### End ### - -simpleCLI :: forall main . (SimpleCLI main, All Option (ArgumentTypes main)) => - main -> IO () -simpleCLI main = do - args <- getArgs - progName <- getProgName - let result = do - outputInfo progName (mkModifiers []) args - (hliftA (const $ Comp NoSelector) (_initialFieldStates (Proxy :: Proxy main))) - filledIn <- fillInPositionalArguments args (_initialFieldStates (Proxy :: Proxy main)) - collectResult filledIn - f <- handleResult result - _run f main - -instance SimpleCLI (IO ()) where - type ArgumentTypes (IO ()) = '[] - _initialFieldStates Proxy = Nil - _run Nil = id - _run _ = impossible "_run" - -instance (Option a, SimpleCLI rest) => - SimpleCLI (a -> rest) where - type ArgumentTypes (a -> rest) = a ': ArgumentTypes rest - _initialFieldStates Proxy = PositionalArgument :* _initialFieldStates (Proxy :: Proxy rest) - _run (I a :* r) main = _run r (main a) - _run _ _ = impossible "_run" diff --git a/src/WithCli.hs b/src/WithCli.hs new file mode 100644 --- /dev/null +++ b/src/WithCli.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module WithCli ( + withCli, + WithCli(), + HasArguments(argumentsParser), + atomicArgumentsParser, + Argument(argumentType, parseArgument), + -- * Modifiers + withCliModified, + Modifier(..), + -- * Useful Re-exports + SOP.Generic, + SOP.HasDatatypeInfo, + SOP.Code, + SOP.All2, + Typeable, + Proxy(..), + ) where + +-- todo: add pure api with withCli + +import Data.Proxy +import Data.Typeable +import qualified Generics.SOP as SOP +import System.Environment + +import System.Console.GetOpt.Generics.Modifier +import WithCli.Argument +import WithCli.HasArguments +import WithCli.Parser +import WithCli.Result + +-- | 'withCli' converts an IO operation into a program with a proper CLI. +-- Retrieves command line arguments through 'withArgs'. +-- @main@ (the given IO operation) can have arbitrarily many parameters +-- provided all parameters have instances for 'HasArguments'. +-- +-- May throw the following exceptions: +-- +-- - @'ExitFailure' 1@ in case of invalid options. Error messages are written +-- to @stderr@. +-- - @'ExitSuccess'@ in case @--help@ is given. (@'ExitSuccess'@ behaves like +-- a normal exception, except that -- if uncaught -- the process will exit +-- with exit-code @0@.) Help output is written to @stdout@. +-- +-- Example: + +-- ### Start "docs/Simple.hs" "module Simple where\n\n" Haddock ### + +-- | +-- > import WithCli +-- > +-- > main :: IO () +-- > main = withCli run +-- > +-- > run :: String -> Int -> Bool -> IO () +-- > run s i b = print (s, i, b) + +-- ### End ### + +-- | Using the above program in a shell: + +-- ### Start "docs/Simple.shell-protocol" "" Haddock ### + +-- | +-- > $ program foo 42 true +-- > ("foo",42,True) +-- > $ program --help +-- > program [OPTIONS] STRING INTEGER BOOL +-- > -h --help show help and exit +-- > $ program foo 42 bar +-- > cannot parse as BOOL: bar +-- > # exit-code 1 +-- > $ program +-- > missing argument of type STRING +-- > missing argument of type INTEGER +-- > missing argument of type BOOL +-- > # exit-code 1 +-- > $ program foo 42 yes bar +-- > unknown argument: bar +-- > # exit-code 1 + +-- ### End ### + +withCli :: forall main . WithCli main => main -> IO () +withCli = withCliModified [] + +-- | This is a variant of 'withCli' that allows to tweak the generated +-- command line interface by providing a list of 'Modifier's. +withCliModified :: forall main . WithCli main => [Modifier] -> main -> IO () +withCliModified mods main = do + args <- getArgs + modifiers <- handleResult (mkModifiers mods) + _run modifiers (return $ emptyParser ()) (\ () -> main) args + +-- | Everything that can be used as a @main@ function with 'withCli' needs to +-- have an instance of 'WithCli'. You shouldn't need to implement your own +-- instances. +class WithCli main where + _run :: Modifiers -> Result (Parser Unnormalized a) -> (a -> main) -> [String] -> IO () + +instance WithCli (IO ()) where + _run modifiers mkParser mkMain args = do + progName <- getProgName + parser <- handleResult mkParser + a <- handleResult $ runParser progName modifiers + (normalizeParser (applyModifiers modifiers parser)) args + mkMain a + +instance (HasArguments a, WithCli rest) => WithCli (a -> rest) where + _run modifiers fa mkMain args = + _run modifiers (combine fa (argumentsParser modifiers Nothing)) (\ (a, r) -> mkMain a r) args diff --git a/src/WithCli/Argument.hs b/src/WithCli/Argument.hs new file mode 100644 --- /dev/null +++ b/src/WithCli/Argument.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# OPTIONS_GHC -fno-warn-deprecated-flags #-} + +module WithCli.Argument where + +import Data.Orphans () +import Prelude () +import Prelude.Compat + +import Data.List +import Data.Proxy +import Text.Read + +-- | 'Argument' is a typeclass for things that can be parsed as atomic values from +-- single command line arguments, e.g. strings (and filenames) and numbers. +-- +-- Occasionally you might want to declare your own instance for additional +-- type safety and for providing a more informative command argument type. +-- Here's an example: + +-- ### Start "docs/CustomOption.hs" "module CustomOption where\n\n" Haddock ### + +-- | +-- > {-# LANGUAGE DeriveDataTypeable #-} +-- > +-- > import WithCli +-- > +-- > data File = File FilePath +-- > deriving (Show, Typeable) +-- > +-- > instance Argument File where +-- > argumentType Proxy = "custom-file-type" +-- > parseArgument f = Just (File f) +-- > +-- > instance HasArguments File where +-- > argumentsParser = atomicArgumentsParser +-- > +-- > main :: IO () +-- > main = withCli run +-- > +-- > run :: File -> IO () +-- > run = print + +-- ### End ### + +-- | And this is how the above program behaves: + +-- ### Start "docs/CustomOption.shell-protocol" "" Haddock ### + +-- | +-- > $ program --help +-- > program [OPTIONS] custom-file-type +-- > -h --help show help and exit +-- > $ program some/file +-- > File "some/file" + +-- ### End ### + +class Argument a where + argumentType :: Proxy a -> String + parseArgument :: String -> Maybe a + +instance Argument String where + argumentType Proxy = "STRING" + parseArgument = Just + +instance Argument Int where + argumentType _ = "INTEGER" + parseArgument = readMaybe + +instance Argument Integer where + argumentType _ = "INTEGER" + parseArgument = readMaybe + +instance Argument Float where + argumentType _ = "NUMBER" + parseArgument = readFloat + +instance Argument Double where + argumentType _ = "NUMBER" + parseArgument = readFloat + +readFloat :: (RealFloat n, Read n) => String -> Maybe n +readFloat s = case readMaybe s of + Just n -> Just n + Nothing + | "." `isPrefixOf` s -> readMaybe ("0" ++ s) + | otherwise -> Nothing diff --git a/src/WithCli/Flag.hs b/src/WithCli/Flag.hs new file mode 100644 --- /dev/null +++ b/src/WithCli/Flag.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveFunctor #-} + +module WithCli.Flag where + +import Prelude () +import Prelude.Compat + +import Data.Monoid +import System.Console.GetOpt + +data Flag a + = Help + | Version String + | NoHelp a + deriving (Functor) + +instance Monoid a => Monoid (Flag a) where + mappend a b = case (a, b) of + (Help, _) -> Help + (_, Help) -> Help + (Version s, _) -> Version s + (_, Version s) -> Version s + (NoHelp a, NoHelp b) -> NoHelp (a <> b) + mempty = NoHelp mempty + +foldFlags :: [Flag a] -> Flag [a] +foldFlags flags = mconcat $ map (fmap pure) flags + +helpOption :: OptDescr (Flag a) +helpOption = + Option ['h'] ["help"] (NoArg Help) "show help and exit" + +versionOption :: String -> OptDescr (Flag a) +versionOption version = + Option ['v'] ["version"] (NoArg (Version version)) "show version and exit" + +usage :: String -> [String] -> [OptDescr ()] -> String +usage progName fields options = usageInfo header options + where + header :: String + header = unwords $ + progName : + "[OPTIONS]" : + fields ++ + [] diff --git a/src/WithCli/HasArguments.hs b/src/WithCli/HasArguments.hs new file mode 100644 --- /dev/null +++ b/src/WithCli/HasArguments.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-deprecated-flags #-} + +module WithCli.HasArguments where + +import Data.Orphans () +import Prelude () +import Prelude.Compat + +import Data.Char +import Data.List.Compat +import Data.Proxy +import Data.Traversable +import Generics.SOP as SOP +import System.Console.GetOpt +import Text.Read + +import System.Console.GetOpt.Generics.Modifier +import WithCli.Parser +import WithCli.Normalize +import WithCli.Argument +import WithCli.Result + +parseArgumentResult :: forall a . Argument a => Maybe String -> String -> Result a +parseArgumentResult mMsg s = case parseArgument s of + Just x -> return x + Nothing -> parseError (argumentType (Proxy :: Proxy a)) mMsg s + +parseError :: String -> Maybe String -> String -> Result a +parseError typ mMsg s = Errors $ pure $ + "cannot parse as " ++ typ ++ + maybe "" (\ msg -> " (" ++ msg ++ ")") mMsg ++ + ": " ++ s + +-- | Everything that can be used as an argument to your @main@ function +-- (see 'withCli') needs to have a 'HasArguments' instance. +-- +-- 'HasArguments' also allows to conjure up instances for record types +-- to create more complex command line interfaces. Here's an example: + +-- ### Start "docs/SimpleRecord.hs" "module SimpleRecord where\n\n" Haddock ### + +-- | +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import qualified GHC.Generics +-- > import System.Console.GetOpt.Generics +-- > +-- > data Options +-- > = Options { +-- > port :: Int, +-- > daemonize :: Bool, +-- > config :: Maybe FilePath +-- > } +-- > deriving (Show, GHC.Generics.Generic) +-- > +-- > instance Generic Options +-- > instance HasDatatypeInfo Options +-- > instance HasArguments Options +-- > +-- > main :: IO () +-- > main = withCli run +-- > +-- > run :: Options -> IO () +-- > run = print + +-- ### End ### + +-- | In a shell this program behaves like this: + +-- ### Start "docs/SimpleRecord.shell-protocol" "" Haddock ### + +-- | +-- > $ program --port 8080 --config some/path +-- > Options {port = 8080, daemonize = False, config = Just "some/path"} +-- > $ program --port 8080 --daemonize +-- > Options {port = 8080, daemonize = True, config = Nothing} +-- > $ program --port foo +-- > cannot parse as INTEGER: foo +-- > # exit-code 1 +-- > $ program +-- > missing option: --port=INTEGER +-- > # exit-code 1 +-- > $ program --help +-- > program [OPTIONS] +-- > --port=INTEGER +-- > --daemonize +-- > --config=STRING (optional) +-- > -h --help show help and exit + +-- ### End ### + +class HasArguments a where + argumentsParser :: Modifiers -> Maybe String -> Result (Parser Unnormalized a) + default argumentsParser :: + (SOP.Generic a, SOP.HasDatatypeInfo a, All2 HasArguments (Code a)) => + Modifiers -> + Maybe String -> Result (Parser Unnormalized a) + argumentsParser = const . genericParser + +-- * atomic HasArguments + +instance HasArguments Int where + argumentsParser = atomicArgumentsParser + +instance HasArguments Bool where + argumentsParser = wrapForPositionalArguments "Bool" (const boolParser) + +instance HasArguments String where + argumentsParser = atomicArgumentsParser + +instance HasArguments Float where + argumentsParser = atomicArgumentsParser + +instance HasArguments Double where + argumentsParser = atomicArgumentsParser + +instance (HasArguments a, HasArguments b) => HasArguments (a, b) + +instance (HasArguments a, HasArguments b, HasArguments c) => HasArguments (a, b, c) + +wrapForPositionalArguments :: String -> (Modifiers -> Maybe String -> Result a) -> (Modifiers -> Maybe String -> Result a) +wrapForPositionalArguments typ wrapped modifiers (Just field) = + if isPositionalArgumentsField modifiers field + then Errors ["UseForPositionalArguments can only be used for fields of type [String] not " ++ typ] + else wrapped modifiers (Just field) +wrapForPositionalArguments _ wrapped modifiers Nothing = wrapped modifiers Nothing + +instance Argument a => HasArguments (Maybe a) where + argumentsParser _ = maybeParser + +instance Argument a => HasArguments [a] where + argumentsParser modifiers (Just field) = + return $ if isPositionalArgumentsField modifiers field + then positionalArgumentsParser + else listParser (Just field) + argumentsParser _ Nothing = + return $ listParser Nothing + +-- | Useful for implementing your own instances of 'HasArguments' on top +-- of a custom 'Argument' instance. +atomicArgumentsParser :: forall a . Argument a => + Modifiers -> + Maybe String -> Result (Parser Unnormalized a) +atomicArgumentsParser = + wrapForPositionalArguments typ inner + where + typ = argumentType (Proxy :: Proxy a) + + inner modifiers mLong = return $ case mLong of + Nothing -> withoutLongOption + Just long -> withLongOption modifiers long + + withoutLongOption = Parser { + parserDefault = Nothing, + parserOptions = [], + parserNonOptions = + [NonOptionsParser typ (\ (s : r) -> fmap ((, r) . const . Just) $ parseArgumentResult Nothing s)], + parserConvert = \ case + Just a -> return a + Nothing -> Errors $ pure $ + "missing argument of type " ++ typ + } + + withLongOption modifiers long = Parser { + parserDefault = Left (), + parserOptions = pure $ + Option [] [long] + (fmap (fmap (const . Right)) $ + ReqArg (parseArgumentResult Nothing) typ) + "", + parserNonOptions = [], + parserConvert = \ case + Right a -> return a + Left () -> Errors $ pure $ + "missing option: --" ++ normalize (applyModifiersLong modifiers long) ++ "=" ++ typ + } + +listParser :: forall a . Argument a => + Maybe String -> Parser Unnormalized [a] +listParser mLong = case mLong of + Nothing -> positionalArgumentsParser + Just long -> Parser { + parserDefault = [], + parserOptions = pure $ + Option [] [long] + (ReqArg + (\ s -> fmap (\ a -> (++ [a])) (parseArgumentResult (Just "multiple possible") s)) + (argumentType (Proxy :: Proxy a) ++ " (multiple possible)")) + "", + parserNonOptions = [], + parserConvert = return + } + +positionalArgumentsParser :: forall a . Argument a => + Parser Unnormalized [a] +positionalArgumentsParser = Parser { + parserDefault = [], + parserOptions = [], + parserNonOptions = [NonOptionsParser (argumentType (Proxy :: Proxy a)) parse], + parserConvert = return +} + where + parse :: [String] -> Result ([a] -> [a], [String]) + parse args = do + mods <- forM args $ \ arg -> + case parseArgument arg of + Just a -> return (a :) + Nothing -> parseError (argumentType (Proxy :: Proxy a)) Nothing arg + return (foldl' (.) id mods, []) + +maybeParser :: forall a . Argument a => + Maybe String -> Result (Parser Unnormalized (Maybe a)) +maybeParser mLong = case mLong of + Nothing -> Errors ["cannot use Maybes for positional arguments"] + Just long -> return $ Parser { + parserDefault = Nothing, + parserOptions = pure $ + Option [] [long] + (ReqArg + (\ s -> fmap (\ a -> (const (Just a))) (parseArgumentResult (Just "optional") s)) + (argumentType (Proxy :: Proxy a) ++ " (optional)")) + "", + parserNonOptions = [], + parserConvert = return + } + +boolParser :: Maybe String -> Result (Parser Unnormalized Bool) +boolParser mLong = return $ case mLong of + Nothing -> Parser { + parserDefault = Nothing, + parserOptions = [], + parserNonOptions = pure $ + (NonOptionsParser "BOOL" (\ (s : r) -> (, r) <$> maybe (parseError "BOOL" Nothing s) (return . const . Just) (parseBool s))), + parserConvert = \ case + Just x -> return x + Nothing -> Errors $ pure $ + "missing argument of type BOOL" + } + Just long -> Parser { + parserDefault = False, + parserOptions = pure $ + Option [] [long] + (NoArg (return (const True))) + "", + parserNonOptions = [], + parserConvert = return + } + +parseBool :: String -> Maybe Bool +parseBool s + | map toLower s `elem` ["true", "yes", "on"] = Just True + | map toLower s `elem` ["false", "no", "off"] = Just False + | otherwise = case readMaybe s of + Just (n :: Integer) -> Just (n > 0) + Nothing -> Nothing + +-- * generic HasArguments + +genericParser :: forall a . + (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) => + Modifiers -> + Result (Parser Unnormalized a) +genericParser modifiers = fmap (fmap to) $ case datatypeInfo (Proxy :: Proxy a) of + ADT _ typeName (constructorInfo :* Nil) -> + case constructorInfo of + (Record _ fields) -> + fmap (fmap (SOP . Z)) (fieldsParser modifiers fields) + Constructor{} -> + fmap (fmap (SOP . Z)) (noSelectorsParser modifiers shape) + Infix{} -> + err typeName "infix constructors" + ADT _ typeName Nil -> + err typeName "empty data types" + ADT _ typeName (_ :* _ :* _) -> + err typeName "sum types" + Newtype _ _ (Record _ fields) -> + fmap (fmap (SOP . Z)) (fieldsParser modifiers fields) + Newtype _ typeName (Constructor _) -> + err typeName "constructors without field labels" + where + err typeName message = Errors $ pure $ + "getopt-generics doesn't support " ++ message ++ + " (" ++ typeName ++ ")." + +fieldsParser :: All HasArguments xs => + Modifiers -> NP FieldInfo xs -> Result (Parser Unnormalized (NP I xs)) +fieldsParser modifiers = \ case + Nil -> return $ emptyParser Nil + FieldInfo fieldName :* rest -> + fmap (fmap (\ (a, r) -> a :* r)) $ + combine (fmap (fmap I) $ (argumentsParser modifiers (Just fieldName))) (fieldsParser modifiers rest) + +noSelectorsParser :: All HasArguments xs => + Modifiers -> Shape xs -> Result (Parser Unnormalized (NP I xs)) +noSelectorsParser modifiers = \ case + ShapeNil -> return $ emptyParser Nil + ShapeCons rest -> + fmap (fmap (\ (a, r) -> a :* r)) $ + combine (fmap (fmap I) $ (argumentsParser modifiers Nothing)) (noSelectorsParser modifiers rest) diff --git a/src/WithCli/Normalize.hs b/src/WithCli/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/WithCli/Normalize.hs @@ -0,0 +1,32 @@ + +module WithCli.Normalize ( + normalize, + matches, + ) where + +import Data.Char + +matches :: String -> String -> Bool +matches a b = + normalize a == normalize b + +normalize :: String -> String +normalize s = + if all (not . isAllowedChar) s + then s + else + slugify $ + dropWhile (== '-') $ + filter isAllowedChar $ + map (\ c -> if c == '_' then '-' else c) $ + s + where + slugify (a : r) + | isUpper a = slugify (toLower a : r) + slugify (a : b : r) + | isUpper b = a : '-' : slugify (toLower b : r) + | otherwise = a : slugify (b : r) + slugify x = x + +isAllowedChar :: Char -> Bool +isAllowedChar c = (isAscii c && isAlphaNum c) || (c `elem` "-_") diff --git a/src/WithCli/Parser.hs b/src/WithCli/Parser.hs new file mode 100644 --- /dev/null +++ b/src/WithCli/Parser.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module WithCli.Parser where + +import Data.Orphans () +import Prelude () +import Prelude.Compat + +import Control.Arrow +import Control.Monad +import System.Console.GetOpt as Base + +import System.Console.GetOpt.Generics.Modifier.Types +import WithCli.Flag +import WithCli.Normalize +import WithCli.Result + +data NonOptionsParser uninitialized = + NonOptionsParser { + nonOptionsType :: String, + nonOptionsParser :: [String] -> Result (uninitialized -> uninitialized, [String]) + } + +combineNonOptionsParser :: [NonOptionsParser u] -> [NonOptionsParser v] + -> [NonOptionsParser (u, v)] +combineNonOptionsParser a b = + map (modMod first) a ++ + map (modMod second) b + where + modMod :: ((a -> a) -> (b -> b)) -> NonOptionsParser a -> NonOptionsParser b + modMod f (NonOptionsParser field parser) = + NonOptionsParser field (fmap (fmap (first f)) parser) + +data Parser phase a where + Parser :: { + parserDefault :: uninitialized, + parserOptions :: [OptDescr (Result (uninitialized -> uninitialized))], + parserNonOptions :: [NonOptionsParser uninitialized], + parserConvert :: uninitialized -> Result a + } -> Parser phase a + +instance Functor (Parser phase) where + fmap f (Parser def options nonOptions convert) = + Parser def options nonOptions (fmap f . convert) + +-- phases: +data Unnormalized +data Normalized + +emptyParser :: a -> Parser phase a +emptyParser a = Parser { + parserDefault = a, + parserOptions = [], + parserNonOptions = [], + parserConvert = return +} + +normalizeParser :: Parser Unnormalized a -> Parser Normalized a +normalizeParser (Parser d options nonOptions convert) = + Parser d (map (mapLongOptions normalize) options) nonOptions convert + where + mapLongOptions :: (String -> String) -> OptDescr a -> OptDescr a + mapLongOptions f (Option shorts longs argDescr help) = + Option shorts (map f longs) argDescr help + +modParserOptions :: (forall x . [OptDescr (Result x)] -> [OptDescr (Result x)]) + -> Parser Unnormalized a -> Parser Unnormalized a +modParserOptions f (Parser def options nonOptions convert) = + Parser def (f options) nonOptions convert + +combine :: forall a b phase . + Result (Parser phase a) -> Result (Parser phase b) + -> Result (Parser phase (a, b)) +combine a b = inner <$> a <*> b + where + inner :: Parser phase a -> Parser phase b -> Parser phase (a, b) + inner (Parser defaultA optionsA nonOptionsA convertA) (Parser defaultB optionsB nonOptionsB convertB) = + Parser { + parserDefault = (defaultA, defaultB), + parserOptions = + map (fmap (fmap first)) optionsA ++ map (fmap (fmap second)) optionsB, + parserNonOptions = combineNonOptionsParser nonOptionsA nonOptionsB, + parserConvert = + \ (u, v) -> (,) <$> (convertA u) <*> (convertB v) + } + +fillInOptions :: [Result (u -> u)] -> u -> Result u +fillInOptions [] u = return u +fillInOptions (option : options) u = do + f <- option + fillInOptions options (f u) + +fillInNonOptions :: [[String] -> Result (u -> u, [String])] -> [String] -> u + -> Result u +fillInNonOptions (parser : parsers) nonOptions@(_ : _) u = do + (p, rest) <- parser nonOptions + fillInNonOptions parsers rest (p u) +fillInNonOptions [] [] u = + return u +fillInNonOptions [] nonOptions _ = + Errors (map ("unknown argument: " ++) nonOptions) +fillInNonOptions _ [] u = return u + +runParser :: String -> Modifiers -> Parser Normalized a -> [String] -> Result a +runParser progName modifiers Parser{..} args = do + let versionOptions = maybe [] + (\ v -> pure $ versionOption (progName ++ " version " ++ v)) + (getVersion modifiers) + options = map (fmap NoHelp) parserOptions ++ [helpOption] ++ versionOptions + (flags, nonOptions, errs) = + Base.getOpt Base.Permute options args + case foldFlags flags of + Help -> OutputAndExit $ + let fields = case getPositionalArgumentType modifiers of + Nothing -> map nonOptionsType parserNonOptions + Just typ -> ["[" ++ typ ++ "]"] + in usage progName fields (map void options) + Version msg -> OutputAndExit msg + NoHelp innerFlags -> + reportErrors errs *> + (fillInOptions innerFlags parserDefault >>= + fillInNonOptions (map nonOptionsParser parserNonOptions) nonOptions >>= + parserConvert) + where + reportErrors :: [String] -> Result () + reportErrors = \ case + [] -> return () + errs -> Errors errs diff --git a/src/WithCli/Result.hs b/src/WithCli/Result.hs new file mode 100644 --- /dev/null +++ b/src/WithCli/Result.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ViewPatterns #-} + +module WithCli.Result ( + Result(..), + handleResult, + sanitize, + ) where + +import Prelude () +import Prelude.Compat + +import Control.Arrow +import Data.List.Compat +import System.Exit +import System.IO + +-- | Type to wrap results from the pure parsing functions. +data Result a + = Success a + -- ^ The CLI was used correctly and a value of type @a@ was + -- successfully constructed. + | Errors [String] + -- ^ The CLI was used incorrectly. The 'Result' contains a list of error + -- messages. + -- + -- It can also happen that the data type you're trying to use isn't + -- supported. See the + -- for + -- details. + | OutputAndExit String + -- ^ The CLI was used with @--help@. The 'Result' contains the help message. + deriving (Show, Eq, Ord, Functor) + +instance Applicative Result where + pure = Success + OutputAndExit message <*> _ = OutputAndExit message + _ <*> OutputAndExit message = OutputAndExit message + Success f <*> Success x = Success (f x) + Errors a <*> Errors b = Errors (a ++ b) + Errors errs <*> Success _ = Errors errs + Success _ <*> Errors errs = Errors errs + +instance Monad Result where + return = pure + Success a >>= b = b a + Errors errs >>= _ = Errors errs + OutputAndExit message >>= _ = OutputAndExit message + + (>>) = (*>) + +handleResult :: Result a -> IO a +handleResult result = case result of + Success a -> return a + OutputAndExit message -> do + putStr $ sanitize message + exitWith ExitSuccess + Errors errs -> do + hPutStr stderr $ sanitize $ intercalate "\n" errs + exitWith $ ExitFailure 1 + +sanitize :: String -> String +sanitize = + lines >>> + map stripTrailingSpaces >>> + filter (not . null) >>> + map (++ "\n") >>> + concat + +stripTrailingSpaces :: String -> String +stripTrailingSpaces = + reverse . inner . dropWhile (`elem` [' ', '\n']) . reverse + where + inner s = case s of + ('\n' : ' ' : r) -> inner ('\n' : r) + (a : r) -> a : inner r + [] -> [] diff --git a/test/BashProtocol.hs b/test/BashProtocol.hs deleted file mode 100644 --- a/test/BashProtocol.hs +++ /dev/null @@ -1,44 +0,0 @@ - -module BashProtocol (testBashProtocol) where - -import Control.Exception -import Control.Monad -import Data.List -import System.Environment.Compat -import System.FilePath -import System.IO -import System.IO.Silently -import System.Process -import Test.Hspec - -testBashProtocol :: FilePath -> String -> IO () -testBashProtocol program bashProtocol = do - assert (takeFileName program == "program") (return ()) - let protocol = parseProtocol bashProtocol - testProtocol (takeDirectory program) protocol - -data Protocol - = Protocol { - _command :: String, - _expected :: [String] - } - deriving (Show) - -parseProtocol :: String -> [Protocol] -parseProtocol = inner . lines - where - inner :: [String] -> [Protocol] - inner [] = [] - inner (('$' : ' ' : command) : rest) = - let (expected, next) = span (not . ("$ " `isPrefixOf`)) rest in - Protocol command expected : inner next - inner lines = error ("parseProtocol: cannot parse: " ++ show lines) - -testProtocol :: FilePath -> [Protocol] -> IO () -testProtocol programDir protocol = do - path <- getEnv "PATH" - setEnv "PATH" (programDir ++ ":" ++ path) - forM_ protocol $ \ (Protocol command expected) -> do - hPutStrLn stderr ("running: " ++ command) - output <- hCapture_ [stdout, stderr] $ system command - output `shouldBe` unlines expected diff --git a/test/Examples.hs b/test/Examples.hs deleted file mode 100644 --- a/test/Examples.hs +++ /dev/null @@ -1,57 +0,0 @@ - -import Prelude () -import Prelude.Compat - -import Control.Monad -import Data.List -import System.Directory -import System.Exit.Compat -import System.FilePath -import System.IO.Temp -import System.Process -import Test.Hspec - -import BashProtocol - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - files <- runIO $ - map ("docs" ) <$> - filter ((".hs" ==) . takeExtension) <$> - sort <$> - getDirectoryContents "docs" - - forM_ files $ \ file -> do - describe "docs directory ghc" $ do - it ("compile and run " ++ file) $ do - withSystemTempDirectory "getopt-generics-test" $ \ tempDir -> do - compile tempDir file >>= execute file - -compile :: FilePath -> FilePath -> IO FilePath -compile tempDir file = do - let program = tempDir "program" - callCommandCompat $ "cabal exec -- ghc " ++ file ++ - " -outputdir " ++ (tempDir "build") ++ - " -o " ++ program ++ - " -isrc -O0" ++ - " -Wall -Werror -fno-warn-unused-binds -fno-warn-name-shadowing" - return program - -execute :: FilePath -> FilePath -> IO () -execute haskellFile program = do - let bashProtocolFile = dropExtension haskellFile <.> "bash-protocol" - exists <- doesFileExist bashProtocolFile - if not exists - then callCommandCompat $ program ++ " --help" - else do - testBashProtocol program =<< readFile bashProtocolFile - -callCommandCompat :: String -> IO () -callCommandCompat command = do - exitCode <- system command - case exitCode of - ExitSuccess -> return () - failure@ExitFailure{} -> exitWith failure diff --git a/test/ExamplesSpec.hs b/test/ExamplesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ExamplesSpec.hs @@ -0,0 +1,51 @@ + +module ExamplesSpec where + +import Prelude () +import Prelude.Compat + +import Control.Monad +import System.FilePath +import Test.Hspec + +import ShellProtocol + +import qualified CustomOption +import qualified CustomOptionRecord +import qualified RecordType +import qualified Simple +import qualified SimpleRecord +import qualified Test01 +import qualified Test02 +import qualified Test03 +import qualified Test04 + +examples :: [(IO (), String)] +examples = + (Test01.main, "Test01") : + (Test02.main, "Test02") : + (Test03.main, "Test03") : + (Test04.main, "Test04") : + + (Simple.main, "Simple") : + (SimpleRecord.main, "SimpleRecord") : + (RecordType.main, "RecordType") : + (SimpleRecord.main, "SimpleRecord") : + (CustomOption.main, "CustomOption") : + (CustomOptionRecord.main, "CustomOptionRecord") : + [] + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "shell protocols" $ do + forM_ examples $ \ (program, name) -> + it name $ do + test program name + +test :: IO () -> String -> IO () +test program name = do + protocol <- readFile ("docs" name <.> "shell-protocol") + testShellProtocol program protocol diff --git a/test/ModifiersSpec.hs b/test/ModifiersSpec.hs --- a/test/ModifiersSpec.hs +++ b/test/ModifiersSpec.hs @@ -13,7 +13,7 @@ spec = do describe "AddShortOption" $ do it "allows modifiers for short options" $ do - modsParse [AddShortOption "camel-case" 'x'] "-x foo" + modsParse [AddShortOption "camelCase" 'x'] "-x foo" `shouldBe` Success (CamelCaseOptions "foo") it "allows modifiers in camelCase" $ do @@ -39,19 +39,17 @@ it "disregards the earlier renaming" $ do let Errors errs = parse' "--foo foo" - errs `shouldContain` ["unrecognized option `--foo'"] + errs `shouldContain` ["unrecognized option `--foo'\n"] it "contains renamed options in error messages" $ do let Errors errs = modsParse [RenameOption "camelCase" "foo"] "" :: Result CamelCaseOptions + -- _ <- error $ show errs show errs `shouldNotContain` "camelCase" + show errs `shouldNotContain` "camel-case" show errs `shouldContain` "foo" - it "allows to address fields in Modifiers in slugified form" $ do - modsParse [RenameOption "camel-case" "foo"] "--foo bar" - `shouldBe` Success (CamelCaseOptions "bar") - it "" $ do modsParse [RenameOption "bar" "one", RenameOption "baz" "two"] "--one 1 --two foo" `shouldBe` Success (Foo (Just 1) "foo" False) @@ -59,7 +57,7 @@ describe "AddVersionFlag" $ do it "implements --version" $ do let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--version" :: Result Foo - output `shouldBe` "prog-name version 1.0.0\n" + output `shouldBe` "prog-name version 1.0.0" it "--help takes precedence over --version" $ do let OutputAndExit output = modsParse [AddVersionFlag "1.0.0"] "--version --help" :: Result Foo diff --git a/test/ModifiersSpec/UseForPositionalArgumentsSpec.hs b/test/ModifiersSpec/UseForPositionalArgumentsSpec.hs --- a/test/ModifiersSpec/UseForPositionalArgumentsSpec.hs +++ b/test/ModifiersSpec/UseForPositionalArgumentsSpec.hs @@ -1,9 +1,11 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} module ModifiersSpec.UseForPositionalArgumentsSpec where import Data.List import qualified GHC.Generics as GHC +import System.Environment import Test.Hspec import System.Console.GetOpt.Generics @@ -43,7 +45,7 @@ [UseForPositionalArguments "positionalArguments" "type"] "--positional-arguments foo" `shouldBe` - (Errors ["unrecognized option `--positional-arguments'"] + (Errors ["unrecognized option `--positional-arguments'\n"] :: Result WithPositionalArguments) it "complains about fields that don't have type [String]" $ do @@ -67,3 +69,14 @@ [] (modsParse modifiers [] :: Result WithMultiplePositionalArguments) `shouldBe` Errors ["UseForPositionalArguments can only be used once"] + + context "when used without selector" $ do + it "automatically uses positional arguments for [Int]" $ do + withArgs (words "1 2 3") $ + withCli $ \ (xs :: [Int]) -> do + xs `shouldBe` [1, 2, 3] + + it "automatically uses positional arguments for [String]" $ do + withArgs (words "foo bar") $ + withCli $ \ (xs :: [String]) -> do + xs `shouldBe` (words "foo bar") diff --git a/test/ShellProtocol.hs b/test/ShellProtocol.hs new file mode 100644 --- /dev/null +++ b/test/ShellProtocol.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module ShellProtocol (testShellProtocol) where + +import Control.Exception +import Control.Monad +import Data.List +import System.Environment +import System.Exit +import System.IO +import System.IO.Silently +import Test.Hspec + +testShellProtocol :: IO () -> String -> IO () +testShellProtocol program shellProtocol = do + let protocol = parseProtocol shellProtocol + testProtocol program protocol + +data Protocol + = Protocol { + _args :: [String], + _expected :: [String] + } + deriving (Show) + +parseProtocol :: String -> [Protocol] +parseProtocol = inner . lines + where + inner :: [String] -> [Protocol] + inner [] = [] + inner ((words -> "$" : "program" : args) : rest) = + let (expected, next) = span (not . ("$ " `isPrefixOf`)) rest in + Protocol args expected : inner next + inner lines = error ("parseProtocol: cannot parse: " ++ show lines) + +testProtocol :: IO () -> [Protocol] -> IO () +testProtocol program protocol = do + forM_ protocol $ \ (Protocol args expected) -> do + output <- hCapture_ [stdout, stderr] $ + handle (\ (e :: ExitCode) -> printExitCode e) $ + withArgs args $ + withProgName "program" $ + program + output `shouldBe` unlines expected + +printExitCode :: ExitCode -> IO () +printExitCode e = case e of + ExitFailure n -> hPutStrLn stderr ("# exit-code " ++ show n) + ExitSuccess -> return () diff --git a/test/System/Console/GetOpt/Generics/FieldStringSpec.hs b/test/System/Console/GetOpt/Generics/FieldStringSpec.hs deleted file mode 100644 --- a/test/System/Console/GetOpt/Generics/FieldStringSpec.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module System.Console.GetOpt.Generics.FieldStringSpec where - -import Data.Char -import Test.Hspec -import Test.QuickCheck hiding (Success) - -import System.Console.GetOpt.Generics.FieldString - -normalize :: String -> String -normalize = normalized . mkFieldString - -isValidInputChar :: Char -> Bool -isValidInputChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-_" - -isAllowedOutputChar :: Char -> Bool -isAllowedOutputChar c = c `elem` ['a' .. 'z'] ++ ['0' .. '9'] ++ "-" - -upperCaseChar :: Gen Char -upperCaseChar = elements ['A' .. 'Z'] - -spec :: Spec -spec = do - describe "normalized" $ do - it "is idempotent" $ do - property $ \ x -> do - let once = normalize x - twice = normalize once - once `shouldBe` twice - - it "replaces underscores with dashes" $ do - normalize "foo_bar" `shouldBe` "foo-bar" - - it "doesn't modify digits" $ do - normalize "foo2bar" `shouldBe` "foo2bar" - - it "when there's one valid character it returns only dashes and lower case characters" $ do - property $ \ x -> - any isValidInputChar x ==> - normalize x `shouldSatisfy` - (\ s -> all isAllowedOutputChar s) - - it "when there are no valid characters it returns its input" $ do - property $ forAll (listOf (arbitrary `suchThat` (not . isValidInputChar))) $ \ x -> - normalize x `shouldBe` x - - it "replaces camelCase with dashes" $ do - let isValidPrefixChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z'] - property $ - \ prefix suffix -> - (any isValidPrefixChar prefix) ==> - forAll upperCaseChar $ \ upper -> - counterexample (prefix ++ [upper] ++ suffix) $ - normalize (prefix ++ [upper] ++ suffix) - `shouldBe` - normalize prefix ++ "-" ++ normalize (toLower upper : suffix) - - describe "matches" $ do - it "matches normalized strings" $ do - property $ \ s -> - normalize s `matches` mkFieldString s - - it "matches unnormalized strings" $ do - property $ \ s -> - s `matches` mkFieldString s - - describe "renameUnnormalized" $ do - it "allows to rename the unnormalized field names" $ do - let f "camelCaseFoo" = Just "caseFoo" - f _ = Nothing - normalized (renameUnnormalized f (mkFieldString "camelCaseFoo")) `shouldBe` - "case-foo" - - it "doesn't allow to rename normalized field names" $ do - let f "camel-case-foo" = Just "case-foo" - f _ = Nothing - normalized (renameUnnormalized f (mkFieldString "camelCaseFoo")) `shouldBe` - "camel-case-foo" diff --git a/test/System/Console/GetOpt/Generics/ModifierSpec.hs b/test/System/Console/GetOpt/Generics/ModifierSpec.hs --- a/test/System/Console/GetOpt/Generics/ModifierSpec.hs +++ b/test/System/Console/GetOpt/Generics/ModifierSpec.hs @@ -2,34 +2,15 @@ module System.Console.GetOpt.Generics.ModifierSpec where -import Data.Char -import Data.Proxy import qualified GHC.Generics import Generics.SOP import Test.Hspec -import Test.QuickCheck hiding (Result(..)) -import System.Console.GetOpt.Generics.GetArguments import System.Console.GetOpt.Generics.Modifier -import System.Console.GetOpt.Generics.Result +import Util spec :: Spec spec = do - describe "deriveShortOptions" $ do - it "includes modifiers for short options" $ do - let [AddShortOption long short] = deriveShortOptions (Proxy :: Proxy Foo) - (long, short) `shouldBe` ("bar", 'b') - - it "doesn't include modifiers for short options in case of overlaps" $ do - null (deriveShortOptions (Proxy :: Proxy Overlap)) - - describe "mkShortModifiers" $ do - it "returns only lower-case ascii alpha characters as short options" $ do - property $ \ strings -> - all - (\ (AddShortOption _ c) -> isLower c && isAscii c && isAlpha c) - (mkShortModifiers strings) - describe "insertWith" $ do it "combines existing values with the given function" $ do insertWith (++) (1 :: Integer) "bar" [(1, "foo")] @@ -37,16 +18,8 @@ describe "getVersion" $ do it "returns the version" $ do - let modifiers = mkModifiers [AddVersionFlag "1.0.0"] + let modifiers = unsafeModifiers [AddVersionFlag "1.0.0"] getVersion modifiers `shouldBe` Just "1.0.0" - - context "when used with Modifiers" $ do - describe "parseArguments" $ do - it "allows to specify a flag specific help" $ do - let OutputAndExit output = - parseArguments "prog-name" [AddOptionHelp "bar" "bar help text"] - (words "--help") :: Result Foo - output `shouldContain` "--bar=STRING bar help text" data Foo = Foo { diff --git a/test/System/Console/GetOpt/Generics/ResultSpec.hs b/test/System/Console/GetOpt/Generics/ResultSpec.hs deleted file mode 100644 --- a/test/System/Console/GetOpt/Generics/ResultSpec.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module System.Console.GetOpt.Generics.ResultSpec where - -import Control.Exception -import Data.List -import System.Exit -import System.IO -import System.IO.Silently -import Test.Hspec -import Test.QuickCheck hiding (Result(..)) - -import System.Console.GetOpt.Generics.Result - -spec :: Spec -spec = do - describe "Result" $ do - context ">>" $ do - it "collects errors" $ do - (Errors ["foo"] >> Errors ["bar"] :: Result ()) - `shouldBe` Errors ["foo", "bar"] - - describe "errors" $ do - it "removes trailing newlines" $ do - (errors ["foo\n", "bar", "baz\n"] :: Result ()) `shouldBe` - Errors ["foo", "bar", "baz"] - - describe "outputAndExit" $ do - it "removes trailing spaces" $ do - (outputAndExit "foo \nbar" :: Result ()) `shouldBe` - OutputAndExit "foo\nbar" - - it "removes trailing spaces at the end" $ do - (outputAndExit "foo " :: Result ()) `shouldBe` - OutputAndExit "foo" - - it "quickcheck" $ do - property $ \ s -> - let OutputAndExit output = outputAndExit s - in output `shouldSatisfy` (not . (" \n" `isInfixOf`)) - - it "only strips spaces" $ do - property $ \ s -> - let OutputAndExit output = outputAndExit s - in - filter (/= ' ') output - `shouldBe` - filter (/= ' ') s - - describe "handleResult" $ do - it "appends '\\n' at the end of error messages if missing" $ do - output <- hCapture_ [stderr] $ do - handle (\ (_ :: ExitCode) -> return ()) $ do - _ <- handleResult (Errors ["foo", "bar\n", "baz"]) - return () - output `shouldBe` "foo\nbar\nbaz\n" - - context "OutputAndExit" $ do - it "throws ExitSuccess" $ do - handleResult (OutputAndExit "foo") - `shouldThrow` (== ExitSuccess) - - context "Errors" $ do - it "throws an ExitFailure" $ do - handleResult (Errors ["foo"]) - `shouldThrow` (== ExitFailure 1) diff --git a/test/System/Console/GetOpt/Generics/SimpleSpec.hs b/test/System/Console/GetOpt/Generics/SimpleSpec.hs deleted file mode 100644 --- a/test/System/Console/GetOpt/Generics/SimpleSpec.hs +++ /dev/null @@ -1,64 +0,0 @@ - -module System.Console.GetOpt.Generics.SimpleSpec where - -import System.Environment -import System.Exit -import System.IO -import System.IO.Silently -import Test.Hspec - -import System.Console.GetOpt.Generics.Simple - -spec :: Spec -spec = do - describe "simpleCLI" $ do - context "no arguments" $ do - it "executes the operation in case of no command line arguments" $ do - let main :: IO () - main = putStrLn "success" - (capture_ $ withArgs [] $ simpleCLI main) - `shouldReturn` "success\n" - - it "produces nice error messages" $ do - let main :: IO () - main = putStrLn "success" - output <- hCapture_ [stderr] (withArgs ["foo"] (simpleCLI main) `shouldThrow` (== ExitFailure 1)) - output `shouldBe` "unknown argument: foo\n" - - context "1 argument" $ do - it "creates CLIs for unary IO operations" $ do - let main :: String -> IO () - main s = putStrLn ("success: " ++ s) - (capture_ $ withArgs ["foo"] $ simpleCLI main) - `shouldReturn` "success: foo\n" - - it "parses Ints" $ do - let main :: Int -> IO () - main n = putStrLn ("success: " ++ show n) - (capture_ $ withArgs ["12"] $ simpleCLI main) - `shouldReturn` "success: 12\n" - - it "error parsing" $ do - let main :: Int -> IO () - main n = putStrLn ("error: " ++ show n) - output <- hCapture_ [stderr] (withArgs (words "12 foo") (simpleCLI main) `shouldThrow` (== ExitFailure 1)) - output `shouldBe` "unknown argument: foo\n" - - it "offers --help" $ do - let main :: Int -> IO () - main n = putStrLn ("error: " ++ show n) - output <- capture_ (withArgs ["--help"] (simpleCLI main) `shouldThrow` (== ExitSuccess)) - output `shouldContain` "[OPTIONS] INTEGER" - output `shouldContain` "-h --help show help and exit" - - it "works for IO operations with 2 arguments" $ do - let main :: Int -> Bool -> IO () - main n b = putStrLn ("success: " ++ show (n, b)) - (capture_ $ withArgs (words "42 yes") $ simpleCLI main) - `shouldReturn` "success: (42,True)\n" - - it "works for IO operations with 3 arguments" $ do - let main :: String -> Int -> Bool -> IO () - main s n b = putStrLn ("success: " ++ show (s, n, b)) - (capture_ $ withArgs (words "foo 42 yes") $ simpleCLI main) - `shouldReturn` "success: (\"foo\",42,True)\n" diff --git a/test/System/Console/GetOpt/GenericsSpec.hs b/test/System/Console/GetOpt/GenericsSpec.hs --- a/test/System/Console/GetOpt/GenericsSpec.hs +++ b/test/System/Console/GetOpt/GenericsSpec.hs @@ -8,16 +8,19 @@ import Prelude () import Prelude.Compat +import Control.Exception import Data.Foldable (forM_) import Data.List (isPrefixOf, isSuffixOf) -import Data.Typeable import qualified GHC.Generics as GHC import System.Environment +import System.Exit +import System.IO +import System.IO.Silently import Test.Hspec -import Test.QuickCheck hiding (Result(..)) import System.Console.GetOpt.Generics import Util +import WithCli.Result spec :: Spec spec = do @@ -26,7 +29,6 @@ part3 part4 part5 - part6 data Foo = Foo { @@ -63,11 +65,15 @@ parse "--bool --baz foo" `shouldBe` Success (Foo Nothing "foo" True) + it "allows to overwrite String options" $ do + parse "--baz one --baz two" + `shouldBe` Success (Foo Nothing "two" False) + context "with invalid arguments" $ do it "prints out an error" $ do let Errors messages = parse "--no-such-option" :: Result Foo messages `shouldBe` - ["unrecognized option `--no-such-option'", + ["unrecognized option `--no-such-option'\n", "missing option: --baz=STRING"] it "prints errors for missing options" $ do @@ -101,8 +107,11 @@ output `shouldContain` "show help and exit" it "does not contain trailing spaces" $ do - let OutputAndExit output = parse "--help" :: Result Foo - forM_ (lines output) $ \ line -> + output <- + hCapture_ [stdout] $ + handle (\ ExitSuccess -> return ()) $ + handleResult $ ((parse "--help" :: Result Foo) >> return ()) + forM_ (lines output) $ \ line -> do line `shouldSatisfy` (not . (" " `isSuffixOf`)) it "complains when the options datatype is not allowed" $ do @@ -113,11 +122,6 @@ let OutputAndExit output = parse "--help" :: Result Foo output `shouldSatisfy` ("prog-name [OPTIONS]\n" `isPrefixOf`) - describe "parseArguments" $ do - it "allows to overwrite String options" $ do - parse "--baz one --baz two" - `shouldBe` Success (Foo Nothing "two" False) - data ListOptions = ListOptions { multiple :: [Int] @@ -182,39 +186,6 @@ parse "--with-underscore foo" `shouldBe` Success (WithUnderscore "foo") -data CustomFields - = CustomFields { - custom :: Custom, - customList :: [Custom], - customMaybe :: Maybe Custom - } - deriving (GHC.Generic, Show, Eq) - -instance Generic CustomFields -instance HasDatatypeInfo CustomFields - -data Custom - = CFoo - | CBar - | CBaz - deriving (Show, Eq, Typeable) - -instance Option Custom where - argumentType Proxy = "custom" - parseArgument x = case x of - "foo" -> Just CFoo - "bar" -> Just CBar - "baz" -> Just CBaz - _ -> Nothing - -part5 :: Spec -part5 = do - describe "parseArguments" $ do - context "CustomFields" $ do - it "allows easy implementation of custom field types" $ do - parse "--custom foo --custom-list bar --custom-maybe baz" - `shouldBe` Success (CustomFields CFoo [CBar] (Just CBaz)) - data WithoutSelectors = WithoutSelectors String Bool Int deriving (Eq, Show, GHC.Generic) @@ -222,8 +193,8 @@ instance Generic WithoutSelectors instance HasDatatypeInfo WithoutSelectors -part6 :: Spec -part6 = do +part5 :: Spec +part5 = do describe "parseArguments" $ do context "WithoutSelectors" $ do it "populates fields without selectors from positional arguments" $ do @@ -248,43 +219,3 @@ it "allows to use tuples" $ do (parse "42 bar" :: Result (Int, String)) `shouldBe` Success (42, "bar") - - describe "Option.Bool" $ do - describe "parseArgument" $ do - forM_ ["true", "True", "tRue", "TRUE", "yes", "yEs", "on", "oN"] $ \ true -> - it ("parses '" ++ true ++ "' as True") $ do - parseArgument true `shouldBe` Just True - - forM_ ["false", "False", "falSE", "FALSE", "no", "nO", "off", "ofF"] $ \ false -> - it ("parses '" ++ false ++ "' as False") $ do - parseArgument false `shouldBe` Just False - - it "parses every positive integer as true" $ do - property $ \ (n :: Int) -> - n > 0 ==> - parseArgument (show n) `shouldBe` Just True - - it "parses every non-positive integer as false" $ do - property $ \ (n :: Int) -> - n <= 0 ==> - parseArgument (show n) `shouldBe` Just False - - it "doesn't parse 'foo'" $ do - parseArgument "foo" `shouldBe` (Nothing :: Maybe Bool) - - describe "Option.Double" $ do - it "parses doubles" $ do - parseArgument "1.2" `shouldBe` Just (1.2 :: Double) - - it "renders as NUMBER in help and error output" $ do - argumentType (Proxy :: Proxy Double) `shouldBe` "NUMBER" - - it "parses doubles that start with a dot" $ do - parseArgument ".4" `shouldBe` Just (0.4 :: Double) - - describe "Option.Float" $ do - it "parses floats" $ do - parseArgument "1.2" `shouldBe` Just (1.2 :: Float) - - it "renders as NUMBER in help and error output" $ do - argumentType (Proxy :: Proxy Float) `shouldBe` "NUMBER" diff --git a/test/Util.hs b/test/Util.hs --- a/test/Util.hs +++ b/test/Util.hs @@ -3,11 +3,18 @@ module Util where import System.Console.GetOpt.Generics +import System.Console.GetOpt.Generics.Modifier -parse :: (Generic a, HasDatatypeInfo a, All2 Option (Code a)) => +parse :: (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) => String -> Result a parse = modsParse [] -modsParse :: (Generic a, HasDatatypeInfo a, All2 Option (Code a)) => +modsParse :: (Generic a, HasDatatypeInfo a, All2 HasArguments (Code a)) => [Modifier] -> String -> Result a modsParse modifiers = parseArguments "prog-name" modifiers . words + +unsafeModifiers :: [Modifier] -> Modifiers +unsafeModifiers mods = case mkModifiers mods of + Success x -> x + Errors errs -> error ("unsafeModifiers: " ++ show errs) + OutputAndExit msg -> error ("unsafeModifiers: " ++ show msg) diff --git a/test/WithCli/ArgumentSpec.hs b/test/WithCli/ArgumentSpec.hs new file mode 100644 --- /dev/null +++ b/test/WithCli/ArgumentSpec.hs @@ -0,0 +1,26 @@ + +module WithCli.ArgumentSpec where + +import Data.Proxy +import Test.Hspec + +import WithCli.Argument + +spec :: Spec +spec = do + describe "Option.Double" $ do + it "parses doubles" $ do + parseArgument "1.2" `shouldBe` Just (1.2 :: Double) + + it "renders as NUMBER in help and error output" $ do + argumentType (Proxy :: Proxy Double) `shouldBe` "NUMBER" + + it "parses doubles that start with a dot" $ do + parseArgument ".4" `shouldBe` Just (0.4 :: Double) + + describe "Option.Float" $ do + it "parses floats" $ do + parseArgument "1.2" `shouldBe` Just (1.2 :: Float) + + it "renders as NUMBER in help and error output" $ do + argumentType (Proxy :: Proxy Float) `shouldBe` "NUMBER" diff --git a/test/WithCli/HasArgumentsSpec.hs b/test/WithCli/HasArgumentsSpec.hs new file mode 100644 --- /dev/null +++ b/test/WithCli/HasArgumentsSpec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module WithCli.HasArgumentsSpec where + +import Control.Monad +import Test.Hspec +import Test.QuickCheck + +import WithCli.HasArguments + +spec :: Spec +spec = do + describe "parseBool" $ do + forM_ ["true", "True", "tRue", "TRUE", "yes", "yEs", "on", "oN"] $ \ true -> + it ("parses '" ++ true ++ "' as True") $ do + parseBool true `shouldBe` Just True + + forM_ ["false", "False", "falSE", "FALSE", "no", "nO", "off", "ofF"] $ \ false -> + it ("parses '" ++ false ++ "' as False") $ do + parseBool false `shouldBe` Just False + + it "parses every positive integer as true" $ do + property $ \ (n :: Int) -> + n > 0 ==> + parseBool (show n) `shouldBe` Just True + + it "parses every non-positive integer as false" $ do + property $ \ (n :: Int) -> + n <= 0 ==> + parseBool (show n) `shouldBe` Just False + + it "doesn't parse 'foo'" $ do + parseBool "foo" `shouldBe` (Nothing :: Maybe Bool) + diff --git a/test/WithCli/NormalizeSpec.hs b/test/WithCli/NormalizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/WithCli/NormalizeSpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ViewPatterns #-} + +module WithCli.NormalizeSpec where + +import Data.Char +import Test.Hspec +import Test.QuickCheck hiding (Success) + +import WithCli.Normalize + +isValidInputChar :: Char -> Bool +isValidInputChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "-_" + +isAllowedOutputChar :: Char -> Bool +isAllowedOutputChar c = c `elem` ['a' .. 'z'] ++ ['0' .. '9'] ++ "-" + +upperCaseChar :: Gen Char +upperCaseChar = elements ['A' .. 'Z'] + +spec :: Spec +spec = do + describe "normalize" $ do + it "is idempotent" $ do + property $ \ x -> do + let once = normalize x + twice = normalize once + once `shouldBe` twice + + it "replaces underscores with dashes" $ do + normalize "foo_bar" `shouldBe` "foo-bar" + + it "doesn't modify digits" $ do + normalize "foo2bar" `shouldBe` "foo2bar" + + it "when there's one valid character it returns only dashes and lower case characters" $ do + property $ \ x -> + any isValidInputChar x ==> + normalize x `shouldSatisfy` + (\ s -> all isAllowedOutputChar s) + + it "when there are no valid characters it returns its input" $ do + property $ forAll (listOf (arbitrary `suchThat` (not . isValidInputChar))) $ \ x -> + normalize x `shouldBe` x + + it "replaces camelCase with dashes" $ do + let isValidPrefixChar c = c `elem` ['A' .. 'Z'] ++ ['a' .. 'z'] + property $ + \ prefix suffix -> + (any isValidPrefixChar prefix) ==> + forAll upperCaseChar $ \ upper -> + counterexample (prefix ++ [upper] ++ suffix) $ + normalize (prefix ++ [upper] ++ suffix) + `shouldBe` + normalize prefix ++ "-" ++ normalize (toLower upper : suffix) + + describe "matches" $ do + it "matches normalized strings" $ do + property $ \ s -> + normalize s `matches` s + + it "matches unnormalized strings" $ do + property $ \ s -> + s `matches` s diff --git a/test/WithCli/ParserSpec.hs b/test/WithCli/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/WithCli/ParserSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module WithCli.ParserSpec where + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +import WithCli.Parser +import WithCli.Result +import Util + +spec :: Spec +spec = do + describe "runParser" $ do + it "foo" $ do + let fa :: Parser phase Int + fa = Parser { + parserDefault = Nothing, + parserOptions = [], + parserNonOptions = + (NonOptionsParser "type" (\ (s : r) -> (, r) <$> Success (const $ Just $ read s))) : + [], + parserConvert = \ (Just x) -> return x + } + let i = runParser "program" (unsafeModifiers []) fa ["42"] + i `shouldBe` Success 42 diff --git a/test/WithCli/ResultSpec.hs b/test/WithCli/ResultSpec.hs new file mode 100644 --- /dev/null +++ b/test/WithCli/ResultSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module WithCli.ResultSpec where + +import Data.Char +import Data.List +import Safe +import System.Exit +import Test.Hspec +import Test.QuickCheck hiding (Result(..)) + +import WithCli.Result + +spec :: Spec +spec = do + describe "Result" $ do + context ">>" $ do + it "collects errors" $ do + (Errors ["foo"] >> Errors ["bar"] :: Result ()) + `shouldBe` Errors ["foo", "bar"] + + describe "handleResult" $ do + context "OutputAndExit" $ do + it "throws ExitSuccess" $ do + handleResult (OutputAndExit "foo") + `shouldThrow` (== ExitSuccess) + + context "Errors" $ do + it "throws an ExitFailure" $ do + handleResult (Errors ["foo"]) + `shouldThrow` (== ExitFailure 1) + + describe "sanitize" $ do + it "removes empty lines" $ do + property $ \ (unlines -> s) -> do + sanitize s `shouldNotContain` "\n\n" + + it "adds a newline at the end if missing" $ do + property $ \ (unlines -> s) -> + not (null (sanitize s)) ==> + lastMay (sanitize s) `shouldBe` Just '\n' + + it "only strips spaces" $ do + property $ \ (unlines -> s) -> do + counterexample s $ do + let expected = case s of + "" -> "" + x | lastMay x == Just '\n' -> x + x -> x ++ "\n" + filter (not . isSpace) (sanitize s) `shouldBe` filter (not . isSpace) expected + + it "removes trailing spaces" $ do + property $ \ (unlines -> s) -> do + sanitize s `shouldSatisfy` (not . (" \n" `isInfixOf`)) diff --git a/test/WithCliSpec.hs b/test/WithCliSpec.hs new file mode 100644 --- /dev/null +++ b/test/WithCliSpec.hs @@ -0,0 +1,45 @@ + +module WithCliSpec where + +import System.Environment +import System.Exit +import System.IO +import System.IO.Silently +import Test.Hspec + +import WithCli + +spec :: Spec +spec = do + describe "withCli" $ do + context "no arguments" $ do + it "executes the operation in case of no command line arguments" $ do + let main :: IO () + main = putStrLn "success" + (capture_ $ withArgs [] $ withCli main) + `shouldReturn` "success\n" + + it "produces nice error messages" $ do + let main :: IO () + main = putStrLn "success" + output <- hCapture_ [stderr] (withArgs ["foo"] (withCli main) `shouldThrow` (== ExitFailure 1)) + output `shouldBe` "unknown argument: foo\n" + + context "1 argument" $ do + it "parses Ints" $ do + let main :: Int -> IO () + main n = putStrLn ("success: " ++ show n) + (capture_ $ withArgs ["12"] $ withCli main) + `shouldReturn` "success: 12\n" + + it "error parsing" $ do + let main :: Int -> IO () + main n = putStrLn ("error: " ++ show n) + output <- hCapture_ [stderr] (withArgs (words "12 foo") (withCli main) `shouldThrow` (== ExitFailure 1)) + output `shouldBe` "unknown argument: foo\n" + + it "handle Maybes as positional arguments with a proper error message" $ do + let main :: Maybe Int -> IO () + main = error "main" + output <- hCapture_ [stderr] (withCli main `shouldThrow` (== ExitFailure 1)) + output `shouldBe` "cannot use Maybes for positional arguments\n"