diff --git a/src/Options/Applicative/BashCompletion.purs b/src/Options/Applicative/BashCompletion.purs index 7b71bb6..3b75fb2 100644 --- a/src/Options/Applicative/BashCompletion.purs +++ b/src/Options/Applicative/BashCompletion.purs @@ -13,7 +13,7 @@ import Data.Array as Array import Data.Array.NonEmpty as NEA import Data.Either (Either(..)) import Data.Exists (runExists) -import Data.Foldable (fold, oneOf) +import Data.Foldable (fold) import Data.Generic.Rep (class Generic) import Data.Generic.Rep.Show (genericShow) import Data.List as List @@ -52,8 +52,8 @@ bashCompletionParser pinfo pprefs = complParser failure opts = CompletionResult { execCompletion: \progn -> unLines <$> opts progn } - complParser = oneOf - [ failure <$> + complParser = + ( failure <$> ( bashCompletionQuery pinfo pprefs -- To get rich completions, one just needs the first -- command. To customise the lengths, use either of @@ -68,16 +68,16 @@ bashCompletionParser pinfo pprefs = complParser <*> (map Array.fromFoldable <<< many <<< strOption) (long "bash-completion-word" `append` internal) <*> option int (long "bash-completion-index" `append` internal) ) - , failure <$> + ) <|> failure <$> (bashCompletionScript <$> strOption (long "bash-completion-script" `append` internal)) - , failure <$> + <|> failure <$> (fishCompletionScript <$> strOption (long "fish-completion-script" `append` internal)) - , failure <$> + <|> failure <$> (zshCompletionScript <$> strOption (long "zsh-completion-script" `append` internal)) - ] + bashCompletionQuery :: forall a. ParserInfo a -> ParserPrefs -> Richness -> Array String -> Int -> String -> Effect (Array String) bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl pprefs of diff --git a/src/Options/Applicative/Builder/Internal.purs b/src/Options/Applicative/Builder/Internal.purs index ce991c7..07ec46a 100644 --- a/src/Options/Applicative/Builder/Internal.purs +++ b/src/Options/Applicative/Builder/Internal.purs @@ -27,7 +27,6 @@ import Prelude import Options.Applicative.Common (liftOpt) import Options.Applicative.Types (Completer, OptName, OptProperties(..), OptReader, OptVisibility(..), Option(..), ParseError, Parser, ParserInfo) import Control.Alt (alt) -import Control.Plus (empty) import Data.Maybe (Maybe(..), maybe) import Data.Newtype (class Newtype, over) import Data.Tuple (Tuple, fst, lookup) @@ -169,9 +168,11 @@ mkParser :: forall a. DefaultProp a -> (OptProperties -> OptProperties) -> OptReader a -> Parser a -mkParser d@(DefaultProp def _) g rdr = liftOpt opt `alt` maybe empty pure def - where - opt = mkOption d g rdr +mkParser d@(DefaultProp def _) g rdr = + let + o = liftOpt $ mkOption d g rdr + in + maybe o (\a -> o `alt` pure a) def mkOption :: forall a. DefaultProp a -> (OptProperties -> OptProperties) diff --git a/src/Options/Applicative/Common.purs b/src/Options/Applicative/Common.purs index 12bb6ab..083a2a1 100644 --- a/src/Options/Applicative/Common.purs +++ b/src/Options/Applicative/Common.purs @@ -189,7 +189,7 @@ runParser policy isCmdStart p args = case args of prefs <- getPrefs (Tuple mp' args') <- do_step prefs arg argt case mp' of - Nothing -> hoistMaybe result <|> parseError arg p + Nothing -> hoistMaybe (unexpectedError arg p) result Just p' -> runParser (newPolicy arg) CmdCont p' args' where result = (Tuple) <$> evalParser p <*> pure args @@ -201,8 +201,8 @@ runParser policy isCmdStart p args = case args of NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals x -> x -parseError :: forall m x a. MonadP m => String -> Parser x -> m a -parseError arg p = errorP $ UnexpectedError arg $ SomeParser $ mkExists p +unexpectedError :: forall x. String -> Parser x -> ParseError +unexpectedError arg p = UnexpectedError arg $ SomeParser $ mkExists p runParserInfo :: forall m a. MonadP m => ParserInfo a -> Args -> m a runParserInfo i = runParserFully (un ParserInfo i).infoPolicy (un ParserInfo i).infoParser @@ -212,12 +212,12 @@ runParserFully policy p args = do (Tuple r args') <- runParser policy CmdStart p args case args' of List.Nil -> pure r - List.Cons head _ -> parseError head (pure unit) + List.Cons head _ -> errorP $ unexpectedError head (pure unit) -- | The default value of a 'Parser'. This function returns an error if any of -- | the options don't have a default value. evalParser :: forall a. Parser a -> Maybe a -evalParser (NilP r) = r +evalParser (NilP r) = Just r evalParser (OptP _) = Nothing evalParser (MultP e) = runExists (\(MultPE p1 p2) -> evalParser p1 <*> evalParser p2) e evalParser (AltP p1 p2) = evalParser p1 <|> evalParser p2 diff --git a/src/Options/Applicative/Extra.purs b/src/Options/Applicative/Extra.purs index 7913574..1585827 100644 --- a/src/Options/Applicative/Extra.purs +++ b/src/Options/Applicative/Extra.purs @@ -170,7 +170,6 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn -> where exit_code = case msg of ErrorMsg _ -> (un ParserInfo pinfo).infoFailureCode - UnknownError -> (un ParserInfo pinfo).infoFailureCode MissingError _ _ -> (un ParserInfo pinfo).infoFailureCode ExpectsArgError _ -> (un ParserInfo pinfo).infoFailureCode UnexpectedError _ _ -> (un ParserInfo pinfo).infoFailureCode @@ -225,10 +224,6 @@ parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn -> else "Invalid argument `" <> arg <> "'" in stringChunk msg' - UnknownError - -> mempty - - suggestion_help = suggestionsHelp $ case msg of UnexpectedError arg (SomeParser x) -- diff --git a/src/Options/Applicative/Internal.purs b/src/Options/Applicative/Internal.purs index 43bf034..1110094 100644 --- a/src/Options/Applicative/Internal.purs +++ b/src/Options/Applicative/Internal.purs @@ -53,7 +53,7 @@ import Data.Tuple (Tuple(..)) import Options.Applicative.Types (ArgPolicy, Completer, Context(..), IsCmdStart, ParseError(..), Parser, ParserInfo, ParserPrefs, ReadM(..), SomeParser(..)) import Options.Applicative.Types (ParseError(..)) as Reexport -class (MonadPlus m) <= MonadP (m :: Type -> Type) where +class (Monad m, Alt m) <= MonadP (m :: Type -> Type) where enterContext :: forall a. String -> ParserInfo a -> m Unit exitContext :: m Unit getPrefs :: m ParserPrefs @@ -75,20 +75,11 @@ instance pApplicative :: Applicative P where instance pAlt :: Alt P where alt (P x) (P y) = P $ x `alt` y -instance pPlus :: Plus P where - empty = P empty - -instance pAlternative :: Alternative P - instance pBind :: Bind P where bind (P x) k = P $ x >>= \a -> case k a of P y -> y instance pMonad :: Monad P -instance pMonadZero :: MonadZero P - -instance pMonadPlus :: MonadPlus P - contextNames :: Array Context -> Array String contextNames ns = let go (Context n _) = n @@ -103,8 +94,8 @@ instance pMonadP :: MonadP P where exitP i _ p = P <<< maybe (throwError <<< MissingError i <<< SomeParser $ mkExists p) pure errorP = P <<< throwError -hoistMaybe :: forall a m. MonadPlus m => Maybe a -> m a -hoistMaybe = maybe empty pure +hoistMaybe :: forall a m. MonadP m => ParseError -> Maybe a -> m a +hoistMaybe err = maybe (errorP err) pure hoistEither :: forall a m. MonadP m => Either ParseError a -> m a hoistEither = either errorP pure @@ -160,18 +151,12 @@ instance completionApplicative :: Applicative Completion where instance completionAlt :: Alt Completion where alt (Completion x) (Completion y) = Completion $ x `alt` y -instance completionPlus :: Plus Completion where - empty = Completion empty -instance completionAlternative :: Alternative Completion instance completionBind :: Bind Completion where bind (Completion x) k = Completion $ x >>= \a -> case k a of Completion y -> y instance completionMonad :: Monad Completion -instance completionMonadZero :: MonadZero Completion -instance completionMonadPlus :: MonadPlus Completion - instance completionMonadP :: MonadP Completion where enterContext _ _ = pure unit exitContext = pure unit diff --git a/src/Options/Applicative/Types.purs b/src/Options/Applicative/Types.purs index db00e18..bcf55f2 100644 --- a/src/Options/Applicative/Types.purs +++ b/src/Options/Applicative/Types.purs @@ -38,19 +38,19 @@ module Options.Applicative.Types ( optShowDefault, optDescMod, many, - some + some, + optional ) where import Prelude -import Control.Alternative (class Alt, class Alternative, class Plus, alt, empty, (<|>)) +import Control.Alternative (class Alt, alt, (<|>)) import Control.Monad.Except (Except) import Control.Monad.Except.Trans (class MonadThrow, throwError) import Control.Monad.Free (Free, liftF) import Control.Monad.Reader.Trans (ReaderT, ask) import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM) import Control.Monad.Trans.Class (lift) -import Control.MonadPlus (class MonadPlus, class MonadZero) import Data.Bifunctor (bimap) import Data.Exists (Exists, mkExists, runExists) import Data.Generic.Rep (class Generic) @@ -74,7 +74,6 @@ data ParseError = ErrorMsg String | InfoMsg String | ShowHelpText - | UnknownError | MissingError IsCmdStart SomeParser | ExpectsArgError String | UnexpectedError String SomeParser @@ -83,12 +82,7 @@ derive instance isCmdStartGeneric :: Generic IsCmdStart _ instance isCmdStartShow :: Show IsCmdStart where show = genericShow data IsCmdStart = CmdStart | CmdCont - -instance parseErrorMonoid :: Monoid ParseError where - mempty = UnknownError - instance parseErrorSemigroup :: Semigroup ParseError where - append m UnknownError = m append _ m = m @@ -228,11 +222,6 @@ instance readMApplicative :: Applicative ReadM where instance readMAlt :: Alt ReadM where alt (ReadM x) (ReadM y) = ReadM $ alt x y -instance readMPlus :: Plus ReadM where - empty = ReadM empty - -instance readMAlternative :: Alternative ReadM - instance readMBind :: Bind ReadM where bind (ReadM r) f = ReadM $ r >>= un ReadM <<< f @@ -241,9 +230,6 @@ instance readMMonad :: Monad ReadM instance readMMonadFail :: MonadThrow String ReadM where throwError = readerError -instance readMMonadZero :: MonadZero ReadM -instance readMMonadPlus :: MonadPlus ReadM - -- | Return the value being read. readerAsk :: ReadM String readerAsk = ReadM ask @@ -320,7 +306,7 @@ instance optReaderFunctor :: Functor OptReader where -- | -- | creates a parser for an option called \"output\". data Parser a - = NilP (Maybe a) + = NilP a | OptP (Option a) | MultP (Exists (MultPE a)) | AltP (Parser a) (Parser a) @@ -329,7 +315,7 @@ data Parser a data MultPE a x = MultPE (Parser (x -> a)) (Parser x) instance parserFunctor :: Functor Parser where - map f (NilP x) = NilP (map f x) + map f (NilP x) = NilP (f x) map f (OptP opt) = OptP (map f opt) map f (MultP e) = runExists (\(MultPE p1 p2) -> MultP $ mkExists $ MultPE (map (f <<< _) p1) p2) e map f (AltP p1 p2) = AltP (map f p1) (map f p2) @@ -339,16 +325,11 @@ instance parserApply :: Apply Parser where apply a b = MultP (mkExists (MultPE a b)) instance parserApplicative :: Applicative Parser where - pure = NilP <<< Just + pure = NilP instance parserAlt :: Alt Parser where alt = AltP -instance parserPlus :: Plus Parser where - empty = NilP Nothing - -instance parserAlternative :: Alternative Parser - newtype ParserM a = ParserM (Free Parser a) derive newtype instance parserMFunctor :: Functor ParserM @@ -419,6 +400,9 @@ many = manyM >>> fromM some :: forall a. Parser a -> Parser (NonEmptyList a) some = someM >>> fromM +optional :: forall f a. Alt f => Applicative f => f a -> f (Maybe a) +optional a = map Just a <|> pure Nothing + -- | optparse-applicative supplies a rich completion system for bash, -- | zsh, and fish shells. -- | diff --git a/test/Main.purs b/test/Main.purs index a4ec6ef..437cc1c 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -7,7 +7,6 @@ import Control.Lazy (defer) import Control.Monad.Gen (class MonadGen, chooseFloat, chooseInt, suchThat) import Control.Monad.Gen.Common (genMaybe) import Control.Monad.Rec.Class (class MonadRec) -import Control.MonadZero (guard) import Data.Array (fold, foldl, replicate) import Data.Array as Array import Data.Char.Gen (genUnicodeChar) @@ -15,7 +14,7 @@ import Data.Either (Either(..)) import Data.Foldable (elem) import Data.Int (even, odd) import Data.List as List -import Data.Maybe (Maybe(..), fromMaybe, isJust, optional) +import Data.Maybe (Maybe(..), fromMaybe, isJust) import Data.String (Pattern) import Data.String as String import Data.String.CodeUnits (toCharArray) @@ -35,7 +34,7 @@ import ExitCodes as ExitCode import Options.Applicative (argument, briefDesc, columns, command, completeWith, defaultPrefs, disambiguate, execParserPure, flag', forwardOptions, header, help, (<**>), helper, hidden, info, int, long, metavar, noBacktrack, noIntersperse, option, prefs, progDesc, renderFailure, short, showDefault, showHelpOnEmpty, showHelpOnError, str, strArgument, strOption, subparser, subparserInline, switch, value) import Options.Applicative.Help (Chunk(..), editDistance, extractChunk, isEmpty, listToChunk, paragraph, stringChunk) import Options.Applicative.Internal.Utils (lines, words) -import Options.Applicative.Types (CompletionResult(..), ParserFailure, ParserHelp, ParserInfo, ParserPrefs, ParserResult(..), ReadM, many, readerAsk, readerError, some) +import Options.Applicative.Types (CompletionResult(..), ParserFailure, ParserHelp, ParserInfo, ParserPrefs, ParserResult(..), ReadM, many, readerAsk, readerError, some, optional) import Test.QuickCheck ((), (===)) import Test.QuickCheck as QC import Test.QuickCheck.Gen (Gen) @@ -85,7 +84,7 @@ assertCompletion x f = case x of pure $ f completions Failure _ -> pure $ counterExample "unexpected failure" Success val -> pure $ counterExample ("unexpected result " <> show val) - + assertHasLine :: String -> String -> QC.Result assertHasLine l s = l `elem` lines s ("expected line:\n\t" <> l <> "\nnot found") @@ -95,8 +94,10 @@ isInfixOf p = String.indexOf p >>> isJust condr :: (Int -> Boolean) -> ReadM Int condr f = do x <- int - guard (f x) - pure x + if (f x) then + pure x + else + readerError "oh no" type Asset = { name :: String, msg :: String }