hexagoxel
/
butcher
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases Wiki Activity

Rename to butcher, Change everything else

pull/5/head
Lennart Spitzner 2016-07-30 16:25:28 +02:00
parent 4f93f79f5f
commit f033c9e0ab
15 changed files with 2087 additions and 1626 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
README.md Normal file
View File

@ -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.

134
butcher.cabal Normal file
View File

@ -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
}

69
cmdparse-applicative.cabal
View File

@ -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
}

125
src-tests/TestMain.hs Normal file
View File

@ -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

98
src/UI/Butcher/Monadic.hs Normal file
View File

@ -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

913
src/UI/Butcher/Monadic/Core.hs Normal file
View File

@ -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

220
src/UI/Butcher/Monadic/Flag.hs Normal file
View File

@ -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

73
src/UI/Butcher/Monadic/IO.hs Normal file
View File

@ -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)

88
src/UI/Butcher/Monadic/Param.hs Normal file
View File

@ -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..

157
src/UI/Butcher/Monadic/Pretty.hs Normal file
View File

@ -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

185
src/UI/Butcher/Monadic/Types.hs Normal file
View File

@ -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"

628
src/UI/CmdParse/Applicative.hs
View File

@ -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 = ()

155
src/UI/CmdParse/Applicative/Types.hs
View File

@ -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

616
src/UI/CmdParse/Monadic.hs
View File

@ -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 = ()

158
src/UI/CmdParse/Monadic/Types.hs
View File

@ -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