Z-YAML 0.2.0.0 → 0.3.0.0

raw patch · 4 files changed

+97/−107 lines, 4 filesdep ~Z-Datadep ~Z-IOdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Z-Data, Z-IO, base

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Z-YAML.cabal +4/−4
• Z/Data/YAML.hs +53/−80
• Z/Data/YAML/FFI.hsc +39/−22

@@ -1,4 +1,4 @@-Copyright (c) 2017-2020, Haskell Z Team+Copyright (c) 2017-2020, Dong Han  All rights reserved. 

@@ -1,6 +1,6 @@ cabal-version:              >=1.10 name:                       Z-YAML-version:                    0.2.0.0+version:                    0.3.0.0 synopsis:                   YAML tools description:                YAML reading & writing tools for Z project. license:                    BSD3@@ -23,13 +23,13 @@      -- other-modules:     -- other-extensions:-    build-depends:            base >=4.14 && <4.15+    build-depends:            base                  == 4.*                             , unordered-containers  == 0.2.*                             , scientific            == 0.3.*                             , transformers          == 0.5.*                             , primitive             >= 0.5 && < 0.8-                            , Z-Data == 0.3.*-                            , Z-IO == 0.3.*+                            , Z-Data                == 0.4.*+                            , Z-IO                  == 0.4.*       include-dirs:           third_party/libyaml/src

