ron-hs (empty) → 0.4.0
raw patch · 22 files changed
+3116/−0 lines, 22 filesdep +QuickCheckdep +attoparsecdep +base
Dependencies added: QuickCheck, attoparsec, base, base16-bytestring, bytestring, containers, criterion, deepseq, directory, hashable, optics-core, optics-th, ron-hs, scientific, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, vector
Files
- LICENSE-APACHE +201/−0
- bench/Bench.hs +12/−0
- bench/Escape.hs +45/−0
- bench/File.hs +12/−0
- changelog.txt +39/−0
- ron-hs.cabal +134/−0
- src/Data/Ron.hs +76/−0
- src/Data/Ron/Class.hs +668/−0
- src/Data/Ron/Class/Deriving.hs +208/−0
- src/Data/Ron/Class/Internal.hs +20/−0
- src/Data/Ron/Deserialize.hs +530/−0
- src/Data/Ron/Serialize.hs +325/−0
- src/Data/Ron/Value.hs +203/−0
- src/Data/Ron/Value/Internal.hs +44/−0
- test/DerivingVia.hs +66/−0
- test/File.hs +39/−0
- test/ForExample.hs +114/−0
- test/Generic.hs +88/−0
- test/GenericOptions.hs +212/−0
- test/Optics/Ron/Settings.hs +10/−0
- test/Test.hs +38/−0
- test/Values.hs +32/−0
+ LICENSE-APACHE view
@@ -0,0 +1,201 @@+Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2022-2024 morj++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ bench/Bench.hs view
@@ -0,0 +1,12 @@+module Main where++import Criterion.Main (defaultMain)++import qualified File+import qualified Escape+++main = defaultMain+ [ File.benchmark+ , Escape.benchmark+ ]
+ bench/Escape.hs view
@@ -0,0 +1,45 @@+module Escape (benchmark) where++import Criterion.Main (bgroup, bench, nf, Benchmark)+import Data.Ron.Deserialize (loads)+import Data.Text.Encoding (encodeUtf16BE)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as Text++benchmark = bgroup "Escape"+ [ example "ascii" $ BS8.pack . take 500 $ cycle ['a'..'z']+ , example "cyrillic" $ BS8.unwords+ [ "Стандарт состоит из двух основных частей: универсального набора "+ , "символов (англ. Universal character set, UCS) и семейства кодировок"+ , "(англ. Unicode transformation format, UTF). Универсальный набор"+ , "символов перечисляет допустимые по стандарту Юникод символы и"+ , "присваивает каждому символу код в виде неотрицательного целого"+ , "числа, записываемого обычно в шестнадцатеричной форме с префиксом"+ , "U+, например, U+040F. Семейство кодировок определяет способы"+ , "преобразования кодов символов для передачи в потоке или в файле."+ ]+ , example "hexEscapes" $+ let chars = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['\x10000' .. '\x100ff']+ formatChar :: Char -> Builder.Builder+ formatChar c = case BS.length bs of+ 4 -> "\\u" <> Builder.byteString bs+ 8 -> "\\u" <> Builder.byteString (BS.take 4 bs) <> "\\u" <> Builder.byteString (BS.drop 4 bs)+ _ -> error "formatChar: ???"+ where+ bs = Base16.encode $ encodeUtf16BE $ Text.pack [c]++ in BSL.toStrict $ Builder.toLazyByteString $ foldMap formatChar chars+ , example "charEscapes" $+ BS.concat $ replicate 10000 $ BS8.pack "\\\""+ ]+ where+ example :: String -> BS.ByteString -> Benchmark+ example name input =+ let input' = "r##\"" <> input <> "\"##"+ in bench name $ nf loads input+
+ bench/File.hs view
@@ -0,0 +1,12 @@+module File (benchmark) where++import Criterion.Main (bgroup, bench, nfIO)+import Data.Ron.Deserialize (loadFile)++benchFile name =+ bench ("Read " <> name) $ nfIO (loadFile $ "bench/data/" <> name)++benchmark = bgroup "Load file"+ [ benchFile "canada.ron"+ , benchFile "canada.json"+ ]
+ changelog.txt view
@@ -0,0 +1,39 @@+[0.4.0]+- Rename reify to reflect, turns out I confused the two terms (breaking change!)+- Greatly improve docs+- Add explicit license++[0.3.2]+- Add more instances for base and containers+- Change String instance to resemble Text+- Overflows in numeric decoding are now errors instead of being silently+ignored+- Improved error messages with enclosing structure info (but no line info)+- Bugfixes in parsing++[0.3.1]+- Fix different behaviours for different load functions++[0.3.0]+- Rename SerializeSettins to SerializeSettings (breaking change!)+- Float parsing is more compliant: can handle inf, NaN and 1e1+- Fixed reading and writing from files just not working+- Fix building for ghc-9.2+- Add Data.Ron reexport module+- Improve documentation++[0.2.0]+- Add options for generic instances+- Add RonWith to conveniently derive instances with DerivingVia+- Use scientific instead of double+- Fix float parsing++[0.1.2]+- Improved serialization, add style settings+- Fix more bugs with chars+- Add convenience ser-de functions++[0.1.1]+- add Char+- add embedded comments+- bugfixes
+ ron-hs.cabal view
@@ -0,0 +1,134 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name: ron-hs+version: 0.4.0+synopsis: RON format implementation in haskell+description: RON (Rusty Object Notation) format implementation in haskell+category: Text+author: morj+maintainer: hackage@morj.men+license: (Apache-2.0 OR MIT)+license-file: LICENSE-APACHE+build-type: Simple+extra-doc-files:+ changelog.txt++source-repository head+ type: git+ location: https://github.com/maurges/ron-hs++library+ exposed-modules:+ Data.Ron+ Data.Ron.Class+ Data.Ron.Class.Deriving+ Data.Ron.Class.Internal+ Data.Ron.Deserialize+ Data.Ron.Serialize+ Data.Ron.Value+ Data.Ron.Value.Internal+ other-modules:+ Paths_ron_hs+ autogen-modules:+ Paths_ron_hs+ hs-source-dirs:+ src+ default-extensions:+ BangPatterns+ LambdaCase+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ ScopedTypeVariables+ TypeApplications+ TypeOperators+ ghc-options: -Wall -Wcompat -Werror=incomplete-patterns+ build-depends:+ QuickCheck >=2.14.2 && <2.16+ , attoparsec >=0.13.2 && <0.15+ , base >=4.14.3 && <4.22+ , bytestring >=0.10.12 && <0.13+ , containers >=0.6.4 && <0.9+ , deepseq >=1.4.4 && <1.7+ , hashable >=1.3.0 && <1.6+ , scientific >=0.3.7 && <0.4+ , template-haskell >=2.16.0 && <2.24+ , text >=1.2.4 && <2.2+ , vector >=0.12.3 && <0.14+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ other-modules:+ DerivingVia+ File+ ForExample+ Generic+ GenericOptions+ Optics.Ron.Settings+ Values+ Paths_ron_hs+ autogen-modules:+ Paths_ron_hs+ hs-source-dirs:+ test+ default-extensions:+ BangPatterns+ LambdaCase+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ ScopedTypeVariables+ TypeApplications+ TypeOperators+ ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wno-all -Wdefault -Wincomplete-patterns -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.14.2 && <2.16+ , base >=4.14.3 && <4.22+ , bytestring >=0.10.12 && <0.13+ , containers >=0.6.4 && <0.9+ , directory >=1.3.6 && <1.4+ , optics-core >=0.3 && <0.5+ , optics-th >=0.3 && <0.5+ , ron-hs+ , tasty >=1.4.2 && <1.6+ , tasty-hunit ==0.10.*+ , tasty-quickcheck >=0.10 && <0.12+ , text >=1.2.4 && <2.2+ , vector >=0.12.3 && <0.14+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ other-modules:+ Escape+ File+ Paths_ron_hs+ autogen-modules:+ Paths_ron_hs+ hs-source-dirs:+ bench+ default-extensions:+ BangPatterns+ LambdaCase+ MultiWayIf+ NamedFieldPuns+ OverloadedStrings+ ScopedTypeVariables+ TypeApplications+ TypeOperators+ ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wno-all -Wdefault -Wincomplete-patterns -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.14.3 && <4.22+ , base16-bytestring >=1.0.2 && <1.1+ , bytestring >=0.10.12 && <0.13+ , criterion >=1.5.13 && <1.7+ , ron-hs+ , text >=1.2.4 && <2.2+ default-language: Haskell2010
+ src/Data/Ron.hs view
@@ -0,0 +1,76 @@+-- | Most common ron definitions are collected in this module+--+-- == Quick start+--+-- 1. Define a datatype which supports Ron serialization:+--+-- @+-- data MyType+-- = Cons1+-- { _mtBool :: !Bool+-- , _mtList :: ![Text]+-- , _mtOtherValue :: !OtherType+-- }+-- | Cons2 Text Int+-- deriving (Generic)+-- deriving ('ToRon', 'FromRon')+-- via 'RonWith' '['FieldsDropPrefix'] MyType+-- @+--+-- For more options, see "Data.Ron.Class".+--+-- You will need to set @DerivingStrategies, DerivingVia, DeriveGeneric,+-- DataKinds@ for this to compile.+--+-- 2. Read a value of this type from a file with 'decodeFile':+--+-- @+-- myValue <- 'decodeFile' "path\/to\/file"+-- useMyValue myValue+-- @+--+-- 3. Write your value to a file with 'encodeFile'+--+-- @+-- 'encodeFile' 'haskellStyle' "path\/to\/file" myValue+-- @+--+-- For a type defined above, you can expect the serialized form to look like this:+--+-- @+-- Cons1+-- ( bool: false+-- , list:+-- [ "list"+-- , "of"+-- , "strings"+-- ]+-- , otherValue: OtherType (/* something here */)+-- )+-- @+module Data.Ron+ ( -- * Serialize and deserialize+ encode, encodeFile+ , decode, decodeLazy, decodeFile+ -- ** Style options+ , haskellStyle, rustStyle, compactStyle+ -- * Ron class and deriving+ , ToRon (..), FromRon (..)+ , RonWith (..)+ -- ** Settings for deriving+ , UseStrict+ , EncodeWith+ , DecodeWith+ , ConvertWith+ , FieldsToSnakeCase+ , FieldsDropPrefix+ , ImplicitSome+ , NoImplicitSome+ , SkipSingleConstructor+ , NoSkipSingleConstructor+ ) where++import Data.Ron.Class+import Data.Ron.Class.Deriving+import Data.Ron.Serialize+import Data.Ron.Deserialize
+ src/Data/Ron/Class.hs view
@@ -0,0 +1,668 @@+{-# LANGUAGE DefaultSignatures, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE EmptyCase #-}++-- | Definition for ron conversion classes, and for using 'GHC.Generics' to+-- encode any datatype into RON.+module Data.Ron.Class+ ( ToRon (..), FromRon (..)+ , ParseResult+ -- * Settings for generic encoding+ , RonSettings (..)+ , RonFlags (..)+ , strictRonSettings, laxRonSettings+ -- * Generic encoding+ , toRonGeneric+ , fromRonGeneric+ , GToRon, GFromRon+ ) where++import Control.Applicative (liftA2)+import Control.Arrow ((***))+import Data.ByteString (ByteString)+import Data.Complex (Complex ((:+)))+import Data.Foldable (toList)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Map.Strict (Map)+import Data.Proxy (Proxy (..))+import Data.Ron.Class.Internal (productSize, ProductSize)+import Data.Scientific (fromFloatDigits, toRealFloat, Scientific)+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (encodeUtf8)+import Data.Vector (Vector)+import Data.Word (Word8, Word16, Word32, Word64)+import GHC.Generics+ ( Generic (Rep, from, to), V1, U1 (..), (:+:)(..), (:*:)(..)+ , K1 (..), M1 (..)+ , C, S, D, R+ , Constructor (conName, conIsRecord), Selector (selName), Datatype (datatypeName)+ )++import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Vector as Vector++import Data.Ron.Value+import Prelude hiding (fail)+++-- | When decoding from ron, this type is used to indicate decode failure.+-- During decoding, multiple failures may be concatenated with a semicolon, and+-- for some functions the string will be thrown with+-- 'Data.Ron.Deserialize.DecodeError'. When implementing your own decoding+-- functions, you should put short one-sentence error descriptions.+--+-- For the next major release, we plan to replace it with a better mechanism+-- that reports error locations and supports long-form content.+type ParseResult = Either String+fail :: String -> ParseResult a+fail = Left++guard :: String -> Bool -> ParseResult ()+guard _ True = pure ()+guard msg False = fail msg++-- | Like 'Control.Applicative.(<|>)' but collect errors from both sides+(<<|>>) :: ParseResult a -> ParseResult a -> ParseResult a+pa <<|>> pb = case pa of+ Right a -> pure a+ Left ea -> case pb of+ Right b -> pure b+ Left eb -> fail $ ea <> "; "<> eb++-- | A class of values that can be encoded to RON format.+--+-- There are several ways to define an instance:+--+-- 1. By producing a 'Value' by hand+-- 2. By using 'toRonGeneric'+-- 3. By @DerivingVia@ extension and using 'Data.Ron.Class.Deriving.RonWith'+--+-- When using the second option, the encoding parameters are specified with+-- 'RonSettings'. With the third option, the same parameters are specified by a+-- list of settings found in 'Data.Ron.Class.Deriving'.+--+-- The default implementation uses generic encoding with 'laxRonSettings'. You+-- can use other settings like this:+--+-- @+-- instance ToRon MyType where+-- toRon = toRonGeneric strictRonSettings+-- { encodeFlags = RonFlags+-- { implicitSome = True+-- , skipSingleConstructor = True+-- }+-- }+-- @+--+-- Or like this:+--+-- @+-- deriving via (RonWith '[UseStrict, EncodeWith SkipSingleConstructor, EncodeWith ImplicitSome])+-- instance ToRon MyType+-- @+class ToRon a where+ toRon :: a -> Value+ default toRon :: (Generic a, GToRon (Rep a)) => a -> Value+ toRon = toRonDefault++-- | A class of values that can be restored from RON format+--+-- There are several ways to define an instance:+--+-- 1. By deconstructing a 'Value' by hand and producing a value of your type+-- 2. By using 'fromRonGeneric'+-- 3. By @DerivingVia@ extension and using 'Data.Ron.Class.Deriving.RonWith'+--+-- The default implementation uses generic decoding with 'laxRonSettings'. You+-- can use other settings like this:+--+-- @+-- instance FromRon MyType where+-- fromRon = fromRonGeneric strictRonSettings+-- { decodeFlags = RonFlags+-- { implicitSome = True+-- , skipSingleConstructor = True+-- }+-- }+-- @+--+-- Or like this:+--+-- @+-- deriving via (RonWith '[UseStrict, DecodeWith SkipSingleConstructor, DecodeWith ImplicitSome])+-- instance FromRon MyType+-- @+class FromRon a where+ fromRon :: Value -> ParseResult a+ default fromRon :: (Generic a, GFromRon (Rep a)) => Value -> ParseResult a+ fromRon = fromRonDefault++intInRange :: forall a. (Bounded a, Num a, Integral a) => Integer -> ParseResult a+intInRange i+ | i >= minVal && i <= maxVal = pure . fromInteger $ i+ | otherwise = fail $ "Value " <> show i <> " is not in valid range"+ where+ minVal = toInteger (minBound @a)+ maxVal = toInteger (maxBound @a)++instance ToRon Int where+ toRon = Integral . toInteger+instance FromRon Int where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Int8 where+ toRon = Integral . toInteger+instance FromRon Int8 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Int16 where+ toRon = Integral . toInteger+instance FromRon Int16 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Int32 where+ toRon = Integral . toInteger+instance FromRon Int32 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Int64 where+ toRon = Integral . toInteger+instance FromRon Int64 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Word where+ toRon = Integral . toInteger+instance FromRon Word where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Word8 where+ toRon = Integral . toInteger+instance FromRon Word8 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Word16 where+ toRon = Integral . toInteger+instance FromRon Word16 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Word32 where+ toRon = Integral . toInteger+instance FromRon Word32 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Word64 where+ toRon = Integral . toInteger+instance FromRon Word64 where+ fromRon (Integral i) = intInRange i+ fromRon _ = fail "Not an integer"+instance ToRon Integer where+ toRon = Integral+instance FromRon Integer where+ fromRon (Integral i) = pure i+ fromRon _ = fail "Not an integer"++instance ToRon Scientific where+ toRon = Floating+instance FromRon Scientific where+ fromRon (Integral x) = pure . fromInteger $ x+ fromRon (Floating x) = pure x+ fromRon _ = fail "Not a floating"+instance ToRon Double where+ toRon x+ | isNaN x = Unit "NaN"+ | isInfinite x = Unit "inf"+ | otherwise = Floating . fromFloatDigits $ x+instance FromRon Double where+ fromRon (Integral x) = pure . fromInteger $ x+ fromRon (Floating x) = pure . toRealFloat $ x+ fromRon (Unit "inf") = pure $! read "Infinity"+ fromRon (Unit "NaN") = pure $! read "NaN"+ fromRon _ = fail "Not a floating"+instance ToRon Float where+ toRon x+ | isNaN x = Unit "NaN"+ | isInfinite x = Unit "inf"+ | otherwise = Floating . fromFloatDigits $ x+instance FromRon Float where+ fromRon (Integral x) = pure . fromInteger $ x+ fromRon (Floating x) = pure . toRealFloat $ x+ fromRon (Unit "inf") = pure $! read "Infinity"+ fromRon (Unit "NaN") = pure $! read "NaN"+ fromRon _ = fail "Not a floating"++instance (ToRon a) => ToRon (Complex a) where+ toRon (r :+ im) = Tuple "Complex" (Vector.fromList [toRon r, toRon im])+instance (Num a, FromRon a) => FromRon (Complex a) where+ fromRon v@(Integral _) = (:+ 0) <$> fromRon v+ fromRon v@(Floating _) = (:+ 0) <$> fromRon v+ fromRon (Tuple name vals) = do+ guard "Incorrect Complex tuple name" $ name == "" || name == "Complex"+ case Vector.toList vals of+ [r, im] -> liftA2 (:+) (fromRon r) (fromRon im)+ _ -> fail "Incorrect amount of values in complex coordinates"+ fromRon _ = fail "Incorrect Complex value"++instance ToRon Char where+ toRon = Char+instance FromRon Char where+ fromRon (Char x) = pure x+ fromRon _ = fail "Expected Char"++instance ToRon Text where+ toRon = String+instance FromRon Text where+ fromRon (String x) = pure x+ fromRon _ = fail "Not text"++instance ToRon ByteString where+ toRon = List . Vector.fromList . map (Integral . toInteger) . BS.unpack+instance FromRon ByteString where+ fromRon (List bytes) = fmap BS.pack . traverse asWord8 . Vector.toList $ bytes+ where+ asWord8 (Integral x) = intInRange x+ asWord8 _ = fail "Not a byte in list"+ fromRon (String s) = pure . encodeUtf8 $ s+ fromRon _ = fail "Not a bytestring"++instance ToRon Bool where+ toRon True = Unit "true"+ toRon False = Unit "false"+instance FromRon Bool where+ fromRon (Unit name)+ | name == "True" || name == "true" = pure True+ | name == "False" || name == "false" = pure False+ | otherwise = fail $ "Invalid enum value: " <> show name+ fromRon _ = fail "Not a boolean"++instance (ToRon a) => ToRon (Vector.Vector a) where+ toRon = List . Vector.map toRon+instance (FromRon a) => FromRon (Vector.Vector a) where+ fromRon (List xs) = traverse fromRon xs+ fromRon _ = fail "Not a list"+instance (ToRon a) => ToRon [a] where+ toRon = List . Vector.fromList . map toRon+instance (FromRon a) => FromRon [a] where+ fromRon (List xs) = Vector.toList <$> traverse fromRon xs+ fromRon _ = fail "Not a list"+instance {-# OVERLAPPING #-} ToRon [Char] where+ toRon = String . pack+instance {-# OVERLAPPING #-} FromRon [Char] where+ fromRon = fmap unpack . fromRon+instance (ToRon a) => ToRon (NonEmpty a) where+ toRon (x:|xs) = toRon $ x:xs+instance (FromRon a) => FromRon (NonEmpty a) where+ fromRon v = fromRon v >>= \case+ [] -> fail "Expected non-empty list"+ x:xs -> pure $ x:|xs++instance (ToRon k, ToRon v) => ToRon (Map.Map k v) where+ toRon = Map . Map.fromList . map (toRon *** toRon) . Map.toAscList+instance (FromRon k, FromRon v, Ord k) => FromRon (Map.Map k v) where+ fromRon (Map xs) = Map.fromList <$>+ traverse tupleFromRon (Map.toAscList xs)+ where tupleFromRon (a, b) = liftA2 (,) (fromRon a) (fromRon b)+ fromRon _ = fail "Not a map"++instance (ToRon a) => ToRon (Set.Set a) where+ toRon = toRon . Set.toAscList+instance (FromRon a, Ord a) => FromRon (Set.Set a) where+ fromRon = fmap Set.fromList . fromRon+instance (ToRon a) => ToRon (Seq.Seq a) where+ toRon = toRon . toList+instance (FromRon a) => FromRon (Seq.Seq a) where+ fromRon = fmap Seq.fromList . fromRon++instance ToRon () where+ toRon () = Unit ""+instance FromRon () where+ fromRon (Unit name)+ | name == "" = pure ()+ | otherwise = fail "Not a unit enum value"+ fromRon _ = fail "Not a unit"++instance (ToRon a) => ToRon (Maybe a) where+ toRon (Just x) = Tuple "Some" (Vector.singleton $ toRon x)+ toRon Nothing = Unit "None"+instance (FromRon a) => FromRon (Maybe a) where+ fromRon (Tuple name xs)+ | (name == "Just" || name == "Some") && Vector.length xs == 1+ = Just <$> fromRon (Vector.unsafeHead xs)+ | otherwise = fail "Not a Maybe enum"+ fromRon (Unit name)+ | name == "Nothing" || name == "None" = pure Nothing+ | otherwise = fail $ "Incorrect Maybe name: " <> show name+ fromRon _ = fail "Not a named tuple or unit"++instance (ToRon a, ToRon b) => ToRon (Either a b) where+ toRon (Left x) = Tuple "Left" (Vector.singleton $ toRon x)+ toRon (Right x) = Tuple "Right" (Vector.singleton $ toRon x)+instance (FromRon a, FromRon b) => FromRon (Either a b) where+ fromRon (Tuple name xs)+ | Vector.length xs == 1 =+ if | name == "Left" -> Left <$> fromRon (Vector.unsafeHead xs)+ | name == "Right" -> Right <$> fromRon (Vector.unsafeHead xs)+ | otherwise -> fail "Not an Either enum"+ | otherwise = fail "Incorrect amount of arguments to Either"+ fromRon _ = fail "Not an Either value"++instance (ToRon a1, ToRon a2) => ToRon (a1, a2) where+ toRon (a1, a2) = Tuple "" . Vector.fromList $ [toRon a1, toRon a2]++instance (FromRon a1, FromRon a2) => FromRon (a1, a2) where+ fromRon (Tuple name xs)+ | name == "" = case Vector.toList xs of+ [a1, a2] -> liftA2 (,) (fromRon a1) (fromRon a2)+ _ -> fail "Incorrect amount of tuple values"+ | otherwise = fail "Incorrect tuple name"+ fromRon _ = fail "Not a tuple"+++--- Generic instance++-- | Part of 'RonSettings' that applies to both encoding and decoding, and+-- separately+data RonFlags = RonFlags+ { implicitSome :: !Bool+ -- ^ Like ron-rs's @implicit_some@. When set to True, 'Nothing' in record+ -- fields is represented by omission of the field+ , skipSingleConstructor :: !Bool+ -- ^ When a datatype has a single constructor, encoding will omit it and+ -- decoding will ignore it missing, turning the representation into a tuple+ -- or an anonymous record.+ } deriving (Eq, Show)++-- | Settings for use with 'Generic' RON encoding/decoding+data RonSettings = RonSettings+ { fieldModifier :: !(String -> String)+ -- ^ Every field will be renamed using the supplied function+ , constructorModifier :: !(String -> String)+ -- ^ Every constructor will be renamed using the supplied function+ , decodeFlags :: !RonFlags+ -- ^ Options that apply to encoding separately from decoding+ , encodeFlags :: !RonFlags+ -- ^ Options that apply to decoding separately from encoding+ }++data SumContext = SumContext+ { isSingleConstructor :: Bool+ , sumTypeName :: String+ } deriving (Eq, Show)++data ProductContext = ProductContext+ { prodTypeName :: String+ , constructorName :: String+ } deriving (Eq, Show)++-- | Encode ron using 'Generic' instance and provided 'RonSettings'.+--+-- With generic encoding sums are turned into sums, records into records, and+-- multi-param constructors into tuples.+toRonGeneric :: (Generic a, GToRon (Rep a)) => RonSettings -> a -> Value+toRonGeneric conf = toRonG conf . from++-- | Values are expected to exactly conform: all fields should have the same+-- name, all constructors should be present, no @Some@ omission+strictRonSettings :: RonSettings+strictRonSettings = RonSettings+ { fieldModifier = id+ , constructorModifier = id+ , decodeFlags = RonFlags+ { implicitSome = False+ , skipSingleConstructor = False+ }+ , encodeFlags = RonFlags+ { implicitSome = False+ , skipSingleConstructor = False+ }+ }++-- | Relaxes 'strictRonSettings' on constructor omission and implicitSome when+-- decoding, but encodes in the same strict way+laxRonSettings :: RonSettings+laxRonSettings = RonSettings+ { fieldModifier = id+ , constructorModifier = id+ , decodeFlags = RonFlags+ { implicitSome = True+ , skipSingleConstructor = True+ }+ , encodeFlags = RonFlags+ { implicitSome = False+ , skipSingleConstructor = False+ }+ }++toRonDefault :: (Generic a, GToRon (Rep a)) => a -> Value+toRonDefault = toRonGeneric laxRonSettings++-- | Internal class for converting to Ron. You might need it if you're writing+-- you own generic combinators+class GToRon f where+ toRonG :: RonSettings -> f a -> Value++class GToRonSum f where+ toRonSum :: RonSettings -> SumContext -> f a -> Value+class GToRonProduct f where+ toRonProduct+ :: RonSettings -> ProductContext -> f a -> Either (Vector Value) (Map Text Value)+class GToRonRec f where+ toRonRec :: RonSettings -> f a -> Value++instance (Datatype d, GToRonSum f) => GToRon (M1 D d f) where+ toRonG conf (M1 x) = toRonSum conf cont x+ where cont = SumContext+ { isSingleConstructor = True+ , sumTypeName = datatypeName (undefined :: t d f a)+ }++instance GToRonSum V1 where+ toRonSum _ _ x = case x of {}++instance (Constructor c, GToRonProduct f) => GToRonSum (M1 C c f) where+ toRonSum conf cont (M1 x) =+ let con = undefined :: t c f a+ name = if isSingleConstructor cont+ && skipSingleConstructor (encodeFlags conf)+ then ""+ else pack . conName $ con+ cont' = ProductContext+ { prodTypeName = sumTypeName cont+ , constructorName = unpack name+ }+ xs = toRonProduct conf cont' x+ in case (xs, conIsRecord con) of+ (Right xs', True) -> Record name xs'+ (Left xs', False) -> Tuple name xs'+ (Right xs', _) | null xs' -> Unit name+ (Left xs', _) | Vector.null xs' -> Unit name+ _ -> error $ "Bad product: " <> take 128 (show xs)++instance (GToRonSum fl, GToRonSum fr) => GToRonSum (fl :+: fr) where+ toRonSum conf cont (L1 x) = toRonSum conf cont' x+ where cont' = cont+ {isSingleConstructor = False}+ toRonSum conf cont (R1 x) = toRonSum conf cont' x+ where cont' = cont+ {isSingleConstructor = False}++instance GToRonProduct U1 where+ toRonProduct _ _ U1 = Left Vector.empty++instance {-# OVERLAPPING #-} (Selector s, ToRon c)+ => GToRonProduct (M1 S s (K1 R (Maybe c))) where+ toRonProduct conf _cont (M1 (K1 x)) =+ let field = selName (undefined :: t s (K1 R (Maybe c)) a)+ in case x of+ Nothing | implicitSome . encodeFlags $ conf ->+ if null field+ then Left . Vector.singleton . toRon $ Nothing @()+ else Right Map.empty+ Just x' | implicitSome . encodeFlags $ conf ->+ if null field+ then Left . Vector.singleton . toRon $ x'+ else+ let field' = pack $ fieldModifier conf field+ value = toRon x'+ in Right $ Map.singleton field' value+ x'+ | null field -> Left . Vector.singleton . toRon $ x'+ | otherwise ->+ let field' = pack $ fieldModifier conf field+ in Right . Map.singleton field' $ toRon x'++instance (Selector s, GToRonRec f) => GToRonProduct (M1 S s f) where+ toRonProduct conf _cont (M1 x) =+ let field = selName (undefined :: t s f a)+ value = toRonRec conf x+ in case field of+ "" -> Left . Vector.singleton $ value+ _field ->+ let field' = pack $ fieldModifier conf field+ in Right $ Map.singleton field' value++instance (GToRonProduct pl, GToRonProduct pr)+ => GToRonProduct (pl :*: pr) where+ toRonProduct conf cont (x :*: y) =+ case (toRonProduct conf cont x, toRonProduct conf cont y) of+ (Left xs, Left ys) -> Left $ xs <> ys+ (Right xs, Right ys) -> Right $ Map.union xs ys+ _ -> error "Incompatible product branches"++instance ToRon c => GToRonRec (K1 R c) where+ toRonRec _ (K1 x) = toRon x+++-- | Decode ron using 'Generic' instance and provided 'RonSettings'+--+-- With generic encoding sums are turned into sums, records into records, and+-- multi-param constructors into tuples.+fromRonGeneric+ :: (Generic a, GFromRon (Rep a)) => RonSettings -> Value -> ParseResult a+fromRonGeneric conf = fmap to . fromRonG conf++fromRonDefault :: (Generic a, GFromRon (Rep a)) => Value -> ParseResult a+fromRonDefault = fromRonGeneric laxRonSettings++-- | Internal class for converting from Ron. You might need it if you're+-- writing you own generic combinators+class GFromRon f where+ fromRonG :: RonSettings -> Value -> ParseResult (f a)++class GFromRonSum f where+ fromRonSum :: RonSettings -> SumContext -> Value -> ParseResult (f a)+class GFromRonProduct f where+ fromRonProduct+ :: RonSettings+ -> ProductContext+ -> Either (Vector Value) (Map Text Value)+ -> ParseResult (f a)+class GFromRonRec f where+ fromRonRec :: RonSettings -> Value -> ParseResult (f a)++instance (Datatype d, GFromRonSum f) => GFromRon (M1 D d f) where+ fromRonG conf x = M1 <$> fromRonSum conf cont x+ where cont = SumContext+ { isSingleConstructor = True+ , sumTypeName = datatypeName (undefined :: t d f a)+ }++instance (Constructor c, GFromRonProduct f) => GFromRonSum (M1 C c f) where+ fromRonSum conf cont x =+ M1 <$> case x of+ Unit n | name `matches` n+ -> fromRonProduct conf cont' $ Left Vector.empty+ | otherwise -> fail incorrectConstructor+ Tuple n xs | name `matches` n -> fromRonProduct conf cont' $ Left xs+ | otherwise -> fail incorrectConstructor+ Record n xs | name `matches` n -> fromRonProduct conf cont' $ Right xs+ | otherwise -> fail incorrectConstructor+ _ -> fail $ "Incorrect value for type " <> sumTypeName cont+ where+ con = undefined :: t c f a+ name = pack . conName $ con+ matches target ron =+ ron == target+ || ron == ""+ && isSingleConstructor cont+ && skipSingleConstructor (decodeFlags conf)+ incorrectConstructor = "Incorrect constructor " <> constructorName <> " for type " <> sumTypeName cont+ constructorName = case unpack name of+ "" -> "<UNNAMED>"+ n -> n+ cont' = ProductContext+ { prodTypeName = sumTypeName cont+ , constructorName+ }++instance (GFromRonSum fl, GFromRonSum fr) => GFromRonSum (fl :+: fr) where+ fromRonSum conf cont x =+ (L1 <$> fromRonSum conf cont' x) <<|>> (R1 <$> fromRonSum conf cont' x)+ where cont' = cont+ { isSingleConstructor = False }++instance GFromRonProduct U1 where+ fromRonProduct _ _ (Left xs) | Vector.null xs = pure U1+ fromRonProduct _ _ (Right xs) | Map.null xs = pure U1+ fromRonProduct _ c _ = fail $ constructorName c <> ": expected empty structure"++instance {-# OVERLAPPING #-} (Selector s, FromRon c)+ => GFromRonProduct (M1 S s (K1 R (Maybe c))) where+ fromRonProduct conf cont xs =+ let field =+ pack . fieldModifier conf $+ selName (undefined :: t s (K1 R (Maybe c)) a)+ ProductContext {constructorName} = cont+ in case xs of+ Left xs' -> case Vector.uncons xs' of+ Nothing -> fail $ "Not enough elements in tuple " <> constructorName+ Just (x, xs'')+ | Vector.null xs'' -> M1 <$>+ let tryUnwrapped+ | implicitSome . decodeFlags $ conf =+ K1 . Just <$> fromRon x+ | otherwise =+ fail $ constructorName <> ": not using decodeImplicitSome"+ in fromRonRec conf x <<|>> tryUnwrapped+ | otherwise -> fail $ "Trailing members in tuple " <> constructorName+ Right xs'+ | implicitSome . decodeFlags $ conf ->+ case Map.lookup field xs' of+ Nothing -> pure . M1 . K1 $ Nothing+ Just x ->+ let unwrapped = M1 . K1 . Just <$> fromRon x+ wrapped = M1 <$> fromRonRec conf x+ in wrapped <<|>> unwrapped+ | otherwise -> case Map.lookup field xs' of+ Nothing -> fail $ "Field " <> unpack field <> " not present in record " <> constructorName+ Just x -> M1 <$> fromRonRec conf x++instance (Selector s, GFromRonRec f) => GFromRonProduct (M1 S s f) where+ fromRonProduct conf cont xs =+ let field = pack . fieldModifier conf $ selName (undefined :: t s f a)+ ProductContext {constructorName} = cont+ in case xs of+ Left xs' -> case Vector.uncons xs' of+ Nothing -> fail $ "Not enough elements in tuple " <> constructorName+ Just (x, xs'') | Vector.null xs'' -> M1 <$> fromRonRec conf x+ | otherwise -> fail $ "Trailing members in tuple " <> constructorName+ Right xs' -> case Map.lookup field xs' of+ Nothing -> fail $ "Field " <> unpack field <> " not present in record " <> constructorName+ Just x -> M1 <$> fromRonRec conf x++instance (ProductSize pl, GFromRonProduct pl, GFromRonProduct pr)+ => GFromRonProduct (pl :*: pr) where+ fromRonProduct conf cont (Left xs) =+ let sizel = productSize (Proxy @pl)+ (xsl, xsr) = Vector.splitAt sizel xs+ in (:*:)+ <$> fromRonProduct conf cont (Left xsl)+ <*> fromRonProduct conf cont (Left xsr)+ fromRonProduct conf cont xs = (:*:)+ <$> fromRonProduct conf cont xs+ <*> fromRonProduct conf cont xs++instance FromRon c => GFromRonRec (K1 R c) where+ fromRonRec _ x = K1 <$> fromRon x
+ src/Data/Ron/Class/Deriving.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE KindSignatures, DataKinds #-}+{-# LANGUAGE UndecidableInstances, FlexibleContexts #-} -- type family in instance head+{-# LANGUAGE PolyKinds #-}++-- | Allows deriving ron encoding-decoding instances with @DerivingVia@. See 'RonWith'+module Data.Ron.Class.Deriving+ ( RonWith (..)+ -- * Settings+ , UseStrict+ , EncodeWith+ , DecodeWith+ , ConvertWith+ , FieldsToSnakeCase+ , FieldsDropPrefix+ , ImplicitSome+ , NoImplicitSome+ , SkipSingleConstructor+ , NoSkipSingleConstructor+ -- * Undelying typeclasses+ , ReflectSettingsOptions (..)+ , ReflectFlagOptions (..)+ ) where++import Data.Char (isUpper, toLower, isLower)+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic, Rep)++import Data.Ron.Class+++-- | Helper for deriving Ron instances. Use like this:+--+-- @+-- data MyType = MyType {...}+-- deriving (Eq, Show, Generic)+-- deriving (ToRon, FromRon)+-- via RonWith '[FieldsDropPrefix, EncodeWith SkipSingleConstructor] MyType+-- @+--+-- This is identical to+--+-- @+-- data MyType = MyType {...}+-- deriving (Eq, Show, Generic)+-- instance ToRon MyType where+-- toRon =+-- let settings+-- = (\s{encodeFlags} -> s{encodeFlags = encodeFlags{skipSingleConstructor = True}})+-- . (\s{fieldModifier} -> s{dropPrefix . fieldModifier})+-- $ laxRonSettings+-- in toRonGeneric settings+-- @+--+-- The options are applied left to right, and the starting options are+-- 'laxRonSettings'+--+-- All of built-in settings are documented in 'Data.Ron.Class.Deriving' module.+-- You can define your own settings by creating new datatypes and creating+-- instances for 'ReflectSettingsOptions' or 'ReflectFlagOptions'+newtype RonWith s a = RonWith a++instance (Generic a, GToRon (Rep a), ReflectSettingsList s)+ => ToRon (RonWith s a) where+ toRon (RonWith x) = flip toRonGeneric x $ reflectL (Proxy @s) laxRonSettings++instance (Generic a, GFromRon (Rep a), ReflectSettingsList s)+ => FromRon (RonWith s a) where+ fromRon = fmap RonWith . fromRonGeneric (reflectL (Proxy @s) laxRonSettings)++class ReflectSettingsList a where+ reflectL :: Proxy a -> RonSettings -> RonSettings++instance ReflectSettingsList '[] where+ reflectL Proxy s = s+ {-# INLINE reflectL #-}+instance (ReflectSettingsOptions s, ReflectSettingsList ss)+ => ReflectSettingsList (s:ss) where+ reflectL Proxy+ = reflectL (Proxy @ss)+ . reflectS (Proxy @s)+ {-# INLINE reflectL #-}++-- | Replace the current settings with 'strictRonSettings'+data UseStrict+-- | Sets a flag in @encodeFlags@. Can set anything with 'ReflectFlagOptions'+-- instances, like 'ImplicitSome', 'SkipSingleConstructor'+data EncodeWith a+-- | Sets a flag in @decodeFlags@. Can set anything with 'ReflectFlagOptions'+-- instances+data DecodeWith a+-- | Same as setting both 'EncodeWith' and 'DecodeWith'+data ConvertWith a+-- | Convert fields to snake case. If your field also has prefix, you want to+-- have this option after 'FieldsDropPrefix', as options are applied left to+-- right+data FieldsToSnakeCase+-- | Drop the prefix that is usually used with lenses, that is an underscore+-- followed by several lowercase letters; regex for this prefix is+-- @s\/^_[[:lowercase:]]+([[:uppercase:]].*)\/\\1\/@. You probably want to use+-- this field modifier before other field modifiers, as they are applied left+-- to right+data FieldsDropPrefix++-- | Typeclass for you to implement your own options. Here's how+-- 'FieldsToSnakeCase' uses it:+--+-- @+-- instance ReflectSettingsOptions FieldsToSnakeCase where+-- reflectS Proxy s@RonSettings {fieldModifier} = s+-- { fieldModifier = toSnake . fieldModifier }+-- @+--+-- Be careful when composing functions to apply them after the already present,+-- to preserve the left-to-right semantics of adding the options+class ReflectSettingsOptions a where+ reflectS :: Proxy a -> RonSettings -> RonSettings++-- | Encode or decode flag that sets 'Data.Ron.Class.implicitSome' to @True@+data ImplicitSome+-- | Encode or decode flag that sets 'Data.Ron.Class.implicitSome' to @False@+data NoImplicitSome+-- | Encode or decode flag that sets 'Data.Ron.Class.skipSingleConstructor' to @True@+data SkipSingleConstructor+-- | Encode or decode flag that sets 'Data.Ron.Class.skipSingleConstructor' to @False@+data NoSkipSingleConstructor++-- | Typeclass for you to implement your own symmetric options. Here's how+-- 'ImplicitSome' uses it+--+-- @+-- instance ReflectFlagOptions ImplicitSome where+-- reflectF Proxy flags = flags { implicitSome = True }+-- @+class ReflectFlagOptions a where+ reflectF :: Proxy a -> RonFlags -> RonFlags++instance ReflectSettingsOptions UseStrict where+ reflectS Proxy _ = strictRonSettings+ {-# INLINE reflectS #-}++instance ReflectFlagOptions a => ReflectSettingsOptions (EncodeWith a) where+ reflectS Proxy s@RonSettings {encodeFlags} = s+ { encodeFlags = reflectF (Proxy @a) encodeFlags }+ {-# INLINE reflectS #-}+instance ReflectFlagOptions a => ReflectSettingsOptions (DecodeWith a) where+ reflectS Proxy s@RonSettings {decodeFlags} = s+ { decodeFlags = reflectF (Proxy @a) decodeFlags }+ {-# INLINE reflectS #-}+instance ReflectFlagOptions a => ReflectSettingsOptions (ConvertWith a) where+ reflectS Proxy s@RonSettings {encodeFlags, decodeFlags} = s+ { encodeFlags = reflectF (Proxy @a) encodeFlags+ , decodeFlags = reflectF (Proxy @a) decodeFlags+ }+ {-# INLINE reflectS #-}++instance ReflectSettingsOptions FieldsDropPrefix where+ reflectS Proxy conf@RonSettings {fieldModifier} = conf+ { fieldModifier = dropPrefix . fieldModifier }+ where+ dropPrefix ('_':s) =+ case dropWhile (not . isUpper) s of+ "" -> '_':s+ c:s' -> toLower c : s'+ dropPrefix s = s+ {-# INLINE reflectS #-}++instance ReflectSettingsOptions FieldsToSnakeCase where+ reflectS Proxy s@RonSettings {fieldModifier} = s+ { fieldModifier = toSnake . fieldModifier }+ where+ toSnake = camelTo2 '_'+ {-# INLINE reflectS #-}++-- | Better version of camelTo. Example where it works better:+--+-- > camelTo '_' "CamelAPICase" == "camel_apicase"+-- > camelTo2 '_' "CamelAPICase" == "camel_api_case"+--+-- Extracted from aeson at Feb 2022+camelTo2 :: Char -> String -> String+camelTo2 c = map toLower . go2 . go1+ where+ go1 "" = ""+ go1 (x:u:l:xs) | isUpper u && isLower l = x : c : u : l : go1 xs+ go1 (x:xs) = x : go1 xs+ go2 "" = ""+ go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs+ go2 (x:xs) = x : go2 xs++instance ReflectFlagOptions ImplicitSome where+ reflectF Proxy f =+ f { implicitSome = True }+ {-# INLINE reflectF #-}++instance ReflectFlagOptions NoImplicitSome where+ reflectF Proxy f =+ f { implicitSome = False }+ {-# INLINE reflectF #-}++instance ReflectFlagOptions SkipSingleConstructor where+ reflectF Proxy f =+ f { skipSingleConstructor = True }+ {-# INLINE reflectF #-}++instance ReflectFlagOptions NoSkipSingleConstructor where+ reflectF Proxy f =+ f { skipSingleConstructor = False }+ {-# INLINE reflectF #-}
+ src/Data/Ron/Class/Internal.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE KindSignatures, TypeApplications #-}+module Data.Ron.Class.Internal+ ( ProductSize (productSize)+ ) where++import GHC.Generics ((:*:)(..), M1)+import Data.Proxy (Proxy (Proxy))+import Data.Kind (Type)+++class ProductSize (f :: Type -> Type) where+ productSize :: Proxy f -> Int++instance ProductSize (M1 c s f) where+ productSize _ = 1+ {-# INLINE productSize #-}++instance (ProductSize fl, ProductSize fr) => ProductSize (fl :*: fr) where+ productSize _ = productSize (Proxy @fl) + productSize (Proxy @fr)+ {-# INLINE productSize #-}
+ src/Data/Ron/Deserialize.hs view
@@ -0,0 +1,530 @@+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-unused-do-bind #-}+-- | Ron routines for deserialization. Also exposes the underlying attoparsec+-- parsers if you want to build more complicated consumers of ron, like+-- conduits or pipes+module Data.Ron.Deserialize+ ( decode, decodeLazy, decodeFile+ , loads, loadsLazy, loadFile, loadFile'+ -- * Exceptions+ , ParseError, DecodeError+ -- * Parsers+ , document, toplevel, value, ronWhitespace+ ) where++import Control.Applicative ((<|>), liftA2)+import Control.Exception (Exception, throwIO)+import Data.Attoparsec.ByteString (skip)+import Data.ByteString.Char8 (ByteString, cons)+import Data.ByteString.Lazy (toStrict)+import Data.Char (isAlpha, isAlphaNum, chr)+import Data.List (intercalate)+import Data.Map.Strict (Map)+import Data.Ron.Class (FromRon, fromRon)+import Data.Scientific (Scientific, scientific)+import Data.Text (Text, uncons)+import Data.Text.Encoding (decodeUtf8, decodeUtf8')+import Data.Typeable (Typeable)+import Data.Vector (Vector)++import qualified Data.Map.Strict as Map+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Char8 as ByteString8+import qualified Data.ByteString.Builder as Builder+import qualified Data.Text as Text+import qualified Data.Vector as Vector++import Data.Attoparsec.ByteString.Char8 hiding (feed, hexadecimal, decimal, isSpace, scientific)+import Data.Ron.Value+import Prelude hiding (takeWhile)+++-- Each parser function assumes there is no whitespace before it, and must+-- consume all whitespace after it.+--+-- Parsers don't backtrack at all (except a few characters back sometimes+-- internally). It's mostly possible to understand what value is in front of us+-- by its first character, but sometimes we do have to parse the whole+-- identifier or number to see what character comes after it. The parsers xOrY+-- take care of that.+-- But just using those xOrY is not enough at times, since I didn't figure out+-- how to compose them properly: there are a lot of places where this ambiguity+-- arises. So i just duplicated that code. It's still not that bad, but could+-- be a lot better..+--+-- Also, fucking raw strings. Why not just start them with '#'?+++--- Decode functions+++-- | Parse a 'ByteString' to your type. The error is produced by attoparsec and is+-- not very useful.+decode :: FromRon a => ByteString -> Either String a+decode str = loads str >>= fromRon++-- | Parse a lazy 'Lazy.ByteString' to your type. The error is produced by+-- attoparsec and is not very useful.+decodeLazy :: FromRon a => Lazy.ByteString -> Either String a+decodeLazy str = loadsLazy str >>= fromRon++-- | Parse file content to your type. Throws 'ParseError' or 'DecodeError' on+-- errors.+decodeFile :: FromRon a => FilePath -> IO a+decodeFile path = loadFile path >>= pure . fromRon >>= \case+ Left err -> throwIO $! DecodeError err+ Right x -> pure x++-- | Parse a 'ByteString' to a 'Value'. You probably want 'decode' instead+loads :: ByteString -> Either String Value+loads = parseOnly document++-- | Parse a lazy 'Lazy.ByteString' to a 'Value'. You probably want+-- 'decodeLazy' instead+loadsLazy :: Lazy.ByteString -> Either String Value+loadsLazy str = case Lazy.toChunks str of+ [] -> Left "Empty input"+ s:ss -> go ss $! parse document s+ where+ -- since toplevel requires eof after end, _rest should always be nothing+ go _ (Fail _rest contexts message) = Left $+ "Parse error: " <> message+ <> "; context: " <> intercalate "; " contexts+ go [] (Done _rest x) = pure x+ go _ (Done _rest _x) = Left "Unconsumed input after value"+ go (s:ss) (Partial feed) = go ss $! feed s+ go [] (Partial feed) = case feed "" of+ (Fail _rest contexts message) -> Left $+ "Parse error: " <> message+ <> "; context: " <> intercalate "; " contexts+ (Done _rest x) -> pure x+ (Partial _) -> Left "Unexpected end of input"++-- | Parse file. Throws 'ParseError'+loadFile :: FilePath -> IO Value+loadFile path = loadFile' path >>= \case+ Left err -> throwIO $! ParseError err+ Right x -> pure x++-- | Parse file and return the error in 'Either'+loadFile' :: FilePath -> IO (Either String Value)+loadFile' path = loadsLazy <$> Lazy.readFile path+++--- Parsers++-- | A parser for a complete Ron document, consisting of a single value.+-- Expects EOF at the end. Will parse Ron notation, or a toplevel record with+-- no braces, or a toplevel list with no braces; the latter two are ron-hs+-- extensions.+document :: Parser Value+document = ws *> toplevel <* do+ peekChar >>= \case+ Nothing -> pure ()+ Just s -> fail $ "Expected eof, got data starting with " <> show s++-- | Toplevel is either a toplevel 'list', toplevel 'record', or a regular ron+-- 'value'. The first two are ron-hs extensions.+--+-- This is similar to 'document', but won't parse whitespace before self, and+-- doesn't expect EOF at the end.+toplevel :: Parser Value+toplevel = peekChar' >>= \case+ -- raw string, algebraic struct, or a field in toplevel 'record'+ 'r' -> skip1 >> peekChar >>= \case+ Nothing -> pure $ Unit "r"+ Just '#' -> String <$> ronRawString+ Just '\"' -> String <$> ronRawString+ _ -> do+ ident <- decodeUtf8 . cons 'r' <$> takeWhile isKeyword+ ws+ peekChar >>= \case+ Just '(' -> recordOrTuple ident >>= toplevelList+ Just ':' -> skip1 *> ws *> toplevelRecord ident+ _ -> ws *> pure (Unit ident)+ c | startsIdentifier c -> do+ ident <- decodeUtf8 <$> takeWhile isKeyword+ ws+ peekChar >>= \case+ Just '(' -> recordOrTuple ident >>= toplevelList+ Just ':' -> skip1 *> ws *> toplevelRecord ident+ _ -> ws *> toplevelList (Unit ident)+ | otherwise -> value >>= toplevelList++toplevelList :: Value -> Parser Value+toplevelList first = peekChar >>= \case+ Just ',' -> do+ skip1 -- ,+ ws+ xs <- sepBy value (char ',' *> ws)+ option () $ char ',' *> ws+ pure . List . Vector.fromList $ first:xs+ _ -> pure first++toplevelRecord :: Text -> Parser Value+toplevelRecord firstField = do+ firstValue <- value+ let initial = (firstField, firstValue)+ peekChar >>= \case+ Just ',' -> do+ skip1 -- ,+ ws+ let pair = do+ k <- liftA2 cons (satisfy startsIdentifier) (takeWhile isKeyword)+ ws+ char ':'+ ws+ v <- value+ pure (decodeUtf8 k, v)+ xs <- sepBy pair (char ',' *> ws)+ option () $ char ',' *> ws+ pure . Record "" . Map.fromList $ initial:xs+ Nothing -> pure . Record "" . Map.fromList $ [initial]+ _ -> fail "Expecting , at toplevel record"++-- | A ron value as defined by the ron-rs spec (with minor deviations described+-- in this package).+--+-- Unlike 'toplevel', this won't parse bare toplevel list or record. Unlike+-- 'document' and like 'toplevel', won't parse whitespace before self, and+-- doesn't expect EOF at the end.+value :: Parser Value+value = peekChar' >>= \case+ c | startsNumber c -> intOrFloat+ | startsChar c -> Char <$> character+ | startsString c -> String <$> ronString+ | startsList c -> List <$> list+ | startsMap c -> Map <$> ronMap+ | startsStruct c -> recordOrTuple ""+ | startsIdentifier c -> identifierLike c+ | otherwise -> fail $ "Unexpected symbol: " <> show c++-- | Whitespace as defined by ron-rs spec. Useful if you want to build your+-- custom attoparsec parsers from 'value' or 'toplevel'.+ronWhitespace :: Parser ()+ronWhitespace = ws+++--- Numbers ---+++intOrFloat :: Parser Value+intOrFloat = go <* ws where+ go = do+ !positive <- ((== '+') <$> satisfy (\c -> c == '-' || c == '+'))+ <|> pure True+ let intOrFloatSimple = do+ whole <- takeWhile (\c -> decimalDigit c || c == '_')+ peekChar >>= \case+ Just '.' -> skip1 *> (Floating <$> floating positive whole)+ Just 'e' -> Floating <$> floating positive whole+ _ -> ws *> pure (Integral $ buildNumber 10 positive whole)+ peekChar' >>= \case+ '.' -> skip1 *> (Floating <$> floating positive "0")+ '0' -> skip1 >> peekChar >>= \case+ Nothing -> pure $ Integral 0+ Just 'x' -> skip1 *> (Integral <$> hexadecimal positive)+ Just 'o' -> skip1 *> (Integral <$> octal positive)+ Just 'b' -> skip1 *> (Integral <$> binary positive)+ Just '.' -> skip1 *> (Floating <$> floating positive "0")+ Just _ -> intOrFloatSimple+ _ -> intOrFloatSimple++buildNumber :: Integer -> Bool -> ByteString -> Integer+buildNumber base positive digits = mbNegate . ByteString8.foldl' step 0 $ digits where+ mbNegate = if positive then id else negate+ step !a '_' = a+ step !a !d = a * base + toDigit d+ toDigit = \case+ '0' -> 0+ '1' -> 1+ '2' -> 2+ '3' -> 3+ '4' -> 4+ '5' -> 5+ '6' -> 6+ '7' -> 7+ '8' -> 8+ '9' -> 9+ 'a' -> 10+ 'b' -> 11+ 'c' -> 12+ 'd' -> 13+ 'e' -> 14+ 'f' -> 15+ 'A' -> 10+ 'B' -> 11+ 'C' -> 12+ 'D' -> 13+ 'E' -> 14+ 'F' -> 15+ _ -> error "Not a number"++hexadecimal positive+ = buildNumber 16 positive <$> takeWhile (\c -> c == '_' || hexadecimalDigit c) <* ws+decimal positive+ = buildNumber 10 positive <$> takeWhile (\c -> c == '_' || decimalDigit c) <* ws+octal positive+ = buildNumber 8 positive <$> takeWhile (\c -> c == '_' || octalDigit c) <* ws+binary positive+ = buildNumber 2 positive <$> takeWhile (\c -> c == '_' || binaryDigit c) <* ws++floating :: Bool -> ByteString -> Parser Scientific+floating positive !wholeStr = do+ -- dot is already skipped, e is not+ !fracStr <- takeWhile (\c -> c == '_' || decimalDigit c)+ let !fracPart = fromInteger $! buildNumber 10 positive fracStr+ let !wholePart = fromInteger $! buildNumber 10 positive wholeStr+ let !shift = fromIntegral $! ByteString.length fracStr+ !e <- (satisfy (\w -> w == 'e' || w == 'E') *> decimal') <|> pure 0+ let !mantissa = wholePart * 10^shift + fracPart+ let !power = e - shift+ ws+ pure $! scientific mantissa (fromIntegral power)+ where+ decimal' = peekChar' >>= \case+ '+' -> skip1 *> decimal True+ '-' -> skip1 *> decimal False+ c | isDigit c -> decimal True+ _ -> fail "Expected + or - or digit (scientific notation power)"+++--- Strings ---+++character :: Parser Char+character = skip1 >> peekChar' >>= \case+ '\\' -> skip1 *> escapedChar <* char '\'' <* ws+ _ -> do+ chunk <- takeWhile (/= '\'')+ skip1+ ws+ text <- case decodeUtf8' chunk of+ Right x -> pure x+ Left _err -> fail "Incorrect utf8 in Char"+ case uncons text of+ Just (c, cs) | Text.length cs == 0 -> pure c+ _ -> fail "Incorrect length of Char content"++-- This is common for string and char. It seems by the spec @\'@ is incorrect+-- sequence for string, and @\"@ is incorrect sequence for char. I choose to+-- parse both for both for simplicity. Coming from C++ I want to call this+-- "undefined behaviour" in case of incorrect source RON file ;-)+escapedChar :: Parser Char+escapedChar = anyChar >>= \case+ '\\' -> pure '\\'+ '\"' -> pure '\"'+ '\'' -> pure '\''+ 'b' -> pure '\b'+ 'f' -> pure '\f'+ 'n' -> pure '\n'+ 'r' -> pure '\r'+ 't' -> pure '\t'+ 'u' -> do+ digits <- count 4 $ satisfy hexadecimalDigit+ let code = fromIntegral . buildNumber 16 True . ByteString8.pack $ digits+ pure $ chr code+ _ -> fail "Invalid escape sequence"++ronString :: Parser Text+ronString = skip1 *> (decodeUtf8 . toStrict . Builder.toLazyByteString <$> go mempty) <* skip1 <* ws+ where+ go :: Builder.Builder -> Parser Builder.Builder+ go !builder = do+ chunk <- takeTill (\c -> c == '\"' || c == '\\')+ let !r = builder <> Builder.byteString chunk+ peekChar' >>= \case+ '\"' -> pure r+ '\\' -> do+ skip1+ c <- escapedChar+ go $ r <> Builder.charUtf8 c+ _ -> error "takeTill took till wrong character (not \" or \\)"++ronRawString :: Parser Text+ronRawString = do+ delimeter <- takeWhile (== '#')+ char '\"'+ let go !builder = do+ chunk <- takeWhile (/= '\"')+ skip1+ let !r = builder <> Builder.byteString chunk+ (string delimeter *> pure r) <|> go (r <> Builder.char7 '\"')+ r <- decodeUtf8 . toStrict . Builder.toLazyByteString <$> go mempty+ ws+ pure r+++--- List, Map ---+++list :: Parser (Vector Value)+list = do+ skip1 -- [+ ws+ xs <- sepBy value (char ',' *> ws)+ option () $ char ',' *> ws+ char ']'+ ws+ pure . Vector.fromList $ xs++ronMap :: Parser (Map Value Value)+ronMap = do+ skip1 -- {+ ws+ let pair = do+ k <- value+ char ':'+ ws+ v <- value+ pure (k, v)+ xs <- sepBy pair (char ',' *> ws)+ option () $ char ',' *> ws+ char '}'+ ws+ pure . Map.fromList $ xs+++--- Algeraic types+++recordOrTuple :: Text -> Parser Value+recordOrTuple name = skip1 >> ws >> peekChar' >>= \case+ -- either a value or an identifier (or end)+ -- identifier overlaps with 'record' field+ ')' -> skip1 *> ws *> pure (Unit name)+ 'r' -> skip1 >> peekChar' >>= \case+ c | c == '#' || c == '\"' -> do+ val <- String <$> ronRawString+ ws+ Tuple name <$> tupleAndComma [val]+ | otherwise -> common (Just 'r')+ c | startsIdentifier c -> common Nothing+ -- not starting an identifier means it's not a 'record' field, so a 'tuple'+ | otherwise -> Tuple name <$> tuple []+ where+ common mbHead = do+ ident <- decodeUtf8 . maybe id cons mbHead <$> takeWhile isKeyword+ ws+ peekChar' >>= \case+ ':' -> skip1 *> ws *> do+ v <- value+ Record name <$> recordAndComma [(ident, v)]+ '(' -> do -- a 'tuple' with first element as a 'tuple' or 'record'+ val <- recordOrTuple ident+ Tuple name <$> tupleAndComma [val]+ ',' -> skip1 *> ws *> (Tuple name <$> tuple [Unit ident])+ ')' -> skip1 *> ws *> pure (Tuple name (Vector.fromList [Unit ident]))+ _ -> fail "Expecting expecting ':', ',' or '('"+++tuple, tupleAndComma :: [Value] -> Parser (Vector Value)+tuple initial = do+ xs <- sepBy value (char ',' *> ws)+ option () $ char ',' *> ws+ char ')'+ ws+ pure . Vector.fromList $ initial <> xs+tupleAndComma initial = anyChar >>= \case+ ',' -> ws *> tuple initial+ ')' -> ws *> pure (Vector.fromList initial)+ _ -> fail "Expecting ',' or ')' in tuple"++record, recordAndComma :: [(Text, Value)] -> Parser (Map Text Value)+record initial = do+ let pair = do+ k <- liftA2 cons (satisfy startsIdentifier) (takeWhile isKeyword)+ ws+ char ':'+ ws+ v <- value+ pure (decodeUtf8 k, v)+ xs <- sepBy pair (char ',' *> ws)+ option () $ char ',' *> ws+ char ')'+ ws+ pure . Map.fromList $ initial <> xs+recordAndComma initial = anyChar >>= \case+ ',' -> ws *> record initial+ ')' -> ws *> pure (Map.fromList initial)+ _ -> fail "Expecting ',' or ')' in record"++-- | Algebraic struct (named unit, 'record', 'tuple') or a raw string+identifierLike :: Char -> Parser Value+identifierLike 'r' = skip1 >> peekChar >>= \case+ Nothing -> pure $ Unit "r"+ Just '#' -> String <$> ronRawString+ Just '\"' -> String <$> ronRawString+ _ -> do+ name <- decodeUtf8 . cons 'r' <$> takeWhile isKeyword+ ws+ peekChar >>= \case+ Just '(' -> recordOrTuple name+ _ -> ws *> pure (Unit name)+identifierLike _ = do+ name <- decodeUtf8 <$> takeWhile isKeyword+ ws+ peekChar >>= \case+ Just '(' -> recordOrTuple name+ _ -> ws *> pure (Unit name)+++--- Common ---++-- | Whitespace and comment skipper+ws :: Parser ()+ws = skipWhile isSpace >> peekChar >>= \case+ Nothing -> pure ()+ Just c | c == '/' -> skip1 >> anyChar >>= \case+ '/' -> skipWhile (/= '\n') >> endOr skip1 >> ws+ '*' -> goMultiline (1 :: Int)+ _ -> fail "Unexpected '/', not followed by a comment starting"+ _ -> pure () -- not a comment+ where+ goMultiline 0 = ws -- end of multiline comment, try taking some new whitespace+ goMultiline level = do+ skipWhile (\c -> c /= '*' && c /= '/')+ endOr $ anyChar >>= \case+ '*' -> endOr $ anyChar >>= \case+ '/' -> goMultiline $! level - 1+ _ -> goMultiline level+ '/' -> endOr $ anyChar >>= \case+ '*' -> goMultiline $! level + 1+ _ -> goMultiline level+ _ -> error "skipWhile skipped until unexpected character"++isSpace c = c == ' ' || c == '\n' || c == '\r' || c == '\t'+isKeyword c = isAlphaNum c || c == '_' || c == '\''+startsNumber c = c == '+' || c == '-' || c == '.' || decimalDigit c+startsString c = c == '\"'+startsList c = c == '['+startsMap c = c == '{'+startsStruct c = c == '('+startsIdentifier c = isAlpha c || c == '_' -- this can also be a raw string+startsChar c = c == '\''++binaryDigit c = c == '0' || c == '1'+octalDigit c = binaryDigit c || c == '2' || c == '3' || c == '4'+ || c == '5' || c == '6' || c == '7'+decimalDigit c = octalDigit c || c == '8' || c == '9'+hexadecimalDigit c = decimalDigit c+ || c == 'a' || c == 'b' || c == 'c' || c == 'd' || c == 'e' || c == 'f'+ || c == 'A' || c == 'B' || c == 'C' || c == 'D' || c == 'E' || c == 'F'++skip1 = skip (const True)+endOr parser = atEnd >>= \case {True -> pure (); False -> parser}+++--- Exceptions+++-- | Error parsing 'ByteString' to 'Value'+newtype ParseError = ParseError String+ deriving (Show, Typeable)++-- | Error parsing 'Value' to custom type+newtype DecodeError = DecodeError String+ deriving (Show, Typeable)++instance Exception ParseError+instance Exception DecodeError
+ src/Data/Ron/Serialize.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE RecordWildCards #-}++-- | Definitions for serializing values into bytes. When serializing, you must+-- choose a formatting option defined at 'SerializeSettings'+module Data.Ron.Serialize+ ( encode, encodeFile+ , dumps, dumpFile+ -- * Style options+ , SerializeSettings (..)+ , haskellStyle, rustStyle, compactStyle+ , CommaStyle (..)+ -- * Low-level builders+ , ronBuilder+ ) where++import Data.ByteString.Builder (Builder, toLazyByteString, byteString, integerDec, char7, string7, hPutBuilder)+import Data.ByteString.Builder.Prim (primBounded, condB, (>$<), (>*<), liftFixedToBounded, word16HexFixed)+import Data.ByteString.Builder.Scientific (scientificBuilder)+import Data.Char (ord)+import Data.List (intersperse)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8, encodeUtf8BuilderEscaped)+import Data.Ron.Class (ToRon (toRon))+import Data.Word (Word8)+import Test.QuickCheck (Arbitrary, arbitrary, chooseEnum)+import System.IO (IOMode (WriteMode), hSetBinaryMode, hSetBuffering, BufferMode (BlockBuffering), withFile)++import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Builder.Prim as Prim+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Vector as Vector++import Data.Ron.Value+++-- | Style of comma in compound values+data CommaStyle+ = CommaHistoric+ -- ^ Like in json, comma after value without trailing+ | CommaTrailing+ -- ^ Comma after value, including last element+ | CommaLeading+ -- ^ Haskell style, comma at line start+ deriving (Eq, Show, Bounded, Enum)++data SerializeSettings = SerializeSettings+ { commaStyle :: !CommaStyle+ -- ^ How to separate values in compounds (tuples, records, maps, lists)+ , indent :: !Int+ -- ^ Amount of spaces to indent with. Setting this to zero also disables+ -- line breaks+ , singleElementSpecial :: !Bool+ -- ^ When a compound type only contains one element, this compound value is+ -- printed on one line+ , unpackToplevel :: !Bool+ -- ^ Toplevel record and list are unpacked to not include the constructor+ -- and brackets. This is useful for human-consumed files, and looks similar+ -- to yaml but with commas. Warning: ron-rs doesn't support reading this+ , openBracketOnSameLine :: !Bool+ -- ^ For compound types, does the opening bracket go on a new line or stays+ -- on the same line as the constructor+ , closeBracketOnSameLine :: !Bool+ -- ^ For compound types, does the closing bracket go on a new line or stays+ -- on the same line as the last element. Setting this to True is a popular+ -- default in some haskell autoformat programs+ , spaceAfterColon :: !Bool+ -- ^ Should a space character be put after colon in records and maps.+ -- Useful as @False@ for compact representation+ } deriving (Eq, Show)++-- | Style similar to what is produced in haskell with stylish-haskell or+-- hindent.+--+-- * Uses indent size of 4+--+-- * Unpacks top level values+haskellStyle :: SerializeSettings+haskellStyle = SerializeSettings+ { commaStyle = CommaLeading+ , indent = 4+ , singleElementSpecial = True+ , unpackToplevel = True+ , openBracketOnSameLine = False+ , closeBracketOnSameLine = False+ , spaceAfterColon = True+ }++-- | Style similar to what is produced by rustfmt, or by ron-rs itself+rustStyle :: SerializeSettings+rustStyle = SerializeSettings+ { commaStyle = CommaTrailing+ , indent = 4+ , singleElementSpecial = True+ , unpackToplevel = False+ , openBracketOnSameLine = True+ , closeBracketOnSameLine = False+ , spaceAfterColon = True+ }++-- | All whitespace is disabled. Does not unpack toplevel for compatability, so+-- you can set that if you want an even compacter style that can't be read by+-- ron-rs+compactStyle :: SerializeSettings+compactStyle = SerializeSettings+ { commaStyle = CommaHistoric+ , indent = 0+ , singleElementSpecial = True+ , unpackToplevel = False+ , openBracketOnSameLine = True+ , closeBracketOnSameLine = True+ , spaceAfterColon = False+ }++-- | Serialize a value to a lazy bytestring. For settings you can use+-- 'haskellStyle' or 'rustStyle' or 'compactStyle'+encode :: ToRon a => SerializeSettings -> a -> Lazy.ByteString+encode settings = dumps settings . toRon++-- | Serialize a value into a file. For settings you can use+-- 'haskellStyle' or 'rustStyle' or 'compactStyle'+encodeFile :: ToRon a => SerializeSettings -> FilePath -> a -> IO ()+encodeFile settings path = dumpFile settings path . toRon++-- | Serialize a RON value to a lazy bytestring. You probably want to use+-- 'encode' instead+dumps :: SerializeSettings -> Value -> Lazy.ByteString+dumps settings = toLazyByteString . ronBuilder settings++-- | Serialize a RON value into a file. You probably want to use 'encodeFile'+-- instead+dumpFile :: SerializeSettings -> FilePath -> Value -> IO ()+dumpFile settings path value = withFile path WriteMode $ \handle -> do+ -- recommended in builder package+ hSetBinaryMode handle True+ hSetBuffering handle $ BlockBuffering Nothing -- hmm+ hPutBuilder handle $ ronBuilder settings value++-- | The builder producing the serialized representation. You can use this to+-- write ron to outputs not supported by this library, like pipes or conduits+ronBuilder :: SerializeSettings -> Value -> Builder+ronBuilder SerializeSettings {..} = toplevel where+ deeper !lvl = lvl + indent+ nl = if indent == 0 then mempty else char7 '\n'+ shift lvl = string7 $ replicate lvl ' '+ bracketOpen afterColon lvl c+ | indent == 0 = char7 c+ | openBracketOnSameLine = spc <> char7 c <> nl <> shift (deeper lvl)+ <> if commaStyle == CommaLeading+ then char7 ' ' <> char7 ' '+ else mempty+ | commaStyle == CommaLeading =+ nl <> shift (deeper lvl) <> char7 c <> char7 ' '+ | otherwise = nl <> shift lvl <> char7 c <> nl <> shift (deeper lvl)+ where spc = if afterColon && spaceAfterColon then char7 ' ' else mempty+ bracketClose lvl c+ | indent == 0 = char7 c+ | closeBracketOnSameLine = char7 ' ' <> char7 c+ | commaStyle == CommaLeading = nl <> shift (deeper lvl) <> char7 c+ | otherwise = nl <> shift lvl <> char7 c+ comma lvl = if commaStyle == CommaLeading+ then nl <> shift lvl <> string7 ", "+ else char7 ',' <> nl <> shift lvl+ trailingComma = if commaStyle == CommaTrailing+ then char7 ','+ else mempty+ toplevel = if unpackToplevel+ then \case+ -- Those two looks bad with leading comma, not sure what to do.+ -- Don't want to turn them into trailing/historic comma for+ -- toplevel only, since I personally always forget to put it after+ -- the previous element+ List xs | not (Vector.null xs) -> listContent 0 xs+ Record name xs | Text.null name -> recordContent 0 xs+ v -> go startIndent v+ else go startIndent+ -- special handling for haskell-style: don't indent the topmost block+ where startIndent = if commaStyle == CommaLeading+ then negate indent+ else 0+ --+ go = go' False+ go' !afterColon !lvl = \case+ Integral x -> spc <> integerDec x+ Floating x -> spc <> scientificBuilder x+ Char x -> spc <> char7 '\'' <> encodeChar x <> char7 '\''+ String x -> spc <> char7 '"' <> encodeString x <> char7 '"'+ Unit name -> spc <> if Text.null name+ then string7 "()"+ else fromText name+ List xs+ | null xs -> spc <> string7 "[]"+ | singleElementSpecial && isSimple (List xs)+ -> let !x = Vector.unsafeHead xs+ open = if indent /= 0 then string7 "[ " else char7 '['+ close = if indent /= 0 then string7 " ]" else char7 ']'+ in spc <> open <> go lvl x <> close+ | otherwise -> bracketOpen afterColon lvl '[' <> listContent (deeper lvl) xs <> bracketClose lvl ']'+ Map xs+ | null xs -> spc <> string7 "{}"+ | singleElementSpecial && isSimple (Map xs)+ -> let (!k, !v) = head . Map.toList $ xs+ open = if indent /= 0 then string7 "{ " else char7 '{'+ close = if indent /= 0 then string7 " }" else char7 '}'+ in spc <> open <> go lvl k <> char7 ':' <> go' True lvl v <> close+ | otherwise -> bracketOpen afterColon lvl '{' <> mapContent (deeper lvl) xs <> bracketClose lvl '}'+ Tuple name xs+ | singleElementSpecial && isSimple (Tuple name xs) ->+ let !x = Vector.unsafeHead xs+ nameB = if Text.null name+ then mempty+ else fromText name <> char7 ' '+ open = if indent /= 0 then string7 "( " else char7 '('+ close = if indent /= 0 then string7 " )" else char7 ')'+ in spc <> nameB <> open <> go lvl x <> close+ | Text.null name ->+ bracketOpen afterColon lvl '(' <> listContent (deeper lvl) xs <> bracketClose lvl ')'+ | otherwise ->+ spc <> fromText name <> bracketOpen True lvl '(' <> listContent (deeper lvl) xs <> bracketClose lvl ')'+ Record name xs+ | singleElementSpecial && isSimple (Record name xs) ->+ let (!k, !v) = head . Map.toList $ xs+ nameB = if Text.null name+ then mempty+ else fromText name <> char7 ' '+ open = if indent /= 0 then string7 "( " else char7 '('+ close = if indent /= 0 then string7 " )" else char7 ')'+ in spc <> nameB <> open <> fromText k <> char7 ':' <> go' True lvl v <> close+ | Text.null name ->+ bracketOpen afterColon lvl '(' <> recordContent (deeper lvl) xs <> bracketClose lvl ')'+ | otherwise ->+ spc <> fromText name <> bracketOpen True lvl '(' <> recordContent (deeper lvl) xs <> bracketClose lvl ')'+ where+ spc = if afterColon && spaceAfterColon then char7 ' ' else mempty+ --+ listContent lvl = (<> trailingComma) . mconcat . intersperse (comma lvl) . map (go lvl) . Vector.toList+ --+ mapContent lvl = (<> trailingComma) . mconcat . intersperse (comma lvl) . map toElem . Map.toList where+ toElem (k, v) = go lvl k <> char7 ':' <> go' True lvl v+ --+ recordContent lvl = (<> trailingComma) . mconcat . intersperse (comma lvl) . map toElem . Map.toList where+ toElem (k, v) = fromText k <> char7 ':' <> go' True lvl v++-- | Can the value be nicely rendered on a single line? True for non-compounds and single-value compounds+isSimple :: Value -> Bool+isSimple (Integral _) = True+isSimple (Floating _) = True+isSimple (Char _) = True+isSimple (String _) = True+isSimple (Unit _) = True+isSimple (List elems) = case Vector.uncons elems of+ Nothing -> True+ Just (x, xs)+ | null xs -> isSimple x+ | otherwise -> False+isSimple (Map xs)+ | null xs = True+ | length xs == 1 = case Map.toList xs of+ [(k, v)] -> isSimple k && isSimple v+ _ -> False+ | otherwise = False+isSimple (Tuple _ elems) = case Vector.uncons elems of+ Nothing -> True+ Just (x, xs)+ | null xs -> isSimple x+ | otherwise -> False+isSimple (Record _ xs)+ | null xs = True+ | length xs == 1 = case Map.toList xs of+ [(_, v)] -> isSimple v+ _ -> False+ | otherwise = False++fromText :: Text -> Builder+fromText = byteString . encodeUtf8++encodeString :: Text -> Builder+encodeString = encodeUtf8BuilderEscaped escape+ where+ escape+ = condB (== c2w '\\' ) (ascii2 ('\\','\\'))+ . condB (== c2w '\b' ) (ascii2 ('\\','b' ))+ . condB (== c2w '\f' ) (ascii2 ('\\','f' ))+ . condB (== c2w '\n' ) (ascii2 ('\\','n' ))+ . condB (== c2w '\r' ) (ascii2 ('\\','r' ))+ . condB (== c2w '\t' ) (ascii2 ('\\','t' ))+ . condB (== c2w '\"' ) (ascii2 ('\\','\"' ))+ . condB (>= c2w ' ' ) (liftFixedToBounded Prim.word8)+ $ liftFixedToBounded hexEscape -- fallback for chars < 0x20+ hexEscape = (\c -> ('\\', ('u', fromIntegral c))) >$<+ Prim.char8 >*< Prim.char8 >*< word16HexFixed+ ascii2 cs = liftFixedToBounded $ const cs >$< Prim.char7 >*< Prim.char7+ c2w = fromIntegral . ord :: Char -> Word8++encodeChar :: Char -> Builder+encodeChar = primBounded escape+ where+ escape+ = condB (== '\\' ) (unicode2 ('\\','\\'))+ . condB (== '\b' ) (unicode2 ('\\','b' ))+ . condB (== '\f' ) (unicode2 ('\\','f' ))+ . condB (== '\n' ) (unicode2 ('\\','n' ))+ . condB (== '\r' ) (unicode2 ('\\','r' ))+ . condB (== '\t' ) (unicode2 ('\\','t' ))+ . condB (== '\'' ) (unicode2 ('\\','\'' ))+ . condB (>= ' ' ) Prim.charUtf8+ $ liftFixedToBounded hexEscape -- fallback for chars < 0x20+ hexEscape = (\c -> ('\\', ('u', fromIntegral . ord $ c))) >$<+ Prim.char8 >*< Prim.char8 >*< word16HexFixed+ unicode2 cs = const cs >$< Prim.charUtf8 >*< Prim.charUtf8++--- QuickCheck++instance Arbitrary CommaStyle where+ arbitrary = chooseEnum (minBound, maxBound)++instance Arbitrary SerializeSettings where+ arbitrary = SerializeSettings+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary
+ src/Data/Ron/Value.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 800+-- a) THQ works on cross-compilers and unregisterised GHCs+-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this)+-- c) removes one hindrance to have code inferred as SafeHaskell safe+{-# LANGUAGE TemplateHaskellQuotes #-}+#else+{-# LANGUAGE TemplateHaskell #-}+#endif++module Data.Ron.Value+ ( Value (..)+ ) where++import Control.Applicative (liftA2)+import Control.DeepSeq (NFData (rnf))+import Data.Hashable (Hashable, hashWithSalt)+import Data.Foldable (foldl')+import Data.Map.Strict (Map)+import Data.Text (Text)+import Data.Scientific (Scientific, fromFloatDigits)+import Data.Vector (Vector)+import Test.QuickCheck (sized, Arbitrary, arbitrary, Gen, oneof, shuffle, choose, elements, listOf)++import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import qualified Language.Haskell.TH.Syntax as TH+++-- Alternatives:+-- Integer -> Int, Int64+-- Scientific -> Double+-- Map -> HashMap, List of tuples, Vector of tuples (especially for record)+-- Vector -> List (for tuples)+-- NonEmpty for tuple and record? Or unify unit with both of them+--+-- | A RON value represented in haskell. This is the intermediate+-- representation between string and your own type.+--+-- @()@ is represented as @Unit ""@. Anonymous records and tuples are+-- similarily represented by having an empty name.+--+-- 'Tuple' and 'Record' contents are guaranteed to be not empty when parsed,+-- since the empty contents denote a 'Unit'. Attempting to dump an empty tuple+-- or record may produce unexpected results, so don't do that, use 'Unit's instead.+data Value+ = Integral !Integer+ | Floating !Scientific+ | Char !Char+ | String !Text+ | List !(Vector Value)+ | Map !(Map Value Value)+ | Unit !Text+ | Tuple !Text !(Vector Value)+ | Record !Text !(Map Text Value)+ deriving (Eq, Show, Ord)++--- Hashable ---++hashValue :: Int -> Value -> Int+hashValue s (Integral x) = s `hashWithSalt` (0::Int) `hashWithSalt` x+hashValue s (Floating x) = s `hashWithSalt` (1::Int) `hashWithSalt` x+hashValue s (Char x) = s `hashWithSalt` (2::Int) `hashWithSalt` x+hashValue s (String x) = s `hashWithSalt` (3::Int) `hashWithSalt` x+hashValue s (List xs) = foldl' hashWithSalt+ (s `hashWithSalt` (4::Int))+ xs+hashValue s (Map xs) = Map.foldlWithKey'+ (\acc k v -> acc `hashWithSalt` k `hashWithSalt` v)+ (s `hashWithSalt` (5::Int))+ xs+hashValue s (Unit n) = s `hashWithSalt` (6::Int) `hashWithSalt` n+hashValue s (Tuple n xs) = foldl' hashWithSalt+ (s `hashWithSalt` (7::Int) `hashWithSalt` n)+ xs+hashValue s (Record n xs) = Map.foldlWithKey'+ (\acc k v -> acc `hashWithSalt` k `hashWithSalt` v)+ (s `hashWithSalt` (8::Int) `hashWithSalt` n)+ xs++instance Hashable Value where+ hashWithSalt = hashValue++--- Template Haskell ---++instance TH.Lift Value where+ lift (Integral x) = [| Integral x |]+ lift (Floating x) = [| Floating x |]+ lift (Char x) = [| Char x |]+ lift (String x) = [| String (Text.pack s) |]+ where s = Text.unpack x+ lift (List x) = [| List (Vector.fromList a) |]+ where a = Vector.toList x+ lift (Map x) = [| Map (Map.fromAscList m) |]+ where m = Map.toAscList x+ lift (Unit x) = [| Unit (Text.pack s) |]+ where s = Text.unpack x+ lift (Tuple n x) = [| Tuple (Text.pack s) (Vector.fromList a)|]+ where s = Text.unpack n+ a = Vector.toList x+ lift (Record n x) = [| Record (Text.pack s) (Map.fromAscList m) |]+ where s = Text.unpack n+ m = Map.toAscList x++#if MIN_VERSION_template_haskell(2,17,0)+ liftTyped = TH.unsafeCodeCoerce . TH.lift+#elif MIN_VERSION_template_haskell(2,16,0)+ liftTyped = TH.unsafeTExpCoerce . TH.lift+#endif++--- QuickCheck++instance Arbitrary Value where+ arbitrary = sized arbValue+ -- what the hell is 'shrink'?++arbValue :: Int -> Gen Value+arbValue = arbValue' True++arbValue' :: Bool -> Int -> Gen Value+arbValue' allowFloat size+ | size <= 0 = oneof $+ [ Integral <$> arbitrary+ , Char <$> arbitrary+ , String <$> arbText+ , Unit <$> arbIdentifier+ ] <> if allowFloat then [Floating . fromFloatDigits <$> arbitrary @Double] else []+ | otherwise = oneof+ [ List <$> arbList size+ , Map <$> arbMap size+ , Tuple "" <$> arbTuple size+ , Record "" <$> arbRecord size+ , liftA2 Tuple arbIdentifier (arbTuple size)+ , liftA2 Record arbIdentifier (arbRecord size)+ ]++arbText :: Gen Text+arbText = Text.pack <$> arbitrary++arbIdentifier :: Gen Text+arbIdentifier = do+ h <- arbStartIdentifier+ t <- listOf arbKeyword+ pure . Text.pack $ h:t+ where+ starts = ['a'..'z'] <> ['A'..'Z'] <> ['_']+ keyword = starts <> ['0'..'9'] <> ['\'']+ arbStartIdentifier = elements starts+ arbKeyword = elements keyword++arbList :: Int -> Gen (Vector Value)+arbList size = do+ sizes <- arbPartition (size - 1)+ Vector.fromList <$> traverse arbValue sizes++arbMap :: Int -> Gen (Map Value Value)+arbMap size = do+ sizes <- arbPartition (size - 1)+ let makeElem s = liftA2 (,) (arbValue' False 0) (arbValue s)+ Map.fromList <$> traverse makeElem sizes++arbTuple :: Int -> Gen (Vector Value)+arbTuple size = do+ sizes <- arbPartition (size - 1)+ firstSize <- if size <= 1 then pure 0 else choose (1, size-1)+ first <- arbValue firstSize+ Vector.fromList . (first:) <$> traverse arbValue sizes++arbRecord :: Int -> Gen (Map Text Value)+arbRecord size = do+ sizes <- arbPartition (size - 1)+ let makeElem s = liftA2 (,) arbIdentifier (arbValue s)+ firstSize <- if size <= 1 then pure 0 else choose (1, size-1)+ first <- makeElem firstSize+ Map.fromList . (first:) <$> traverse makeElem sizes++-- | Produces new sizes for recursion+arbPartition :: Int -> Gen [Int]+arbPartition size = case compare size 1 of+ LT -> pure []+ EQ -> pure [1]+ GT -> shuffle =<< go size []+ where+ go 0 xs = pure xs+ go !s xs = do+ x <- choose (1, s)+ go (s - 1) (x:xs)++--- Deepseq++instance NFData Value where+ rnf (Integral x) = rnf x+ rnf (Floating x) = rnf x+ rnf (Char x) = rnf x+ rnf (String x) = rnf x+ rnf (List x) = rnf x+ rnf (Map x) = rnf x+ rnf (Unit n) = rnf n+ rnf (Tuple n x) = rnf n `seq` rnf x+ rnf (Record n x) = rnf n `seq` rnf x
+ src/Data/Ron/Value/Internal.hs view
@@ -0,0 +1,44 @@+module Data.Ron.Value.Internal+ where++import Control.Applicative ((<|>))+import Data.Foldable (msum)+import Data.Maybe (isNothing)+import Data.Ron.Class (ToRon (toRon))+import Data.Text (pack)++import qualified Data.Map.Strict as Map+import qualified Data.Vector as Vector++import Data.Ron.Value++(!==!) :: (Eq a, ToRon a) => a -> a -> Maybe (Value, Value)+a !==! b = if a == b then Nothing else Just (toRon a, toRon b)++vshow :: Show a => a -> Value+vshow = String . pack . show++similar' :: Value -> Value -> Bool+similar' a b = isNothing $ similar a b++-- | Like '==' but not precise for floats+similar :: Value -> Value -> Maybe (Value, Value)+similar (Integral a) (Integral b) = a !==! b+similar (Floating a) (Floating b) = if abs (a - b) < 0.001 then Nothing else Just (Floating a, Floating b)+similar (Char a) (Char b) = a !==! b+similar (String a) (String b) = a !==! b+similar (List a) (List b) = vecSimilar a b+similar (Map a) (Map b) = mapSimilar a b+similar (Unit n) (Unit m) = n !==! m+similar (Tuple n a) (Tuple m b) = (n !==! m) <|> vecSimilar a b+similar (Record n a) (Record m b) = (n !==! m) <|> mapSimilar a b+similar _ _ = Just (String "different types", Unit "")++vecSimilar :: Vector.Vector Value -> Vector.Vector Value -> Maybe (Value, Value)+vecSimilar a b = msum $ Vector.zipWith similar a b++mapSimilar :: (Eq k, Show k) => Map.Map k Value -> Map.Map k Value -> Maybe (Value, Value)+mapSimilar a b = go (Map.toAscList a) (Map.toAscList b) where+ go [] [] = Nothing+ go ((ak, av):as) ((bk, bv):bs) = (if ak == bk then Nothing else Just (vshow ak, vshow bk)) <|> (av `similar` bv) <|> go as bs+ go x y = Just (toRon $ length x, toRon $ length y) -- different amount of values
+ test/DerivingVia.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DataKinds #-}+{-# LANGUAGE OverloadedLists #-}+module DerivingVia+ ( derivingViaTests+ ) where++import Data.Ron.Class (ToRon (..), FromRon (..), RonSettings (..))+import Data.Ron.Value (Value (..))+import GHC.Generics (Generic)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty (testGroup)++import Data.Ron.Class.Deriving++data Record1 = Record1+ { _rField :: Int+ , _rOtherField :: Maybe Int+ }+ deriving (Eq, Show, Generic)+ deriving (ToRon, FromRon) via RonWith+ '[ FieldsDropPrefix+ , FieldsToSnakeCase+ , ConvertWith ImplicitSome+ ] Record1++record1 = Record1 1 (Just 2)+record1ron = Record "Record1"+ [ ("field", Integral 1)+ , ("other_field", Integral 2)+ ]++data AppendA+data AppendB+instance ReflectSettingsOptions AppendA where+ reflectS _ s@RonSettings {fieldModifier} = s+ { fieldModifier = (<> "aaa") . fieldModifier }+instance ReflectSettingsOptions AppendB where+ reflectS _ s@RonSettings {fieldModifier} = s+ { fieldModifier = (<> "bbb") . fieldModifier }++newtype Record2 = Record2+ { field' :: Int+ }+ deriving (Eq, Show, Generic)+ deriving (ToRon, FromRon) via RonWith+ '[ AppendA+ , AppendB+ ] Record2++record2 = Record2 1337+record2ron = Record "Record2" [ ("field'aaabbb", Integral 1337) ]++derivingViaTests = testGroup "deriving via"+ [ testGroup "inbuilt field modifiers are correct"+ [ testCase "encode" $+ toRon record1 @?= record1ron+ , testCase "decode" $+ fromRon record1ron @?= Right record1+ ]+ , testGroup "options apply left to right"+ [ testCase "encode" $+ toRon record2 @?= record2ron+ , testCase "decode" $+ fromRon record2ron @?= Right record2+ ]+ ]
+ test/File.hs view
@@ -0,0 +1,39 @@+module File+ ( fileTests+ ) where++import Control.Exception (bracket)+import Data.Ron.Deserialize (decodeFile, loadFile)+import Data.Ron.Serialize (encodeFile, haskellStyle)+import Data.Ron.Value.Internal (similar')+import System.Directory (getTemporaryDirectory, removeFile)+import System.IO (hClose, openTempFile)+import Test.Tasty (testGroup)+import Test.Tasty.HUnit (testCase, (@?=), (@?))++withTempFile :: String -> (FilePath -> IO a) -> IO a+withTempFile template callback = do+ tempDir <- getTemporaryDirectory+ path <- bracket+ (openTempFile tempDir template)+ (\(p, h) -> hClose h >> removeFile p)+ (pure . fst)+ bracket+ (pure path)+ removeFile+ callback++writeAndRead = withTempFile "ron" $ \path -> do+ let value = Just ()+ encodeFile haskellStyle path value+ value' <- decodeFile path+ value @?= value'++readExample = do+ val <- loadFile "example.ron"+ val `similar'` val @? "Value is not similar to itself"++fileTests = testGroup "file tests"+ [ testCase "write and read to file" writeAndRead+ , testCase "read example file" readExample+ ]
+ test/ForExample.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedLists #-}+module ForExample+ ( exampleTests+ ) where++import Data.Ron.Deserialize (loads)+import Data.Ron.Value (Value (..))+import Data.ByteString.Char8 (ByteString, unlines)+import Data.Text.Encoding (encodeUtf8)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty (testGroup)++import Prelude hiding (unlines)++example1, example2, example3 :: ByteString+example1_ron, example2_ron, example3_ron :: Value++example1 = unlines . map encodeUtf8 $+ [ "// RON supports comments"+ , "/* even multiline comments */"+ , "/* even /* embedded /* multiline */ comments */ /* */ */"+ , "TopLevelRecord ("+ , " field: Compound (\"this\", \"is\", \"a\", \"compound\", 123),"++ , " all_datatypes: ("+ , " int: 1_337_322_228,"+ , " float: 2.71828,"+ , " char: 'ы',"+ , " string: \"hello string\n\","+ , " raw_string: r##\"raw \"string\", still unicode\"##,"+ , " list: [\"homogenous\", \"elements\"],"+ , " map: {"+ , " \"value\": \"as keys\","+ , " \"also\": \"homogenous\","+ , " },"+ , " tuple: SomeTuple(0, OtherTuple(\"with\", \"stuff\")),"+ , " record: SomeRecord ("+ , " like: \"this one you're looking at\","+ , " not_homogenous: 2022,"+ , " ),"+ , " unit_values: ["+ , " (), // regular unit"+ , " NamedUnit,"+ , " NamedUnitWithBraces(),"+ , " ]"+ , " )"+ , ")"+ ]+example1_ron = Record "TopLevelRecord"+ [ ( "field", Tuple "Compound"+ [ String "this"+ , String "is"+ , String "a"+ , String "compound"+ , Integral 123+ ]+ )+ , ("all_datatypes", Record ""+ [ ("int", Integral 1337322228)+ , ("float", Floating 2.71828)+ , ("char", Char 'ы')+ , ("string", String "hello string\n")+ , ("raw_string", String "raw \"string\", still unicode")+ , ("list", List [String "homogenous", String "elements"])+ , ( "map", Map+ [ (String "value", String "as keys")+ , (String "also", String "homogenous")+ ]+ )+ , ("tuple", Tuple "SomeTuple"+ [ Integral 0, Tuple "OtherTuple" [String "with", String "stuff"] ]+ )+ , ("record", Record "SomeRecord"+ [ ("like", String "this one you're looking at")+ , ("not_homogenous", Integral 2022)+ ]+ )+ , ("unit_values", List [Unit "", Unit "NamedUnit", Unit "NamedUnitWithBraces"])+ ]+ )+ ]++example2 = unlines+ [ "\"ron-rs document\","+ , "\"with a toplevel list\","+ , "\"denoted by just elements with commas\","+ ]+example2_ron = List+ [ String "ron-rs document"+ , String "with a toplevel list"+ , String "denoted by just elements with commas"+ ]++example3 = unlines+ [ "field1: SomeValue,"+ , "field2: \"other value\","+ , "rstarting_field: 123,"+ ]+example3_ron = Record ""+ [ ("field1", Unit "SomeValue")+ , ("field2", String "other value")+ , ("rstarting_field", Integral 123)+ ]++example4 = "r_at_start: Foobar(1),"+example4_ron = Record ""+ [ ("r_at_start", Tuple "Foobar" [Integral 1]) ]++exampleTests = testGroup "golden decodes"+ [ testCase "example1" $ loads example1 @?= Right example1_ron+ , testCase "example2" $ loads example2 @?= Right example2_ron+ , testCase "example3" $ loads example3 @?= Right example3_ron+ , testCase "example4" $ loads example4 @?= Right example4_ron+ ]
+ test/Generic.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveGeneric, OverloadedLists #-}+module Generic+ ( genericsTests+ ) where++import GHC.Generics (Generic)+import Data.Map.Strict (Map)+import Data.Ron.Class (ParseResult, FromRon (fromRon), ToRon (toRon))+import Data.Ron.Value (Value)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Word (Word8)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty (testGroup)++-- Adapted from ron-rs+data Config = Config+ { float :: (Float, Float)+ , tuple :: TupleStruct+ , map' :: Map Word8 Char+ , nested :: Nested+ , var :: Variant+ , array :: Vector ()+ } deriving (Eq, Show, Generic)++data TupleStruct = TupleStruct () Bool+ deriving (Eq, Show, Generic)++data Variant = A Word8 | B String+ deriving (Eq, Show, Generic)++data Nested = Nested+ { a :: Text+ , b :: Char+ } deriving (Eq, Show, Generic)++instance ToRon Nested+instance FromRon Nested+instance ToRon Variant+instance FromRon Variant+instance ToRon TupleStruct+instance FromRon TupleStruct+instance ToRon Config+instance FromRon Config++config = Config+ { float = (2.18, -1.1)+ , tuple = TupleStruct () False+ , map' = [(0, '1'), (1, '2'), (3, '5'), (8, '1')]+ , nested = Nested+ { a = "Hello from \"RON\""+ , b = 'b'+ }+ , var = A 0+ , array = [(), (), ()]+ }++data BigTuple = BigTuple+ Int+ Float+ String+ Text+ Integer+ Nested+ ()+ Variant+ deriving (Eq, Show, Generic)++instance ToRon BigTuple+instance FromRon BigTuple++bigTuple = BigTuple+ 1 2 "3" "4" 5 Nested { a = "6", b = '7' } () (B "8")++data BigEnum = C | D | E | F | G+ deriving (Eq, Show, Generic)++instance ToRon BigEnum+instance FromRon BigEnum++genericsTests = testGroup "generic instances"+ [ testCase "big record" $ roundtrip config @?= Right config+ , testCase "big tuple" $ roundtrip bigTuple @?= Right bigTuple+ , testCase "big enum" $ roundtrip C @?= Right C+ ]+ where+ roundtrip :: (ToRon a, FromRon a) => a -> ParseResult a+ roundtrip = fromRon . toRon
+ test/GenericOptions.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DeriveGeneric, OverloadedLists #-}+{-# LANGUAGE OverloadedLabels #-}+module GenericOptions+ ( genericOptionsTests+ ) where++import GHC.Generics (Generic)+import Data.Map.Strict (Map)+import Data.Ron.Class (ToRon, FromRon, toRonGeneric, fromRonGeneric, RonSettings (..), strictRonSettings)+import Data.Function ((&))+import Data.Ron.Value (Value (..))+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Word (Word8)+import Optics.Label ()+import Optics.Ron.Settings ()+import Optics.Operators ((.~))+import Optics.Optic ((%))+import Test.Tasty.HUnit (testCase, (@?=), (@=?))+import Test.Tasty (testGroup)++data MaybeFields = MaybeFields+ { f1 :: Int+ , f2 :: Maybe Int+ , f3 :: Maybe (Maybe Int)+ , rec :: Maybe MaybeFields+ } deriving (Eq, Show, Generic)++instance ToRon MaybeFields+instance FromRon MaybeFields++maybeFieldsNone = MaybeFields+ { f1 = 1+ , f2 = Nothing+ , f3 = Nothing+ , rec = Nothing+ }+maybeFieldsNoneRon = Record "MaybeFields"+ [ ("f1", Integral 1)+ ]++maybeFieldsSome = MaybeFields+ { f1 = 1+ , f2 = Just 2+ , f3 = Just $ Just 3+ , rec = Just MaybeFields+ { f1 = 11+ , f2 = Nothing+ , f3 = Nothing+ , rec = Nothing+ }+ }+maybeFieldsSomeRon = Record "MaybeFields"+ [ ("f1", Integral 1)+ , ("f2", Integral 2)+ , ("f3", Tuple "Some" [Integral 3])+ , ("rec", Record "MaybeFields"+ [ ("f1", Integral 11)+ , ("f2", Unit "None")+ , ("f3", Unit "None")+ , ("rec", Unit "None")+ ]+ )+ ]++encodeOptionalFieldsTests = testGroup "optional field encoding"+ [ testCase "all none" $+ enc maybeFieldsNone @?= maybeFieldsNoneRon+ , testCase "all present" $+ enc maybeFieldsSome @?= maybeFieldsSomeRon+ ]+ where+ enc = toRonGeneric settings+ settings = strictRonSettings &+ #encodeFlags % #implicitSome .~ True++decodeOptionalFieldsTests = testGroup "optional field decoding"+ [ testCase "all none" $+ Right maybeFieldsNone @=? dec maybeFieldsNoneRon+ , testCase "all none as None" $+ Right maybeFieldsNone @=? dec (Record "MaybeFields"+ [ ("f1", Integral 1)+ , ("f2", Unit "None")+ , ("f3", Unit "None")+ , ("rec", Unit "None")+ ]+ )+ , testCase "all present" $+ Right maybeFieldsSome @=? dec maybeFieldsSomeRon+ , testCase "all present as Some" $+ Right maybeFieldsSome @=? dec (Record "MaybeFields"+ [ ("f1", Integral 1)+ , ("f2", Tuple "Some" [Integral 2])+ , ("f3", Tuple "Some" [Tuple "Some" [Integral 3]])+ , ("rec", Tuple "Some" [Record "MaybeFields"+ [ ("f1", Integral 11)+ , ("f2", Unit "None")+ , ("f3", Unit "None")+ , ("rec", Unit "None")+ ]]+ )+ ]+ )+ ]+ where+ dec = fromRonGeneric settings+ settings = strictRonSettings &+ #decodeFlags % #implicitSome .~ True++data MaybeTuple = MaybeTuple+ Int+ (Maybe Int)+ (Maybe (Maybe Int))+ (Maybe MaybeTuple)+ deriving (Eq, Show, Generic)++instance ToRon MaybeTuple+instance FromRon MaybeTuple++maybeTupleNone = MaybeTuple+ 1+ Nothing+ Nothing+ Nothing+maybeTupleNoneRon = Tuple "MaybeTuple"+ [ Integral 1+ , Unit "None"+ , Unit "None"+ , Unit "None"+ ]++maybeTupleSome = MaybeTuple+ 1+ (Just 2)+ (Just $ Just 3)+ (Just $ MaybeTuple 1 Nothing Nothing Nothing)+maybeTupleSomeRon = Tuple "MaybeTuple"+ [ Integral 1+ , Integral 2+ , Tuple "Some" [Integral 3]+ , Tuple "MaybeTuple"+ [ Integral 1+ , Unit "None"+ , Unit "None"+ , Unit "None"+ ]+ ]++encodeOptionalTupleFieldsTests = testGroup "optional fields in tuple encoding"+ [ testCase "all none" $+ enc maybeTupleNone @?= maybeTupleNoneRon++ , testCase "all present" $+ enc maybeTupleSome @?= maybeTupleSomeRon+ ]+ where+ enc = toRonGeneric settings+ settings = strictRonSettings &+ #encodeFlags % #implicitSome .~ True++decodeOptionalTupleFieldsTests = testGroup "optional field in tuple decoding"+ [ testCase "all none" $+ Right maybeTupleNone @=? dec maybeTupleNoneRon+ , testCase "all present" $+ Right maybeTupleSome @=? dec maybeTupleSomeRon+ , testCase "all present as Some" $+ Right maybeTupleSome @=? dec (Tuple "MaybeTuple"+ [ Integral 1+ , Tuple "Some" [Integral 2]+ , Tuple "Some" [Tuple "Some" [Integral 3]]+ , Tuple "Some" [Tuple "MaybeTuple"+ [ Integral 1+ , Unit "None"+ , Unit "None"+ , Unit "None"+ ]]+ ]+ )+ ]+ where+ dec = fromRonGeneric settings+ settings = strictRonSettings &+ #decodeFlags % #implicitSome .~ True++singleConstructorTests = testGroup "omitting single constructor"+ [ testCase "record encoding" $+ toRonGeneric se maybeFieldsNone @?= Record "" [ ("f1", Integral 1) ]+ , testCase "tuple encoding" $+ toRonGeneric se maybeTupleNone @?= Tuple ""+ [ Integral 1, Unit "None", Unit "None", Unit "None" ]+ , testCase "record decoding" $+ Right maybeFieldsNone @=? fromRonGeneric sd+ (Record "" [ ("f1", Integral 1) ])+ , testCase "tuple decoding" $+ Right maybeTupleNone @=? fromRonGeneric sd+ (Tuple "" [ Integral 1, Unit "None", Unit "None", Unit "None" ])+ ]+ where+ se = strictRonSettings+ & ( #encodeFlags % #skipSingleConstructor .~ True )+ . ( #encodeFlags % #implicitSome .~ True )+ sd = strictRonSettings+ & ( #decodeFlags % #skipSingleConstructor .~ True )+ . ( #decodeFlags % #implicitSome .~ True )++genericOptionsTests = testGroup "generic options"+ [ encodeOptionalFieldsTests+ , decodeOptionalFieldsTests+ , encodeOptionalTupleFieldsTests+ , decodeOptionalTupleFieldsTests+ , singleConstructorTests+ ]
+ test/Optics/Ron/Settings.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}+module Optics.Ron.Settings+ () where++import Optics.TH (makeFieldLabelsWith, noPrefixFieldLabels)+import Data.Ron.Class (RonFlags, RonSettings)++makeFieldLabelsWith noPrefixFieldLabels ''RonFlags+makeFieldLabelsWith noPrefixFieldLabels ''RonSettings
+ test/Test.hs view
@@ -0,0 +1,38 @@+module Main where++import Data.ByteString.Lazy (toStrict)+import Data.Ron.Deserialize (loads)+import Data.Ron.Serialize (dumps, compactStyle)+import Data.Ron.Value.Internal (similar')+import Test.Tasty (defaultMain, testGroup, localOption)+import Test.Tasty.QuickCheck (testProperty, QuickCheckMaxSize(..))++import ForExample (exampleTests)+import File (fileTests)+import Generic (genericsTests)+import GenericOptions (genericOptionsTests)+import DerivingVia (derivingViaTests)+import Values (valuesTests)++main = defaultMain $ setMaxSize $ testGroup "properties"+ [ always_decodes+ , derivingViaTests+ , exampleTests+ , fileTests+ , genericOptionsTests+ , genericsTests+ , loads_dumps+ , valuesTests+ ]++setMaxSize = localOption $ QuickCheckMaxSize 30++always_decodes = testProperty "isRight . loads . dumps arbStyle $ x" $+ \style value -> case loads . toStrict . dumps style $ value of+ Left _err -> False+ Right _val -> True++loads_dumps = testProperty "loads . dumps compactStyle = id" $+ \value -> case loads . toStrict . dumps compactStyle $ value of+ Left err -> False+ Right value' -> value `similar'` value'
+ test/Values.hs view
@@ -0,0 +1,32 @@+module Values+ ( valuesTests+ ) where++import Data.Text (Text)+import Data.Ron.Deserialize (decode)+import Data.Ron.Serialize (dumps)+import Test.Tasty.HUnit (testCase, (@?=), (@?))+import Test.Tasty (testGroup)+++valuesTests = testGroup "Various specific values"+ [ testGroup "floats"+ [ testCase "0.0" $ decode @Double " 0.0 " @?= Right 0+ , testCase "0.1" $ decode @Double " 0.1 " @?= Right 0.1+ , testCase "1.0e1" $ decode @Double " 1.0e1 " @?= Right 1e1+ , testCase "1.0e+1" $ decode @Double " 1.0e+1 " @?= Right 1e1+ , testCase "1.0e-1" $ decode @Double " 1.0e-1 " @?= Right 1e-1+ , testCase "1e1" $ decode @Double " 1e1 " @?= Right 1e1+ , testCase "1e+1" $ decode @Double " 1e+1 " @?= Right 1e1+ , testCase "1e-1" $ decode @Double " 1e-1 " @?= Right 1e-1+ , testCase "1__e1__" $ decode @Double " 1__e1__ " @?= Right 1e1+ , testCase "1_._0e1_" $ decode @Double " 1_._0e1_ " @?= Right 1e1+ , testCase "inf" $ decode @Double " inf " @?= Right (read "Infinity")+ ]+ , testCase "nan" $ case decode @Double " NaN " of+ Left _ -> False @? "isRight . decode $ \"NaN\""+ Right x -> isNaN x @? "isNaN . fromLeft . decode $ \"NaN\""+ , testCase "raw string" $ decode @Text+ " r##\" foo \\n bar \"baz\" \"## "+ @?= Right " foo \\n bar \"baz\" "+ ]