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

Add the descendDescTo function, minor formatting

pull/6/head
Lennart Spitzner 2020-04-10 23:40:21 +02:00
parent 34d94c2d2e
commit bb646321fe
1 changed files with 35 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
src/UI/Butcher/Monadic/Pretty.hs
View File

@ -36,6 +36,7 @@ module UI.Butcher.Monadic.Pretty
, ppPartDescUsage , ppPartDescUsage
, ppPartDescHeader , ppPartDescHeader
, parsingErrorString , parsingErrorString
, descendDescTo
) )
where where
@ -43,11 +44,16 @@ where
#include "prelude.inc" #include "prelude.inc"
import Control.Monad.Free import Control.Monad.Free
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict
import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS as MultiRWSS
import qualified Control.Monad.Trans.MultiState.Strict
as MultiStateS
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import Text.PrettyPrint ( (<+>), ($$), ($+$) ) import Text.PrettyPrint ( (<+>)
, ($$)
, ($+$)
)
import Data.HList.ContainsType import Data.HList.ContainsType
@ -77,9 +83,10 @@ ppUsage (CommandDesc mParent _syn _help parts out children _hidden) =
Just{} -> PP.brackets $ subDoc Just{} -> PP.brackets $ subDoc
subDoc = subDoc =
PP.fcat PP.fcat
$ PP.punctuate (PP.text " | ") $ PP.punctuate (PP.text " | ")
$ Data.Foldable.toList $ Data.Foldable.toList
$ (PP.text . fst) <$> visibleChildren $ (PP.text . fst)
<$> visibleChildren
-- | ppUsageShortSub exampleDesc yields: -- | ppUsageShortSub exampleDesc yields:
-- --
@ -138,13 +145,19 @@ ppUsageWithHelp (CommandDesc mParent _syn help parts out children _hidden) =
-- fromJust $ ppUsageAt ["version"] exampleDesc yields: -- fromJust $ ppUsageAt ["version"] exampleDesc yields:
-- --
-- > example version [--porcelain] -- > example version [--porcelain]
ppUsageAt :: [String] -- (sub)command sequence ppUsageAt
-> CommandDesc a :: [String] -- (sub)command sequence
-> Maybe PP.Doc -> CommandDesc a
ppUsageAt strings desc = -> Maybe PP.Doc
case strings of ppUsageAt strings desc = ppUsage <$> descendDescTo strings desc
[] -> Just $ ppUsage desc
(s:sr) -> find ((Just s==) . fst) (_cmd_children desc) >>= ppUsageAt sr . snd -- | Access a child command's CommandDesc.
descendDescTo :: [String] -> CommandDesc a -> Maybe (CommandDesc a)
descendDescTo strings desc = case strings of
[] -> Just desc
(s : sr) -> do -- Maybe
(_, childDesc) <- find ((Just s ==) . fst) (_cmd_children desc)
descendDescTo sr childDesc
-- | ppHelpShallow exampleDesc yields: -- | ppHelpShallow exampleDesc yields:
-- --
@ -180,7 +193,7 @@ ppHelpShallow desc =
$+$ PP.text "" $+$ PP.text ""
$+$ PP.nest $+$ PP.nest
2 2
( case syn of (case syn of
Nothing -> pparents mParent Nothing -> pparents mParent
Just s -> pparents mParent <+> PP.text "-" <+> s Just s -> pparents mParent <+> PP.text "-" <+> s
) )
@ -258,7 +271,7 @@ ppHelpDepthOne desc =
$+$ PP.text "" $+$ PP.text ""
$+$ PP.nest $+$ PP.nest
2 2
( case syn of (case syn of
Nothing -> pparents mParent Nothing -> pparents mParent
Just s -> pparents mParent <+> PP.text "-" <+> s Just s -> pparents mParent <+> PP.text "-" <+> s
) )
@ -330,7 +343,7 @@ ppPartDescUsage = \case
PartReorder ps -> PartReorder ps ->
let flags = [ d | PartMany d <- ps ] let flags = [ d | PartMany d <- ps ]
params = filter params = filter
( \case (\case
PartMany{} -> False PartMany{} -> False
_ -> True _ -> True
) )
@ -364,16 +377,16 @@ parsingErrorString :: ParsingError -> String
parsingErrorString (ParsingError mess remaining) = parsingErrorString (ParsingError mess remaining) =
"error parsing arguments: " ++ messStr ++ remainingStr "error parsing arguments: " ++ messStr ++ remainingStr
where where
messStr = case mess of messStr = case mess of
[] -> "" [] -> ""
(m:_) -> m ++ " " (m : _) -> m ++ " "
remainingStr = case remaining of remainingStr = case remaining of
InputString "" -> "at the end of input." InputString "" -> "at the end of input."
InputString str -> case show str of InputString str -> case show str of
s | length s < 42 -> "at: " ++ s ++ "." s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"." s -> "at: " ++ take 40 s ++ "..\"."
InputArgs [] -> "at the end of input" InputArgs [] -> "at the end of input"
InputArgs xs -> case List.unwords $ show <$> xs of InputArgs xs -> case List.unwords $ show <$> xs of
s | length s < 42 -> "at: " ++ s ++ "." s | length s < 42 -> "at: " ++ s ++ "."
s -> "at: " ++ take 40 s ++ "..\"." s -> "at: " ++ take 40 s ++ "..\"."