yaml-combinators 1.0.1 → 1.1
raw patch · 4 files changed
+213/−66 lines, 4 files
Files
- ChangeLog.md +7/−0
- src/Data/Yaml/Combinators.hs +130/−54
- tests/test.hs +74/−11
- yaml-combinators.cabal +2/−1
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for yaml-combinators +## 1.1++* Add `null_`+* Expose `ppParseError`+* Improve the quality of error messages+* Change the definition of the `Reason` type+ ## 1.0.1 — 2017-06-13 * Add `validate`
src/Data/Yaml/Combinators.hs view
@@ -15,6 +15,7 @@ , number , integer , bool+ , null_ -- * Arrays , array , theArray@@ -29,6 +30,7 @@ , theField -- * Errors , ParseError(..)+ , ppParseError , Reason(..) , validate ) where@@ -40,17 +42,20 @@ import Data.List import Data.Maybe import Data.ByteString (ByteString)+import Data.Monoid ((<>)) import qualified Data.ByteString.Char8 as BS8 import Data.Bifunctor (first) import Control.Monad.Trans.Reader import Control.Monad.Trans.State as State-import Control.Monad.Trans.Class import Data.Vector (Vector) import qualified Data.Vector as V import Data.Functor.Product import Data.Functor.Constant import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM+import Data.HashSet (HashSet)+import qualified Data.HashSet as HS+import Data.Ord import Generics.SOP import Generics.SOP.TH @@ -58,6 +63,7 @@ -- >>> :set -XOverloadedStrings -XTypeApplications -- >>> import Data.Monoid +-- orphan Value instances deriveGeneric ''Value ----------------------------------------------------------------------@@ -87,25 +93,76 @@ -- | Describes what exactly went wrong during parsing. data Reason+ -- NB: the order of constructors is important for the Ord instance = UnexpectedAsPartOf Value Value- | ExpectedAsPartOf String Value- | ExpectedInsteadOf String Value+ | ExpectedAsPartOf (HashSet String) Value+ | ExpectedInsteadOf (HashSet String) Value deriving (Eq, Show) +-- | Find out which error is more severe+compareSeverity :: ParseError -> ParseError -> Ordering+compareSeverity (ParseError l1 r1) (ParseError l2 r2) =+ -- extra stuff is always less severe than mismatching/missing stuff+ comparing (not . isUnexpected) r1 r2 <>+ -- otherwise, compare the depths+ compare l1 l2 <>+ -- if the depths are equal, mismatches are more severe that misses,+ comparing isMismatch r1 r2+ where+ isUnexpected e = case e of+ UnexpectedAsPartOf {} -> True+ _ -> False+ isMismatch e = case e of+ ExpectedInsteadOf {} -> True+ _ -> False++-- | Choose the more severe of two errors.+--+-- If they are equally severe, pick the earlier one.+moreSevere :: ParseError -> ParseError -> ParseError+moreSevere e1 e2 =+ case compareSeverity e1 e2 of+ LT -> e2+ _ -> e1++-- | Choose the less severe of two errors.+--+-- If they are equally severe, pick the earlier one.+lessSevere :: ParseError -> ParseError -> ParseError+lessSevere e1 e2 =+ case compareSeverity e1 e2 of+ GT -> e2+ _ -> e1++newtype Validation a = Validation { getValidation :: Either ParseError a }+ deriving Functor++instance Applicative Validation where+ pure = Validation . Right+ Validation a <*> Validation b = Validation $+ case a of+ Right va -> fmap va b+ Left ea -> either (Left . moreSevere ea) (const $ Left ea) b++bindV :: Validation a -> (a -> Validation b) -> Validation b+bindV a b = Validation $ getValidation a >>= getValidation . b+ mergeParseError :: ParseError -> ParseError -> ParseError-mergeParseError e1@(ParseError l1 r1) e2@(ParseError l2 r2) =- case compare l1 l2 of- GT -> e1- EQ- | ExpectedAsPartOf exp1 w1 <- r1- , ExpectedAsPartOf exp2 w2 <- r2- , w1 == w2- -> ParseError l1 (ExpectedAsPartOf (exp1 ++ ", " ++ exp2) w1)- | ExpectedInsteadOf exp1 w1 <- r1- , ExpectedInsteadOf exp2 w2 <- r2- , w1 == w2- -> ParseError l1 (ExpectedInsteadOf (exp1 ++ ", " ++ exp2) w1)- _ -> e2+mergeParseError e1@(ParseError l1 r1) e2@(ParseError l2 r2)+ -- first, see if we can merge the two errors+ | l1 == l2+ , ExpectedAsPartOf exp1 w1 <- r1+ , ExpectedAsPartOf exp2 w2 <- r2+ , w1 == w2+ = ParseError l1 (ExpectedAsPartOf (exp1 <> exp2) w1)+ | l1 == l2+ , ExpectedInsteadOf exp1 w1 <- r1+ , ExpectedInsteadOf exp2 w2 <- r2+ , w1 == w2+ = ParseError l1 (ExpectedInsteadOf (exp1 <> exp2) w1)+ -- otherwise, just choose the least severe one,+ -- since its branch is more likely to be the right one+ | otherwise = lessSevere e1 e2 ppParseError :: ParseError -> String ppParseError (ParseError _lvl reason) =@@ -113,18 +170,21 @@ UnexpectedAsPartOf part whole -> "Unexpected \n\n" ++ showYaml part ++ "\nas part of\n\n" ++ showYaml whole ExpectedInsteadOf exp1 got ->- "Expected " ++ exp1 ++ " instead of:\n\n" ++ showYaml got+ "Expected " ++ fmt_list exp1 ++ " instead of:\n\n" ++ showYaml got ExpectedAsPartOf exp1 got ->- "Expected " ++ exp1 ++ " as part of:\n\n" ++ showYaml got+ "Expected " ++ fmt_list exp1 ++ " as part of:\n\n" ++ showYaml got where showYaml :: Value -> String showYaml = BS8.unpack . encode + fmt_list :: HashSet String -> String+ fmt_list = intercalate ", " . sort . HS.toList+ ---------------------------------------------------------------------- -- Core definitions ---------------------------------------------------------------------- -newtype ParserComponent a fs = ParserComponent (Maybe (Value -> NP I fs -> Either ParseError a))+newtype ParserComponent a fs = ParserComponent (Maybe (Value -> NP I fs -> Validation a)) -- | A top-level YAML parser. -- -- * Construct a 'Parser' with 'string', 'number', 'integer', 'bool', 'array', or 'object'.@@ -150,8 +210,8 @@ (Nothing, Nothing) -> Nothing (Just p1, Nothing) -> Just p1 (Nothing, Just p2) -> Just p2- (Just p1, Just p2) -> Just $ \o v ->- case (p1 o v, p2 o v) of+ (Just p1, Just p2) -> Just $ \o v -> Validation $+ case (getValidation $ p1 o v, getValidation $ p2 o v) of (Right r1, _) -> Right r1 (_, Right r2) -> Right r2 (Left l1, Left l2) -> Left $ mergeParseError l1 l2@@ -162,13 +222,16 @@ -- | A low-level function to run a 'Parser'. runParser :: Parser a -> Value -> Either ParseError a-runParser (Parser comps) orig@(from -> SOP v) =+runParser p = getValidation . runParserV p++runParserV :: Parser a -> Value -> Validation a+runParserV (Parser comps) orig@(from -> SOP v) = hcollapse $ hliftA2 match comps v where- match :: ParserComponent a fs -> NP I fs -> K (Either ParseError a) fs+ match :: ParserComponent a fs -> NP I fs -> K (Validation a) fs match (ParserComponent mbP) v1 = K $ case mbP of- Nothing -> Left $ ParseError 0 $ ExpectedInsteadOf expected orig+ Nothing -> Validation . Left $ ParseError 0 $ ExpectedInsteadOf (HS.singleton expected) orig Just p -> p orig v1 expected =@@ -195,24 +258,22 @@ wrap (ParserComponent maybeP) = ParserComponent $ case maybeP of Nothing -> Nothing- Just p -> Just $ \orig val ->- case p orig val of- Left err -> Left err- Right parsed -> decorator parsed orig+ Just p -> Just $ \orig val -> p orig val `bindV`+ \parsed -> Validation $ decorator parsed orig ---------------------------------------------------------------------- -- Combinators ---------------------------------------------------------------------- -incErrLevel :: Either ParseError a -> Either ParseError a-incErrLevel = first $ \(ParseError l r) -> ParseError (l+1) r+incErrLevel :: Validation a -> Validation a+incErrLevel = Validation . first (\(ParseError l r) -> ParseError (l+1) r) . getValidation -- | Match a single YAML string. -- -- >>> parse string "howdy" -- Right "howdy" string :: Parser Text-string = fromComponent $ S . S . Z $ ParserComponent $ Just $ const $ \(I s :* Nil) -> Right s+string = fromComponent $ S . S . Z $ ParserComponent $ Just $ const $ \(I s :* Nil) -> pure s -- | Match a specific YAML string, usually a «tag» identifying a particular -- form of an array or object.@@ -225,9 +286,9 @@ -- bye theString :: Text -> Parser () theString t = fromComponent $ S . S . Z $ ParserComponent $ Just $ const $ \(I s :* Nil) ->- if s == t+ Validation $ if s == t then Right ()- else Left $ ParseError 1 (ExpectedInsteadOf (show t) (String s))+ else Left $ ParseError 0 (ExpectedInsteadOf (HS.singleton $ show t) (String s)) -- | Match an array of elements, where each of elements are matched by -- the same parser. This is the function you'll use most of the time when@@ -236,7 +297,7 @@ -- >>> parse (array string) "[a,b,c]" -- Right ["a","b","c"] array :: Parser a -> Parser (Vector a)-array p = fromComponent $ S . Z $ ParserComponent $ Just $ const $ \(I a :* Nil) -> incErrLevel $ mapM (runParser p) a+array p = fromComponent $ S . Z $ ParserComponent $ Just $ const $ \(I a :* Nil) -> incErrLevel $ traverse (runParserV p) a -- | An 'ElementParser' describes how to parse a fixed-size array -- where each positional element has its own parser.@@ -247,21 +308,22 @@ -- * Construct an 'ElementParser' with 'element' and the 'Applicative' combinators. -- -- * Turn a 'FieldParser' into a 'Parser' with 'theArray'.-newtype ElementParser a = ElementParser (StateT [Value] (Either (Array -> ParseError)) a)+newtype ElementParser a = ElementParser+ (((State [Value]) :.: (ReaderT Array Validation)) a) deriving (Functor, Applicative) -- | Construct an 'ElementParser' that parses the current array element -- with the given 'Parser'. element :: Parser a -> ElementParser a-element p = ElementParser $ do+element p = ElementParser $ Comp $ do vs <- State.get case vs of- [] -> lift $ Left $ \arr ->+ [] -> return $ ReaderT $ \arr -> Validation . Left $ let n = V.length arr + 1- in ParseError 0 $ ExpectedAsPartOf ("at least " ++ show n ++ " elements") $ Array arr+ in ParseError 0 $ ExpectedAsPartOf (HS.singleton $ "at least " ++ show n ++ " elements") $ Array arr (v:vs') -> do State.put vs'- lift $ first const $ incErrLevel $ runParser p v+ return . liftR $ runParserV p v -- | Match an array consisting of a fixed number of elements. The way each -- element is parsed depends on its position within the array and@@ -270,18 +332,21 @@ -- >>> parse (theArray $ (,) <$> element string <*> element bool) "[f, true]" -- Right ("f",True) theArray :: ElementParser a -> Parser a-theArray (ElementParser ep) = fromComponent $ S . Z $ ParserComponent $ Just $ const $ \(I a :* Nil) -> incErrLevel $- case runStateT ep (V.toList a) of- Right (r, []) -> return r- Right (_, v:_) -> Left $ ParseError 0 $ UnexpectedAsPartOf v $ Array a- Left errFn -> Left $ errFn a+theArray (ElementParser (Comp ep)) = fromComponent $ S . Z $ ParserComponent $ Just $ const $ \(I a :* Nil) -> incErrLevel $+ case first (flip runReaderT a) $ runState ep (V.toList a) of+ (result, leftover) ->+ result <*+ (case leftover of+ [] -> pure ()+ v : _ -> Validation . Left $ ParseError 0 $ UnexpectedAsPartOf v $ Array a+ ) -- | Match a real number. -- -- >>> parse number "3.14159" -- Right 3.14159 number :: Parser Scientific-number = fromComponent $ S . S . S . Z $ ParserComponent $ Just $ const $ \(I n :* Nil) -> Right n+number = fromComponent $ S . S . S . Z $ ParserComponent $ Just $ const $ \(I n :* Nil) -> pure n -- | Match an integer. --@@ -290,16 +355,23 @@ integer :: (Integral i, Bounded i) => Parser i integer = fromComponent $ S . S . S . Z $ ParserComponent $ Just $ const $ \(I n :* Nil) -> case toBoundedInteger n of- Just i -> Right i- Nothing -> Left $ ParseError 0 $ ExpectedInsteadOf "integer" (Number n)+ Just i -> pure i+ Nothing -> Validation . Left $ ParseError 0 $ ExpectedInsteadOf (HS.singleton "integer") (Number n) -- | Match a boolean. -- -- >>> parse bool "yes" -- Right True bool :: Parser Bool-bool = fromComponent $ S . S . S . S . Z $ ParserComponent $ Just $ const $ \(I b :* Nil) -> Right b+bool = fromComponent $ S . S . S . S . Z $ ParserComponent $ Just $ const $ \(I b :* Nil) -> pure b +-- | Match the @null@ value.+--+-- >>> parse null_ "null"+-- Right ()+null_ :: Parser ()+null_ = fromComponent $ S . S . S . S . S . Z $ ParserComponent $ Just $ const $ \Nil -> pure ()+ -- | Make a parser match only valid values. -- -- If the validator does not accept the value, it should return a@@ -321,7 +393,7 @@ decorate parser (validity . validator) where validity (Right result) _ = Right result- validity (Left problem) orig = Left $ ParseError 1 $ ExpectedInsteadOf problem orig+ validity (Left problem) orig = Left $ ParseError 1 $ ExpectedInsteadOf (HS.singleton problem) orig -- | A 'FieldParser' describes how to parse an object. --@@ -330,7 +402,7 @@ -- * Turn a 'FieldParser' into a 'Parser' with 'object'. newtype FieldParser a = FieldParser (Product- (ReaderT Object (Either ParseError))+ (ReaderT Object Validation) (Constant (HashMap Text ())) a) deriving (Functor, Applicative) @@ -344,8 +416,8 @@ Pair (ReaderT $ \o -> case HM.lookup name o of- Nothing -> Left $ ParseError 0 $ ExpectedAsPartOf ("field " ++ show name) $ Object o- Just v -> incErrLevel $ runParser p v+ Nothing -> Validation . Left $ ParseError 0 $ ExpectedAsPartOf (HS.singleton $ "field " ++ show name) $ Object o+ Just v -> runParserV p v ) (Constant $ HM.singleton name ()) @@ -357,7 +429,7 @@ -> FieldParser (Maybe a) optField name p = FieldParser $ Pair- (ReaderT $ \o -> traverse (incErrLevel . runParser p) $ HM.lookup name o)+ (ReaderT $ \o -> traverse (runParserV p) $ HM.lookup name o) (Constant $ HM.singleton name ()) -- | Declare an optional object field with the given name and with a default@@ -405,5 +477,9 @@ [] -> pure () name : _ -> let v = o HM.! name- in Left $ ParseError 0 $ UnexpectedAsPartOf (Object (HM.singleton name v)) (Object o)+ in Validation . Left $ ParseError 0 $ UnexpectedAsPartOf (Object (HM.singleton name v)) (Object o) )++-- | Like 'lift' for 'ReaderT', but doesn't require a 'Monad' instance+liftR :: f a -> ReaderT r f a+liftR = ReaderT . const
tests/test.hs view
@@ -4,6 +4,7 @@ import Test.Tasty import Test.Tasty.HUnit import Data.Aeson hiding (object)+import qualified Data.Text as T import Data.Monoid import qualified Data.HashMap.Strict as HM @@ -15,22 +16,22 @@ Right "hi" , testCase "Expect String, get Number" $ runParser string (Number 3) @?=- Left (ParseError 0 $ ExpectedInsteadOf "String" (Number 3))+ Left (ParseError 0 $ ExpectedInsteadOf ["String"] (Number 3)) , testCase "Expect specific String, get another String" $ runParser (theString "bye") (String "hi") @?=- Left (ParseError 1 $ ExpectedInsteadOf "\"bye\"" (String "hi"))+ Left (ParseError 0 $ ExpectedInsteadOf ["\"bye\""] (String "hi")) , testCase "Expect specific String or Number, get another string" $ runParser (theString "bye" <> void number) (String "hi") @?=- Left (ParseError 1 $ ExpectedInsteadOf "\"bye\"" (String "hi"))+ Left (ParseError 0 $ ExpectedInsteadOf ["\"bye\""] (String "hi")) , testCase "Expect an array, get an array" $ runParser (array string) (Array [String "hi"]) @?= Right ["hi"] , testCase "Expect an array, get an object" $ runParser (array string) (Object HM.empty) @?=- Left (ParseError 0 $ ExpectedInsteadOf "Array" (Object []))+ Left (ParseError 0 $ ExpectedInsteadOf ["Array"] (Object [])) , testCase "Expect an array of Strings, get an array of Numbers" $ runParser (array string) (Array [Number 3]) @?=- Left (ParseError 1 $ ExpectedInsteadOf "String" (Number 3))+ Left (ParseError 1 $ ExpectedInsteadOf ["String"] (Number 3)) , testCase "Expect an object, get an object" $ runParser (object $ field "foo" number) (Object [("foo", Number 1)]) @?= Right 1@@ -39,19 +40,19 @@ Right "foo" , testCase "Validated String, rejects everything" $ runParser (validate string (const (Left "contrarianism" :: Either String String))) (String "foo") @?=- Left (ParseError 1 (ExpectedInsteadOf "contrarianism" (String "foo")))+ Left (ParseError 1 (ExpectedInsteadOf ["contrarianism"] (String "foo"))) , testCase "Expect an object, get an array" $ runParser (object $ field "foo" number) (Array []) @?=- Left (ParseError 0 $ ExpectedInsteadOf "Object" (Array []))+ Left (ParseError 0 $ ExpectedInsteadOf ["Object"] (Array [])) , testCase "Expect an object, get an object missing a field" $ runParser (object $ field "foo" number *> field "bar" string) (Object [("foo", Number 1)]) @?=- Left (ParseError 1 $ ExpectedAsPartOf "field \"bar\"" (Object ([("foo",Number 1.0)])))+ Left (ParseError 1 $ ExpectedAsPartOf ["field \"bar\""] (Object ([("foo",Number 1.0)]))) , testCase "Expect an object, get an object with an extra field" $ runParser (object $ field "foo" number) (Object [("foo", Number 1), ("bar", String "x")]) @?= Left (ParseError 1 $ UnexpectedAsPartOf (Object [("bar", String "x")]) (Object [("foo", Number 1), ("bar", String "x")])) , testCase "Expect an object, get a field that doesn't match" $ runParser (object $ field "foo" number) (Object [("foo", String "hi")]) @?=- Left (ParseError 2 $ ExpectedInsteadOf "Number" (String "hi"))+ Left (ParseError 1 $ ExpectedInsteadOf ["Number"] (String "hi")) , testCase "Expect an object with opt field, field present" $ runParser (object $ optField "foo" number) (Object [("foo", Number 1)]) @?= Right (Just 1)@@ -75,17 +76,79 @@ (theArray $ (,) <$> element number <*> element string) (Array [Number 2]) @?=- Left (ParseError 1 (ExpectedAsPartOf "at least 2 elements" (Array [Number 2])))+ Left (ParseError 1 (ExpectedAsPartOf ["at least 2 elements"] (Array [Number 2]))) , testCase "Expect an array of number and string, get only string" $ runParser (theArray $ (,) <$> element number <*> element string) (Array [String "hi"]) @?=- Left (ParseError 2 $ ExpectedInsteadOf "Number" (String "hi"))+ Left (ParseError 1 $ ExpectedInsteadOf ["Number"] (String "hi")) , testCase "Expect an array of number and string, get them and something else" $ runParser (theArray $ (,) <$> element number <*> element string) (Array [Number 2, String "hi", Number 42]) @?= Left (ParseError 1 $ UnexpectedAsPartOf (Number 42) (Array [Number 2.0,String "hi",Number 42]))+ , testCase "Wrong tag" $+ runParser+ ((object (Nothing <$ theField "tag" "Nothing")) <>+ (object (Just <$ theField "tag" "Just" <*> field "value" number)))+ (Object [("tag", String "Nothing"), ("value", Number 3)])+ @?=+ Left (ParseError 1 (UnexpectedAsPartOf+ (Object ([("value",Number 3.0)]))+ (Object ([("tag",String "Nothing"),("value",Number 3.0)]))))+ , testCase "More serious error takes precedence even though it happens later" $+ runParser+ (theArray (element (object (pure ())) *> element number))+ (Array [Object [("foo","bar")], String "baz"])+ @?=+ Left (ParseError 1 (ExpectedInsteadOf ["Number"] (String "baz")))+ , testCase "Prefer the branch with missing data to the branch with mismatched tag" $ do+ let+ p1 = object $ ()+ <$ theField "tag" "one"+ <* field "a" string++ p2 = object $ ()+ <$ theField "tag" "two"++ v = Object [("tag", String "one")]+ expected_result = Left (ParseError 1+ (ExpectedAsPartOf+ ["field \"a\""]+ v+ ))+ runParser p1 v @?= expected_result+ runParser (p1 <> p2) v @?= expected_result+ runParser (p2 <> p1) v @?= expected_result+ , testCase "When a tag is mismatched, all alternatives get collected" $ do+ let+ p1 = object $ ()+ <$ theField "tag" "one"+ <* field "a" string++ p2 = object $ ()+ <$ theField "tag" "two"++ p3 = object $ ()+ <$ theField "foo" "bar"+ <* theField "tag" "three"++ v = Object [("tag", String "xxx"),("garbage",Number 7)]+ expected_result = Left (ParseError 1+ (ExpectedInsteadOf+ ["\"one\"", "\"two\"", "\"three\""]+ (String "xxx")+ ))+ runParser (p1 <> p2 <> p3) v @?= expected_result+ , testCase "Alternatives are only reported once" $ do+ let+ even_str = validate string $ \s ->+ if even (T.length s)+ then Right s+ else Left "even-length string"+ runParser (even_str <> even_str) (String "x")+ @?=+ Left (ParseError 1 (ExpectedInsteadOf ["even-length string"] (String "x"))) ]
yaml-combinators.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: yaml-combinators-version: 1.0.1+version: 1.1 synopsis: YAML parsing combinators for improved validation and error reporting description: Based on the article <https://ro-che.info/articles/2015-07-26-better-yaml-parsing Better Yaml Parsing>.@@ -58,6 +58,7 @@ , aeson , tasty , tasty-hunit+ , text , unordered-containers , yaml-combinators