diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,11 @@ +### 0.1.1.0 + +* `Data.YAML` module promoted from `TrustWorthy` to `Safe` +* Add `FromYAML Natural` instance +* Add `Alternative` and `MonadPlus` instances for `Data.YAML.Parser` +* Add `Data.YAML.decodeStrict` function +* Export `Data.YAML.typeMismatch` helper function + +## 0.1.0.0 + +* First version. Released on an unsuspecting world. diff --git a/HsYAML.cabal b/HsYAML.cabal --- a/HsYAML.cabal +++ b/HsYAML.cabal @@ -1,9 +1,10 @@ cabal-version: 1.14 name: HsYAML -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Pure Haskell YAML 1.2 parser homepage: https://github.com/hvr/HsYAML +bug-reports: https://github.com/hvr/HsYAML/issues license: GPL-3 license-file: LICENSE author: Herbert Valerio Riedel @@ -15,17 +16,21 @@ tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 description: - @HsYAML@ is a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) parser for Haskell. + @HsYAML@ is a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) parser implementation for Haskell. . - Features include: + Features of @HsYAML@ include: . - * Pure Haskell implementation with small dependency footprint and emphasis on strict compliance with the [YAML 1.2 specification](http://yaml.org/spec/1.2/spec.html) - * Low-level API access to lexical token-based scanner ("Data.YAML.Token") - * Event-based API resembling LibYAML's Event-based API ("Data.YAML.Event") - * Support for constructing custom YAML node graph representation (including support for cyclic YAML data structures) - * Direct decoding via typeclass-based API similiar to @aeson@ ("Data.YAML") - * Support for /Failsafe/, /JSON/ and /Core/ schemas as defined in the YAML 1.2 specification (including support for user-defined custom schemas) + * Pure Haskell implementation with small dependency footprint and emphasis on strict compliance with the [YAML 1.2 specification](http://yaml.org/spec/1.2/spec.html). + * Direct decoding to native Haskell types via (@aeson@-inspired) typeclass-based API (see "Data.YAML"). + * Support for constructing custom YAML node graph representation (including support for cyclic YAML data structures). + * Support for the standard (untyped) /Failsafe/, (strict) /JSON/, and (flexible) /Core/ \"schemas\" providing implicit typing rules as defined in the YAML 1.2 specification (including support for user-defined custom schemas). + * Event-based API resembling LibYAML's Event-based API (see "Data.YAML.Event"). + * Low-level API access to lexical token-based scanner (see "Data.YAML.Token"). + . +extra-source-files: + ChangeLog.md + source-repository head type: git location: https://github.com/hvr/HsYAML.git @@ -65,6 +70,12 @@ , text >=1.2.3 && <1.3 , mtl >=2.2.1 && <2.3 , parsec >=3.1.13.0 && < 3.2 + + if !impl(ghc >= 8.0) + build-depends: fail >=4.9.0.0 && <4.10 + + if !impl(ghc >= 7.10) + build-depends: nats >=1.1.2 && <1.2 ghc-options: -Wall diff --git a/src-test/Main.hs b/src-test/Main.hs --- a/src-test/Main.hs +++ b/src-test/Main.hs @@ -159,6 +159,23 @@ unescapeSpcTab :: T.Text -> T.Text unescapeSpcTab = T.replace "" " " . T.replace "" "\t" + +data TestPass = PassExpErr -- ^ expected parse fail + | PassEvs -- ^ events ok + | PassEvsJson -- ^ events+json ok + deriving (Eq,Ord,Show) + +data TestFail = FailParse -- ^ unexpected parse fail + | FailSuccess -- ^ unexpected parse success + | FailEvs -- ^ events wrong/mismatched + | FailJson -- ^ JSON wrong/mismatched + deriving (Eq,Ord,Show) + +data TestRes + = Pass !TestPass + | Fail !TestFail + deriving (Eq,Ord,Show) + cmdRunTml :: [FilePath] -> IO () cmdRunTml args = do results <- forM args $ \fn -> do @@ -185,7 +202,7 @@ Left err | isErr -> do putStrLn "OK! (error)" - pure True + pure (Pass PassExpErr) | otherwise -> do putStrLn "FAIL!" putStrLn "" @@ -204,7 +221,7 @@ putStrLn "" putStrLn "----------------------------------------------------------------------------" putStrLn "" - pure False + pure (Fail FailParse) Right evs' -> do let evs'' = map ev2str evs' @@ -214,21 +231,21 @@ case mInJsonDat of Nothing -> do putStrLn "OK!" - pure True + pure (Pass PassEvs) Just inJsonDat -> do iutJson <- either fail pure $ decodeAeson inYamlDat if iutJson == inJsonDat then do putStrLn "OK! (+JSON)" - pure True + pure (Pass PassEvsJson) else do putStrLn "FAIL! (bad JSON)" putStrLn' ("ref = " ++ show inJsonDat) putStrLn' ("iut = " ++ show iutJson) - pure False + pure (Fail FailJson) else do if isErr @@ -250,15 +267,23 @@ putStrLn "" putStrLn "----------------------------------------------------------------------------" putStrLn "" - pure False + pure (Fail (if isErr then FailSuccess else FailEvs)) putStrLn "" - let ok = length (filter id results') - nok = length (filter not results') + let ok = length [ () | Pass _ <- results' ] + nok = length [ () | Fail _ <- results' ] + + stat j = show $ Map.findWithDefault 0 j $ Map.fromListWith (+) [ (k,1::Int) | k <- results' ] + results' = concat results - putStrLn ("done (passed: " ++ show ok ++ " / failed: " ++ show nok ++ ")") + putStrLn $ concat + [ "done -- passed: ", show ok + , " (ev: ", stat (Pass PassEvs), ", ev+json: ", stat (Pass PassEvsJson), ", err: ", stat (Pass PassExpErr), ") / " + , "failed: ", show nok + , " (err: ", stat (Fail FailParse), ", ev:", stat (Fail FailEvs), ", json:", stat (Fail FailJson), ", ok:", stat (Fail FailSuccess), ")" + ] -- | Incomplete proof-of-concept 'testml-compiler' operation diff --git a/src/Data/YAML.hs b/src/Data/YAML.hs --- a/src/Data/YAML.hs +++ b/src/Data/YAML.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} -- | -- Copyright: © Herbert Valerio Riedel 2015-2018 -- SPDX-License-Identifier: GPL-3.0 -- --- Document oriented YAML parsing API inspired by [aeson](http://hackage.haskell.org/package/aeson). +-- Document oriented [YAML](http://yaml.org/spec/1.2/spec.html) parsing API inspired by [aeson](http://hackage.haskell.org/package/aeson). -- --- === Usage Example +-- === Overview -- --- Let's assume we want to decode a simple YAML document +-- The diagram below depicts the standard layers of a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) processor. This module covers the upper /Native/ and /Representation/ layers, whereas the "Data.YAML.Event" and "Data.YAML.Token" modules provide access to the lower /Serialization/ and /Presentation/ layers respectively. -- +-- <> +-- +-- === Quick Start Tutorial +-- +-- Let's assume we want to decode (i.e. /load/) a simple YAML document +-- -- > - name: Erik Weisz -- > age: 52 -- > magic: True -- > - name: Mina Crandon -- > age: 53 -- --- into a Haskell list of person records, i.e. a value of type @[Person]@. +-- into a native Haskell data structure of type @[Person]@, i.e. a list of 'Person' records. -- -- The code below shows how to manually define a @Person@ record type together with a 'FromYAML' instance: -- @@ -49,9 +54,11 @@ ( -- * Typeclass-based resolving/decoding decode + , decodeStrict , FromYAML(..) , Parser , parseEither + , typeMismatch -- ** Accessors for YAML 'Mapping's , Mapping @@ -86,6 +93,8 @@ ) where +import qualified Control.Monad.Fail as Fail +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BS.L import qualified Data.Map as Map import qualified Data.Text as T @@ -182,24 +191,63 @@ -- -- See also 'parseEither' or 'decode' newtype Parser a = P { unP :: Either String a } - deriving (Functor,Applicative) --- TODO: MonadFail +instance Functor Parser where + fmap f (P x) = P (fmap f x) + + x <$ P (Right _) = P (Right x) + _ <$ P (Left e) = P (Left e) + +instance Applicative Parser where + pure = P . Right + + P (Left e) <*> _ = P (Left e) + P (Right f) <*> P r = P (fmap f r) + + P (Left e) *> _ = P (Left e) + P (Right _) *> p = p + instance Monad Parser where return = pure P m >>= k = P (m >>= unP . k) (>>) = (*>) + fail = Fail.fail + +-- | @since 0.1.1.0 +instance Fail.MonadFail Parser where fail = P . Left +-- | @since 0.1.1.0 +instance Alternative Parser where + empty = fail "empty" + + P (Left _) <|> y = y + x <|> _ = x + +-- | @since 0.1.1.0 +instance MonadPlus Parser where + mzero = empty + mplus = (<|>) + -- | Run 'Parser' -- -- A common use-case is 'parseEither' 'parseYAML'. parseEither :: Parser a -> Either String a parseEither = unP --- helper -failTypeMismatch :: String -> Node -> Parser a -failTypeMismatch expected node = fail ("expected " ++ expected ++ " instead of " ++ got) +-- | Informative failure helper +-- +-- This is typically used in fall-through cases of 'parseYAML' like so +-- +-- > instance FromYAML ... where +-- > parseYAML ... = ... +-- > parseYAML node = typeMismatch "SomeThing" node +-- +-- @since 0.1.1.0 +typeMismatch :: String -- ^ descriptive name of expected data + -> Node -- ^ actual node + -> Parser a +typeMismatch expected node = fail ("expected " ++ expected ++ " instead of " ++ got) where got = case node of Scalar (SBool _) -> "!!bool" @@ -225,7 +273,7 @@ -- | Operate on @tag:yaml.org,2002:null@ node (or fail) withNull :: String -> Parser a -> Node -> Parser a withNull _ f (Scalar SNull) = f -withNull expected _ v = failTypeMismatch expected v +withNull expected _ v = typeMismatch expected v -- | Trivial instance @@ -238,7 +286,7 @@ -- | Operate on @tag:yaml.org,2002:bool@ node (or fail) withBool :: String -> (Bool -> Parser a) -> Node -> Parser a withBool _ f (Scalar (SBool b)) = f b -withBool expected _ v = failTypeMismatch expected v +withBool expected _ v = typeMismatch expected v instance FromYAML Text where parseYAML = withStr "!!str" pure @@ -246,7 +294,7 @@ -- | Operate on @tag:yaml.org,2002:str@ node (or fail) withStr :: String -> (Text -> Parser a) -> Node -> Parser a withStr _ f (Scalar (SStr b)) = f b -withStr expected _ v = failTypeMismatch expected v +withStr expected _ v = typeMismatch expected v instance FromYAML Integer where parseYAML = withInt "!!int" pure @@ -254,59 +302,40 @@ -- | Operate on @tag:yaml.org,2002:int@ node (or fail) withInt :: String -> (Integer -> Parser a) -> Node -> Parser a withInt _ f (Scalar (SInt b)) = f b -withInt expected _ v = failTypeMismatch expected v +withInt expected _ v = typeMismatch expected v +-- | @since 0.1.0.0 +instance FromYAML Natural where + parseYAML = withInt "!!int" $ \b -> if b < 0 then fail ("!!int " ++ show b ++ " out of range for 'Natural'") + else pure (fromInteger b) + +-- helper for fixed-width integers +{-# INLINE parseInt #-} +parseInt :: (Integral a, Bounded a) => [Char] -> Node -> Parser a +parseInt name = withInt "!!int" $ \b -> maybe (fail $ "!!int " ++ show b ++ " out of range for '" ++ name ++ "'") pure $ + fromIntegerMaybe b + +instance FromYAML Int where parseYAML = parseInt "Int" +instance FromYAML Int8 where parseYAML = parseInt "Int8" +instance FromYAML Int16 where parseYAML = parseInt "Int16" +instance FromYAML Int32 where parseYAML = parseInt "Int32" +instance FromYAML Int64 where parseYAML = parseInt "Int64" +instance FromYAML Word where parseYAML = parseInt "Word" +instance FromYAML Word8 where parseYAML = parseInt "Word8" +instance FromYAML Word16 where parseYAML = parseInt "Word16" +instance FromYAML Word32 where parseYAML = parseInt "Word32" +instance FromYAML Word64 where parseYAML = parseInt "Word64" + + instance FromYAML Double where parseYAML = withFloat "!!float" pure -- | Operate on @tag:yaml.org,2002:float@ node (or fail) withFloat :: String -> (Double -> Parser a) -> Node -> Parser a withFloat _ f (Scalar (SFloat b)) = f b -withFloat expected _ v = failTypeMismatch expected v - --- signed fixed-width integers - -instance FromYAML Int where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Int8 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int8'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Int16 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int16'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Int32 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int32'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Int64 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Int64'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n +withFloat expected _ v = typeMismatch expected v -instance FromYAML Word where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Word8 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word8'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Word16 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word16'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Word32 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word32'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - -instance FromYAML Word64 where - parseYAML (Scalar (SInt b)) = maybe (fail $ "!!int " ++ show b ++ " out of range for 'Word64'") pure $ fromIntegerMaybe b - parseYAML n = failTypeMismatch "!!int" n - instance (Ord k, FromYAML k, FromYAML v) => FromYAML (Map k v) where parseYAML = withMap "!!map" $ \xs -> Map.fromList <$> mapM (\(a,b) -> (,) <$> parseYAML a <*> parseYAML b) (Map.toList xs) @@ -314,7 +343,7 @@ withMap :: String -> (Mapping -> Parser a) -> Node -> Parser a withMap _ f (Mapping tag xs) | tag == tagMap = f xs -withMap expected _ v = failTypeMismatch expected v +withMap expected _ v = typeMismatch expected v instance FromYAML v => FromYAML [v] where parseYAML = withSeq "!!seq" (mapM parseYAML) @@ -323,7 +352,7 @@ withSeq :: String -> ([Node] -> Parser a) -> Node -> Parser a withSeq _ f (Sequence tag xs) | tag == tagSeq = f xs -withSeq expected _ v = failTypeMismatch expected v +withSeq expected _ v = typeMismatch expected v instance FromYAML a => FromYAML (Maybe a) where parseYAML (Scalar SNull) = pure Nothing @@ -414,3 +443,8 @@ decode :: FromYAML v => BS.L.ByteString -> Either String [v] decode bs0 = decodeNode bs0 >>= mapM (parseEither . parseYAML . (\(Doc x) -> x)) +-- | Like 'decode' but takes a strict 'BS.ByteString' +-- +-- @since 0.1.1.0 +decodeStrict :: FromYAML v => BS.ByteString -> Either String [v] +decodeStrict = decode . BS.L.fromChunks . (:[]) diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -21,6 +21,7 @@ import Control.Monad as X import Data.Int as X import Data.Word as X +import Numeric.Natural as X (Natural) import Control.Monad.Except import Control.Monad.Identity as X