diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017-2020, Haskell Z Team +Copyright (c) 2017-2020, Dong Han All rights reserved. diff --git a/Z-YAML.cabal b/Z-YAML.cabal --- a/Z-YAML.cabal +++ b/Z-YAML.cabal @@ -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 diff --git a/Z/Data/YAML.hs b/Z/Data/YAML.hs --- a/Z/Data/YAML.hs +++ b/Z/Data/YAML.hs @@ -7,7 +7,7 @@ Stability : experimental Portability : non-portable -Simple YAML codec using and JSON's 'FromValue' \/ 'ToValue' utilities. +Simple YAML codec using 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 diff --git a/Z/Data/YAML/FFI.hsc b/Z/Data/YAML/FFI.hsc --- a/Z/Data/YAML/FFI.hsc +++ b/Z/Data/YAML/FFI.hsc @@ -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