json-litobj (empty) → 0.1.0.0
raw patch · 6 files changed
+365/−0 lines, 6 filesdep +QuickCheckdep +basedep +hspecsetup-changed
Dependencies added: QuickCheck, base, hspec, json, json-litobj
Files
- LICENSE +30/−0
- README.md +34/−0
- Setup.hs +2/−0
- Text/JSON/Permissive.hs +119/−0
- json-litobj.cabal +90/−0
- tests/UnitTests.hs +90/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Jonathan Kochems++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jonathan Kochems nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,34 @@+# json-litobj [](https://travis-ci.org/jonathankochems/json-litobj) [](http://codecov.io/github/jonathankochems/json-litobj?branch=master) [](https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29)++This module extends Text.JSON to enable the decoding of strings containing literal JS objects.+In particular, it relaxes the restriction that fields in JSON objects must be strings.++For example:++* JSON conformant: ++> { "foo" : "bar" }++* literal JS object: ++> { foo : "bar" }++## Documentation++The haddock documentation can be found on [hackage](https://hackage.haskell.org/package/json-litobj-0.1.0.0).++## Motivation++I wanted to parse JSON responses from various websites with Text.JSON. Unfortunately, I ran into parsing errors due to literal JS objects included in the answer strings. Since literal JS object are not really part of the JSON format I started this module to work around this problem.++## Contributing++If you feel that this module is missing something useful which should be part of a more ``permissive'' JSON parsing please consider a contribution.++To contribute:++1. fork this repository+2. create a feature branch +3. commit and push your code to your feature branch+4. create a pull request to this repository+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/JSON/Permissive.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.JSON.Permissive+-- Copyright : (c) Jonathan Kochems 2015+-- License : BSD-3+-- Maintainer : jonathan.kochems@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module extends Text.JSON to enable the decoding of strings containing literal JS objects.+-- In particular, it relaxes the restriction that fields in JSON objects must be strings.+--+-- For example:+--+-- > JSON conformant: literal JS object:+-- > { "foo" : "bar" } { foo : "bar" }+--+-----------------------------------------------------------------------------+module Text.JSON.Permissive(decodePermissive, get_fields) where+import Text.JSON (Result(..))+import Text.JSON.Parsec ( runParser, try, CharParser(..), spaces, space, char, sepBy, manyTill, anyChar,+ string, p_number, p_string, p_boolean, p_null, many, choice, noneOf, option, + lookAhead, ParseError, optionMaybe )+import Text.JSON.Types (JSValue(..), JSObject(..), toJSObject, toJSString, fromJSObject)+import Control.Monad(mzero)+import Data.Maybe (fromMaybe, isJust)+import Control.Applicative ((<$>))++ +{--------------------------------------------------------------------+ Decoding+--------------------------------------------------------------------}+-- | decodes a string encoding a JSON object in a relaxed fashion+--+-- > decode "{ foo : \"bar\" }"+-- > Error "Malformed JSON: expecting string: foo : \"b"+-- >+-- > decodePermissive "{ foo : \"bar\" }" == Ok $ toJSObject [("foo", JSString $ toJSString "bar")]+-- > decodePermissive "{ \"foo\" : \"bar\" }" == Ok $ toJSObject [("foo", JSString $ toJSString "bar")]+decodePermissive :: String -> Result (JSObject JSValue)+decodePermissive s = either (Error . show) + (Ok . toJSObject) + $ runParser p_object () "stdin" s++{--------------------------------------------------------------------+ JSON Object Interaction+--------------------------------------------------------------------}+-- | returns the list of fields of a JSON Object+--+-- > do obj <- decodePermissive "{ foo : \"bar\", fooz : \"baz\" }"+-- > return $ get_fields obj == Ok ["foo", "fooz"]+--+-- > do obj <- decodePermissive "{ foo : \"bar\", fooz : \"baz\" }"+-- > return $ get_field obj $ head $ get_fields obj == Ok (Just $ JSString $ toJSString "bar" )+get_fields :: JSObject a -> [String]+get_fields = map fst . fromJSObject+++{--------------------------------------------------------------------+ Helper Parsers+--------------------------------------------------------------------}+-- The main change is in p_object to relax the restrictions on +-- fields.+p_object :: CharParser () [(String, JSValue)]+p_object = do _ <- spaces+ _ <- char '{'+ _ <- spaces+ rs <- option [] $ try $ entry `sepBy` string ","+ _ <- spaces+ _ <- char '}'+ return rs+ where entry = do _ <- spaces + x <- choice [try_wrapper p_string' "\"", many $ noneOf ":, }"]+ _ <- spaces + _ <- char ':'+ _ <- spaces+ val <- p_jvalue+ _ <- spaces+ return (x,val)++-- p_jvalue just hooks in the p_object parser (and also the modified p_array parser) +p_jvalue :: CharParser () JSValue+p_jvalue = choice [ (JSObject . toJSObject) <$> try_wrapper p_object "{", + JSArray <$> try_wrapper p_array "[",+ (JSString . toJSString) <$> try_wrapper p_string' "\"",+ JSRational False <$> try p_number,+ JSBool <$> try p_boolean,+ (\() -> JSNull) <$> try p_null+ ]++-- p_array just hooks into the p_jvalue parser+p_array :: CharParser () [JSValue]+p_array = do _ <- char '['+ rs <- entry `sepBy` string ","+ _ <- char ']'+ return rs+ where entry = do _ <- spaces+ res <- p_jvalue+ _ <- spaces+ return res++-- p_string' is a modified version of p_string that preserves leading whitespace. From the documention +-- of Text.JSON it would appear this is undesired behaviour. However, the quick check tests show that+-- Text.JSON.decode in fact does preserve leading whitespace in strings.+p_string' = do ws <- leadingWhiteSpace+ s <- p_string+ return $ ws ++ s++leadingWhiteSpace = lookAhead $ try $ do _ <- string "\""+ many space + ++-- Helper function to use in non-deterministic choice with lookAhead+try_wrapper :: CharParser () a -> String -> CharParser () a+try_wrapper p prefix = do try $ lookAhead (string prefix)+ try p+++
+ json-litobj.cabal view
@@ -0,0 +1,90 @@+-- The name of the package.+name: json-litobj++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Extends Text.JSON to handle literal JS objects.++-- A longer description of the package.+description: This module extends Text.JSON to enable the decoding of strings containing literal JS objects.++-- URL for the project homepage or repository.+homepage: https://github.com/jonathankochems/json-litobj++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Jonathan Kochems++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: jonathan.kochems@gmail.com++-- A copyright notice.+-- copyright: ++category: Text++build-type: Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+extra-source-files: README.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.10++-- Source repository information for development branch+source-repository head+ type: git+ location: git://github.com/jonathankochems/json-litobj.git + branch: develop++-- Source repository information for json-litobj-0.1.0.0+source-repository this+ type: git+ location: git://github.com/jonathankochems/json-litobj.git + branch: master+ tag: hackage-0.1.0.0++library+ -- Modules exported by the library.+ exposed-modules: Text.JSON.Permissive+ + -- Modules included in this library but not exported.+ -- other-modules: + + -- LANGUAGE extensions used by modules in this package.+ -- other-extensions: + + -- Other library packages from which modules are imported.+ build-depends: base >=4.7 && <4.8, json >=0.9 && <0.10+ + -- Directories containing source files.+ -- hs-source-dirs: + + -- Base language which the package is written in.+ default-language: Haskell2010++Test-Suite test-json-litobj+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: UnitTests.hs+ build-depends: base,+ hspec >= 1.3,+ QuickCheck >= 2.6,+ json >=0.9,+ json-litobj ++
+ tests/UnitTests.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main) where++{-Imports for testing-}+import Test.Hspec+import Test.QuickCheck++{-Basic libraries-}+import Control.Applicative ((<$>))+import Data.Char(isPrint)+import Data.Either++import Text.JSON (encode, decode, resultToEither)+import Text.JSON.Types (toJSObject, toJSString, JSValue(..), JSObject, JSString)++{-Modules to test-}+import Text.JSON.Permissive+++main :: IO ()+main = textJsonPermissive++textJsonPermissive :: IO ()+textJsonPermissive = hspec $+ describe "Text.JSON.Permissive" $ do+ it "should parse JSON objects with relaxed field syntax" $ do+ let nonstrict_json_string = "{ foo : \"bar\" }"+ json_object = toJSObject [("foo", JSString $ toJSString "bar")]+ either (\_ -> error "fail") + id + (resultToEither $ decodePermissive nonstrict_json_string) `shouldBe` json_object+ it "should parse JSON objects with relaxed and normal field syntax" $ do+ let mixed_json_string = "{ foo : \"bar\", \"fooz\" : \"baz\" }"+ json_object = toJSObject [("foo", JSString $ toJSString "bar"), ("fooz", JSString $ toJSString "baz")]+ either (\_ -> error "fail") + id + (resultToEither $ decodePermissive mixed_json_string) `shouldBe` json_object+ it "should parse JSON objects produced by Text.JSON.encode" $ do+ let json_object = toJSObject [("foo", JSString $ toJSString "bar"), ("fooz", JSString $ toJSString "baz")]+ json_object_string = encode json_object+ either (\_ -> error "fail") + id + (resultToEither $ decodePermissive json_object_string) `shouldBe` json_object+ it "should parse *all* JSON objects produced by Text.JSON.encode" $+ property $ + forAll jsonObject $ + \json_object -> + either (\s -> error $ "fail non-strict: " ++ show s ) + id + (resultToEither . decodePermissive $ encode json_object) `shouldBe` + either (\s -> error $ "fail conformant: " ++ s ) + id + (resultToEither . decode $ encode json_object) + it "should give access to all available fields of a JSON object" $ do+ let fields = either (\s -> error $ "failed to parse: " ++ show s ) + id + (resultToEither $ get_fields <$> decodePermissive "{ foo : \"bar\", fooz : \"baz\" }" )+ fields `shouldBe` ["foo", "fooz"]+++jsonObject :: Gen (JSObject JSValue)+jsonObject = do+ depth_bound <- choose(0,4)+ json_object_with_depth depth_bound++jsonValueWithDepth :: Int -> Gen JSValue+jsonValueWithDepth d = oneof [ fmap JSString json_string,+ JSObject <$> json_object_with_depth d,+ JSArray <$> json_array_with_depth d,+ elements [JSNull],+ fmap JSBool arbitrary,+ fmap (uncurry JSRational) arbitrary + ]++json_string :: Gen JSString+json_string = do+ l <- choose(0,10)+ fmap toJSString $ suchThat (vector l) $ all isPrint++json_object_with_depth :: Int -> Gen (JSObject JSValue)+json_object_with_depth d = do+ num_fields <- choose(0,4)+ strings <- vector num_fields+ values <- vectorOf num_fields $ jsonValueWithDepth (d-1)+ return $ toJSObject $ zip strings values++json_array_with_depth :: Int -> Gen [JSValue]+json_array_with_depth d = do+ l <- choose(0,4)+ vectorOf l $ jsonValueWithDepth (d-1)