diff --git a/README.md b/README.md new file mode 100644 index 0000000..476532a --- /dev/null +++ b/README.md @@ -0,0 +1,94 @@ +# butcher + +#### Chops a command or program invocation into digestable pieces. + +Similar to the `optparse-applicative` package, but less features, +more flexibility and more evil. + +The main differences are: + +* Provides a pure interface by default + +* Has clearly defined semantics, see the section below. + +* Exposes an evil monadic interface, which allows for much nicer binding of + command part results to some variable name, where in `optparse-applicative` + you easily lose track of what field you are modifying after the 5th `<*>`. + + Evil, because you are not allowed to use the monad's full power in this + case, i.e. there is a constraint that is not statically enforced. + See below. + +* The monadic interface allows much clearer definitions of commandparses + with (nested) subcommands. No pesky sum-types are necessary. + +* Additionally, it is possible to wrap everything in _another_ applicative + (chosen by the user) and execute actions whenever specific parts are + parsed successfully. This provides a direct interface for more advanced + features, like `--no-foo` pendants to `--foo` flags. + +## The evil monadic interface + +As long as you only use Applicative or (Kleisli) Arrow, you can use the +interface freely. When you use Monad, there is one rule: Whenever you read +any command-parts like in + +~~~~ +f <- addFlag ... +p <- addParam ... +~~~~ + +you are only allowed to use bindings bound thusly in any command's +implemenation, i.e. inside the parameter to `addCmdImpl`. You are _not_ +allowed to force/inspect/patternmatch on them before that. _good_ usage is: + +~~~~ +addCmdImpl $ do + print x + print y +~~~~ + +while _bad_ would be + +~~~~ +f <- addFlag +when f $ do + p <- addParam + -- evil: the existence of the param `p` + -- depends on parse result for the flag `f`. +~~~~ + +That means that checking if a combination of flags is allowed must be done +after parsing. (But different commands and their subcommands have separate +sets of flags.) + +## Package intentions + +Consider a commandline invocation like "ghc -O -i src -Main.hs -o Main". This +package provides a way for the programmer to simultaneously define the +semantics of your program based on its arguments and retrieve documentation +for the user. More specifically, i had three goals in mind: + +1. Straight-forward description of (sub)command and flag-specific behaviour +2. Extract understandable usage/help commandline documents/texts from that + descriptions, think of `ghc --help` or `stack init --help`. +3. Extract necessary information to compute commandline completion results + from any partial input. + +## Semantics + +Basic elements of a command are flags, parameters and subcommands. These can +be composed in certain ways, i.e. flags can have a (or possibly multiple?) +parameters; parameters can be grouped into sequences, and commands can have +subcommands. + +Commands are essentially `String -> Either ParseError out` where `out` can +be chosen by the user. It could for example be `IO ()`. + +To allow more flexible composition, the parts of a command have the "classic" +parser's type: `String -> Maybe (p, String)` where `p` depends on the part. +Parse a prefix of the input and return something and the remaining input, or +fail with `Nothing`. + +A command-parser contains a sequence of parts and then a number of subcommands +and/or some implementation. diff --git a/butcher.cabal b/butcher.cabal new file mode 100644 index 0000000..05962df --- /dev/null +++ b/butcher.cabal @@ -0,0 +1,134 @@ +-- Initial cmdparse-applicative.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: butcher +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +license-file: LICENSE +author: Lennart Spitzner +maintainer: lsp@informatik.uni-kiel.de +-- copyright: +-- category: +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +flag butcher-dev + description: dev options + default: False + +library + exposed-modules: UI.Butcher.Monadic.Types + UI.Butcher.Monadic + UI.Butcher.Monadic.Core + UI.Butcher.Monadic.Param + UI.Butcher.Monadic.Flag + UI.Butcher.Monadic.Pretty + UI.Butcher.Monadic.IO + -- other-modules: + -- other-extensions: + build-depends: + { base >=4.9 && <4.10 + , free + , unsafe + , lens + , qualified-prelude + , multistate + , pretty + , containers + , either + , transformers + , mtl + , extra + } + if flag(butcher-dev) { + build-depends: + hspec + } + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + ApplicativeDo + } + ghc-options: { + -Wall + -fprof-auto -fprof-cafs -fno-spec-constr + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + if flag(butcher-dev) { + ghc-options: -O0 -Werror + } + +test-suite tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: + { base >=4.9 && <4.10 + , butcher + , free + , unsafe + , lens + , qualified-prelude + , multistate + , pretty + , containers + , either + , transformers + , mtl + , extra + } + if flag(butcher-dev) { + buildable: True + build-depends: + hspec + } else { + buildable: False + } + ghc-options: -Wall + main-is: TestMain.hs + other-modules: + hs-source-dirs: src-tests + default-extensions: { + CPP + + NoImplicitPrelude + + GADTs + + FlexibleContexts + FlexibleInstances + ScopedTypeVariables + MonadComprehensions + LambdaCase + MultiWayIf + KindSignatures + } + ghc-options: { + -Wall + -O0 + -fprof-auto -fprof-cafs -fno-spec-constr + -j + -fno-warn-unused-imports + -fno-warn-orphans + } + if flag(butcher-dev) { + ghc-options: -Werror + } + diff --git a/cmdparse-applicative.cabal b/cmdparse-applicative.cabal deleted file mode 100644 index c8d6084..0000000 --- a/cmdparse-applicative.cabal +++ /dev/null @@ -1,69 +0,0 @@ --- Initial cmdparse-applicative.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: cmdparse-applicative -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -license-file: LICENSE -author: Lennart Spitzner -maintainer: lsp@informatik.uni-kiel.de --- copyright: --- category: -build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >=1.10 - -flag cmdparse-applicative-dev - description: dev options - default: False - -library - exposed-modules: UI.CmdParse.Applicative.Types - UI.CmdParse.Applicative - UI.CmdParse.Monadic.Types - UI.CmdParse.Monadic - -- other-modules: - -- other-extensions: - build-depends: - { base >=4.9 && <4.10 - , free - , unsafe - , lens - , qualified-prelude - , multistate - , pretty - , containers - , either - , transformers - , mtl - } - hs-source-dirs: src - default-language: Haskell2010 - default-extensions: { - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - ApplicativeDo - } - ghc-options: { - -Wall - -fprof-auto -fprof-cafs -fno-spec-constr - -j - -fno-warn-unused-imports - -fno-warn-orphans - } - if flag(cmdparse-applicative-dev) { - ghc-options: -O0 -Werror - } diff --git a/src-tests/TestMain.hs b/src-tests/TestMain.hs new file mode 100644 index 0000000..806cb50 --- /dev/null +++ b/src-tests/TestMain.hs @@ -0,0 +1,125 @@ +module Main where + + + +#include "qprelude/bundle-gamma.inc" + +import Test.Hspec + +-- import NeatInterpolation + +import UI.Butcher.Monadic + + + +main :: IO () +main = hspec $ tests + +tests :: Spec +tests = do + describe "checkTests" checkTests + describe "simpleParseTest" simpleParseTest + describe "simpleRunTest" simpleRunTest + + +checkTests :: Spec +checkTests = do + before_ pending $ it "check001" $ True `shouldBe` True + + +simpleParseTest :: Spec +simpleParseTest = do + it "failed parse 001" $ cmdRunParser Nothing (InputString "foo") testCmd1 + `shouldSatisfy` Data.Either.Combinators.isLeft . snd + it "toplevel" $ (testParse testCmd1 "" >>= _cmd_out) + `shouldSatisfy` Maybe.isNothing + it "hasImpl 001" $ (testParse testCmd1 "abc" >>= _cmd_out) + `shouldSatisfy` Maybe.isJust + it "hasImpl 002" $ (testParse testCmd1 "def" >>= _cmd_out) + `shouldSatisfy` Maybe.isJust + + +simpleRunTest :: Spec +simpleRunTest = do + it "failed run" $ testRun testCmd1 "" `shouldBe` Right Nothing + describe "no reordering" $ do + it "cmd 1" $ testRun testCmd1 "abc" `shouldBe` Right (Just 100) + it "cmd 2" $ testRun testCmd1 "def" `shouldBe` Right (Just 200) + it "flag 1" $ testRun testCmd1 "abc -f" `shouldBe` Right (Just 101) + it "flag 2" $ testRun testCmd1 "abc --flong" `shouldBe` Right (Just 101) + it "flag 3" $ testRun testCmd1 "abc -f -f" `shouldBe` Right (Just 101) + it "flag 4" $ testRun testCmd1 "abc -f -g" `shouldBe` Right (Just 103) + it "flag 5" $ testRun testCmd1 "abc -f -g -f" `shouldSatisfy` Data.Either.Combinators.isLeft -- no reordering + it "flag 6" $ testRun testCmd1 "abc -g -f" `shouldSatisfy` Data.Either.Combinators.isLeft -- no reordering + it "flag 7" $ testRun testCmd1 "abc -g -g" `shouldBe` Right (Just 102) + describe "with reordering" $ do + it "cmd 1" $ testRun testCmd2 "abc" `shouldBe` Right (Just 100) + it "cmd 2" $ testRun testCmd2 "def" `shouldBe` Right (Just 200) + it "flag 1" $ testRun testCmd2 "abc -f" `shouldBe` Right (Just 101) + it "flag 2" $ testRun testCmd2 "abc --flong" `shouldBe` Right (Just 101) + it "flag 3" $ testRun testCmd2 "abc -f -f" `shouldBe` Right (Just 101) + it "flag 4" $ testRun testCmd2 "abc -f -g" `shouldBe` Right (Just 103) + it "flag 5" $ testRun testCmd2 "abc -f -g -f" `shouldBe` Right (Just 103) + it "flag 6" $ testRun testCmd2 "abc -g -f" `shouldBe` Right (Just 103) + it "flag 7" $ testRun testCmd2 "abc -g -g" `shouldBe` Right (Just 102) + describe "with action" $ do + it "flag 1" $ testRunA testCmd3 "abc" `shouldBe` Right 0 + it "flag 2" $ testRunA testCmd3 "abc -f" `shouldBe` Right 1 + it "flag 3" $ testRunA testCmd3 "abc -g" `shouldBe` Right 2 + it "flag 4" $ testRunA testCmd3 "abc -f -g" `shouldBe` Right 3 + it "flag 5" $ testRunA testCmd3 "abc -g -f" `shouldBe` Right 3 + + +testCmd1 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () +testCmd1 = do + addCmd "abc" $ do + f <- addSimpleBoolFlag "f" ["flong"] mempty + g <- addSimpleBoolFlag "g" ["glong"] mempty + addCmdImpl $ do + when f $ WriterS.tell 1 + when g $ WriterS.tell 2 + WriterS.tell 100 + addCmd "def" $ do + addCmdImpl $ do + WriterS.tell 200 + +testCmd2 :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () +testCmd2 = do + addCmd "abc" $ do + reorderStart + f <- addSimpleBoolFlag "f" ["flong"] mempty + g <- addSimpleBoolFlag "g" ["glong"] mempty + reorderStop + addCmdImpl $ do + when f $ WriterS.tell 1 + when g $ WriterS.tell 2 + WriterS.tell 100 + addCmd "def" $ do + addCmdImpl $ do + WriterS.tell 200 + +testCmd3 :: CmdParser (StateS.State Int) () () +testCmd3 = do + addCmd "abc" $ do + reorderStart + addSimpleFlagA "f" ["flong"] mempty (StateS.modify (+1)) + addSimpleFlagA "g" ["glong"] mempty (StateS.modify (+2)) + reorderStop + addCmdImpl () + addCmd "def" $ do + addCmdImpl () + +testParse :: CmdParser Identity out () -> String -> Maybe (CommandDesc out) +testParse cmd s = either (const Nothing) Just + $ snd + $ cmdRunParser Nothing (InputString s) cmd + +testRun :: CmdParser Identity (WriterS.Writer (Sum Int) ()) () -> String -> Either ParsingError (Maybe Int) +testRun cmd s = fmap (fmap (getSum . WriterS.execWriter) . _cmd_out) + $ snd + $ cmdRunParser Nothing (InputString s) cmd + +testRunA :: CmdParser (StateS.State Int) () () -> String -> Either ParsingError Int +testRunA cmd str = (\((_, e), s) -> e $> s) + $ flip StateS.runState (0::Int) + $ cmdRunParserA Nothing (InputString str) cmd diff --git a/src/UI/Butcher/Monadic.hs b/src/UI/Butcher/Monadic.hs new file mode 100644 index 0000000..e6ac82b --- /dev/null +++ b/src/UI/Butcher/Monadic.hs @@ -0,0 +1,98 @@ +module UI.Butcher.Monadic + ( module Export + , cmds + -- , sample + -- , test + , test2 + , test3 + ) +where + + + +#include "qprelude/bundle-gamma.inc" + +import qualified Text.PrettyPrint as PP + +import UI.Butcher.Monadic.Types as Export +import UI.Butcher.Monadic.Core as Export +import UI.Butcher.Monadic.Flag as Export +import UI.Butcher.Monadic.Param as Export +import UI.Butcher.Monadic.Pretty as Export +import UI.Butcher.Monadic.IO as Export + +-- import qualified Options.Applicative as OPA + + +cmds :: CmdParser Identity (IO ()) () +cmds = do + addCmd "echo" $ do + addCmdHelpStr "print its parameter to output" + str <- addReadParam "STRING" (paramHelpStr "the string to print") + addCmdImpl $ do + putStrLn str + addCmd "hello" $ do + addCmdHelpStr "greet the user" + reorderStart + short <- addSimpleBoolFlag "" ["short"] mempty + name <- addReadParam "NAME" (paramHelpStr "your name, so you can be greeted properly" + <> paramDefault "user") + reorderStop + addCmdImpl $ do + if short + then putStrLn $ "hi, " ++ name ++ "!" + else putStrLn $ "hello, " ++ name ++ ", welcome from butcher!" + addCmd "foo" $ do + addCmdHelpStr "foo" + desc <- peekCmdDesc + addCmdImpl $ do + putStrLn "foo" + print $ ppHelpShallow desc + addCmd "help" $ do + desc <- peekCmdDesc + addCmdImpl $ do + print $ ppHelpShallow $ maybe undefined snd (_cmd_mParent desc) + +data Sample = Sample + { _hello :: Int + , _s1 :: String + , _s2 :: String + , _quiet :: Bool + } + deriving Show + +-- sample :: OPA.Parser Sample +-- sample = Sample +-- <$> OPA.option OPA.auto +-- ( OPA.long "hello" +-- <> OPA.metavar "TARGET" +-- <> OPA.help "Target for the greeting" ) +-- <*> OPA.strArgument (OPA.metavar "S1") +-- <*> OPA.strArgument (OPA.metavar "S2") +-- <*> OPA.switch +-- ( OPA.long "quiet" +-- <> OPA.help "Whether to be quiet" ) +-- +-- test :: String -> OPA.ParserResult Sample +-- test s = OPA.execParserPure OPA.defaultPrefs (OPA.ParserInfo sample True mempty mempty mempty (-13) True) (List.words s) + +test2 :: IO () +test2 = case cmdCheckParser (Just "butcher") cmds of + Left e -> putStrLn $ "LEFT: " ++ e + Right desc -> do + print $ ppUsage desc + print $ maybe undefined id $ ppUsageAt ["hello"] desc + +test3 :: String -> IO () +test3 s = case cmdRunParser (Just "butcher") (InputString s) cmds of + (desc, Left e) -> do + print e + print $ ppHelpShallow desc + _cmd_mParent desc `forM_` \(_, d) -> do + print $ ppUsage d + (desc, Right out) -> do + case _cmd_out out of + Nothing -> do + putStrLn "command is missing implementation!" + print $ ppHelpShallow desc + Just f -> f diff --git a/src/UI/Butcher/Monadic/Core.hs b/src/UI/Butcher/Monadic/Core.hs new file mode 100644 index 0000000..9d603fc --- /dev/null +++ b/src/UI/Butcher/Monadic/Core.hs @@ -0,0 +1,913 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} + +module UI.Butcher.Monadic.Core + ( addCmdSynopsis + , addCmdHelp + , addCmdHelpStr + , peekCmdDesc + , addCmdPart + , addCmdPartA + , addCmdPartMany + , addCmdPartManyA + , addCmdPartInp + , addCmdPartInpA + , addCmdPartManyInp + , addCmdPartManyInpA + , addCmd + , addCmdImpl + , reorderStart + , reorderStop + , cmdCheckParser + , cmdRunParser + , cmdRunParserA + ) +where + + + +#include "qprelude/bundle-gamma.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS +import Data.Unique (Unique) +import qualified System.Unsafe as Unsafe + +import qualified Control.Lens.TH as LensTH +import qualified Control.Lens as Lens +import Control.Lens ( (.=), (%=), (%~), (.~) ) + +import qualified Text.PrettyPrint as PP +import Text.PrettyPrint ( (<+>), ($$), ($+$) ) + +import Data.HList.ContainsType + +import Data.Dynamic + +import UI.Butcher.Monadic.Types + + + +-- general-purpose helpers +---------------------------- + +mModify :: MonadMultiState s m => (s -> s) -> m () +mModify f = mGet >>= mSet . f + +-- sadly, you need a degree in type inference to know when we can use +-- these operators and when it must be avoided due to type ambiguities +-- arising around s in the signatures below. That's the price of not having +-- the functional dependency in MonadMulti*T. + +(.=+) :: MonadMultiState s m + => Lens.ASetter s s a b -> b -> m () +l .=+ b = mModify $ l .~ b + +(%=+) :: MonadMultiState s m + => Lens.ASetter s s a b -> (a -> b) -> m () +l %=+ f = mModify (l %~ f) + +-- inflateStateProxy :: (Monad m, ContainsType s ss) +-- => p s -> StateS.StateT s m a -> MultiRWSS.MultiRWST r w ss m a +-- inflateStateProxy _ = MultiRWSS.inflateState + +-- more on-topic stuff +---------------------------- + +-- instance IsHelpBuilder (CmdBuilder out) where +-- help s = liftF $ CmdBuilderHelp s () +-- +-- instance IsHelpBuilder (ParamBuilder p) where +-- help s = liftF $ ParamBuilderHelp s () +-- +-- instance IsHelpBuilder FlagBuilder where +-- help s = liftF $ FlagBuilderHelp s () + +addCmdSynopsis :: String -> CmdParser f out () +addCmdSynopsis s = liftF $ CmdParserSynopsis s () + +addCmdHelp :: PP.Doc -> CmdParser f out () +addCmdHelp s = liftF $ CmdParserHelp s () + +addCmdHelpStr :: String -> CmdParser f out () +addCmdHelpStr s = liftF $ CmdParserHelp (PP.text s) () + +peekCmdDesc :: CmdParser f out (CommandDesc out) +peekCmdDesc = liftF $ CmdParserPeekDesc id + +addCmdPart + :: (Applicative f, Typeable p) + => PartDesc + -> (String -> Maybe (p, String)) + -> CmdParser f out p +addCmdPart p f = liftF $ CmdParserPart p f (\_ -> pure ()) id + +addCmdPartA + :: (Typeable p) + => PartDesc + -> (String -> Maybe (p, String)) + -> (p -> f ()) + -> CmdParser f out p +addCmdPartA p f a = liftF $ CmdParserPart p f a id + +addCmdPartMany + :: (Applicative f, Typeable p) + => PartDesc + -> (String -> Maybe (p, String)) + -> CmdParser f out [p] +addCmdPartMany p f = liftF $ CmdParserPartMany p f (\_ -> pure ()) id + +addCmdPartManyA + :: (Typeable p) + => PartDesc + -> (String -> Maybe (p, String)) + -> (p -> f ()) + -> CmdParser f out [p] +addCmdPartManyA p f a = liftF $ CmdParserPartMany p f a id + +addCmdPartInp + :: (Applicative f, Typeable p) + => PartDesc + -> (Input -> Maybe (p, Input)) + -> CmdParser f out p +addCmdPartInp p f = liftF $ CmdParserPartInp p f (\_ -> pure ()) id + +addCmdPartInpA + :: (Typeable p) + => PartDesc + -> (Input -> Maybe (p, Input)) + -> (p -> f ()) + -> CmdParser f out p +addCmdPartInpA p f a = liftF $ CmdParserPartInp p f a id + +addCmdPartManyInp + :: (Applicative f, Typeable p) + => PartDesc + -> (Input -> Maybe (p, Input)) + -> CmdParser f out [p] +addCmdPartManyInp p f = liftF $ CmdParserPartManyInp p f (\_ -> pure ()) id + +addCmdPartManyInpA + :: (Typeable p) + => PartDesc + -> (Input -> Maybe (p, Input)) + -> (p -> f ()) + -> CmdParser f out [p] +addCmdPartManyInpA p f a = liftF $ CmdParserPartManyInp p f a id + +addCmd + :: Applicative f + => String + -> CmdParser f out () + -> CmdParser f out () +addCmd str sub = liftF $ CmdParserChild str sub (pure ()) () + +addCmdImpl :: out -> CmdParser f out () +addCmdImpl o = liftF $ CmdParserImpl o () + +reorderStart :: CmdParser f out () +reorderStart = liftF $ CmdParserReorderStart () + +reorderStop :: CmdParser f out () +reorderStop = liftF $ CmdParserReorderStop () + +-- addPartHelp :: String -> CmdPartParser () +-- addPartHelp s = liftF $ CmdPartParserHelp s () +-- +-- addPartParserBasic :: (String -> Maybe (p, String)) -> Maybe p -> CmdPartParser p +-- addPartParserBasic f def = liftF $ CmdPartParserCore f def id +-- +-- addPartParserOptionalBasic :: CmdPartParser p -> CmdPartParser (Maybe p) +-- addPartParserOptionalBasic p = liftF $ CmdPartParserOptional p id + +data PartGatherData f + = forall p . Typeable p => PartGatherData + { _pgd_id :: Int + , _pgd_desc :: PartDesc + , _pgd_parseF :: Either (String -> Maybe (p, String)) + (Input -> Maybe (p, Input)) + , _pgd_act :: p -> f () + , _pgd_many :: Bool + } + +type PartParsedData = Map Int [Dynamic] + +data CmdDescStack = StackBottom [PartDesc] + | StackLayer [PartDesc] String CmdDescStack + +descStackAdd :: PartDesc -> CmdDescStack -> CmdDescStack +descStackAdd d = \case + StackBottom l -> StackBottom $ d:l + StackLayer l s u -> StackLayer (d:l) s u + + +cmdCheckParser :: forall f out + . Maybe String -- top-level command name + -> CmdParser f out () + -> Either String (CommandDesc ()) +cmdCheckParser mTopLevel cmdParser + = (>>= final) + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateAS (StackBottom []) + $ MultiRWSS.withMultiStateS emptyCommandDesc + $ processMain cmdParser + where + final :: (CommandDesc out, CmdDescStack) + -> Either String (CommandDesc ()) + final (desc, stack) + = case stack of + StackBottom descs -> Right + $ descFixParentsWithTopM (mTopLevel <&> \n -> (n, emptyCommandDesc)) + $ () <$ desc + { _cmd_parts = reverse descs + , _cmd_children = reverse $ _cmd_children desc + } + StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart" + processMain :: CmdParser f out () + -> MultiRWSS.MultiRWST '[] '[] '[CommandDesc out, CmdDescStack] (Either String) () + processMain = \case + Pure x -> return x + Free (CmdParserHelp h next) -> do + cmd :: CommandDesc out <- mGet + mSet $ cmd { _cmd_help = Just h } + processMain next + Free (CmdParserSynopsis s next) -> do + cmd :: CommandDesc out <- mGet + mSet $ cmd { _cmd_synopsis = Just $ PP.text s } + processMain next + Free (CmdParserPeekDesc nextF) -> do + processMain $ nextF monadMisuseError + Free (CmdParserPart desc _parseF _act nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd desc descStack + processMain $ nextF monadMisuseError + Free (CmdParserPartInp desc _parseF _act nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd desc descStack + processMain $ nextF monadMisuseError + Free (CmdParserPartMany desc _parseF _act nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd (PartMany desc) descStack + processMain $ nextF monadMisuseError + Free (CmdParserPartManyInp desc _parseF _act nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd (PartMany desc) descStack + processMain $ nextF monadMisuseError + Free (CmdParserChild cmdStr sub _act next) -> do + cmd :: CommandDesc out <- mGet + subCmd <- do + stackCur :: CmdDescStack <- mGet + mSet (emptyCommandDesc :: CommandDesc out) + mSet $ StackBottom [] + processMain sub + c <- mGet + stackBelow <- mGet + mSet cmd + mSet stackCur + subParts <- case stackBelow of + StackBottom descs -> return $ reverse descs + StackLayer _ _ _ -> lift $ Left "unclosed ReorderStart or GroupStart" + return c + { _cmd_children = reverse $ _cmd_children c + , _cmd_parts = subParts + } + mSet $ cmd + { _cmd_children = (cmdStr, subCmd) : _cmd_children cmd + } + processMain next + Free (CmdParserImpl out next) -> do + cmd_out .=+ Just out + processMain $ next + Free (CmdParserGrouped groupName next) -> do + stackCur <- mGet + mSet $ StackLayer [] groupName stackCur + processMain $ next + Free (CmdParserGroupEnd next) -> do + stackCur <- mGet + case stackCur of + StackBottom{} -> do + lift $ Left $ "butcher interface error: group end without group start" + StackLayer _descs "" _up -> do + lift $ Left $ "GroupEnd found, but expected ReorderStop first" + StackLayer descs groupName up -> do + mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up + processMain $ next + Free (CmdParserReorderStop next) -> do + stackCur <- mGet + case stackCur of + StackBottom{} -> lift $ Left $ "ReorderStop without reorderStart" + StackLayer descs "" up -> do + mSet $ descStackAdd (PartReorder (reverse descs)) up + StackLayer{} -> lift $ Left $ "Found ReorderStop, but need GroupEnd first" + processMain next + Free (CmdParserReorderStart next) -> do + stackCur <- mGet + mSet $ StackLayer [] "" stackCur + processMain next + + monadMisuseError :: a + monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed" + + +cmdRunParser + :: Maybe String + -> Input + -> CmdParser Identity out () + -> (CommandDesc (), Either ParsingError (CommandDesc out)) +cmdRunParser mTopLevel inputInitial cmdParser + = runIdentity + $ cmdRunParserA mTopLevel inputInitial cmdParser + + +cmdRunParserA :: forall f out + . Applicative f + => Maybe String + -> Input + -> CmdParser f out () + -> f ( CommandDesc () + , Either ParsingError (CommandDesc out) + ) +cmdRunParserA mTopLevel inputInitial cmdParser + = runIdentity + $ MultiRWSS.runMultiRWSTNil + $ (<&> captureFinal) + $ MultiRWSS.withMultiWriterWA + $ MultiRWSS.withMultiStateA cmdParser + $ MultiRWSS.withMultiStateSA (StackBottom []) + $ MultiRWSS.withMultiStateSA inputInitial + $ MultiRWSS.withMultiStateSA initialCommandDesc + $ processMain cmdParser + where + initialCommandDesc = emptyCommandDesc + { _cmd_mParent = mTopLevel <&> \n -> (n, emptyCommandDesc) } + captureFinal :: ([String], (CmdDescStack, (Input, (CommandDesc out, f())))) + -> f (CommandDesc (), Either ParsingError (CommandDesc out)) + captureFinal (errs, (descStack, (inputRest, (cmd, act)))) = + act $> (() <$ cmd', res) + where + errs' = errs ++ inputErrs ++ stackErrs + inputErrs = case inputRest of + InputString s | all Char.isSpace s -> [] + InputString{} -> ["could not parse input/unprocessed input"] + InputArgs [] -> [] + InputArgs{} -> ["could not parse input/unprocessed input"] + stackErrs = case descStack of + StackBottom{} -> [] + _ -> ["butcher interface error: unclosed group"] + cmd' = postProcessCmd descStack cmd + res = if null errs' + then Right cmd' + else Left $ ParsingError errs' inputRest + processMain :: CmdParser f out () + -> MultiRWSS.MultiRWS + '[] + '[[String]] + '[CommandDesc out, Input, CmdDescStack, CmdParser f out ()] + (f ()) + processMain = \case + Pure () -> return $ pure $ () + Free (CmdParserHelp h next) -> do + cmd :: CommandDesc out <- mGet + mSet $ cmd { _cmd_help = Just h } + processMain next + Free (CmdParserSynopsis s next) -> do + cmd :: CommandDesc out <- mGet + mSet $ cmd { _cmd_synopsis = Just $ PP.text s } + processMain next + Free (CmdParserPeekDesc nextF) -> do + parser <- mGet + -- partialDesc :: CommandDesc out <- mGet + -- partialStack :: CmdDescStack <- mGet + -- run the rest without affecting the actual stack + -- to retrieve the complete cmddesc. + cmdCur :: CommandDesc out <- mGet + let (cmd :: CommandDesc out, stack) + = runIdentity + $ MultiRWSS.runMultiRWSTNil + $ MultiRWSS.withMultiStateSA emptyCommandDesc + { _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc + $ MultiRWSS.withMultiStateS (StackBottom []) -- partialStack + $ iterM processCmdShallow $ parser + processMain $ nextF $ postProcessCmd stack cmd + Free (CmdParserPart desc parseF actF nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd desc descStack + input <- mGet + case input of + InputString str -> case parseF str of + Just (x, rest) -> do + mSet $ InputString rest + actRest <- processMain $ nextF x + return $ actF x *> actRest + Nothing -> do + mTell ["could not parse " ++ getPartSeqDescPositionName desc] + processMain $ nextF monadMisuseError + InputArgs (str:strr) -> case parseF str of + Just (x, "") -> do + mSet $ InputArgs strr + actRest <- processMain $ nextF x + return $ actF x *> actRest + _ -> do + mTell ["could not parse " ++ getPartSeqDescPositionName desc] + processMain $ nextF monadMisuseError + InputArgs [] -> do + mTell ["could not parse " ++ getPartSeqDescPositionName desc] + processMain $ nextF monadMisuseError + Free (CmdParserPartInp desc parseF actF nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd desc descStack + input <- mGet + case parseF input of + Just (x, rest) -> do + mSet $ rest + actRest <- processMain $ nextF x + return $ actF x *> actRest + Nothing -> do + mTell ["could not parse " ++ getPartSeqDescPositionName desc] + processMain $ nextF monadMisuseError + Free (CmdParserPartMany desc parseF actF nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd desc descStack + let proc = do + dropSpaces + input <- mGet + case input of + InputString str -> case parseF str of + Just (x, r) -> do + mSet $ InputString r + xr <- proc + return $ x:xr + Nothing -> return [] + InputArgs (str:strr) -> case parseF str of + Just (x, "") -> do + mSet $ InputArgs strr + xr <- proc + return $ x:xr + _ -> return [] + InputArgs [] -> return [] + r <- proc + let act = traverse actF r + (act *>) <$> processMain (nextF $ r) + Free (CmdParserPartManyInp desc parseF actF nextF) -> do + do + descStack <- mGet + mSet $ descStackAdd desc descStack + let proc = do + dropSpaces + input <- mGet + case parseF input of + Just (x, r) -> do + mSet $ r + xr <- proc + return $ x:xr + Nothing -> return [] + r <- proc + let act = traverse actF r + (act *>) <$> processMain (nextF $ r) + f@(Free (CmdParserChild cmdStr sub act next)) -> do + dropSpaces + input <- mGet + let + mRest = case input of + InputString str | cmdStr == str -> + Just $ InputString "" + InputString str | (cmdStr++" ") `isPrefixOf` str -> + Just $ InputString $ drop (length cmdStr + 1) str + InputArgs (str:strr) | cmdStr == str -> + Just $ InputArgs strr + _ -> Nothing + case mRest of + Nothing -> do + cmd :: CommandDesc out <- mGet + subCmd <- MultiRWSS.withMultiStateS (emptyCommandDesc :: CommandDesc out) + $ MultiRWSS.withMultiStateA (StackBottom []) + $ iterM processCmdShallow sub + mSet $ cmd { _cmd_children = (cmdStr, subCmd) : _cmd_children cmd } + processMain next + Just rest -> do + iterM processCmdShallow f + cmd <- do + c :: CommandDesc out <- mGet + prevStack :: CmdDescStack <- mGet + return $ postProcessCmd prevStack c + mSet $ rest + mSet $ (emptyCommandDesc :: CommandDesc out) + { _cmd_mParent = Just (cmdStr, cmd) + } + mSet $ sub + mSet $ StackBottom [] + subAct <- processMain sub + return $ act *> subAct + Free (CmdParserImpl out next) -> do + cmd_out .=+ Just out + processMain $ next + Free (CmdParserGrouped groupName next) -> do + stackCur <- mGet + mSet $ StackLayer [] groupName stackCur + processMain $ next + Free (CmdParserGroupEnd next) -> do + stackCur <- mGet + case stackCur of + StackBottom{} -> do + mTell $ ["butcher interface error: group end without group start"] + return $ pure () -- hard abort should be fine for this case. + StackLayer descs groupName up -> do + mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up + processMain $ next + Free (CmdParserReorderStop next) -> do + mTell $ ["butcher interface error: reorder stop without reorder start"] + processMain next + Free (CmdParserReorderStart next) -> do + reorderData <- MultiRWSS.withMultiStateA (1::Int) + $ MultiRWSS.withMultiWriterW + $ iterM reorderPartGather $ next + let + reorderMapInit :: Map Int (PartGatherData f) + reorderMapInit = Map.fromList $ reorderData <&> \d -> (_pgd_id d, d) + tryParsePartData :: Input -> PartGatherData f -> First (Int, Dynamic, Input, Bool, f ()) + tryParsePartData input (PartGatherData pid _ pfe act allowMany) = + First [ (pid, toDyn r, rest, allowMany, act r) + | (r, rest) <- case pfe of + Left pfStr -> case input of + InputString str -> case pfStr str of + Just (x, r) | r/=str -> Just (x, InputString r) + _ -> Nothing + InputArgs (str:strr) -> case pfStr str of + Just (x, "") -> Just (x, InputArgs strr) + _ -> Nothing + InputArgs [] -> Nothing + Right pfInp -> case pfInp input of + Just (x, r) | r/=input -> Just (x, r) + _ -> Nothing + ] + parseLoop = do + input <- mGet + m :: Map Int (PartGatherData f) <- mGet + case getFirst $ Data.Foldable.foldMap (tryParsePartData input) m of + -- i will be angry if foldMap ever decides to not fold + -- in order of keys. + Nothing -> return $ pure () + Just (pid, x, rest, more, act) -> do + mSet rest + mModify $ Map.insertWith (++) pid [x] + when (not more) $ do + mSet $ Map.delete pid m + actRest <- parseLoop + return $ act *> actRest + (finalMap, (fr, acts)) <- MultiRWSS.withMultiStateSA (Map.empty :: PartParsedData) + $ MultiRWSS.withMultiStateA reorderMapInit + $ do + acts <- parseLoop -- filling the map + stackCur <- mGet + mSet $ StackLayer [] "" stackCur + fr <- MultiRWSS.withMultiStateA (1::Int) $ processParsedParts next + return (fr, acts) + -- we check that all data placed in the map has been consumed while + -- running the parts for which we collected the parseresults. + -- there can only be any rest if the collection of parts changed + -- between the reorderPartGather traversal and the processParsedParts + -- consumption. + if Map.null finalMap + then do + actRest <- processMain fr + return $ acts *> actRest + else monadMisuseError + + reorderPartGather + :: ( MonadMultiState Int m + , MonadMultiWriter [PartGatherData f] m + , MonadMultiWriter [String] m + ) + => CmdParserF f out (m ()) + -> m () + reorderPartGather = \case + CmdParserPart desc parseF actF nextF -> do + pid <- mGet + mSet $ pid + 1 + mTell [PartGatherData pid desc (Left parseF) actF False] + nextF $ monadMisuseError + CmdParserPartInp desc parseF actF nextF -> do + pid <- mGet + mSet $ pid + 1 + mTell [PartGatherData pid desc (Right parseF) actF False] + nextF $ monadMisuseError + CmdParserPartMany desc parseF actF nextF -> do + pid <- mGet + mSet $ pid + 1 + mTell [PartGatherData pid desc (Left parseF) actF True] + nextF $ monadMisuseError + CmdParserPartManyInp desc parseF actF nextF -> do + pid <- mGet + mSet $ pid + 1 + mTell [PartGatherData pid desc (Right parseF) actF True] + nextF $ monadMisuseError + CmdParserReorderStop _next -> do + return () + CmdParserHelp{} -> restCase + CmdParserSynopsis{} -> restCase + CmdParserPeekDesc{} -> restCase + CmdParserChild{} -> restCase + CmdParserImpl{} -> restCase + CmdParserReorderStart{} -> restCase + CmdParserGrouped{} -> restCase + CmdParserGroupEnd{} -> restCase + where + restCase = do + mTell ["Did not find expected ReorderStop after the reordered parts"] + return () + + processParsedParts + :: forall m r w s m0 a + . ( MonadMultiState Int m + , MonadMultiState PartParsedData m + , MonadMultiState (Map Int (PartGatherData f)) m + , MonadMultiState Input m + , MonadMultiState (CommandDesc out) m + , MonadMultiWriter [[Char]] m + , m ~ MultiRWSS.MultiRWST r w s m0 + , ContainsType (CmdParser f out ()) s + , ContainsType CmdDescStack s + , Monad m0 + ) + => CmdParser f out a + -> m (CmdParser f out a) + processParsedParts = \case + Free (CmdParserPart desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF + Free (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF + Free (CmdParserPartMany desc _ _ nextF) -> partMany desc nextF + Free (CmdParserPartManyInp desc _ _ nextF) -> partMany desc nextF + Free (CmdParserReorderStop next) -> do + stackCur <- mGet + case stackCur of + StackBottom{} -> do + mTell ["unexpected stackBottom"] + StackLayer descs _ up -> do + mSet $ descStackAdd (PartReorder (reverse descs)) up + return next + Free (CmdParserGrouped groupName next) -> do + stackCur <- mGet + mSet $ StackLayer [] groupName stackCur + processParsedParts $ next + Free (CmdParserGroupEnd next) -> do + stackCur <- mGet + case stackCur of + StackBottom{} -> do + mTell $ ["butcher interface error: group end without group start"] + return $ next -- hard abort should be fine for this case. + StackLayer descs groupName up -> do + mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up + processParsedParts $ next + Pure x -> return $ return $ x + f -> do + mTell ["Did not find expected ReorderStop after the reordered parts"] + return f + where + part + :: forall p + . Typeable p + => PartDesc + -> (p -> CmdParser f out a) + -> m (CmdParser f out a) + part desc nextF = do + do + stackCur <- mGet + mSet $ descStackAdd desc stackCur + pid <- mGet + mSet $ pid + 1 + parsedMap :: PartParsedData <- mGet + mSet $ Map.delete pid parsedMap + partMap :: Map Int (PartGatherData f) <- mGet + input :: Input <- mGet + let errorResult = do + mTell ["could not parse expected input " + ++ getPartSeqDescPositionName desc + ++ " with remaining input: " + ++ show input + ] + failureCurrentShallowRerun + return $ return $ monadMisuseError -- so ugly. + -- should be correct nonetheless. + continueOrMisuse :: Maybe p -> m (CmdParser f out a) + continueOrMisuse = maybe monadMisuseError + (processParsedParts . nextF) + case Map.lookup pid parsedMap of + Nothing -> case Map.lookup pid partMap of + Nothing -> monadMisuseError -- it would still be in the map + -- if it never had been successfully + -- parsed, as indicicated by the + -- previous parsedMap Nothing lookup. + Just (PartGatherData _ _ pfe _ _) -> case pfe of + Left pf -> case pf "" of + Nothing -> errorResult + Just (dx, _) -> continueOrMisuse $ cast dx + Right pf -> case pf (InputArgs []) of + Nothing -> errorResult + Just (dx, _) -> continueOrMisuse $ cast dx + Just [dx] -> continueOrMisuse $ fromDynamic dx + Just _ -> monadMisuseError + partMany + :: Typeable p + => PartDesc + -> ([p] -> CmdParser f out a) + -> m (CmdParser f out a) + partMany desc nextF = do + do + stackCur <- mGet + mSet $ descStackAdd (PartMany desc) stackCur + pid <- mGet + mSet $ pid + 1 + m :: PartParsedData <- mGet + mSet $ Map.delete pid m + let partDyns = case Map.lookup pid m of + Nothing -> [] + Just r -> r + case mapM fromDynamic partDyns of + Nothing -> monadMisuseError + Just xs -> processParsedParts $ nextF xs + + -- this does no error reporting at all. + -- user needs to use check for that purpose instead. + processCmdShallow :: ( MonadMultiState (CommandDesc out) m + , MonadMultiState CmdDescStack m + ) + => CmdParserF f out (m ()) + -> m () + processCmdShallow = \case + CmdParserHelp h next -> do + cmd :: CommandDesc out <- mGet + mSet $ cmd { _cmd_help = Just h } + next + CmdParserSynopsis s next -> do + cmd :: CommandDesc out <- mGet + mSet $ cmd { _cmd_synopsis = Just $ PP.text s } + next + CmdParserPeekDesc nextF -> do + mGet >>= nextF + CmdParserPart desc _parseF _act nextF -> do + do + stackCur <- mGet + mSet $ descStackAdd desc stackCur + nextF monadMisuseError + CmdParserPartInp desc _parseF _act nextF -> do + do + stackCur <- mGet + mSet $ descStackAdd desc stackCur + nextF monadMisuseError + CmdParserPartMany desc _parseF _act nextF -> do + do + stackCur <- mGet + mSet $ descStackAdd (PartMany desc) stackCur + nextF monadMisuseError + CmdParserPartManyInp desc _parseF _act nextF -> do + do + stackCur <- mGet + mSet $ descStackAdd (PartMany desc) stackCur + nextF monadMisuseError + CmdParserChild cmdStr _sub _act next -> do + cmd_children %=+ ((cmdStr, emptyCommandDesc :: CommandDesc out):) + next + CmdParserImpl out next -> do + cmd_out .=+ Just out + next + CmdParserGrouped groupName next -> do + stackCur <- mGet + mSet $ StackLayer [] groupName stackCur + next + CmdParserGroupEnd next -> do + stackCur <- mGet + case stackCur of + StackBottom{} -> do + return () + StackLayer _descs "" _up -> do + return () + StackLayer descs groupName up -> do + mSet $ descStackAdd (PartRedirect groupName (PartSeq (reverse descs))) up + next + CmdParserReorderStop next -> do + stackCur <- mGet + case stackCur of + StackBottom{} -> return () + StackLayer descs "" up -> do + mSet $ descStackAdd (PartReorder (reverse descs)) up + StackLayer{} -> return () + next + CmdParserReorderStart next -> do + stackCur <- mGet + mSet $ StackLayer [] "" stackCur + next + + failureCurrentShallowRerun + :: ( m ~ MultiRWSS.MultiRWST r w s m0 + , MonadMultiState (CmdParser f out ()) m + , MonadMultiState (CommandDesc out) m + , ContainsType CmdDescStack s + , Monad m0 + ) + => m () + failureCurrentShallowRerun = do + parser <- mGet + cmd :: CommandDesc out + <- MultiRWSS.withMultiStateS emptyCommandDesc + $ iterM processCmdShallow parser + mSet cmd + + postProcessCmd :: CmdDescStack -> CommandDesc out -> CommandDesc out + postProcessCmd descStack cmd + = descFixParents + $ cmd { _cmd_parts = case descStack of + StackBottom l -> reverse l + StackLayer{} -> [] + , _cmd_children = reverse $ _cmd_children cmd + } + + monadMisuseError :: a + monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed" + + + getPartSeqDescPositionName :: PartDesc -> String + getPartSeqDescPositionName = \case + PartLiteral s -> s + PartVariable s -> s + PartOptional ds' -> f ds' + PartAlts alts -> f $ head alts -- this is not optimal, but probably + -- does not matter. + PartDefault _ d -> f d + PartRedirect s _ -> s + PartMany ds -> f ds + PartWithHelp _ d -> f d + PartSeq ds -> List.unwords $ f <$> ds + PartReorder ds -> List.unwords $ f <$> ds + + where + f = getPartSeqDescPositionName + + dropSpaces :: MonadMultiState Input m => m () + dropSpaces = do + inp <- mGet + case inp of + InputString s -> mSet $ InputString $ dropWhile Char.isSpace s + InputArgs{} -> return () + + +-- cmdActionPartial :: CommandDesc out -> Either String out +-- cmdActionPartial = maybe (Left err) Right . _cmd_out +-- where +-- err = "command is missing implementation!" +-- +-- cmdAction :: CmdParser out () -> String -> Either String out +-- cmdAction b s = case cmdRunParser Nothing s b of +-- (_, Right cmd) -> cmdActionPartial cmd +-- (_, Left (ParsingError (out:_) _)) -> Left $ out +-- _ -> error "whoops" +-- +-- cmdActionRun :: (CommandDesc () -> ParsingError -> out) +-- -> CmdParser out () +-- -> String +-- -> out +-- cmdActionRun f p s = case cmdRunParser Nothing s p of +-- (cmd, Right out) -> case _cmd_out out of +-- Just o -> o +-- Nothing -> f cmd (ParsingError ["command is missing implementation!"] "") +-- (cmd, Left err) -> f cmd err + +descFixParents :: CommandDesc a -> CommandDesc a +descFixParents = descFixParentsWithTopM Nothing + +-- descFixParentsWithTop :: String -> CommandDesc a -> CommandDesc a +-- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc)) + +descFixParentsWithTopM :: Maybe (String, CommandDesc a) -> CommandDesc a -> CommandDesc a +descFixParentsWithTopM mTop topDesc = + go $ case mTop of + Nothing -> topDesc + Just top -> topDesc { _cmd_mParent = Just top } + where + go :: CommandDesc a -> CommandDesc a + go desc = + let fixedDesc = desc { _cmd_children = _cmd_children desc <&> \(n, sd) -> + (n, go $ sd { _cmd_mParent = Just (n, fixedDesc)}) + } + in fixedDesc + + +_tooLongText :: Int -- max length + -> String -- alternative if actual length is bigger than max. + -> String -- text to print, if length is fine. + -> PP.Doc +_tooLongText i alt s = PP.text $ Bool.bool alt s $ null $ drop i s diff --git a/src/UI/Butcher/Monadic/Flag.hs b/src/UI/Butcher/Monadic/Flag.hs new file mode 100644 index 0000000..6271650 --- /dev/null +++ b/src/UI/Butcher/Monadic/Flag.hs @@ -0,0 +1,220 @@ +module UI.Butcher.Monadic.Flag + ( Flag(..) + , addSimpleBoolFlag + , addSimpleCountFlag + , addSimpleFlagA + , addFlagReadParam + , addFlagReadParamA + , addFlagStringParam + , addFlagStringParamA + , flagHelp + , flagHelpStr + , flagDefault + ) +where + + + +#include "qprelude/bundle-gamma.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS +import Data.Unique (Unique) +import qualified System.Unsafe as Unsafe + +import qualified Control.Lens.TH as LensTH +import qualified Control.Lens as Lens +import Control.Lens ( (.=), (%=), (%~), (.~) ) + +import qualified Text.PrettyPrint as PP + +import Data.HList.ContainsType + +import Data.Dynamic + +import UI.Butcher.Monadic.Types +import UI.Butcher.Monadic.Core + +import Data.List.Extra ( firstJust ) + + + +data Flag p = Flag + { _flag_help :: Maybe PP.Doc + , _flag_default :: Maybe p + } + +instance Monoid (Flag p) where + mempty = Flag Nothing Nothing + Flag a1 b1 `mappend` Flag a2 b2 = Flag (a1 <|> a2) (b1 <|> b2) + +flagHelp :: PP.Doc -> Flag p +flagHelp h = mempty { _flag_help = Just h } + +flagHelpStr :: String -> Flag p +flagHelpStr s = mempty { _flag_help = Just $ PP.text s } + +flagDefault :: p -> Flag p +flagDefault d = mempty { _flag_default = Just d } + +addSimpleBoolFlag + :: Applicative f + => String -> [String] -> Flag Void -> CmdParser f out Bool +addSimpleBoolFlag shorts longs flag = + addSimpleBoolFlagAll shorts longs flag (pure ()) + +addSimpleFlagA + :: String -> [String] -> Flag Void -> f () -> CmdParser f out () +addSimpleFlagA shorts longs flag act + = void $ addSimpleBoolFlagAll shorts longs flag act + +addSimpleBoolFlagAll + :: String -- short flag chars, i.e. "v" for -v + -> [String] -- list of long names, i.e. ["verbose"] + -> Flag Void + -> f () + -> CmdParser f out Bool +addSimpleBoolFlagAll shorts longs flag a = fmap (not . null) + $ addCmdPartManyA desc parseF (\() -> a) + where + allStrs = fmap (\c -> "-"++[c]) shorts + ++ fmap (\s -> "--"++s) longs + desc :: PartDesc + desc = (maybe id PartWithHelp $ _flag_help flag) + $ PartAlts $ PartLiteral <$> allStrs + parseF :: String -> Maybe ((), String) + parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ]) + allStrs) + <|> ( firstJust (\s -> [ ((), drop (length s + 1) str) + | (s ++ " ") `isPrefixOf` str ]) + allStrs) + +addSimpleCountFlag :: Applicative f + => String -- short flag chars, i.e. "v" for -v + -> [String] -- list of long names, i.e. ["verbose"] + -> Flag Void + -> CmdParser f out Int +addSimpleCountFlag shorts longs flag = fmap length + $ addCmdPartMany desc parseF + where + -- we _could_ allow this to parse repeated short flags, like "-vvv" + -- (meaning "-v -v -v") correctly. + allStrs = fmap (\c -> "-"++[c]) shorts + ++ fmap (\s -> "--"++s) longs + desc :: PartDesc + desc = (maybe id PartWithHelp $ _flag_help flag) + $ PartAlts $ PartLiteral <$> allStrs + parseF :: String -> Maybe ((), String) + parseF str = ( firstJust (\s -> [ ((), drop (length s) str) | s==str ]) + allStrs) + <|> ( firstJust (\s -> [ ((), drop (length s + 1) str) + | (s ++ " ") `isPrefixOf` str ]) + allStrs) + +addFlagReadParam + :: forall f p out + . (Applicative f, Typeable p, Text.Read.Read p, Show p) + => String + -> [String] + -> String -- param name + -> Flag p + -> CmdParser f out [p] +addFlagReadParam shorts longs name flag + = addFlagReadParamAll shorts longs name flag (\_ -> pure ()) + +addFlagReadParamA + :: forall f p out + . (Typeable p, Text.Read.Read p, Show p) + => String + -> [String] + -> String -- param name + -> Flag p + -> (p -> f ()) + -> CmdParser f out () +addFlagReadParamA shorts longs name flag act + = void $ addFlagReadParamAll shorts longs name flag act + +addFlagReadParamAll + :: forall f p out + . (Typeable p, Text.Read.Read p, Show p) + => String + -> [String] + -> String -- param name + -> Flag p + -> (p -> f ()) + -> CmdParser f out [p] +addFlagReadParamAll shorts longs name flag act = addCmdPartManyA desc parseF act + where + allStrs = fmap (\c -> "-"++[c]) shorts + ++ fmap (\s -> "--"++s) longs + desc = (maybe id PartWithHelp $ _flag_help flag) + $ PartSeq [desc1, desc2] + desc1 :: PartDesc + desc1 = PartAlts $ PartLiteral <$> allStrs + desc2 = (maybe id (PartDefault . show) $ _flag_default flag) + $ PartVariable name + parseF :: String -> Maybe (p, String) + parseF str = flip firstJust allStrs + $ \s -> [ t + | (s ++ " ") `isPrefixOf` str + , t <- case Text.Read.reads $ drop (length s + 1) str of + ((x, ' ':r):_) -> Just (x, dropWhile Char.isSpace r) + ((x, []):_) -> Just (x, []) + _ -> _flag_default flag <&> \x -> (x, s) + ] + +addFlagStringParam + :: forall f out + . (Applicative f) + => String + -> [String] + -> String -- param name + -> Flag Void + -> CmdParser f out [String] +addFlagStringParam shorts longs name flag + = addFlagStringParamAll shorts longs name flag (\_ -> pure ()) + +addFlagStringParamA + :: forall f out + . String + -> [String] + -> String -- param name + -> Flag Void + -> (String -> f ()) + -> CmdParser f out () +addFlagStringParamA shorts longs name flag act + = void $ addFlagStringParamAll shorts longs name flag act + +addFlagStringParamAll + :: forall f out + . String + -> [String] + -> String -- param name + -> Flag Void -- we forbid the default because it has bad interaction + -- with the eat-anything behaviour of the string parser. + -> (String -> f ()) + -> CmdParser f out [String] +addFlagStringParamAll shorts longs name flag act = addCmdPartManyInpA desc parseF act + where + allStrs = fmap (\c -> "-"++[c]) shorts + ++ fmap (\s -> "--"++s) longs + desc = (maybe id PartWithHelp $ _flag_help flag) + $ PartSeq [desc1, desc2] + desc1 :: PartDesc + desc1 = PartAlts $ PartLiteral <$> allStrs + desc2 = (maybe id (PartDefault . show) $ _flag_default flag) + $ PartVariable name + parseF :: Input -> Maybe (String, Input) + parseF (InputString str) + = flip firstJust allStrs + $ \s -> [ (x, InputString rest2) + | (s ++ " ") `isPrefixOf` str + , let rest1 = drop (length s + 1) str + , let (x, rest2) = break (not . Char.isSpace) rest1 + ] + parseF (InputArgs (s1:s2:sr)) + = flip firstJust allStrs + $ \s -> [ (s2, InputArgs sr) + | s == s1 + ] + parseF (InputArgs _) = Nothing diff --git a/src/UI/Butcher/Monadic/IO.hs b/src/UI/Butcher/Monadic/IO.hs new file mode 100644 index 0000000..5b40405 --- /dev/null +++ b/src/UI/Butcher/Monadic/IO.hs @@ -0,0 +1,73 @@ +module UI.Butcher.Monadic.IO + ( mainFromCmdParser + , addHelpCommand + , addButcherDebugCommand + ) +where + + + +#include "qprelude/bundle-gamma.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS +import Data.Unique (Unique) +import qualified System.Unsafe as Unsafe + +import qualified Control.Lens.TH as LensTH +import qualified Control.Lens as Lens +import Control.Lens ( (.=), (%=), (%~), (.~) ) + +import qualified Text.PrettyPrint as PP + +import Data.HList.ContainsType + +import Data.Dynamic + +import UI.Butcher.Monadic.Types +import UI.Butcher.Monadic.Core +import UI.Butcher.Monadic.Pretty + + + +mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO () +mainFromCmdParser cmd = do + progName <- System.Environment.getProgName + case cmdCheckParser (Just progName) cmd of + Left e -> do + putStrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!" + putStrLn $ "(" ++ e ++ ")" + putStrLn $ "aborting." + Right _ -> do + args <- System.Environment.getArgs + case cmdRunParser (Just progName) (InputArgs args) cmd of + (desc, Left (ParsingError mess remaining)) -> do + putStrLn $ progName ++ ": error parsing arguments: " ++ head mess + putStrLn $ case remaining of + InputString "" -> "at the end of input." + InputString str -> case show str of + s | length s < 42 -> "at: " ++ s ++ "." + s -> "at: " ++ take 40 s ++ "..\"." + InputArgs [] -> "at the end of input" + InputArgs xs -> case List.unwords $ show <$> xs of + s | length s < 42 -> "at: " ++ s ++ "." + s -> "at: " ++ take 40 s ++ "..\"." + putStrLn $ "usage:" + print $ ppUsage desc + (desc, Right out) -> case _cmd_out out of + Nothing -> do + putStrLn $ "usage:" + print $ ppUsage desc + Just a -> a + +addHelpCommand :: Applicative f => CmdParser f (IO ()) () +addHelpCommand = addCmd "help" $ do + desc <- peekCmdDesc + addCmdImpl $ do + print $ ppHelpShallow $ maybe undefined snd (_cmd_mParent desc) + +addButcherDebugCommand :: Applicative f => CmdParser f (IO ()) () +addButcherDebugCommand = addCmd "butcherdebug" $ do + desc <- peekCmdDesc + addCmdImpl $ do + print $ maybe undefined snd (_cmd_mParent desc) diff --git a/src/UI/Butcher/Monadic/Param.hs b/src/UI/Butcher/Monadic/Param.hs new file mode 100644 index 0000000..ff9fdd2 --- /dev/null +++ b/src/UI/Butcher/Monadic/Param.hs @@ -0,0 +1,88 @@ +module UI.Butcher.Monadic.Param + ( Param(..) + , paramHelp + , paramHelpStr + , paramDefault + , addReadParam + , addReadParamOpt + ) +where + + + +#include "qprelude/bundle-gamma.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS +import Data.Unique (Unique) +import qualified System.Unsafe as Unsafe + +import qualified Control.Lens.TH as LensTH +import qualified Control.Lens as Lens +import Control.Lens ( (.=), (%=), (%~), (.~) ) + +import qualified Text.PrettyPrint as PP + +import Data.HList.ContainsType + +import Data.Dynamic + +import UI.Butcher.Monadic.Types +import UI.Butcher.Monadic.Core + + + +data Param p = Param + { _param_default :: Maybe p + , _param_help :: Maybe PP.Doc + } + +instance Monoid (Param p) where + mempty = Param Nothing Nothing + Param a1 b1 `mappend` Param a2 b2 = Param (a1 `f` a2) (b1 `mappend` b2) + where + f Nothing x = x + f x _ = x + +paramHelpStr :: String -> Param p +paramHelpStr s = mempty { _param_help = Just $ PP.text s } + +paramHelp :: PP.Doc -> Param p +paramHelp h = mempty { _param_help = Just h } + +paramDefault :: p -> Param p +paramDefault d = mempty { _param_default = Just d } + +addReadParam :: forall f out a + . (Applicative f, Typeable a, Show a, Text.Read.Read a) + => String + -> Param a + -> CmdParser f out a +addReadParam name par = addCmdPart desc parseF + where + desc :: PartDesc + desc = (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) + +addReadParamOpt :: forall f out a + . (Applicative f, Typeable a, Text.Read.Read a) + => String + -> Param a + -> CmdParser f out (Maybe a) +addReadParamOpt name par = addCmdPart desc parseF + where + desc :: PartDesc + desc = PartOptional + $ (maybe id PartWithHelp $ _param_help par) + $ PartVariable name + parseF :: String -> Maybe (Maybe a, String) + parseF s = case Text.Read.reads s of + ((x, ' ':r):_) -> Just (Just x, dropWhile Char.isSpace r) + ((x, []):_) -> Just (Just x, []) + _ -> Just (Nothing, s) -- TODO: we could warn about a default.. diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs new file mode 100644 index 0000000..4b49d5a --- /dev/null +++ b/src/UI/Butcher/Monadic/Pretty.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiWayIf #-} + +module UI.Butcher.Monadic.Pretty + ( ppUsage + , ppUsageAt + , ppHelpShallow + , ppPartDescUsage + , ppPartDescHeader + ) +where + + + +#include "qprelude/bundle-gamma.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS +import Data.Unique (Unique) +import qualified System.Unsafe as Unsafe + +import qualified Control.Lens.TH as LensTH +import qualified Control.Lens as Lens +import Control.Lens ( (.=), (%=), (%~), (.~) ) + +import qualified Text.PrettyPrint as PP +import Text.PrettyPrint ( (<+>), ($$), ($+$) ) + +import Data.HList.ContainsType + +import Data.Dynamic + +import UI.Butcher.Monadic.Types +import UI.Butcher.Monadic.Core + + + +ppUsage :: CommandDesc a + -> PP.Doc +ppUsage (CommandDesc mParent _help _syn parts out children) = + pparents mParent <+> PP.fsep (partDocs ++ [subsDoc]) + where + pparents :: Maybe (String, CommandDesc out) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (n, cd)) = pparents (_cmd_mParent cd) <+> PP.text n + partDocs = parts <&> ppPartDescUsage + subsDoc = case out of + _ | null children -> PP.empty -- TODO: remove debug + Nothing -> PP.parens $ subDoc + Just{} -> PP.brackets $ subDoc + subDoc = PP.fcat $ PP.punctuate (PP.text " | ") $ children <&> \(n, _) -> + PP.text n + +ppUsageAt :: [String] -- (sub)command sequence + -> CommandDesc a + -> Maybe PP.Doc +ppUsageAt strings desc = + case strings of + [] -> Just $ ppUsage desc + (s:sr) -> find ((s==) . fst) (_cmd_children desc) >>= snd .> ppUsageAt sr + +ppHelpShallow :: CommandDesc a + -> PP.Doc +ppHelpShallow desc@(CommandDesc mParent syn help parts _out _children) = + nameSection + $+$ usageSection + $+$ descriptionSection + $+$ partsSection + $+$ PP.text "" + where + nameSection = case mParent of + Nothing -> PP.empty + Just{} -> + PP.text "NAME" + $+$ PP.text "" + $+$ PP.nest 2 (case syn of + Nothing -> pparents mParent + Just s -> pparents mParent <+> PP.text "-" <+> s) + $+$ PP.text "" + pparents :: Maybe (String, CommandDesc out) -> PP.Doc + pparents Nothing = PP.empty + pparents (Just (n, cd)) = pparents (_cmd_mParent cd) PP.<+> PP.text n + usageSection = + PP.text "USAGE" + $+$ PP.text "" + $+$ PP.nest 2 (ppUsage desc) + descriptionSection = case help of + Nothing -> PP.empty + Just h -> + PP.text "" + $+$ PP.text "DESCRIPTION" + $+$ PP.text "" + $+$ PP.nest 2 h + partsSection = if null partsTuples then PP.empty else + PP.text "" + $+$ PP.text "ARGUMENTS" + $+$ PP.text "" + $+$ PP.nest 2 (PP.vcat partsTuples) + partsTuples :: [PP.Doc] + partsTuples = parts >>= go + where + go = \case + PartLiteral{} -> [] + PartVariable{} -> [] + PartOptional p -> go p + PartAlts ps -> ps >>= go + PartSeq ps -> ps >>= go + PartDefault _ p -> go p + PartRedirect s p -> [PP.text s $$ PP.nest 20 (ppPartDescUsage p)] + ++ (PP.nest 2 <$> go p) + PartReorder ps -> ps >>= go + PartMany p -> go p + PartWithHelp doc p -> [ppPartDescHeader p $$ PP.nest 20 doc] + ++ go p + +ppPartDescUsage :: PartDesc -> PP.Doc +ppPartDescUsage = \case + PartLiteral s -> PP.text s + PartVariable s -> PP.text s + PartOptional p -> PP.brackets $ rec p + PartAlts ps -> PP.fcat $ PP.punctuate (PP.text ",") $ rec <$> ps + PartSeq ps -> PP.fsep $ rec <$> ps + PartDefault _ p -> PP.brackets $ rec p + PartRedirect s _ -> PP.text s + PartMany p -> rec p <> PP.text "+" + PartWithHelp _ p -> rec p + PartReorder ps -> + let flags = [d | PartMany d <- ps] + params = filter (\case PartMany{} -> False; _ -> True) ps + in PP.brackets (PP.fsep $ rec <$> flags) + <+> PP.fsep (rec <$> params) + where + rec = ppPartDescUsage + +ppPartDescHeader :: PartDesc -> PP.Doc +ppPartDescHeader = \case + PartLiteral s -> PP.text s + PartVariable s -> PP.text s + PartOptional ds' -> rec ds' + PartAlts alts -> PP.hcat $ List.intersperse (PP.text ",") $ rec <$> alts + PartDefault _ d -> rec d + PartRedirect s _ -> PP.text s + PartMany ds -> rec ds + PartWithHelp _ d -> rec d + PartSeq ds -> PP.hsep $ rec <$> ds + PartReorder ds -> PP.vcat $ rec <$> ds + where + rec = ppPartDescHeader diff --git a/src/UI/Butcher/Monadic/Types.hs b/src/UI/Butcher/Monadic/Types.hs new file mode 100644 index 0000000..9392de9 --- /dev/null +++ b/src/UI/Butcher/Monadic/Types.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MonadComprehensions #-} + +module UI.Butcher.Monadic.Types + ( CommandDesc(..) + , cmd_mParent + , cmd_help + , cmd_synopsis + , cmd_parts + , cmd_out + , cmd_children + , emptyCommandDesc + , CmdParserF(..) + , CmdParser + , PartDesc(..) + , Input (..) + , ParsingError (..) + ) +where + + + +#include "qprelude/bundle-gamma.inc" +import Control.Monad.Free +import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS +-- import Data.Unique (Unique) +import qualified System.Unsafe as Unsafe + +import qualified Control.Lens.TH as LensTH +import qualified Control.Lens as Lens + +import qualified Text.PrettyPrint as PP + +import Data.Dynamic + + + +data Input = InputString String | InputArgs [String] + deriving (Show, Eq) + +data ParsingError = ParsingError + { _pe_messages :: [String] + , _pe_remaining :: Input + } + deriving (Show, Eq) + +data CmdParserF f out a + = CmdParserHelp PP.Doc a + | CmdParserSynopsis String a + | CmdParserPeekDesc (CommandDesc out -> 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 -> f ()) (p -> a) + | forall p . Typeable p => CmdParserPartMany PartDesc (String -> Maybe (p, String)) (p -> f ()) ([p] -> a) + | forall p . Typeable p => CmdParserPartInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) (p -> a) + | forall p . Typeable p => CmdParserPartManyInp PartDesc (Input -> Maybe (p, Input)) (p -> f ()) ([p] -> a) + | CmdParserChild String (CmdParser f out ()) (f ()) a + | CmdParserImpl out a + | CmdParserReorderStart a + | CmdParserReorderStop a + | CmdParserGrouped String a + | CmdParserGroupEnd a + + +type CmdParser f out = Free (CmdParserF f out) + +-- type CmdParser a = CmdParserM a a + +-- data CmdPartParserF a +-- = CmdPartParserHelp String a +-- | forall p . CmdPartParserCore (String -> Maybe (p, String)) -- parser +-- (Maybe p) -- optional default value +-- (p -> a) +-- | forall p . CmdPartParserOptional (CmdPartParser p) +-- (Maybe p -> a) +-- -- the idea here was to allow adding some dynamic data to each "node" of +-- -- the output CommandDesc so the user can potentially add custom additional +-- -- information, and write a custom pretty-printer for e.g. help output +-- -- from that dynamically-enriched CommandDesc structure. +-- -- disabled for now, because i am not sure what exactly "adding to every +-- -- node" involves, because the mapping from Functor to Desc is nontrivial. +-- -- (and because i don't have a direct use-case at the moment..) +-- -- | CmdPartParserCustom Dynamic a +-- +-- type CmdPartParser = Free CmdPartParserF + +--------- + +data CommandDesc out = CommandDesc + { _cmd_mParent :: Maybe (String, CommandDesc out) + , _cmd_synopsis :: Maybe PP.Doc + , _cmd_help :: Maybe PP.Doc + , _cmd_parts :: [PartDesc] + , _cmd_out :: Maybe out + , _cmd_children :: [(String, CommandDesc out)] + } + +-- type PartSeqDesc = [PartDesc] + +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 + | PartRedirect String -- name for the redirection + PartDesc + | PartReorder [PartDesc] + | PartMany PartDesc + | PartWithHelp PP.Doc PartDesc + deriving Show + +{- +command documentation structure +1. terminals. e.g. "--dry-run" +2. non-terminals, e.g. "FILES" +3. sequences, e.g. " FLAGS NUMBER PATH" +-- 4. alternatives, e.g. "--date=(relative|local|iso|rfc|..)" +5. sub-commands: git (init|commit|push|clone|..) + compared to 4, the subcommands have their own flags and params; + they essentially "take over". +6. optional, e.g. "cabal run [COMPONENT]" +7. default, e.g. "-O(LEVEL=1)" +8. indirection, e.g. "cabal COMMAND\n\nCOMMAND: ..." +-} + +-- + +deriving instance Functor (CmdParserF f out) +deriving instance Functor CommandDesc + +-- + +emptyCommandDesc :: CommandDesc out +emptyCommandDesc = CommandDesc Nothing Nothing Nothing [] Nothing [] + +instance Show (CommandDesc out) where + show c = "Command help=" ++ show (_cmd_help c) + ++ " synopsis=" ++ show (_cmd_synopsis c) + ++ " mParent=" ++ show (fst <$> _cmd_mParent c) + ++ " out=" ++ maybe "(none)" (\_ -> "(smth)") (_cmd_out c) + ++ " parts.length=" ++ show (length $ _cmd_parts c) + ++ " parts=" ++ show (_cmd_parts c) + ++ " children=" ++ show (fst <$> _cmd_children c) + +-- + +Lens.makeLenses ''CommandDesc +Lens.makeLenses ''PartDesc + +-- + + + +-- instance Show FlagDesc where +-- show (FlagDesc _ short long helpM params) = show (short, long, helpM, params) -- TODO: improve + +-- class Typeable a => IsParam a where +-- paramParse :: String -> Maybe (a, String, String) -- value, representation, rest +-- paramStaticDef :: a + +-- emptyParamDesc :: ParamDesc a +-- emptyParamDesc = ParamDesc Nothing Nothing + +-- deriving instance Show a => Show (ParamDesc a) + + +-- instance Show a => Show (CmdParserF out a) where +-- show (CmdParserHelp s x) = "(CmdParserHelp " ++ show s ++ " " ++ show x ++ ")" +-- show (CmdParserFlag shorts longs _ _) = "(CmdParserFlag -" ++ shorts ++ " " ++ show longs ++ ")" +-- show (CmdParserParam s _ _) = "(CmdParserParam " ++ s ++ ")" +-- show (CmdParserChild s _ _) = "(CmdParserChild " ++ s ++ ")" +-- show (CmdParserRun _) = "CmdParserRun" + diff --git a/src/UI/CmdParse/Applicative.hs b/src/UI/CmdParse/Applicative.hs deleted file mode 100644 index 9654b98..0000000 --- a/src/UI/CmdParse/Applicative.hs +++ /dev/null @@ -1,628 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} - -module UI.CmdParse.Applicative - ( -- main - cmdActionPartial - , cmdAction - , cmd_run - , CmdBuilder - , addFlag - , addCmd - , addParam - , help - , impl - , def - , flagAsBool - , cmdGetPartial - , ppCommand - , ppCommandShort - , ppCommandShortHelp - -- re-exports: - , Command(..) - , Flag(..) - , Param(..) - , cmdCheckNonStatic - ) -where - - - -#include "qprelude/bundle-gamma.inc" -import Control.Applicative.Free -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS -import Data.Unique (Unique) -import qualified System.Unsafe as Unsafe - -import qualified Control.Lens.TH as LensTH -import qualified Control.Lens as Lens -import Control.Lens ( (.=), (%=), (%~), (.~) ) - -import qualified Text.PrettyPrint as PP - -import UI.CmdParse.Applicative.Types - -import Data.HList.ContainsType - - - --- general-purpose helpers ----------------------------- - -mModify :: MonadMultiState s m => (s -> s) -> m () -mModify f = mGet >>= mSet . f - --- sadly, you need a degree in type inference to know when we can use --- these operators and when it must be avoided due to type ambiguities --- arising around s in the signatures below. That's the price of not having --- the functional dependency in MonadMulti*T. - -(.=+) :: MonadMultiState s m - => Lens.ASetter s s a b -> b -> m () -l .=+ b = mModify $ l .~ b - -(%=+) :: MonadMultiState s m - => Lens.ASetter s s a b -> (a -> b) -> m () -l %=+ f = mModify (l %~ f) - --- inflateStateProxy :: (Monad m, ContainsType s ss) --- => p s -> StateS.StateT s m a -> MultiRWSS.MultiRWST r w ss m a --- inflateStateProxy _ = MultiRWSS.inflateState - --- actual CmdBuilder stuff ----------------------------- - -instance IsHelpBuilder (CmdBuilder out) where - help s = liftAp $ CmdBuilderHelp s () - -instance IsHelpBuilder (ParamBuilder p) where - help s = liftAp $ ParamBuilderHelp s () - -instance IsHelpBuilder FlagBuilder where - help s = liftAp $ FlagBuilderHelp s () - -addCmd :: String -> CmdBuilder out () -> CmdBuilder out () -addCmd s m = liftAp $ CmdBuilderChild s m () - -addParam :: (Show p, IsParam p) => String -> ParamBuilder p () -> CmdBuilder out p -addParam s m = liftAp $ CmdBuilderParam s m id - -{-# NOINLINE addFlag #-} -addFlag :: String -> [String] -> FlagBuilder a -> CmdBuilder out [a] -addFlag shorts longs m = Unsafe.performIO $ do - unique <- Data.Unique.newUnique - return $ liftAp $ CmdBuilderFlag unique shorts longs m id - -impl :: a -> CmdBuilder a () -impl x = liftAp $ CmdBuilderRun x () - -def :: p -> ParamBuilder p () -def d = liftAp $ ParamBuilderDef d () - --- | Does some limited "static" testing on a CmdBuilder. --- "static" as in: it does not read any actual input. --- Mostly checks that certain things are not defined multiple times, --- e.g. help annotations. -cmdCheckNonStatic :: CmdBuilder out () -> Maybe String -cmdCheckNonStatic cmdBuilder = join - $ Data.Either.Combinators.leftToMaybe - $ flip StateS.evalState emptyCommand - $ runEitherT - $ runAp iterFunc cmdBuilder - where - iterFunc :: CmdBuilderF out a - -> EitherT (Maybe String) - (StateS.State (Command out0)) a - iterFunc = \case - CmdBuilderHelp h r -> do - cmd <- State.Class.get - case _cmd_help cmd of - Nothing -> - cmd_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - pure r - CmdBuilderFlag funique _shorts _longs f r -> do - case checkFlag funique f of -- yes, this is a mapM_. - Nothing -> pure () -- but that does not help readability. - err -> left $ err - pure $ r [] - CmdBuilderParam _ p r -> do - case checkParam p of - Nothing -> pure () - err -> left $ err - pure $ r $ paramStaticDef - CmdBuilderChild _s c r -> do - case cmdCheckNonStatic c of - Nothing -> pure () - err -> left $ err - pure r - CmdBuilderRun _o _r -> - left Nothing - checkFlag :: Unique -> FlagBuilder b -> Maybe String - checkFlag unique flagBuilder = join - $ Data.Either.Combinators.leftToMaybe - $ flip StateS.evalState (Flag unique "" [] Nothing []) - $ runEitherT - $ runAp iterFuncFlag flagBuilder - where - iterFuncFlag :: FlagBuilderF b - -> EitherT (Maybe String) (StateS.State Flag) b - iterFuncFlag = \case - FlagBuilderHelp h r -> do - param <- State.Class.get - case _flag_help param of - Nothing -> - flag_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - pure r - FlagBuilderParam _s p r -> do - case checkParam p of - Nothing -> pure () - err -> left $ err - pure $ r $ paramStaticDef - checkParam :: Show p => ParamBuilder p () -> Maybe String - checkParam paramBuilder = join - $ Data.Either.Combinators.leftToMaybe - $ flip StateS.evalState (Param Nothing Nothing) - $ runEitherT - $ runAp iterFuncParam paramBuilder - where - iterFuncParam :: Show p - => ParamBuilderF p a - -> EitherT (Maybe String) (StateS.State (Param p)) a - iterFuncParam = \case - ParamBuilderHelp h r -> do - param <- State.Class.get - case _param_help param of - Nothing -> - param_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - pure $ r - ParamBuilderDef d r -> do - param <- State.Class.get - case _param_def param of - Nothing -> - param_def .= Just d - Just{} -> - left $ Just $ "default is already defined when trying to add default \"" ++ show d ++ "\"" - pure $ r - -cmdGetPartial :: forall out . String - -> CmdBuilder out () - -> ( [String] -- errors - , String -- remaining string - , Command out -- current result, as far as parsing was possible. - -- (!) take care not to run this command's action - -- if there are errors (!) - ) -cmdGetPartial inputStr cmdBuilder - = runIdentity - $ MultiRWSS.runMultiRWSTNil - $ (<&> captureFinal) - $ MultiRWSS.withMultiWriterWA - $ MultiRWSS.withMultiStateSA inputStr - $ MultiRWSS.withMultiStateS emptyCommand - $ processMain cmdBuilder - where - -- make sure that all input is processed; otherwise - -- add an error. - -- Does not use the writer because this method does some tuple - -- shuffling. - captureFinal :: ([String], (String, Command out)) - -> ([String], String, Command out) - captureFinal (errs, (s, cmd)) = (errs', s, cmd) - where - errs' = errs ++ if not $ all Char.isSpace s - then ["could not parse input at " ++ s] - else [] - - -- main "interpreter" over the free monad. not implemented as an iteration - -- because we switch to a different interpreter (and interpret the same - -- stuff more than once) when processing flags. - processMain :: CmdBuilder out () - -> MultiRWSS.MultiRWS '[] '[[String]] '[Command out, String] () - processMain = \case - Pure x -> return x - Ap (CmdBuilderHelp h r) next -> do - cmd :: Command out <- mGet - mSet $ cmd { _cmd_help = Just h } - processMain $ ($ r) <$> next - f@(Ap (CmdBuilderFlag{}) _) -> do - flagData <- MultiRWSS.withMultiWriterW $ -- WriterS.execWriterT $ - runAp iterFlagGather f - do - cmd :: Command out <- mGet - mSet $ cmd { _cmd_flags = _cmd_flags cmd ++ flagData } - parsedFlag <- MultiRWSS.withMultiStateS (Map.empty :: FlagParsedMap) - $ parseFlags flagData - (finalMap, fr) <- MultiRWSS.withMultiStateSA parsedFlag $ runParsedFlag f - if Map.null finalMap - then processMain fr - else mTell ["internal error in application or colint library: inconsistent flag definitions."] - Ap (CmdBuilderParam s p r) next -> do - let param = processParam p - cmd :: Command out <- mGet - mSet $ cmd { _cmd_params = _cmd_params cmd ++ [ParamA s param] } - str <- mGet - x <- case (paramParse str, _param_def param) of - (Nothing, Just x) -> do - -- did not parse, use configured default value - return $ x - (Nothing, Nothing) -> do - -- did not parse, no default value. add error, cont. with static default. - mTell ["could not parse param at " ++ str] - return paramStaticDef - (Just (v, _, x), _) -> do - -- parsed value; update the rest-string-to-parse, return value. - mSet $ x - return $ v - processMain $ ($ r x) <$> next - Ap (CmdBuilderChild s c r) next -> do - dropSpaces - str <- mGet - let mRest = if - | s == str -> Just "" - | (s++" ") `isPrefixOf` str -> Just $ drop (length s + 1) str - | otherwise -> Nothing - case mRest of - Nothing -> do - cmd :: Command out <- mGet - subCmd <- MultiRWSS.withMultiStateS emptyCommand - $ runAp processCmdShallow c - mSet $ cmd { _cmd_children = _cmd_children cmd ++ [(s, subCmd)] } - processMain $ ($ r) <$> next - Just rest -> do - old :: Command out <- mGet - mSet $ rest - mSet $ emptyCommand { - _cmd_mParent = Just (old, s) - } - processMain c - Ap (CmdBuilderRun o r) next -> do - cmd_run .=+ Just o - processMain $ ($ r) <$> next - - -- only captures some (i.e. roughly one layer) of the structure of - -- the (remaining) builder, not parsing any input. - processCmdShallow :: MonadMultiState (Command out) m - => CmdBuilderF out a - -> m a - processCmdShallow = \case - CmdBuilderHelp h r -> do - cmd :: Command out <- mGet - mSet $ cmd { - _cmd_help = Just h - } - pure $ r - CmdBuilderFlag _funique _shorts _longs _f r -> do - pure $ r [] - CmdBuilderParam s p r -> do - cmd :: Command out <- mGet - mSet $ cmd { - _cmd_params = _cmd_params cmd ++ [ParamA s $ processParam p] - } - pure $ r $ paramStaticDef - CmdBuilderChild s _c r -> do - cmd_children %=+ (++[(s, emptyCommand :: Command out)]) - pure $ r - CmdBuilderRun _o r -> - pure $ r - - -- extract a list of flag declarations. return [], i.e. pretend that no - -- flag matches while doing so. - iterFlagGather :: CmdBuilderF out a - -> MultiRWSS.MultiRWS r ([Flag]':wr) s a - iterFlagGather = \case - -- x | trace ("iterFlagGather: " ++ show (x $> ())) False -> error "laksjdlkja" - CmdBuilderFlag funique shorts longs f next -> do - let flag = processFlag funique shorts longs f - mTell $ [flag] - pure $ next [] - CmdBuilderHelp _ r -> pure r - CmdBuilderParam _ _ r -> pure $ r $ paramStaticDef - CmdBuilderChild _ _ r -> pure r - CmdBuilderRun _ r -> pure r - - -- the second iteration (technically not an iterM, but close..) over flags: - -- use the parsed flag map, so that the actual flag (values) are captured - -- in this run. - -- return the final CmdBuilder when a non-flag is encountered. - runParsedFlag :: CmdBuilder out () - -> MultiRWSS.MultiRWS '[] '[[String]] '[FlagParsedMap, Command out, String] (CmdBuilder out ()) - runParsedFlag = \case - Ap (CmdBuilderFlag funique _ _ f r) next -> do - m :: FlagParsedMap <- mGet - let flagRawStrs = case Map.lookup funique m of - Nothing -> [] - Just x -> x - mSet $ Map.delete funique m - runParsedFlag $ next <&> \g -> g $ r $ reparseFlag f <$> flagRawStrs - Pure x -> return $ pure x - f -> return f - - reparseFlag :: FlagBuilder b -> FlagParsedElement -> b - reparseFlag = undefined -- TODO FIXME WHO LEFT THIS HERE - - parseFlags :: ( MonadMultiWriter [String] m - , MonadMultiState String m - , MonadMultiState FlagParsedMap m - ) - => [Flag] - -> m () - parseFlags flags = do - dropSpaces - str <- mGet - case str of - ('-':'-':longRest) -> - case getAlt $ mconcat $ flags <&> \f - -> mconcat $ _flag_long f <&> \l - -> let len = length l - in Alt $ do - guard $ isPrefixOf l longRest - r <- case List.drop len longRest of - "" -> return "" - (' ':r) -> return r - _ -> mzero - return $ (l, r, f) of - Nothing -> mTell ["could not understand flag at --" ++ longRest] - Just (flagStr, flagRest, flag) -> - if length (_flag_params flag) /= 0 - then error "flag params not supported yet!" - else do - mSet flagRest - mModify $ Map.insertWith (++) - (_flag_unique flag) - [FlagParsedElement [flagStr]] - ('-':shortRest) -> - case shortRest of - (c:' ':r) -> - case getAlt $ mconcat $ flags <&> \f - -> mconcat $ _flag_short f <&> \s - -> Alt $ do - guard $ c==s - r' <- case r of - (' ':r') -> return r' - _ -> mzero - return (c, r', f) of - Nothing -> mTell ["could not understand flag at -" ++ shortRest] - Just (flagChr, flagRest, flag) -> - if length (_flag_params flag) /= 0 - then error "flag params not supported yet!" - else do - mSet flagRest - mModify $ Map.insertWith (++) - (_flag_unique flag) - [FlagParsedElement ["-"++[flagChr]]] - _ -> mTell ["could not parse flag at -" ++ shortRest] - _ -> pure () - dropSpaces :: MonadMultiState String m => m () - dropSpaces = mModify $ dropWhile Char.isSpace - processFlag :: Unique -> [Char] -> [String] -> FlagBuilder b -> Flag - processFlag unique shorts longs flagBuilder - = flip StateS.execState (Flag unique shorts longs Nothing []) - $ runAp iterFuncFlag flagBuilder - where - iterFuncFlag :: FlagBuilderF a - -> (StateS.State Flag) a - iterFuncFlag = \case - FlagBuilderHelp h r -> (flag_help .= Just h) $> r - FlagBuilderParam s p r -> do - let param = processParam p - flag_params %= (++ [ParamA s param]) - pure $ r $ paramStaticDef - processParam :: Show p => ParamBuilder p () -> Param p - processParam paramBuilder = flip StateS.execState emptyParam - $ runEitherT - $ runAp iterFuncParam paramBuilder - where - iterFuncParam :: Show p - => ParamBuilderF p a - -> EitherT (Maybe String) (StateS.State (Param p)) a - iterFuncParam = \case - ParamBuilderHelp h r -> do - param <- State.Class.get - case _param_help param of - Nothing -> - param_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - pure $ r - ParamBuilderDef d r -> do - param <- State.Class.get - case _param_def param of - Nothing -> - param_def .= Just d - Just{} -> - left $ Just $ "default is already defined when trying to add default \"" ++ show d ++ "\"" - pure $ r - -cmdActionPartial :: Command out -> Either String out -cmdActionPartial = maybe (Left err) Right . _cmd_run - where - err = "command is missing implementation!" - -cmdAction :: String -> CmdBuilder out () -> Either String out -cmdAction s b = case cmdGetPartial s b of - ([], _, cmd) -> cmdActionPartial cmd - ((out:_), _, _) -> Left $ out - -ppCommand :: Command out -> String -ppCommand cmd - = PP.render - $ PP.vcat - [ case _cmd_help cmd of - Nothing -> PP.empty - Just x -> PP.text x - , case _cmd_children cmd of - [] -> PP.empty - cs -> PP.text "commands:" PP.$$ PP.nest 2 (PP.vcat $ commandShort <$> cs) - , case _cmd_flags cmd of - [] -> PP.empty - fs -> PP.text "flags:" PP.$$ PP.nest 2 (PP.vcat $ flagShort <$> fs) - ] - where - commandShort :: (String, Command out) -> PP.Doc - commandShort (s, c) - = PP.text (s ++ ((_cmd_params c) >>= \(ParamA ps _) -> " " ++ ps)) - PP.<> case _cmd_help c of - Nothing -> PP.empty - Just h -> PP.text ":" PP.<+> PP.text h - flagShort :: Flag -> PP.Doc - flagShort f = PP.hsep (PP.text . ("-"++) . return <$> _flag_short f) - PP.<+> PP.hsep (PP.text . ("--"++) <$> _flag_long f) - PP.<+> case _flag_help f of - Nothing -> PP.empty - Just h -> PP.text h - -ppCommandShort :: Command out -> String -ppCommandShort cmd - = PP.render - $ printParent cmd - PP.<+> - case _cmd_flags cmd of - [] -> PP.empty - fs -> tooLongText 20 "[FLAGS]" $ List.unwords $ fs <&> \f -> - "[" - ++ (List.unwords $ (_flag_short f <&> \c -> ['-', c]) - ++ (_flag_long f <&> \l -> "--" ++ l) - ) - ++ "]" - PP.<+> - case _cmd_params cmd of - [] -> PP.empty - ps -> PP.text $ List.unwords $ ps <&> \(ParamA s _) -> Char.toUpper <$> s - PP.<+> - case _cmd_children cmd of - [] -> PP.empty - cs -> PP.text - $ if Maybe.isJust $ _cmd_run cmd - then "[<" ++ intercalate "|" (fst <$> cs) ++ ">]" - else "<" ++ intercalate "|" (fst <$> cs) ++ ">" - where - printParent :: Command out -> PP.Doc - printParent c = case _cmd_mParent c of - Nothing -> PP.empty - Just (p, x) -> printParent p PP.<+> PP.text x - -ppCommandShortHelp :: Command out -> String -ppCommandShortHelp cmd - = PP.render - $ printParent cmd - PP.<+> - case _cmd_flags cmd of - [] -> PP.empty - fs -> tooLongText 20 "[FLAGS]" $ List.unwords $ fs <&> \f -> - "[" - ++ (List.unwords $ (_flag_short f <&> \c -> ['-', c]) - ++ (_flag_long f <&> \l -> "--" ++ l) - ) - ++ "]" - PP.<+> - case _cmd_params cmd of - [] -> PP.empty - ps -> PP.text $ List.unwords $ ps <&> \(ParamA s _) -> Char.toUpper <$> s - PP.<+> - case _cmd_children cmd of - [] -> PP.empty - cs -> PP.text - $ if Maybe.isJust $ _cmd_run cmd - then "[<" ++ intercalate "|" (fst <$> cs) ++ ">]" - else "<" ++ intercalate "|" (fst <$> cs) ++ ">" - PP.<> - case _cmd_help cmd of - Nothing -> PP.empty - Just h -> PP.text ":" PP.<+> PP.text h - where - printParent :: Command out -> PP.Doc - printParent c = case _cmd_mParent c of - Nothing -> PP.empty - Just (p, x) -> printParent p PP.<+> PP.text x - -tooLongText :: Int -- max length - -> String -- alternative if actual length is bigger than max. - -> String -- text to print, if length is fine. - -> PP.Doc -tooLongText i alt s = PP.text $ Bool.bool alt s $ null $ drop i s - --- TODO -{- -cmds :: CmdBuilder (IO ()) () -cmds = do - _ <- addCmd "echo" $ do - _ <- help "print its parameter to output" - str <- addParam "string" $ do - _ <- help "the string to print" - pure () - -- def "foo" - _ <- impl $ do - putStrLn str - pure () - addCmd "hello" $ do - help "prints some greeting" - short <- flagAsBool $ addFlag "" ["short"] $ pure () - name <- addParam "name" $ do - _ <- help "your name, so you can be greeted properly" - _ <- def "user" - pure () - impl $ do - if short - then putStrLn $ "hi, " ++ name ++"!" - else putStrLn $ "hello, " ++ name ++", welcome to colint!" - pure () - pure () - -main :: IO () -main = do - case cmdCheckNonStatic cmds of - Just err -> do - putStrLn "error building commands!!" - putStrLn err - Nothing -> do - forever $ do - putStr "> " - hFlush stdout - input <- System.IO.getLine - let (errs, _, partial) = cmdGetPartial input cmds - print partial - putStrLn $ ppCommand $ partial - case (errs, cmdActionPartial partial) of - (err:_, _) -> print err - ([], eEff) -> case eEff of - Left err -> do - putStrLn $ "could not interpret input: " ++ err - Right eff -> do - eff --} - -flagAsBool :: CmdBuilder m [a] -> CmdBuilder m Bool -flagAsBool = fmap (not . null) - --- ---- - -instance IsParam String where - paramParse s = do - let s1 = dropWhile Char.isSpace s - let (param, rest) = List.span (not . Char.isSpace) s1 - guard $ not $ null param - pure $ (param, param, rest) -- we remove trailing whitespace, evil as we are. - paramStaticDef = "" - -instance IsParam () where - paramParse s = do - let s1 = dropWhile Char.isSpace s - rest <- List.stripPrefix "()" s1 - pure $ ((), "()", rest) - paramStaticDef = () diff --git a/src/UI/CmdParse/Applicative/Types.hs b/src/UI/CmdParse/Applicative/Types.hs deleted file mode 100644 index 51bc270..0000000 --- a/src/UI/CmdParse/Applicative/Types.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MonadComprehensions #-} - -module UI.CmdParse.Applicative.Types - ( Command(..) - , cmd_mParent - , cmd_help - , cmd_flags - , cmd_params - , cmd_children - , cmd_run - , flag_help - , flag_long - , flag_params - , flag_unique - , flag_short - , param_def - , param_help - , emptyCommand - , emptyParam - , FlagParsedMap - , FlagParsedElement(..) - , IsParam(..) - , IsHelpBuilder(..) - , CmdBuilderF(..) - , CmdBuilder - , ParamBuilderF(..) - , ParamBuilder - , FlagBuilderF(..) - , FlagBuilder - , Flag(..) - , Param(..) - , ParamA(..) - ) -where - - - -#include "qprelude/bundle-gamma.inc" -import Control.Applicative.Free -import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS -import Data.Unique (Unique) -import qualified System.Unsafe as Unsafe - -import qualified Control.Lens.TH as LensTH -import qualified Control.Lens as Lens - - - -data Command out = Command - { _cmd_mParent :: Maybe (Command out, String) -- parent command - -- , substring that leads to $this. - -- (kinda wonky, i know.) - , _cmd_help :: Maybe String - , _cmd_flags :: [Flag] - , _cmd_params :: [ParamA] - , _cmd_children :: [(String, Command out)] - , _cmd_run :: Maybe out - } - -emptyCommand :: Command out -emptyCommand = Command Nothing Nothing [] [] [] Nothing - -instance Show (Command out) where - show c = "Command help=" ++ show (_cmd_help c) - ++ " flags=" ++ show (_cmd_flags c) - ++ " params=" ++ show (_cmd_params c) - ++ " children=" ++ show (_cmd_children c) - ++ " run=" ++ case _cmd_run c of Nothing -> "Nothing"; Just{} -> "Just{..}" - --- class IsFlag a where --- flagParse :: String -> Maybe (a, String) --- staticDef :: a - -data Flag = Flag - { _flag_unique :: Unique - , _flag_short :: String - , _flag_long :: [String] - , _flag_help :: Maybe String - , _flag_params :: [ParamA] - } - -instance Show Flag where - show (Flag _ short long helpM params) = show (short, long, helpM, params) -- TODO: improve - -type FlagParsedMap = Map Unique [FlagParsedElement] - -data FlagParsedElement = FlagParsedElement [String] - deriving Show - -data ParamA = forall p . (IsParam p, Show p) => ParamA String (Param p) - -deriving instance Show ParamA - -class IsParam a where - paramParse :: String -> Maybe (a, String, String) -- value, representation, rest - paramStaticDef :: a - -data Param a = Param - { _param_help :: Maybe String - , _param_def :: Maybe a - } - -emptyParam :: Param a -emptyParam = Param Nothing Nothing - -deriving instance Show a => Show (Param a) - -data CmdBuilderF out a - = CmdBuilderHelp String a - | forall b . CmdBuilderFlag Unique String [String] (FlagBuilder b) ([b] -> a) - | forall p . (Show p, IsParam p) => CmdBuilderParam String (ParamBuilder p ()) (p -> a) - | CmdBuilderChild String (CmdBuilder out ()) a - | CmdBuilderRun out a - -deriving instance Functor (CmdBuilderF out) - -instance Show a => Show (CmdBuilderF out a) where - show (CmdBuilderHelp s x) = "(CmdBuilderHelp " ++ show s ++ " " ++ show x ++ ")" - show (CmdBuilderFlag _ shorts longs _ _) = "(CmdBuilderFlag -" ++ shorts ++ " " ++ show longs ++ ")" - show (CmdBuilderParam s _ _) = "(CmdBuilderParam " ++ s ++ ")" - show (CmdBuilderChild s _ _) = "(CmdBuilderChild " ++ s ++ ")" - show (CmdBuilderRun _ _) = "CmdBuilderRun" - -type CmdBuilder out = Ap (CmdBuilderF out) - -data FlagBuilderF a - = FlagBuilderHelp String a - | forall p . (Show p, IsParam p) => FlagBuilderParam String (ParamBuilder p ()) (p -> a) - -deriving instance Functor FlagBuilderF - -type FlagBuilder = Ap FlagBuilderF - -data ParamBuilderF p a - = ParamBuilderHelp String a - | ParamBuilderDef p a - -deriving instance Functor (ParamBuilderF p) - -type ParamBuilder p = Ap (ParamBuilderF p) - -class IsHelpBuilder m where - help :: String -> m () - -Lens.makeLenses ''Command -Lens.makeLenses ''Flag -Lens.makeLenses ''Param diff --git a/src/UI/CmdParse/Monadic.hs b/src/UI/CmdParse/Monadic.hs deleted file mode 100644 index 6809814..0000000 --- a/src/UI/CmdParse/Monadic.hs +++ /dev/null @@ -1,616 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE MultiWayIf #-} - -module UI.CmdParse.Monadic - ( main - , cmdActionPartial - , cmdAction - , cmd_run - , CmdBuilder - , addFlag - , addCmd - , addParam - , help - , impl - , def - , flagAsBool - , cmdGetPartial - , ppCommand - , ppCommandShort - , ppCommandShortHelp - -- re-exports: - , Command(..) - , Flag(..) - , Param(..) - ) -where - - - -#include "qprelude/bundle-gamma.inc" -import Control.Monad.Free -import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS -import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS -import Data.Unique (Unique) -import qualified System.Unsafe as Unsafe - -import qualified Control.Lens.TH as LensTH -import qualified Control.Lens as Lens -import Control.Lens ( (.=), (%=), (%~), (.~) ) - -import qualified Text.PrettyPrint as PP - -import UI.CmdParse.Monadic.Types - -import Data.HList.ContainsType - - - --- general-purpose helpers ----------------------------- - -mModify :: MonadMultiState s m => (s -> s) -> m () -mModify f = mGet >>= mSet . f - --- sadly, you need a degree in type inference to know when we can use --- these operators and when it must be avoided due to type ambiguities --- arising around s in the signatures below. That's the price of not having --- the functional dependency in MonadMulti*T. - -(.=+) :: MonadMultiState s m - => Lens.ASetter s s a b -> b -> m () -l .=+ b = mModify $ l .~ b - -(%=+) :: MonadMultiState s m - => Lens.ASetter s s a b -> (a -> b) -> m () -l %=+ f = mModify (l %~ f) - --- inflateStateProxy :: (Monad m, ContainsType s ss) --- => p s -> StateS.StateT s m a -> MultiRWSS.MultiRWST r w ss m a --- inflateStateProxy _ = MultiRWSS.inflateState - --- actual CmdBuilder stuff ----------------------------- - -instance IsHelpBuilder (CmdBuilder out) where - help s = liftF $ CmdBuilderHelp s () - -instance IsHelpBuilder (ParamBuilder p) where - help s = liftF $ ParamBuilderHelp s () - -instance IsHelpBuilder FlagBuilder where - help s = liftF $ FlagBuilderHelp s () - -addCmd :: String -> CmdBuilder out () -> CmdBuilder out () -addCmd s m = liftF $ CmdBuilderChild s m () - -addParam :: (Show p, IsParam p) => String -> ParamBuilder p () -> CmdBuilder out p -addParam s m = liftF $ CmdBuilderParam s m id - -{-# NOINLINE addFlag #-} -addFlag :: String -> [String] -> FlagBuilder a -> CmdBuilder out [a] -addFlag shorts longs m = Unsafe.performIO $ do - unique <- Data.Unique.newUnique - return $ liftF $ CmdBuilderFlag unique shorts longs m id - -impl :: a -> CmdBuilder a () -impl x = liftF $ CmdBuilderRun x - -def :: p -> ParamBuilder p () -def d = liftF $ ParamBuilderDef d () - --- | Does some limited "static" testing on a CmdBuilder. --- "static" as in: it does not read any actual input. --- Mostly checks that certain things are not defined multiple times, --- e.g. help annotations. -cmdCheckNonStatic :: CmdBuilder out () -> Maybe String -cmdCheckNonStatic cmdBuilder = join - $ Data.Either.Combinators.leftToMaybe - $ flip StateS.evalState emptyCommand - $ runEitherT - $ iterM iterFunc cmdBuilder - where - iterFunc :: CmdBuilderF out - (EitherT (Maybe String) - (StateS.State (Command out0)) a) - -> EitherT (Maybe String) - (StateS.State (Command out0)) a - iterFunc = \case - CmdBuilderHelp h next -> do - cmd <- State.Class.get - case _cmd_help cmd of - Nothing -> - cmd_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - next - CmdBuilderFlag funique _shorts _longs f next -> do - case checkFlag funique f of -- yes, this is a mapM_. - Nothing -> pure () -- but that does not help readability. - err -> left $ err - next [] - CmdBuilderParam _ p next -> do - case checkParam p of - Nothing -> pure () - err -> left $ err - next $ paramStaticDef - CmdBuilderChild _s c next -> do - case cmdCheckNonStatic c of - Nothing -> pure () - err -> left $ err - next - CmdBuilderRun _o -> - left Nothing - checkFlag :: Unique -> FlagBuilder b -> Maybe String - checkFlag unique flagBuilder = join - $ Data.Either.Combinators.leftToMaybe - $ flip StateS.evalState (Flag unique "" [] Nothing []) - $ runEitherT - $ iterM iterFuncFlag flagBuilder - where - iterFuncFlag :: FlagBuilderF (EitherT (Maybe String) (StateS.State Flag) b) - -> EitherT (Maybe String) (StateS.State Flag) b - iterFuncFlag = \case - FlagBuilderHelp h next -> do - param <- State.Class.get - case _flag_help param of - Nothing -> - flag_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - next - FlagBuilderParam _s p next -> do - case checkParam p of - Nothing -> pure () - err -> left $ err - next $ paramStaticDef - checkParam :: Show p => ParamBuilder p () -> Maybe String - checkParam paramBuilder = join - $ Data.Either.Combinators.leftToMaybe - $ flip StateS.evalState (Param Nothing Nothing) - $ runEitherT - $ iterM iterFuncParam paramBuilder - where - iterFuncParam :: Show p - => ParamBuilderF p (EitherT (Maybe String) (StateS.State (Param p)) ()) - -> EitherT (Maybe String) (StateS.State (Param p)) () - iterFuncParam = \case - ParamBuilderHelp h next -> do - param <- State.Class.get - case _param_help param of - Nothing -> - param_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - next - ParamBuilderDef d next -> do - param <- State.Class.get - case _param_def param of - Nothing -> - param_def .= Just d - Just{} -> - left $ Just $ "default is already defined when trying to add default \"" ++ show d ++ "\"" - next - -cmdGetPartial :: forall out . String - -> CmdBuilder out () - -> ( [String] -- errors - , String -- remaining string - , Command out -- current result, as far as parsing was possible. - -- (!) take care not to run this command's action - -- if there are errors (!) - ) -cmdGetPartial inputStr cmdBuilder - = runIdentity - $ MultiRWSS.runMultiRWSTNil - $ (<&> captureFinal) - $ MultiRWSS.withMultiWriterWA - $ MultiRWSS.withMultiStateSA inputStr - $ MultiRWSS.withMultiStateS emptyCommand - $ processMain cmdBuilder - where - -- make sure that all input is processed; otherwise - -- add an error. - -- Does not use the writer because this method does some tuple - -- shuffling. - captureFinal :: ([String], (String, Command out)) - -> ([String], String, Command out) - captureFinal (errs, (s, cmd)) = (errs', s, cmd) - where - errs' = errs ++ if not $ all Char.isSpace s - then ["could not parse input at " ++ s] - else [] - - -- main "interpreter" over the free monad. not implemented as an iteration - -- because we switch to a different interpreter (and interpret the same - -- stuff more than once) when processing flags. - processMain :: CmdBuilder out () - -> MultiRWSS.MultiRWS '[] '[[String]] '[Command out, String] () - processMain = \case - Pure x -> return x - Free (CmdBuilderHelp h next) -> do - cmd :: Command out <- mGet - mSet $ cmd { _cmd_help = Just h } - processMain next - f@(Free (CmdBuilderFlag{})) -> do - flagData <- MultiRWSS.withMultiWriterW $ -- WriterS.execWriterT $ - iterM iterFlagGather f - do - cmd :: Command out <- mGet - mSet $ cmd { _cmd_flags = _cmd_flags cmd ++ flagData } - parsedFlag <- MultiRWSS.withMultiStateS (Map.empty :: FlagParsedMap) - $ parseFlags flagData - (finalMap, fr) <- MultiRWSS.withMultiStateSA parsedFlag $ runParsedFlag f - if Map.null finalMap - then processMain fr - else mTell ["internal error in application or colint library: inconsistent flag definitions."] - Free (CmdBuilderParam s p next) -> do - let param = processParam p - cmd :: Command out <- mGet - mSet $ cmd { _cmd_params = _cmd_params cmd ++ [ParamA s param] } - str <- mGet - x <- case (paramParse str, _param_def param) of - (Nothing, Just x) -> do - -- did not parse, use configured default value - return $ x - (Nothing, Nothing) -> do - -- did not parse, no default value. add error, cont. with static default. - mTell ["could not parse param at " ++ str] - return paramStaticDef - (Just (v, _, r), _) -> do - -- parsed value; update the rest-string-to-parse, return value. - mSet $ r - return $ v - processMain $ next $ x - Free (CmdBuilderChild s c next) -> do - dropSpaces - str <- mGet - let mRest = if - | s == str -> Just "" - | (s++" ") `isPrefixOf` str -> Just $ drop (length s + 1) str - | otherwise -> Nothing - case mRest of - Nothing -> do - cmd :: Command out <- mGet - subCmd <- MultiRWSS.withMultiStateS emptyCommand - $ iterM processCmdShallow c - mSet $ cmd { _cmd_children = _cmd_children cmd ++ [(s, subCmd)] } - processMain next - Just rest -> do - old :: Command out <- mGet - mSet $ rest - mSet $ emptyCommand { - _cmd_mParent = Just (old, s) - } - processMain c - Free (CmdBuilderRun o) -> cmd_run .=+ Just o - - -- only captures some (i.e. roughly one layer) of the structure of - -- the (remaining) builder, not parsing any input. - processCmdShallow :: MonadMultiState (Command out) m - => CmdBuilderF out (m ()) - -> m () - processCmdShallow = \case - CmdBuilderHelp h next -> do - cmd :: Command out <- mGet - mSet $ cmd { - _cmd_help = Just h - } - next - CmdBuilderFlag _funique _shorts _longs _f next -> do - next [] - CmdBuilderParam s p next -> do - cmd :: Command out <- mGet - mSet $ cmd { - _cmd_params = _cmd_params cmd ++ [ParamA s $ processParam p] - } - next $ paramStaticDef - CmdBuilderChild s _c next -> do - cmd_children %=+ (++[(s, emptyCommand :: Command out)]) - next - CmdBuilderRun _o -> - return () - - -- extract a list of flag declarations. return [], i.e. pretend that no - -- flag matches while doing so. - iterFlagGather :: CmdBuilderF out (MultiRWSS.MultiRWS r ([Flag]':wr) s ()) - -> MultiRWSS.MultiRWS r ([Flag]':wr) s () - iterFlagGather = \case - -- x | trace ("iterFlagGather: " ++ show (x $> ())) False -> error "laksjdlkja" - CmdBuilderFlag funique shorts longs f next -> do - let flag = processFlag funique shorts longs f - mTell $ [flag] - next [] - _ -> pure () - - -- the second iteration (technically not an iterM, but close..) over flags: - -- use the parsed flag map, so that the actual flag (values) are captured - -- in this run. - -- return the final CmdBuilder when a non-flag is encountered. - runParsedFlag :: CmdBuilder out () - -> MultiRWSS.MultiRWS '[] '[[String]] '[FlagParsedMap, Command out, String] (CmdBuilder out ()) - runParsedFlag = \case - Free (CmdBuilderFlag funique _ _ f next) -> do - m :: FlagParsedMap <- mGet - let flagRawStrs = case Map.lookup funique m of - Nothing -> [] - Just r -> r - mSet $ Map.delete funique m - runParsedFlag $ next $ reparseFlag f <$> flagRawStrs - Pure x -> return $ return x - f -> return f - - reparseFlag :: FlagBuilder b -> FlagParsedElement -> b - reparseFlag = undefined -- TODO FIXME WHO LEFT THIS HERE - - parseFlags :: ( MonadMultiWriter [String] m - , MonadMultiState String m - , MonadMultiState FlagParsedMap m - ) - => [Flag] - -> m () - parseFlags flags = do - dropSpaces - str <- mGet - case str of - ('-':'-':longRest) -> - case getAlt $ mconcat $ flags <&> \f - -> mconcat $ _flag_long f <&> \l - -> let len = length l - in Alt $ do - guard $ isPrefixOf l longRest - r <- case List.drop len longRest of - "" -> return "" - (' ':r) -> return r - _ -> mzero - return $ (l, r, f) of - Nothing -> mTell ["could not understand flag at --" ++ longRest] - Just (flagStr, flagRest, flag) -> - if length (_flag_params flag) /= 0 - then error "flag params not supported yet!" - else do - mSet flagRest - mModify $ Map.insertWith (++) - (_flag_unique flag) - [FlagParsedElement [flagStr]] - ('-':shortRest) -> - case shortRest of - (c:' ':r) -> - case getAlt $ mconcat $ flags <&> \f - -> mconcat $ _flag_short f <&> \s - -> Alt $ do - guard $ c==s - r' <- case r of - (' ':r') -> return r' - _ -> mzero - return (c, r', f) of - Nothing -> mTell ["could not understand flag at -" ++ shortRest] - Just (flagChr, flagRest, flag) -> - if length (_flag_params flag) /= 0 - then error "flag params not supported yet!" - else do - mSet flagRest - mModify $ Map.insertWith (++) - (_flag_unique flag) - [FlagParsedElement ["-"++[flagChr]]] - _ -> mTell ["could not parse flag at -" ++ shortRest] - _ -> pure () - dropSpaces :: MonadMultiState String m => m () - dropSpaces = mModify $ dropWhile Char.isSpace - processFlag :: Unique -> [Char] -> [String] -> FlagBuilder b -> Flag - processFlag unique shorts longs flagBuilder - = flip StateS.execState (Flag unique shorts longs Nothing []) - $ iterM iterFuncFlag flagBuilder - where - iterFuncFlag :: FlagBuilderF ((StateS.State Flag) a) - -> (StateS.State Flag) a - iterFuncFlag = \case - FlagBuilderHelp h next -> flag_help .= Just h >> next - FlagBuilderParam s p next -> do - let param = processParam p - flag_params %= (++ [ParamA s param]) - next $ paramStaticDef - processParam :: Show p => ParamBuilder p () -> Param p - processParam paramBuilder = flip StateS.execState emptyParam - $ runEitherT - $ iterM iterFuncParam paramBuilder - where - iterFuncParam :: Show p - => ParamBuilderF p (EitherT (Maybe String) (StateS.State (Param p)) ()) - -> EitherT (Maybe String) (StateS.State (Param p)) () - iterFuncParam = \case - ParamBuilderHelp h next -> do - param <- State.Class.get - case _param_help param of - Nothing -> - param_help .= Just h - Just{} -> - left $ Just $ "help is already defined when trying to add help \"" ++ h ++ "\"" - next - ParamBuilderDef d next -> do - param <- State.Class.get - case _param_def param of - Nothing -> - param_def .= Just d - Just{} -> - left $ Just $ "default is already defined when trying to add default \"" ++ show d ++ "\"" - next - -cmdActionPartial :: Command out -> Either String out -cmdActionPartial = maybe (Left err) Right . _cmd_run - where - err = "command is missing implementation!" - -cmdAction :: String -> CmdBuilder out () -> Either String out -cmdAction s b = case cmdGetPartial s b of - ([], _, cmd) -> cmdActionPartial cmd - ((out:_), _, _) -> Left $ out - -ppCommand :: Command out -> String -ppCommand cmd - = PP.render - $ PP.vcat - [ case _cmd_help cmd of - Nothing -> PP.empty - Just x -> PP.text x - , case _cmd_children cmd of - [] -> PP.empty - cs -> PP.text "commands:" PP.$$ PP.nest 2 (PP.vcat $ commandShort <$> cs) - , case _cmd_flags cmd of - [] -> PP.empty - fs -> PP.text "flags:" PP.$$ PP.nest 2 (PP.vcat $ flagShort <$> fs) - ] - where - commandShort :: (String, Command out) -> PP.Doc - commandShort (s, c) - = PP.text (s ++ ((_cmd_params c) >>= \(ParamA ps _) -> " " ++ ps)) - PP.<> case _cmd_help c of - Nothing -> PP.empty - Just h -> PP.text ":" PP.<+> PP.text h - flagShort :: Flag -> PP.Doc - flagShort f = PP.hsep (PP.text . ("-"++) . return <$> _flag_short f) - PP.<+> PP.hsep (PP.text . ("--"++) <$> _flag_long f) - PP.<+> case _flag_help f of - Nothing -> PP.empty - Just h -> PP.text h - -ppCommandShort :: Command out -> String -ppCommandShort cmd - = PP.render - $ printParent cmd - PP.<+> - case _cmd_flags cmd of - [] -> PP.empty - fs -> tooLongText 20 "[FLAGS]" $ List.unwords $ fs <&> \f -> - "[" - ++ (List.unwords $ (_flag_short f <&> \c -> ['-', c]) - ++ (_flag_long f <&> \l -> "--" ++ l) - ) - ++ "]" - PP.<+> - case _cmd_params cmd of - [] -> PP.empty - ps -> PP.text $ List.unwords $ ps <&> \(ParamA s _) -> Char.toUpper <$> s - PP.<+> - case _cmd_children cmd of - [] -> PP.empty - cs -> PP.text - $ if Maybe.isJust $ _cmd_run cmd - then "[<" ++ intercalate "|" (fst <$> cs) ++ ">]" - else "<" ++ intercalate "|" (fst <$> cs) ++ ">" - where - printParent :: Command out -> PP.Doc - printParent c = case _cmd_mParent c of - Nothing -> PP.empty - Just (p, x) -> printParent p PP.<+> PP.text x - -ppCommandShortHelp :: Command out -> String -ppCommandShortHelp cmd - = PP.render - $ printParent cmd - PP.<+> - case _cmd_flags cmd of - [] -> PP.empty - fs -> tooLongText 20 "[FLAGS]" $ List.unwords $ fs <&> \f -> - "[" - ++ (List.unwords $ (_flag_short f <&> \c -> ['-', c]) - ++ (_flag_long f <&> \l -> "--" ++ l) - ) - ++ "]" - PP.<+> - case _cmd_params cmd of - [] -> PP.empty - ps -> PP.text $ List.unwords $ ps <&> \(ParamA s _) -> Char.toUpper <$> s - PP.<+> - case _cmd_children cmd of - [] -> PP.empty - cs -> PP.text - $ if Maybe.isJust $ _cmd_run cmd - then "[<" ++ intercalate "|" (fst <$> cs) ++ ">]" - else "<" ++ intercalate "|" (fst <$> cs) ++ ">" - PP.<> - case _cmd_help cmd of - Nothing -> PP.empty - Just h -> PP.text ":" PP.<+> PP.text h - where - printParent :: Command out -> PP.Doc - printParent c = case _cmd_mParent c of - Nothing -> PP.empty - Just (p, x) -> printParent p PP.<+> PP.text x - -tooLongText :: Int -- max length - -> String -- alternative if actual length is bigger than max. - -> String -- text to print, if length is fine. - -> PP.Doc -tooLongText i alt s = PP.text $ Bool.bool alt s $ null $ drop i s - -cmds :: CmdBuilder (IO ()) () -cmds = do - addCmd "echo" $ do - help "print its parameter to output" - str <- addParam "string" $ do - help "the string to print" - -- def "foo" - impl $ do - putStrLn str - addCmd "hello" $ do - help "prints some greeting" - short <- flagAsBool $ addFlag "" ["short"] $ return () - name <- addParam "name" $ do - help "your name, so you can be greeted properly" - def "user" - impl $ do - if short - then putStrLn $ "hi, " ++ name ++"!" - else putStrLn $ "hello, " ++ name ++", welcome to colint!" - -flagAsBool :: CmdBuilder m [a] -> CmdBuilder m Bool -flagAsBool = fmap (not . null) - -main :: IO () -main = do - case cmdCheckNonStatic cmds of - Just err -> do - putStrLn "error building commands!!" - putStrLn err - Nothing -> do - forever $ do - putStr "> " - hFlush stdout - input <- System.IO.getLine - let (errs, _, partial) = cmdGetPartial input cmds - print partial - putStrLn $ ppCommand $ partial - case (errs, cmdActionPartial partial) of - (err:_, _) -> print err - ([], eEff) -> case eEff of - Left err -> do - putStrLn $ "could not interpret input: " ++ err - Right eff -> do - eff - --- ---- - -instance IsParam String where - paramParse s = do - let s1 = dropWhile Char.isSpace s - let (param, rest) = List.span (not . Char.isSpace) s1 - guard $ not $ null param - pure $ (param, param, rest) -- we remove trailing whitespace, evil as we are. - paramStaticDef = "" - -instance IsParam () where - paramParse s = do - let s1 = dropWhile Char.isSpace s - rest <- List.stripPrefix "()" s1 - pure $ ((), "()", rest) - paramStaticDef = () diff --git a/src/UI/CmdParse/Monadic/Types.hs b/src/UI/CmdParse/Monadic/Types.hs deleted file mode 100644 index ee3b072..0000000 --- a/src/UI/CmdParse/Monadic/Types.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MonadComprehensions #-} - -module UI.CmdParse.Monadic.Types - ( Command(..) - , cmd_mParent - , cmd_help - , cmd_flags - , cmd_params - , cmd_children - , cmd_run - , flag_help - , flag_long - , flag_params - , flag_unique - , flag_short - , param_def - , param_help - , emptyCommand - , emptyParam - , FlagParsedMap - , FlagParsedElement(..) - , IsParam(..) - , IsHelpBuilder(..) - , CmdBuilderF(..) - , CmdBuilder - , ParamBuilderF(..) - , ParamBuilder - , FlagBuilderF(..) - , FlagBuilder - , Flag(..) - , Param(..) - , ParamA(..) - ) -where - - - -#include "qprelude/bundle-gamma.inc" -import Control.Monad.Free -import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS -import Data.Unique (Unique) -import qualified System.Unsafe as Unsafe - -import qualified Control.Lens.TH as LensTH -import qualified Control.Lens as Lens - - - -data Command out = Command - { _cmd_mParent :: Maybe (Command out, String) -- parent command - -- , substring that leads to $this. - -- (kinda wonky, i know.) - , _cmd_help :: Maybe String - , _cmd_flags :: [Flag] - , _cmd_params :: [ParamA] - , _cmd_children :: [(String, Command out)] - , _cmd_run :: Maybe out - } - -emptyCommand :: Command out -emptyCommand = Command Nothing Nothing [] [] [] Nothing - -instance Show (Command out) where - show c = "Command help=" ++ show (_cmd_help c) - ++ " flags=" ++ show (_cmd_flags c) - ++ " params=" ++ show (_cmd_params c) - ++ " children=" ++ show (_cmd_children c) - ++ " run=" ++ case _cmd_run c of Nothing -> "Nothing"; Just{} -> "Just{..}" - --- class IsFlag a where --- flagParse :: String -> Maybe (a, String) --- staticDef :: a - -data Flag = Flag - { _flag_unique :: Unique - , _flag_short :: String - , _flag_long :: [String] - , _flag_help :: Maybe String - , _flag_params :: [ParamA] - } - -instance Show Flag where - show (Flag _ short long helpM params) = show (short, long, helpM, params) -- TODO: improve - -type FlagParsedMap = Map Unique [FlagParsedElement] - -data FlagParsedElement = FlagParsedElement [String] - deriving Show - -data ParamA = forall p . (IsParam p, Show p) => ParamA String (Param p) - -deriving instance Show ParamA - -class IsParam a where - paramParse :: String -> Maybe (a, String, String) -- value, representation, rest - paramStaticDef :: a - -data Param a = Param - { _param_help :: Maybe String - , _param_def :: Maybe a - } - -emptyParam :: Param a -emptyParam = Param Nothing Nothing - -deriving instance Show a => Show (Param a) - -data CmdBuilderF out a - = CmdBuilderHelp String a - | forall b . CmdBuilderFlag Unique String [String] (FlagBuilder b) ([b] -> a) - | forall p . (Show p, IsParam p) => CmdBuilderParam String (ParamBuilder p ()) (p -> a) - | CmdBuilderChild String (CmdBuilder out ()) a - | CmdBuilderRun out -- TODO: why do we "abort" here? (i.e. no `a`) - -- this is not actually enforced when writing - -- CmdBuilders, is it? if it is not, this would result - -- in rather nasty silent-ignoring. - -deriving instance Functor (CmdBuilderF out) - -instance Show a => Show (CmdBuilderF out a) where - show (CmdBuilderHelp s x) = "(CmdBuilderHelp " ++ show s ++ " " ++ show x ++ ")" - show (CmdBuilderFlag _ shorts longs _ _) = "(CmdBuilderFlag -" ++ shorts ++ " " ++ show longs ++ ")" - show (CmdBuilderParam s _ _) = "(CmdBuilderParam " ++ s ++ ")" - show (CmdBuilderChild s _ _) = "(CmdBuilderChild " ++ s ++ ")" - show (CmdBuilderRun _) = "CmdBuilderRun" - -type CmdBuilder out = Free (CmdBuilderF out) - -data FlagBuilderF a - = FlagBuilderHelp String a - | forall p . (Show p, IsParam p) => FlagBuilderParam String (ParamBuilder p ()) (p -> a) - -deriving instance Functor FlagBuilderF - -type FlagBuilder = Free FlagBuilderF - -data ParamBuilderF p a - = ParamBuilderHelp String a - | ParamBuilderDef p a - -deriving instance Functor (ParamBuilderF p) - -type ParamBuilder p = Free (ParamBuilderF p) - -class IsHelpBuilder m where - help :: String -> m () - -Lens.makeLenses ''Command -Lens.makeLenses ''Flag -Lens.makeLenses ''Param