Merge pull request #9 from well-typed/erikd-master

 Support GHC 9.2/9.4 and bytesting 0.11

.github/workflows/ci.yml

@@ -0,0 +1,38 @@
+name: CI
+on:
+  push:
+    branches:
+      - master
+  pull_request:
+    types:
+      - opened
+      - synchronize
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        ghc: ["8.0.2", "8.2.2", "8.4.2", "8.6.5", "8.8.1", "8.10.7", "9.2.4"]
+    env:
+      CONFIG: "--enable-tests"
+    steps:
+      - uses: actions/checkout@v2
+      - name: "Setup haskell"
+        uses: haskell/actions/setup@v2
+        id: setup-haskell
+        with:
+          ghc-version: ${{ matrix.ghc }}
+          cabal-version: 3.6.2.0
+      - run: cabal update
+      - run: cabal freeze $CONFIG
+      - uses: actions/cache@v2
+        with:
+          path: ${{ steps.setup-haskell.outputs.cabal-store }}
+          key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+          restore-keys: |
+            ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+            ${{ runner.os }}-${{ matrix.ghc }}-
+      - run: cabal build $CONFIG
+      - run: cabal test $CONFIG
+      - run: cabal haddock $CONFIG
+      - run: cabal sdist

Text/JSON/Canonical/Parse.hs

@@ -232,7 +232,7 @@ digitToInt54 = fromIntegral . digitToInt
 
 manyN :: Int -> Parser a -> Parser [a]
 manyN 0 _ =  pure []
-manyN n p =  ((:) <$> p <*> manyN (n-1) p)
+manyN n p =  ((:) <$> p <*> manyN (n - 1) p)
          <|> pure []
 
 ------------------------------------------------------------------------------

Text/JSON/Canonical/Types.hs

@@ -26,7 +26,7 @@ import Data.Ix (Ix)
 #if !MIN_VERSION_base(4,8,0)
 import Data.Monoid (Monoid)
 #endif
-#if MIN_VERSION_base(4,9,0)
+#if (MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0))
 import Data.Semigroup (Semigroup)
 #endif
 import Data.Typeable (Typeable)

cabal.project

@@ -0,0 +1,6 @@
+packages: canonical-json.cabal
+
+package canonical-json
+  tests: True
+
+test-show-details: direct

canonical-json.cabal

@@ -41,7 +41,7 @@ library
                        MultiParamTypeClasses, FlexibleInstances,
                        ScopedTypeVariables, OverlappingInstances
   build-depends:       base              >= 4.5     && < 5,
-                       bytestring        >= 0.10.4  && < 0.11,
+                       bytestring        >= 0.10.4  && < 0.12,
                        containers        >= 0.4     && < 0.7,
                        deepseq           >= 1.2     && < 1.5,
                        parsec            >= 3.1     && < 3.2,
@@ -57,10 +57,10 @@ test-suite tests
                        bytestring,
                        canonical-json,
                        containers,
-                       aeson             == 1.4.*,
+                       aeson             >= 1.4     && < 2.2,
                        vector,
                        unordered-containers,
-                       QuickCheck        >= 2.11    && < 2.13,
+                       QuickCheck        >= 2.11    && < 2.16,
                        tasty,
                        tasty-quickcheck
   default-language:    Haskell2010

tests/TestSuite.hs

@@ -14,10 +14,14 @@ import Control.Applicative (Applicative(..), (<$>))
 #endif
 
 import qualified Data.Aeson as Aeson (Value (..), eitherDecode)
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as KeyMap (fromList)
+#else
+import qualified Data.HashMap.Strict as KeyMap (fromList)
+#endif
 import           Data.String (IsString, fromString)
 import qualified Data.Map            as Map
 import qualified Data.Vector         as V  (fromList)
-import qualified Data.HashMap.Strict as HM (fromList)
 
 import           Test.QuickCheck
 import           Test.Tasty.QuickCheck (testProperty)
@@ -63,7 +67,9 @@ prop_canonical_pretty jsval =
     fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)))
 
 prop_aeson_canonical jsval =
-    Aeson.eitherDecode (renderCanonicalJSON jsval) == Right (toAeson jsval)
+    Aeson.eitherDecode (renderCanonicalJSON jsval') == Right (toAeson jsval')
+  where
+    jsval' = omitNonPrintableChars jsval
 
 prop_toJSON_fromJSON :: (Monad m, ToJSON m a, FromJSON m a, Eq a) => a -> m Bool
 prop_toJSON_fromJSON x =
@@ -117,12 +123,43 @@ toAeson (JSBool b)    = Aeson.Bool b
 toAeson (JSNum n)     = Aeson.Number (fromIntegral n)
 toAeson (JSString s)  = Aeson.String (toAesonStr s)
 toAeson (JSArray xs)  = Aeson.Array  $ V.fromList  [ toAeson x | x <- xs ]
-toAeson (JSObject xs) = Aeson.Object $ HM.fromList [ (toAesonStr k, toAeson v)
-                                                   | (k, v) <- xs ]
+toAeson (JSObject xs) = Aeson.Object $ KeyMap.fromList [ (toAesonStr k, toAeson v)
+                                                       | (k, v) <- xs ]
 
 toAesonStr :: IsString s => JSString -> s
 toAesonStr = fromString . fromJSString
 
+-- | As discussed in the haddock docs for 'renderCanonicalJSON', Canonical
+-- JSON is /not/ a proper subset of RFC 7159.
+--
+-- So for the property 'prop_aeson_canonical', where we check that everything
+-- produced as canoncal JSON can be parsed by Aeson (which we assume correctly
+-- implements RFC 7159), we have to tweak things to keep us within the common
+-- subset of canoncal JSON and RFC 7159. Specifically, canoncal JSON only
+-- escapes \ and ", and does not escape any other non-printable characters.
+--
+-- So the tweak is to just omit non-printable characters from all strings.
+--
+omitNonPrintableChars :: JSValue -> JSValue
+omitNonPrintableChars = omitJSValue
+  where
+    omitJSValue v@JSNull        = v
+    omitJSValue v@(JSBool    _) = v
+    omitJSValue v@(JSNum     _) = v
+    omitJSValue   (JSString  s) = JSString (omitJSString s)
+    omitJSValue   (JSArray  vs) = JSArray  [ omitJSValue v | v <- vs]
+    omitJSValue   (JSObject vs) = JSObject $ omitDupKeys
+                                           [ (omitJSString k, omitJSValue v)
+                                           | (k,v) <- vs ]
+
+    omitDupKeys :: [(JSString, JSValue)] -> [(JSString, JSValue)]
+    omitDupKeys = nubBy (\a b -> fst a == fst b)
+
+    omitJSString :: JSString -> JSString
+    omitJSString = toJSString
+                 . filter (\c -> c >= ' ')
+                 . fromJSString
+
 instance Arbitrary JSValue where
   arbitrary =
     sized $ \sz ->
@@ -161,5 +198,6 @@ instance Arbitrary Int54 where
 
 instance Arbitrary JSString where
   arbitrary = toJSString . getASCIIString <$> arbitrary
-  shrink  s = [ toJSString s' | s' <- shrink (fromJSString s) ]
+  shrink  s = [ toJSString s' | s' <- shrink (fromJSString s)
+                              , all (\c -> c >= ' ') s' ]