@@ -7,7 +7,7 @@ Stability   : experimental Portability : non-portable -Simple YAML codec using <https://libyaml.docsforge.com/ libYAML> and JSON's 'FromValue' \/ 'ToValue' utilities.+Simple YAML codec using <https://libyaml.docsforge.com/ libYAML> and JSON's 'JSON' utilities. The design choice to make things as simple as possible since YAML is a complex format, there're some limitations using this approach:  * Does not support complex keys.@@ -26,7 +26,7 @@     , magic :: Bool     }   deriving (Show, Generic)-  deriving anyclass (YAML.FromValue, YAML.ToValue)+  deriving anyclass (YAML.JSON)  > YAML.decode @[Person] "- name: Erik Weisz\\n  age: 52\\n  magic: True\\n" > Right [Person {name = "Erik Weisz", age = 52, magic = True}]@@ -37,120 +37,93 @@  module Z.Data.YAML   ( -- * Decode and encode using YAML-    decodeFromFile-  , decodeValueFromFile-  , decode-  , decodeValue-  , encodeToFile-  , encodeValueToFile+    decode   , encode-  , encodeValue-  , YAMLParseException(..)-  , YAMLParseError(..)+  , readYAMLFile+  , writeYAMLFile   -- * Streaming parser and builder   , parseSingleDoucment   , parseAllDocuments   , buildSingleDocument   , buildValue+  -- * Errors+  , YAMLError(..)+  , YAMLParseError(..)+  , ConvertError(..)+  , DecodeError   -- * Re-Exports-  , FromValue(..)-  , ToValue(..)+  , JSON(..)   , Value(..)   ) where  import           Control.Applicative import           Control.Monad import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader import           Data.Bits              ((.|.), unsafeShiftL) import           Data.IORef-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet        as HS-import qualified Data.Scientific as Sci+import qualified Data.HashMap.Strict    as HM+import qualified Data.HashSet           as HS+import qualified Data.Scientific        as Sci+import           GHC.Generics           (Generic)+import           System.IO.Unsafe import           Z.Data.ASCII-import qualified Z.Data.Parser as P-import qualified Z.Data.Vector as V-import qualified Z.Data.Text   as T-import           Z.Data.JSON            (FromValue(..), ToValue(..), Value(..), ConvertError, convert')+import qualified Z.Data.Parser          as P+import qualified Z.Data.Vector          as V+import qualified Z.Data.Text            as T+import           Z.Data.JSON            (JSON(..), Value(..), ConvertError, convertValue) import           Z.Data.YAML.FFI-import           Control.Monad.Trans.Reader-import qualified Z.Data.Vector.FlatMap as FM-import qualified Z.Data.Builder as B+import qualified Z.Data.Vector.FlatMap  as FM+import qualified Z.Data.Builder         as B import           Z.Data.CBytes          (CBytes) import           Z.Data.YAML.FFI import           Z.IO --- | Decode a 'FromValue' instance from file.-decodeFromFile :: (HasCallStack, FromValue a) => CBytes -> IO a-decodeFromFile p = withResource (initFileParser p) $ \ src -> do-    r <- convert' <$> parseSingleDoucment src-    case r of Left e -> throwIO (YAMLConvertException e callStack)-              Right v -> return v---- | Decode a 'Value' from file.-decodeValueFromFile :: HasCallStack => CBytes -> IO Value-decodeValueFromFile p = withResource (initFileParser p) parseSingleDoucment+type DecodeError = Either YAMLError ConvertError --- | Decode a 'FromValue' instance from bytes.-decode :: HasCallStack => FromValue a => V.Bytes -> IO a-decode bs = withResource (initParser bs) $ \ src -> do-    r <- convert' <$> parseSingleDoucment src-    case r of Left e -> throwIO (YAMLConvertException e callStack)-              Right v -> return v+-- | Decode a 'JSON' instance from a YAML file.+readYAMLFile :: forall a. (HasCallStack, JSON a) => CBytes -> IO a+readYAMLFile p = unwrap =<< withResource (initFileParser p) (\ src -> do+    r <- try (parseSingleDoucment src)+    case r of+        Left (e :: YAMLError) -> return (Left (Left e))+        Right r' -> case (convertValue r' :: Either ConvertError a) of+            Left e' -> return (Left (Right e'))+            Right v -> return (Right v)) --- | Decode a 'Value' from bytes.-decodeValue :: HasCallStack => V.Bytes -> IO Value-decodeValue bs = withResource (initParser bs) parseSingleDoucment+-- | Decode a 'JSON' instance from YAML bytes.+decode :: forall a .(HasCallStack, JSON a) => V.Bytes -> Either DecodeError a+decode bs = unsafePerformIO . withResource (initParser bs) $ \ src -> do+    r <- try (parseSingleDoucment src)+    case r of+        Left e -> return (Left (Left e))+        Right r' -> case (convertValue r' :: Either ConvertError a) of+            Left e' -> return (Left (Right e'))+            Right v -> return (Right v) --- | Encode a 'ToValue' instance to file.-encodeToFile :: (HasCallStack, ToValue a) => YAMLFormatOpts -> CBytes -> a -> IO ()-encodeToFile opts p x = withResource (initFileEmitter opts p) $ \ sink ->+-- | Encode a 'JSON' instance to YAML file.+writeYAMLFile :: (HasCallStack, JSON a) => YAMLFormatOpts -> CBytes -> a -> IO ()+writeYAMLFile opts p x = withResource (initFileEmitter opts p) $ \ sink ->     buildSingleDocument sink (toValue x) --- | Encode a 'Value' to file.-encodeValueToFile :: HasCallStack => YAMLFormatOpts -> CBytes -> Value -> IO ()-encodeValueToFile opts p v = withResource (initFileEmitter opts p) $ \ sink ->-    buildSingleDocument sink v---- | Encode a 'ToValue' instance as UTF8 text.-encode :: (HasCallStack, ToValue a) => YAMLFormatOpts -> a -> IO T.Text-encode opts x = withResource (initEmitter opts) $ \ (p, sink) -> do+-- | Encode a 'JSON' instance as UTF8 YAML text.+encode :: (HasCallStack, JSON a) => YAMLFormatOpts -> a -> T.Text+encode opts x = unsafePerformIO . withResource (initEmitter opts) $ \ (p, sink) -> do     buildSingleDocument sink (toValue x)     getEmitterResult p --- | Encode a 'Value' as UTF8 text.-encodeValue :: HasCallStack => YAMLFormatOpts -> Value -> IO T.Text-encodeValue opts v = withResource (initEmitter opts) $ \ (p, sink) -> do-    buildSingleDocument sink v-    getEmitterResult p- -------------------------------------------------------------------------------- -data YAMLParseError-    = UnknownAlias MarkedEvent-    | UnexpectedEvent MarkedEvent-    | NonStringKey MarkedEvent-    | NonStringKeyAlias MarkedEvent-    | UnexpectedEventEnd-  deriving (Show, Eq)--instance Exception YAMLParseError--data YAMLParseException-    = YAMLParseException YAMLParseError CallStack-    | YAMLConvertException ConvertError CallStack-    | MultipleDocuments CallStack-  deriving Show--instance Exception YAMLParseException-+-- | Parse a single YAML document, throw 'OtherYAMLError' if multiple documents are met. parseSingleDoucment :: HasCallStack => Source MarkedEvent -> IO Value parseSingleDoucment src = do     docs <- parseAllDocuments src     case docs of         [] -> return Null         [doc] -> return doc-        _ -> throwIO (MultipleDocuments callStack)+        _ -> throwIO (OtherYAMLError "multiple YAML documents") +-- | Parse all YAML documents. parseAllDocuments :: HasCallStack => Source MarkedEvent -> IO [Value] parseAllDocuments src = do     me <- pull src@@ -158,8 +131,8 @@         Just (MarkedEvent EventStreamStart _ _) -> do             as <- newIORef HM.empty             catch (runReaderT parseDocs (src, as)) $ \ (e :: YAMLParseError) ->-                throwIO (YAMLParseException e callStack)-        Just me' -> throwIO (YAMLParseException (UnexpectedEvent me') callStack)+                throwYAMLError e+        Just me' -> throwYAMLError (UnexpectedEvent me')         -- empty file input, comment only string/file input         _ -> return []   where

