Skip to content

Commit

Permalink
Improve error reporting
Browse files Browse the repository at this point in the history
  • Loading branch information
@tibbe
tibbe committed Aug 23, 2012
1 parent 737cad9 commit 08d1673
Showing 1 changed file with 43 additions and 43 deletions.
86 changes: 43 additions & 43 deletions Data/Ceason/Conversion.hs
View file
Expand Up @@ -16,8 +16,6 @@ module Data.Ceason.Conversion
, Result(..)
, Parser
, parse
, parseMaybe
, parseEither

-- * Accessors
, (.!)
Expand Down Expand Up @@ -111,8 +109,7 @@ class ToRecord a where
instance FromField a => FromRecord (Only a) where
parseRecord v
| n == 1 = Only <$> parseField (V.unsafeIndex v 0)
| otherwise = fail $ "cannot unpack array of length " ++
show n ++ " into a 'Only'"
| otherwise = lengthMismatch 1 v
where
n = V.length v

Expand All @@ -125,8 +122,7 @@ instance (FromField a, FromField b) => FromRecord (a, b) where
parseRecord v
| n == 2 = (,) <$> parseField (V.unsafeIndex v 0)
<*> parseField (V.unsafeIndex v 1)
| otherwise = fail $ "cannot unpack array of length " ++
show n ++ " into a pair"
| otherwise = lengthMismatch 2 v
where
n = V.length v

Expand All @@ -138,8 +134,7 @@ instance (FromField a, FromField b, FromField c) => FromRecord (a, b, c) where
| n == 3 = (,,) <$> parseField (V.unsafeIndex v 0)
<*> parseField (V.unsafeIndex v 1)
<*> parseField (V.unsafeIndex v 2)
| otherwise = fail $ "cannot unpack array of length " ++
show n ++ " into a 3-tuple"
| otherwise = lengthMismatch 3 v
where
n = V.length v

Expand All @@ -154,8 +149,7 @@ instance (FromField a, FromField b, FromField c, FromField d) =>
<*> parseField (V.unsafeIndex v 1)
<*> parseField (V.unsafeIndex v 2)
<*> parseField (V.unsafeIndex v 3)
| otherwise = fail $ "cannot unpack array of length " ++
show n ++ " into a 4-tuple"
| otherwise = lengthMismatch 4 v
where
n = V.length v

Expand All @@ -172,8 +166,7 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>
<*> parseField (V.unsafeIndex v 2)
<*> parseField (V.unsafeIndex v 3)
<*> parseField (V.unsafeIndex v 4)
| otherwise = fail $ "cannot unpack array of length " ++
show n ++ " into a 5-tuple"
| otherwise = lengthMismatch 5 v
where
n = V.length v

Expand All @@ -192,8 +185,7 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e,
<*> parseField (V.unsafeIndex v 3)
<*> parseField (V.unsafeIndex v 4)
<*> parseField (V.unsafeIndex v 5)
| otherwise = fail $ "cannot unpack array of length " ++
show n ++ " into a 6-tuple"
| otherwise = lengthMismatch 6 v
where
n = V.length v

Expand All @@ -213,8 +205,7 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e,
<*> parseField (V.unsafeIndex v 4)
<*> parseField (V.unsafeIndex v 5)
<*> parseField (V.unsafeIndex v 6)
| otherwise = fail $ "cannot unpack array of length " ++
show n ++ " into a 7-tuple"
| otherwise = lengthMismatch 7 v
where
n = V.length v

Expand All @@ -225,6 +216,17 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
toField a, toField b, toField c, toField d, toField e, toField f,
toField g]

lengthMismatch :: Int -> Record -> Parser a
lengthMismatch expected v =
fail $ "cannot unpack array of length " ++
show n ++ " into a " ++ desired ++ ". Input record: " ++
show v
where
n = V.length v
desired | expected == 1 = "Only"
| expected == 2 = "pair"
| otherwise = show expected ++ "-tuple"

instance FromField a => FromRecord [a] where
parseRecord = traverse parseField . V.toList

