List instance

Data/Aeson/Types/Class.hs

@@ -29,10 +29,18 @@ module Data.Aeson.Types.Class
     , typeMismatch
     ) where
 
+import Data.Aeson.Encode.Builder
 import Data.Aeson.Types.Internal
+import Data.Monoid ((<>))
 import Data.Text (Text)
 import GHC.Generics (Generic, Rep, from, to)
 import qualified Data.Aeson.Encode.Builder as E
+import qualified Data.ByteString.Builder as B
+import qualified Data.Vector as V
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid (mempty)
+#endif
 
 -- | Class of generic representation types ('Rep') that can be converted to
 -- JSON.
@@ -165,6 +173,19 @@ class ToJSON a where
     toEncoding = Encoding . E.encodeToBuilder . toJSON
     {-# INLINE toEncoding #-}
 
+    toJSONList :: [a] -> Value
+    toJSONList = Array . V.fromList . map toJSON
+    {-# INLINE toJSONList #-}
+
+    toEncodingList :: [a] -> Encoding
+    toEncodingList [] = emptyArray_
+    toEncodingList (x:xs) = Encoding $
+        B.char7 '[' <> builder x <> commas xs <> B.char7 ']'
+      where
+        commas  = foldr (\v vs -> B.char7 ',' <> builder v <> vs) mempty
+        builder = fromEncoding . toEncoding
+    {-# INLINE toEncodingList #-}
+
 -- | A type that can be converted from JSON, with the possibility of
 -- failure.
 --
@@ -245,6 +266,19 @@ class FromJSON a where
     default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
     parseJSON = genericParseJSON defaultOptions
 
+    parseJSONList :: Value -> Parser [a]
+    parseJSONList (Array a)
+        = sequence
+        . zipWith parseIndexedJSON [0..]
+        . V.toList
+        $ a
+      where
+        parseIndexedJSON :: FromJSON a => Int -> Value -> Parser a
+        parseIndexedJSON idx value = parseJSON value <?> Index idx
+
+    parseJSONList v = typeMismatch "[a]" v
+
+
 -- | A key-value pair for encoding a JSON object.
 class KeyValue kv where
     (.=) :: ToJSON v => Text -> v -> kv

Data/Aeson/Types/Instances.hs

@@ -4,9 +4,6 @@
     ViewPatterns #-}
 {-# LANGUAGE DefaultSignatures #-}
 
-#define NEEDS_INCOHERENT
-#include "overlapping-compat.h"
-
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- TODO: Drop this when we remove support for Data.Attoparsec.Number
@@ -62,7 +59,7 @@ module Data.Aeson.Types.Instances
     ) where
 
 import Control.Applicative (Const(..))
-import Data.Aeson.Encode.Functions (brackets, builder, encode, foldable, list)
+import Data.Aeson.Encode.Functions (brackets, builder, encode, foldable)
 import Data.Aeson.Functions (hashMapKey, mapHashKeyVal, mapKey, mapKeyVal)
 import Data.Aeson.Types.Class
 import Data.Aeson.Types.Internal
@@ -92,6 +89,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 import Foreign.Storable (Storable)
 import Numeric.Natural (Natural)
 import Prelude hiding (foldr)
+import qualified Prelude
 import qualified Data.Aeson.Encode.Builder as E
 import qualified Data.Aeson.Parser.Time as Time
 import qualified Data.ByteString.Builder as B
@@ -224,31 +222,29 @@ instance FromJSON () where
                     else fail "Expected an empty array"
     {-# INLINE parseJSON #-}
 
-instance INCOHERENT_ ToJSON [Char] where
-    toJSON = String . T.pack
-    {-# INLINE toJSON #-}
-
-    toEncoding = Encoding . E.string
-    {-# INLINE toEncoding #-}
-
-instance INCOHERENT_ FromJSON [Char] where
-    parseJSON = withText "String" $ pure . T.unpack
-    {-# INLINE parseJSON #-}
-
 instance ToJSON Char where
     toJSON = String . T.singleton
     {-# INLINE toJSON #-}
 
+    toJSONList = String . T.pack
+    {-# INLINE toJSONList #-}
+
     toEncoding = Encoding . E.string . (:[])
     {-# INLINE toEncoding #-}
 
+    toEncodingList = Encoding . E.string
+    {-# INLINE toEncodingList #-}
+
 instance FromJSON Char where
     parseJSON = withText "Char" $ \t ->
                   if T.compareLength t 1 == EQ
                     then pure $ T.head t
                     else fail "Expected a string of length 1"
     {-# INLINE parseJSON #-}
 
+    parseJSONList = withText "String" $ pure . T.unpack
+    {-# INLINE parseJSONList #-}
+
 instance ToJSON Scientific where
     toJSON = Number
     {-# INLINE toJSON #-}
@@ -493,10 +489,13 @@ instance FromJSON LT.Text where
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a) => ToJSON (NonEmpty a) where
-    toJSON = toJSON . toList
+    toJSON = Array . V.fromList . map toJSON . toList
     {-# INLINE toJSON #-}
 
-    toEncoding = toEncoding . toList
+    toEncoding (x :| xs) = Encoding $
+        B.char7 '[' <> builder x <> commas xs <> B.char7 ']'
+      where
+        commas  = Prelude.foldr (\v vs -> B.char7 ',' <> builder v <> vs) mempty
     {-# INLINE toEncoding #-}
 
 instance (FromJSON a) => FromJSON (NonEmpty a) where
@@ -506,16 +505,15 @@ instance (FromJSON a) => FromJSON (NonEmpty a) where
         ne []     = fail "Expected a NonEmpty but got an empty list"
         ne (x:xs) = pure (x :| xs)
 
-instance OVERLAPPABLE_ (ToJSON a) => ToJSON [a] where
-    toJSON = Array . V.fromList . map toJSON
+instance (ToJSON a) => ToJSON [a] where
+    toJSON = toJSONList
     {-# INLINE toJSON #-}
 
-    toEncoding xs = list xs
+    toEncoding = toEncodingList
     {-# INLINE toEncoding #-}
 
-instance OVERLAPPABLE_ (FromJSON a) => FromJSON [a] where
-    parseJSON = withArray "[a]" $ Tr.sequence .
-                zipWith parseIndexedJSON [0..] . V.toList
+instance (FromJSON a) => FromJSON [a] where
+    parseJSON = parseJSONList
     {-# INLINE parseJSON #-}
 
 instance (ToJSON a) => ToJSON (Seq.Seq a) where

tests/UnitTests.hs

@@ -286,8 +286,8 @@ overlappingRegression bs = fromMaybe [] $ decode bs
 issue351 :: [Assertion]
 issue351 = [
     assertEqual "Int"  ([1, 2, 3] :: [Int])  $ overlappingRegression "[1, 2, 3]"
-  , assertEqual "Char" (""        :: String) $ overlappingRegression "\"abc\""
-  , assertEqual "Char" ("abc"     :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]"
+  , assertEqual "Char" ("abc"     :: String) $ overlappingRegression "\"abc\""
+  , assertEqual "Char" (""        :: String) $ overlappingRegression "[\"a\", \"b\", \"c\"]"
   ]
 
 ------------------------------------------------------------------------------