From 75bb965621881ac59ce6b7a077a2261171d3a35c Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Mon, 4 Dec 2017 12:42:53 +0300
Subject: Produce prettier error messages

---
 Coalpit.hs | 46 ++++++++++++++++++++++++++--------------------
 1 file changed, 26 insertions(+), 20 deletions(-)

diff --git a/Coalpit.hs b/Coalpit.hs
index 357b6e5..7b9fd39 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -63,7 +63,7 @@ module Coalpit (
   , defMod
   -- * Parsing helpers
   , Parser
-  , Args(..)
+  , CLArg(..)
   , pS
   , readArg
   ) where
@@ -75,20 +75,23 @@ import Text.Megaparsec.Char
 import Data.Char
 import Data.Proxy
 import Data.Semigroup
+import Data.Void
+import qualified Data.List.NonEmpty as NE
 
 
--- | Command-line arguments wrapper, used to avoid an orphan 'Stream'
--- instance.
-newtype Args = Args [String]
+-- | Command-line argument wrapper, used to avoid orphan ShowToken
+-- String and Stream [String] instances.
+newtype CLArg = CLArg { unArg :: String }
+  deriving (Ord, Eq)
 
 -- | Advances by one token.
 advance :: Pos -> SourcePos -> t -> SourcePos
 advance _ (SourcePos n l c) _ = SourcePos n l (c <> pos1)
 
 -- | A list of strings (command-line arguments) stream.
-instance Stream Args where
-  type Token Args = String
-  type Tokens Args = [String]
+instance Stream [CLArg] where
+  type Token [CLArg] = CLArg
+  type Tokens [CLArg] = [CLArg]
   tokenToChunk Proxy = pure
   tokensToChunk Proxy = id
   chunkToTokens Proxy = id
@@ -96,21 +99,24 @@ instance Stream Args where
   chunkEmpty Proxy = null
   advance1 Proxy = advance
   advanceN Proxy w = foldl' (advance w)
-  take1_ (Args []) = Nothing
-  take1_ (Args (t:ts)) = Just (t, Args ts)
-  takeN_ n (Args s)
-    | n <= 0    = Just ([], Args s)
+  take1_ ([]) = Nothing
+  take1_ ((t:ts)) = Just (t, ts)
+  takeN_ n s
+    | n <= 0    = Just ([], s)
     | null s    = Nothing
-    | otherwise = Just (take n s, Args (drop n s))
-  takeWhile_ f (Args s) = (takeWhile f s, Args (dropWhile f s))
+    | otherwise = Just (take n s, (drop n s))
+  takeWhile_ f s = (takeWhile f s, (dropWhile f s))
+
+instance ShowToken CLArg where
+  showTokens xs = concat $ NE.map unArg xs
 
 -- | Command-line arguments parser.
-type Parser = Parsec String Args
+type Parser = Parsec Void [CLArg]
 
 -- | Applies a String parser to a single argument.
-pS :: Parsec String String a -> Parsec String Args a
+pS :: Parsec Void String a -> Parsec Void [CLArg] a
 pS p = try $ do
-  x <- token Right Nothing
+  x <- token (Right . unArg) Nothing
   case parse p "argument" x of
     Left e -> fail $ show e
     Right x' -> pure x'
@@ -144,8 +150,8 @@ class GArgParser f where
 
 -- | Parses arguments.
 fromArgs :: ArgParser a => Modifiers -> [String] -> Either String a
-fromArgs m args = case parse (argParser m) "arguments" (Args args) of
-  Left err -> Left $ show err
+fromArgs m args = case parse (argParser m) "arguments" (map CLArg args) of
+  Left err -> Left $ parseErrorPretty err
   Right x -> Right x
 
 -- | Arguments serializer class.
@@ -287,7 +293,7 @@ instance (ToArgs a) => GToArgs (K1 i a) where
 -- | Reads an argument using its 'Read' instance.
 readArg :: Read a => Parser a
 readArg = do
-  x <- token Right Nothing
+  x <- token (Right . unArg) Nothing
   case reads x of
     [(n, "")] -> pure n
     _ -> fail $ "Failed to read: " ++ x
@@ -313,7 +319,7 @@ instance ToArgs Double where
   toArgs _ i = [show i]
 
 instance {-#OVERLAPPING#-} ArgParser String where
-  argParser _ = token Right Nothing
+  argParser _ = token (Right . unArg) Nothing
 instance {-#OVERLAPPING#-} ToArgs String where
   toArgs _ i = [i]
 
-- 
cgit v1.2.3