Expand Down Expand Up @@ -362,8 +364,7 @@ class ToField a where
instance FromField Char where
parseField s
| T.compareLength t 1 == EQ = pure (T.head t)
| otherwise = fail $ "when expecting a Char, encountered \"" ++
B8.unpack s ++ "\" instead"
| otherwise = typeError "Char" s Nothing
where t = T.decodeUtf8 s
{-# INLINE parseField #-}

Expand All @@ -389,92 +390,92 @@ instance ToField Float where

parseDouble :: B.ByteString -> Parser Double
parseDouble s = case parseOnly double s of
Left err -> fail err
Left err -> typeError "Double" s (Just err)
Right n -> pure n
{-# INLINE parseDouble #-}

instance FromField Int where
parseField = parseIntegral
parseField = parseIntegral "Int"
{-# INLINE parseField #-}

instance ToField Int where
toField = decimal
{-# INLINE toField #-}

instance FromField Integer where
parseField = parseIntegral
parseField = parseIntegral "Integer"
{-# INLINE parseField #-}

instance ToField Integer where
toField = decimal
{-# INLINE toField #-}

instance FromField Int8 where
parseField = parseIntegral
parseField = parseIntegral "Int8"
{-# INLINE parseField #-}

instance ToField Int8 where
toField = decimal
{-# INLINE toField #-}

instance FromField Int16 where
parseField = parseIntegral
parseField = parseIntegral "Int16"
{-# INLINE parseField #-}

instance ToField Int16 where
toField = decimal
{-# INLINE toField #-}

instance FromField Int32 where
parseField = parseIntegral
parseField = parseIntegral "Int32"
{-# INLINE parseField #-}

instance ToField Int32 where
toField = decimal
{-# INLINE toField #-}

instance FromField Int64 where
parseField = parseIntegral
parseField = parseIntegral "Int64"
{-# INLINE parseField #-}

instance ToField Int64 where
toField = decimal
{-# INLINE toField #-}

instance FromField Word where
parseField = parseIntegral
parseField = parseIntegral "Word"
{-# INLINE parseField #-}

instance ToField Word where
toField = decimal
{-# INLINE toField #-}

instance FromField Word8 where
parseField = parseIntegral
parseField = parseIntegral "Word8"
{-# INLINE parseField #-}

instance ToField Word8 where
toField = decimal
{-# INLINE toField #-}

instance FromField Word16 where
parseField = parseIntegral
parseField = parseIntegral "Word16"
{-# INLINE parseField #-}

instance ToField Word16 where
toField = decimal
{-# INLINE toField #-}

instance FromField Word32 where
parseField = parseIntegral
parseField = parseIntegral "Word32"
{-# INLINE parseField #-}

instance ToField Word32 where
toField = decimal
{-# INLINE toField #-}

instance FromField Word64 where
parseField = parseIntegral
parseField = parseIntegral "Word64"
{-# INLINE parseField #-}

instance ToField Word64 where
Expand Down Expand Up @@ -534,12 +535,20 @@ instance ToField LT.Text where
toField = toField . B.concat . L.toChunks . LT.encodeUtf8
{-# INLINE toField #-}

parseIntegral :: Integral a => B.ByteString -> Parser a
parseIntegral s = case parseOnly number s of
Left err -> fail err
parseIntegral :: Integral a => String -> B.ByteString -> Parser a
parseIntegral typ s = case parseOnly number s of
Left err -> typeError typ s (Just err)
Right n -> pure (floor n)
{-# INLINE parseIntegral #-}

typeError :: String -> B.ByteString -> Maybe String -> Parser a
typeError typ s mmsg =
fail $ "expected " ++ typ ++ ", got '" ++ B8.unpack s ++ "'" ++ cause
where
cause = case mmsg of
Just msg -> " (" ++ msg ++ ")"
Nothing -> ""

------------------------------------------------------------------------
-- Constructors and accessors

Expand All @@ -555,7 +564,7 @@ v .! idx = parseField (v ! idx)
-- to the desired type.
(.:) :: FromField a => NamedRecord -> B.ByteString -> Parser a
m .: name = maybe (fail err) parseField $ HM.lookup name m
where err = "No field named " ++ B8.unpack name
where err = "no field named '" ++ B8.unpack name ++ "'"
{-# INLINE (.:) #-}

-- | Construct a pair from a name and a value. For use with
Expand Down Expand Up @@ -685,12 +694,3 @@ apP d e = do
parse :: Parser a -> Result a
parse p = runParser p Error Success
{-# INLINE parse #-}

-- | Run a 'Parser' with a 'Maybe' result type.
parseMaybe :: (a -> Parser b) -> a -> Maybe b
parseMaybe m v = runParser (m v) (const Nothing) Just
{-# INLINE parseMaybe #-}

-- | Run a 'Parser' with an 'Either' result type.
parseEither :: (a -> Parser b) -> a -> Either String b
parseEither m v = runParser (m v) Left Right

0 comments on commit 08d1673

Please sign in to comment.