module UI.Butcher.Monadic.Interactive
( simpleCompletion
, interactiveHelpDoc
, partDescStrings
)
where
#include "prelude.inc"
import qualified Text.PrettyPrint as PP
import UI.Butcher.Monadic.Internal.Types
import UI.Butcher.Monadic.Internal.Core
import UI.Butcher.Monadic.Pretty
simpleCompletion
:: String
-> CommandDesc ()
-> String
-> String
simpleCompletion line cdesc pcRest =
List.drop (List.length lastWord) $ case choices of
[] -> ""
(c1:cr) ->
case
filter (\s -> List.all (s`isPrefixOf`) cr) $ reverse $ List.inits c1
of
[] -> ""
(x:_) -> x
where
nameDesc = case _cmd_mParent cdesc of
Nothing -> cdesc
Just (_, parent) | null pcRest -> parent
Just{} -> cdesc
lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ line
choices :: [String]
choices = join
[ [ r
| (Just r, _) <- Data.Foldable.toList (_cmd_children nameDesc)
, lastWord `isPrefixOf` r
]
, [ s
| s <- partDescStrings =<< _cmd_parts nameDesc
, lastWord `isPrefixOf` s
]
]
interactiveHelpDoc
:: String
-> CommandDesc ()
-> String
-> Int
-> PP.Doc
interactiveHelpDoc cmdline desc pcRest maxLines = if
| null cmdline -> helpStrShort
| List.last cmdline == ' ' -> helpStrShort
| otherwise -> helpStr
where
helpStr = if List.length optionLines > maxLines
then
PP.fcat $ List.intersperse (PP.text "|") $ PP.text . fst <$> optionLines
else PP.vcat $ optionLines <&> \case
(s, "") -> PP.text s
(s, h ) -> PP.text s PP.<> PP.text h
where
nameDesc = case _cmd_mParent desc of
Nothing -> desc
Just (_, parent) | null pcRest -> parent
Just{} -> desc
lastWord = reverse $ takeWhile (not . Char.isSpace) $ reverse $ cmdline
optionLines :: [(String, String)]
optionLines =
join
[ [ (s, e)
| (Just s, c) <- Data.Foldable.toList (_cmd_children nameDesc)
, lastWord `isPrefixOf` s
, let e = join $ join
[ [ " ARGS" | not $ null $ _cmd_parts c ]
, [ " CMDS" | not $ null $ _cmd_children c ]
, [ ": " ++ show h | Just h <- [_cmd_help c] ]
]
]
, [ (s, "")
| s <- partDescStrings =<< _cmd_parts nameDesc
, lastWord `isPrefixOf` s
]
]
helpStrShort = ppUsageWithHelp desc
partDescStrings :: PartDesc -> [String]
partDescStrings = \case
PartLiteral s -> [s]
PartVariable _ -> []
PartOptional x -> partDescStrings x
PartAlts alts -> alts >>= partDescStrings
PartSeq [] -> []
PartSeq (x:_) -> partDescStrings x
PartDefault _ x -> partDescStrings x
PartSuggestion ss x -> [ s | s <- ss ] ++ partDescStrings x
PartRedirect _ x -> partDescStrings x
PartReorder xs -> xs >>= partDescStrings
PartMany x -> partDescStrings x
PartWithHelp _h x -> partDescStrings x