diff --git a/Z-YAML.cabal b/Z-YAML.cabal --- a/Z-YAML.cabal +++ b/Z-YAML.cabal @@ -1,87 +1,87 @@ -cabal-version: >=1.10 -name: Z-YAML -version: 0.3.0.0 -synopsis: YAML tools -description: YAML reading & writing tools for Z project. -license: BSD3 -license-file: LICENSE -author: Dong Han -maintainer: winterland1989@gmail.com -copyright: (c) Dong Han, 2020 -category: Data -build-type: Simple -homepage: https://github.com/haskell-Z/z-yaml -bug-reports: https://github.com/haskell-Z/z-yaml/issues +cabal-version: 2.2 +name: Z-YAML +version: 0.3.2.0 +synopsis: YAML tools +description: YAML reading & writing tools for Z project. +license: BSD-3-Clause +license-file: LICENSE +copyright: (c) Dong Han, 2020 +author: Dong Han +maintainer: winterland1989@gmail.com +category: Data +homepage: https://github.com/ZHaskell/z-yaml +bug-reports: https://github.com/ZHaskell/z-yaml/issues +build-type: Simple +extra-source-files: CHANGELOG.md + third_party/libyaml/src/yaml_private.h + third_party/libyaml/include/yaml.h + test/datas/smoke.yaml -extra-source-files: CHANGELOG.md - third_party/libyaml/src/yaml_private.h - third_party/libyaml/include/yaml.h +source-repository head + type: git + location: git://github.com/ZHaskell/z-yaml.git library - exposed-modules: Z.Data.YAML - Z.Data.YAML.FFI - - -- other-modules: - -- other-extensions: - build-depends: base == 4.* - , unordered-containers == 0.2.* - , scientific == 0.3.* - , transformers == 0.5.* - , primitive >= 0.5 && < 0.8 - , Z-Data == 0.4.* - , Z-IO == 0.4.* - - - include-dirs: third_party/libyaml/src - third_party/libyaml/include - - c-sources: cbits/hs_yaml.c - third_party/libyaml/src/api.c - third_party/libyaml/src/dumper.c - third_party/libyaml/src/emitter.c - third_party/libyaml/src/loader.c - third_party/libyaml/src/parser.c - third_party/libyaml/src/reader.c - third_party/libyaml/src/scanner.c - third_party/libyaml/src/writer.c + exposed-modules: Z.Data.YAML + Z.Data.YAML.FFI + build-depends: base == 4.* + , Z-Data >= 0.5 && < 1 + , Z-IO >= 0.5 && < 1 + , primitive >= 0.5 && < 0.8 + , scientific == 0.3.* + , transformers == 0.5.* + , unordered-containers == 0.2.* + default-language: Haskell2010 + default-extensions: MultiParamTypeClasses + RankNTypes + ExistentialQuantification + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + CPP + KindSignatures + BangPatterns + TemplateHaskell + GeneralizedNewtypeDeriving + MagicHash + TypeFamilies + StandaloneDeriving + UnliftedFFITypes + CApiFFI + TypeOperators + RecordWildCards + OverloadedStrings + UnboxedTuples + DeriveGeneric + DefaultSignatures + QuasiQuotes + ViewPatterns + TupleSections + MultiWayIf + ConstraintKinds + PolyKinds + DataKinds + BinaryLiterals + PatternSynonyms + PartialTypeSignatures + DeriveAnyClass + TypeApplications + TypeFamilyDependencies + DerivingStrategies + QuantifiedConstraints + cc-options: -DYAML_VERSION_STRING="0.2.5" -DYAML_VERSION_MAJOR=0 + -DYAML_VERSION_MINOR=2 -DYAML_VERSION_PATCH=5 + c-sources: cbits/hs_yaml.c, third_party/libyaml/src/api.c, + third_party/libyaml/src/dumper.c, third_party/libyaml/src/emitter.c, + third_party/libyaml/src/loader.c, third_party/libyaml/src/parser.c, + third_party/libyaml/src/reader.c, third_party/libyaml/src/scanner.c, + third_party/libyaml/src/writer.c + include-dirs: third_party/libyaml/src, third_party/libyaml/include - cc-options: -DYAML_VERSION_STRING="0.2.5" -DYAML_VERSION_MAJOR=0 -DYAML_VERSION_MINOR=2 -DYAML_VERSION_PATCH=5 - -- hs-source-dirs: - default-language: Haskell2010 - default-extensions: BangPatterns - BinaryLiterals - CApiFFI - ConstraintKinds - CPP - DerivingStrategies - DeriveGeneric - DeriveAnyClass - DefaultSignatures - DataKinds - ExistentialQuantification - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - KindSignatures - MagicHash - MultiParamTypeClasses - MultiWayIf - PartialTypeSignatures - PatternSynonyms - PolyKinds - QuantifiedConstraints - QuasiQuotes - OverloadedStrings - RankNTypes - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TemplateHaskell - TypeApplications - TypeFamilyDependencies - TypeFamilies - TypeOperators - TupleSections - UnboxedTuples - UnliftedFFITypes - ViewPatterns +test-suite Z-YAML-Test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + build-depends: base, Z-Data, Z-YAML, hspec ^>= 2.7 + default-language: Haskell2010 + ghc-options: -threaded diff --git a/Z/Data/YAML.hs b/Z/Data/YAML.hs --- a/Z/Data/YAML.hs +++ b/Z/Data/YAML.hs @@ -83,7 +83,7 @@ -- | 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 +readYAMLFile p = unwrap "EPARSE" =<< withResource (initFileParser p) (\ src -> do r <- try (parseSingleDoucment src) case r of Left (e :: YAMLError) -> return (Left (Left e)) 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 @@ -34,23 +34,23 @@ , renderUriTags -- * Constants , ScalarStyle - , pattern Any - , pattern Plain - , pattern SingleQuoted - , pattern DoubleQuoted - , pattern Literal - , pattern Folded - , pattern PlainNoTag + , pattern Any + , pattern Plain + , pattern SingleQuoted + , pattern DoubleQuoted + , pattern Literal + , pattern Folded + , pattern PlainNoTag , SequenceStyle - , pattern AnySequence + , pattern AnySequence , pattern BlockSequence - , pattern FlowSequence + , pattern FlowSequence , MappingStyle , pattern AnyMapping , pattern BlockMapping - , pattern FlowMapping + , pattern FlowMapping , TagRender - , pattern Explicit + , pattern Explicit , pattern Implicit -- * Exception type , YAMLError(..) @@ -76,7 +76,7 @@ import qualified Z.IO.FileSystem as FS import qualified Z.Data.Vector as V import qualified Z.Data.Text.Base as T -import Z.Data.Text.Print (Print) +import qualified Z.Data.Text as T import Z.Data.JSON (JSON) #include "yaml.h" @@ -84,61 +84,61 @@ type Anchor = T.Text data Event = - EventStreamStart - | EventStreamEnd - | EventDocumentStart - | EventDocumentEnd + EventStreamStart + | EventStreamEnd + | EventDocumentStart + | EventDocumentEnd | EventAlias !Anchor - | EventScalar !Anchor !T.Text !Tag !ScalarStyle - | EventSequenceStart !Anchor !Tag !SequenceStyle - | EventSequenceEnd - | EventMappingStart !Anchor !Tag !MappingStyle - | EventMappingEnd + | EventScalar !Anchor !T.Text !Tag !ScalarStyle + | EventSequenceStart !Anchor !Tag !SequenceStyle + | EventSequenceEnd + | EventMappingStart !Anchor !Tag !MappingStyle + | EventMappingEnd deriving (Show, Ord, Eq, Generic) - deriving anyclass (Print, JSON) + deriving anyclass (T.Print, JSON) -data MarkedEvent = MarkedEvent +data MarkedEvent = MarkedEvent { markedEvent :: !Event , startMark :: !Mark , endMark :: !Mark } deriving (Show, Ord, Eq, Generic) - deriving anyclass (Print, JSON) + deriving anyclass (T.Print, JSON) -- | The pointer position -data Mark = Mark +data Mark = Mark { yamlIndex :: {-# UNPACK #-} !Int , yamlLine :: {-# UNPACK #-} !Int - , yamlColumn :: {-# UNPACK #-} !Int + , yamlColumn :: {-# UNPACK #-} !Int } deriving (Show, Ord, Eq, Generic) - deriving anyclass (Print, JSON) + deriving anyclass (T.Print, JSON) -- | Style for scalars - e.g. quoted / folded --- +-- type ScalarStyle = CInt pattern Any, Plain, SingleQuoted, DoubleQuoted, Literal, Folded, PlainNoTag :: ScalarStyle pattern Any = 0 -pattern Plain = 1 -pattern SingleQuoted = 2 -pattern DoubleQuoted = 3 -pattern Literal = 4 -pattern Folded = 5 -pattern PlainNoTag = 6 +pattern Plain = 1 +pattern SingleQuoted = 2 +pattern DoubleQuoted = 3 +pattern Literal = 4 +pattern Folded = 5 +pattern PlainNoTag = 6 -- | Style for sequences - e.g. block or flow --- +-- type SequenceStyle = CInt pattern AnySequence, BlockSequence, FlowSequence :: SequenceStyle pattern AnySequence = 0 -pattern BlockSequence = 1 +pattern BlockSequence = 1 pattern FlowSequence = 2 -- | Style for mappings - e.g. block or flow --- -type MappingStyle = CInt +-- +type MappingStyle = CInt pattern AnyMapping, BlockMapping, FlowMapping :: MappingStyle -pattern AnyMapping = 0 +pattern AnyMapping = 0 pattern BlockMapping = 1 pattern FlowMapping = 2 @@ -153,7 +153,7 @@ | UriTag T.Text | NoTag deriving (Show, Ord, Eq, Generic) - deriving anyclass (Print, JSON) + deriving anyclass (T.Print, JSON) tagToCBytes :: Tag -> CB.CBytes tagToCBytes StrTag = "tag:yaml.org,2002:str" @@ -181,24 +181,31 @@ data YAMLError = ParseEventException CB.CBytes CB.CBytes Mark -- ^ problem, context, mark - | ParseAliasEventWithEmptyAnchor Mark Mark + | ParseAliasEventWithEmptyAnchor Mark Mark | ParseYAMLError YAMLParseError -- ^ custom parse error - | EmitEventException Event CInt - | EmitAliasEventWithEmptyAnchor + | EmitEventException Event CInt + | EmitAliasEventWithEmptyAnchor | OtherYAMLError T.Text - deriving Show + deriving (Eq, Generic) + deriving anyclass T.Print +instance Show YAMLError where show = T.toString + data YAMLParseError = UnknownAlias MarkedEvent | UnexpectedEvent MarkedEvent | NonStringKey MarkedEvent | NonStringKeyAlias MarkedEvent | UnexpectedEventEnd - deriving Show + deriving (Eq, Generic) + deriving anyclass T.Print +instance Show YAMLParseError where show = T.toString + instance Exception YAMLError instance Exception YAMLParseError + -- | Throw custom YAML error. throwYAMLError :: YAMLParseError -> IO a throwYAMLError desc = throwIO (ParseYAMLError desc) @@ -216,10 +223,10 @@ -- | Create a source that yields marked events from a piece of YAML bytes. -- initParser :: V.Bytes -> Resource (Source MarkedEvent) -initParser bs +initParser bs | V.null bs = return BIO{ pull = return Nothing } | otherwise = do - (pparser, bs', bio) <- initResource + (pparser, bs', bio) <- initResource (do pparser <- throwOOMIfNull hs_init_yaml_parser bs' <- pinPrimVector bs withPrimVectorSafe bs' $ \ bptr blen -> do @@ -234,9 +241,9 @@ -- initFileParser :: HasCallStack => CB.CBytes -> Resource (Source MarkedEvent) initFileParser p = do - (pparser, file, bio) <- initResource + (pparser, file, bio) <- initResource (do pparser <- throwOOMIfNull hs_init_yaml_parser - (f, _) <- acquire $ FS.initFile p FS.O_RDONLY FS.DEFAULT_MODE + (f, _) <- acquire $ FS.initFile p FS.O_RDONLY FS.DEFAULT_FILE_MODE fd <- FS.getFileFD f file <- CB.withCBytesUnsafe "r" (fdopen fd) yaml_parser_set_input_file pparser file @@ -266,8 +273,8 @@ where readAnchor :: Int -> MBA## EventStruct -> IO Anchor readAnchor off pe = do - p <- peekMBA pe off - if p == nullPtr + p <- peekMBA pe off + if p == nullPtr then return T.empty else T.Text <$> fromNullTerminated p @@ -276,8 +283,8 @@ readTag :: Int -> MBA## EventStruct -> IO Tag readTag off pe = do - p <- peekMBA pe off - if p == nullPtr + p <- peekMBA pe off + if p == nullPtr then return NoTag else bytesToTag <$!> fromNullTerminated p @@ -285,12 +292,12 @@ peekEvent pe = do et <- peekMBA pe (#offset yaml_event_t, type) - si :: CUInt <- peekMBA pe (#offset yaml_event_t, start_mark.index) - sl :: CUInt <- peekMBA pe (#offset yaml_event_t, start_mark.line) - sc :: CUInt <- peekMBA pe (#offset yaml_event_t, start_mark.column) - ei :: CUInt <- peekMBA pe (#offset yaml_event_t, end_mark.index) - el :: CUInt <- peekMBA pe (#offset yaml_event_t, end_mark.line) - ec :: CUInt <- peekMBA pe (#offset yaml_event_t, end_mark.column) + si :: CUInt <- peekMBA pe (#offset yaml_event_t, start_mark.index) + sl :: CUInt <- peekMBA pe (#offset yaml_event_t, start_mark.line) + sc :: CUInt <- peekMBA pe (#offset yaml_event_t, start_mark.column) + ei :: CUInt <- peekMBA pe (#offset yaml_event_t, end_mark.index) + el :: CUInt <- peekMBA pe (#offset yaml_event_t, end_mark.line) + ec :: CUInt <- peekMBA pe (#offset yaml_event_t, end_mark.column) let startMark = Mark (fromIntegral si) (fromIntegral sl) (fromIntegral sc) endMark = Mark (fromIntegral ei) (fromIntegral el) (fromIntegral ec) returnMarked e = return (Just (MarkedEvent e startMark endMark)) @@ -401,9 +408,9 @@ -- | Make a new YAML event sink, whose result can be fetched via 'getEmitterResult'. -- -initEmitter :: YAMLFormatOpts -> Resource (Ptr EmitterStruct, Sink Event) +initEmitter :: YAMLFormatOpts -> Resource (Ptr EmitterStruct, Sink Event) initEmitter fopts@YAMLFormatOpts{..} = do - p <- initResource + p <- initResource (do let canonical = if yamlFormatCanonical then 1 else 0 throwOOMIfNull (hs_init_yaml_emitter canonical (fromIntegral yamlFormatIndent) (fromIntegral yamlFormatWidth))) @@ -417,10 +424,10 @@ -- -- Note the file will be opened in @'FS.O_APPEND' .|. 'FS.O_CREAT' .|. 'FS.O_WRONLY'@ mode, -- bytes will be written after the end of the original file if there'are old bytes. -initFileEmitter :: HasCallStack => YAMLFormatOpts -> CB.CBytes -> Resource (Sink Event) +initFileEmitter :: HasCallStack => YAMLFormatOpts -> CB.CBytes -> Resource (Sink Event) initFileEmitter fopts@YAMLFormatOpts{..} p = do (pemitter, file) <- initResource - (do (f, _) <- acquire $ FS.initFile p (FS.O_APPEND .|. FS.O_CREAT .|. FS.O_WRONLY) FS.DEFAULT_MODE + (do (f, _) <- acquire $ FS.initFile p (FS.O_APPEND .|. FS.O_CREAT .|. FS.O_WRONLY) FS.DEFAULT_FILE_MODE fd <- FS.getFileFD f file <- CB.withCBytesUnsafe "w" (fdopen fd) let canonical = if yamlFormatCanonical then 1 else 0 @@ -437,7 +444,7 @@ -- | Fetch YAML emitter's building buffer. -- -getEmitterResult :: Ptr EmitterStruct -> IO T.Text +getEmitterResult :: Ptr EmitterStruct -> IO T.Text getEmitterResult pemitter = do l <- hs_get_yaml_emitter_length pemitter (bs,_) <- allocBytesUnsafe (fromIntegral l) $ \ p -> hs_copy_yaml_emitter_result pemitter p l @@ -452,9 +459,9 @@ EventStreamEnd -> yaml_stream_end_event_initialize pe EventDocumentStart -> hs_yaml_document_start pe EventDocumentEnd -> yaml_document_end_event_initialize pe 1 - EventScalar anchor t tag style0 -> - withPrimVectorUnsafe (T.getUTF8Bytes t) $ \ pvalue off len -> - withAnchor anchor $ \ panchor -> + EventScalar anchor t tag style0 -> + withPrimVectorUnsafe (T.getUTF8Bytes t) $ \ pvalue off len -> + withAnchor anchor $ \ panchor -> withTag tag $ \ ptag -> do let pi0 = tagsImplicit e (pi, style) = case style0 of @@ -472,7 +479,7 @@ style -- style EventSequenceStart anchor tag style -> - withAnchor anchor $ \ panchor -> + withAnchor anchor $ \ panchor -> withTag tag $ \ ptag -> hs_yaml_sequence_start_event_initialize pe @@ -485,7 +492,7 @@ EventMappingStart anchor tag style -> withAnchor anchor $ \ panchor -> - withTag tag $ \ ptag -> + withTag tag $ \ ptag -> hs_yaml_mapping_start_event_initialize pe panchor ptag (tagsImplicit e) style EventMappingEnd -> yaml_mapping_end_event_initialize pe @@ -495,7 +502,7 @@ then throwIO EmitAliasEventWithEmptyAnchor else withAnchor anchor (yaml_alias_event_initialize pe) - if (ret /= 1) + if (ret /= 1) then throwIO (EmitEventException e ret) else do ret' <- yaml_emitter_emit pemitter pe @@ -511,7 +518,7 @@ tagSuppressed _ = False withTag tag = CB.withCBytesUnsafe (tagToCBytes tag) - withAnchor anchor = CB.withCBytesUnsafe (CB.fromText anchor) + withAnchor anchor = CB.withCBytesUnsafe (CB.fromText anchor) -- | Whether a tag should be rendered explicitly in the output or left -- implicit. diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import GHC.Generics (Generic) +import Test.Hspec +import qualified Z.Data.Text as T +import qualified Z.Data.YAML as YAML + + +main :: IO () +main = hspec $ smokeSpec + +data Person = Person + { name :: T.Text + , age :: Int + } deriving (Show, Generic, YAML.JSON) + +smokeSpec :: Spec +smokeSpec = context "SmokeTest" $ do + it "Z.Data.YAML.readYAMLFile" $ do + persons <- YAML.readYAMLFile @[Person] "test/datas/smoke.yaml" + let first = persons !! 0 + name first `shouldBe` "Alice" + age first `shouldBe` 16 + let second = persons !! 1 + name second `shouldBe` "Bob" + age second `shouldBe` 14 diff --git a/test/datas/smoke.yaml b/test/datas/smoke.yaml new file mode 100644 --- /dev/null +++ b/test/datas/smoke.yaml @@ -0,0 +1,4 @@ +- name: Alice + age: 16 +- name: Bob + age: 14