diff --git a/LICENSE-APACHE b/LICENSE-APACHE new file mode 100644 --- /dev/null +++ b/LICENSE-APACHE @@ -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. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,12 @@ +module Main where + +import Criterion.Main (defaultMain) + +import qualified File +import qualified Escape + + +main = defaultMain + [ File.benchmark + , Escape.benchmark + ] diff --git a/bench/Escape.hs b/bench/Escape.hs new file mode 100644 --- /dev/null +++ b/bench/Escape.hs @@ -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 + diff --git a/bench/File.hs b/bench/File.hs new file mode 100644 --- /dev/null +++ b/bench/File.hs @@ -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" + ] diff --git a/changelog.txt b/changelog.txt new file mode 100644 --- /dev/null +++ b/changelog.txt @@ -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 diff --git a/ron-hs.cabal b/ron-hs.cabal new file mode 100644 --- /dev/null +++ b/ron-hs.cabal @@ -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 diff --git a/src/Data/Ron.hs b/src/Data/Ron.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron.hs @@ -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 diff --git a/src/Data/Ron/Class.hs b/src/Data/Ron/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron/Class.hs @@ -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 + "" -> "" + 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 diff --git a/src/Data/Ron/Class/Deriving.hs b/src/Data/Ron/Class/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron/Class/Deriving.hs @@ -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 #-} diff --git a/src/Data/Ron/Class/Internal.hs b/src/Data/Ron/Class/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron/Class/Internal.hs @@ -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 #-} diff --git a/src/Data/Ron/Deserialize.hs b/src/Data/Ron/Deserialize.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron/Deserialize.hs @@ -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 diff --git a/src/Data/Ron/Serialize.hs b/src/Data/Ron/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron/Serialize.hs @@ -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 diff --git a/src/Data/Ron/Value.hs b/src/Data/Ron/Value.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron/Value.hs @@ -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 diff --git a/src/Data/Ron/Value/Internal.hs b/src/Data/Ron/Value/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ron/Value/Internal.hs @@ -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 diff --git a/test/DerivingVia.hs b/test/DerivingVia.hs new file mode 100644 --- /dev/null +++ b/test/DerivingVia.hs @@ -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 + ] + ] diff --git a/test/File.hs b/test/File.hs new file mode 100644 --- /dev/null +++ b/test/File.hs @@ -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 + ] diff --git a/test/ForExample.hs b/test/ForExample.hs new file mode 100644 --- /dev/null +++ b/test/ForExample.hs @@ -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 + ] diff --git a/test/Generic.hs b/test/Generic.hs new file mode 100644 --- /dev/null +++ b/test/Generic.hs @@ -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 diff --git a/test/GenericOptions.hs b/test/GenericOptions.hs new file mode 100644 --- /dev/null +++ b/test/GenericOptions.hs @@ -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 + ] diff --git a/test/Optics/Ron/Settings.hs b/test/Optics/Ron/Settings.hs new file mode 100644 --- /dev/null +++ b/test/Optics/Ron/Settings.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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' diff --git a/test/Values.hs b/test/Values.hs new file mode 100644 --- /dev/null +++ b/test/Values.hs @@ -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\" " + ]