Add function parsingErrorString

src/UI/Butcher/Monadic.hs

@@ -83,7 +83,7 @@ runCmdParserWithHelpDesc mProgName input cmdF =
 -- any error case.
 runCmdParserSimple :: String -> CmdParser Identity out () -> Either String out
 runCmdParserSimple s p = case snd $ runCmdParser Nothing (InputString s) p of
-  Left e -> Left $ show e
+  Left e -> Left $ parsingErrorString e
   Right desc ->
     maybe (Left "command has no implementation") Right $ _cmd_out desc
 

src/UI/Butcher/Monadic/IO.hs

@@ -38,31 +38,38 @@ mainFromCmdParser :: CmdParser Identity (IO ()) () -> IO ()
 mainFromCmdParser cmd = do
   progName <- System.Environment.getProgName
   case checkCmdParser (Just progName) cmd of
-    Left e -> do
-      putStrErrLn $ progName ++ ": internal error: failed sanity check for butcher main command parser!"
+    Left  e -> do
+      putStrErrLn
+        $ progName
+        ++ ": internal error: failed sanity check for butcher main command parser!"
       putStrErrLn $ "(" ++ e ++ ")"
       putStrErrLn $ "aborting."
     Right _ -> do
       args <- System.Environment.getArgs
       case runCmdParser (Just progName) (InputArgs args) cmd of
         (desc, Left (ParsingError mess remaining)) -> do
-          putStrErrLn $ progName ++ ": error parsing arguments: " ++ head mess
+          putStrErrLn
+            $  progName
+            ++ ": error parsing arguments: "
+            ++ case mess of
+                 []    -> ""
+                 (m:_) -> m
           putStrErrLn $ case remaining of
-            InputString "" -> "at the end of input."
+            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                 -> "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 ++ "..\"."
+              s                 -> "at: " ++ take 40 s ++ "..\"."
           putStrErrLn $ "usage:"
           printErr $ ppUsage desc
-        (desc, Right out) -> case _cmd_out out of
+        (desc, Right out                         ) -> case _cmd_out out of
           Nothing -> do
             putStrErrLn $ "usage:"
             printErr $ ppUsage desc
-          Just a -> a
+          Just a  -> a
 
 -- | Same as mainFromCmdParser, but with one additional twist: You get access
 -- to a knot-tied complete CommandDesc for this full command. Useful in

src/UI/Butcher/Monadic/Pretty.hs

@@ -33,6 +33,7 @@ module UI.Butcher.Monadic.Pretty
   , ppUsageWithHelp
   , ppPartDescUsage
   , ppPartDescHeader
+  , parsingErrorString
   )
 where
 
@@ -233,3 +234,21 @@ ppPartDescHeader = \case
  where
   rec = ppPartDescHeader
 
+-- | Simple conversion from 'ParsingError' to 'String'.
+parsingErrorString :: ParsingError -> String
+parsingErrorString (ParsingError mess remaining) =
+  "error parsing arguments: " ++ messStr ++ remainingStr
+ where
+  messStr      = case mess of
+    []    -> ""
+    (m:_) -> m ++ " "
+  remainingStr = 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 ++ "..\"."
+