@@ -53,7 +53,9 @@     , pattern Explicit      , pattern Implicit     -- * Exception type-    , LibYAMLException (..)+    , YAMLError(..)+    , YAMLParseError(..)+    , throwYAMLError     ) where  import Control.Applicative@@ -75,7 +77,7 @@ import qualified Z.Data.Vector      as V import qualified Z.Data.Text.Base   as T import           Z.Data.Text.Print  (Print)-import           Z.Data.JSON        (EncodeJSON, FromValue, ToValue)+import           Z.Data.JSON        (JSON)  #include "yaml.h" @@ -93,7 +95,7 @@     | EventMappingStart   !Anchor !Tag !MappingStyle      | EventMappingEnd         deriving (Show, Ord, Eq, Generic)-    deriving anyclass (Print, EncodeJSON, FromValue, ToValue)+    deriving anyclass (Print, JSON)  data MarkedEvent = MarkedEvent      { markedEvent :: !Event@@ -101,7 +103,7 @@     , endMark :: !Mark     }     deriving (Show, Ord, Eq, Generic)-    deriving anyclass (Print, EncodeJSON, FromValue, ToValue)+    deriving anyclass (Print, JSON)  -- | The pointer position data Mark = Mark @@ -110,7 +112,7 @@     , yamlColumn :: {-# UNPACK #-} !Int      }     deriving (Show, Ord, Eq, Generic)-    deriving anyclass (Print, EncodeJSON, FromValue, ToValue)+    deriving anyclass (Print, JSON)  -- | Style for scalars - e.g. quoted / folded -- @@ -151,7 +153,7 @@          | UriTag T.Text          | NoTag     deriving (Show, Ord, Eq, Generic)-    deriving anyclass (Print, EncodeJSON, FromValue, ToValue)+    deriving anyclass (Print, JSON)  tagToCBytes :: Tag -> CB.CBytes tagToCBytes StrTag = "tag:yaml.org,2002:str"@@ -177,15 +179,30 @@ bytesToTag "" = NoTag bytesToTag s = UriTag (T.validate s) -data LibYAMLException-    = ParseEventException CB.CBytes CB.CBytes Mark CallStack  -- ^ problem, context, mark-    | ParseAliasEventWithEmptyAnchor Mark Mark CallStack-    | EmitEventException Event CInt CallStack-    | EmitAliasEventWithEmptyAnchor CallStack+data YAMLError+    = ParseEventException CB.CBytes CB.CBytes Mark     -- ^ problem, context, mark+    | ParseAliasEventWithEmptyAnchor Mark Mark +    | ParseYAMLError YAMLParseError                    -- ^ custom parse error+    | EmitEventException Event CInt +    | EmitAliasEventWithEmptyAnchor +    | OtherYAMLError T.Text     deriving Show -instance Exception LibYAMLException+data YAMLParseError+    = UnknownAlias MarkedEvent+    | UnexpectedEvent MarkedEvent+    | NonStringKey MarkedEvent+    | NonStringKeyAlias MarkedEvent+    | UnexpectedEventEnd+  deriving Show +instance Exception YAMLError+instance Exception YAMLParseError++-- | Throw custom YAML error.+throwYAMLError :: YAMLParseError -> IO a+throwYAMLError desc = throwIO (ParseYAMLError desc)+ data ParserStruct foreign import ccall unsafe "hs_yaml.c hs_init_yaml_parser" hs_init_yaml_parser :: IO (Ptr ParserStruct) foreign import ccall unsafe "hs_yaml.c hs_free_yaml_parser" hs_free_yaml_parser :: Ptr ParserStruct -> IO ()@@ -198,7 +215,7 @@  -- | Create a source that yields marked events from a piece of YAML bytes. ---initParser :: HasCallStack => V.Bytes -> Resource (Source MarkedEvent)+initParser :: V.Bytes -> Resource (Source MarkedEvent) initParser bs      | V.null bs = return BIO{ pull = return Nothing }     | otherwise = do@@ -230,7 +247,7 @@     return bio  -- | Parse a single event from YAML parser.-peekParserEvent :: HasCallStack => Ptr ParserStruct -> IO (Maybe MarkedEvent)+peekParserEvent :: Ptr ParserStruct -> IO (Maybe MarkedEvent) peekParserEvent parser = do     (_, me) <- allocBytesUnsafe (#size yaml_event_t) $ \ pe -> do         res <- yaml_parser_parse parser pe@@ -243,7 +260,7 @@                 l :: CUInt <- (#peek yaml_parser_t, problem_mark.line) parser                 c :: CUInt <- (#peek yaml_parser_t, problem_mark.column) parser                 let problemMark = Mark (fromIntegral i) (fromIntegral l) (fromIntegral c)-                throwIO (ParseEventException problem context problemMark callStack)+                throwIO (ParseEventException problem context problemMark)             else peekEvent pe     return me   where@@ -264,7 +281,7 @@         then return NoTag         else bytesToTag <$!> fromNullTerminated p -    peekEvent :: HasCallStack => MBA## EventStruct -> IO (Maybe MarkedEvent)+    peekEvent :: MBA## EventStruct -> IO (Maybe MarkedEvent)     peekEvent pe = do         et <- peekMBA pe (#offset yaml_event_t, type) @@ -286,7 +303,7 @@             (#const YAML_ALIAS_EVENT) -> do                 yanchor <- peekMBA pe (#offset yaml_event_t, data.alias.anchor)                 anchor <- if yanchor == nullPtr-                          then throwIO (ParseAliasEventWithEmptyAnchor startMark endMark callStack)+                          then throwIO (ParseAliasEventWithEmptyAnchor startMark endMark)                           else fromNullTerminated yanchor                 returnMarked (EventAlias (T.Text anchor))             (#const YAML_SCALAR_EVENT) -> do@@ -384,7 +401,7 @@  -- | Make a new YAML event sink, whose result can be fetched via 'getEmitterResult'. ---initEmitter :: HasCallStack => YAMLFormatOpts -> Resource (Ptr EmitterStruct, Sink Event) +initEmitter :: YAMLFormatOpts -> Resource (Ptr EmitterStruct, Sink Event)  initEmitter fopts@YAMLFormatOpts{..} = do     p <- initResource          (do let canonical = if yamlFormatCanonical then 1 else 0@@ -428,7 +445,7 @@  -- | Push a single YAML event to emitter. ---emitEvent :: HasCallStack => Ptr EmitterStruct -> YAMLFormatOpts -> Event -> IO ()+emitEvent :: Ptr EmitterStruct -> YAMLFormatOpts -> Event -> IO () emitEvent pemitter fopts e = void . allocBytesUnsafe (#size yaml_event_t) $ \ pe -> do     ret <- case e of         EventStreamStart   -> yaml_stream_start_event_initialize pe (#const YAML_ANY_ENCODING)@@ -475,14 +492,14 @@          EventAlias anchor ->             if T.null anchor-            then throwIO (EmitAliasEventWithEmptyAnchor callStack)+            then throwIO EmitAliasEventWithEmptyAnchor             else withAnchor anchor (yaml_alias_event_initialize pe)      if (ret /= 1) -    then throwIO (EmitEventException e ret callStack)+    then throwIO (EmitEventException e ret)     else do         ret' <- yaml_emitter_emit pemitter pe-        when (ret /= 1) (throwIO (EmitEventException e ret callStack))+        when (ret /= 1) (throwIO (EmitEventException e ret))   where     tagsImplicit (EventScalar _ _ t _) | tagSuppressed t = 1     tagsImplicit (EventMappingStart _ t _) | tagSuppressed t = 1