summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2017-12-04 12:42:53 +0300
committerdefanor <defanor@uberspace.net>2017-12-04 12:42:53 +0300
commit75bb965621881ac59ce6b7a077a2261171d3a35c (patch)
treeb365aa10320ed1a6956f98aefcf99b0fcf1a482a
parentb876ef842345b69eec32b17c02642febdc9d3883 (diff)
downloadcoalpit-75bb965621881ac59ce6b7a077a2261171d3a35c.zip
coalpit-75bb965621881ac59ce6b7a077a2261171d3a35c.tar.gz
coalpit-75bb965621881ac59ce6b7a077a2261171d3a35c.tar.bz2
Produce prettier error messages
-rw-r--r--Coalpit.hs46
1 files 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]