├── .gitignore ├── LICENSE ├── README.md ├── bower.json ├── psc-package.json ├── src └── Node │ ├── Commando.purs │ ├── Optlicative.purs │ └── Optlicative │ ├── Internal.purs │ └── Types.purs └── test ├── Main.purs └── Types.purs /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2017 Thimoteus (https://github.com/Thimoteus) 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-optlicative 2 | 3 | An applicative-style CLI option parsing lib with accumulative errors and type-based 4 | command parsing. 5 | 6 | ## Usage by example 7 | 8 | Let's say we have a CLI program called `p`, and we want it to accept a 9 | flag that determines whether its output will be colored or not. 10 | 11 | We want users to express this intention by writing `p --color`. 12 | 13 | Somewhere in our code we have a `Config` type that represents options 14 | passed in: 15 | 16 | ```purescript 17 | type Config r = {color :: Boolean | r} 18 | ``` 19 | 20 | To parse this, we use the `flag` combinator: 21 | 22 | ```purescript 23 | parseConfig :: Optlicative (Config ()) 24 | parseConfig = {color: _} <$> flag "color" Nothing 25 | ``` 26 | 27 | If we want to extend `Config` to include an `--output` option that takes a filename argument, that's easy too: 28 | 29 | ```purescript 30 | type Config' r = Config (output :: String | r) 31 | 32 | parseConfig' :: Optlicative (Config' ()) 33 | parseConfig' = {color: _, output: _} 34 | <$> flag "color" Nothing 35 | <*> string "output" Nothing 36 | ``` 37 | 38 | Suddenly we think of several more boolean flags we want to support: 39 | 40 | ```purescript 41 | type Config'' r = Config' (humanReadable :: Boolean, metricUnits :: Boolean | r) 42 | 43 | parseConfig'' :: Optlicative (Config'' ()) 44 | parseConfig'' = {color: _, output: _, humanReadable: _, metricUnits: _} 45 | <$> flag "color" Nothing 46 | <*> string "output" Nothing 47 | <*> flag "human-readable" Nothing 48 | <*> flag "metric-units" Nothing 49 | ``` 50 | 51 | But now if we want users to use every one of these flags, we require them to write something like `p --color --human-readable --metric-units --output "./output.txt"`. That's way too long! 52 | 53 | If we want to allow single-hyphen, single-character options we just change a few `Nothing`'s: 54 | 55 | ```purescript 56 | parseConfig2 :: Optlicative (Config'' ()) 57 | parseConfig2 = {color: _, humanReadable: _, metricUnits: _, output: _} 58 | <$> flag "color" (Just 'c') 59 | <*> flag "human-readable" (Just 'H') 60 | <*> flag "metric-units" (Just 'm') 61 | <*> string "output" Nothing 62 | ``` 63 | 64 | Now our users can write `p -cHm --output "./output.txt"`. Much better! 65 | 66 | ### Error messages 67 | 68 | By default, if the `--output` option is missing the following error will be 69 | generated: `"Missing option: Option 'output' is required."` 70 | 71 | Our flags won't produce any error messages, since if a user doesn't supply a flag we assume they want it to be `false`. 72 | 73 | But we can also change the error message, for example by changing our `--output` parser to `string "output" (Just "I need to know where to place my output!")` 74 | 75 | Error messages are accumulated via the semigroup-based `V` applicative functor, 76 | meaning that if the user gives input that causes multiple errors, each one can be 77 | shown. 78 | 79 | ### Optional values 80 | 81 | What if we want to provide a default output directory, and don't want to require 82 | the user to always supply it? We can use `optional`, `withDefault` or `withDefaultM`: 83 | 84 | ```purescript 85 | parseConfig4 :: Optlicative (Config'' ()) 86 | parseConfig4 = {color: _, _, humanReadable: _, metricUnits: _, output: _} 87 | <$> flag "color" (Just 'c') 88 | <*> flag "human-readable" (Just 'H') 89 | <*> flag "metric-units" (Just 'm') 90 | <*> withDefault "./output.txt" (string "output" Nothing) 91 | ``` 92 | 93 | Note that none of these three combinators will fail. 94 | 95 | ### Custom data-types 96 | 97 | If we have a way of reading values from a `String` (specifically a function `f` of 98 | type `String -> F a`) then we can use `optF f` to read such a value. Any errors 99 | in the `F` monad get turned into `OptErrors` in the `Optlicative` functor. 100 | 101 | Example: 102 | 103 | ```purescript 104 | readTupleString :: String -> F (Tuple Int Int) 105 | 106 | optTuple :: Optlicative (Tuple Int Int) 107 | optTuple = optF readTupleString "point" (Just "Points must be in the form '(x,y)'") 108 | ``` 109 | 110 | Then the option `--point (3,5)` won't error if and only if 111 | `readTupleString "(3,5)"` does not error. 112 | 113 | ### Options that accept multiple arguments 114 | 115 | Again, assuming we have a function `read :: String -> F a` for some type `a`, 116 | we can use `manyF read :: Int -> String -> Maybe ErrorMsg -> Optlicative (List a)`. 117 | 118 | In this case, `Int` represents the number of arguments expected (none of which 119 | may start with a hyphen character). 120 | 121 | ### Running the parser 122 | 123 | ```purescript 124 | optlicate :: Constraints => Record optrow -> Preferences a -> Effect {cmd :: Maybe String, value :: Value a} 125 | ``` 126 | 127 | `Preferences` is a record: 128 | 129 | ```purescript 130 | { errorOnUnrecognizedOpts :: Boolean 131 | , usage :: Maybe String 132 | , globalOpts :: Optlicative a 133 | } 134 | ``` 135 | 136 | A `defaultPreferences :: Preferences Void` is available. 137 | 138 | The `errorOnUnrecognizedOpts` field indicates whether an error should be generated 139 | if a user passes in an option that isn't recognized by the parser. 140 | 141 | The `usage` field will print a given message in case of any error. 142 | 143 | `globalOpts` is for options which don't match a given command; for more on commands 144 | see the next section. 145 | 146 | The `value` field has type `Value a`, which is a type synonym for 147 | `V (List OptError) a`. This means you'll need to use `unV` from 148 | `Data.Validation.Semigroup`, handling any possible errors, in order to have access 149 | to the value of type `a`. 150 | 151 | ## Dealing with Commands 152 | 153 | Let's take a closer look at the "Constraints" part of the `optlicate` type signature. 154 | The actual signature starts like this: 155 | 156 | ```purescript 157 | optlicate :: forall optrow a e. Commando optrow => Record optrow -> Preferences a -> ... 158 | ``` 159 | 160 | The important part is the `Commando` typeclass constraint. It applies only to 161 | a certain class of rows -- similar to homogenous rows, but a bit more generalized 162 | than what usually comes to mind. Let's look at an example: 163 | 164 | ``` 165 | type MyConfig = 166 | ( command :: Opt Config 167 | ( more :: Opt Config () 168 | ) 169 | , second :: Opt Config () 170 | ) 171 | ``` 172 | 173 | Note that this type has not only breadth but also depth. The `Opt` type is a 174 | datatype around `Optlicative` but with extra type information in the second argument: 175 | this is what allows us to nest commands, treating every possible command (and 176 | associated options) as a tree-like structure (a record), where each node (field) 177 | represents a pair of a command entered, and the options for that command. 178 | 179 | For example, if the user had run `p command --help`, the parser would then recognize this, and match the `Optlicative Config` associated with the `command` command and 180 | run it against the `--help` flag. 181 | 182 | Any command, if it exists, will be placed into the `cmd` field of the result -- 183 | if the program is used like `p command more`, then `cmd = Just "more"`. 184 | 185 | Let's look at the first argument to `optlicate`. In our example case, we'd need a 186 | value of type `Record MyConfig`. If we can construct a value for just one field, 187 | we can construct them all. And those values are built using `Opt`, as suggested 188 | by the definition of `MyConfig`: 189 | 190 | ```purescript 191 | data Opt (a :: Type) (row :: # Type) = Opt (Optlicative a) (Record row) 192 | ``` 193 | 194 | `Opt`s are pairs of `Optlicative`s and a record, which allows us to continue 195 | chaining new `Optlicative`s. With this in mind, we can construct what we want: 196 | 197 | ```purescript 198 | myConfig :: Record MyConfig 199 | myConfig = 200 | { command: Opt commandOptlicative 201 | { more: Opt moreOptlicative {} 202 | } 203 | , second: Opt secondOptlicative {} 204 | } 205 | ``` 206 | 207 | We can also use `endOpt` to get rid of those empty records if we wish: 208 | `more: endOpt moreOptlicative`. 209 | 210 | ## More examples 211 | 212 | See the `test/` folder. 213 | 214 | ## Unsupported/future features 215 | 216 | * "Unsupported command" errors: when a command is given but does not match anything 217 | * passthrough options (as in `program --program-opt -- --passthrough-opt`) 218 | * use of single characters for options instead of just flags 219 | * other things I haven't thought of 220 | 221 | ## Installation 222 | 223 | * Using bower: 224 | 225 | ``` 226 | > bower install purescript-optlicative 227 | ``` 228 | 229 | * Or, 230 | 231 | Add it to a package set! -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-optlicative", 3 | "homepage": "https://github.com/Thimoteus/purescript-optlicative", 4 | "authors": [ 5 | "thimoteus " 6 | ], 7 | "repository": { 8 | "type": "git", 9 | "url": "https://github.com/Thimoteus/purescript-optlicative.git" 10 | }, 11 | "description": "Applicative-style CLI argument/option parsing for node", 12 | "main": "", 13 | "keywords": [ 14 | "purescript", 15 | "applicative", 16 | "option", 17 | "parsing" 18 | ], 19 | "license": "MIT", 20 | "ignore": [ 21 | "**/.*", 22 | "node_modules", 23 | "bower_components", 24 | "test", 25 | "tests" 26 | ], 27 | "dependencies": { 28 | "purescript-foreign": "^5.0.0", 29 | "purescript-validation": "^4.0.0", 30 | "purescript-record": "^2.0.0", 31 | "purescript-node-process": "^7.0.0", 32 | "purescript-console": "^4.1.0" 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /psc-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-optlicative", 3 | "set": "master", 4 | "source": "https://github.com/thimoteus/package-sets.git", 5 | "depends": [ 6 | "record", 7 | "typelevel-prelude", 8 | "symbols", 9 | "validation", 10 | "node-process", 11 | "psci-support", 12 | "console", 13 | "eff", 14 | "prelude" 15 | ] 16 | } -------------------------------------------------------------------------------- /src/Node/Commando.purs: -------------------------------------------------------------------------------- 1 | module Node.Commando 2 | ( class RLCommando, rlCommando 3 | , class Commando, commando 4 | , Opt(..) 5 | , endOpt 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Data.List (List(Nil), (:)) 11 | import Data.Maybe (Maybe(..)) 12 | import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) 13 | import Node.Optlicative.Types (Optlicative) 14 | import Record (delete, get) 15 | import Prim.Row as R 16 | import Prim.RowList as RL 17 | import Type.Data.RowList (RLProxy(..)) 18 | 19 | class RLCommando 20 | (rl :: RL.RowList) 21 | (row :: # Type) 22 | (a :: Type) 23 | | rl -> row 24 | where 25 | rlCommando :: RLProxy rl -> Record row -> List String -> Maybe {cmd :: String, opt :: Optlicative a} 26 | 27 | instance basisRlHelp :: RLCommando RL.Nil () a where 28 | rlCommando _ _ _ = Nothing 29 | 30 | instance ihRlHelp :: 31 | ( IsSymbol k -- key in row of IH case 32 | , RLCommando tail rowtail a -- IH 33 | , RLCommando list' row' a -- also IH, for 2nd arg which is a row 34 | , R.Cons k (Opt a row') rowtail row -- row = rowtail U Opt 35 | , R.Lacks k rowtail 36 | , RL.RowToList rowtail tail -- rowtail <-> tail 37 | , RL.RowToList row (RL.Cons k (Opt a row') tail) -- row <-> list 38 | , RL.RowToList row' list' -- row' <-> list' 39 | ) => RLCommando (RL.Cons k (Opt a row') tail) row a where 40 | 41 | rlCommando _ rec args@(cmd : Nil) = 42 | let 43 | sproxy = SProxy :: SProxy k 44 | opt = getopt (get sproxy rec) 45 | rectail = (delete sproxy rec) :: Record rowtail 46 | in 47 | if cmd == reflectSymbol sproxy 48 | then Just {cmd, opt} 49 | else rlCommando (RLProxy :: RLProxy tail) rectail args 50 | 51 | rlCommando _ rec args@(x : xs) = -- haven't found final command yet 52 | let 53 | sproxy = SProxy :: SProxy k 54 | rldeeper = RLProxy :: RLProxy list' 55 | rlwider = RLProxy :: RLProxy tail 56 | rec' = (getrow (get sproxy rec)) :: Record row' 57 | rectail = (delete sproxy rec) :: Record rowtail 58 | in 59 | if x == reflectSymbol sproxy -- we're on the right path 60 | then rlCommando rldeeper rec' xs -- recurse deeper 61 | else rlCommando rlwider rectail args -- recurse wider 62 | 63 | rlCommando _ _ _ = Nothing -- ran out of command path elements 64 | 65 | class Commando (row :: # Type) a where 66 | commando :: Record row -> List String -> Maybe {cmd :: String, opt :: Optlicative a} 67 | 68 | instance rowHelpInst :: 69 | ( RL.RowToList row list 70 | , RLCommando list row a 71 | ) => Commando row a where 72 | commando rec xs = rlCommando (RLProxy :: RLProxy list) rec xs 73 | 74 | data Opt (a :: Type) (row :: # Type) = Opt (Optlicative a) (Record row) 75 | 76 | endOpt :: forall a. Optlicative a -> Opt a () 77 | endOpt o = Opt o {} 78 | 79 | getopt :: forall a row. Opt a row -> Optlicative a 80 | getopt (Opt opt _) = opt 81 | 82 | getrow :: forall a row. Opt a row -> Record row 83 | getrow (Opt _ row) = row 84 | -------------------------------------------------------------------------------- /src/Node/Optlicative.purs: -------------------------------------------------------------------------------- 1 | module Node.Optlicative 2 | ( throw 3 | , flag 4 | , string 5 | , int 6 | , float 7 | , optional 8 | , withDefault 9 | , withDefaultM 10 | , optF 11 | , optForeign 12 | , many 13 | , manyF 14 | , optlicate 15 | , defaultPreferences 16 | , renderErrors 17 | , logErrors 18 | , module Exports 19 | ) where 20 | 21 | import Prelude 22 | 23 | import Control.Monad.Except (runExcept) 24 | import Data.Array (intercalate) 25 | import Data.Either (Either(..)) 26 | import Data.Int (fromNumber) 27 | import Data.List (List(..), (:)) 28 | import Data.List as List 29 | import Data.Maybe (Maybe(..)) 30 | import Data.Traversable (traverse) 31 | import Data.Validation.Semigroup (invalid, isValid, toEither) 32 | import Effect (Effect) 33 | import Effect.Console (error) 34 | import Foreign (F, Foreign, unsafeToForeign) 35 | import Global (isNaN, readFloat) 36 | import Node.Commando (class Commando) 37 | import Node.Commando (class Commando, commando, Opt(..), endOpt) as Exports 38 | import Node.Optlicative.Internal (ddash, ex, except, find, hasHyphen, multipleErrorsToOptErrors, parse, removeAtFor, removeAtForWhile, removeHyphen, startsDash) 39 | import Node.Optlicative.Types (ErrorMsg, OptError(..), Optlicative(..), Preferences, Value, renderOptError) 40 | import Node.Optlicative.Types (OptError(..), ErrorMsg, Optlicative(..), Value, Preferences) as Exports 41 | import Node.Process (argv) 42 | 43 | -- | A combinator that always fails. 44 | throw :: forall a. OptError -> Optlicative a 45 | throw e = Optlicative (except e) 46 | 47 | -- | Check whether a boolean value appears as an option. This combinator cannot 48 | -- | fail, as absence of its option is interpreted as `false`. The first argument 49 | -- | is the expected name, the second is an optional character for single-hyphen 50 | -- | style: For example, `boolean "optimize" (Just 'O')` will parse both 51 | -- | `--optimize` and `-O`. 52 | flag :: String -> Maybe Char -> Optlicative Boolean 53 | flag name mc = Optlicative \ state -> case find ddash name state of 54 | Just i -> 55 | let 56 | {removed, rest} = removeAtFor i 0 state 57 | in 58 | {state: rest, val: pure true} 59 | _ -> case mc of 60 | Just c -> 61 | if hasHyphen c state 62 | then {state: removeHyphen c state, val: pure true} 63 | else {state, val: pure false} 64 | _ -> {state, val: pure false} 65 | 66 | -- | Check whether a string appears as an option. The first argument is the 67 | -- | expected name, the second is a custom error message if the option does not 68 | -- | appear. A default error message is provided if this argument is `Nothing`. 69 | string :: String -> Maybe ErrorMsg -> Optlicative String 70 | string name msg = Optlicative \ state -> case find ddash name state of 71 | Just i -> 72 | let 73 | {removed, rest} = removeAtForWhile i 1 (not <<< startsDash) state 74 | in 75 | case List.head removed.unparsed of 76 | Just h -> {state: rest, val: pure h} 77 | _ -> ex name (show 1) MissingArg msg rest 78 | _ -> ex name mempty MissingOpt msg state 79 | 80 | -- | Check whether an integer appears as an option. Arguments are the same as for 81 | -- | `string`. 82 | int :: String -> Maybe ErrorMsg -> Optlicative Int 83 | int name msg = Optlicative \ state -> case find ddash name state of 84 | Just i -> 85 | let 86 | {removed, rest} = removeAtForWhile i 1 (not <<< startsDash) state 87 | in 88 | case List.head removed.unparsed of 89 | Just h -> case fromNumber (readFloat h) of 90 | Just n -> {state: rest, val: pure n} 91 | _ -> ex name "int" TypeError msg rest 92 | _ -> ex name (show 1) MissingArg msg rest 93 | _ -> ex name mempty MissingOpt msg state 94 | 95 | -- | Check whether a float appears as an option. Arguments are the same as for 96 | -- | `string`. Note that numbers without decimal points will still parse as floats. 97 | float :: String -> Maybe ErrorMsg -> Optlicative Number 98 | float name msg = Optlicative \ state -> case find ddash name state of 99 | Just i -> 100 | let 101 | {removed, rest} = removeAtForWhile i 1 (not <<< startsDash) state 102 | in 103 | case List.head removed.unparsed of 104 | Just h -> 105 | if isNaN (readFloat h) 106 | then ex name "float" TypeError msg rest 107 | else {state: rest, val: pure (readFloat h)} 108 | _ -> ex name (show 1) MissingArg msg rest 109 | _ -> ex name mempty MissingOpt msg state 110 | 111 | -- | Instead of failing, turns an optlicative parser into one that always succeeds 112 | -- | but may do so with `Nothing` if no such option is found. 113 | -- | This is useful for `--help` flags in particular: Without this combinator, 114 | -- | it's easy to make an `Optlicative` that gives an unhelpful `MissingOpt` 115 | -- | error message when all the user did was try to find help text for a command. 116 | optional :: forall a. Optlicative a -> Optlicative (Maybe a) 117 | optional (Optlicative o) = Optlicative \ s -> 118 | let {state, val} = o s 119 | in {state, val: if isValid val then Just <$> val else pure Nothing} 120 | 121 | -- | Apply an `Optlicative` parser zero or more times, collecting the 122 | -- | results in a `List`. 123 | many :: forall a. Optlicative a -> Optlicative (List a) 124 | many parser = Optlicative \optstate -> go parser optstate Nil 125 | where 126 | go (Optlicative o) s acc = 127 | let 128 | { state, val } = o s 129 | in 130 | case toEither val of 131 | Left _ -> { state, val: pure (List.reverse acc) } 132 | Right v -> go parser state (v:acc) 133 | 134 | -- | Instead of failing, turns an optlicative parser into one that always succeeds 135 | -- | but may do so with the given default argument if no such option is found. 136 | withDefault :: forall a. a -> Optlicative a -> Optlicative a 137 | withDefault def (Optlicative o) = Optlicative \ s -> 138 | let {state, val} = o s 139 | in {state, val: if isValid val then val else pure def} 140 | 141 | -- | Like `withDefault` but the default value is `mempty`. 142 | withDefaultM :: forall m. Monoid m => Optlicative m -> Optlicative m 143 | withDefaultM = withDefault mempty 144 | 145 | -- | Check whether something appears as an option, and coerce it to `Foreign` if 146 | -- | it does. This can be used to parse a JSON argument, for example. 147 | optForeign :: String -> Maybe ErrorMsg -> Optlicative Foreign 148 | optForeign name msg = Optlicative \ state -> case find ddash name state of 149 | Just i -> 150 | let 151 | {removed, rest} = removeAtForWhile i 1 (not <<< startsDash) state 152 | in 153 | case List.head removed.unparsed of 154 | Just h -> {state: rest, val: pure (unsafeToForeign h)} 155 | _ -> ex name (show 1) MissingArg msg rest 156 | _ -> ex name mempty MissingOpt msg state 157 | 158 | -- | Given a deserializing function, returns the value if no errors were encountered 159 | -- | during deserialization. If there were errors, they are turned into `OptError`s. 160 | optF :: forall a. (String -> F a) -> String -> Maybe ErrorMsg -> Optlicative a 161 | optF read name msg = Optlicative \ state -> case find ddash name state of 162 | Just i -> 163 | let 164 | {removed, rest} = removeAtForWhile i 1 (not <<< startsDash) state 165 | in 166 | case List.head removed.unparsed of 167 | Just h -> case runExcept (read h) of 168 | Right v -> {state: rest, val: pure v} 169 | Left errs -> {state: rest, val: invalid (multipleErrorsToOptErrors errs)} 170 | _ -> ex name (show 1) MissingArg msg rest 171 | _ -> ex name mempty MissingOpt msg state 172 | 173 | -- | Given a deserializing function and the number of args to parse, none of which 174 | -- | may start with a '-' character, returns a list of parsed values. 175 | manyF :: forall a. (String -> F a) -> Int -> String -> Maybe ErrorMsg -> Optlicative (List a) 176 | manyF read len name msg = Optlicative \ state -> case find ddash name state of 177 | Just i -> 178 | let 179 | {removed, rest} = removeAtForWhile i len (not <<< startsDash) state 180 | in 181 | case runExcept (traverse read removed.unparsed) of 182 | Right vs -> {state: rest, val: pure vs} 183 | Left errs -> {state: rest, val: invalid (multipleErrorsToOptErrors errs)} 184 | _ -> ex name mempty MissingOpt msg state 185 | 186 | -- | A convenience function for nicely printing error messages. 187 | renderErrors :: List OptError -> String 188 | renderErrors = intercalate "\n" <<< map renderOptError 189 | 190 | logErrors :: List OptError -> Effect Unit 191 | logErrors = error <<< renderErrors 192 | 193 | -- | A `Preferences` that errors on unrecognized options, has no usage text, 194 | -- | and uses an always-failing parser for global options. 195 | defaultPreferences :: Preferences Void 196 | defaultPreferences = 197 | { errorOnUnrecognizedOpts: true 198 | , usage: Nothing 199 | , globalOpts: throw (Custom "Error: defaultPreferences used.") 200 | } 201 | 202 | -- | Use this to run an `Optlicative`. 203 | optlicate 204 | :: forall optrow a 205 | . Commando optrow a 206 | => Record optrow 207 | -> Preferences a 208 | -> Effect {cmd :: Maybe String, value :: Value a} 209 | optlicate rec prefs = parse rec prefs <$> argv 210 | -------------------------------------------------------------------------------- /src/Node/Optlicative/Internal.purs: -------------------------------------------------------------------------------- 1 | module Node.Optlicative.Internal where 2 | 3 | import Prelude 4 | 5 | import Data.Array as Array 6 | import Data.Foldable (or) 7 | import Data.List (List(Nil), (:)) 8 | import Data.List as List 9 | import Data.List.Types (toList) 10 | import Data.Maybe (Maybe(..), maybe) 11 | import Data.Newtype (unwrap) 12 | import Data.String as String 13 | import Data.String.CodeUnits as CU 14 | import Data.Validation.Semigroup (invalid, isValid) 15 | import Foreign (MultipleErrors, renderForeignError) 16 | import Node.Commando (class Commando, commando) 17 | import Node.Optlicative.Types (ErrorMsg, OptError(..), OptState, Result, Value, Preferences) 18 | 19 | throwSingleError :: forall a. OptError -> Value a 20 | throwSingleError = invalid <<< List.singleton 21 | 22 | except :: forall a. OptError -> OptState -> Result a 23 | except e state = {state, val: throwSingleError e} 24 | 25 | ex :: forall a. String -> String -> (String -> OptError) -> Maybe String -> OptState -> Result a 26 | ex name exp ctor mb st = except (maybe (defaultError ctor name exp) ctor mb) st 27 | 28 | findAllIndices :: forall a. (a -> Boolean) -> List a -> List Int 29 | findAllIndices f xs = List.reverse zs where 30 | zs = go Nil 0 xs 31 | go acc i (y:ys) = if f y then go (i : acc) (i + 1) ys else go acc (i + 1) ys 32 | go acc _ Nil = acc 33 | 34 | removeAtFor :: Int -> Int -> OptState -> {removed :: OptState, rest :: OptState} 35 | removeAtFor beg end = removeAtForWhile beg end (const true) 36 | 37 | removeAtForWhile 38 | :: Int 39 | -> Int 40 | -> (String -> Boolean) 41 | -> OptState 42 | -> {removed :: OptState, rest :: OptState} 43 | removeAtForWhile beg end f state@{unparsed} = 44 | let 45 | splice = spliceWhile f beg (end + 1) unparsed 46 | in 47 | {removed: {unparsed: splice.focus}, rest: {unparsed: splice.pre <> splice.post}} 48 | 49 | spliceWhile 50 | :: forall a 51 | . (a -> Boolean) 52 | -> Int -> Int 53 | -> List a 54 | -> {pre :: List a, focus :: List a, post :: List a} 55 | spliceWhile f beg end lst = 56 | let 57 | a = takeDropWhile (const true) beg lst 58 | b = takeDropWhile' f (end - 1) a.dropped 59 | in 60 | { pre: a.taken 61 | , focus: b.taken 62 | , post: b.dropped 63 | } 64 | 65 | takeDropWhile :: forall a. (a -> Boolean) -> Int -> List a -> {taken :: List a, dropped :: List a} 66 | takeDropWhile = takeDrop Nil 67 | 68 | -- Ignores first element 69 | takeDropWhile' :: forall a. (a -> Boolean) -> Int -> List a -> {taken :: List a, dropped :: List a} 70 | takeDropWhile' _ _ Nil = {taken: Nil, dropped: Nil} 71 | takeDropWhile' f n (_ : xs) = takeDrop Nil f n xs 72 | 73 | takeDrop :: forall a. List a -> (a -> Boolean) -> Int -> List a -> {taken :: List a, dropped :: List a} 74 | takeDrop acc f n lst = case n, lst of 75 | 0, _ -> {taken: List.reverse acc, dropped: lst} 76 | _, Nil -> {taken: List.reverse acc, dropped: lst} 77 | _, x : xs -> 78 | if f x 79 | then takeDrop (x : acc) f (n - 1) xs 80 | else {taken: List.reverse acc, dropped: lst} 81 | 82 | removeHyphen :: Char -> OptState -> OptState 83 | removeHyphen c state = 84 | let 85 | f str 86 | | isMultiHyphen str = String.replace 87 | (String.Pattern (CU.singleton c)) 88 | (String.Replacement "") 89 | str 90 | | str == "-" <> CU.singleton c = "" 91 | | otherwise = str 92 | in 93 | state {unparsed = List.filter (_ /= "") (f <$> state.unparsed)} 94 | 95 | isMultiHyphen :: String -> Boolean 96 | isMultiHyphen s = 97 | String.take 1 s == "-" && 98 | String.take 2 s /= "--" && 99 | String.length s >= 3 100 | 101 | isSingleHyphen :: String -> Boolean 102 | isSingleHyphen s = 103 | String.take 1 s == "-" && 104 | String.take 2 s /= "--" && 105 | String.length s == 2 106 | 107 | isDdash :: String -> Boolean 108 | isDdash s = String.take 2 s == "--" && String.length s >= 3 109 | 110 | startsDash :: String -> Boolean 111 | startsDash s = String.take 1 s == "-" 112 | 113 | hyphens :: List String -> List String 114 | hyphens = List.filter (isMultiHyphen || isSingleHyphen) 115 | 116 | hasHyphen :: Char -> OptState -> Boolean 117 | hasHyphen c state = or $ 118 | String.contains (String.Pattern $ CU.singleton c) <$> 119 | hyphens state.unparsed 120 | 121 | find :: forall a. (a -> String) -> a -> OptState -> Maybe Int 122 | find f n = List.elemIndex (f n) <<< _.unparsed 123 | 124 | ddash :: String -> String 125 | ddash = append "--" 126 | 127 | hyphen :: Char -> String 128 | hyphen = append "-" <<< CU.singleton 129 | 130 | charList :: String -> List Char 131 | charList = charList' Nil where 132 | charList' acc str = case CU.uncons str of 133 | Just {head, tail} -> charList' (head : acc) tail 134 | _ -> acc 135 | 136 | defaultError :: (ErrorMsg -> OptError) -> String -> String -> OptError 137 | defaultError f name expected = case f "" of 138 | TypeError _ -> TypeError $ 139 | "Option '" <> name <> "' expects an argument of type " <> expected <> "." 140 | MissingOpt _ -> MissingOpt $ 141 | "Option '" <> name <> "' is required." 142 | MissingArg _ -> MissingArg $ 143 | "Option '" <> name <> "' expects " <> expected <> " arguments." 144 | UnrecognizedOpt _ -> UnrecognizedOpt name 145 | UnrecognizedCommand _ -> UnrecognizedCommand name 146 | Custom _ -> Custom name 147 | 148 | multipleErrorsToOptErrors :: MultipleErrors -> List OptError 149 | multipleErrorsToOptErrors errs = 150 | let strerrs = map renderForeignError errs 151 | strlist = toList strerrs 152 | in map Custom strlist 153 | 154 | unrecognizedOpts :: forall a. OptState -> Value a 155 | unrecognizedOpts state = invalid $ map UnrecognizedOpt $ unrecognize Nil state.unparsed 156 | where 157 | unrecognize acc lst 158 | | (s : ss) <- lst 159 | , isDdash s = unrecognize (s : acc) ss 160 | | (_ : ss) <- lst = unrecognize acc ss 161 | | otherwise = acc 162 | 163 | partitionArgsList :: List String -> {cmds :: List String, opts :: List String} 164 | partitionArgsList argslist = 165 | let 166 | isCmd x = String.take 1 x /= "-" 167 | {init, rest} = List.span isCmd argslist 168 | in 169 | {cmds: init, opts: rest} 170 | 171 | parse 172 | :: forall optrow a 173 | . Commando optrow a 174 | => Record optrow 175 | -> Preferences a 176 | -> Array String 177 | -> {cmd :: Maybe String, value :: Value a} 178 | parse rec prefs argv = 179 | let 180 | args = Array.drop 2 argv 181 | argslist = List.fromFoldable args 182 | {cmds, opts} = partitionArgsList argslist 183 | -- Commands 184 | cmdores = commando rec cmds 185 | cmd = _.cmd <$> cmdores 186 | -- Opts 187 | o = maybe prefs.globalOpts _.opt cmdores 188 | {state, val} = unwrap o {unparsed: opts} 189 | unrecCheck = prefs.errorOnUnrecognizedOpts && not (List.null state.unparsed) 190 | value = case prefs.usage, unrecCheck, isValid val of 191 | Just msg, true, true -> 192 | unrecognizedOpts state <*> 193 | throwSingleError (Custom msg) 194 | Just msg, true, _ -> 195 | unrecognizedOpts state <*> 196 | throwSingleError (Custom msg) <*> 197 | val 198 | Just msg, false, false -> throwSingleError (Custom msg) <*> val 199 | Just _, false, _ -> val 200 | _, true, _ -> unrecognizedOpts state <*> val 201 | _, _, _ -> val 202 | in 203 | {cmd, value} 204 | -------------------------------------------------------------------------------- /src/Node/Optlicative/Types.purs: -------------------------------------------------------------------------------- 1 | module Node.Optlicative.Types where 2 | 3 | import Prelude 4 | 5 | import Control.Alt (class Alt) 6 | import Control.Alternative (class Alternative) 7 | import Control.Plus (class Plus) 8 | import Data.List (List, singleton) 9 | import Data.Maybe (Maybe) 10 | import Data.Newtype (class Newtype) 11 | import Data.Validation.Semigroup (V, isValid, invalid) 12 | 13 | newtype Optlicative a = Optlicative (OptState -> Result a) 14 | 15 | derive instance newtypeOptlicative :: Newtype (Optlicative a) _ 16 | 17 | derive instance functorOptlicative :: Functor Optlicative 18 | 19 | instance applyOptlicative :: Apply Optlicative where 20 | apply (Optlicative f) (Optlicative a) = Optlicative \ s -> 21 | let 22 | r1 = f s 23 | a' = a r1.state 24 | val = r1.val <*> a'.val 25 | state = a'.state 26 | in 27 | {state, val} 28 | 29 | instance applicativeOptlicative :: Applicative Optlicative where 30 | pure a = Optlicative \ state -> {state, val: pure a} 31 | 32 | instance altOptlicative :: Alt Optlicative where 33 | alt (Optlicative x) (Optlicative y) = Optlicative \ s -> 34 | let 35 | {val} = x s 36 | in 37 | if isValid val then x s else y s 38 | 39 | instance plusOptlicative :: Plus Optlicative where 40 | empty = Optlicative \ state -> 41 | {state, val: invalid (singleton (Custom "Error: empty called"))} 42 | 43 | instance alternativeOptlicative :: Alternative Optlicative 44 | 45 | data OptError 46 | = TypeError ErrorMsg 47 | | MissingOpt ErrorMsg 48 | | MissingArg ErrorMsg 49 | | UnrecognizedOpt String 50 | | UnrecognizedCommand String 51 | | Custom ErrorMsg 52 | 53 | renderOptError :: OptError -> String 54 | renderOptError = case _ of 55 | TypeError msg -> "Type error: " <> msg 56 | MissingOpt msg -> "Missing option: " <> msg 57 | MissingArg msg -> "Missing argument: " <> msg 58 | UnrecognizedOpt msg -> "Unrecognized option: " <> msg 59 | UnrecognizedCommand msg -> "Unrecognized command: " <> msg 60 | Custom msg -> msg 61 | 62 | instance showError :: Show OptError where 63 | show (TypeError msg) = "(TypeError " <> show msg <> ")" 64 | show (MissingOpt msg) = "(MissingOpt " <> show msg <> ")" 65 | show (MissingArg msg) = "(MissingArg " <> show msg <> ")" 66 | show (UnrecognizedOpt msg) = "(UnrecognizedOpt " <> show msg <> ")" 67 | show (UnrecognizedCommand msg) = "(UnrecognizedCommand " <> show msg <> ")" 68 | show (Custom msg) = "(Custom " <> show msg <> ")" 69 | 70 | type Value a = V (List OptError) a 71 | 72 | type OptState = {unparsed :: List String} 73 | 74 | type Result a = {state :: OptState, val :: Value a} 75 | 76 | type ErrorMsg = String 77 | 78 | type Preferences a = 79 | { errorOnUnrecognizedOpts :: Boolean 80 | , usage :: Maybe String 81 | , globalOpts :: Optlicative a 82 | } -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Effect.Console (log) 7 | import Data.List (length) 8 | import Data.Maybe (Maybe(..), maybe) 9 | import Data.Validation.Semigroup (unV) 10 | import Node.Commando (Opt(Opt)) 11 | import Node.Optlicative (Optlicative, Preferences, defaultPreferences, flag, logErrors, optlicate, string, many) 12 | import Test.Types (Config(..), ConfigRec, showConfig) 13 | 14 | configRec :: Record ConfigRec 15 | configRec = 16 | { one: Opt optOne 17 | { two: Opt optTwo {} 18 | } 19 | } 20 | 21 | optOne :: Optlicative Config 22 | optOne = (\ output names help -> ConfigOne {output, names, help}) 23 | <$> string "output" Nothing 24 | <*> many (string "name" Nothing) 25 | <*> flag "help" (Just 'h') 26 | 27 | optTwo :: Optlicative Config 28 | optTwo = (\ color help -> ConfigTwo {color, help}) 29 | <$> flag "color" (Just 'c') 30 | <*> flag "help" (Just 'h') 31 | 32 | globalConfig :: Optlicative Config 33 | globalConfig = (\ help version say -> GlobalConfig {help, version, say}) 34 | <$> flag "help" (Just 'h') 35 | <*> flag "version" (Just 'v') 36 | <*> string "say" Nothing 37 | 38 | myPrefs :: Preferences Config 39 | myPrefs = defaultPreferences {globalOpts = globalConfig} 40 | 41 | -- | Try running the following: 42 | -- | 1. `pulp test -- one` 43 | -- | 2. `pulp test -- one --output` 44 | -- | 3. `pulp test -- one --output blah` 45 | -- | 4. `pulp test -- one two` 46 | -- | 5. `pulp test -- one two --help` 47 | -- | 5. `pulp test -- --version` 48 | -- | 6. `pulp test -- one --name "John" --name "Bob" --name "Billy" 49 | -- | 7. `pulp test -- --version` 50 | -- | 8. `pulp test -- --version --say doh` 51 | -- | 9. `pulp test` 52 | main :: Effect Unit 53 | main = do 54 | {cmd, value} <- optlicate configRec myPrefs 55 | maybe 56 | (log "No path parsed") 57 | (\ x -> log "Path parsed" *> log x) 58 | cmd 59 | unV 60 | (\ x -> do 61 | log "Errors found: " 62 | log (show (length x) <> " errors") 63 | logErrors x) 64 | (\ x -> log "Value found: " *> log (showConfig x)) 65 | value 66 | -------------------------------------------------------------------------------- /test/Types.purs: -------------------------------------------------------------------------------- 1 | module Test.Types where 2 | 3 | import Prelude 4 | import Node.Commando (Opt) 5 | import Data.List (List, fold) 6 | 7 | type ConfigRec = 8 | ( one :: Opt Config 9 | ( two :: Opt Config () 10 | ) 11 | ) 12 | 13 | data Config 14 | = GlobalConfig GlobalConfig 15 | | ConfigOne ConfigOne 16 | | ConfigTwo ConfigTwo 17 | 18 | showConfig :: Config -> String 19 | showConfig (GlobalConfig {help, version, say}) = 20 | "Global config parsed: \n" <> 21 | "help: " <> show help <> ", " <> 22 | "version: " <> show version <> ", " <> 23 | "say: " <> say 24 | showConfig (ConfigOne {output, names, help}) = 25 | "ConfigOne parsed: \n" <> 26 | "output: " <> output <> ", " <> 27 | "names: " <> fold names <> ", " <> 28 | "help: " <> show help 29 | showConfig (ConfigTwo {color, help}) = 30 | "ConfigTwo parsed: \n" <> 31 | "color: " <> show color <> ", " <> 32 | "help: " <> show help 33 | 34 | type GlobalConfig = 35 | { help :: Boolean 36 | , version :: Boolean 37 | , say :: String 38 | } 39 | 40 | type ConfigOne = 41 | { output :: String 42 | , names :: List String 43 | , help :: Boolean 44 | } 45 | 46 | type ConfigTwo = 47 | { color :: Boolean 48 | , help :: Boolean 49 | } 50 | --------------------------------------------------------------------------------