Merge pull request #26 from dgendill/master

Instances for NonEmpty Array and NonEmpty List

Author: thomashoneyman

bower.json

@@ -27,7 +27,9 @@
     "purescript-maybe": "^4.0.0",
     "purescript-ordered-collections": "^1.0.0",
     "purescript-foreign-object": "^1.0.0",
-    "purescript-record": "^1.0.0"
+    "purescript-record": "^1.0.0",
+    "purescript-nonempty": "^5.0.0",
+    "purescript-arrays": "^5.1.0"
   },
   "devDependencies": {
     "purescript-test-unit": "^14.0.0"

src/Data/Argonaut/Decode/Class.purs

@@ -2,13 +2,17 @@ module Data.Argonaut.Decode.Class where
 
 import Prelude
 
+import Control.Alternative (class Plus)
 import Data.Argonaut.Core (Json, isNull, caseJsonNull, caseJsonBoolean, caseJsonNumber, caseJsonString, toArray, toObject, toString, stringify)
-import Data.Bifunctor (lmap)
-import Data.Either (Either(..))
+import Data.Array as Arr
+import Data.Bifunctor (lmap, rmap)
+import Data.Either (Either(..), note)
 import Data.Int (fromNumber)
 import Data.List (List(..), (:), fromFoldable)
+import Data.List as L
 import Data.Map as M
 import Data.Maybe (maybe, Maybe(..))
+import Data.NonEmpty (NonEmpty, singleton, (:|))
 import Data.String (CodePoint, codePointAt)
 import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
 import Data.Traversable (traverse)
@@ -66,6 +70,16 @@ instance decodeJsonString :: DecodeJson String where
 instance decodeJsonJson :: DecodeJson Json where
   decodeJson = Right
 
+instance decodeJsonNonEmptyArray :: (DecodeJson a) => DecodeJson (NonEmpty Array a) where
+  decodeJson
+    = lmap ("Couldn't decode NonEmpty Array: " <> _)
+    <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> x.head :| x.tail) <<< note " is empty" <<< Arr.uncons) <=< decodeJArray)
+
+instance decodeJsonNonEmptyList :: (DecodeJson a) => DecodeJson (NonEmpty List a) where
+  decodeJson
+    = lmap ("Couldn't decode NonEmpty List: " <> _)
+    <<< (traverse decodeJson <=< (lmap ("JSON Array" <> _) <<< rmap (\x -> x.head :| x.tail) <<< note " is empty" <<< L.uncons) <=< map (map fromFoldable) decodeJArray)
+
 instance decodeJsonChar :: DecodeJson CodePoint where
   decodeJson j =
     maybe (Left $ "Expected character but found: " <> stringify j) Right

src/Data/Argonaut/Encode/Class.purs

@@ -3,11 +3,14 @@ module Data.Argonaut.Encode.Class where
 import Prelude
 
 import Data.Argonaut.Core (Json, fromArray, fromBoolean, fromNumber, fromObject, fromString, jsonNull)
+import Data.Array as Arr
 import Data.Either (Either, either)
 import Data.Int (toNumber)
 import Data.List (List(..), (:), toUnfoldable)
+import Data.List as L
 import Data.Map as M
 import Data.Maybe (Maybe(..))
+import Data.NonEmpty (NonEmpty(..))
 import Data.String (CodePoint)
 import Data.String.CodePoints as CP
 import Data.String.CodeUnits as CU
@@ -58,6 +61,12 @@ instance encodeJsonJson :: EncodeJson Json where
 instance encodeJsonCodePoint :: EncodeJson CodePoint where
   encodeJson = encodeJson <<< CP.singleton
 
+instance encodeJsonNonEmptyArray :: (EncodeJson a) => EncodeJson (NonEmpty Array a) where
+  encodeJson (NonEmpty h t) = encodeJson $ Arr.cons h t
+
+instance encodeJsonNonEmptyList :: (EncodeJson a) => EncodeJson (NonEmpty List a) where
+  encodeJson (NonEmpty h t) = encodeJson $ L.insertAt 0 h t
+
 instance encodeJsonChar :: EncodeJson Char where
   encodeJson = encodeJson <<< CU.singleton
 

test/Test/Main.purs

@@ -11,7 +11,9 @@ import Data.Argonaut.Parser (jsonParser)
 import Data.Bifunctor (rmap)
 import Data.Either (Either(..))
 import Data.Foldable (foldl)
+import Data.List (List)
 import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
+import Data.NonEmpty (NonEmpty)
 import Data.String.Gen (genUnicodeString)
 import Data.Tuple (Tuple(..))
 import Effect (Effect)
@@ -28,6 +30,7 @@ import Test.Unit.QuickCheck (quickCheck)
 main :: Effect Unit
 main = runTest do
   suite "Either Check" eitherCheck
+  suite "Encode/Decode NonEmpty Check" nonEmptyCheck
   suite "Encode/Decode Checks" encodeDecodeCheck
   suite "Encode/Decode Record Checks" encodeDecodeRecordCheck
   suite "Combinators Checks" combinatorsCheck
@@ -157,6 +160,25 @@ eitherCheck = do
         Left err ->
           false <?> err
 
+nonEmptyCheck :: TestSuite
+nonEmptyCheck = do
+  test "Test EncodeJson/DecodeJson on NonEmpty Array" do
+    quickCheck \(x :: NonEmpty Array String) ->
+      case decodeJson (encodeJson x) of
+        Right decoded ->
+          decoded == x
+            <?> ("x = " <> show x <> ", decoded = " <> show decoded)
+        Left err ->
+          false <?> err
+  test "Test EncodeJson/DecodeJson on NonEmpty List" do
+    quickCheck \(x :: NonEmpty List String) ->
+      case decodeJson (encodeJson x) of
+        Right decoded ->
+          decoded == x
+            <?> ("x = " <> show x <> ", decoded = " <> show decoded)
+        Left err ->
+          false <?> err
+
 errorMsgCheck :: TestSuite
 errorMsgCheck = do
   test "Test that decoding array fails with the proper message" do