butcher 1.3.3.0 → 1.3.3.1
raw patch · 4 files changed
+5/−465 lines, 4 filesdep ~base
Dependency ranges changed: base
Files
- ChangeLog.md +4/−0
- butcher.cabal +1/−3
- src/UI/Butcher/Applicative.hs +0/−317
- src/UI/Butcher/Applicative/Types.hs +0/−145
ChangeLog.md view
@@ -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
butcher.cabal view
@@ -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 <https://github.com/lspitzner/butcher/blob/master/README.md README> (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:
− src/UI/Butcher/Applicative.hs
@@ -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 ++ "!"--}
− src/UI/Butcher/Applicative/Types.hs
@@ -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)