├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── BENCHMARKS.txt ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── changelog.md ├── ci ├── ci.nix ├── jobsets.json └── jobsets.nix ├── default.nix ├── nix ├── sources.json ├── sources.nix └── waargoverlay.nix ├── src ├── Waargonaut.hs └── Waargonaut │ ├── Attoparsec.hs │ ├── Decode.hs │ ├── Decode │ ├── Error.hs │ ├── Internal.hs │ ├── Runners.hs │ ├── Traversal.hs │ ├── Types.hs │ └── ZipperMove.hs │ ├── Encode.hs │ ├── Encode │ ├── Builder.hs │ ├── Builder │ │ ├── CommaSep.hs │ │ ├── JArray.hs │ │ ├── JChar.hs │ │ ├── JNumber.hs │ │ ├── JObject.hs │ │ ├── JString.hs │ │ ├── Types.hs │ │ └── Whitespace.hs │ └── Types.hs │ ├── Generic.hs │ ├── Lens.hs │ ├── Prettier.hs │ ├── Test.hs │ ├── Types.hs │ └── Types │ ├── CommaSep.hs │ ├── CommaSep │ ├── Elem.hs │ └── Elems.hs │ ├── JArray.hs │ ├── JChar.hs │ ├── JChar │ ├── Escaped.hs │ ├── HexDigit4.hs │ └── Unescaped.hs │ ├── JNumber.hs │ ├── JObject.hs │ ├── JObject │ └── JAssoc.hs │ ├── JString.hs │ ├── Json.hs │ └── Whitespace.hs ├── test ├── Bench.hs ├── Decoder.hs ├── Decoder │ ├── Laws.hs │ └── Parsers.hs ├── Doctests.hs ├── Encoder.hs ├── Encoder │ └── Laws.hs ├── Generics.hs ├── Golden.hs ├── Json.hs ├── Laws.hs ├── Main.hs ├── Prettier │ ├── NestedObjs.hs │ └── pretty_nested_objs.json ├── Properties.hs ├── Types │ ├── CommaSep.hs │ ├── Common.hs │ ├── JChar.hs │ ├── JNumber.hs │ ├── JString.hs │ ├── Json.hs │ └── Whitespace.hs ├── Utils.hs └── json-data │ ├── bad-json │ ├── no_comma_arr.json │ └── no_comma_obj.json │ ├── goldens │ ├── backslash128.json.golden │ ├── empty_arr_empty_ws.json.golden │ ├── image_obj.json.golden │ ├── location_array.json.golden │ ├── nested_arrs.json.golden │ ├── null_arr_trailing_comma_ws.json.golden │ ├── numbers.json.golden │ ├── twitter100.json.golden │ ├── twitter_with_hex_vals.json.golden │ └── unicode_2705.json.golden │ ├── image_obj.json │ ├── keys-in-obj.json │ ├── location_array.json │ ├── mishandling.json │ ├── numbers.json │ ├── twitter100.json │ ├── twitter_with_hex_vals.json │ └── unicode_2705.json ├── waarg-overrides.nix ├── waargbench ├── CHANGELOG.md ├── LICENCE ├── Setup.hs ├── bench │ └── Bench.hs ├── cabal.project ├── default.nix ├── src │ ├── Common.hs │ └── Waargbench.hs └── waargbench.cabal └── waargonaut.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local* 20 | .HTF/ 21 | .ghc.environment.* 22 | result -------------------------------------------------------------------------------- /BENCHMARKS.txt: -------------------------------------------------------------------------------- 1 | Running 1 benchmarks... 2 | Benchmark bench: RUNNING... 3 | benchmarked Parse - Attoparsec/jp100 4 | time 27.96 ms (27.71 ms .. 28.14 ms) 5 | 1.000 R² (0.999 R² .. 1.000 R²) 6 | mean 28.84 ms (28.53 ms .. 29.39 ms) 7 | std dev 906.7 μs (626.8 μs .. 1.153 ms) 8 | 9 | benchmarked Parse - Attoparsec/twitter100 10 | time 19.68 ms (19.53 ms .. 19.91 ms) 11 | 1.000 R² (0.999 R² .. 1.000 R²) 12 | mean 20.41 ms (20.18 ms .. 20.80 ms) 13 | std dev 718.6 μs (427.1 μs .. 1.191 ms) 14 | 15 | benchmarked Parse - Attoparsec/numbers 16 | time 4.365 ms (4.344 ms .. 4.387 ms) 17 | 1.000 R² (1.000 R² .. 1.000 R²) 18 | mean 4.439 ms (4.414 ms .. 4.474 ms) 19 | std dev 93.28 μs (69.92 μs .. 113.0 μs) 20 | 21 | benchmarked Succinct Index/jp100 22 | time 895.6 μs (892.7 μs .. 898.3 μs) 23 | 1.000 R² (1.000 R² .. 1.000 R²) 24 | mean 894.4 μs (893.3 μs .. 896.0 μs) 25 | std dev 4.528 μs (3.456 μs .. 6.925 μs) 26 | 27 | benchmarked Succinct Index/twitter100 28 | time 698.5 μs (687.1 μs .. 716.2 μs) 29 | 0.998 R² (0.998 R² .. 0.999 R²) 30 | mean 720.2 μs (716.2 μs .. 722.7 μs) 31 | std dev 10.87 μs (6.649 μs .. 15.16 μs) 32 | 33 | benchmarked Succinct Index/numbers 34 | time 137.6 μs (137.2 μs .. 138.0 μs) 35 | 1.000 R² (1.000 R² .. 1.000 R²) 36 | mean 137.8 μs (137.6 μs .. 138.0 μs) 37 | std dev 613.8 ns (504.7 ns .. 761.2 ns) 38 | 39 | benchmarked Decode/Image Decode (manual - traversal) 40 | time 124.9 μs (124.6 μs .. 125.2 μs) 41 | 1.000 R² (1.000 R² .. 1.000 R²) 42 | mean 124.9 μs (124.8 μs .. 125.1 μs) 43 | std dev 533.3 ns (390.9 ns .. 754.9 ns) 44 | 45 | benchmarked Decode/Image Decode (manual - succinct) 46 | time 117.3 μs (117.1 μs .. 117.5 μs) 47 | 1.000 R² (1.000 R² .. 1.000 R²) 48 | mean 117.1 μs (117.0 μs .. 117.3 μs) 49 | std dev 557.0 ns (433.1 ns .. 779.0 ns) 50 | 51 | benchmarked Decode/Image Decode (generic) 52 | time 65.69 μs (65.54 μs .. 65.83 μs) 53 | 1.000 R² (1.000 R² .. 1.000 R²) 54 | mean 65.66 μs (65.56 μs .. 65.77 μs) 55 | std dev 351.0 ns (280.0 ns .. 470.9 ns) 56 | 57 | benchmarked Decode/[Scientific] (manual - traversal) 58 | time 10.39 ms (10.34 ms .. 10.44 ms) 59 | 1.000 R² (1.000 R² .. 1.000 R²) 60 | mean 10.37 ms (10.34 ms .. 10.47 ms) 61 | std dev 146.8 μs (57.29 μs .. 240.4 μs) 62 | 63 | benchmarked Decode/[Scientific] (generic) 64 | time 7.706 ms (7.673 ms .. 7.741 ms) 65 | 1.000 R² (1.000 R² .. 1.000 R²) 66 | mean 7.819 ms (7.772 ms .. 7.901 ms) 67 | std dev 176.9 μs (114.5 μs .. 256.2 μs) 68 | 69 | Benchmark bench: FINISH 70 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation 2 | (CSIRO) ABN 41 687 119 230. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of QFPL nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/qfpl/waargonaut.svg?branch=master)](https://travis-ci.org/qfpl/waargonaut) 2 | 3 | # Waargonaut 4 | 5 | Flexible, precise, and efficient JSON decoding/encoding library. This package 6 | provides a plethora of tools for decoding, encoding, and manipulating JSON data. 7 | 8 | ## Features 9 | 10 | * Fully RFC compliant, with property based testing used to ensure the desired 11 | invariants are preserved. 12 | 13 | * Encoders and Decoders are values, they are not tied to a typeclass and as such 14 | you are not tied to a single interpretation of how a particular type 15 | "_should_" be handled. 16 | 17 | * No information is discarded on parsing. Trailing whitespace, and any 18 | formatting whitespace (carriage returns etc) are all preserved. 19 | 20 | * A history keeping zipper is used for Decoding, providing precise control of 21 | how _you_ decode _your_ JSON data. With informative error messages if things 22 | don't go according to plan. 23 | 24 | * Flexible and expressive Decoder & Encoder functions let you parse and build 25 | the JSON structures _you_ require, with no surprises. 26 | 27 | * BYO parsing library, the parser built into Waargonaut does not tie you to a 28 | particular parsing library. With the caveat that your parsing library must 29 | have an instance of `CharParsing` from the [parsers](https://hackage.haskell.org/package/parsers) package. 30 | 31 | * Generic functions are provided to make the creation of Encoders and Decoders 32 | are bit easier. However these _are_ tied to typeclasses, so they do come with 33 | some assumptions. 34 | 35 | * Lenses, Prisms, and Traversals are provided to allow you to investigate and 36 | manipulate the JSON data structures to your hearts content, without breaking 37 | the invariants. 38 | 39 | * The awesome work on succinct data structures by John Ky and [Haskell Works](https://github.com/haskell-works/) 40 | is used to power the decoder. Providing the same zipper capabilities and 41 | property based guarantees, but with all the speed and efficiency capabilities 42 | that succinct data structures have to offer. 43 | 44 | ## Example 45 | 46 | - Data Structure: 47 | ```haskell 48 | data Image = Image 49 | { _imageWidth :: Int 50 | , _imageHeight :: Int 51 | , _imageTitle :: Text 52 | , _imageAnimated :: Bool 53 | , _imageIDs :: [Int] 54 | } 55 | ``` 56 | 57 | - Encoder: 58 | ```haskell 59 | encodeImage :: Applicative f => Encoder f Image 60 | encodeImage = E.mapLikeObj $ \img -> 61 | E.intAt "Width" (_imageWidth img) 62 | . E.intAt "Height" (_imageHeight img) 63 | . E.textAt "Title" (_imageTitle img) 64 | . E.boolAt "Animated" (_imageAnimated img) 65 | . E.listAt E.int "IDs" (_imageIDs img) 66 | ``` 67 | 68 | - Decoder: 69 | ```haskell 70 | imageDecoder :: Monad f => D.Decoder f Image 71 | imageDecoder = D.withCursor $ \curs -> do 72 | -- Move down into the JSON object. 73 | io <- D.down curs 74 | -- We need individual values off of our object, 75 | Image 76 | <$> D.fromKey "Width" D.int io 77 | <*> D.fromKey "Height" D.int io 78 | <*> D.fromKey "Title" D.text io 79 | <*> D.fromKey "Animated" D.bool io 80 | <*> D.fromKey "IDs" (D.list D.int) io 81 | ``` 82 | 83 | ### Zippers 84 | 85 | Waargonaut uses zippers for its decoding which allows for precise control in 86 | how you interrogate your JSON input. Take JSON structures and decode them 87 | precisely as you require: 88 | 89 | ##### Input: 90 | 91 | ```JSON 92 | ["a","fred",1,2,3,4] 93 | ``` 94 | 95 | ##### Data Structure: 96 | 97 | ```haskell 98 | data Foo = Foo (Char,String,[Int]) 99 | ``` 100 | 101 | ##### Decoder: 102 | 103 | The zipper starts the very root of the JSON input, we tell it to move 'down' 104 | into the first element. 105 | ```haskell 106 | fooDecoder :: Monad f => Decoder f Foo 107 | fooDecoder = D.withCursor $ \cursor -> do 108 | fstElem <- D.down cursor 109 | ``` 110 | From the first element we can then decode the focus of the zipper using a 111 | specific decoder: 112 | ```haskell 113 | aChar <- D.focus D.unboundedChar fstElem 114 | ``` 115 | The next thing we want to decode is the second element of the array, so we 116 | move right one step or tooth, and then attempt to decode a string at the 117 | focus. 118 | ```haskell 119 | aString <- D.moveRight1 fstElem >>= D.focus D.string 120 | ``` 121 | Finally we want to take everything else in the list and combine them into a 122 | single list of Int values. Starting from the first element, we move right 123 | two positions (over the char and the string elements), then we use one of 124 | the provided decoder functions that will repeatedly move in a direction and 125 | combine all of the elements it can until it can no longer move. 126 | ```haskell 127 | aIntList <- D.moveRightN 2 fstElem >>= D.rightwardSnoc [] D.int 128 | ``` 129 | Lastly, we build the Foo using the decoded values. 130 | ```haskell 131 | pure $ Foo (aChar, aString, aIntList) 132 | ``` 133 | 134 | The zipper stores the history of your movements, so any errors provide 135 | information about the path they took prior to encountering an error. Making 136 | debugging precise and straight-forward. 137 | 138 | ### Property Driven Development 139 | 140 | This library is built to parse and produce JSON in accordance with the [RFC 141 | 8259](https://tools.ietf.org/html/rfc8259) standard. The data structures, 142 | parser, and printer are built to satify the [Round Trip Property](https://teh.id.au/posts/2017/06/07/round-trip-property/): 143 | 144 | Which may be expressed using the following pseudocode: 145 | 146 | ``` 147 | parse . print = id 148 | ``` 149 | This indicates that any JSON produced by this library will be parsed back in as 150 | the exact data structure that produced it. This includes whitespace such as 151 | carriage returns and trailing whitespace. There is no loss of information. 152 | 153 | There is also this property, again in pseudocode: 154 | 155 | ``` 156 | print . parse . print = print 157 | ``` 158 | This states that the printed form of the JSON will not change will be identical 159 | after parsing and then re-printing. There is no loss of information. 160 | 161 | This provides a solid foundation to build upon. 162 | 163 | **NB:** The actual code will of course return values that account for the 164 | possibility of failure. Computers being what they are. 165 | 166 | ### TODO(s) 167 | 168 | In no particular order... 169 | 170 | - [ ] improve/bikeshed encoding object api 171 | - [ ] gather feedback on tests/benchmarks that matter 172 | - [ ] provide testing functions so users can be more confident in their Encoder/Decoder construction 173 | - [x] (feedback required) documentation in the various modules to explain any weirdness or things that users may consider to be 'missing' or 'wrong'. 174 | - [x] (mostly) provide greater rationale behind lack of reliance in typeclasses for encoding/decoding 175 | - [ ] provide functions to add preset whitespace layouts to encoded json. 176 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #ifndef MIN_VERSION_cabal_doctest 4 | #define MIN_VERSION_cabal_doctest(x,y,z) 0 5 | #endif 6 | 7 | #if MIN_VERSION_cabal_doctest(1,0,0) 8 | 9 | import Distribution.Extra.Doctest 10 | main = defaultMainWithDoctests "doctests" 11 | 12 | #else 13 | 14 | import Distribution.Simple (defaultMain) 15 | main = defaultMain 16 | 17 | #endif 18 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./waargonaut.cabal 3 | 4 | optimization: False 5 | 6 | package bits-extra 7 | flags: +bmi2 8 | 9 | package hw-rankselect 10 | flags: +bmi2 11 | 12 | package hw-rankselect-base 13 | flags: +bmi2 14 | 15 | package hw-json 16 | flags: +bmi2 17 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Revision history for waargonaut 2 | 3 | ## 0.8.0.2 -- 2020-06-02 4 | 5 | - Support GHC 8.10.x and GHC 8.8.x 6 | - Fix warnings for GHC < 8.2.x 7 | 8 | ## 0.8.0.1 -- 2019-09-22 9 | 10 | * Support GHC 8.8.1 11 | 12 | * Support generics-sop 0.5 13 | 14 | ## 0.8.0.0 -- 2019-09-04 15 | 16 | * Add `onObj'` which is just `onObj` but specialised to `Identity`. 17 | 18 | * Add `gObjEncoder` for deriving `ObjEncoder` structures for record types only. Using the 19 | `IsRecord` constraint from `record-sop` package. This makes it easier to leverage the 20 | Contravariant functionality of the `ObjEncoder` without losing the benefits of deriving 21 | more trivial encoders. 22 | 23 | * Added the `FieldNameAsKey` option to the newtype options for generic derived enc/decoders. 24 | 25 | * Fixes #69 by removing duplicate call to `_optionsFieldName` function. Added regression test. 26 | 27 | * Improved the handling of newtype options for generic deriving to give a bit more 28 | flexibility and avoid strangeness with respect to some combinations of options. 29 | 30 | * Change the building of escaped whitespace chars to actually use the 31 | `escapedWhitespaceChar` function, instead of incorrectly generating an unescaped 32 | character. 33 | 34 | * Add haddock to gObjEncoder function 35 | 36 | * Correctly bump version to 0.8.0.0 as this is a breaking change because of new 37 | constructors on an exported sum type. 38 | 39 | * Remove some commented out code. 40 | 41 | * Add a better failure message to "impossible" error case. 42 | 43 | * Regenerate nix after cabal file changes 44 | 45 | ## 0.6.1.0 -- 2019-02-27 46 | 47 | * Add `passKeysToValues` decoder for decoding JSON objects where the key should 48 | be part of the value. 49 | 50 | ## 0.6.0.0 -- 2019-02-19 51 | 52 | #### Fixes 53 | 54 | * Handling of HeXDigit4 values was not correct. The bug was partly due to the 55 | choice of optic, instead of producing a (type/failure) error when working with 56 | mixed-case hex values, it seems to be zero'ing them out. 57 | * Added regression tests 58 | 59 | #### Rework 60 | 61 | * Redesigned ParseFn to handle: 62 | * Data.String.String 63 | * Data.Text.Text 64 | * Data.ByteString.ByteString 65 | * Updated documentation for ParseFn to match changes 66 | * Updated documentation for default parsing functions 67 | * Generalised the Builder process to handle Text and ByteString 68 | * Created a record type to hold the required functions for builders 69 | * Created submodules to house the generalised builders (see Waargonaut.Encode.Builder and friends) 70 | * Added test to ensure both builders produce identical output 71 | * Updated documentation for Encode process to match changes 72 | * Added deprecation notice to `Waargonaut.Decode.Traversal` 73 | 74 | #### Cleanup 75 | 76 | * Factored out components into more submodules: 77 | * UnescapedJChar 78 | * EscapedJChar 79 | * HexDigit4 80 | * Elem 81 | * Elems 82 | * JAssoc 83 | * Decode.Runners 84 | * Updated documentation if required for module changes. 85 | * Deleted commented out code 86 | * Changed all file textual encoding/decoding tests to Test.Tasty.Golden. 87 | 88 | #### New hotness 89 | 90 | * Added a few prisms to allow for similar behaviour to the lens-aeson package. 91 | * Added property tests for these new prisms to check they comply with the prism law. 92 | 93 | ## 0.5.2.1 -- 2019-01-08 94 | 95 | * Upgraded the nix overrides to use the overlay technique. 96 | * Lowered the bound on tagged to 0.8.5 which allowed it to be removed from the list of overridden packages. 97 | 98 | ## 0.5.2.0 -- 2019-01-03 99 | 100 | * Add `Waargonaut.Prettier` module that contains a traversal to modify a `Json` structure to add indentation and newlines. 101 | 102 | ## 0.5.1.0 -- 2019-01-02 103 | 104 | * Fix order of `either` decoder to match documentation, `Right` decoder was not being attempted first. 105 | * Expose functionality to check the 'type' of the JSON at the current cursor position. 106 | * Update list decoder to check that we're at an array before attempting to decode. It will now fail when attempting to decode a list and something of type list is not found. Previously it would return an empty list when a number was present. 107 | 108 | ## 0.5.0.0 -- 2018-12-18 109 | 110 | * Changed internal builder from `ByteString` to `Text` builder. 111 | * Fixed bug for going from `JString` <-> `Text`, was breaking round-trip. 112 | * Removed instances of `AsJString` for `Text` and `ByteString`, replaced with more correct `Prism` and some better functions. 113 | * Added regression tests for round tripping text and bytestring (char8). 114 | 115 | ## 0.4.2.0 -- 2018-11-29 116 | 117 | * Improved pretty printing of CursorHistory by condensing multiple numeric movements and removing the single movements following searching for keys. 118 | * Add `fromKeyOptional` and `atKeyOptional` that make it easier to handle optional keys on objects. 119 | * Add `prismDOrFail'` function to allow the user to construct an error from the value that was decoded. 120 | 121 | ## 0.4.1.0 -- 2018-11-20 122 | 123 | * Add `oneOf` decoder and tests 124 | 125 | ## 0.4.0.0 -- 2018-11-19 126 | 127 | * Redesign & rebuild of `Encoder` internals to allow for greater control and flexibility 128 | * Factor our law tests into their own module (a recheck of these tests is needed) 129 | * Fixed bug in `list` and `nonempty` decoders 130 | * Fixed bug in `foldCursor` function 131 | * Fixed bug in `Cons` instance for `CommaSep` 132 | * Fixed bug in documentation for `atKey` 133 | * Added `_MapLikeObj` `Prism` 134 | * Added some optics into object / maplikeobj keys 135 | * Fixed bug in `maybeOrNull` decoder to be more strict in what it accepts 136 | * Rewrote `either` decoder in terms of the alternative instance to allow for better errors 137 | 138 | ## 0.3.0.0 -- 2018-11-14 139 | 140 | * Change to use the `natural` package for `Natural` numbers. 141 | 142 | ## 0.2.1.0 -- 2018-11-13 143 | 144 | * Add `MonadError` and `Alt` instance for `Decoder` 145 | * Add property tests for the typeclass laws for `Encoder` and `Decoder` 146 | * Removed need for `MonadError` constraint on `prismDOrFail` 147 | 148 | ## 0.2.0.2 -- 2018-11-12 149 | 150 | * Fix `Applicative` instance for `Decoder`. 151 | 152 | ## 0.2.0.1 -- 2018-11-07 153 | 154 | * Update `moveToKey` to record a successful movement to a key, before continuing 155 | 156 | ## 0.2.0.0 -- 2018-11-06 157 | 158 | * Provide more precise errors from Decoder for missing or invalid keys 159 | * Removed a parameter from `KeyDecodeFailed` error constructor 160 | * Fix issue where printing the zipper movements had left and right movement arrows swapped. 161 | 162 | ## 0.1.0.0 -- 2018-11-01 163 | 164 | * First version. Released on an unsuspecting world. 165 | -------------------------------------------------------------------------------- /ci/ci.nix: -------------------------------------------------------------------------------- 1 | { supportedSystems ? ["x86_64-linux"] 2 | , supportedCompilers ? [ "ghc822" "ghc843" ] 3 | }: 4 | 5 | with (import { inherit supportedSystems; }); 6 | 7 | let 8 | pkgs = import {}; 9 | 10 | configurations = 11 | pkgs.lib.listToAttrs ( 12 | pkgs.lib.concatMap (compiler: 13 | pkgs.lib.concatMap (system: 14 | [{name = "haskell-packages-" + compiler + "-waargonaut-" + system ; value = {inherit compiler system;};}] 15 | ) supportedSystems 16 | ) supportedCompilers 17 | ); 18 | 19 | jobs = 20 | pkgs.lib.mapAttrs (name: configuration: 21 | let 22 | compiler = configuration.compiler; 23 | system = configuration.system; 24 | nixpkgs = { pkgs = pkgsFor system; }; 25 | waargonaut = import ../default.nix { inherit nixpkgs compiler; }; 26 | in 27 | waargonaut 28 | ) configurations; 29 | in 30 | jobs 31 | -------------------------------------------------------------------------------- /ci/jobsets.json: -------------------------------------------------------------------------------- 1 | { 2 | "enabled": 1, 3 | "hidden": false, 4 | "description": "jobsets", 5 | "nixexprinput": "waargonaut", 6 | "nixexprpath": "ci/jobsets.nix", 7 | "checkinterval": 300, 8 | "schedulingshares": 1, 9 | "enableemail": false, 10 | "emailoverride": "", 11 | "keepnr": 5, 12 | "inputs": { 13 | "waargonaut": { "type": "git", "value": "https://github.com/qfpl/waargonaut", "emailresponsible": false }, 14 | "nixpkgs": { "type": "git", "value": "https://github.com/NixOS/nixpkgs.git release-18.09", "emailresponsible": false } 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /ci/jobsets.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs, declInput }: let pkgs = import nixpkgs {}; in { 2 | jobsets = pkgs.runCommand "spec.json" {} '' 3 | cat < $out <//archive/.tar.gz" 13 | }, 14 | "nixpkgs": { 15 | "branch": "nixpkgs-unstable", 16 | "description": "Nix Packages collection", 17 | "homepage": "", 18 | "owner": "NixOS", 19 | "repo": "nixpkgs", 20 | "rev": "2bb5cbf7f8b99a8d1d6646abe5ab993f6823212f", 21 | "sha256": "0vn6znlk36azpha4jinvwg6mqqhzahm4m3lfy86p4drb7rb72w8i", 22 | "type": "tarball", 23 | "url": "https://github.com/NixOS/nixpkgs/archive/2bb5cbf7f8b99a8d1d6646abe5ab993f6823212f.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: name: spec: 10 | let 11 | name' = sanitizeName name + "-src"; 12 | in 13 | if spec.builtin or true then 14 | builtins_fetchurl { inherit (spec) url sha256; name = name'; } 15 | else 16 | pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; 17 | 18 | fetch_tarball = pkgs: name: spec: 19 | let 20 | name' = sanitizeName name + "-src"; 21 | in 22 | if spec.builtin or true then 23 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 24 | else 25 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 26 | 27 | fetch_git = name: spec: 28 | let 29 | ref = 30 | if spec ? ref then spec.ref else 31 | if spec ? branch then "refs/heads/${spec.branch}" else 32 | if spec ? tag then "refs/tags/${spec.tag}" else 33 | abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; 34 | in 35 | builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; 36 | 37 | fetch_local = spec: spec.path; 38 | 39 | fetch_builtin-tarball = name: throw 40 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 41 | $ niv modify ${name} -a type=tarball -a builtin=true''; 42 | 43 | fetch_builtin-url = name: throw 44 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 45 | $ niv modify ${name} -a type=file -a builtin=true''; 46 | 47 | # 48 | # Various helpers 49 | # 50 | 51 | # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 52 | sanitizeName = name: 53 | ( 54 | concatMapStrings (s: if builtins.isList s then "-" else s) 55 | ( 56 | builtins.split "[^[:alnum:]+._?=-]+" 57 | ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) 58 | ) 59 | ); 60 | 61 | # The set of packages used when specs are fetched using non-builtins. 62 | mkPkgs = sources: system: 63 | let 64 | sourcesNixpkgs = 65 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; 66 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 67 | hasThisAsNixpkgsPath = == ./.; 68 | in 69 | if builtins.hasAttr "nixpkgs" sources 70 | then sourcesNixpkgs 71 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 72 | import {} 73 | else 74 | abort 75 | '' 76 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 77 | add a package called "nixpkgs" to your sources.json. 78 | ''; 79 | 80 | # The actual fetching function. 81 | fetch = pkgs: name: spec: 82 | 83 | if ! builtins.hasAttr "type" spec then 84 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 85 | else if spec.type == "file" then fetch_file pkgs name spec 86 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 87 | else if spec.type == "git" then fetch_git name spec 88 | else if spec.type == "local" then fetch_local spec 89 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 90 | else if spec.type == "builtin-url" then fetch_builtin-url name 91 | else 92 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 93 | 94 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 95 | # the path directly as opposed to the fetched source. 96 | replace = name: drv: 97 | let 98 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 99 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 100 | in 101 | if ersatz == "" then drv else 102 | # this turns the string into an actual Nix path (for both absolute and 103 | # relative paths) 104 | if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; 105 | 106 | # Ports of functions for older nix versions 107 | 108 | # a Nix version of mapAttrs if the built-in doesn't exist 109 | mapAttrs = builtins.mapAttrs or ( 110 | f: set: with builtins; 111 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 112 | ); 113 | 114 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 115 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 116 | 117 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 118 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 119 | 120 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 121 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 122 | concatMapStrings = f: list: concatStrings (map f list); 123 | concatStrings = builtins.concatStringsSep ""; 124 | 125 | # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 126 | optionalAttrs = cond: as: if cond then as else {}; 127 | 128 | # fetchTarball version that is compatible between all the versions of Nix 129 | builtins_fetchTarball = { url, name ? null, sha256 }@attrs: 130 | let 131 | inherit (builtins) lessThan nixVersion fetchTarball; 132 | in 133 | if lessThan nixVersion "1.12" then 134 | fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 135 | else 136 | fetchTarball attrs; 137 | 138 | # fetchurl version that is compatible between all the versions of Nix 139 | builtins_fetchurl = { url, name ? null, sha256 }@attrs: 140 | let 141 | inherit (builtins) lessThan nixVersion fetchurl; 142 | in 143 | if lessThan nixVersion "1.12" then 144 | fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 145 | else 146 | fetchurl attrs; 147 | 148 | # Create the final "sources" from the config 149 | mkSources = config: 150 | mapAttrs ( 151 | name: spec: 152 | if builtins.hasAttr "outPath" spec 153 | then abort 154 | "The values in sources.json should not have an 'outPath' attribute" 155 | else 156 | spec // { outPath = replace name (fetch config.pkgs name spec); } 157 | ) config.sources; 158 | 159 | # The "config" used by the fetchers 160 | mkConfig = 161 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 162 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 163 | , system ? builtins.currentSystem 164 | , pkgs ? mkPkgs sources system 165 | }: rec { 166 | # The sources, i.e. the attribute set of spec name to spec 167 | inherit sources; 168 | 169 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 170 | inherit pkgs; 171 | }; 172 | 173 | in 174 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 175 | -------------------------------------------------------------------------------- /nix/waargoverlay.nix: -------------------------------------------------------------------------------- 1 | hlib: _: hsuper: 2 | let 3 | de-broken = hlib.markUnbroken; 4 | handle-hw = drv: hlib.dontCheck (hlib.setBuildTarget (de-broken hsuper.${drv}) "lib:${drv}"); 5 | in { 6 | natural = hlib.dontCheck (de-broken hsuper.natural); 7 | # weeeeeeeee 8 | hw-json-simd = handle-hw "hw-json-simd"; 9 | hw-json-standard-cursor = handle-hw "hw-json-standard-cursor"; 10 | hw-rankselect = hlib.dontCheck (hlib.setBuildTargets (de-broken hsuper.hw-rankselect) [ 11 | "lib:hw-rankselect-gen" 12 | "lib:hw-rankselect" 13 | ]); 14 | } -------------------------------------------------------------------------------- /src/Waargonaut/Attoparsec.hs: -------------------------------------------------------------------------------- 1 | -- | Some default decoder implementations using the @attoparsec@ package. 2 | -- 3 | -- Waargonaut works with any parser that has an instance of the 4 | -- 'Text.Parser.Char.CharParsing' typeclass. So you're able to select from a few 5 | -- different parsing libraries, depending on your needs. This module provides 6 | -- some convenient defaults using the package. 7 | -- 8 | -- These functions are implemented using the @decodeFromX@ functions in the 9 | -- @Waargonaut.Decode@ module. They use the @parseOnly@ function, from either 10 | -- the 'Data.Attoparsec.Text' or 'Data.Attoparsec.ByteString' attoparsec modules. 11 | -- 12 | module Waargonaut.Attoparsec 13 | ( -- * Decoders 14 | decodeAttoparsecText 15 | , decodeAttoparsecByteString 16 | , pureDecodeAttoparsecText 17 | , pureDecodeAttoparsecByteString 18 | ) where 19 | 20 | import Data.Functor.Identity (Identity) 21 | 22 | import Data.ByteString (ByteString) 23 | import Data.Text (Text) 24 | 25 | import qualified Data.Attoparsec.ByteString as AB 26 | import qualified Data.Attoparsec.Text as AT 27 | 28 | import Waargonaut.Decode (CursorHistory, Decoder) 29 | import Waargonaut.Decode.Error (DecodeError) 30 | 31 | import qualified Waargonaut.Decode as D 32 | 33 | -- | Use the 'AT.parseOnly' function as our default parser for decoding 'Text' input. 34 | decodeAttoparsecText 35 | :: Monad f 36 | => Decoder f a 37 | -> Text 38 | -> f (Either (DecodeError, CursorHistory) a) 39 | decodeAttoparsecText decoder = 40 | D.decodeFromText AT.parseOnly decoder 41 | 42 | -- | Use the 'AB.parseOnly' function as our default parser for decoding 'ByteString' input. 43 | decodeAttoparsecByteString 44 | :: Monad f 45 | => Decoder f a 46 | -> ByteString 47 | -> f (Either (DecodeError, CursorHistory) a) 48 | decodeAttoparsecByteString decoder = 49 | D.decodeFromByteString AB.parseOnly decoder 50 | 51 | -- | As per 'decodeAttoparsecText' but with @f@ specialised to 'Identity'. 52 | pureDecodeAttoparsecText 53 | :: Decoder Identity a 54 | -> Text 55 | -> Either (DecodeError, CursorHistory) a 56 | pureDecodeAttoparsecText decoder = 57 | D.pureDecodeFromText AT.parseOnly decoder 58 | 59 | -- | As per 'decodeAttoparsecByteString' but with @f@ specialised to 'Identity'. 60 | pureDecodeAttoparsecByteString 61 | :: Decoder Identity a 62 | -> ByteString 63 | -> Either (DecodeError, CursorHistory) a 64 | pureDecodeAttoparsecByteString decoder = 65 | D.pureDecodeFromByteString AB.parseOnly decoder 66 | -------------------------------------------------------------------------------- /src/Waargonaut/Decode/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | -- | Types and typeclass for errors in Waargonaut decoding. 3 | module Waargonaut.Decode.Error 4 | ( DecodeError (..) 5 | , AsDecodeError (..) 6 | , Err (..) 7 | ) where 8 | 9 | import Control.Lens (Prism') 10 | import qualified Control.Lens as L 11 | 12 | import GHC.Word (Word64) 13 | 14 | import HaskellWorks.Data.Json.Standard.Cursor.Type (JsonType) 15 | 16 | import Data.Text (Text) 17 | 18 | import Waargonaut.Decode.ZipperMove (ZipperMove) 19 | 20 | import Waargonaut.Types (JNumber) 21 | 22 | -- | Convenience Error structure for the separate parsing/decoding phases. For 23 | -- when things really aren't that complicated. 24 | data Err c e 25 | = Parse e 26 | | Decode (DecodeError, c) 27 | deriving (Show, Eq, Functor) 28 | 29 | -- | 30 | -- Set of errors that may occur during the decode phase. 31 | -- 32 | data DecodeError 33 | = ConversionFailure Text 34 | | TypeMismatch JsonType 35 | | KeyDecodeFailed 36 | | KeyNotFound Text 37 | | FailedToMove ZipperMove 38 | | NumberOutOfBounds JNumber 39 | | InputOutOfBounds Word64 40 | | ParseFailed Text 41 | deriving (Show, Eq) 42 | 43 | -- | Describes the sorts of errors that may be treated as a 'DecodeError', for use with 'Control.Lens.Prism's. 44 | class AsDecodeError r where 45 | _DecodeError :: Prism' r DecodeError 46 | _ConversionFailure :: Prism' r Text 47 | _TypeMismatch :: Prism' r JsonType 48 | _KeyDecodeFailed :: Prism' r () 49 | _KeyNotFound :: Prism' r Text 50 | _FailedToMove :: Prism' r ZipperMove 51 | _NumberOutOfBounds :: Prism' r JNumber 52 | _InputOutOfBounds :: Prism' r Word64 53 | _ParseFailed :: Prism' r Text 54 | 55 | _ConversionFailure = _DecodeError . _ConversionFailure 56 | _TypeMismatch = _DecodeError . _TypeMismatch 57 | _KeyDecodeFailed = _DecodeError . _KeyDecodeFailed 58 | _KeyNotFound = _DecodeError . _KeyNotFound 59 | _FailedToMove = _DecodeError . _FailedToMove 60 | _NumberOutOfBounds = _DecodeError . _NumberOutOfBounds 61 | _InputOutOfBounds = _DecodeError . _InputOutOfBounds 62 | _ParseFailed = _DecodeError . _ParseFailed 63 | 64 | instance AsDecodeError DecodeError where 65 | _DecodeError = id 66 | 67 | _ConversionFailure 68 | = L.prism ConversionFailure 69 | (\x -> case x of 70 | ConversionFailure y -> Right y 71 | _ -> Left x 72 | ) 73 | 74 | _TypeMismatch 75 | = L.prism TypeMismatch 76 | (\x -> case x of 77 | TypeMismatch y -> Right y 78 | _ -> Left x 79 | ) 80 | 81 | _KeyDecodeFailed 82 | = L.prism (const KeyDecodeFailed) 83 | (\x -> case x of 84 | KeyDecodeFailed -> Right () 85 | _ -> Left x 86 | ) 87 | 88 | _KeyNotFound 89 | = L.prism KeyNotFound 90 | (\x -> case x of 91 | KeyNotFound y -> Right y 92 | _ -> Left x 93 | ) 94 | 95 | _FailedToMove 96 | = L.prism FailedToMove 97 | (\x -> case x of 98 | FailedToMove y -> Right y 99 | _ -> Left x 100 | ) 101 | 102 | _NumberOutOfBounds 103 | = L.prism NumberOutOfBounds 104 | (\x -> case x of 105 | NumberOutOfBounds y -> Right y 106 | _ -> Left x 107 | ) 108 | 109 | _InputOutOfBounds 110 | = L.prism InputOutOfBounds 111 | (\x -> case x of 112 | InputOutOfBounds y -> Right y 113 | _ -> Left x 114 | ) 115 | 116 | _ParseFailed 117 | = L.prism ParseFailed 118 | (\x -> case x of 119 | ParseFailed y -> Right y 120 | _ -> Left x 121 | ) 122 | -------------------------------------------------------------------------------- /src/Waargonaut/Decode/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | -- | 7 | -- 8 | -- Types for the succinct data structure decoder 9 | -- 10 | module Waargonaut.Decode.Types 11 | ( ParseFn 12 | , Cursor 13 | , CursorHistory 14 | , Decoder (..) 15 | , DecodeResult (..) 16 | , JCurs (..) 17 | , mkCursor 18 | , jsonTypeAt 19 | , JsonType(..) 20 | ) where 21 | 22 | import Control.Lens (Rewrapped, 23 | Wrapped (..), 24 | iso) 25 | import Control.Monad.Except (MonadError (..)) 26 | import Control.Monad.Morph (MFunctor (..), 27 | MMonad (..)) 28 | import Control.Monad.Reader (MonadReader, 29 | ReaderT (..)) 30 | import Control.Monad.State (MonadState) 31 | import Control.Monad.Trans.Class (MonadTrans (lift)) 32 | 33 | import Data.Functor.Alt (Alt (..)) 34 | import qualified Data.Text as Text 35 | 36 | import Data.ByteString (ByteString) 37 | 38 | import HaskellWorks.Data.Json.Standard.Cursor.Fast (Cursor,fromByteStringViaBlanking) 39 | import HaskellWorks.Data.Json.Standard.Cursor.Generic (cursorRank) 40 | import HaskellWorks.Data.Json.Standard.Cursor.Type (JsonType (..), 41 | JsonTypeAt (..)) 42 | import HaskellWorks.Data.Positioning (Count) 43 | 44 | import Waargonaut.Decode.Internal (CursorHistory', DecodeError (..), 45 | DecodeResultT (..), 46 | ZipperMove (BranchFail), 47 | recordZipperMove) 48 | 49 | import Waargonaut.Types (Json) 50 | 51 | -- | We define the index of our 'CursorHistory'' to be the 'HaskellWorks.Data.Positioning.Count'. 52 | type CursorHistory = 53 | CursorHistory' Count 54 | 55 | -- | Convenience alias for the type of the function we will use to parse 56 | -- the input string into the 'Json' structure. 57 | type ParseFn = 58 | ByteString -> Either DecodeError Json 59 | 60 | -- | 'Decoder' type that is used directly to convert 'Json' structures to other 61 | -- data types. 62 | -- 63 | newtype Decoder f a = Decoder 64 | { runDecoder :: ParseFn -> JCurs -> DecodeResultT Count DecodeError f a 65 | } 66 | deriving Functor 67 | 68 | instance Monad f => Applicative (Decoder f) where 69 | pure a = Decoder $ \_ _ -> pure a 70 | aToB <*> a = Decoder $ \p c -> 71 | runDecoder aToB p c <*> runDecoder a p c 72 | 73 | instance Monad f => Alt (Decoder f) where 74 | a b = Decoder $ \p c -> catchError (runDecoder a p c) $ \e -> do 75 | recordZipperMove (BranchFail . Text.pack $ show e) (cursorRank $ unJCurs c) 76 | runDecoder b p c 77 | 78 | instance Monad f => Monad (Decoder f) where 79 | return = pure 80 | a >>= aToFb = Decoder $ \p c -> do 81 | r <- runDecoder a p c 82 | runDecoder (aToFb r) p c 83 | 84 | instance Monad f => MonadError DecodeError (Decoder f) where 85 | throwError e = Decoder (\_ _ -> throwError e) 86 | catchError d handle = Decoder $ \p c -> 87 | catchError (runDecoder d p c) (\e -> runDecoder (handle e) p c) 88 | 89 | instance MonadTrans Decoder where 90 | lift fa = Decoder (\ _ _ -> lift fa) 91 | 92 | instance MFunctor Decoder where 93 | hoist nat (Decoder pjdr) = Decoder (\p -> hoist nat . pjdr p) 94 | 95 | -- | Wrapper type for the 'SuccinctCursor' 96 | newtype JCurs = JCurs 97 | { unJCurs :: Cursor 98 | } deriving JsonTypeAt 99 | 100 | instance JCurs ~ t => Rewrapped JCurs t 101 | 102 | instance Wrapped JCurs where 103 | type Unwrapped JCurs = Cursor 104 | _Wrapped' = iso unJCurs JCurs 105 | 106 | -- | Take a 'ByteString' input and build an index of the JSON structure inside 107 | -- 108 | mkCursor :: ByteString -> JCurs 109 | mkCursor = JCurs . fromByteStringViaBlanking 110 | 111 | -- | Provide some of the type parameters that the underlying 'DecodeResultT' 112 | -- requires. This contains the state and error management as we walk around our 113 | -- zipper and decode our JSON input. 114 | -- 115 | -- Addtionally we keep our parsing function in a 'ReaderT' such that it's 116 | -- accessible for all of the decoding steps. 117 | -- 118 | newtype DecodeResult f a = DecodeResult 119 | { unDecodeResult :: ReaderT ParseFn (DecodeResultT Count DecodeError f) a 120 | } 121 | deriving ( Functor 122 | , Applicative 123 | , Monad 124 | , MonadReader ParseFn 125 | , MonadError DecodeError 126 | , MonadState CursorHistory 127 | ) 128 | 129 | instance MonadTrans DecodeResult where 130 | lift = DecodeResult . lift . lift 131 | 132 | instance MFunctor DecodeResult where 133 | hoist nat (DecodeResult dr) = DecodeResult (hoist (hoist nat) dr) 134 | 135 | instance MMonad DecodeResult where 136 | embed f (DecodeResult dr) = DecodeResult . ReaderT $ \p -> 137 | embed (flip runReaderT p . unDecodeResult . f) $ runReaderT dr p 138 | -------------------------------------------------------------------------------- /src/Waargonaut/Decode/ZipperMove.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Types and functions for describing the movements of a cursor around the 3 | -- 'Waargonaut.Types.Json.Json' structure. 4 | module Waargonaut.Decode.ZipperMove 5 | ( ZipperMove (..) 6 | , AsZipperMove (..) 7 | , ppZipperMove 8 | ) where 9 | 10 | import Control.Lens (Prism') 11 | import qualified Control.Lens as L 12 | 13 | import Data.Text (Text) 14 | import qualified Data.Text as Text 15 | 16 | #if !MIN_VERSION_base(4,11,0) 17 | import Data.Semigroup ((<>)) 18 | #endif 19 | 20 | import Natural (Natural) 21 | 22 | import Text.PrettyPrint.Annotated.WL (Doc, (<+>)) 23 | import qualified Text.PrettyPrint.Annotated.WL as WL 24 | 25 | -- | 26 | -- Set of moves that may be executed on a zipper. 27 | -- 28 | data ZipperMove 29 | = U 30 | | D 31 | | DAt Text 32 | | Item Text 33 | | L Natural 34 | | R Natural 35 | | BranchFail Text 36 | deriving (Show, Eq) 37 | 38 | -- | Pretty print a given zipper movement, used when printing 39 | -- 'Waargonaut.Decode.Internal.CursorHistory'' to improve the readability of the errors. 40 | ppZipperMove :: ZipperMove -> Doc a 41 | ppZipperMove m = case m of 42 | U -> WL.text "up/" <> WL.linebreak 43 | D -> WL.text "down\\" <> WL.linebreak 44 | 45 | L n -> WL.text "-<-" <+> ntxt n 46 | R n -> WL.text " ->-" <+> ntxt n 47 | 48 | DAt k -> WL.text "into\\" <+> itxt "key" k <> WL.linebreak 49 | Item t -> WL.text "-::" <+> itxt "item" t <> WL.linebreak 50 | BranchFail t -> WL.text "(attempted: " <+> ntxt t <+> WL.text ")" <> WL.linebreak 51 | where 52 | itxt t k' = WL.parens (WL.text t <+> WL.colon <+> WL.text (Text.unpack k')) 53 | ntxt n' = WL.parens (WL.char 'i' <+> WL.char '+' <+> WL.text (show n')) 54 | 55 | -- | Classy 'Control.Lens.Prism''s for things that may be treated as a 'ZipperMove'. 56 | class AsZipperMove r where 57 | _ZipperMove :: Prism' r ZipperMove 58 | _U :: Prism' r () 59 | _D :: Prism' r () 60 | _DAt :: Prism' r Text 61 | _Item :: Prism' r Text 62 | _L :: Prism' r Natural 63 | _R :: Prism' r Natural 64 | 65 | _U = _ZipperMove . _U 66 | _D = _ZipperMove . _D 67 | _DAt = _ZipperMove . _DAt 68 | _Item = _ZipperMove . _Item 69 | _L = _ZipperMove . _L 70 | _R = _ZipperMove . _R 71 | 72 | instance AsZipperMove ZipperMove where 73 | _ZipperMove = id 74 | 75 | _U = L.prism (const U) 76 | (\x -> case x of 77 | U -> Right () 78 | _ -> Left x 79 | ) 80 | 81 | _D = L.prism (const D) 82 | (\x -> case x of 83 | D -> Right () 84 | _ -> Left x 85 | ) 86 | 87 | _DAt = L.prism DAt 88 | (\x -> case x of 89 | DAt y -> Right y 90 | _ -> Left x 91 | ) 92 | 93 | _Item = L.prism Item 94 | (\x -> case x of 95 | Item y -> Right y 96 | _ -> Left x 97 | ) 98 | 99 | _L = L.prism L 100 | (\x -> case x of 101 | L y -> Right y 102 | _ -> Left x 103 | ) 104 | 105 | _R = L.prism R 106 | (\x -> case x of 107 | R y -> Right y 108 | _ -> Left x 109 | ) 110 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | -- | 4 | -- 5 | -- Builder structures to help with turning 'Json' into a textual encoding. 6 | -- 7 | module Waargonaut.Encode.Builder where 8 | 9 | import Data.String (IsString, fromString) 10 | 11 | #if !MIN_VERSION_base(4,11,0) 12 | import Data.Monoid ((<>)) 13 | #endif 14 | 15 | 16 | import Data.Text (Text) 17 | import qualified Data.Text.Lazy.Builder as T 18 | import qualified Data.Text.Lazy.Builder.Int as T 19 | 20 | import Data.ByteString (ByteString) 21 | import qualified Data.ByteString.Builder as B 22 | import qualified Data.ByteString.Builder.Prim as BP 23 | 24 | import Waargonaut.Types.Json (JType (..), Json (..)) 25 | import Waargonaut.Types.Whitespace (WS) 26 | 27 | import Waargonaut.Encode.Builder.JArray (jArrayBuilder) 28 | import Waargonaut.Encode.Builder.JNumber (jNumberBuilder) 29 | import Waargonaut.Encode.Builder.JObject (jObjectBuilder) 30 | import Waargonaut.Encode.Builder.JString (jStringBuilder) 31 | import Waargonaut.Encode.Builder.Types (Builder (..)) 32 | 33 | -- | A 'T.Text' builder 34 | textBuilder :: Builder Text T.Builder 35 | textBuilder = Builder 36 | T.singleton 37 | T.fromText 38 | T.decimal 39 | 40 | -- | A 'B.ByteString' builder 41 | bsBuilder :: Builder ByteString B.Builder 42 | bsBuilder = Builder 43 | (BP.primBounded BP.charUtf8) 44 | B.byteString 45 | B.intDec 46 | 47 | -- | A general builder function for working with 'JType' values. 48 | -- 49 | jTypesBuilder 50 | :: ( IsString t 51 | , Monoid b 52 | ) 53 | => Builder t b 54 | -> (Builder t b -> WS -> b) 55 | -> JType WS Json 56 | -> b 57 | jTypesBuilder bldr s jt = 58 | let 59 | (jBuilt, tws') = case jt of 60 | JNull tws -> (fromChunk bldr (fromString "null"), tws) 61 | JBool b tws -> (fromChunk bldr (fromString $ if b then "true" else "false"), tws) 62 | JNum jn tws -> (jNumberBuilder bldr jn, tws) 63 | JStr js tws -> (jStringBuilder bldr js, tws) 64 | JArr js tws -> (jArrayBuilder bldr s waargonautBuilder js, tws) 65 | JObj jobj tws -> (jObjectBuilder bldr s waargonautBuilder jobj, tws) 66 | in 67 | jBuilt <> s bldr tws' 68 | 69 | -- | Using the given whitespace builder, create a builder for a given 'Json' value. 70 | waargonautBuilder 71 | :: ( IsString t 72 | , Monoid b 73 | ) 74 | => (Builder t b -> WS -> b) 75 | -> Builder t b 76 | -> Json 77 | -> b 78 | waargonautBuilder ws bldr (Json jt) = 79 | jTypesBuilder bldr ws jt 80 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/CommaSep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | -- | 4 | -- 5 | -- Builder functions for 'CommaSeparated' values. 6 | -- 7 | module Waargonaut.Encode.Builder.CommaSep (commaSeparatedBuilder) where 8 | 9 | #if !MIN_VERSION_base(4,11,0) 10 | import Data.Monoid ((<>)) 11 | #endif 12 | 13 | import Waargonaut.Types.CommaSep (Comma, CommaSeparated (..), 14 | Elem (..), Elems (..)) 15 | 16 | import Waargonaut.Encode.Builder.Types (Builder (..)) 17 | 18 | -- | Builder for UTF8 Comma 19 | commaBuilder :: Builder t b -> b 20 | commaBuilder b = fromChar b ',' 21 | {-# INLINE commaBuilder #-} 22 | 23 | -- | Builder for a comma and trailing whitespace combination. 24 | commaTrailingBuilder 25 | :: ( Monoid b 26 | , Foldable f 27 | ) 28 | => Builder t b 29 | -> (Builder t b -> ws -> b) 30 | -> f (Comma, ws) 31 | -> b 32 | commaTrailingBuilder bldr wsB = 33 | foldMap ((commaBuilder bldr <>) . (wsB bldr) . snd) 34 | 35 | -- | Using the given builders for the whitespace and elements (@a@), create a 36 | -- builder for a 'CommaSeparated'. 37 | commaSeparatedBuilder 38 | :: forall ws a t b. Monoid b 39 | => Builder t b 40 | -> Char 41 | -> Char 42 | -> (Builder t b -> ws -> b) 43 | -> (Builder t b -> a -> b) 44 | -> CommaSeparated ws a 45 | -> b 46 | commaSeparatedBuilder bldr op fin wsB aB (CommaSeparated lws sepElems) = 47 | fromChar bldr op <> wsB bldr lws <> maybe mempty buildElems sepElems <> fromChar bldr fin 48 | where 49 | elemBuilder (Elem e eTrailing) = 50 | aB bldr e <> commaTrailingBuilder bldr wsB eTrailing 51 | 52 | buildElems (Elems es elst) = 53 | foldMap elemBuilder es <> elemBuilder elst 54 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/JArray.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Builder function for 'JArray' 4 | -- 5 | module Waargonaut.Encode.Builder.JArray (jArrayBuilder) where 6 | 7 | import Waargonaut.Types.JArray (JArray (..)) 8 | 9 | import Waargonaut.Encode.Builder.CommaSep (commaSeparatedBuilder) 10 | import Waargonaut.Encode.Builder.Types (Builder) 11 | 12 | -- | Using the given builders, build a 'JArray'. 13 | jArrayBuilder 14 | :: Monoid b 15 | => Builder t b 16 | -> (Builder t b -> ws -> b) 17 | -> ((Builder t b -> ws -> b) -> Builder t b -> a -> b) 18 | -> JArray ws a 19 | -> b 20 | jArrayBuilder bldr ws a (JArray cs) = 21 | commaSeparatedBuilder bldr '[' ']' ws (a ws) cs 22 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/JChar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- 4 | -- Builder structures for 'JChar's 5 | -- 6 | module Waargonaut.Encode.Builder.JChar (jCharBuilder) where 7 | 8 | import Control.Lens (review) 9 | 10 | #if !MIN_VERSION_base(4,11,0) 11 | import Data.Monoid ((<>)) 12 | #endif 13 | 14 | import Data.Digit (HeXaDeCiMaL, charHeXaDeCiMaL) 15 | 16 | import Waargonaut.Encode.Builder.Types (Builder (..)) 17 | import Waargonaut.Types.JChar (JChar (..)) 18 | import Waargonaut.Types.JChar.Escaped (Escaped (..)) 19 | import Waargonaut.Types.JChar.HexDigit4 (HexDigit4 (..)) 20 | import Waargonaut.Types.JChar.Unescaped (_Unescaped) 21 | import Waargonaut.Types.Whitespace (unescapedWhitespaceChar) 22 | 23 | -- | Using the given function, return the builder for a single 'JChar'. 24 | jCharBuilder 25 | :: ( Monoid b 26 | , HeXaDeCiMaL digit 27 | ) 28 | => Builder t b 29 | -> JChar digit 30 | -> b 31 | jCharBuilder bldr (UnescapedJChar c) = fromChar bldr (review _Unescaped c) 32 | jCharBuilder bldr (EscapedJChar jca) = fromChar bldr '\\' <> case jca of 33 | QuotationMark -> fromChar bldr '"' 34 | ReverseSolidus -> fromChar bldr '\\' 35 | Solidus -> fromChar bldr '/' 36 | Backspace -> fromChar bldr 'b' 37 | (WhiteSpace ws) -> fromChar bldr (unescapedWhitespaceChar ws) 38 | Hex (HexDigit4 a b c d) -> fromChar bldr 'u' <> foldMap hexChar [a,b,c,d] 39 | where 40 | hexChar = 41 | fromChar bldr . review charHeXaDeCiMaL 42 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/JNumber.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- 4 | -- Builders for 'JNumber' 5 | -- 6 | module Waargonaut.Encode.Builder.JNumber 7 | ( jNumberBuilder 8 | ) where 9 | 10 | import Control.Lens (review) 11 | 12 | import qualified Data.Digit as D 13 | import Data.List.NonEmpty (NonEmpty) 14 | 15 | #if !MIN_VERSION_base(4,11,0) 16 | import Data.Monoid ((<>)) 17 | #endif 18 | 19 | 20 | import Waargonaut.Types.JNumber (E (..), Exp (..), Frac (..), 21 | JNumber (..), jIntToDigits) 22 | 23 | import Waargonaut.Encode.Builder.Types (Builder (..)) 24 | 25 | -- $setup 26 | -- >>> :set -XOverloadedStrings 27 | -- >>> import Data.List.NonEmpty (NonEmpty ((:|))) 28 | -- >>> import Data.Digit (DecDigit(..)) 29 | -- >>> import qualified Data.Digit as D 30 | -- >>> import Data.Text.Lazy.Builder (toLazyText) 31 | -- >>> import Waargonaut.Encode.Builder (textBuilder) 32 | -- >>> import Waargonaut.Types.JNumber (JInt' (JIntInt)) 33 | -- 34 | 35 | getExpSymbol 36 | :: Monoid b 37 | => Builder t b 38 | -> Maybe Bool 39 | -> b 40 | getExpSymbol bldr (Just True) = fromChar bldr '-' 41 | getExpSymbol bldr (Just False) = fromChar bldr '+' 42 | getExpSymbol _ _ = mempty 43 | 44 | eBuilder 45 | :: Monoid b 46 | => Builder t b 47 | -> E 48 | -> b 49 | eBuilder bldr Ee = fromChar bldr 'e' 50 | eBuilder bldr EE = fromChar bldr 'E' 51 | 52 | fracBuilder :: Monoid b => Builder t b -> Frac -> b 53 | fracBuilder bldr (Frac digs) = digitsBuilder bldr digs 54 | 55 | digitsBuilder 56 | :: Monoid b 57 | => Builder t b 58 | -> NonEmpty D.DecDigit 59 | -> b 60 | digitsBuilder bldr = 61 | foldMap (fromInt bldr . review D.integralDecimal) 62 | 63 | -- | Builder for the exponent portion. 64 | expBuilder 65 | :: Monoid b 66 | => Builder t b 67 | -> Exp 68 | -> b 69 | expBuilder bldr (Exp e sign digs) = 70 | eBuilder bldr e <> getExpSymbol bldr sign <> digitsBuilder bldr digs 71 | 72 | -- | Printing of JNumbers 73 | -- 74 | -- >>> toLazyText $ jNumberBuilder textBuilder (JNumber {_minus = False, _numberint = JIntInt D.DecDigit3 [], _frac = Just (Frac (D.DecDigit4 :| [D.DecDigit5])), _expn = Just (Exp {_ex = Ee, _minusplus = Just False, _expdigits = D.DecDigit1 :| [D.DecDigit0]})}) 75 | -- "3.45e+10" 76 | -- 77 | -- >>> toLazyText $ jNumberBuilder textBuilder (JNumber {_minus = True, _numberint = JIntInt D.DecDigit3 [], _frac = Just (Frac (D.DecDigit4 :| [D.DecDigit5])), _expn = Just (Exp {_ex = Ee, _minusplus = Just True, _expdigits = D.DecDigit0 :| [D.x2]})}) 78 | -- "-3.45e-02" 79 | -- 80 | -- >>> toLazyText $ jNumberBuilder textBuilder (JNumber {_minus = False, _numberint = JIntInt D.DecDigit0 [D.DecDigit0], _frac = Nothing, _expn = Nothing}) 81 | -- "00" 82 | -- 83 | jNumberBuilder 84 | :: Monoid b 85 | => Builder t b 86 | -> JNumber 87 | -> b 88 | jNumberBuilder bldr (JNumber sign digs mfrac mexp) = 89 | s <> digits <> frac' <> expo 90 | where 91 | s = if sign then fromChar bldr '-' else mempty 92 | digits = digitsBuilder bldr . jIntToDigits $ digs 93 | frac' = foldMap (mappend (fromChar bldr '.') . fracBuilder bldr) mfrac 94 | expo = foldMap (expBuilder bldr) mexp 95 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/JObject.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- 4 | -- Builder structures for 'JObject's 5 | -- 6 | module Waargonaut.Encode.Builder.JObject (jObjectBuilder) where 7 | 8 | #if !MIN_VERSION_base(4,11,0) 9 | import Data.Monoid ((<>)) 10 | #endif 11 | 12 | import Waargonaut.Types.JObject (JAssoc (..), JObject (..)) 13 | 14 | import Waargonaut.Encode.Builder.CommaSep (commaSeparatedBuilder) 15 | import Waargonaut.Encode.Builder.JString (jStringBuilder) 16 | import Waargonaut.Encode.Builder.Types (Builder (..)) 17 | 18 | -- | Builder for a single "key:value" pair. 19 | jAssocBuilder 20 | :: Monoid b 21 | => (Builder t b -> ws -> b) 22 | -> ((Builder t b -> ws -> b) -> Builder t b -> a -> b) 23 | -> Builder t b 24 | -> JAssoc ws a 25 | -> b 26 | jAssocBuilder ws aBuilder bldr (JAssoc k ktws vpws v) = 27 | jStringBuilder bldr k <> ws bldr ktws <> fromChar bldr ':' <> ws bldr vpws <> aBuilder ws bldr v 28 | 29 | -- | Construct a 'Builder' for an entire 'JObject', duplicate keys are preserved. 30 | jObjectBuilder 31 | :: Monoid b 32 | => Builder t b 33 | -> (Builder t b -> ws -> b) 34 | -> ((Builder t b -> ws -> b) -> Builder t b -> a -> b) 35 | -> JObject ws a 36 | -> b 37 | jObjectBuilder bldr ws aBuilder (JObject c) = 38 | commaSeparatedBuilder bldr '{' '}' ws (jAssocBuilder ws aBuilder) c 39 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/JString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- 4 | -- Builder structures for 'JString's 5 | -- 6 | module Waargonaut.Encode.Builder.JString (jStringBuilder) where 7 | 8 | #if !MIN_VERSION_base(4,11,0) 9 | import Data.Monoid ((<>)) 10 | #endif 11 | import Waargonaut.Types.JString (JString, JString' (..)) 12 | 13 | import Waargonaut.Encode.Builder.JChar (jCharBuilder) 14 | import Waargonaut.Encode.Builder.Types (Builder (..)) 15 | 16 | -- $setup 17 | -- >>> :set -XOverloadedStrings 18 | -- >>> import Data.Function (($)) 19 | -- >>> import Data.Digit (HeXDigit(..)) 20 | -- >>> import qualified Data.Vector as V 21 | -- >>> import Waargonaut.Types.Whitespace 22 | -- >>> import Waargonaut.Types.JChar.Unescaped 23 | -- >>> import Waargonaut.Types.JChar.Escaped 24 | -- >>> import Waargonaut.Types.JChar.HexDigit4 25 | -- >>> import Waargonaut.Types.JChar 26 | -- >>> import Waargonaut.Encode.Builder (textBuilder) 27 | -- >>> import Data.Text.Lazy.Builder (toLazyText) 28 | ---- 29 | 30 | -- | Builder for a 'JString'. 31 | -- 32 | -- >>> toLazyText $ jStringBuilder textBuilder ((JString' V.empty) :: JString) 33 | -- "\"\"" 34 | -- 35 | -- >>> toLazyText $ jStringBuilder textBuilder ((JString' $ V.fromList [UnescapedJChar (Unescaped 'a'),UnescapedJChar (Unescaped 'b'),UnescapedJChar (Unescaped 'c')]) :: JString) 36 | -- "\"abc\"" 37 | -- 38 | -- >>> toLazyText $ jStringBuilder textBuilder ((JString' $ V.fromList [UnescapedJChar (Unescaped 'a'),EscapedJChar (WhiteSpace CarriageReturn),UnescapedJChar (Unescaped 'b'),UnescapedJChar (Unescaped 'c')]) :: JString) 39 | -- "\"a\\rbc\"" 40 | -- 41 | -- >>> toLazyText $ jStringBuilder textBuilder ((JString' $ V.fromList [UnescapedJChar (Unescaped 'a'),EscapedJChar (WhiteSpace CarriageReturn),UnescapedJChar (Unescaped 'b'),UnescapedJChar (Unescaped 'c'),EscapedJChar (Hex (HexDigit4 HeXDigita HeXDigitb HeXDigit1 HeXDigit2)),EscapedJChar (WhiteSpace NewLine),UnescapedJChar (Unescaped 'd'),UnescapedJChar (Unescaped 'e'),UnescapedJChar (Unescaped 'f'),EscapedJChar QuotationMark]) :: JString) 42 | -- "\"a\\rbc\\uab12\\ndef\\\"\"" 43 | -- 44 | -- >>> toLazyText $ jStringBuilder textBuilder ((JString' $ V.singleton (UnescapedJChar (Unescaped 'a'))) :: JString) 45 | -- "\"a\"" 46 | -- 47 | -- >>> toLazyText $ jStringBuilder textBuilder (JString' $ V.singleton (EscapedJChar ReverseSolidus) :: JString) 48 | -- "\"\\\\\"" 49 | -- 50 | jStringBuilder 51 | :: Monoid b 52 | => Builder t b 53 | -> JString 54 | -> b 55 | jStringBuilder bldr (JString' jcs) = 56 | fromChar bldr '\"' <> foldMap (jCharBuilder bldr) jcs <> fromChar bldr '\"' 57 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- The structure used to contain the required character and related functions for running a "builder". 4 | -- 5 | module Waargonaut.Encode.Builder.Types (Builder (..)) where 6 | 7 | -- | The builder data type. 8 | data Builder t b = Builder 9 | { fromChar :: Char -> b -- ^ Create a builder from a Haskell 'Char' 10 | , fromChunk :: t -> b -- ^ Create a builder from a chunk or piece of @t@ 11 | , fromInt :: Int -> b -- ^ Create a builder from a Haskell 'Int' 12 | } 13 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Builder/Whitespace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- 4 | -- Builder structures for 'Whitespace' 5 | -- 6 | module Waargonaut.Encode.Builder.Whitespace 7 | ( whitespaceBuilder 8 | , wsBuilder 9 | , wsRemover 10 | ) where 11 | 12 | #if !MIN_VERSION_base(4,11,0) 13 | import Data.Monoid (Monoid) 14 | #endif 15 | 16 | import Waargonaut.Types.Whitespace (WS (..), Whitespace (..)) 17 | 18 | import Waargonaut.Encode.Builder.Types (Builder (..)) 19 | 20 | -- | Create a 'Data.ByteString.Builder' from a 'Whitespace' 21 | whitespaceBuilder :: Monoid b => Builder t b -> Whitespace -> b 22 | whitespaceBuilder bldr Space = fromChar bldr ' ' 23 | whitespaceBuilder bldr HorizontalTab = fromChar bldr '\t' 24 | whitespaceBuilder bldr LineFeed = fromChar bldr '\f' 25 | whitespaceBuilder bldr CarriageReturn = fromChar bldr '\r' 26 | whitespaceBuilder bldr NewLine = fromChar bldr '\n' 27 | {-# INLINE whitespaceBuilder #-} 28 | 29 | -- | Reconstitute the given whitespace into its original form. 30 | wsBuilder :: Monoid b => Builder t b -> WS -> b 31 | wsBuilder bldr (WS ws) = foldMap (whitespaceBuilder bldr) ws 32 | {-# INLINE wsBuilder #-} 33 | 34 | -- | Remove any whitespace. Minification for free, yay! 35 | wsRemover :: Monoid b => Builder t b -> WS -> b 36 | wsRemover _ = const mempty 37 | {-# INLINE wsRemover #-} 38 | -------------------------------------------------------------------------------- /src/Waargonaut/Encode/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | -- | 4 | -- Types and functions that make up the internal structure of the encoders. 5 | -- 6 | module Waargonaut.Encode.Types 7 | ( -- * Types 8 | EncoderFns (..) 9 | 10 | -- * Useful aliases 11 | , Encoder 12 | , Encoder' 13 | , ObjEncoder 14 | , ObjEncoder' 15 | 16 | -- * Runners 17 | , runEncoder 18 | , runPureEncoder 19 | 20 | -- * Helpers 21 | , jsonEncoder 22 | , objEncoder 23 | , generaliseEncoder 24 | ) where 25 | 26 | import Control.Monad (Monad) 27 | import Control.Monad.Morph (MFunctor (..), 28 | generalize) 29 | 30 | import Control.Applicative (Applicative, liftA2, 31 | pure) 32 | import Control.Category (id, (.)) 33 | import Control.Lens (( # )) 34 | 35 | import Data.Either (either) 36 | import Data.Function (const, ($)) 37 | import Data.Functor (Functor) 38 | import Data.Functor.Contravariant (Contravariant (..)) 39 | 40 | import Data.Functor.Contravariant.Divisible (Decidable (..), 41 | Divisible (..)) 42 | import Data.Monoid (mempty) 43 | import Data.Semigroup ((<>)) 44 | import Data.Void (absurd) 45 | 46 | import Data.Functor (fmap) 47 | import Data.Functor.Identity (Identity (..)) 48 | 49 | import Waargonaut.Types (JObject, Json, WS, _JObj) 50 | 51 | 52 | -- | 53 | -- Define an "encoder" as a function from some @a@ to some 'Json' with the 54 | -- allowance for some context @f@. 55 | -- 56 | -- The helper functions 'jsonEncoder' and 'objEncoder' are probably what you 57 | -- want to use. 58 | -- 59 | data EncoderFns i f a = EncoderFns 60 | { finaliseEncoding :: i -> Json -- ^ The @i@ need not be the final 'Json' structure. This function will complete the output from 'initialEncoding' to the final 'Json' output. 61 | 62 | , initialEncoding :: a -> f i -- ^ Run the initial encoding step of the given input. This lets you encode the @a@ to an intermediate structure before utilising the 'finaliseEncoding' function to complete the process. 63 | } 64 | 65 | instance MFunctor (EncoderFns i) where 66 | hoist nat (EncoderFns f i) = EncoderFns f (nat . i) 67 | 68 | -- | Generalise any 'Encoder' a' to 'Encoder f a' 69 | generaliseEncoder :: Monad f => EncoderFns i Identity a -> EncoderFns i f a 70 | generaliseEncoder (EncoderFns f i) = EncoderFns f (generalize . i) 71 | 72 | instance Contravariant (EncoderFns o f) where 73 | contramap f e = EncoderFns (finaliseEncoding e) (initialEncoding e . f) 74 | {-# INLINE contramap #-} 75 | 76 | instance Applicative f => Divisible (EncoderFns (JObject WS Json) f) where 77 | conquer = objEncoder (const (pure mempty)) 78 | {-# INLINE conquer #-} 79 | 80 | divide atobc (EncoderFns _ oB) (EncoderFns _ oC) = objEncoder $ \a -> 81 | let 82 | (b,c) = atobc a 83 | in 84 | liftA2 (<>) (oB b) (oC c) 85 | {-# INLINE divide #-} 86 | 87 | instance Applicative f => Decidable (EncoderFns (JObject WS Json) f) where 88 | lose f = objEncoder $ \a -> absurd (f a) 89 | {-# INLINE lose #-} 90 | 91 | choose split (EncoderFns _ oB) (EncoderFns _ oC) = objEncoder $ \a -> 92 | either oB oC (split a) 93 | {-# INLINE choose #-} 94 | 95 | -- | As a convenience, this type defines the @i@ to be a specific 'Json' structure: 96 | type Encoder f a = EncoderFns Json f a 97 | 98 | -- | As a convenience, this type defines the @i@ to be a specific 'JObject WS Json' structure: 99 | type ObjEncoder f a = EncoderFns (JObject WS Json) f a 100 | 101 | -- | As a convenience, this type is a pure Encoder over 'Identity' in place of the @f@. 102 | type Encoder' a = EncoderFns Json Identity a 103 | -- | As a convenience, this type is a pure ObjEncoder over 'Identity' in place of the @f@. 104 | type ObjEncoder' a = EncoderFns (JObject WS Json) Identity a 105 | 106 | -- | Run any encoder to the 'Json' representation, allowing for some 107 | -- 'Functor' context @f@. 108 | runEncoder :: Functor f => EncoderFns i f a -> a -> f Json 109 | runEncoder e = fmap (finaliseEncoding e) . initialEncoding e 110 | {-# INLINE runEncoder #-} 111 | 112 | -- | Run any encoder to the 'Json' representation, with the context specialised 113 | -- to 'Identity' for convenience. 114 | runPureEncoder :: EncoderFns i Identity a -> a -> Json 115 | runPureEncoder e = runIdentity . fmap (finaliseEncoding e) . initialEncoding e 116 | {-# INLINE runPureEncoder #-} 117 | 118 | -- | Helper function for creating an 'Encoder', provides the default 119 | -- 'finaliseEncoding' function for 'Json' encoders. 120 | jsonEncoder :: (a -> f Json) -> EncoderFns Json f a 121 | jsonEncoder = EncoderFns id 122 | {-# INLINE jsonEncoder #-} 123 | 124 | -- | Helper function for creating a JSON @object@ 'Encoder'. Provides the 125 | -- default 'finaliseEncoding' function for completing the 'JObject' to the 126 | -- necessary 'Json' type. 127 | objEncoder :: (a -> f (JObject WS Json)) -> EncoderFns (JObject WS Json) f a 128 | objEncoder = EncoderFns (\o -> _JObj # (o, mempty)) 129 | {-# INLINE objEncoder #-} 130 | -------------------------------------------------------------------------------- /src/Waargonaut/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | -- | 8 | -- 9 | -- Some high level prisms for interacting with something that could be JSON. 10 | -- 11 | module Waargonaut.Lens 12 | ( 13 | -- * Prisms 14 | _TextJson 15 | , _Number 16 | , _String 17 | , _Bool 18 | , _ArrayOf 19 | , _ObjHashMapOf 20 | , _Null 21 | ) where 22 | 23 | import Prelude (Bool, Show) 24 | 25 | import Control.Applicative (liftA2) 26 | import Control.Category ((.)) 27 | import Control.Error.Util (note) 28 | import Control.Lens (Prism', cons, preview, prism, 29 | review, (^?), _1, _Wrapped) 30 | import Control.Monad (Monad, void) 31 | import Data.Foldable (foldr) 32 | import Data.Function (const, ($)) 33 | import Data.Functor (fmap) 34 | import Data.Scientific (Scientific) 35 | import Data.Tuple (uncurry) 36 | 37 | import Data.Bifunctor (first) 38 | import Data.Either (Either (..)) 39 | 40 | import Text.Parser.Char (CharParsing) 41 | 42 | import Data.Text (Text) 43 | import qualified Data.Text.Lazy as TL 44 | 45 | import Data.Vector (Vector) 46 | import qualified Data.Vector as V 47 | 48 | import Data.HashMap.Strict (HashMap) 49 | import qualified Data.HashMap.Strict as HM 50 | 51 | import qualified Waargonaut.Types.JObject.JAssoc as JA 52 | 53 | import qualified Waargonaut.Types.CommaSep as CS 54 | import Waargonaut.Types.JString (_JStringText) 55 | 56 | import Waargonaut.Types.JNumber (_JNumberScientific) 57 | import Waargonaut.Types.Json (AsJType (..), Json) 58 | 59 | import qualified Waargonaut.Decode as D 60 | import qualified Waargonaut.Encode as E 61 | 62 | -- | 'Prism'' between 'Json' and 'Text' 63 | _TextJson 64 | :: ( CharParsing g 65 | , Monad g 66 | , Show e 67 | ) 68 | => (forall a. g a -> Text -> Either e a) 69 | -> Prism' Text Json 70 | _TextJson pf = prism 71 | (TL.toStrict . E.simplePureEncodeText E.json) 72 | (\b -> first (const b) $ D.pureDecodeFromText pf D.json b) 73 | {-# INLINE _TextJson #-} 74 | 75 | -- | 'Prism'' between some 'Json' and a 'Scientific' value 76 | _Number :: Prism' Json Scientific 77 | _Number = prism (E.asJson' E.scientific) (\j -> note j $ j ^? _JNum . _1 . _JNumberScientific) 78 | {-# INLINE _Number #-} 79 | 80 | -- | 'Prism'' between some 'Json' and a 'Text' value 81 | _String :: Prism' Json Text 82 | _String = prism (E.asJson' E.text) (\j -> note j $ j ^? _JStr . _1 . _JStringText) 83 | {-# INLINE _String #-} 84 | 85 | -- | 'Prism'' between some 'Json' and a '()' value 86 | _Null :: Prism' Json () 87 | _Null = prism (E.asJson' E.null) (\j -> note j . void $ j ^? _JNull) 88 | {-# INLINE _Null #-} 89 | 90 | -- | 'Prism'' between some 'Json' and a 'Bool' value 91 | _Bool :: Prism' Json Bool 92 | _Bool = prism (E.asJson' E.bool) (\j -> note j $ j ^? _JBool . _1) 93 | {-# INLINE _Bool#-} 94 | 95 | -- | 'Prism'' between some 'Json' and an array of something given the provided 'Prism'' 96 | _ArrayOf :: Prism' Json x -> Prism' Json (Vector x) 97 | _ArrayOf _Value = prism fromJ toJ 98 | where 99 | fromJ = E.asJson' (E.traversable E.json) . fmap (review _Value) 100 | {-# INLINE fromJ #-} 101 | toJ = CS.fromCommaSep (_JArr . _1 . _Wrapped) V.empty (foldr cons V.empty) (preview _Value) 102 | {-# INLINE toJ #-} 103 | {-# INLINE _ArrayOf #-} 104 | 105 | -- | 'Prism'' between some 'Json' and a strict 'HashMap' with 'Text' keys, and 106 | -- some value of a type provided by the given @Prism' Json x@. 107 | _ObjHashMapOf :: Prism' Json x -> Prism' Json (HashMap Text x) 108 | _ObjHashMapOf _Value = prism toJ fromJ 109 | where 110 | toJ = E.asJson' (E.keyValueTupleFoldable (E.prismE _Value E.json)) . HM.toList 111 | {-# INLINE toJ #-} 112 | 113 | toVals el = liftA2 (,) 114 | (preview (JA.jsonAssocKey . _JStringText) el) 115 | (preview (JA.jsonAssocVal . _Value) el) 116 | {-# INLINE toVals #-} 117 | 118 | fromJ = CS.fromCommaSep (_JObj . _1 . _Wrapped) HM.empty 119 | (foldr (uncurry HM.insert) HM.empty) toVals 120 | {-# INLINE fromJ #-} 121 | {-# INLINE _ObjHashMapOf #-} 122 | -------------------------------------------------------------------------------- /src/Waargonaut/Prettier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | -- | Functions and types for pretty printing the Json data structures. 5 | module Waargonaut.Prettier 6 | ( -- * Types 7 | InlineOption (..) 8 | , NumSpaces (..) 9 | , IndentStep (..) 10 | 11 | -- * Functions 12 | , prettyJson 13 | , simpleEncodePretty 14 | 15 | -- * Rexports 16 | , module Natural 17 | ) where 18 | 19 | import Prelude (Eq, Show, (+), (-)) 20 | 21 | import Control.Applicative (Applicative, (<$>)) 22 | import Control.Category (id, (.)) 23 | import Control.Lens (Traversal', over, 24 | traverseOf, (%~), (.~), 25 | _1, _2, _Just, _Wrapped) 26 | 27 | import Natural (Natural, minus, 28 | successor', zero', 29 | _Natural) 30 | 31 | import qualified Data.Text.Lazy as LT 32 | import qualified Data.Text.Lazy.Builder as TB 33 | 34 | import Data.Bool (Bool, bool) 35 | import Data.Foldable (elem, length) 36 | import Data.Function (($)) 37 | import Data.Functor (fmap) 38 | import Data.Maybe (maybe) 39 | import Data.Semigroup ((<>)) 40 | import Data.Traversable (traverse) 41 | import qualified Data.Vector as V 42 | 43 | import qualified Control.Lens as L 44 | import qualified Control.Lens.Plated as P 45 | 46 | import Waargonaut.Encode (Encoder, runEncoder) 47 | import Waargonaut.Types.CommaSep (Elems) 48 | import qualified Waargonaut.Types.CommaSep as CS 49 | import Waargonaut.Types.JObject (HasJAssoc (..), JAssoc) 50 | import Waargonaut.Types.Json (AsJType (..), JType (..), 51 | Json, jsonTraversal) 52 | import Waargonaut.Types.Whitespace (WS (..), Whitespace (..)) 53 | 54 | import Waargonaut.Encode.Builder (textBuilder, 55 | waargonautBuilder) 56 | import Waargonaut.Encode.Builder.Whitespace (wsBuilder) 57 | 58 | -- | Some choices for how the Json is indented. 59 | data InlineOption 60 | = ArrayOnly -- ^ Only keep array elements on the same line, input line breaks between object values. 61 | | ObjectOnly -- ^ Only keep object elements on the same line, input line breaks between array values. 62 | | Both -- ^ Keep both object and array elements on the same line. 63 | | Neither -- ^ Input line breaks for both array and object elements. 64 | deriving (Show, Eq) 65 | 66 | -- | Newtype to indicate how many spaces we would like to use for the indentation 67 | -- 68 | newtype NumSpaces = NumSpaces Natural 69 | deriving (Eq, Show) 70 | 71 | -- | Newtype for how many spaces the indentation should be increased by for each level. 72 | -- 73 | -- A safe assumption is for this value to be the same as the number of steps for 74 | -- the identation. Such that an indentation of two spaces will be increased by 75 | -- two for each subsequent level. 76 | -- 77 | newtype IndentStep = IndentStep Natural 78 | deriving (Eq, Show) 79 | 80 | -- | Encode an @a@ directly to a 'Data.Text' using 81 | -- the provided 'Encoder', the output will have newlines and 82 | -- indentation added based on the 'InlineOption' and 'NumSpaces'. 83 | -- 84 | -- @ 85 | -- let two = successor' $ successor' zero' 86 | -- simpleEncodePretty ArrayOnly (IndentStep two) (NumSpaces two) myEncoder myVal 87 | -- @ 88 | -- 89 | simpleEncodePretty 90 | :: Applicative f 91 | => InlineOption 92 | -> IndentStep 93 | -> NumSpaces 94 | -> Encoder f a 95 | -> a 96 | -> f LT.Text 97 | simpleEncodePretty io step ind enc = 98 | fmap (TB.toLazyText . waargonautBuilder wsBuilder textBuilder . prettyJson io step ind) 99 | . runEncoder enc 100 | 101 | objelems :: AsJType r WS a => Traversal' r (Elems WS (JAssoc WS a)) 102 | objelems = _JObj . _1 . _Wrapped . CS._CommaSeparated . _2 . _Just 103 | 104 | -- I'm not sure this is a legal traversal 105 | immediateTrailingWS :: Traversal' Json WS 106 | immediateTrailingWS f = traverseOf _Wrapped $ \case 107 | JNull ws -> JNull <$> f ws 108 | JBool b ws -> JBool b <$> f ws 109 | JNum n ws -> JNum n <$> f ws 110 | JStr s ws -> JStr s <$> f ws 111 | JArr a ws -> JArr a <$> f ws 112 | JObj o ws -> JObj o <$> f ws 113 | 114 | prettyCommaSep 115 | :: L.Traversal' b (CS.CommaSeparated WS a) 116 | -> L.Traversal' a Json 117 | -> Bool 118 | -> Natural 119 | -> Natural 120 | -> b 121 | -> b 122 | prettyCommaSep csWrapper nested inline step w = 123 | setheadleadingws . stepaftercomma 124 | where 125 | spaces x = V.replicate (_Natural L.# x) Space 126 | ws' x = bool (WS (V.singleton NewLine) <>) id inline $ WS (spaces x) 127 | 128 | i = ws' (bool w (successor' zero') inline) 129 | l = bool (ws' (w `minus` step)) i inline 130 | 131 | setheadleadingws = csWrapper . CS._CommaSeparated . _1 .~ i 132 | 133 | stepaftercomma = csWrapper . CS._CommaSeparated . _2 . _Just %~ \es -> es 134 | L.& CS.elemsElems . traverse . CS.elemTrailing . fmap . _2 .~ i 135 | L.& CS.elemsLast . CS.elemTrailing . _Just . _2 .~ l 136 | L.& CS.elemsLast . CS.elemVal . nested . immediateTrailingWS .~ l 137 | 138 | -- | Apply some indentation and spacing rules to a given Json input. 139 | -- 140 | -- To apply newlines to object elements only and indent by two spaces, 141 | -- increasing that indentation by two spaces for each nested object or array. 142 | -- 143 | -- @ 144 | -- let two = successor' $ successor' zero' 145 | -- prettyJson ArrayOnly (IndentStep two) (NumSpaces two) j 146 | -- @ 147 | -- 148 | prettyJson :: InlineOption -> IndentStep -> NumSpaces -> Json -> Json 149 | prettyJson inlineOpt (IndentStep step) (NumSpaces w) = P.transformOf jsonTraversal ( 150 | prettyCommaSep (_JArr . _1 . _Wrapped) id inlineArr step w . 151 | prettyCommaSep (_JObj . _1 . _Wrapped) jsonAssocVal inlineObj step w . 152 | setnested . 153 | alignafterkey 154 | ) 155 | where 156 | inlineArr = inlineOpt `elem` [ArrayOnly, Both] 157 | inlineObj = inlineOpt `elem` [ObjectOnly, Both] 158 | 159 | spaces x = V.replicate x Space 160 | 161 | alignafterkey j = over (objelems . traverse) (\ja -> 162 | let 163 | kl = ja L.^. jsonAssocKey . _Wrapped . L.to length 164 | in 165 | ja L.& jsonAssocValPreceedingWS .~ (WS . spaces $ longestKey - kl) 166 | ) j 167 | where 168 | longestKey = maybe 1 (+1) $ L.maximumOf (objelems . L.folded . jsonAssocKey . _Wrapped . L.to length) j 169 | 170 | setnested = objelems . traverse . jsonAssocVal %~ 171 | prettyJson inlineOpt (IndentStep step) (NumSpaces $ w <> step) 172 | -------------------------------------------------------------------------------- /src/Waargonaut/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | Helper functions for testing your 'Decoder' and 'Encoder' functions. 3 | -- 4 | module Waargonaut.Test 5 | ( roundTripSimple 6 | ) where 7 | 8 | import Data.Text (Text) 9 | 10 | import qualified Data.Text.Lazy as TextL 11 | 12 | import Text.Parser.Char (CharParsing) 13 | 14 | import Waargonaut.Encode (Encoder) 15 | import qualified Waargonaut.Encode as E 16 | 17 | import Waargonaut.Decode (CursorHistory, Decoder) 18 | import qualified Waargonaut.Decode as D 19 | import Waargonaut.Decode.Error (DecodeError) 20 | 21 | -- | Test a 'Encoder' and 'Decoder' pair are able to maintain the "round trip" 22 | -- property. That is, if you encode a given value, and then decode it, you should 23 | -- have the exact same value that you started with. 24 | roundTripSimple 25 | :: ( Eq b 26 | , Monad f 27 | , CharParsing f 28 | , Monad g 29 | , Show e 30 | ) 31 | => (forall a. f a -> Text -> Either e a) 32 | -> Encoder g b 33 | -> Decoder g b 34 | -> b 35 | -> g (Either (DecodeError, CursorHistory) Bool) 36 | roundTripSimple f e d a = do 37 | encodedA <- E.simpleEncodeTextNoSpaces e a 38 | fmap (== a) <$> D.decodeFromText f d (TextL.toStrict encodedA) 39 | -------------------------------------------------------------------------------- /src/Waargonaut/Types.hs: -------------------------------------------------------------------------------- 1 | -- | Convenience module for reexporting all the inner Waargonaut types. 2 | module Waargonaut.Types 3 | ( 4 | module Waargonaut.Types.JArray 5 | , module Waargonaut.Types.JChar 6 | , module Waargonaut.Types.JNumber 7 | , module Waargonaut.Types.JObject 8 | , module Waargonaut.Types.JString 9 | , module Waargonaut.Types.Whitespace 10 | , module Waargonaut.Types.CommaSep 11 | , module Waargonaut.Types.Json 12 | ) where 13 | 14 | import Waargonaut.Types.CommaSep 15 | import Waargonaut.Types.JArray 16 | import Waargonaut.Types.JChar 17 | import Waargonaut.Types.JNumber 18 | import Waargonaut.Types.JObject 19 | import Waargonaut.Types.Json 20 | import Waargonaut.Types.JString 21 | import Waargonaut.Types.Whitespace 22 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/CommaSep/Elem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NoImplicitPrelude #-} 8 | -- | 9 | -- 10 | -- Data structures and functions for managing a single element in a 11 | -- 'Waargonaut.Types.CommaSep.CommaSeparated' structure. 12 | -- 13 | module Waargonaut.Types.CommaSep.Elem 14 | ( 15 | -- * Types 16 | Elem (..) 17 | , HasElem (..) 18 | , Comma (Comma) 19 | 20 | , _ElemTrailingIso 21 | 22 | -- * Parse 23 | , parseComma 24 | , parseCommaTrailingMaybe 25 | ) where 26 | 27 | import Prelude (Eq, Show (showsPrec), showString, 28 | shows, (&&), (==)) 29 | 30 | import Control.Applicative (Applicative (..), liftA2, pure, (<*>)) 31 | import Control.Category (id, (.)) 32 | 33 | import Control.Lens (Iso, Iso', Lens', from, iso, (^.)) 34 | 35 | import Data.Bifoldable (Bifoldable (bifoldMap)) 36 | import Data.Bifunctor (Bifunctor (bimap)) 37 | import Data.Bitraversable (Bitraversable (bitraverse)) 38 | import Data.Foldable (Foldable, foldMap) 39 | import Data.Functor (Functor, fmap, (<$), (<$>)) 40 | import Data.Functor.Classes (Eq1, Show1, eq1, showsPrec1) 41 | import Data.Maybe (Maybe (..), fromMaybe) 42 | import Data.Monoid (Monoid (..), mempty) 43 | import Data.Traversable (Traversable, traverse) 44 | 45 | import Data.Functor.Identity (Identity (..)) 46 | 47 | import Text.Parser.Char (CharParsing) 48 | import qualified Text.Parser.Char as C 49 | import qualified Text.Parser.Combinators as C 50 | 51 | -- $setup 52 | -- >>> :set -XOverloadedStrings 53 | -- >>> import Utils 54 | -- >>> import Waargonaut.Types.Json 55 | -- >>> import Waargonaut.Types.Whitespace 56 | -- >>> import Data.Either (Either (..)) 57 | -- 58 | 59 | -- | Unary type to represent a comma. 60 | data Comma = Comma 61 | deriving (Eq, Show) 62 | 63 | -- | Parse a single comma (,) 64 | parseComma :: CharParsing f => f Comma 65 | parseComma = Comma <$ C.char ',' 66 | {-# INLINE parseComma #-} 67 | 68 | -- | Parse an optional comma and its trailing whitespace. 69 | -- 70 | -- >>> testparse (parseCommaTrailingMaybe parseWhitespace) ", " 71 | -- Right (Just (Comma,WS [Space])) 72 | -- 73 | -- >>> testparse (parseCommaTrailingMaybe parseWhitespace) " , " 74 | -- Right Nothing 75 | -- 76 | -- >>> testparse (parseCommaTrailingMaybe parseWhitespace) ",, " 77 | -- Right (Just (Comma,WS [])) 78 | -- 79 | parseCommaTrailingMaybe 80 | :: CharParsing f 81 | => f ws 82 | -> f (Maybe (Comma, ws)) 83 | parseCommaTrailingMaybe = 84 | C.optional . liftA2 (,) parseComma 85 | 86 | -- | Data type to represent a single element in a 'Waargonaut.Types.CommaSep.CommaSeparated' list. Carries 87 | -- information about it's own trailing whitespace. Denoted by the @f@. 88 | data Elem f ws a = Elem 89 | { _elemVal :: a 90 | , _elemTrailing :: f (Comma, ws) 91 | } 92 | deriving (Functor, Foldable, Traversable) 93 | 94 | instance (Monoid ws, Applicative f) => Applicative (Elem f ws) where 95 | pure a = Elem a (pure (Comma, mempty)) 96 | (Elem atob _) <*> (Elem a t') = Elem (atob a) t' 97 | 98 | instance Functor f => Bifunctor (Elem f) where 99 | bimap f g (Elem a t) = Elem (g a) (fmap (fmap f) t) 100 | 101 | instance Foldable f => Bifoldable (Elem f) where 102 | bifoldMap f g (Elem a t) = g a `mappend` foldMap (foldMap f) t 103 | 104 | instance Traversable f => Bitraversable (Elem f) where 105 | bitraverse f g (Elem a t) = Elem <$> g a <*> traverse (traverse f) t 106 | 107 | -- | Typeclass for things that contain a single 'Elem' structure. 108 | class HasElem c f ws a | c -> f ws a where 109 | elem :: Lens' c (Elem f ws a) 110 | elemTrailing :: Lens' c (f (Comma, ws)) 111 | {-# INLINE elemTrailing #-} 112 | elemVal :: Lens' c a 113 | {-# INLINE elemVal #-} 114 | elemTrailing = elem . elemTrailing 115 | elemVal = elem . elemVal 116 | 117 | instance HasElem (Elem f ws a) f ws a where 118 | {-# INLINE elemTrailing #-} 119 | {-# INLINE elemVal #-} 120 | elem = id 121 | elemTrailing f (Elem x1 x2) = Elem x1 <$> f x2 122 | elemVal f (Elem x1 x2) = (`Elem` x2) <$> f x1 123 | 124 | instance (Show1 f, Show ws, Show a) => Show (Elem f ws a) where 125 | showsPrec _ (Elem v t) = 126 | showString "Elem {_elemVal = " . shows v . 127 | showString ", _elemTrailing = " . showsPrec1 0 t . showString "}" 128 | 129 | instance (Eq1 f, Eq ws, Eq a) => Eq (Elem f ws a) where 130 | Elem v1 t1 == Elem v2 t2 = v1 == v2 && eq1 t1 t2 131 | 132 | floopId :: Monoid ws => Iso' (Identity (Comma,ws)) (Maybe (Comma,ws)) 133 | floopId = iso (Just . runIdentity) (pure . fromMaybe (Comma, mempty)) 134 | 135 | -- | 'Control.Lens.Iso' between an 'Elem' that is not on the trailing element and one that is. 136 | _ElemTrailingIso 137 | :: ( Monoid ws 138 | , Monoid ws' 139 | ) 140 | => Iso (Elem Identity ws a) (Elem Identity ws' a') (Elem Maybe ws a) (Elem Maybe ws' a') 141 | _ElemTrailingIso = iso 142 | (\(Elem a t) -> Elem a (t ^. floopId)) 143 | (\(Elem a t) -> Elem a (t ^. from floopId)) 144 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/CommaSep/Elems.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# LANGUAGE TupleSections #-} 10 | -- | 11 | -- 12 | -- Data structures and functions for handling the elements contained in a 'Waargonaut.Types.CommaSep.CommaSeparated' structure. 13 | -- 14 | module Waargonaut.Types.CommaSep.Elems 15 | ( 16 | -- * Types 17 | Elems (..) 18 | , HasElems (..) 19 | 20 | -- * Parse 21 | , parseCommaSeparatedElems 22 | 23 | -- * Functions 24 | , consElems 25 | , unconsElems 26 | ) where 27 | 28 | import Prelude (Eq, Show) 29 | 30 | import Control.Applicative (Applicative (..), liftA2, pure, 31 | (<*>)) 32 | import Control.Category (id, (.)) 33 | import Control.Monad (Monad) 34 | 35 | import Control.Lens (Lens', cons, from, snoc, to, 36 | (%~), (.~), (^.), (^?), _Cons) 37 | 38 | import Data.Bifoldable (Bifoldable (bifoldMap)) 39 | import Data.Bifunctor (Bifunctor (bimap)) 40 | import Data.Bitraversable (Bitraversable (bitraverse)) 41 | import Data.Foldable (Foldable, foldMap) 42 | import Data.Function (($), (&)) 43 | import Data.Functor (Functor, fmap, (<$>)) 44 | import Data.Functor.Identity (Identity (..)) 45 | import Data.Maybe (Maybe (..), maybe) 46 | import Data.Monoid (Monoid (..), mempty) 47 | import Data.Semigroup (Semigroup ((<>))) 48 | import Data.Traversable (Traversable, traverse) 49 | 50 | import Data.Vector (Vector) 51 | 52 | import Text.Parser.Char (CharParsing) 53 | import qualified Text.Parser.Combinators as C 54 | 55 | import Waargonaut.Types.CommaSep.Elem (Comma, Elem (..), HasElem (..), 56 | parseCommaTrailingMaybe, 57 | _ElemTrailingIso) 58 | -- $setup 59 | -- >>> :set -XOverloadedStrings 60 | -- >>> import Utils 61 | -- >>> import Waargonaut.Types.Json 62 | -- >>> import Waargonaut.Types.Whitespace 63 | -- >>> import Control.Monad (return) 64 | -- >>> import Data.Either (Either (..), isLeft) 65 | -- >>> import Waargonaut.Decode.Error (DecodeError) 66 | -- >>> import Data.Digit (HeXDigit) 67 | -- >>> import Text.Parser.Char (alphaNum) 68 | -- >>> import Data.Char (Char) 69 | -- >>> let charWS = ((,) <$> alphaNum <*> parseWhitespace) :: CharParsing f => f (Char, WS) 70 | ---- 71 | 72 | -- | This type represents a non-empty list of elements, enforcing that the any 73 | -- element but the last must be followed by a trailing comma and supporting option 74 | -- of a final trailing comma. 75 | data Elems ws a = Elems 76 | { _elemsElems :: Vector (Elem Identity ws a) 77 | , _elemsLast :: Elem Maybe ws a 78 | } 79 | deriving (Eq, Show, Functor, Foldable, Traversable) 80 | 81 | instance Bifunctor Elems where 82 | bimap f g (Elems es el) = Elems (fmap (bimap f g) es) (bimap f g el) 83 | 84 | instance Bifoldable Elems where 85 | bifoldMap f g (Elems es el) = foldMap (bifoldMap f g) es `mappend` bifoldMap f g el 86 | 87 | instance Bitraversable Elems where 88 | bitraverse f g (Elems es el) = Elems 89 | <$> traverse (bitraverse f g) es 90 | <*> bitraverse f g el 91 | 92 | -- | Typeclass for things that contain an 'Elems' structure. 93 | class HasElems c ws a | c -> ws a where 94 | elems :: Lens' c (Elems ws a) 95 | elemsElems :: Lens' c (Vector (Elem Identity ws a)) 96 | {-# INLINE elemsElems #-} 97 | elemsLast :: Lens' c (Elem Maybe ws a) 98 | {-# INLINE elemsLast #-} 99 | elemsElems = elems . elemsElems 100 | elemsLast = elems . elemsLast 101 | 102 | instance HasElems (Elems ws a) ws a where 103 | {-# INLINE elemsElems #-} 104 | {-# INLINE elemsLast #-} 105 | elems = id 106 | elemsElems f (Elems x1 x2) = fmap (`Elems` x2) (f x1) 107 | elemsLast f (Elems x1 x2) = fmap (Elems x1) (f x2) 108 | 109 | instance Monoid ws => Applicative (Elems ws) where 110 | pure a = Elems mempty (pure a) 111 | Elems atobs atob <*> Elems as a = Elems (liftA2 (<*>) atobs as) (atob <*> a) 112 | 113 | instance Monoid ws => Semigroup (Elems ws a) where 114 | (<>) (Elems as alast) (Elems bs blast) = 115 | Elems (snoc as (alast ^. from _ElemTrailingIso) <> bs) blast 116 | 117 | -- | Add a value to the beginning of the 'Elems' 118 | consElems :: Monoid ws => ((Comma,ws), a) -> Elems ws a -> Elems ws a 119 | consElems (ews,a) e = e & elemsElems %~ cons (Elem a (Identity ews)) 120 | {-# INLINE consElems #-} 121 | 122 | -- | Attempt to remove the initial value off the front of an 'Elems' 123 | unconsElems :: Monoid ws => Elems ws a -> ((Maybe (Comma,ws), a), Maybe (Elems ws a)) 124 | unconsElems e = maybe (e', Nothing) (\(em, ems) -> (idT em, Just $ e & elemsElems .~ ems)) es' 125 | where 126 | es' = e ^? elemsElems . _Cons 127 | e' = (e ^. elemsLast . elemTrailing, e ^. elemsLast . elemVal) 128 | idT x = (x ^. elemTrailing . to (Just . runIdentity), x ^. elemVal) 129 | {-# INLINE unconsElems #-} 130 | 131 | -- | Parse the elements of a 'Waargonaut.Types.CommaSep.CommaSeparated' list, handling the optional trailing comma and its whitespace. 132 | -- 133 | -- >>> testparse (parseCommaSeparatedElems parseWhitespace alphaNum) "a, b, c, d" 134 | -- Right (Elems {_elemsElems = [Elem {_elemVal = 'a', _elemTrailing = Identity (Comma,WS [Space])},Elem {_elemVal = 'b', _elemTrailing = Identity (Comma,WS [Space])},Elem {_elemVal = 'c', _elemTrailing = Identity (Comma,WS [Space])}], _elemsLast = Elem {_elemVal = 'd', _elemTrailing = Nothing}}) 135 | -- 136 | -- >>> testparse (parseCommaSeparatedElems parseWhitespace alphaNum) "a, b,c,d, " 137 | -- Right (Elems {_elemsElems = [Elem {_elemVal = 'a', _elemTrailing = Identity (Comma,WS [Space])},Elem {_elemVal = 'b', _elemTrailing = Identity (Comma,WS [])},Elem {_elemVal = 'c', _elemTrailing = Identity (Comma,WS [])}], _elemsLast = Elem {_elemVal = 'd', _elemTrailing = Just (Comma,WS [Space])}}) 138 | -- 139 | -- >>> testparse (parseCommaSeparatedElems parseWhitespace alphaNum) "d, " 140 | -- Right (Elems {_elemsElems = [], _elemsLast = Elem {_elemVal = 'd', _elemTrailing = Just (Comma,WS [Space])}}) 141 | -- 142 | -- >>> testparse (parseCommaSeparatedElems parseWhitespace charWS) "d , " 143 | -- Right (Elems {_elemsElems = [], _elemsLast = Elem {_elemVal = ('d',WS [Space]), _elemTrailing = Just (Comma,WS [Space])}}) 144 | -- 145 | -- >>> testparse (parseCommaSeparatedElems parseWhitespace charWS) "d\n, e, " 146 | -- Right (Elems {_elemsElems = [Elem {_elemVal = ('d',WS [NewLine]), _elemTrailing = Identity (Comma,WS [Space])}], _elemsLast = Elem {_elemVal = ('e',WS []), _elemTrailing = Just (Comma,WS [Space,Space])}}) 147 | -- 148 | parseCommaSeparatedElems 149 | :: ( Monad f 150 | , CharParsing f 151 | ) 152 | => f ws 153 | -> f a 154 | -> f (Elems ws a) 155 | parseCommaSeparatedElems ws a = do 156 | hd <- a 157 | sep <- parseCommaTrailingMaybe ws 158 | maybe (pure $ Elems mempty (Elem hd sep)) (go mempty . (hd,)) sep 159 | where 160 | idElem e = Elem e . Identity 161 | 162 | fin cels lj sp = 163 | pure $ Elems cels (Elem lj sp) 164 | 165 | go commaElems (lastJ, lastSep) = do 166 | mJ <- C.optional a 167 | case mJ of 168 | Nothing -> fin commaElems lastJ (Just lastSep) 169 | Just j -> do 170 | msep <- parseCommaTrailingMaybe ws 171 | let commaElems' = snoc commaElems $ idElem lastJ lastSep 172 | maybe (fin commaElems' j Nothing) (go commaElems' . (j,)) msep 173 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/JArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoImplicitPrelude #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | -- | 10 | -- 11 | -- JSON Array representation and functions. 12 | -- 13 | module Waargonaut.Types.JArray 14 | ( 15 | -- * Types 16 | JArray (..) 17 | 18 | -- * Parser 19 | , parseJArray 20 | ) where 21 | 22 | import Prelude (Eq, Show, Int) 23 | 24 | import Control.Category ((.)) 25 | import Control.Error.Util (note) 26 | import Control.Lens (AsEmpty (..), Cons (..), Rewrapped, Ixed (..), Index, IxValue, 27 | Wrapped (..), cons, iso, 28 | nearly, over, prism, to, ( # ), 29 | (^.), (^?), _2, _Wrapped) 30 | import Control.Lens.Extras (is) 31 | import Control.Monad (Monad) 32 | 33 | import Data.Bifoldable (Bifoldable (bifoldMap)) 34 | import Data.Bifunctor (Bifunctor (bimap)) 35 | import Data.Bitraversable (Bitraversable (bitraverse)) 36 | import Data.Foldable (Foldable) 37 | import Data.Function (($)) 38 | import Data.Functor (Functor, (<$>)) 39 | import Data.Monoid (Monoid (..), mempty) 40 | import Data.Semigroup (Semigroup (..)) 41 | import Data.Traversable (Traversable) 42 | 43 | import Text.Parser.Char (CharParsing, char) 44 | 45 | import Waargonaut.Types.CommaSep (CommaSeparated, 46 | parseCommaSeparated) 47 | 48 | -- $setup 49 | -- >>> :set -XOverloadedStrings 50 | -- >>> import Utils 51 | -- >>> import Waargonaut.Types.Json 52 | -- >>> import Waargonaut.Types.Whitespace 53 | -- >>> import Control.Monad (return) 54 | -- >>> import Data.Either (Either (..), isLeft) 55 | -- >>> import Waargonaut.Decode.Error (DecodeError) 56 | ---- 57 | 58 | -- | Conveniently, a JSON array is a 'CommaSeparated' list with an optional 59 | -- trailing comma, some instances and other functions need to work differently so 60 | -- we wrap it up in a newtype. 61 | newtype JArray ws a = 62 | JArray (CommaSeparated ws a) 63 | deriving (Eq, Show, Functor, Foldable, Traversable) 64 | 65 | instance JArray ws a ~ t => Rewrapped (JArray ws a) t 66 | instance Wrapped (JArray ws a) where 67 | type Unwrapped (JArray ws a) = CommaSeparated ws a 68 | _Wrapped' = iso (\(JArray x) -> x) JArray 69 | 70 | instance Monoid ws => Cons (JArray ws a) (JArray ws a) a a where 71 | _Cons = prism 72 | (\(a,j) -> over _Wrapped (cons a) j) 73 | (\j -> note j $ over _2 (_Wrapped #) <$> j ^? _Wrapped . _Cons) 74 | {-# INLINE _Cons #-} 75 | 76 | instance (Semigroup ws, Monoid ws) => AsEmpty (JArray ws a) where 77 | _Empty = nearly (JArray mempty) (^. _Wrapped . to (is _Empty)) 78 | {-# INLINE _Empty #-} 79 | 80 | instance (Monoid ws, Semigroup ws) => Semigroup (JArray ws a) where 81 | (JArray a) <> (JArray b) = JArray (a <> b) 82 | 83 | instance (Semigroup ws, Monoid ws) => Monoid (JArray ws a) where 84 | mempty = JArray mempty 85 | mappend = (<>) 86 | 87 | type instance IxValue (JArray ws a) = a 88 | type instance Index (JArray ws a) = Int 89 | 90 | instance Ixed (JArray ws a) where 91 | ix i f (JArray cs) = JArray <$> ix i f cs 92 | 93 | instance Bifunctor JArray where 94 | bimap f g (JArray cs) = JArray (bimap f g cs) 95 | 96 | instance Bifoldable JArray where 97 | bifoldMap f g (JArray cs) = bifoldMap f g cs 98 | 99 | instance Bitraversable JArray where 100 | bitraverse f g (JArray cs) = JArray <$> bitraverse f g cs 101 | 102 | -- | Parse a single JSON array 103 | -- 104 | -- >>> testparse (parseJArray parseWhitespace parseWaargonaut) "[null ]" 105 | -- Right (JArray (CommaSeparated (WS []) (Just (Elems {_elemsElems = [], _elemsLast = Elem {_elemVal = Json (JNull (WS [Space])), _elemTrailing = Nothing}})))) 106 | -- 107 | -- >>> testparse (parseJArray parseWhitespace parseWaargonaut) "[null,]" 108 | -- Right (JArray (CommaSeparated (WS []) (Just (Elems {_elemsElems = [], _elemsLast = Elem {_elemVal = Json (JNull (WS [])), _elemTrailing = Just (Comma,WS [])}})))) 109 | -- 110 | parseJArray 111 | :: ( Monad f 112 | , CharParsing f 113 | ) 114 | => f ws 115 | -> f a 116 | -> f (JArray ws a) 117 | parseJArray ws a = JArray <$> 118 | parseCommaSeparated (char '[') (char ']') ws a 119 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/JChar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | -- | Types and functions for handling characters in JSON. 12 | module Waargonaut.Types.JChar 13 | ( 14 | -- * Types 15 | JChar (..) 16 | , AsJChar (..) 17 | , HasJChar (..) 18 | 19 | -- * Parser 20 | , parseJChar 21 | 22 | -- * Conversion 23 | , utf8CharToJChar 24 | , jCharToUtf8Char 25 | , jCharToChar 26 | , charToJChar 27 | ) where 28 | 29 | import Prelude (Char, Eq, Ord, Show, 30 | otherwise, (/=)) 31 | 32 | import Control.Category (id, (.)) 33 | import Control.Lens (Lens', Prism', preview, 34 | prism, review) 35 | 36 | import Control.Applicative ((<$>), (<|>)) 37 | 38 | import Data.Bits ((.&.)) 39 | import Data.Char (ord) 40 | import Data.Either (Either (..)) 41 | import Data.Foldable (Foldable, asum) 42 | import Data.Function (($)) 43 | import Data.Functor (Functor) 44 | import Data.Maybe (Maybe (..), fromMaybe) 45 | import Data.Traversable (Traversable) 46 | 47 | import qualified Data.Text.Internal as Text 48 | 49 | import Data.Digit (HeXDigit, HeXaDeCiMaL) 50 | import qualified Data.Digit as D 51 | 52 | import Text.Parser.Char (CharParsing) 53 | 54 | import Waargonaut.Types.JChar.HexDigit4 (HexDigit4 (..)) 55 | 56 | import Waargonaut.Types.JChar.Escaped (AsEscaped (..), Escaped (..), 57 | charToEscaped, escapedToChar, 58 | parseEscaped) 59 | 60 | import Waargonaut.Types.JChar.Unescaped (AsUnescaped (..), Unescaped, 61 | parseUnescaped) 62 | 63 | -- $setup 64 | -- >>> :set -XOverloadedStrings 65 | -- >>> import Data.Function (($)) 66 | -- >>> import Data.Either(Either (..), isLeft) 67 | -- >>> import Data.Digit (HeXDigit(..)) 68 | -- >>> import Utils 69 | -- >>> import Waargonaut.Decode.Error (DecodeError) 70 | -- >>> import Waargonaut.Types.Whitespace 71 | -- >>> import Waargonaut.Types.JChar.Unescaped 72 | -- >>> import Waargonaut.Types.JChar.Escaped 73 | -- >>> import Waargonaut.Types.JChar 74 | ---- 75 | 76 | -- | A JChar may be unescaped or escaped. 77 | data JChar digit 78 | = EscapedJChar ( Escaped digit ) 79 | | UnescapedJChar Unescaped 80 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 81 | 82 | -- | Typeclass for things that have a 'JChar'. 83 | class HasJChar c digit | c -> digit where 84 | jChar :: Lens' c (JChar digit) 85 | 86 | instance HasJChar (JChar digit) digit where 87 | jChar = id 88 | 89 | -- | Typeclass for things that be used as a 'JChar'. 90 | class AsJChar r digit | r -> digit where 91 | _JChar :: Prism' r (JChar digit) 92 | _EscapedJChar :: Prism' r (Escaped digit) 93 | _UnescapedJChar :: Prism' r Unescaped 94 | 95 | _EscapedJChar = _JChar . _EscapedJChar 96 | _UnescapedJChar = _JChar . _UnescapedJChar 97 | 98 | instance AsJChar (JChar digit) digit where 99 | _JChar = id 100 | _EscapedJChar = prism EscapedJChar 101 | (\ x -> case x of 102 | EscapedJChar y1 -> Right y1 103 | _ -> Left x 104 | ) 105 | _UnescapedJChar = prism UnescapedJChar 106 | (\ x -> case x of 107 | UnescapedJChar y1 -> Right y1 108 | _ -> Left x 109 | ) 110 | 111 | instance AsEscaped (JChar digit) digit where 112 | _Escaped = _JChar . _Escaped 113 | 114 | instance AsUnescaped (JChar digit) where 115 | _Unescaped = _JChar . _Unescaped 116 | 117 | -- instance AsJChar Char HeXDigit where 118 | -- Don't implement this, it's not a lawful prism. 119 | 120 | -- | Convert a 'JChar' to a Haskell 'Char' 121 | jCharToChar :: JChar HeXDigit -> Char 122 | jCharToChar (UnescapedJChar uejc) = review _Unescaped uejc 123 | jCharToChar (EscapedJChar ejc) = escapedToChar ejc 124 | 125 | -- | Attempt to convert a Haskell 'Char' to a JSON acceptable 'JChar' 126 | charToJChar :: Char -> Maybe (JChar HeXDigit) 127 | charToJChar c = 128 | (UnescapedJChar <$> preview _Unescaped c) <|> 129 | (EscapedJChar <$> charToEscaped c) 130 | 131 | utf8SafeChar :: Char -> Maybe Char 132 | utf8SafeChar c | ord c .&. 0x1ff800 /= 0xd800 = Just c 133 | | otherwise = Nothing 134 | 135 | -- | Convert a 'Char' to 'JChar HexDigit' and replace any invalid values with 136 | -- @U+FFFD@ as per the 'Data.Text.Text' documentation. 137 | -- 138 | -- Refer to documentation for more info. 139 | -- 140 | utf8CharToJChar :: Char -> JChar HeXDigit 141 | utf8CharToJChar c = fromMaybe scalarReplacement (charToJChar $ Text.safe c) 142 | where scalarReplacement = EscapedJChar (Hex (HexDigit4 D.xf D.xf D.xf D.xd)) 143 | {-# INLINE utf8CharToJChar #-} 144 | 145 | -- | Try to convert a 'JChar' to a 'Data.Text.Text' safe 'Char' value. Refer to the link for more info: 146 | -- https://hackage.haskell.org/package/text-1.2.3.0/docs/Data-Text-Internal.html#v:safe 147 | jCharToUtf8Char :: JChar HeXDigit -> Maybe Char 148 | jCharToUtf8Char = utf8SafeChar . jCharToChar 149 | {-# INLINE jCharToUtf8Char #-} 150 | 151 | -- | Parse a JSON character. 152 | -- 153 | -- >>> testparse parseJChar "\\u1234" :: Either DecodeError (JChar HeXDigit) 154 | -- Right (EscapedJChar (Hex (HexDigit4 HeXDigit1 HeXDigit2 HeXDigit3 HeXDigit4))) 155 | -- 156 | -- >>> testparse parseJChar "\\\\" :: Either DecodeError (JChar HeXDigit) 157 | -- Right (EscapedJChar ReverseSolidus) 158 | -- 159 | -- >>> testparse parseJChar "\\r" 160 | -- Right (EscapedJChar (WhiteSpace CarriageReturn)) 161 | -- 162 | -- >>> testparsetheneof parseJChar "a" 163 | -- Right (UnescapedJChar (Unescaped 'a')) 164 | -- 165 | -- >>> testparsethennoteof parseJChar "ax" 166 | -- Right (UnescapedJChar (Unescaped 'a')) 167 | parseJChar :: 168 | (CharParsing f, HeXaDeCiMaL digit) => 169 | f ( JChar digit ) 170 | parseJChar = asum 171 | [ EscapedJChar <$> parseEscaped 172 | , UnescapedJChar <$> parseUnescaped 173 | ] 174 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/JChar/Escaped.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | -- | Types and functions for handling escaped characters in JSON. 10 | module Waargonaut.Types.JChar.Escaped 11 | ( 12 | -- * Types 13 | Escaped (..) 14 | , AsEscaped (..) 15 | 16 | -- * Parser 17 | , parseEscaped 18 | 19 | -- * Conversion 20 | , escapedToChar 21 | , charToEscaped 22 | ) where 23 | 24 | import Prelude (Eq, Ord, Show) 25 | 26 | import Control.Applicative (pure, (*>), (<|>)) 27 | import Control.Category (id, (.)) 28 | 29 | import Control.Lens (Prism', preview, prism, to, 30 | _Just) 31 | 32 | import Data.Foldable (Foldable, asum) 33 | import Data.Functor (Functor, (<$>)) 34 | import Data.Traversable (Traversable) 35 | 36 | import Data.Function (const) 37 | 38 | import Data.Char (Char) 39 | import Data.Either (Either (..)) 40 | import Data.Maybe (Maybe (..)) 41 | 42 | import Data.Digit (HeXDigit, HeXaDeCiMaL) 43 | 44 | import Text.Parser.Char (CharParsing, char) 45 | 46 | import Waargonaut.Types.JChar.HexDigit4 (HexDigit4, charToHexDigit4, 47 | hexDigit4ToChar, 48 | parseHexDigit4) 49 | import Waargonaut.Types.Whitespace (Whitespace (..), 50 | escapedWhitespaceChar, 51 | _WhitespaceChar) 52 | 53 | -- $setup 54 | -- >>> :set -XOverloadedStrings 55 | -- >>> import Control.Monad (return) 56 | -- >>> import Data.Either(Either (..), isLeft) 57 | -- >>> import Data.Digit (HeXDigit(..)) 58 | -- >>> import qualified Data.Digit as D 59 | -- >>> import Waargonaut.Decode.Error (DecodeError) 60 | -- >>> import Utils 61 | ---- 62 | 63 | -- | Things that may be escaped in a JSON string. 64 | data Escaped digit 65 | = QuotationMark 66 | | ReverseSolidus 67 | | Solidus 68 | | Backspace 69 | | WhiteSpace Whitespace 70 | | Hex ( HexDigit4 digit ) 71 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 72 | 73 | -- | Typeclass for things that may be used as an escaped JChar. 74 | class AsEscaped r digit | r -> digit where 75 | _Escaped :: Prism' r (Escaped digit) 76 | _QuotationMark :: Prism' r () 77 | _ReverseSolidus :: Prism' r () 78 | _Solidus :: Prism' r () 79 | _Backspace :: Prism' r () 80 | _WhiteSpace :: Prism' r Whitespace 81 | _Hex :: Prism' r (HexDigit4 digit) 82 | 83 | _QuotationMark = _Escaped . _QuotationMark 84 | _ReverseSolidus = _Escaped . _ReverseSolidus 85 | _Solidus = _Escaped . _Solidus 86 | _Backspace = _Escaped . _Backspace 87 | _WhiteSpace = _Escaped . _WhiteSpace 88 | _Hex = _Escaped . _Hex 89 | 90 | instance AsEscaped (Escaped digit) digit where 91 | _Escaped = id 92 | _QuotationMark = prism (const QuotationMark) 93 | (\ x -> case x of 94 | QuotationMark -> Right () 95 | _ -> Left x 96 | ) 97 | _ReverseSolidus = prism (const ReverseSolidus) 98 | (\ x -> case x of 99 | ReverseSolidus -> Right () 100 | _ -> Left x 101 | ) 102 | _Solidus = prism (const Solidus) 103 | (\ x -> case x of 104 | Solidus -> Right () 105 | _ -> Left x 106 | ) 107 | _Backspace = prism (const Backspace) 108 | (\ x -> case x of 109 | Backspace -> Right () 110 | _ -> Left x 111 | ) 112 | _WhiteSpace = prism WhiteSpace 113 | (\ x -> case x of 114 | WhiteSpace y1 -> Right y1 115 | _ -> Left x 116 | ) 117 | _Hex = prism Hex 118 | (\ x -> case x of 119 | Hex y1 -> Right y1 120 | _ -> Left x 121 | ) 122 | 123 | -- | Parse an escapted JSON character. 124 | -- 125 | -- >>> testparse parseEscaped "\\\"" 126 | -- Right QuotationMark 127 | -- 128 | -- >>> testparse parseEscaped "\\\\" 129 | -- Right ReverseSolidus 130 | -- 131 | -- >>> testparse parseEscaped "\\/" 132 | -- Right Solidus 133 | -- 134 | -- >>> testparse parseEscaped "\\b" 135 | -- Right Backspace 136 | -- 137 | -- >>> testparse parseEscaped "\\f" 138 | -- Right (WhiteSpace LineFeed) 139 | -- 140 | -- >>> testparse parseEscaped "\\n" 141 | -- Right (WhiteSpace NewLine) 142 | -- 143 | -- >>> testparse parseEscaped "\\r" 144 | -- Right (WhiteSpace CarriageReturn) 145 | -- 146 | -- >>> testparse parseEscaped "\\t" 147 | -- Right (WhiteSpace HorizontalTab) 148 | -- 149 | -- >>> testparse parseEscaped "\\u1234" :: Either DecodeError (Escaped HeXDigit) 150 | -- Right (Hex (HexDigit4 HeXDigit1 HeXDigit2 HeXDigit3 HeXDigit4)) 151 | -- 152 | -- >>> testparsetheneof parseEscaped "\\t" 153 | -- Right (WhiteSpace HorizontalTab) 154 | -- 155 | -- >>> testparsethennoteof parseEscaped "\\tx" 156 | -- Right (WhiteSpace HorizontalTab) 157 | parseEscaped :: 158 | (CharParsing f, HeXaDeCiMaL digit) => 159 | f ( Escaped digit ) 160 | parseEscaped = 161 | let 162 | z = 163 | asum ((\(c, p) -> char c *> pure p) <$> 164 | [ 165 | ('"' , QuotationMark) 166 | , ('\\', ReverseSolidus) 167 | , ('/' , Solidus) 168 | , ('b' , Backspace) 169 | , (' ' , WhiteSpace Space) 170 | , ('f' , WhiteSpace LineFeed) 171 | , ('n' , WhiteSpace NewLine) 172 | , ('r' , WhiteSpace CarriageReturn) 173 | , ('t' , WhiteSpace HorizontalTab) 174 | ]) 175 | h = 176 | Hex <$> (char 'u' *> parseHexDigit4) 177 | in 178 | char '\\' *> (z <|> h) 179 | 180 | -- | Convert an 'Escaped' character to a Haskell 'Char' 181 | escapedToChar :: Escaped HeXDigit -> Char 182 | escapedToChar = \case 183 | QuotationMark -> '"' 184 | ReverseSolidus -> '\\' 185 | Solidus -> '/' 186 | Backspace -> '\b' 187 | WhiteSpace wc -> escapedWhitespaceChar wc 188 | Hex hd -> hexDigit4ToChar hd 189 | 190 | -- | Attempt to convert a Haskell 'Char' to an 'Escaped' JSON character 191 | charToEscaped :: Char -> Maybe (Escaped HeXDigit) 192 | charToEscaped c = case c of 193 | '"' -> Just QuotationMark 194 | '\\' -> Just ReverseSolidus 195 | '/' -> Just Solidus 196 | '\b' -> Just Backspace 197 | _ -> preview asWhitespace c <|> preview asHex c 198 | where 199 | asWhitespace = _WhitespaceChar . to WhiteSpace 200 | asHex = to charToHexDigit4 . _Just . to Hex 201 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/JChar/HexDigit4.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FunctionalDependencies #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | -- | 10 | -- 11 | -- Types and functions for handling \\u0000 values in JSON. 12 | -- 13 | module Waargonaut.Types.JChar.HexDigit4 14 | ( 15 | -- * Types 16 | HexDigit4 (..) 17 | , HasHexDigit4 (..) 18 | 19 | -- * Parse / Build 20 | , parseHexDigit4 21 | 22 | -- * Conversion 23 | , hexDigit4ToChar 24 | , charToHexDigit4 25 | ) where 26 | 27 | import Prelude (Eq, Ord (..), Show, otherwise, (||)) 28 | 29 | import Control.Applicative ((<*>)) 30 | import Control.Category (id, (.)) 31 | import Control.Lens (Lens') 32 | import Control.Monad ((=<<)) 33 | 34 | import Control.Error.Util (hush) 35 | 36 | import Data.List.NonEmpty (NonEmpty ((:|))) 37 | 38 | import Data.Foldable (Foldable) 39 | import Data.Function (($)) 40 | import Data.Functor (Functor, fmap, (<$>)) 41 | import Data.Traversable (Traversable) 42 | 43 | import Data.Char (Char, chr, ord) 44 | import Data.Either (Either (..)) 45 | import Data.Maybe (Maybe (..)) 46 | import Text.Parser.Char (CharParsing) 47 | 48 | import Data.Digit (HeXDigit, HeXaDeCiMaL) 49 | import qualified Data.Digit as D 50 | 51 | -- $setup 52 | -- >>> :set -XOverloadedStrings 53 | -- >>> import Control.Monad (return) 54 | -- >>> import Data.Either(Either (..), isLeft) 55 | -- >>> import Data.Digit (HeXDigit(..)) 56 | -- >>> import qualified Data.Digit as D 57 | -- >>> import Waargonaut.Decode.Error (DecodeError) 58 | -- >>> import Utils 59 | ---- 60 | 61 | -- | JSON Characters may be single escaped UTF16 "\uab34". 62 | data HexDigit4 d = 63 | HexDigit4 d d d d 64 | deriving (Eq, Show, Ord, Functor, Foldable, Traversable) 65 | 66 | -- | Typeclass for things that contain a 'HexDigit4'. 67 | class HasHexDigit4 c d | c -> d where 68 | hexDigit4 :: Lens' c (HexDigit4 d) 69 | 70 | instance HasHexDigit4 (HexDigit4 d) d where 71 | hexDigit4 = id 72 | 73 | hexHeX :: D.HexDigit -> D.HeXDigit 74 | hexHeX = \case 75 | D.HexDigit0 -> D.HeXDigit0 76 | D.HexDigit1 -> D.HeXDigit1 77 | D.HexDigit2 -> D.HeXDigit2 78 | D.HexDigit3 -> D.HeXDigit3 79 | D.HexDigit4 -> D.HeXDigit4 80 | D.HexDigit5 -> D.HeXDigit5 81 | D.HexDigit6 -> D.HeXDigit6 82 | D.HexDigit7 -> D.HeXDigit7 83 | D.HexDigit8 -> D.HeXDigit8 84 | D.HexDigit9 -> D.HeXDigit9 85 | D.HexDigita -> D.HeXDigita 86 | D.HexDigitb -> D.HeXDigitb 87 | D.HexDigitc -> D.HeXDigitc 88 | D.HexDigitd -> D.HeXDigitd 89 | D.HexDigite -> D.HeXDigite 90 | D.HexDigitf -> D.HeXDigitf 91 | 92 | -- | Convert a given 'HexDigit4' to a Haskell 'Char'. 93 | hexDigit4ToChar :: HexDigit4 HeXDigit -> Char 94 | hexDigit4ToChar (HexDigit4 a b c d) = chr (D._HeXDigitsIntegral (Right $ a :| [b,c,d])) 95 | 96 | -- | Try to convert a Haskell 'Char' to a JSON acceptable character. NOTE: This 97 | -- cannot preserve the upper or lower casing of any original 'Waargonaut.Types.Json.Json' data structure 98 | -- inputs that may have been used to create this 'Char'. Also the JSON RFC 99 | -- specifies a "limited" range of @U+0000@ to @U+FFFF@ as permissible as a six 100 | -- character sequence: @\u0000@. 101 | charToHexDigit4 :: Char -> Maybe (HexDigit4 HeXDigit) 102 | charToHexDigit4 x 103 | | x < '\x0' || x > '\xffff' = Nothing 104 | | otherwise = toHexDig . fmap hexHeX =<< hush (D.integralHexDigits (ord x)) 105 | where 106 | z = D.x0 107 | 108 | toHexDig (a :| [b,c,d]) = Just (HexDigit4 a b c d) 109 | toHexDig ( b :| [c,d]) = Just (HexDigit4 z b c d) 110 | toHexDig ( c :| [d]) = Just (HexDigit4 z z c d) 111 | toHexDig ( d :| []) = Just (HexDigit4 z z z d) 112 | toHexDig _ = Nothing 113 | 114 | {-# INLINE charToHexDigit4 #-} 115 | 116 | -- | Parse a single 'HexDigit4'. 117 | -- 118 | -- >>> testparse parseHexDigit4 "1234" :: Either DecodeError (HexDigit4 HeXDigit) 119 | -- Right (HexDigit4 HeXDigit1 HeXDigit2 HeXDigit3 HeXDigit4) 120 | -- 121 | -- >>> testparse parseHexDigit4 "12aF" :: Either DecodeError (HexDigit4 HeXDigit) 122 | -- Right (HexDigit4 HeXDigit1 HeXDigit2 HeXDigita HeXDigitF) 123 | -- 124 | -- >>> testparse parseHexDigit4 "aBcD" :: Either DecodeError (HexDigit4 HeXDigit) 125 | -- Right (HexDigit4 HeXDigita HeXDigitB HeXDigitc HeXDigitD) 126 | -- 127 | -- >>> testparsetheneof parseHexDigit4 "12aF" :: Either DecodeError (HexDigit4 HeXDigit) 128 | -- Right (HexDigit4 HeXDigit1 HeXDigit2 HeXDigita HeXDigitF) 129 | -- 130 | -- >>> testparsethennoteof parseHexDigit4 "12aFx" :: Either DecodeError (HexDigit4 HeXDigit) 131 | -- Right (HexDigit4 HeXDigit1 HeXDigit2 HeXDigita HeXDigitF) 132 | parseHexDigit4 :: 133 | ( CharParsing f, HeXaDeCiMaL digit ) => 134 | f ( HexDigit4 digit ) 135 | parseHexDigit4 = HexDigit4 136 | <$> D.parseHeXaDeCiMaL 137 | <*> D.parseHeXaDeCiMaL 138 | <*> D.parseHeXaDeCiMaL 139 | <*> D.parseHeXaDeCiMaL 140 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/JChar/Unescaped.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Types and functions for handling valid unescaped characters in JSON. 4 | -- 5 | module Waargonaut.Types.JChar.Unescaped 6 | ( 7 | -- * Types 8 | Unescaped (..) 9 | , AsUnescaped (..) 10 | 11 | -- * Parser 12 | , parseUnescaped 13 | ) where 14 | 15 | import Prelude (Eq, Ord (..), Show, (&&), (==), (||)) 16 | 17 | import Control.Category (id) 18 | import Control.Lens (Prism', has, prism') 19 | 20 | import Data.Foldable (any) 21 | import Data.Function (($)) 22 | import Data.Functor ((<$>)) 23 | 24 | import Data.Char (Char, ord) 25 | import Data.Maybe (Maybe (..)) 26 | 27 | import Text.Parser.Char (CharParsing, satisfy) 28 | 29 | -- $setup 30 | -- >>> :set -XOverloadedStrings 31 | -- >>> import Control.Monad (return) 32 | -- >>> import Data.Either(Either (..), isLeft) 33 | -- >>> import Data.Digit (HeXDigit(..)) 34 | -- >>> import qualified Data.Digit as D 35 | -- >>> import Waargonaut.Decode.Error (DecodeError) 36 | -- >>> import Utils 37 | ---- 38 | 39 | -- | Type to specify that this character is unescaped and may be represented 40 | -- using a normal Haskell 'Char'. 41 | newtype Unescaped = 42 | Unescaped Char 43 | deriving (Eq, Ord, Show) 44 | 45 | -- | Typeclass for things that may used as an unescaped JChar. 46 | class AsUnescaped a where 47 | _Unescaped :: Prism' a Unescaped 48 | 49 | instance AsUnescaped Unescaped where 50 | _Unescaped = id 51 | 52 | instance AsUnescaped Char where 53 | _Unescaped = prism' 54 | (\(Unescaped c) -> c) 55 | (\c -> if any ($ c) excluded then Nothing 56 | else Just (Unescaped c) 57 | ) 58 | where 59 | excluded = 60 | [ (== '\NUL') 61 | , (== '"') 62 | , (== '\\') 63 | , \x -> 64 | let 65 | c = ord x 66 | in 67 | (c < 0x20 && c > 0x21) || -- "%x20-21" 68 | (c < 0x23 && c > 0x5B) || -- "%x23-5B" 69 | (c < 0x5D && c > 0x10FFFF) -- "%x5D-10FFFF" 70 | ] 71 | 72 | -- | Parse an unescaped JSON character. 73 | -- 74 | -- >>> testparse parseUnescaped "a" 75 | -- Right (Unescaped 'a') 76 | -- 77 | -- >>> testparse parseUnescaped "\8728" 78 | -- Right (Unescaped '\8728') 79 | -- 80 | -- >>> testparsetheneof parseUnescaped "a" 81 | -- Right (Unescaped 'a') 82 | -- 83 | -- >>> testparsethennoteof parseUnescaped "ax" 84 | -- Right (Unescaped 'a') 85 | parseUnescaped :: 86 | CharParsing f => 87 | f Unescaped 88 | parseUnescaped = 89 | Unescaped <$> satisfy (has _Unescaped) 90 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/JObject/JAssoc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | -- | Types and functions for handling our representation of a key:value pair in 12 | -- a JSON object. 13 | module Waargonaut.Types.JObject.JAssoc 14 | ( 15 | -- * Key/value pair type 16 | JAssoc (..) 17 | , HasJAssoc (..) 18 | 19 | -- * Parse 20 | , parseJAssoc 21 | 22 | -- * Update 23 | , jAssocAlterF 24 | ) where 25 | 26 | import Prelude (Eq, Show) 27 | 28 | import Control.Applicative ((<*), (<*>)) 29 | import Control.Category (id, (.)) 30 | import Control.Lens (Lens', ( # ), (.~)) 31 | 32 | import Control.Monad (Monad) 33 | import Data.Bifoldable (Bifoldable (bifoldMap)) 34 | import Data.Bifunctor (Bifunctor (bimap)) 35 | import Data.Bitraversable (Bitraversable (bitraverse)) 36 | import Data.Foldable (Foldable) 37 | import Data.Functor (Functor, fmap, (<$>)) 38 | import Data.Maybe (Maybe (..), maybe) 39 | import Data.Monoid (Monoid (mappend, mempty)) 40 | import Data.Text (Text) 41 | import Data.Traversable (Traversable) 42 | 43 | import Text.Parser.Char (CharParsing, char) 44 | 45 | import Waargonaut.Types.JString (JString, 46 | parseJString, _JStringText) 47 | 48 | -- | This type represents the key:value pair inside of a JSON object. 49 | -- 50 | -- It is built like this so that we can preserve any whitespace information that 51 | -- may surround it. 52 | data JAssoc ws a = JAssoc 53 | { _jsonAssocKey :: JString 54 | , _jsonAssocKeyTrailingWS :: ws 55 | , _jsonAssocValPreceedingWS :: ws 56 | , _jsonAssocVal :: a 57 | } 58 | deriving (Eq, Show, Functor, Foldable, Traversable) 59 | 60 | instance Bifunctor JAssoc where 61 | bimap f g (JAssoc k w1 w2 v) = JAssoc k (f w1) (f w2) (g v) 62 | 63 | instance Bifoldable JAssoc where 64 | bifoldMap f g (JAssoc _ w1 w2 v) = f w1 `mappend` f w2 `mappend` g v 65 | 66 | instance Bitraversable JAssoc where 67 | bitraverse f g (JAssoc k w1 w2 v) = JAssoc k <$> f w1 <*> f w2 <*> g v 68 | 69 | -- | This class allows you to write connective lenses for other data structures 70 | -- that may contain a 'JAssoc'. 71 | class HasJAssoc c ws a | c -> ws a where 72 | jAssoc :: Lens' c (JAssoc ws a) 73 | jsonAssocKey :: Lens' c JString 74 | {-# INLINE jsonAssocKey #-} 75 | jsonAssocKeyTrailingWS :: Lens' c ws 76 | {-# INLINE jsonAssocKeyTrailingWS #-} 77 | jsonAssocVal :: Lens' c a 78 | {-# INLINE jsonAssocVal #-} 79 | jsonAssocValPreceedingWS :: Lens' c ws 80 | {-# INLINE jsonAssocValPreceedingWS #-} 81 | jsonAssocKey = jAssoc . jsonAssocKey 82 | jsonAssocKeyTrailingWS = jAssoc . jsonAssocKeyTrailingWS 83 | jsonAssocVal = jAssoc . jsonAssocVal 84 | jsonAssocValPreceedingWS = jAssoc . jsonAssocValPreceedingWS 85 | 86 | instance HasJAssoc (JAssoc ws a) ws a where 87 | jAssoc = id 88 | jsonAssocKey f (JAssoc x1 x2 x3 x4) = fmap (\y1 -> JAssoc y1 x2 x3 x4) (f x1) 89 | {-# INLINE jsonAssocKey #-} 90 | jsonAssocKeyTrailingWS f (JAssoc x1 x2 x3 x4) = fmap (\y1 -> JAssoc x1 y1 x3 x4) (f x2) 91 | {-# INLINE jsonAssocKeyTrailingWS #-} 92 | jsonAssocVal f (JAssoc x1 x2 x3 x4) = fmap (JAssoc x1 x2 x3) (f x4) 93 | {-# INLINE jsonAssocVal #-} 94 | jsonAssocValPreceedingWS f (JAssoc x1 x2 x3 x4) = fmap (\y1 -> JAssoc x1 x2 y1 x4) (f x3) 95 | {-# INLINE jsonAssocValPreceedingWS #-} 96 | 97 | -- | Helper function for trying to update/create a JAssoc value in some Functor. 98 | -- This function is analogus to the 'Data.Map.alterF' function. 99 | jAssocAlterF 100 | :: ( Monoid ws 101 | , Functor f 102 | ) 103 | => Text 104 | -> (Maybe a -> f (Maybe a)) 105 | -> Maybe (JAssoc ws a) 106 | -> f (Maybe (JAssoc ws a)) 107 | jAssocAlterF k f mja = fmap g <$> f (_jsonAssocVal <$> mja) where 108 | g v = maybe (JAssoc (_JStringText # k) mempty mempty v) (jsonAssocVal .~ v) mja 109 | 110 | -- | Parse a single "key:value" pair 111 | parseJAssoc 112 | :: ( Monad f 113 | , CharParsing f 114 | ) 115 | => f ws 116 | -> f a 117 | -> f (JAssoc ws a) 118 | parseJAssoc ws a = JAssoc 119 | <$> parseJString <*> ws <* char ':' <*> ws <*> a 120 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/JString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoImplicitPrelude #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | -- | Types and functions for handling JSON strings. 10 | module Waargonaut.Types.JString 11 | ( 12 | -- * Types 13 | JString 14 | , JString' (..) 15 | , AsJString (..) 16 | 17 | , _JStringText 18 | , stringToJString 19 | 20 | -- * Parser 21 | , parseJString 22 | ) where 23 | 24 | import Prelude (Eq, Ord, Show, String, foldr) 25 | 26 | import Control.Applicative (Applicative, (*>), (<*)) 27 | import Control.Category (id, (.)) 28 | import Control.Error.Util (note) 29 | import Control.Lens (Prism', Profunctor, Rewrapped, 30 | Wrapped (..), iso, prism, review) 31 | 32 | import Data.Either (Either (Right)) 33 | import Data.Foldable (Foldable) 34 | import Data.Function (($)) 35 | import Data.Functor (Functor, fmap, (<$>)) 36 | import Data.Text (Text) 37 | import qualified Data.Text as Text 38 | import Data.Traversable (Traversable, traverse) 39 | 40 | import Data.Vector (Vector) 41 | import qualified Data.Vector as V 42 | 43 | import Data.Digit (HeXDigit) 44 | 45 | import Text.Parser.Char (CharParsing, char) 46 | import Text.Parser.Combinators (many) 47 | 48 | import Waargonaut.Types.JChar (JChar, charToJChar, jCharToChar, 49 | parseJChar, utf8CharToJChar) 50 | 51 | -- $setup 52 | -- >>> :set -XOverloadedStrings 53 | -- >>> import Control.Lens ((#)) 54 | -- >>> import Control.Monad (return) 55 | -- >>> import Data.Function (($)) 56 | -- >>> import Data.Either(Either (..), isLeft) 57 | -- >>> import Data.Digit (HeXDigit(..)) 58 | -- >>> import qualified Data.Vector as V 59 | -- >>> import Utils 60 | -- >>> import Waargonaut.Decode.Error (DecodeError) 61 | -- >>> import Waargonaut.Types.Whitespace 62 | -- >>> import Waargonaut.Types.JChar.Unescaped 63 | -- >>> import Waargonaut.Types.JChar.Escaped 64 | -- >>> import Waargonaut.Types.JChar.HexDigit4 65 | -- >>> import Waargonaut.Types.JChar 66 | -- >>> import Data.Text.Lazy.Builder (toLazyText) 67 | ---- 68 | 69 | -- | A JSON string is a list of JSON acceptable characters, we use a newtype to 70 | -- create the 'JString' type from a 'Vector JChar'. This is polymorphic over the 71 | -- acceptable types of character encoding digits. 72 | newtype JString' digit = 73 | JString' (Vector (JChar digit)) 74 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 75 | 76 | -- | As only one subset of digits are currently acceptable, Hexadecimal, we 77 | -- provide this type alias to close that loop. 78 | type JString = JString' HeXDigit 79 | 80 | instance JString' digit ~ t => Rewrapped (JString' digit) t 81 | 82 | instance Wrapped (JString' digit) where 83 | type Unwrapped (JString' digit) = Vector (JChar digit) 84 | _Wrapped' = iso (\ (JString' x) -> x) JString' 85 | 86 | -- | Classy 'Control.Lens.Prism'' for things that may be treated as a 'JString'. 87 | class AsJString a where 88 | _JString :: Prism' a JString 89 | 90 | instance AsJString JString where 91 | _JString = id 92 | 93 | instance AsJString [JChar HeXDigit] where 94 | _JString = prism (\(JString' cs) -> V.toList cs) (Right . JString' . V.fromList) 95 | 96 | instance AsJString String where 97 | _JString = prism 98 | (\(JString' cx) -> V.toList $ jCharToChar <$> cx) 99 | (\x -> JString' . V.fromList <$> traverse (note x . charToJChar) x) 100 | 101 | -- | Conversion between a 'JString' and 'Text'. 102 | -- 103 | -- JSON strings a wider range of encodings than 'Text' and to be consistent with 104 | -- the 'Text' type, these invalid types are replaced with a placeholder value. 105 | -- 106 | _JStringText :: (Profunctor p, Applicative f) => p Text (f Text) -> p JString (f JString) 107 | _JStringText = iso (Text.pack . review _JString) (JString' . V.fromList . fmap utf8CharToJChar . Text.unpack) 108 | 109 | -- | Parse a 'JString', storing escaped characters and any explicitly escaped 110 | -- character encodings '\uXXXX'. 111 | -- 112 | -- >>> testparse parseJString "\"\"" 113 | -- Right (JString' []) 114 | -- 115 | -- >>> testparse parseJString "\"\\\\\"" 116 | -- Right (JString' [EscapedJChar ReverseSolidus]) 117 | -- 118 | -- >>> testparse parseJString "\"abc\"" 119 | -- Right (JString' [UnescapedJChar (Unescaped 'a'),UnescapedJChar (Unescaped 'b'),UnescapedJChar (Unescaped 'c')]) 120 | -- 121 | -- >>> testparse parseJString "\"a\\rbc\"" 122 | -- Right (JString' [UnescapedJChar (Unescaped 'a'),EscapedJChar (WhiteSpace CarriageReturn),UnescapedJChar (Unescaped 'b'),UnescapedJChar (Unescaped 'c')]) 123 | -- 124 | -- >>> testparse parseJString "\"a\\rbc\\uab12\\ndef\\\"\"" :: Either DecodeError JString 125 | -- Right (JString' [UnescapedJChar (Unescaped 'a'),EscapedJChar (WhiteSpace CarriageReturn),UnescapedJChar (Unescaped 'b'),UnescapedJChar (Unescaped 'c'),EscapedJChar (Hex (HexDigit4 HeXDigita HeXDigitb HeXDigit1 HeXDigit2)),EscapedJChar (WhiteSpace NewLine),UnescapedJChar (Unescaped 'd'),UnescapedJChar (Unescaped 'e'),UnescapedJChar (Unescaped 'f'),EscapedJChar QuotationMark]) 126 | -- 127 | -- >>> testparsethennoteof parseJString "\"a\"\\u" 128 | -- Right (JString' [UnescapedJChar (Unescaped 'a')]) 129 | -- 130 | -- >>> testparsethennoteof parseJString "\"a\"\t" 131 | -- Right (JString' [UnescapedJChar (Unescaped 'a')]) 132 | parseJString 133 | :: CharParsing f 134 | => f JString 135 | parseJString = 136 | char '"' *> (JString' . V.fromList <$> many parseJChar) <* char '"' 137 | 138 | -- | Convert a 'String' to a 'JString'. 139 | stringToJString :: String -> JString 140 | stringToJString = JString' . foldr (V.cons . utf8CharToJChar) V.empty 141 | 142 | -------------------------------------------------------------------------------- /src/Waargonaut/Types/Whitespace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | -- | 6 | -- 7 | -- Parsers and builders for whitespace characters in our JSON. 8 | -- 9 | module Waargonaut.Types.Whitespace 10 | ( 11 | Whitespace (..) 12 | , WS (..) 13 | , _WhitespaceChar 14 | 15 | , escapedWhitespaceChar 16 | , unescapedWhitespaceChar 17 | 18 | , oneWhitespace 19 | , parseWhitespace 20 | , parseSomeWhitespace 21 | 22 | ) where 23 | 24 | import Control.Applicative (liftA2) 25 | import Control.Lens (AsEmpty (..), Cons (..), Prism', 26 | Rewrapped, Wrapped (..), iso, 27 | mapped, nearly, over, prism, prism', 28 | to, uncons, (^.), _2, _Wrapped) 29 | import Control.Lens.Extras (is) 30 | 31 | import Data.Vector (Vector) 32 | import qualified Data.Vector as V 33 | 34 | import Data.List.NonEmpty (NonEmpty ((:|))) 35 | 36 | import Data.Foldable (asum) 37 | #if !MIN_VERSION_base(4,11,0) 38 | import Data.Semigroup (Semigroup(..)) 39 | #endif 40 | 41 | import Text.Parser.Char (CharParsing, char, newline, tab) 42 | import Text.Parser.Combinators (many) 43 | 44 | -- $setup 45 | -- >>> :set -XOverloadedStrings 46 | -- >>> import Control.Monad (return) 47 | -- >>> import Data.Either(Either (..), isLeft) 48 | -- >>> import qualified Data.Digit as D 49 | -- >>> import Waargonaut.Decode.Error (DecodeError) 50 | -- >>> import Data.ByteString.Lazy (toStrict) 51 | -- >>> import Data.ByteString.Builder (toLazyByteString) 52 | -- >>> import Utils 53 | ---- 54 | 55 | -- | Represent the different types of whitespace. 56 | data Whitespace 57 | = Space 58 | | HorizontalTab 59 | | LineFeed 60 | | NewLine 61 | | CarriageReturn 62 | deriving (Eq, Ord, Show) 63 | 64 | -- | This is a wrapper for a sequence of consecutive whitespace. 65 | newtype WS = WS (Vector Whitespace) 66 | deriving (Eq, Show) 67 | 68 | instance Cons WS WS Whitespace Whitespace where 69 | _Cons = prism' (\(w,ws) -> over _Wrapped (V.cons w) ws) (\(WS ws) -> over (mapped . _2) WS (uncons ws)) 70 | {-# INLINE _Cons #-} 71 | 72 | instance AsEmpty WS where 73 | _Empty = nearly mempty (^. _Wrapped . to (is _Empty)) 74 | {-# INLINE _Empty #-} 75 | 76 | instance WS ~ t => Rewrapped WS t 77 | instance Wrapped WS where 78 | type Unwrapped WS = Vector Whitespace 79 | _Wrapped' = iso (\(WS x) -> x) WS 80 | {-# INLINE _Wrapped' #-} 81 | 82 | instance Semigroup WS where 83 | (WS a) <> (WS b) = WS (a <> b) 84 | {-# INLINE (<>) #-} 85 | 86 | instance Monoid WS where 87 | mempty = WS V.empty 88 | {-# INLINE mempty #-} 89 | mappend = (<>) 90 | {-# INLINE mappend #-} 91 | 92 | -- | Handy 'Prism'' between a 'Char' its possible 'Whitespace' representation. 93 | _WhitespaceChar :: Prism' Char Whitespace 94 | _WhitespaceChar = prism escapedWhitespaceChar 95 | (\x -> case x of 96 | ' ' -> Right Space 97 | '\t' -> Right HorizontalTab 98 | '\f' -> Right LineFeed 99 | '\r' -> Right CarriageReturn 100 | '\n' -> Right NewLine 101 | _ -> Left x 102 | ) 103 | 104 | -- | Parse a single 'Whitespace' character. 105 | oneWhitespace 106 | :: CharParsing f 107 | => f Whitespace 108 | oneWhitespace = asum 109 | [ Space <$ char ' ' 110 | , HorizontalTab <$ tab 111 | , LineFeed <$ char '\f' 112 | , CarriageReturn <$ char '\r' 113 | , NewLine <$ newline 114 | ] 115 | 116 | -- | 117 | -- 118 | -- >>> testparse parseWhitespace " " 119 | -- Right (WS [Space]) 120 | -- 121 | -- >>> testparse parseWhitespace "\n " 122 | -- Right (WS [NewLine,Space,Space,Space,Space]) 123 | -- 124 | -- >>> testparse parseWhitespace " \t" 125 | -- Right (WS [Space,HorizontalTab]) 126 | -- 127 | -- >>> testparse parseWhitespace "\f\f" 128 | -- Right (WS [LineFeed,LineFeed]) 129 | -- 130 | -- >>> testparse parseWhitespace "\r\r\r" 131 | -- Right (WS [CarriageReturn,CarriageReturn,CarriageReturn]) 132 | -- 133 | -- >>> testparse parseWhitespace "\n\r\r\n" 134 | -- Right (WS [NewLine,CarriageReturn,CarriageReturn,NewLine]) 135 | -- 136 | -- >>> testparse parseWhitespace "" 137 | -- Right (WS []) 138 | -- 139 | -- >>> testparse parseWhitespace "\n ]" 140 | -- Right (WS [NewLine,Space,Space,Space]) 141 | -- 142 | parseWhitespace 143 | :: CharParsing f 144 | => f WS 145 | parseWhitespace = 146 | WS . V.fromList <$> many oneWhitespace 147 | 148 | -- | Parse a 'NonEmpty' sequence of consecutive whitespace. 149 | parseSomeWhitespace 150 | :: CharParsing f 151 | => f (NonEmpty Whitespace) 152 | parseSomeWhitespace = 153 | liftA2 (:|) oneWhitespace (many oneWhitespace) 154 | 155 | -- | Change a 'Whitespace' into a single unescaped 'Char'. Useful if you're 156 | -- already handling escaping with some other mechanism. 157 | unescapedWhitespaceChar :: Whitespace -> Char 158 | unescapedWhitespaceChar Space = ' ' 159 | unescapedWhitespaceChar HorizontalTab = 't' 160 | unescapedWhitespaceChar LineFeed = 'f' 161 | unescapedWhitespaceChar CarriageReturn = 'r' 162 | unescapedWhitespaceChar NewLine = 'n' 163 | {-# INLINE unescapedWhitespaceChar #-} 164 | 165 | -- | Change a 'Whitespace' into its escaped 'Char' form. 166 | escapedWhitespaceChar :: Whitespace -> Char 167 | escapedWhitespaceChar Space = ' ' 168 | escapedWhitespaceChar HorizontalTab = '\t' 169 | escapedWhitespaceChar LineFeed = '\f' 170 | escapedWhitespaceChar CarriageReturn = '\r' 171 | escapedWhitespaceChar NewLine = '\n' 172 | {-# INLINE escapedWhitespaceChar #-} 173 | -------------------------------------------------------------------------------- /test/Bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | module Main where 4 | 5 | import Control.Applicative (liftA2, liftA3) 6 | 7 | import Data.Functor.Identity (Identity) 8 | 9 | import Data.Maybe (isJust) 10 | 11 | import Data.ByteString (ByteString) 12 | import qualified Data.ByteString as BS 13 | 14 | import qualified Gauge as G 15 | 16 | import Control.Lens (isn't, _Left) 17 | import Data.Attoparsec.ByteString (parseOnly) 18 | 19 | import qualified HaskellWorks.Data.Json.Succinct.Cursor.Token as HW 20 | 21 | import qualified Waargonaut as W 22 | 23 | import Types.Common (Image (..), parseBS, imageDecodeManual, imageDecodeGeneric, imageDecodeSuccinct) 24 | import Waargonaut.Decode.Error (DecodeError) 25 | 26 | import Waargonaut.Decode (Decoder) 27 | import qualified Waargonaut.Decode as D 28 | 29 | import qualified Waargonaut.Decode.Succinct as SD 30 | 31 | import qualified Waargonaut.Generic as G 32 | 33 | parseOkay :: ByteString -> Bool 34 | parseOkay = isn't _Left . parseOnly W.parseWaargonaut 35 | 36 | succinctIndexOkay :: ByteString -> Bool 37 | succinctIndexOkay = isJust . HW.jsonTokenAt . SD.unJCurs . SD.mkCursor 38 | 39 | traversalDecode :: Decoder Identity a -> ByteString -> Bool 40 | traversalDecode d = isn't _Left . D.simpleDecode parseBS d 41 | 42 | succinctDecode :: SD.Decoder Identity a -> ByteString -> Bool 43 | succinctDecode d = isn't _Left . SD.runPureDecode d parseBS . SD.mkCursor 44 | 45 | rf :: FilePath -> IO ByteString 46 | rf f = BS.readFile $ "../test/json-data/" <> f 47 | 48 | getParseFiles :: IO (ByteString, ByteString, ByteString) 49 | getParseFiles = liftA3 (,,) 50 | (rf "jp100.json") 51 | (rf "twitter100.json") 52 | (rf "numbers.json") 53 | 54 | getDecodeFiles :: IO (ByteString, ByteString) 55 | getDecodeFiles = liftA2 (,) 56 | (rf "test1.json") 57 | (rf "numbers.json") 58 | 59 | main :: IO () 60 | main = G.defaultMain 61 | [ parse 62 | , parseSuccinct 63 | , decode 64 | ] 65 | 66 | decode :: G.Benchmark 67 | decode = G.env getDecodeFiles $ \ ~(image, numbers) -> G.bgroup "Decode" 68 | [ G.bench "Image Decode (manual - traversal)" $ G.nf (traversalDecode imageDecodeManual) image 69 | , G.bench "Image Decode (generic)" $ G.nf (succinctDecode imageDecodeGeneric) image 70 | , G.bench "[Scientific] (manual - traversal)" $ G.nf (traversalDecode (D.list D.scientific)) numbers 71 | , G.bench "Image Decode (manual - succinct)" $ G.nf (succinctDecode imageDecodeSuccinct) image 72 | ] 73 | 74 | parse :: G.Benchmark 75 | parse = G.env getParseFiles $ \ ~(jp100, twitter100, numbers) -> G.bgroup "Full Parse" 76 | [ G.bench "jp100" $ G.nf parseOkay jp100 77 | , G.bench "twitter100" $ G.nf parseOkay twitter100 78 | , G.bench "numbers" $ G.nf parseOkay numbers 79 | ] 80 | 81 | parseSuccinct :: G.Benchmark 82 | parseSuccinct = G.env getParseFiles $ \ ~(jp100, twitter100, numbers) -> G.bgroup "Succinct Index" 83 | [ G.bench "jp100" $ G.nf succinctIndexOkay jp100 84 | , G.bench "twitter100" $ G.nf succinctIndexOkay twitter100 85 | , G.bench "numbers" $ G.nf succinctIndexOkay numbers 86 | ] 87 | -------------------------------------------------------------------------------- /test/Decoder/Laws.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module Decoder.Laws (decoderLaws) where 6 | 7 | import Control.Applicative (Applicative, pure) 8 | import Control.Monad.Except (throwError) 9 | 10 | import Data.Functor.Alt (Alt (())) 11 | import Data.Functor.Identity (Identity) 12 | 13 | import Test.Tasty (TestTree, testGroup) 14 | import Test.Tasty.Hedgehog (testProperty) 15 | 16 | import Hedgehog 17 | import qualified Hedgehog.Gen as Gen 18 | 19 | import qualified Waargonaut.Attoparsec as WA 20 | import qualified Waargonaut.Decode as D 21 | import Waargonaut.Decode.Error (DecodeError (ConversionFailure)) 22 | import Waargonaut.Decode.Types (Decoder) 23 | 24 | import qualified Laws 25 | 26 | runD :: Decoder Identity a -> Either (DecodeError, D.CursorHistory) a 27 | runD d = WA.pureDecodeAttoparsecText d "true" 28 | 29 | newtype ShowDecoder a = SD (Decoder Identity a) 30 | deriving (Functor, Monad, Applicative) 31 | 32 | instance Alt ShowDecoder where 33 | (SD a) (SD b) = SD (a b) 34 | 35 | instance Eq a => Eq (ShowDecoder a) where 36 | (SD a) == (SD b) = runD a == runD b 37 | 38 | instance Show a => Show (ShowDecoder a) where 39 | show (SD d) = show $ runD d 40 | 41 | genShowDecoder :: Gen a -> Gen (ShowDecoder a) 42 | genShowDecoder genA = Gen.choice 43 | [ SD . pure <$> genA 44 | , SD <$> Gen.constant (throwError $ ConversionFailure "Intentional DecodeError (TEST)") 45 | ] 46 | 47 | decoderLaws :: TestTree 48 | decoderLaws = testGroup "Decoder Laws" 49 | [ testGroup "Applicative" 50 | 51 | [ testProperty "identity" $ Laws.applicative_id genShowDecoder Gen.bool 52 | , testProperty "composition" $ Laws.applicative_composition genShowDecoder Gen.bool Gen.bool Gen.bool 53 | , testProperty "homomorphism" $ Laws.applicative_homomorphism sdPure Gen.bool Gen.bool 54 | , testProperty "interchange" $ Laws.applicative_interchange sdPure Gen.bool Gen.bool 55 | ] 56 | 57 | , testGroup "Alt" 58 | [ testProperty "associativity" $ Laws.alt_associativity genShowDecoder Gen.bool 59 | , testProperty "left distributes" $ Laws.alt_left_distributes genShowDecoder Gen.bool Gen.bool 60 | ] 61 | 62 | , testGroup "Monad" 63 | [ testProperty "return a >>= k = k a" $ Laws.monad_return_bind genShowDecoder Gen.bool Gen.bool 64 | , testProperty "m >>= return = m" $ Laws.monad_bind_return_id genShowDecoder Gen.bool 65 | , testProperty "associativity" $ Laws.monad_associativity genShowDecoder Gen.bool Gen.bool Gen.bool 66 | ] 67 | 68 | , testGroup "Functor" 69 | [ testProperty "'fmap compose'" $ Laws.fmap_compose genShowDecoder Gen.bool Gen.bool Gen.bool 70 | ] 71 | ] 72 | where 73 | sdPure = (pure :: a -> ShowDecoder a) 74 | -------------------------------------------------------------------------------- /test/Decoder/Parsers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Decoder.Parsers where 3 | 4 | import Control.Error.Util (note) 5 | import Control.Lens (preview, _1, _last) 6 | 7 | import Data.Either (Either) 8 | 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString.Char8 as BS8 11 | import Data.Text (Text) 12 | 13 | import Text.ParserCombinators.ReadP (ReadP) 14 | import qualified Text.ParserCombinators.ReadP as RP 15 | 16 | import Waargonaut.Types (JArray, JNumber, JString, Json, 17 | WS) 18 | import qualified Waargonaut.Types as WT 19 | 20 | import Waargonaut.Decode.DecodeResult (DecodeError (..)) 21 | 22 | parsur 23 | :: Show a 24 | => ReadP a 25 | -> Text 26 | -> ByteString 27 | -> Either DecodeError a 28 | parsur p t = note (ParseFailed t) 29 | -- readP will give us EVERYTHING that the parser allows, this is wild. 30 | . preview (_last . _1) 31 | . RP.readP_to_S p 32 | . BS8.unpack 33 | 34 | pJStr 35 | :: ByteString 36 | -> Either DecodeError JString 37 | pJStr = parsur WT.parseJString "JString" 38 | 39 | pint 40 | :: ByteString 41 | -> Either DecodeError JNumber 42 | pint = parsur WT.parseJNumber "JNumber" 43 | 44 | poolean 45 | :: ByteString 46 | -> Either DecodeError Json 47 | poolean = parsur (WT.Json <$> WT.parseJBool WT.parseWhitespace) "JBool" 48 | 49 | parray 50 | :: ByteString 51 | -> Either DecodeError (JArray WS Json) 52 | parray = parsur (WT.parseJArray WT.parseWhitespace WT.parseWaargonaut) "JArray" 53 | 54 | pjnum 55 | :: Json 56 | -> Either DecodeError Int 57 | pjnum = (note (ConversionFailure "Expected JNumber")) . preview (WT._JNum . _1 . WT._JNumberInt) 58 | 59 | pjson 60 | :: ByteString 61 | -> Either DecodeError Json 62 | pjson = 63 | parsur WT.parseWaargonaut "Json" 64 | -------------------------------------------------------------------------------- /test/Doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (flags, pkgs, module_sources) 4 | import Test.DocTest (doctest) 5 | 6 | main :: IO () 7 | main = doctest $ flags ++ pkgs ++ ["test/Types/Common.hs", "test/Utils.hs"] ++ module_sources 8 | -------------------------------------------------------------------------------- /test/Encoder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Encoder 5 | ( encoderTests 6 | , encodeImage 7 | , testImageDataType 8 | ) where 9 | 10 | import Control.Lens ((<&>), (?~)) 11 | 12 | import Test.Tasty (TestName, TestTree, testGroup) 13 | import Test.Tasty.HUnit (Assertion, testCase, (@?=)) 14 | 15 | import Data.Proxy (Proxy (..)) 16 | 17 | import Waargonaut.Encode (Encoder, Encoder') 18 | import qualified Waargonaut.Encode as E 19 | 20 | import Data.Text.Lazy (Text) 21 | 22 | import Types.Common (Image (..), Overlayed (..), testFudge, 23 | testImageDataType) 24 | 25 | import Waargonaut.Generic (GWaarg, mkEncoder, proxy) 26 | import Waargonaut.Types.Json (oat) 27 | 28 | testOptionalKeyValue :: Assertion 29 | testOptionalKeyValue = do 30 | let 31 | encoder = E.mapLikeObj $ \(a,b) -> 32 | E.atKey' "A" E.text a . 33 | E.atOptKey' "B" E.int b 34 | 35 | hasKey = ("bob", Just 33) 36 | withKey = "{\"A\":\"bob\",\"B\":33}" 37 | 38 | noKey = ("bob", Nothing) 39 | withoutKey = "{\"A\":\"bob\"}" 40 | 41 | E.simplePureEncodeTextNoSpaces encoder hasKey @?= withKey 42 | E.simplePureEncodeTextNoSpaces encoder noKey @?= withoutKey 43 | 44 | testImageEncodedNoSpaces :: Text 45 | testImageEncodedNoSpaces = "{\"Width\":800,\"Height\":600,\"Title\":\"View from 15th Floor\",\"Animated\":false,\"IDs\":[116,943,234,38793]}" 46 | 47 | -- | The recommended way of defining an Encoder is to be explicit. 48 | encodeImage :: Applicative f => Encoder f Image 49 | encodeImage = E.mapLikeObj $ \img -> 50 | E.intAt "Width" (_imageWidth img) 51 | . E.intAt "Height" (_imageHeight img) 52 | . E.textAt "Title" (_imageTitle img) 53 | . E.boolAt "Animated" (_imageAnimated img) 54 | . E.listAt E.int "IDs" (_imageIDs img) 55 | 56 | testFudgeEncodedWithConsName :: Text 57 | testFudgeEncodedWithConsName = "{\"fudgey\":\"Chocolate\"}" 58 | 59 | testOverlayed :: Overlayed 60 | testOverlayed = Overlayed "fred" testFudge 61 | 62 | testOverlayedOut :: Text 63 | testOverlayedOut = "{\"id\":\"fred\",\"fudgey\":\"Chocolate\"}" 64 | 65 | encodeOverlay :: Applicative f => Encoder f Overlayed 66 | encodeOverlay = E.encodeA $ \(Overlayed i f) -> E.runEncoder fudgeEnc f 67 | <&> oat "id" ?~ E.runPureEncoder E.text i 68 | where 69 | fudgeEnc = proxy mkEncoder (Proxy :: Proxy GWaarg) 70 | 71 | tCase 72 | :: TestName 73 | -> Encoder' a 74 | -> a 75 | -> Text 76 | -> TestTree 77 | tCase nm enc a expected = testCase nm $ 78 | E.simplePureEncodeTextNoSpaces enc a @?= expected 79 | 80 | encoderTests :: TestTree 81 | encoderTests = testGroup "Encoder" 82 | [ tCase "Image" encodeImage testImageDataType testImageEncodedNoSpaces 83 | , tCase "Image (Generic)" enc testImageDataType testImageEncodedNoSpaces 84 | , tCase "newtype - with constructor name" enc testFudge testFudgeEncodedWithConsName 85 | , tCase "Overlayed" encodeOverlay testOverlayed testOverlayedOut 86 | , testCase "Optional Key:Value" testOptionalKeyValue 87 | ] 88 | where 89 | enc = proxy mkEncoder (Proxy :: Proxy GWaarg) 90 | -------------------------------------------------------------------------------- /test/Encoder/Laws.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | module Encoder.Laws (encoderLaws) where 4 | 5 | import Test.Tasty (TestTree, testGroup) 6 | import Test.Tasty.Hedgehog (testProperty) 7 | 8 | import Data.Functor.Contravariant (contramap) 9 | import Data.Functor.Identity (Identity) 10 | import Data.Text.Lazy (Text) 11 | 12 | import Hedgehog 13 | import qualified Hedgehog.Function as Fn 14 | import qualified Hedgehog.Gen as Gen 15 | 16 | import Waargonaut.Encode (Encoder) 17 | import qualified Waargonaut.Encode as E 18 | 19 | import qualified Laws 20 | 21 | runSE :: ShowEncoder a -> a -> Text 22 | runSE (SE e) = E.simplePureEncodeTextNoSpaces e 23 | 24 | newtype ShowEncoder a = SE (Encoder Identity a) 25 | 26 | instance Show a => Show (ShowEncoder a) where 27 | show (SE _) = "an encoder of type a" 28 | 29 | instance Fn.Contravariant ShowEncoder where 30 | contramap f (SE a) = SE (Fn.contramap f a) 31 | 32 | genShowEncoder :: Encoder Identity a -> Gen a -> Gen (ShowEncoder a) 33 | genShowEncoder enc _ = Gen.constant (SE enc) 34 | 35 | encoderLaws :: TestTree 36 | encoderLaws = testGroup "Encoder Laws" 37 | [ testGroup "Contravariant" 38 | [ testProperty "composition" 39 | $ Laws.contravariant_composition_with_run (genShowEncoder E.bool) runSE Gen.bool (Gen.maybe Gen.bool) Gen.bool 40 | , testProperty "identity" 41 | $ Laws.contravariant_identity_with_run (genShowEncoder E.bool) runSE Gen.bool 42 | ] 43 | ] 44 | -------------------------------------------------------------------------------- /test/Generics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Generics 3 | ( genericsTests 4 | ) where 5 | 6 | import Test.Tasty (TestTree, testGroup) 7 | import Test.Tasty.HUnit (Assertion, testCase, (@?=)) 8 | 9 | import Waargonaut.Encode (Encoder) 10 | import qualified Waargonaut.Encode as E 11 | 12 | import qualified Types.Common as C 13 | 14 | import qualified Waargonaut.Generic as G 15 | 16 | testGenericFieldNameFunctionUsedOnce :: Assertion 17 | testGenericFieldNameFunctionUsedOnce = do 18 | let 19 | encFudge :: Applicative f => Encoder f C.Fudge 20 | encFudge = G.untag . G.gEncoder $ C.fudgeJsonOpts 21 | { G._optionsFieldName = tail 22 | } 23 | 24 | expected = "{\"udge\":\"Chocolate\"}" 25 | 26 | E.simplePureEncodeTextNoSpaces encFudge C.testFudge @?= expected 27 | 28 | genericsTests :: TestTree 29 | genericsTests = testGroup "Generics" 30 | [ testCase "Options fieldName function is used only once" testGenericFieldNameFunctionUsedOnce 31 | ] 32 | -------------------------------------------------------------------------------- /test/Golden.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Golden (goldenTests) where 3 | 4 | import Control.Applicative (pure, (*>)) 5 | import Control.Category ((.)) 6 | import Control.Monad ((>=>)) 7 | 8 | import System.Exit (exitFailure) 9 | import System.FilePath (FilePath, takeBaseName) 10 | import System.IO (IO, print) 11 | 12 | import Data.Semigroup ((<>)) 13 | import Data.Either (either) 14 | import Data.Function (($)) 15 | 16 | import Data.ByteString.Lazy (ByteString, readFile, toStrict) 17 | 18 | import Data.Attoparsec.ByteString (parseOnly) 19 | 20 | import Test.Tasty (TestTree, testGroup) 21 | import Test.Tasty.Golden (findByExtension, goldenVsString) 22 | 23 | import qualified Waargonaut.Decode as D 24 | import qualified Waargonaut.Encode as E 25 | 26 | import qualified Prettier.NestedObjs as WaargP 27 | 28 | readAndEncodeFile :: FilePath -> IO ByteString 29 | readAndEncodeFile = readFile 30 | >=> D.decodeFromByteString parseOnly D.json . toStrict 31 | >=> either (\err -> print err *> exitFailure) pure 32 | >=> E.simpleEncodeByteString E.json 33 | 34 | goldenTests :: IO TestTree 35 | goldenTests = do 36 | fs <- findByExtension [".golden"] "test/json-data/goldens" 37 | pure . testGroup "Golden Tests" $ 38 | [ goldenVsString (takeBaseName input) input (readAndEncodeFile input) 39 | | input <- fs 40 | ] <> 41 | [ WaargP.testGoldenPrettyNested 42 | ] 43 | -------------------------------------------------------------------------------- /test/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Json 3 | ( jsonPrisms 4 | ) where 5 | 6 | import Control.Applicative (liftA2) 7 | import Control.Lens (Prism', preview, review, _Empty) 8 | 9 | import Test.Tasty 10 | import Test.Tasty.Hedgehog (testProperty) 11 | import Test.Tasty.HUnit (testCase, (@?=)) 12 | 13 | import Hedgehog (Gen, Property, forAll, property, (===)) 14 | import qualified Hedgehog.Gen as Gen 15 | import qualified Hedgehog.Range as Range 16 | 17 | import Data.Vector (Vector) 18 | import qualified Data.Vector as V 19 | 20 | import Data.HashMap.Strict (HashMap) 21 | import qualified Data.HashMap.Strict as HM 22 | 23 | import Data.Text (Text) 24 | 25 | import qualified Data.Attoparsec.Text as AT 26 | 27 | import Waargonaut.Types 28 | 29 | import Waargonaut.Lens (_ArrayOf, _Bool, _Number, _ObjHashMapOf, 30 | _String, _TextJson) 31 | 32 | import Types.Common (genScientific, genText) 33 | import Types.Json (genJson) 34 | 35 | prismLaw :: (Eq a, Show a) => Gen a -> Prism' b a -> Property 36 | prismLaw genA prismA = property $ forAll genA >>= \a -> 37 | preview prismA (review prismA a) === Just a 38 | 39 | emptyPrismLaw :: TestTree 40 | emptyPrismLaw = 41 | testGroup "_Empty" 42 | [ testCase "CommaSeparated" 43 | $ preview _Empty (review _Empty () :: CommaSeparated WS (JAssoc WS Json)) @?= Just () 44 | , testCase "JObject" 45 | $ preview _Empty (review _Empty () :: JObject WS Json) @?= Just () 46 | , testCase "JArray" 47 | $ preview _Empty (review _Empty () :: JArray WS Json) @?= Just () 48 | , testCase "MapLikeObj" 49 | $ preview _Empty (review _Empty () :: MapLikeObj WS Json) @?= Just () 50 | , testCase "WS" 51 | $ preview _Empty (review _Empty () :: WS) @?= Just () 52 | ] 53 | 54 | objHashMapPrismLaws :: TestTree 55 | objHashMapPrismLaws = testGroup "Json hashmap prism" 56 | [ testProperty "_ObjHashMapOf Scientific" 57 | $ prismLaw (genHashMapOf $ genScientific (Just 10)) (_ObjHashMapOf _Number) 58 | 59 | , testProperty "_ObjHashMapOf Text" 60 | $ prismLaw (genHashMapOf genText) (_ObjHashMapOf _String) 61 | 62 | , testProperty "_ObjHashMapOf Bool" 63 | $ prismLaw (genHashMapOf Gen.bool) (_ObjHashMapOf _Bool) 64 | 65 | , testProperty "_ObjHashMapOf Json" 66 | $ prismLaw (genHashMapOf genJson) (_ObjHashMapOf (_String . _TextJson AT.parseOnly)) 67 | ] 68 | 69 | arrayOfPrismLaws :: TestTree 70 | arrayOfPrismLaws = testGroup "Json array prism" 71 | [ testProperty "_ArrayOf Scientific" 72 | $ prismLaw (genListOf $ genScientific (Just 10)) (_ArrayOf _Number) 73 | 74 | , testProperty "_ArrayOf Text" 75 | $ prismLaw (genListOf genText) (_ArrayOf _String) 76 | 77 | , testProperty "_ArrayOf Bool" 78 | $ prismLaw (genListOf Gen.bool) (_ArrayOf _Bool) 79 | 80 | , testProperty "_ArrayOf Json" 81 | $ prismLaw (genListOf genJson) (_ArrayOf (_String . _TextJson AT.parseOnly)) 82 | ] 83 | 84 | jsonPrisms :: TestTree 85 | jsonPrisms = 86 | testGroup "Json 'Prisms'' must OBEY THE LAW: (preview p (review p x) == Just x)" 87 | [ testProperty "_Bool" $ prismLaw Gen.bool _Bool 88 | , testProperty "_Number" $ prismLaw (genScientific (Just 10)) _Number 89 | , testProperty "_TextJson" $ prismLaw genJson (_TextJson AT.parseOnly) 90 | , testProperty "_String" $ prismLaw genText _String 91 | 92 | , arrayOfPrismLaws 93 | , objHashMapPrismLaws 94 | , emptyPrismLaw 95 | ] 96 | 97 | genHashMapOf :: Gen a -> Gen (HashMap Text a) 98 | genHashMapOf genElem = HM.fromList <$> Gen.list (Range.linear 0 100) tup 99 | where tup = liftA2 (,) genText genElem 100 | 101 | genListOf :: Gen a -> Gen (Vector a) 102 | genListOf genElem = V.fromList <$> Gen.list (Range.linear 0 100) genElem 103 | -------------------------------------------------------------------------------- /test/Laws.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Laws 4 | ( fmap_compose 5 | 6 | , alt_left_distributes 7 | , alt_associativity 8 | 9 | , applicative_id 10 | , applicative_composition 11 | , applicative_homomorphism 12 | , applicative_interchange 13 | 14 | , monad_return_bind 15 | , monad_bind_return_id 16 | , monad_associativity 17 | 18 | , contravariant_identity 19 | , contravariant_composition 20 | , contravariant_identity_with_run 21 | , contravariant_composition_with_run 22 | ) where 23 | 24 | import Control.Applicative (liftA3) 25 | 26 | import Data.Functor.Alt (Alt (..)) 27 | import Data.Functor.Contravariant (Contravariant, contramap) 28 | 29 | import Hedgehog 30 | import Hedgehog.Function (Arg, Vary) 31 | import qualified Hedgehog.Function as Fn 32 | 33 | fmap_compose 34 | :: forall f a b c 35 | . ( Functor f 36 | , Show (f a) 37 | , Show a, Arg a, Vary a 38 | , Show b, Arg b, Vary b 39 | , Show c 40 | , Eq (f c) 41 | , Show (f c) 42 | ) 43 | => (forall x. Gen x -> Gen (f x)) 44 | -> Gen a 45 | -> Gen b 46 | -> Gen c 47 | -> Property 48 | fmap_compose genF genA genB genC = property $ do 49 | g <- Fn.forAllFn $ Fn.fn genB 50 | f <- Fn.forAllFn $ Fn.fn genC 51 | xs <- forAll $ genF genA 52 | fmap (f . g) xs === fmap f (fmap g xs) 53 | 54 | -- | 55 | -- Alt left distributes 56 | -- <$> left-distributes over : f <$> (a b) = (f <$> a) (f <$> b) 57 | alt_left_distributes 58 | :: forall a b f. 59 | ( Alt f 60 | , Show a, Arg a, Vary a, Eq a 61 | , Show b, Arg b, Vary b, Eq b 62 | , Show (f a), Eq (f a) 63 | , Show (f b) 64 | ) 65 | => (forall x. Gen x -> Gen (f x)) 66 | -> Gen a 67 | -> Gen b 68 | -> Property 69 | alt_left_distributes genF genA genB = property $ do 70 | f <- Fn.forAllFn $ Fn.fn genA 71 | 72 | a <- forAll (genF genB) 73 | b <- forAll (genF genB) 74 | 75 | (f <$> (a b)) === ((f <$> a) (f <$> b)) 76 | 77 | -- | 78 | -- Alt Associative 79 | -- is associative: (a b) c = a (b c) 80 | -- 81 | alt_associativity 82 | :: forall f a. 83 | ( Alt f 84 | , Show (f a), Eq (f a) 85 | ) 86 | => (forall x. Gen x -> Gen (f x)) 87 | -> Gen a 88 | -> Property 89 | alt_associativity genF genA = property $ do 90 | (a,b,c) <- forAll $ liftA3 (,,) 91 | (genF genA) 92 | (genF genA) 93 | (genF genA) 94 | 95 | ((a b) c) === (a (b c)) 96 | 97 | -- | 98 | -- identity 99 | -- 100 | -- pure id <*> v = v 101 | applicative_id 102 | :: forall f a. 103 | ( Applicative f 104 | , Show (f a) 105 | , Eq (f a) 106 | ) 107 | => (forall x. Gen x -> Gen (f x)) 108 | -> Gen a 109 | -> Property 110 | applicative_id genF genA = property $ do 111 | a <- forAll (genF genA) 112 | (pure id <*> a) === a 113 | 114 | -- | 115 | -- composition 116 | -- 117 | -- pure (.) <*> u <*> v <*> w = u <*> (v <*> w) 118 | applicative_composition 119 | :: forall f a b c. 120 | ( Show a, Arg a, Vary a, Eq a 121 | , Show b, Arg b, Vary b, Eq b 122 | , Show c, Arg c, Vary c 123 | , Show (f a) 124 | , Show (f b) 125 | , Show (f c) 126 | , Eq (f a) 127 | , Eq (f b) 128 | , Eq (f c) 129 | , Applicative f 130 | ) 131 | => (forall x. Gen x -> Gen (f x)) 132 | -> Gen a 133 | -> Gen b 134 | -> Gen c 135 | -> Property 136 | applicative_composition genF genA genB genC = property $ do 137 | u <- Fn.forAllFn $ Fn.fn genB 138 | v <- Fn.forAllFn $ Fn.fn genC 139 | 140 | w <- forAll (genF genA) 141 | 142 | let 143 | dU = pure u 144 | dV = pure v 145 | 146 | ( pure (.) <*> dU <*> dV <*> w ) === ( dU <*> ( dV <*> w ) ) 147 | 148 | -- | 149 | -- homomorphism 150 | -- 151 | -- pure f <*> pure x = pure (f x) 152 | applicative_homomorphism 153 | :: forall f a b. 154 | ( Show a, Arg a, Vary a, Eq a 155 | , Show b, Arg b, Vary b 156 | , Show (f a), Eq (f a) 157 | , Eq (f b) 158 | , Applicative f 159 | ) 160 | => (forall x. x -> f x) 161 | -> Gen a 162 | -> Gen b 163 | -> Property 164 | applicative_homomorphism pureF genA genB = property $ do 165 | f <- Fn.forAllFn $ Fn.fn genA 166 | x <- forAll genB 167 | 168 | (pureF f <*> pureF x) === (pureF (f x)) 169 | 170 | -- | 171 | -- interchange 172 | -- 173 | -- u <*> pure y = pure ($ y) <*> u 174 | applicative_interchange 175 | :: forall f u y. 176 | ( Applicative f 177 | , Show u, Arg u, Vary u, Eq u 178 | , Show y, Arg y, Vary y 179 | , Show (f u), Eq (f u) 180 | , Show (f y), Eq (f y) 181 | ) 182 | => (forall x. x -> f x) 183 | -> Gen u 184 | -> Gen y 185 | -> Property 186 | applicative_interchange pureF genU genY = property $ do 187 | u <- Fn.forAllFn $ Fn.fn genU 188 | y <- forAll genY 189 | 190 | let 191 | dU = pureF u 192 | 193 | (dU <*> pure y) === (pure ($ y) <*> dU) 194 | 195 | -- | 196 | -- monad 197 | -- 198 | -- return a >>= k = k a 199 | monad_return_bind 200 | :: forall f a k. 201 | ( Monad f 202 | , Show a, Arg a, Vary a, Eq a 203 | , Show k, Arg k, Vary k, Eq k 204 | , Show (f a), Eq (f a) 205 | , Show (f k), Eq (f k) 206 | ) 207 | => (forall x. Gen x -> Gen (f x)) 208 | -> Gen a 209 | -> Gen k 210 | -> Property 211 | monad_return_bind genF genA genK = property $ do 212 | k <- Fn.forAllFn $ Fn.fn (genF genK) 213 | a <- forAll genA 214 | 215 | (return a >>= k) === (k a) 216 | 217 | -- | 218 | -- monad 219 | -- 220 | -- m >>= return = m 221 | monad_bind_return_id 222 | :: forall f a. 223 | ( Monad f 224 | , Show a, Eq a 225 | , Show (f a), Eq (f a) 226 | ) 227 | => (forall x. Gen x -> Gen (f x)) 228 | -> Gen a 229 | -> Property 230 | monad_bind_return_id genF genA = property $ do 231 | m <- forAll (genF genA) 232 | 233 | (m >>= return) === m 234 | 235 | -- | 236 | -- monad 237 | -- 238 | -- m >>= (\x -> k x >>= h) = (m >>= k) >>= h 239 | monad_associativity 240 | :: forall f m k h. 241 | ( Monad f 242 | , Show m, Arg m, Vary m, Eq m 243 | , Show k, Arg k, Vary k, Eq k 244 | , Show h, Arg h, Vary h, Eq h 245 | , Show (f m), Eq (f m) 246 | , Show (f k), Eq (f k) 247 | , Show (f h), Eq (f h) 248 | ) 249 | => (forall x. Gen x -> Gen (f x)) 250 | -> Gen m 251 | -> Gen k 252 | -> Gen h 253 | -> Property 254 | monad_associativity genF genM genK genH = property $ do 255 | m <- forAll (genF genM) 256 | 257 | k <- Fn.forAllFn $ Fn.fn (genF genK) 258 | h <- Fn.forAllFn $ Fn.fn (genF genH) 259 | 260 | (m >>= (\x -> k x >>= h)) === ( (m >>= k) >>= h ) 261 | 262 | -- | 263 | -- contravariant 264 | -- 265 | -- contramap f . contramap g = contramap (g . f) 266 | contravariant_composition 267 | :: forall f a b c. 268 | ( Contravariant f 269 | , Show a, Arg a, Vary a, Eq (f a), Show (f a) 270 | , Show b, Arg b, Vary b, Eq b 271 | , Show c, Show (f c) 272 | ) 273 | => (forall x. Gen x -> Gen (f x)) 274 | -> Gen a 275 | -> Gen b 276 | -> Gen c 277 | -> Property 278 | contravariant_composition genF _genA genB genC = property $ do 279 | f <- Fn.forAllFn $ (Fn.fn genB :: Gen (Fn.Fn a b)) 280 | g <- Fn.forAllFn $ (Fn.fn genC :: Gen (Fn.Fn b c)) 281 | 282 | fc <- forAll (genF genC) 283 | 284 | (contramap f . contramap g) fc === contramap (g . f) fc 285 | 286 | -- | 287 | -- contravariant 288 | -- 289 | -- contramap id a = a 290 | contravariant_identity 291 | :: forall f a. 292 | ( Contravariant f 293 | , Show a, Arg a, Vary a 294 | , Show (f a) 295 | , Eq (f a) 296 | ) 297 | => (forall x. Gen x -> Gen (f x)) 298 | -> Gen a 299 | -> Property 300 | contravariant_identity genF genA = property $ do 301 | a <- forAll (genF genA) 302 | 303 | contramap id a === a 304 | 305 | -- | 306 | -- contravariant 307 | -- 308 | -- contramap f . contramap g = contramap (g . f) 309 | contravariant_composition_with_run 310 | :: forall f a b c x. 311 | ( Contravariant f 312 | , Show a, Arg a, Vary a 313 | , Show b, Arg b, Vary b, Eq b 314 | , Show c, Show (f c) 315 | , Eq x, Show x 316 | ) 317 | => (Gen c -> Gen (f c)) 318 | -> (f a -> a -> x) 319 | -> Gen a 320 | -> Gen b 321 | -> Gen c 322 | -> Property 323 | contravariant_composition_with_run genF runF genA genB genC = property $ do 324 | f <- Fn.forAllFn $ (Fn.fn genB :: Gen (Fn.Fn a b)) 325 | g <- Fn.forAllFn $ (Fn.fn genC :: Gen (Fn.Fn b c)) 326 | 327 | a <- forAll genA 328 | fc <- forAll (genF genC) 329 | 330 | runF ((contramap f . contramap g) fc) a === runF (contramap (g . f) fc) a 331 | 332 | -- | 333 | -- contravariant 334 | -- 335 | -- contramap id a = a 336 | contravariant_identity_with_run 337 | :: forall f a b. 338 | ( Contravariant f 339 | , Show a, Arg a, Vary a, Eq a 340 | , Show b, Eq b 341 | , Show (f a) 342 | ) 343 | => (Gen a -> Gen (f a)) 344 | -> (f a -> a -> b) 345 | -> Gen a 346 | -> Property 347 | contravariant_identity_with_run genF runF genA = property $ do 348 | fa <- forAll (genF genA) 349 | a <- forAll genA 350 | 351 | runF (contramap id fa) a === runF fa a 352 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TupleSections #-} 3 | module Main (main) where 4 | 5 | import GHC.Word (Word8) 6 | 7 | import Data.Either (isLeft) 8 | 9 | import Data.Semigroup ((<>)) 10 | 11 | import Data.Text (Text) 12 | import qualified Data.Text as Text 13 | import qualified Data.Text.Encoding as Text 14 | import qualified Data.Text.IO as Text 15 | 16 | import qualified Data.Text.Lazy as TextL 17 | 18 | import qualified Data.ByteString as BS 19 | 20 | import Test.Tasty 21 | import Test.Tasty.HUnit 22 | 23 | import qualified Waargonaut.Attoparsec as WA 24 | import qualified Waargonaut.Decode as D 25 | import qualified Waargonaut.Encode as E 26 | 27 | import qualified Types.Common as Common 28 | 29 | import qualified Decoder 30 | import qualified Decoder.Laws 31 | import qualified Encoder 32 | import qualified Encoder.Laws 33 | import qualified Golden 34 | import qualified Generics 35 | import qualified Json 36 | import qualified Properties 37 | 38 | mishandlingOfCharVsUtf8Bytes :: TestTree 39 | mishandlingOfCharVsUtf8Bytes = testCaseSteps "Mishandling of UTF-8 Bytes vs Haskell Char" $ \step -> do 40 | let 41 | valChar = '\128' :: Char 42 | valText = "\128" :: Text 43 | valStr = [valChar] :: String 44 | encVal = "\"\128\"" :: Text 45 | valBytes = [34,194,128,34] :: [Word8] 46 | 47 | testFilePath = "test/json-data/mishandling.json" 48 | 49 | step "Pack String to Text" 50 | Text.pack valStr @?= valText 51 | 52 | step "Encoder via Text" 53 | let x = TextL.toStrict $ Common.encodeText E.text valText 54 | x @?= encVal 55 | 56 | step "Create JSON file" 57 | Text.writeFile testFilePath x 58 | 59 | step "encoder output ~ packed bytes" 60 | Text.encodeUtf8 x @?= BS.pack valBytes 61 | 62 | step "Decode file input" 63 | decodedFile <- WA.decodeAttoparsecText D.text =<< Text.readFile testFilePath 64 | decodedFile @?= Right valText 65 | 66 | regressionTests :: TestTree 67 | regressionTests = testGroup "Expected Failure" $ 68 | toTestFail <$> fs 69 | where 70 | toTestFail (dsc, f) = testCase dsc $ do 71 | r <- WA.decodeAttoparsecText D.json =<< Text.readFile ("test/json-data/bad-json/" <> f) 72 | assertBool (f <> " should fail to parse!") (isLeft r) 73 | 74 | fs = 75 | [ ("[11 12 13] (test4.json)","no_comma_arr.json") 76 | , ("{\"foo\":3\"bar\":4} (test6.json)", "no_comma_obj.json") 77 | ] 78 | 79 | main :: IO () 80 | main = do 81 | goldens <- Golden.goldenTests 82 | defaultMain $ testGroup "Waargonaut All Tests" 83 | [ regressionTests 84 | , mishandlingOfCharVsUtf8Bytes 85 | 86 | , Properties.propertyTests 87 | , Json.jsonPrisms 88 | , Decoder.Laws.decoderLaws 89 | , Encoder.Laws.encoderLaws 90 | 91 | , Decoder.decoderTests 92 | , Encoder.encoderTests 93 | 94 | , Generics.genericsTests 95 | 96 | , goldens 97 | ] 98 | -------------------------------------------------------------------------------- /test/Prettier/NestedObjs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Test case from 5 | -- 6 | -- https://gist.github.com/tonymorris/420fff469463037f5ed3f76339cb51e2 7 | -- 8 | module Prettier.NestedObjs where 9 | 10 | import Data.Functor.Identity 11 | import Prelude 12 | 13 | import qualified Data.Text.Lazy.Encoding as TLE 14 | 15 | import Data.Text.Lazy 16 | import Natural 17 | 18 | import Waargonaut.Encode 19 | import Waargonaut.Prettier 20 | 21 | import Test.Tasty (TestTree) 22 | import Test.Tasty.Golden (goldenVsString) 23 | 24 | data Wibble = 25 | Wibble { 26 | _a1 :: String 27 | , _a2 :: String 28 | , _a3 :: String 29 | , _a4 :: String 30 | } deriving (Eq, Ord, Show) 31 | 32 | data Wobble = 33 | Wobble { 34 | _b1 :: Wibble 35 | , _b2 :: Wibble 36 | } deriving (Eq, Ord, Show) 37 | 38 | testWibble1 :: 39 | Wibble 40 | testWibble1 = 41 | Wibble 42 | "hi1" 43 | "bye1" 44 | "hello1" 45 | "goodbye1" 46 | 47 | testWibble2 :: 48 | Wibble 49 | testWibble2 = 50 | Wibble 51 | "hi2" 52 | "bye2" 53 | "hello2" 54 | "goodbye2" 55 | 56 | testWobble :: 57 | Wobble 58 | testWobble = 59 | Wobble 60 | testWibble1 61 | testWibble2 62 | 63 | wibbleEncoder :: 64 | Applicative f => 65 | Encoder f Wibble 66 | wibbleEncoder = 67 | mapLikeObj $ \w -> 68 | atKey' "a1" string (_a1 w) . 69 | atKey' "a2" string (_a2 w) . 70 | atKey' "a3" string (_a3 w) . 71 | atKey' "a4" string (_a4 w) 72 | 73 | wobbleEncoder :: 74 | Applicative f => 75 | Encoder f Wobble 76 | wobbleEncoder = 77 | mapLikeObj $ \w -> 78 | atKey' "b1" wibbleEncoder (_b1 w) . 79 | atKey' "b2" wibbleEncoder (_b2 w) 80 | 81 | prettyied :: Text 82 | prettyied = 83 | let two = successor' (successor' zero') 84 | in runIdentity (simpleEncodePretty ArrayOnly (IndentStep two) (NumSpaces two) wobbleEncoder testWobble) 85 | 86 | -- Expected this 87 | {- 88 | { 89 | "b1": { 90 | "a1": "hi1", 91 | "a2": "bye1", 92 | "a3": "hello1", 93 | "a4": "goodbye1" 94 | }, 95 | "b2": { 96 | "a1": "hi2", 97 | "a2": "bye2", 98 | "a3": "hello2", 99 | "a4": "goodbye2" 100 | } 101 | } 102 | -} 103 | -- 104 | -- Got this 105 | {- 106 | { 107 | "b1": { 108 | "a1": "hi1", 109 | "a2": "bye1", 110 | "a3": "hello1", 111 | "a4": "goodbye1" 112 | }, 113 | "b2": { 114 | "a1": "hi2", 115 | "a2": "bye2", 116 | "a3": "hello2", 117 | "a4": "goodbye2" 118 | } 119 | } 120 | -} 121 | testGoldenPrettyNested :: TestTree 122 | testGoldenPrettyNested = goldenVsString "'encodePretty' simple nested objects" 123 | "test/Prettier/pretty_nested_objs.json" 124 | (pure $ TLE.encodeUtf8 prettyied) 125 | -------------------------------------------------------------------------------- /test/Prettier/pretty_nested_objs.json: -------------------------------------------------------------------------------- 1 | { 2 | "b1": { 3 | "a1": "hi1", 4 | "a2": "bye1", 5 | "a3": "hello1", 6 | "a4": "goodbye1" 7 | }, 8 | "b2": { 9 | "a1": "hi2", 10 | "a2": "bye2", 11 | "a3": "hello2", 12 | "a4": "goodbye2" 13 | } 14 | } -------------------------------------------------------------------------------- /test/Types/CommaSep.hs: -------------------------------------------------------------------------------- 1 | module Types.CommaSep where 2 | 3 | import Control.Applicative (liftA2) 4 | 5 | import Hedgehog 6 | import qualified Hedgehog.Gen as Gen 7 | import qualified Hedgehog.Range as Range 8 | 9 | import Data.Functor.Identity (Identity (..)) 10 | 11 | import qualified Data.Vector as V 12 | 13 | import Waargonaut.Types.CommaSep (Comma (..), CommaSeparated (..), 14 | Elem (..), Elems (..)) 15 | 16 | genCommaWSPair 17 | :: Gen ws 18 | -> Gen (Comma,ws) 19 | genCommaWSPair = 20 | liftA2 (,) (Gen.constant Comma) 21 | 22 | genCommaIdentity 23 | :: Gen ws 24 | -> Gen (Identity (Comma,ws)) 25 | genCommaIdentity = 26 | fmap Identity . genCommaWSPair 27 | 28 | genCommaOp 29 | :: Gen ws 30 | -> Gen (Maybe (Comma,ws)) 31 | genCommaOp = 32 | Gen.maybe . genCommaWSPair 33 | 34 | genEmptyCommaSeparated 35 | :: Gen ws 36 | -> Gen (CommaSeparated ws a) 37 | genEmptyCommaSeparated gWS = 38 | CommaSeparated <$> gWS <*> Gen.constant Nothing 39 | 40 | genCommaSeparated 41 | :: Gen ws 42 | -> Gen a 43 | -> Gen (CommaSeparated ws a) 44 | genCommaSeparated gWS gA = Gen.recursive Gen.choice 45 | [ genEmptyCommaSeparated gWS 46 | ] 47 | [ CommaSeparated <$> gWS <*> Gen.maybe genCommaElems 48 | ] 49 | where 50 | genCommaElems = Elems 51 | <$> (V.fromList <$> Gen.list (Range.linear 1 100) genCommaIdElem) 52 | <*> genCommaLastElem 53 | 54 | genCommaIdElem = Elem <$> gA <*> genCommaIdentity gWS 55 | genCommaLastElem = Elem <$> gA <*> genCommaOp gWS 56 | -------------------------------------------------------------------------------- /test/Types/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | module Types.Common 9 | ( genDecimalDigit 10 | , genDecimalDigits 11 | , genDecimalDigitNoZero 12 | , genHeXaDeCiMaLDigit 13 | , genHeXaDeCiMaLDigitNoZero 14 | , genNonEmptyDecimalDigit 15 | , genText 16 | , genScientific 17 | , genWhitespace 18 | 19 | , prop_generic_tripping 20 | , encodeJsonText 21 | , encodeText 22 | , encodeBS 23 | 24 | , testImageDataType 25 | , testFudge 26 | , fudgeJsonOpts 27 | , imageDecodeGeneric 28 | , imageDecodeSuccinct 29 | 30 | -- * Some test types to be messed with 31 | , Image (..) 32 | , Fudge (..) 33 | , HasImage (..) 34 | , Overlayed (..) 35 | ) where 36 | 37 | import Generics.SOP (Generic, HasDatatypeInfo) 38 | import qualified GHC.Generics as GHC 39 | 40 | import Control.Lens (makeClassy) 41 | import Control.Monad ((>=>)) 42 | 43 | import Data.Functor.Identity (Identity) 44 | import qualified Data.List as List 45 | import Data.List.NonEmpty (NonEmpty) 46 | import Data.Maybe (fromMaybe) 47 | 48 | import Data.Text (Text) 49 | import qualified Data.Text.Lazy as TextL 50 | 51 | import Hedgehog 52 | import qualified Hedgehog.Gen as Gen 53 | import qualified Hedgehog.Range as Range 54 | 55 | import Data.Scientific (Scientific) 56 | import qualified Data.Scientific as Sci 57 | 58 | import Data.ByteString (ByteString) 59 | 60 | import qualified Data.ByteString.Lazy as BL 61 | 62 | import Data.Tagged (Tagged) 63 | import qualified Data.Tagged as T 64 | 65 | import Data.Digit (DecDigit, HeXDigit) 66 | import qualified Data.Digit as D 67 | 68 | import qualified Waargonaut.Decode as SD 69 | 70 | import qualified Waargonaut.Encode as E 71 | import Waargonaut.Types (Json) 72 | import Waargonaut.Types.Whitespace (Whitespace (..)) 73 | 74 | import qualified Waargonaut.Attoparsec as WA 75 | 76 | import Waargonaut.Generic (GWaarg, JsonDecode (..), 77 | JsonEncode (..), NewtypeName (..), 78 | Options (..), defaultOpts, 79 | gDecoder, gEncoder) 80 | 81 | data Image = Image 82 | { _imageWidth :: Int 83 | , _imageHeight :: Int 84 | , _imageTitle :: Text 85 | , _imageAnimated :: Bool 86 | , _imageIDs :: [Int] 87 | } 88 | deriving (Show, Eq, GHC.Generic) 89 | makeClassy ''Image 90 | 91 | testImageDataType :: Image 92 | testImageDataType = Image 800 600 "View from 15th Floor" False [116, 943, 234, 38793] 93 | 94 | imageDecodeSuccinct :: Monad f => SD.Decoder f Image 95 | imageDecodeSuccinct = SD.withCursor $ SD.down >=> \curs -> do 96 | -- Move to the value at the "Image" key 97 | io <- SD.moveToKey "Image" curs >>= SD.down 98 | -- We need individual values off of our object, 99 | Image 100 | <$> SD.fromKey "Width" SD.int io 101 | <*> SD.fromKey "Height" SD.int io 102 | <*> SD.fromKey "Title" SD.text io 103 | <*> SD.fromKey "Animated" SD.bool io 104 | <*> SD.fromKey "IDs" (SD.list SD.int) io 105 | 106 | imageDecodeGeneric :: Monad f => SD.Decoder f Image 107 | imageDecodeGeneric = SD.withCursor $ SD.fromKey "Image" iDec 108 | -- Without using 'Proxy' type, crunchy. 109 | where iDec = T.untag (mkDecoder :: Monad f => Tagged GWaarg (SD.Decoder f Image)) 110 | 111 | -- Proxy the decoder using the tag from the typeclass instance, much nicer 112 | -- where iDec = T.proxy mkDecoder (Proxy :: Proxy GWaarg) 113 | 114 | -- As above but with the niceness of TypeApplications (GHC > 8), even better 115 | -- where iDec = T.proxy mkDecoder (Proxy @GWaarg) 116 | 117 | -- Even better with using TypeApplications directly on the 'mkDecoder' 118 | -- where iDec = T.untag $ mkDecoder @GWaarg 119 | 120 | instance Generic Image 121 | instance HasDatatypeInfo Image 122 | 123 | imageOpts :: Options 124 | imageOpts = defaultOpts 125 | { _optionsFieldName = \s -> 126 | fromMaybe s $ List.stripPrefix "_image" s 127 | } 128 | 129 | -- | You can just 'generics-sop' to automatically create an Encoder for you. Be 130 | -- sure to check your outputs as the Generic system must make some assumptions 131 | -- about how certain things are structured. These assumptions may not agree with 132 | -- your expectations so always check. 133 | instance JsonEncode GWaarg Image where mkEncoder = gEncoder imageOpts 134 | instance JsonDecode GWaarg Image where mkDecoder = gDecoder imageOpts 135 | 136 | newtype Fudge = Fudge { unCrepe :: Text } 137 | deriving (Eq, Show, GHC.Generic) 138 | 139 | instance Generic Fudge 140 | instance HasDatatypeInfo Fudge 141 | 142 | fudgeJsonOpts :: Options 143 | fudgeJsonOpts = defaultOpts 144 | { _optionsNewtypeWithConsName = ConstructorNameAsKey 145 | , _optionsFieldName = const "fudgey" 146 | } 147 | 148 | instance JsonEncode GWaarg Fudge where mkEncoder = gEncoder fudgeJsonOpts 149 | instance JsonDecode t Fudge where mkDecoder = gDecoder fudgeJsonOpts 150 | 151 | testFudge :: Fudge 152 | testFudge = Fudge "Chocolate" 153 | 154 | data Overlayed = Overlayed 155 | { _overId :: Text 156 | , _overFu :: Fudge 157 | } 158 | deriving (Show, GHC.Generic) 159 | 160 | genDecimalDigit :: Gen DecDigit 161 | genDecimalDigit = Gen.element decimalDigit 162 | 163 | genHeXaDeCiMaLDigit :: Gen HeXDigit 164 | genHeXaDeCiMaLDigit = Gen.element hExAdEcImAlDigit 165 | 166 | decimalDigit :: [DecDigit] 167 | decimalDigit = 168 | [ D.DecDigit0 169 | , D.DecDigit1 170 | , D.DecDigit2 171 | , D.DecDigit3 172 | , D.DecDigit4 173 | , D.DecDigit5 174 | , D.DecDigit6 175 | , D.DecDigit7 176 | , D.DecDigit8 177 | , D.DecDigit9 178 | ] 179 | 180 | hExAdEcImAlDigit :: [HeXDigit] 181 | hExAdEcImAlDigit = 182 | [ D.HeXDigit0 183 | , D.HeXDigit1 184 | , D.HeXDigit2 185 | , D.HeXDigit3 186 | , D.HeXDigit4 187 | , D.HeXDigit5 188 | , D.HeXDigit6 189 | , D.HeXDigit7 190 | , D.HeXDigit8 191 | , D.HeXDigit9 192 | , D.HeXDigita 193 | , D.HeXDigitb 194 | , D.HeXDigitc 195 | , D.HeXDigitd 196 | , D.HeXDigite 197 | , D.HeXDigitf 198 | , D.HeXDigitA 199 | , D.HeXDigitB 200 | , D.HeXDigitC 201 | , D.HeXDigitD 202 | , D.HeXDigitE 203 | , D.HeXDigitF 204 | ] 205 | 206 | genDecimalDigitNoZero :: Gen DecDigit 207 | genDecimalDigitNoZero = Gen.filter (/= D.DecDigit0) genDecimalDigit 208 | 209 | genHeXaDeCiMaLDigitNoZero :: Gen HeXDigit 210 | genHeXaDeCiMaLDigitNoZero = Gen.filter (/= D.HeXDigit0) genHeXaDeCiMaLDigit 211 | 212 | genDecimalDigits :: Gen [DecDigit] 213 | genDecimalDigits = Gen.list (Range.linear 1 10) genDecimalDigit 214 | 215 | genNonEmptyDecimalDigit :: Gen (NonEmpty DecDigit) 216 | genNonEmptyDecimalDigit = Gen.nonEmpty (Range.linear 1 10) genDecimalDigit 217 | 218 | genWhitespace :: Gen Whitespace 219 | genWhitespace = Gen.element 220 | [ Space 221 | , HorizontalTab 222 | , LineFeed 223 | , NewLine 224 | , CarriageReturn 225 | ] 226 | 227 | genText :: Gen Text 228 | genText = Gen.text ( Range.linear 0 100 ) Gen.unicodeAll 229 | 230 | genScientific :: MonadGen m => Maybe Int -> m Scientific 231 | genScientific lim = either fst fst . Sci.fromRationalRepetend lim 232 | <$> Gen.realFrac_ (Range.linearFrac 0.0001 1000.0) 233 | 234 | encodeJsonText :: Json -> Text 235 | encodeJsonText = TextL.toStrict . E.simplePureEncodeText E.json 236 | 237 | encodeText :: E.Encoder Identity a -> a -> TextL.Text 238 | encodeText e = E.simplePureEncodeText e 239 | 240 | encodeBS :: Json -> ByteString 241 | encodeBS = BL.toStrict . E.simplePureEncodeByteString E.json 242 | 243 | prop_generic_tripping 244 | :: ( MonadTest m 245 | , Show a 246 | , Eq a 247 | ) 248 | => Tagged GWaarg (E.Encoder Identity a) 249 | -> Tagged GWaarg (SD.Decoder Identity a) 250 | -> a 251 | -> m () 252 | prop_generic_tripping e d a = tripping a 253 | (E.simplePureEncodeTextNoSpaces (T.untag e)) 254 | (WA.pureDecodeAttoparsecText (T.untag d) . TextL.toStrict) 255 | -------------------------------------------------------------------------------- /test/Types/JChar.hs: -------------------------------------------------------------------------------- 1 | module Types.JChar 2 | ( genJChar 3 | , genHex4 4 | , genJCharEscaped 5 | , genJCharUnescaped 6 | ) where 7 | 8 | import Hedgehog 9 | import qualified Hedgehog.Gen as Gen 10 | 11 | import Control.Lens (preview) 12 | import Types.Common (genHeXaDeCiMaLDigit, 13 | genWhitespace) 14 | 15 | import Data.Digit (HeXDigit) 16 | 17 | import Waargonaut.Types.JChar (JChar (..)) 18 | import Waargonaut.Types.JChar.Escaped (Escaped (..)) 19 | import Waargonaut.Types.JChar.HexDigit4 (HexDigit4 (..)) 20 | import Waargonaut.Types.JChar.Unescaped (AsUnescaped (..), Unescaped) 21 | 22 | genJChar :: Gen (JChar HeXDigit) 23 | genJChar = Gen.choice 24 | [ EscapedJChar <$> genJCharEscaped 25 | , UnescapedJChar <$> genJCharUnescaped 26 | ] 27 | 28 | genJCharUnescaped :: Gen Unescaped 29 | genJCharUnescaped = Gen.just $ preview _Unescaped <$> Gen.unicode 30 | 31 | genJCharEscaped :: Gen (Escaped HeXDigit) 32 | genJCharEscaped = do 33 | h4 <- genHex4 34 | ws <- genWhitespace 35 | Gen.element 36 | [ QuotationMark 37 | , ReverseSolidus 38 | , Solidus 39 | , Backspace 40 | , WhiteSpace ws 41 | , Hex h4 42 | ] 43 | 44 | genHex4 :: Gen (HexDigit4 HeXDigit) 45 | genHex4 = HexDigit4 46 | <$> genHeXaDeCiMaLDigit 47 | <*> genHeXaDeCiMaLDigit 48 | <*> genHeXaDeCiMaLDigit 49 | <*> genHeXaDeCiMaLDigit 50 | -------------------------------------------------------------------------------- /test/Types/JNumber.hs: -------------------------------------------------------------------------------- 1 | module Types.JNumber 2 | ( genJNumber 3 | ) where 4 | 5 | import Control.Applicative (liftA2) 6 | import Control.Lens (( # )) 7 | 8 | import Hedgehog 9 | import qualified Hedgehog.Gen as Gen 10 | 11 | import Types.Common (genDecimalDigitNoZero, 12 | genDecimalDigits, 13 | genNonEmptyDecimalDigit) 14 | 15 | import Waargonaut.Types.JNumber (E (..), Exp (..), Frac (..), JInt, 16 | JNumber (..), _JIntInt, _JZero) 17 | 18 | genJNumber :: Gen JNumber 19 | genJNumber = JNumber 20 | <$> Gen.bool 21 | <*> genJInt 22 | <*> Gen.maybe genFrac 23 | <*> Gen.maybe genExp 24 | 25 | genJInt :: Gen JInt 26 | genJInt = Gen.choice 27 | [ Gen.constant (_JZero # ()) 28 | , (_JIntInt #) <$> liftA2 (,) genDecimalDigitNoZero genDecimalDigits 29 | ] 30 | 31 | genFrac :: Gen Frac 32 | genFrac = Frac <$> genNonEmptyDecimalDigit 33 | 34 | genExp :: Gen Exp 35 | genExp = Exp 36 | <$> Gen.element [EE,Ee] 37 | <*> Gen.maybe Gen.bool 38 | <*> genNonEmptyDecimalDigit 39 | -------------------------------------------------------------------------------- /test/Types/JString.hs: -------------------------------------------------------------------------------- 1 | module Types.JString 2 | ( genJString 3 | ) where 4 | 5 | import Control.Lens (( # ), _Wrapped) 6 | 7 | import Hedgehog 8 | import qualified Hedgehog.Gen as Gen 9 | import qualified Hedgehog.Range as Range 10 | 11 | import qualified Data.Vector as V 12 | 13 | import Types.JChar (genJChar) 14 | 15 | import Waargonaut.Types.JString (JString) 16 | 17 | genJString 18 | :: Gen JString 19 | genJString = 20 | (_Wrapped #) . V.fromList <$> Gen.list (Range.linear 0 1000) genJChar 21 | -------------------------------------------------------------------------------- /test/Types/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Types.Json 3 | ( genJson 4 | ) where 5 | 6 | import Hedgehog 7 | import qualified Hedgehog.Gen as Gen 8 | 9 | import qualified Types.JNumber as G 10 | import qualified Types.JString as G 11 | import qualified Types.Whitespace as G 12 | 13 | import Waargonaut.Types.Whitespace (WS) 14 | 15 | import Waargonaut.Types.JArray (JArray (..)) 16 | import Waargonaut.Types.JObject (JAssoc (..), JObject (..)) 17 | 18 | import Waargonaut (JType (..), Json (..)) 19 | 20 | import Types.CommaSep (genCommaSeparated, 21 | genEmptyCommaSeparated) 22 | 23 | genJArray :: Gen (JArray WS Json) 24 | genJArray = JArray <$> genCommaSeparated G.genWS genJson 25 | 26 | genJAssoc :: Gen (JAssoc WS Json) 27 | genJAssoc = Gen.recursive Gen.choice 28 | -- Non Recursive 29 | (mk <$> genJsonNonRecursive) 30 | -- Recursive 31 | [ mk genJson ] 32 | where 33 | mk v = JAssoc 34 | <$> G.genJString 35 | <*> G.genWS 36 | <*> G.genWS 37 | <*> v 38 | 39 | genJObj :: Gen (JObject WS Json) 40 | genJObj = JObject <$> genCommaSeparated G.genWS genJAssoc 41 | 42 | toJson 43 | :: (t -> WS -> JType WS Json) 44 | -> Gen t 45 | -> Gen Json 46 | toJson c v = 47 | (\v' -> Json . c v') <$> v <*> G.genWS 48 | 49 | genJsonNonRecursive :: [Gen Json] 50 | genJsonNonRecursive = 51 | [ toJson (const JNull) G.genWS 52 | , toJson JBool Gen.bool 53 | , toJson JNum G.genJNumber 54 | , toJson JStr G.genJString 55 | , emptyCommaSep JArr JArray 56 | , emptyCommaSep JObj JObject 57 | ] 58 | where 59 | emptyCommaSep oc c = Json <$> ( 60 | oc . c <$> genEmptyCommaSeparated G.genWS <*> G.genWS 61 | ) 62 | 63 | genJson :: Gen Json 64 | genJson = Gen.recursive Gen.choice 65 | -- Non-recursive 66 | genJsonNonRecursive 67 | -- Recursive 68 | [ toJson JArr genJArray 69 | , toJson JObj genJObj 70 | ] 71 | -------------------------------------------------------------------------------- /test/Types/Whitespace.hs: -------------------------------------------------------------------------------- 1 | module Types.Whitespace 2 | ( genWS 3 | , genEmptyWS 4 | ) where 5 | 6 | import Hedgehog 7 | import qualified Hedgehog.Gen as Gen 8 | import qualified Hedgehog.Range as Range 9 | 10 | import qualified Data.Vector as V 11 | 12 | import Types.Common (genWhitespace) 13 | 14 | import Waargonaut.Types.Whitespace (WS (..)) 15 | 16 | genWS :: Gen WS 17 | genWS = WS . V.fromList <$> Gen.list (Range.linear 0 30) genWhitespace 18 | 19 | genEmptyWS :: Gen WS 20 | genEmptyWS = Gen.constant mempty 21 | -------------------------------------------------------------------------------- /test/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Utils where 5 | 6 | import Control.Applicative ((<$>), (<*), (<*>)) 7 | 8 | import Data.Char (Char) 9 | import Data.Either (Either (..)) 10 | import Data.Text (Text) 11 | 12 | import Data.Attoparsec.Text (Parser, anyChar, endOfInput, 13 | parseOnly) 14 | 15 | import Waargonaut.Decode (parseWith) 16 | import Waargonaut.Decode.Error (DecodeError) 17 | 18 | testparse 19 | :: Parser a 20 | -> Text 21 | -> Either DecodeError a 22 | testparse p = 23 | parseWith parseOnly p 24 | 25 | testparsetheneof 26 | :: Parser a 27 | -> Text 28 | -> Either DecodeError a 29 | testparsetheneof p = 30 | testparse (p <* endOfInput) 31 | 32 | testparsethennoteof 33 | :: Parser a 34 | -> Text 35 | -> Either DecodeError a 36 | testparsethennoteof p = 37 | testparse (p <* anyChar) 38 | 39 | testparsethen 40 | :: Parser a 41 | -> Text 42 | -> Either DecodeError (a, Char) 43 | testparsethen p = 44 | testparse ((,) <$> p <*> anyChar <* endOfInput) 45 | -------------------------------------------------------------------------------- /test/json-data/bad-json/no_comma_arr.json: -------------------------------------------------------------------------------- 1 | [11 12 13] -------------------------------------------------------------------------------- /test/json-data/bad-json/no_comma_obj.json: -------------------------------------------------------------------------------- 1 | {"foo":3"bar":4} -------------------------------------------------------------------------------- /test/json-data/goldens/backslash128.json.golden: -------------------------------------------------------------------------------- 1 | {"a":"\\128"} 2 | -------------------------------------------------------------------------------- /test/json-data/goldens/empty_arr_empty_ws.json.golden: -------------------------------------------------------------------------------- 1 | [ ] -------------------------------------------------------------------------------- /test/json-data/goldens/image_obj.json.golden: -------------------------------------------------------------------------------- 1 | { 2 | "Image": { 3 | "Width": 800, 4 | "Height": 600, 5 | "Title": "View from 15th Floor", 6 | "Thumbnail": { 7 | "Url": "http://www.example.com/image/481989943", 8 | "Height": 125, 9 | "Width": 100 10 | }, 11 | "Animated" : false, 12 | "IDs": [116, 943, 234, 38793] 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/json-data/goldens/location_array.json.golden: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "precision": "zip", 4 | "Latitude": 37.7668, 5 | "Longitude": -122.3959, 6 | "Address": "", 7 | "City": "SAN FRANCISCO", 8 | "State": "CA", 9 | "Zip": "94107", 10 | "Country": "US" 11 | }, 12 | { 13 | "precision": "zip", 14 | "Latitude": 37.371991, 15 | "Longitude": -122.026020, 16 | "Address": "", 17 | "City": "SUNNYVALE", 18 | "State": "CA", 19 | "Zip": "94085", 20 | "Country": "US" 21 | } 22 | ] 23 | -------------------------------------------------------------------------------- /test/json-data/goldens/nested_arrs.json.golden: -------------------------------------------------------------------------------- 1 | [[[[0.00]]]] -------------------------------------------------------------------------------- /test/json-data/goldens/null_arr_trailing_comma_ws.json.golden: -------------------------------------------------------------------------------- 1 | [null, ] -------------------------------------------------------------------------------- /test/json-data/goldens/unicode_2705.json.golden: -------------------------------------------------------------------------------- 1 | "\u2705" 2 | -------------------------------------------------------------------------------- /test/json-data/image_obj.json: -------------------------------------------------------------------------------- 1 | { 2 | "Image": { 3 | "Width": 800, 4 | "Height": 600, 5 | "Title": "View from 15th Floor", 6 | "Thumbnail": { 7 | "Url": "http://www.example.com/image/481989943", 8 | "Height": 125, 9 | "Width": 100 10 | }, 11 | "Animated" : false, 12 | "IDs": [116, 943, 234, 38793] 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /test/json-data/keys-in-obj.json: -------------------------------------------------------------------------------- 1 | { "Collection" : { 2 | "ID0": { 3 | "SomeCommonKeys": "Some data" 4 | }, 5 | "ID1": { 6 | "SomeCommonKeys": "Some different data" 7 | } 8 | } -------------------------------------------------------------------------------- /test/json-data/location_array.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "precision": "zip", 4 | "Latitude": 37.7668, 5 | "Longitude": -122.3959, 6 | "Address": "", 7 | "City": "SAN FRANCISCO", 8 | "State": "CA", 9 | "Zip": "94107", 10 | "Country": "US" 11 | }, 12 | { 13 | "precision": "zip", 14 | "Latitude": 37.371991, 15 | "Longitude": -122.026020, 16 | "Address": "", 17 | "City": "SUNNYVALE", 18 | "State": "CA", 19 | "Zip": "94085", 20 | "Country": "US" 21 | } 22 | ] 23 | -------------------------------------------------------------------------------- /test/json-data/mishandling.json: -------------------------------------------------------------------------------- 1 | "€" -------------------------------------------------------------------------------- /test/json-data/unicode_2705.json: -------------------------------------------------------------------------------- 1 | "\u2705" 2 | -------------------------------------------------------------------------------- /waarg-overrides.nix: -------------------------------------------------------------------------------- 1 | sources: hlib: hself: hsuper: { 2 | # doctest = hsuper.callCabal2nix "doctest" sources.doctest {}; 3 | # haskellworks 4 | hw-bits = hsuper.callCabal2nix "hw-bits" sources.hw-bits {}; 5 | hw-balancedparens = hlib.dontCheck ( 6 | hsuper.callCabal2nix "hw-balancedparens" sources.hw-balancedparens {} 7 | ); 8 | hw-json-simd = hlib.dontCheck (hlib.markUnbroken hsuper.hw-json-simd); 9 | hw-rankselect = hsuper.callCabal2nix "hw-rankselect" sources.hw-rankselect {}; 10 | hw-excess = hlib.markUnbroken hsuper.hw-excess; 11 | hw-rankselect-base = hlib.markUnbroken hsuper.hw-rankselect-base; 12 | hw-json-standard-cursor = hlib.markUnbroken hsuper.hw-json-standard-cursor; 13 | 14 | # other 15 | natural = hsuper.callPackage sources.natural {}; 16 | digit = hlib.markUnbroken hsuper.digit; 17 | hoist-error = hsuper.callPackage sources.hs-hoist-error {}; 18 | 19 | # newtype = hlib.dontCheck (hlib.doJailbreak hsuper.newtype); 20 | ChasingBottoms = hlib.doJailbreak hsuper.ChasingBottoms; 21 | constraints = hsuper.callCabal2nix "constraints" sources.constraints {}; 22 | } 23 | -------------------------------------------------------------------------------- /waargbench/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for waargbench 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /waargbench/LICENCE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Commonwealth Scientific and Industrial Research Organisation 2 | (CSIRO) ABN 41 687 119 230. 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of QFPL nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /waargbench/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /waargbench/bench/Bench.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Waargbench 4 | 5 | main :: IO () 6 | main = Waargbench.main 7 | -------------------------------------------------------------------------------- /waargbench/cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./waargbench.cabal -------------------------------------------------------------------------------- /waargbench/default.nix: -------------------------------------------------------------------------------- 1 | { sources ? import ./../nix/sources.nix 2 | , compiler ? "default" 3 | }: 4 | let 5 | pkgs = import sources.nixpkgs {}; 6 | 7 | baseHaskellPackages = if compiler == "default" 8 | then pkgs.haskellPackages 9 | else pkgs.haskell.packages.${compiler}; 10 | 11 | haskellPackages = baseHaskellPackages.override (old: { 12 | overrides = pkgs.lib.composeExtensions 13 | (old.overrides or (_: _: {})) 14 | (import ./../nix/waargoverlay.nix pkgs.haskell.lib); 15 | }); 16 | 17 | withWaarg = haskellPackages.override (old: { 18 | overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: {})) (hself: hsuper: { 19 | waargonaut = hself.callCabal2nix "waargonaut" ../. {}; 20 | }); 21 | }); 22 | 23 | drv = pkgs.haskell.lib.doBenchmark (withWaarg.callCabal2nix "waargbench" ./. {}); 24 | in 25 | pkgs.haskell.lib.shellAware drv 26 | -------------------------------------------------------------------------------- /waargbench/src/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Common 5 | ( testImageDataType 6 | , imageDecodeGeneric 7 | , imageDecode 8 | , decodeScientific 9 | , Image (..) 10 | ) where 11 | 12 | import qualified GHC.Generics as GHC 13 | 14 | import Control.Monad ((>=>)) 15 | import Data.Proxy (Proxy (..)) 16 | 17 | import qualified Data.List as List 18 | import Data.Maybe (fromMaybe) 19 | import Data.Text (Text) 20 | 21 | import Data.Scientific (Scientific) 22 | 23 | import qualified Waargonaut.Decode as D 24 | 25 | import Waargonaut.Generic (GWaarg, Generic, HasDatatypeInfo, 26 | JsonDecode (..), JsonEncode (..), 27 | Options (..), defaultOpts, gDecoder, 28 | gEncoder, proxy) 29 | 30 | data Image = Image 31 | { _imageWidth :: Int 32 | , _imageHeight :: Int 33 | , _imageTitle :: Text 34 | , _imageAnimated :: Bool 35 | , _imageIDs :: [Int] 36 | } 37 | deriving (Show, Eq, GHC.Generic) 38 | 39 | testImageDataType :: Image 40 | testImageDataType = Image 800 600 "View from 15th Floor" False [116, 943, 234, 38793] 41 | 42 | imageDecode :: Monad f => D.Decoder f Image 43 | imageDecode = D.withCursor $ D.down >=> \curs -> do 44 | -- Move to the value at the "Image" key 45 | io <- D.moveToKey "Image" curs >>= D.down 46 | -- We need individual values off of our object, 47 | Image 48 | <$> D.fromKey "Width" D.int io 49 | <*> D.fromKey "Height" D.int io 50 | <*> D.fromKey "Title" D.text io 51 | <*> D.fromKey "Animated" D.bool io 52 | <*> D.fromKey "IDs" (D.list D.int) io 53 | 54 | imageDecodeGeneric :: Monad f => D.Decoder f Image 55 | imageDecodeGeneric = D.withCursor $ D.fromKey "Image" (proxy mkDecoder (Proxy :: Proxy GWaarg)) 56 | 57 | instance Generic Image 58 | instance HasDatatypeInfo Image 59 | 60 | imageOpts :: Options 61 | imageOpts = defaultOpts 62 | { _optionsFieldName = \s -> 63 | fromMaybe s $ List.stripPrefix "_image" s 64 | } 65 | 66 | 67 | -- | You can just 'generics-sop' to automatically create an Encoder for you. Be 68 | -- sure to check your outputs as the Generic system must make some assumptions 69 | -- about how certain things are structured. These assumptions may not agree with 70 | -- your expectations so always check. 71 | instance JsonEncode GWaarg Image where mkEncoder = gEncoder imageOpts 72 | instance JsonDecode GWaarg Image where mkDecoder = gDecoder imageOpts 73 | 74 | decodeScientific :: Monad f => D.Decoder f [Scientific] 75 | decodeScientific = proxy mkDecoder (Proxy :: Proxy GWaarg) 76 | -------------------------------------------------------------------------------- /waargbench/src/Waargbench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Main (main) where 3 | 4 | import Control.Applicative (liftA2) 5 | 6 | import Data.Functor.Identity (Identity) 7 | 8 | import Data.ByteString (ByteString) 9 | import qualified Data.ByteString as BS 10 | import Data.Either (isRight) 11 | import Data.Maybe (isJust) 12 | import Data.Monoid ((<>)) 13 | 14 | import Data.Attoparsec.ByteString (parseOnly) 15 | 16 | import qualified Criterion.Main as G 17 | import qualified HaskellWorks.Data.Json.Standard.Cursor.Type as HW 18 | 19 | import qualified Waargonaut as W 20 | 21 | import Waargonaut.Decode (Decoder) 22 | import qualified Waargonaut.Decode as D 23 | 24 | import Common (decodeScientific, 25 | imageDecode, 26 | imageDecodeGeneric) 27 | 28 | parseOkay :: ByteString -> Bool 29 | parseOkay = isRight . parseOnly W.parseWaargonaut 30 | 31 | indexOkay :: ByteString -> Bool 32 | indexOkay = isJust . HW.jsonTypeAt . D.unJCurs . D.mkCursor 33 | 34 | decodeByteString :: Decoder Identity a -> ByteString -> Bool 35 | decodeByteString d = isRight . D.pureDecodeFromByteString parseOnly d 36 | 37 | rf :: FilePath -> IO ByteString 38 | rf f = BS.readFile $ "../test/json-data/" <> f 39 | 40 | getParseFiles :: IO [ByteString] 41 | getParseFiles = sequence 42 | [ (rf "twitter_with_hex_vals.json") 43 | , (rf "twitter100.json") 44 | , (rf "numbers.json") 45 | ] 46 | 47 | getDecodeFiles :: IO (ByteString, ByteString) 48 | getDecodeFiles = liftA2 (,) 49 | (rf "image_obj.json") 50 | (rf "numbers.json") 51 | 52 | main :: IO () 53 | main = G.defaultMain 54 | [ parse 55 | , parseSuccinct 56 | , decode 57 | ] 58 | 59 | decode :: G.Benchmark 60 | decode = G.env getDecodeFiles $ \ ~(image, numbers) -> G.bgroup "Decode" 61 | [ G.bench "Image Decode (generic)" $ G.nf (decodeByteString imageDecodeGeneric) image 62 | , G.bench "Image Decode" $ G.nf (decodeByteString imageDecode) image 63 | , G.bench "[Scientific]" $ G.nf (decodeByteString decodeScientific) numbers 64 | ] 65 | 66 | parse :: G.Benchmark 67 | parse = G.env getParseFiles $ \ ~(twitterWithHexVals:twitter100:numbers:_) -> G.bgroup "Parse - Attoparsec" 68 | [ G.bench "twitter_with_hex_vals" $ G.nf parseOkay twitterWithHexVals 69 | , G.bench "twitter100" $ G.nf parseOkay twitter100 70 | , G.bench "numbers" $ G.nf parseOkay numbers 71 | ] 72 | 73 | parseSuccinct :: G.Benchmark 74 | parseSuccinct = G.env getParseFiles $ \ ~(twitterWithHexVals:twitter100:numbers:_) -> G.bgroup "Succinct Index" 75 | [ G.bench "twitter_with_hex_vals" $ G.nf indexOkay twitterWithHexVals 76 | , G.bench "twitter100" $ G.nf indexOkay twitter100 77 | , G.bench "numbers" $ G.nf indexOkay numbers 78 | ] 79 | -------------------------------------------------------------------------------- /waargbench/waargbench.cabal: -------------------------------------------------------------------------------- 1 | -- Initial waargbench.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: waargbench 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | -- The license under which the package is released. 9 | license: BSD3 10 | 11 | -- The file containing the license text. 12 | license-file: LICENCE 13 | 14 | -- The package author(s). 15 | author: QFPL @ Data61 16 | 17 | -- An email address to which users can send suggestions, bug reports, and 18 | -- patches. 19 | maintainer: oᴉ˙ldɟb@uɐǝs 20 | 21 | -- A copyright notice. 22 | copyright: Copyright (C) 2018 Commonwealth Scientific and Industrial Research Organisation (CSIRO) 23 | 24 | -- category: 25 | 26 | build-type: Simple 27 | extra-source-files: CHANGELOG.md 28 | cabal-version: >=1.10 29 | 30 | tested-with: GHC==8.0.2 31 | , GHC==8.2.2 32 | , GHC==8.4.4 33 | , GHC==8.6.4 34 | 35 | -- Extra files to be distributed with the package, such as examples or a README. 36 | extra-source-files: ../test/json-data/twitter_with_hex_vals.json 37 | , ../test/json-data/numbers.json 38 | , ../test/json-data/image_obj.json 39 | , ../test/json-data/twitter100.json 40 | 41 | benchmark bench 42 | 43 | type: exitcode-stdio-1.0 44 | main-is: Waargbench.hs 45 | 46 | other-modules: Common 47 | -- other-extensions: 48 | build-depends: base >= 4.8 && < 5 49 | , lens >= 4.15 && < 5.2 50 | , semigroups >= 0.8.4 && < 0.20 51 | , text >= 1.2 && < 1.3 52 | , generics-sop >= 0.3.2 && < 5 53 | , digit >= 0.7 && < 1 54 | , bytestring >= 0.10.6 && < 0.12 55 | , attoparsec >= 0.13 && < 0.15 56 | 57 | , hw-json-standard-cursor >= 0.2.1.1 && < 0.3 58 | 59 | , scientific >= 0.3 && < 0.4 60 | , primitive >= 0.6.4 && < 0.8 61 | 62 | , hedgehog 63 | , criterion 64 | , waargonaut 65 | 66 | hs-source-dirs: src 67 | default-language: Haskell2010 68 | ghc-options: -Wall -O2 69 | -------------------------------------------------------------------------------- /waargonaut.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: waargonaut 3 | version: 0.8.0.2 4 | synopsis: JSON wrangling 5 | description: 6 | Flexible, precise, and efficient JSON decoding/encoding library. 7 | 8 | license: BSD-3-Clause 9 | license-file: LICENSE 10 | author: HASKELL-WAARGONAUT @ Data61 11 | maintainer: 12 | oᴉ˙ldɟb@uɐǝs, emilypi@cohomolo.gy, george@wils.online, tonymorris+github@gmail.com 13 | 14 | copyright: 15 | Copyright (C) 2018-2019 Commonwealth Scientific and Industrial Research Organisation (CSIRO) 16 | Copyright (C) 2020-2021 Sean Chalmers and Emily Pillmore 17 | 18 | category: Parser, Web, JSON 19 | build-type: Simple 20 | extra-doc-files: 21 | changelog.md 22 | README.md 23 | 24 | -- Misc json files 25 | -- Known bad json files 26 | -- Golden files 27 | extra-source-files: 28 | test/json-data/bad-json/no_comma_arr.json 29 | test/json-data/bad-json/no_comma_obj.json 30 | test/json-data/goldens/backslash128.json.golden 31 | test/json-data/goldens/empty_arr_empty_ws.json.golden 32 | test/json-data/goldens/image_obj.json.golden 33 | test/json-data/goldens/location_array.json.golden 34 | test/json-data/goldens/nested_arrs.json.golden 35 | test/json-data/goldens/null_arr_trailing_comma_ws.json.golden 36 | test/json-data/goldens/numbers.json.golden 37 | test/json-data/goldens/twitter100.json.golden 38 | test/json-data/goldens/twitter_with_hex_vals.json.golden 39 | test/json-data/goldens/unicode_2705.json.golden 40 | test/json-data/image_obj.json 41 | test/json-data/keys-in-obj.json 42 | test/json-data/numbers.json 43 | test/json-data/twitter_with_hex_vals.json 44 | test/json-data/unicode_2705.json 45 | 46 | homepage: https://github.com/haskell-waargonaut/waargonaut 47 | bug-reports: https://github.com/haskell-waargonaut/waargonaut/issues 48 | tested-with: 49 | GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.1 50 | 51 | 52 | source-repository head 53 | type: git 54 | location: git@github.com/haskell-waargonaut/waargonaut.git 55 | 56 | library 57 | -- Modules included in this executable, other than Main. 58 | exposed-modules: 59 | Waargonaut 60 | Waargonaut.Attoparsec 61 | Waargonaut.Decode 62 | Waargonaut.Decode.Error 63 | Waargonaut.Decode.Internal 64 | Waargonaut.Decode.Runners 65 | Waargonaut.Decode.Traversal 66 | Waargonaut.Decode.Types 67 | Waargonaut.Decode.ZipperMove 68 | Waargonaut.Encode 69 | Waargonaut.Encode.Builder 70 | Waargonaut.Encode.Builder.CommaSep 71 | Waargonaut.Encode.Builder.JArray 72 | Waargonaut.Encode.Builder.JChar 73 | Waargonaut.Encode.Builder.JNumber 74 | Waargonaut.Encode.Builder.JObject 75 | Waargonaut.Encode.Builder.JString 76 | Waargonaut.Encode.Builder.Types 77 | Waargonaut.Encode.Builder.Whitespace 78 | Waargonaut.Encode.Types 79 | Waargonaut.Generic 80 | Waargonaut.Lens 81 | Waargonaut.Prettier 82 | Waargonaut.Test 83 | Waargonaut.Types 84 | Waargonaut.Types.CommaSep 85 | Waargonaut.Types.CommaSep.Elem 86 | Waargonaut.Types.CommaSep.Elems 87 | Waargonaut.Types.JArray 88 | Waargonaut.Types.JChar 89 | Waargonaut.Types.JChar.Escaped 90 | Waargonaut.Types.JChar.HexDigit4 91 | Waargonaut.Types.JChar.Unescaped 92 | Waargonaut.Types.JNumber 93 | Waargonaut.Types.JObject 94 | Waargonaut.Types.JObject.JAssoc 95 | Waargonaut.Types.Json 96 | Waargonaut.Types.JString 97 | Waargonaut.Types.Whitespace 98 | 99 | ghc-options: -Wall 100 | 101 | -- Other library packages from which modules are imported. 102 | build-depends: 103 | attoparsec >=0.13 && <0.15 104 | , base >=4.11 && <4.16 105 | , bifunctors >=5 && <5.6 106 | , bytestring >=0.10.6 && <0.12 107 | , containers >=0.5.6 && <0.7 108 | , contravariant >=1.4 && <1.6 109 | , digit >=0.7 && <1 110 | , distributive >=0.5 && <0.7 111 | , errors >=2.2 && <2.4 112 | , generics-sop >=0.4 && <0.6 113 | , hoist-error >=0.2 && <0.3 114 | , hw-balancedparens >=0.2 && <0.5 115 | , hw-bits >=0.7 && <0.8 116 | , hw-json-standard-cursor >=0.2.1.1 && <0.3 117 | , hw-prim >=0.6 && <0.7 118 | , hw-rankselect >=0.13 && <0.14 119 | , lens >=4.15 && <5.2 120 | , mmorph >=1.1 && <1.3 121 | , mtl >=2.2.2 && <2.3 122 | , nats >=1 && <1.2 123 | , natural >=0.3 && <0.4 124 | , parsers >=0.12 && <0.13 125 | , records-sop >=0.1 && <0.2 126 | , scientific >=0.3 && <0.4 127 | , semigroupoids >=5.2.2 && <5.4 128 | , semigroups >=0.8.4 && <0.20 129 | , tagged >=0.8.5 && <0.9 130 | , text >=1.2 && <1.3 131 | , transformers >=0.4 && <0.7 132 | , unordered-containers >=0.2.9 && <0.3 133 | , vector >=0.12 && <0.13 134 | , witherable >=0.2 && <0.5 135 | , wl-pprint-annotated >=0.1 && <0.2 136 | , zippers >=0.2 && <0.4 137 | 138 | -- Directories containing source files. 139 | hs-source-dirs: src 140 | 141 | -- Base language which the package is written in. 142 | default-language: Haskell2010 143 | 144 | test-suite waarg-tests 145 | other-modules: 146 | Decoder 147 | Decoder.Laws 148 | Encoder 149 | Encoder.Laws 150 | Generics 151 | Golden 152 | Json 153 | Laws 154 | Prettier.NestedObjs 155 | Properties 156 | Types.CommaSep 157 | Types.Common 158 | Types.JChar 159 | Types.JNumber 160 | Types.Json 161 | Types.JString 162 | Types.Whitespace 163 | Utils 164 | 165 | type: exitcode-stdio-1.0 166 | main-is: Main.hs 167 | hs-source-dirs: test 168 | build-depends: 169 | attoparsec >=0.13 && <0.15 170 | , base >=4.11 && <4.16 171 | , bytestring >=0.10.6 && <0.12 172 | , containers >=0.5.6 && <0.7 173 | , contravariant >=1.4 && <1.6 174 | , digit >=0.7 && <1 175 | , distributive >=0.5 && <0.7 176 | , filepath >=1.4 && <1.5 177 | , generics-sop >=0.4 && <0.6 178 | , hedgehog >=0.6 && <1.2 179 | , hedgehog-fn >=0.6 && <2 180 | , hw-balancedparens >=0.2 && <0.5 181 | , hw-bits >=0.7 && <0.8 182 | , hw-json-standard-cursor >=0.2.1.1 && <0.3 183 | , hw-prim >=0.6 && <0.7 184 | , hw-rankselect >=0.13 && <0.14 185 | , lens >=4.15 && <5.2 186 | , mtl >=2.2.2 && <2.3 187 | , natural >=0.3 && <0.4 188 | , scientific >=0.3 && <0.4 189 | , semigroupoids >=5.2.2 && <5.6 190 | , semigroups >=0.8.4 && <0.20 191 | , tagged >=0.8.5 && <0.9 192 | , tasty >=0.11 && <1.5 193 | , tasty-expected-failure >=0.11 && <0.13 194 | , tasty-golden >=2.3 && <2.4 195 | , tasty-hedgehog >=0.2 && <1.2 196 | , tasty-hunit >=0.10 && <0.11 197 | , text >=1.2 && <1.3 198 | , unordered-containers >=0.2.9 && <0.3 199 | , vector >=0.12 && <0.13 200 | , waargonaut 201 | , zippers >=0.2 && <0.4 202 | 203 | ghc-options: -Wall 204 | 205 | -- Constraint on the version of Cabal needed to build this package. 206 | default-language: Haskell2010 207 | --------------------------------------------------------------------------------