initial commit

.gitignore

@@ -0,0 +1,13 @@
+*.glade~
+*.prof
+*.aux
+*.eventlog
+*.hp
+*.ps
+/*.pdf
+dist
+.cabal-sandbox/
+.stack-work/
+cabal.sandbox.config
+**/*.gui~
+\#*.gui\#

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for cmdparse-applicative
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2016, Lennart Spitzner
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Lennart Spitzner nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

cmdparse-applicative.cabal

@@ -0,0 +1,69 @@
+-- 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
+  }

src/UI/CmdParse/Applicative.hs

@@ -0,0 +1,628 @@
+{-# 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 = ()

src/UI/CmdParse/Applicative/Types.hs

@@ -0,0 +1,155 @@
+{-# 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

src/UI/CmdParse/Monadic.hs

@@ -0,0 +1,616 @@
+{-# 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 = ()

src/UI/CmdParse/Monadic/Types.hs

@@ -0,0 +1,158 @@
+{-# 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