diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for butcher +## 1.3.3.1 -- April 2020 + +* Fix a cabal file mistake + ## 1.3.3.0 -- April 2020 * Fix bug with params with default when parsing from commandline diff --git a/butcher.cabal b/butcher.cabal --- a/butcher.cabal +++ b/butcher.cabal @@ -1,5 +1,5 @@ name: butcher -version: 1.3.3.0 +version: 1.3.3.1 synopsis: Chops a command or program invocation into digestable pieces. description: See the (it is properly formatted on github). license: BSD3 @@ -34,8 +34,6 @@ UI.Butcher.Monadic.IO UI.Butcher.Monadic.Interactive UI.Butcher.Monadic.BuiltinCommands - UI.Butcher.Applicative.Types - UI.Butcher.Applicative other-modules: UI.Butcher.Monadic.Internal.Types UI.Butcher.Monadic.Internal.Core build-depends: diff --git a/src/UI/Butcher/Applicative.hs b/src/UI/Butcher/Applicative.hs deleted file mode 100644 --- a/src/UI/Butcher/Applicative.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} - -module UI.Butcher.Applicative where - - - -#include "prelude.inc" - -import UI.Butcher.Applicative.Types -import Control.Applicative.Free -import qualified Text.PrettyPrint as PP - - -data DescState = DescState - { parts :: Deque PartDesc - , children :: Deque (String, CommandDesc) - , help :: Maybe PP.Doc - , reorder :: Maybe (Deque PartDesc) - } - -toCmdDesc :: forall out . CmdParser out out -> CommandDesc -toCmdDesc cmdParser = - let final = appEndo (runAp_ f cmdParser) initialState - in CommandDesc { _cmd_mParent = Nothing - , _cmd_synopsis = Nothing - , _cmd_help = help final - , _cmd_parts = Data.Foldable.toList $ parts final - , _cmd_children = Data.Foldable.toList $ children final - , _cmd_visibility = Visible - } - where - f :: CmdParserF out a -> Endo (DescState) - f x = Endo $ \s -> case x of - CmdParserHelp doc _ -> s { help = Just doc } - CmdParserSynopsis _ _ -> error "todo" - CmdParserPeekInput _ -> s - CmdParserPart desc _ _ -> appendPart s desc - CmdParserPartMany _ desc _ _ -> appendPart s desc - CmdParserPartInp desc _ _ -> appendPart s desc - CmdParserPartManyInp _ desc _ _ -> appendPart s desc - CmdParserChild name parser _ -> appendChild s $ (name, toCmdDesc parser) - CmdParserReorderStart _ -> s { reorder = reorder s <|> Just empty } - CmdParserReorderStop _ -> case reorder s of - Nothing -> s - Just ps -> s { parts = parts s <> ps, reorder = Nothing } - where - appendPart s p = s { parts = Deque.snoc p (parts s) } - appendChild s c = s { children = Deque.snoc c (children s) } - initialState = DescState { parts = mempty - , children = mempty - , help = Nothing - , reorder = mempty - } - -data ParserState out = ParserState - { p_parts :: Deque PartDesc - , p_children :: Deque (String, CommandDesc) - , p_help :: Maybe PP.Doc - , p_reorder :: Maybe (Deque PartDesc) - , p_input :: Input - } - -runCmdParser - :: Input -> CmdParser out out -> (CommandDesc, Either ParsingError out) -runCmdParser initialInput initialParser = - let topDesc = toCmdDesc initialParser - in (topDesc, go initialInput topDesc initialParser) - where - go :: Input -> CommandDesc -> CmdParser out out -> Either ParsingError out - go input desc parser = - -- TODO use x? - let initialState = ParserState { p_parts = mempty - , p_children = mempty - , p_help = Nothing - , p_reorder = mempty - , p_input = input - } - (outE, _x) = StateS.runState (iter parser) initialState - in outE - where - iter - :: CmdParser out out - -> StateS.State (ParserState out) (Either ParsingError out) - iter = \case - Pure x -> pure $ Right x - Ap (CmdParserHelp _ x) next -> continue next x - Ap (CmdParserSynopsis _ x) next -> continue next x - Ap (CmdParserPeekInput f ) next -> do - s <- StateS.get - iter $ next <&> \g -> g $ f (inputToString $ p_input s) - Ap (CmdParserPart _ parseF f) next -> parseWithStr - parseF - (\x -> iter $ next <&> \g -> g (f x)) - (\s -> pure $ Left $ ParsingError { _pe_messages = ["could not parse"] - , _pe_remaining = p_input s - } - ) - Ap (CmdParserPartMany _ _ parseF f) next -> do - let loop = do - dropSpaces - parseWithStr - parseF - (\x -> do - more <- loop - pure (x : more) - ) - (\_ -> pure []) - ps <- loop - iter $ next <&> \g -> g (f ps) - Ap (CmdParserPartInp _ parseF f) next -> do - s <- StateS.get - case parseF (p_input s) of - Just (x, rest) -> do - StateS.put s { p_input = rest } - iter $ next <&> \g -> g (f x) - Nothing -> pure $ Left $ ParsingError - { _pe_messages = ["could not parse"] - , _pe_remaining = p_input s - } - Ap (CmdParserPartManyInp _ _ parseF f) next -> do - let loop = do - dropSpaces - s <- StateS.get - case parseF (p_input s) of - Just (x, rest) -> do - StateS.put s { p_input = rest } - (x :) <$> loop - Nothing -> pure $ [] - ps <- loop - iter $ next <&> \g -> g (f ps) - Ap (CmdParserChild name childParser x) next -> do - dropSpaces - s <- StateS.get - let childDesc = case find ((== name) . fst) (_cmd_children desc) of - Just (_, d) -> d - Nothing -> error "inconsistent child name map" - case p_input s of - InputString str -> if - | str == name -> do - pure $ go (InputString "") childDesc childParser - | --- TODO str prefix - otherwise -> continue next x - InputArgs (a1 : ar) | a1 == name -> do - pure $ go (InputArgs ar) childDesc childParser - InputArgs{} -> continue next x - Ap (CmdParserReorderStart _) next -> error "TODO" next - Ap (CmdParserReorderStop _) next -> error "TODO" next - where - continue next x = iter (($x) <$> next) - parseWithStr f successF failF = do - s <- StateS.get - case p_input s of - InputString str -> case f str of - Just (x, rest) -> do - StateS.put s { p_input = InputString rest } - successF x - Nothing -> failF s - InputArgs (a1 : ar) -> case f a1 of - Just (x, "") -> do - StateS.put s { p_input = InputArgs ar } - successF x - _ -> failF s - InputArgs [] -> failF s - - inputToString :: Input -> String - inputToString (InputString s ) = s - inputToString (InputArgs ss) = List.unwords ss - dropSpaces = do - st <- StateS.get - case p_input st of - InputString s -> - StateS.put $ st { p_input = InputString $ dropWhile Char.isSpace s } - InputArgs{} -> return () - -addCmdPart - :: Typeable p => PartDesc -> (String -> Maybe (p, String)) -> CmdParser out p -addCmdPart p f = liftAp $ CmdParserPart p f id - -addCmdPartMany - :: Typeable p - => ManyUpperBound - -> PartDesc - -> (String -> Maybe (p, String)) - -> CmdParser out [p] -addCmdPartMany b p f = liftAp $ CmdParserPartMany b p f id - -addCmdPartInp - :: Typeable p => PartDesc -> (Input -> Maybe (p, Input)) -> CmdParser out p -addCmdPartInp p f = liftAp $ CmdParserPartInp p f id - -addCmdPartManyInp - :: Typeable p - => ManyUpperBound - -> PartDesc - -> (Input -> Maybe (p, Input)) - -> CmdParser out [p] -addCmdPartManyInp b p f = liftAp $ CmdParserPartManyInp b p f id - -data Param p = Param - { _param_default :: Maybe p - , _param_help :: Maybe PP.Doc - , _param_suggestions :: Maybe [CompletionItem] - } - -addReadParam - :: forall out a - . (Typeable a, Show a, Text.Read.Read a) - => String -- ^ paramater name, for use in usage/help texts - -> Param a -- ^ properties - -> CmdParser out a -addReadParam name par = addCmdPart desc parseF - where - desc :: PartDesc - desc = - addSuggestion (_param_suggestions par) - $ (maybe id PartWithHelp $ _param_help par) - $ (maybe id (PartDefault . show) $ _param_default par) - $ PartVariable name - parseF :: String -> Maybe (a, String) - parseF s = case Text.Read.reads s of - ((x, ' ' : r) : _) -> Just (x, dropWhile Char.isSpace r) - ((x, [] ) : _) -> Just (x, []) - _ -> _param_default par <&> \x -> (x, s) - -addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc -addSuggestion Nothing = id -addSuggestion (Just sugs) = PartSuggestion sugs - - -data Flag a = Flag - { flag_name :: String - , flag_short :: String - , flag_long :: [String] - , flag_opts :: FlagOpts a - , flag_parser :: String -> Maybe (Identity a, String) - } - -data FlagOpts a = FlagOpts - { _flag_help :: Maybe PP.Doc - , _flag_default :: Maybe a - , _flag_visibility :: Visibility - } - -traverseFlags - :: (Covered c, CTraversable Typeable (c 'Wrap)) - => c 'Wrap Flag - -> CmdParser out (c 'Bare Identity) -traverseFlags k = do - r <- cTraverse - (Proxy @Typeable) - (\f -> addCmdPart (PartVariable (flag_name f)) (flag_parser f)) - k - pure $ unwrap r - -test :: IO () -test = do - let parser = do - arg :: Int <- addReadParam - "arg" - Param { _param_default = Nothing - , _param_help = Nothing - , _param_suggestions = Nothing - } - pure $ print arg - let (desc, eOut) = runCmdParser (InputArgs ["42"]) parser - print desc - case eOut of - Left err -> do - putStrLn "parsing error" - print err - Right f -> f - --- butcherMain :: ButcherA (IO ()) -> IO () --- --- type ButcherA out = Writer [ButcherCmd out] () --- type ButcherCmd = Ap ButcherCmdF out --- data ButcherCmdF a --- = ButcherCmdHelp String (() -> a) --- | ButcherCmdParamString (String -> a) - - -{- -stringArg :: UnwrapField ('Just Arg) String -stringArg = mempty - -argDef :: a -> UnwrapField ('Just Arg) a -argDef x = mempty { _arg_def = Just x } - -fromUnordered - :: (Covered h, CTraversable (h Wrap)) - => String - -> h Wrap Arg - -> CmdParserF out (h Plain Identity) - -data Arg a = Arg - { _arg_def :: Maybe a - , _arg_help :: Maybe String - } - -instance Monoid (Arg a) where .. - -data MyArgs s f = MyArgs - { greeting :: Wear s f String - , name :: Wear s f String - } - -main = butcherMain $ do - args <- fromUnordered MyArgs - { greeting = stringArg <> argDef "hi" - , name = stringArg - } - pure do - putStrLn $ greeting args ++ ", " ++ name args ++ "!" --} diff --git a/src/UI/Butcher/Applicative/Types.hs b/src/UI/Butcher/Applicative/Types.hs deleted file mode 100644 --- a/src/UI/Butcher/Applicative/Types.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} - -module UI.Butcher.Applicative.Types where - - - -#include "prelude.inc" -import Control.Applicative.Free -import qualified Control.Monad.Trans.MultiState.Strict - as MultiStateS - --- import qualified Lens.Micro.TH as LensTH - -import qualified Text.PrettyPrint as PP - - - --- | Butcher supports two input modi: @String@ and @[String]@. Program --- arguments have the latter form, while parsing interactive command input --- (e.g. when you implement a terminal of sorts) is easier when you can --- process the full @String@ without having to wordify it first by some --- means (and List.words is not the right approach in many situations.) -data Input = InputString String | InputArgs [String] - deriving (Show, Eq) - --- | Information about an error that occured when trying to parse some @Input@ --- using some @CmdParser@. -data ParsingError = ParsingError - { _pe_messages :: [String] - , _pe_remaining :: Input - } - deriving (Show, Eq) - --- | Specifies whether we accept 0-1 or 0-n for @CmdParserPart@s. -data ManyUpperBound - = ManyUpperBound1 - | ManyUpperBoundN - -data Visibility = Visible | Hidden - deriving (Show, Eq) - - -data CmdParserF out a - = CmdParserHelp PP.Doc a - | CmdParserSynopsis String a - -- | CmdParserPeekDesc (CommandDesc () -> a) - | CmdParserPeekInput (String -> a) - -- TODO: we can clean up this duplication by providing - -- a function (String -> Maybe (p, String)) -> (Input -> Maybe (p, Input)). - | forall p . Typeable p => CmdParserPart - PartDesc - (String -> Maybe (p, String)) - (p -> a) - | forall p . Typeable p => CmdParserPartMany - ManyUpperBound PartDesc - (String -> Maybe (p, String)) - ([p] -> a) - | forall p . Typeable p => CmdParserPartInp - PartDesc - (Input -> Maybe (p, Input)) - (p -> a) - | forall p . Typeable p => CmdParserPartManyInp - ManyUpperBound - PartDesc - (Input -> Maybe (p, Input)) - ([p] -> a) - | CmdParserChild String (CmdParser out out) a - | CmdParserReorderStart a - | CmdParserReorderStop a - -- | CmdParserGrouped String a - -- | CmdParserGroupEnd a - -type CmdParser out = Ap (CmdParserF out) - ---------- - --- | A representation/description of a command parser built via the --- 'CmdParser' monad. Can be transformed into a pretty Doc to display --- as usage/help via 'UI.Butcher.Monadic.Pretty.ppUsage' and related functions. --- --- Note that there is the '_cmd_out' accessor that contains @Maybe out@ which --- might be useful after successful parsing. -data CommandDesc = CommandDesc - { _cmd_mParent :: Maybe (Maybe String, CommandDesc) - , _cmd_synopsis :: Maybe PP.Doc - , _cmd_help :: Maybe PP.Doc - , _cmd_parts :: [PartDesc] - , _cmd_children :: [(String, CommandDesc)] - , _cmd_visibility :: Visibility - } - deriving Show - --- type PartSeqDesc = [PartDesc] - --- | A representation/description of a command's parts, i.e. flags or params. --- As a butcher user, the higher-level pretty-printing functions for --- 'CommandDesc' are probably sufficient. -data PartDesc - = PartLiteral String -- expect a literal string, like "--dry-run" - | PartVariable String -- expect some user-provided input. The - -- string represents the name for the variable - -- used in the documentation, e.g. "FILE" - | PartOptional PartDesc - | PartAlts [PartDesc] - | PartSeq [PartDesc] - | PartDefault String -- default representation - PartDesc - | PartSuggestion [CompletionItem] PartDesc - | PartRedirect String -- name for the redirection - PartDesc - | PartReorder [PartDesc] - | PartMany PartDesc - | PartWithHelp PP.Doc PartDesc - | PartHidden PartDesc - deriving Show - -data CompletionItem - = CompletionString String - | CompletionDirectory - | CompletionFile - deriving Show - -data Cover - = Bare - | Wrap - -type family Wear cover f a where - Wear 'Bare Identity a = a - Wear 'Wrap f a = f a - -class Covered c where - wrap :: c 'Bare Identity -> c 'Wrap Identity - unwrap :: c 'Wrap Identity -> c 'Bare Identity - -class CTraversable ctx c where - cTraverse :: Proxy ctx -> (forall a . ctx a => f a -> m (g a)) -> c f -> m (c g)