From 719d447701a27b70c83661b615944880ae9b49c6 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <lsp@informatik.uni-kiel.de>
Date: Tue, 16 May 2017 22:03:25 +0200
Subject: [PATCH] Add function parsingErrorString

---
 src/UI/Butcher/Monadic.hs        |  2 +-
 src/UI/Butcher/Monadic/IO.hs     | 27 +++++++++++++++++----------
 src/UI/Butcher/Monadic/Pretty.hs | 19 +++++++++++++++++++
 3 files changed, 37 insertions(+), 11 deletions(-)

diff --git a/src/UI/Butcher/Monadic.hs b/src/UI/Butcher/Monadic.hs
index 1ddad25..3e9dd88 100644
--- a/src/UI/Butcher/Monadic.hs
+++ b/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
 
diff --git a/src/UI/Butcher/Monadic/IO.hs b/src/UI/Butcher/Monadic/IO.hs
index c23fd34..a35c8d5 100644
--- a/src/UI/Butcher/Monadic/IO.hs
+++ b/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
diff --git a/src/UI/Butcher/Monadic/Pretty.hs b/src/UI/Butcher/Monadic/Pretty.hs
index c1e9b3a..e26e4c2 100644
--- a/src/UI/Butcher/Monadic/Pretty.hs
+++ b/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 ++ "..\"."
+