Rename to butcher, Change everything else
Lennart Spitzner
parent
4f93f79f5f
commit
f033c9e0ab
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
}
|
||||
|
||||
|
|
@ -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
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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..
|
||||
|
|
@ -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
|
||||
|
|
@ -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. "<program> 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"
|
||||
|
||||
|
|
@ -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 = ()
|
||||
|
|
@ -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
|
||||
|
|
@ -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 = ()
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue