From 3300b672cc6651c76c775a6874afb3c53b2d7902 Mon Sep 17 00:00:00 2001 From: Elliot Davies Date: Mon, 8 Oct 2018 17:06:47 +0100 Subject: [PATCH 1/6] Add encodeRecord --- src/Data/Argonaut/Encode/Class.purs | 33 +++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/src/Data/Argonaut/Encode/Class.purs b/src/Data/Argonaut/Encode/Class.purs index ba8fb4d..b72af38 100644 --- a/src/Data/Argonaut/Encode/Class.purs +++ b/src/Data/Argonaut/Encode/Class.purs @@ -11,8 +11,13 @@ import Data.Maybe (Maybe(..)) import Data.String (CodePoint) import Data.String.CodePoints as CP import Data.String.CodeUnits as CU +import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Tuple (Tuple(..)) import Foreign.Object as FO +import Prim.Row as Row +import Prim.RowList as RL +import Record as Record +import Type.Data.RowList (RLProxy(..)) class EncodeJson a where encodeJson :: a -> Json @@ -70,3 +75,31 @@ instance encodeMap :: (Ord a, EncodeJson a, EncodeJson b) => EncodeJson (M.Map a instance encodeVoid :: EncodeJson Void where encodeJson = absurd + +instance encodeRecord :: (GEncodeJson row list, RL.RowToList row list) => EncodeJson (Record row) where + encodeJson rec = fromObject $ gEncodeJson rec (RLProxy :: RLProxy list) + + +class GEncodeJson (row :: # Type) (list :: RL.RowList) where + gEncodeJson :: Record row -> RLProxy list -> FO.Object Json + +instance gEncodeJsonNil :: GEncodeJson row RL.Nil where + gEncodeJson _ _ = FO.empty + +instance gEncodeJsonCons + :: ( EncodeJson value + , GEncodeJson row tail + , IsSymbol field + , Row.Cons field value tail' row + ) + => GEncodeJson row (RL.Cons field value tail) where + + gEncodeJson row _ = + let + sProxy :: SProxy field + sProxy = SProxy + in + FO.insert + (reflectSymbol sProxy) + (encodeJson $ Record.get sProxy row) + (gEncodeJson row $ RLProxy :: RLProxy tail) \ No newline at end of file From 93485e15f3666e4d02e9b2625a3bd60c54536f89 Mon Sep 17 00:00:00 2001 From: Elliot Davies Date: Tue, 9 Oct 2018 17:53:54 +0100 Subject: [PATCH 2/6] Add generic JSON decoding --- src/Data/Argonaut/Decode/Class.purs | 43 +++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/src/Data/Argonaut/Decode/Class.purs b/src/Data/Argonaut/Decode/Class.purs index 398fe9a..89c4bf5 100644 --- a/src/Data/Argonaut/Decode/Class.purs +++ b/src/Data/Argonaut/Decode/Class.purs @@ -13,10 +13,15 @@ import Data.List (List(..), (:), fromFoldable) import Data.Map as M import Data.Maybe (maybe, Maybe(..)) import Data.String (CodePoint, codePointAt) +import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol) import Data.Traversable (traverse) import Data.TraversableWithIndex (traverseWithIndex) import Data.Tuple (Tuple(..)) import Foreign.Object as FO +import Prim.Row as Row +import Prim.RowList as RL +import Record as Record +import Type.Data.RowList (RLProxy(..)) class DecodeJson a where decodeJson :: Json -> Either String a @@ -98,3 +103,41 @@ decodeJArray = maybe (Left "Value is not an Array") Right <<< toArray decodeJObject :: Json -> Either String (FO.Object Json) decodeJObject = maybe (Left "Value is not an Object") Right <<< toObject + + +instance decodeRecord :: (GDecodeJson row list, RL.RowToList row list) => DecodeJson (Record row) where + decodeJson json = + case toObject json of + Just object -> gDecodeJson object (RLProxy :: RLProxy list) + Nothing -> Left "Could not convert JSON to object" + +class GDecodeJson (row :: # Type) (list :: RL.RowList) | list -> row where + gDecodeJson :: FO.Object Json -> RLProxy list -> Either String (Record row) + +instance gDecodeJsonNil :: GDecodeJson () RL.Nil where + gDecodeJson _ _ = Right {} + +instance gDecodeJsonCons + :: ( DecodeJson value + , GDecodeJson rowTail tail + , IsSymbol field + , Row.Cons field value rowTail row + , Row.Lacks field rowTail + ) + => GDecodeJson row (RL.Cons field value tail) where + + gDecodeJson object _ = do + let sProxy :: SProxy field + sProxy = SProxy + + fieldName = reflectSymbol sProxy + + rest <- gDecodeJson object (RLProxy :: RLProxy tail) + + case FO.lookup fieldName object of + Just jsonVal -> do + val <- decodeJson jsonVal + Right $ Record.insert sProxy val rest + + Nothing -> + Left $ "JSON was missing expected field: " <> fieldName \ No newline at end of file From 1538a1c6e118539fec81bafc116260c44443369d Mon Sep 17 00:00:00 2001 From: Elliot Davies Date: Tue, 9 Oct 2018 17:58:07 +0100 Subject: [PATCH 3/6] Export everything --- src/Data/Argonaut/Decode/Class.purs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Data/Argonaut/Decode/Class.purs b/src/Data/Argonaut/Decode/Class.purs index 89c4bf5..b6578ad 100644 --- a/src/Data/Argonaut/Decode/Class.purs +++ b/src/Data/Argonaut/Decode/Class.purs @@ -1,7 +1,4 @@ -module Data.Argonaut.Decode.Class - ( class DecodeJson - , decodeJson - ) where +module Data.Argonaut.Decode.Class where import Prelude From 2619e30c73e135692fea3d66dc4624770ab8bbe9 Mon Sep 17 00:00:00 2001 From: Elliot Davies Date: Wed, 7 Nov 2018 21:11:06 +0000 Subject: [PATCH 4/6] Formatting --- src/Data/Argonaut/Decode/Class.purs | 12 ++++++++---- src/Data/Argonaut/Encode/Class.purs | 12 ++++++++---- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/Data/Argonaut/Decode/Class.purs b/src/Data/Argonaut/Decode/Class.purs index b6578ad..03ca376 100644 --- a/src/Data/Argonaut/Decode/Class.purs +++ b/src/Data/Argonaut/Decode/Class.purs @@ -101,8 +101,12 @@ decodeJArray = maybe (Left "Value is not an Array") Right <<< toArray decodeJObject :: Json -> Either String (FO.Object Json) decodeJObject = maybe (Left "Value is not an Object") Right <<< toObject +instance decodeRecord + :: ( GDecodeJson row list + , RL.RowToList row list + ) + => DecodeJson (Record row) where -instance decodeRecord :: (GDecodeJson row list, RL.RowToList row list) => DecodeJson (Record row) where decodeJson json = case toObject json of Just object -> gDecodeJson object (RLProxy :: RLProxy list) @@ -122,13 +126,13 @@ instance gDecodeJsonCons , Row.Lacks field rowTail ) => GDecodeJson row (RL.Cons field value tail) where - + gDecodeJson object _ = do let sProxy :: SProxy field sProxy = SProxy fieldName = reflectSymbol sProxy - + rest <- gDecodeJson object (RLProxy :: RLProxy tail) case FO.lookup fieldName object of @@ -137,4 +141,4 @@ instance gDecodeJsonCons Right $ Record.insert sProxy val rest Nothing -> - Left $ "JSON was missing expected field: " <> fieldName \ No newline at end of file + Left $ "JSON was missing expected field: " <> fieldName diff --git a/src/Data/Argonaut/Encode/Class.purs b/src/Data/Argonaut/Encode/Class.purs index b72af38..d2ee94c 100644 --- a/src/Data/Argonaut/Encode/Class.purs +++ b/src/Data/Argonaut/Encode/Class.purs @@ -76,9 +76,13 @@ instance encodeMap :: (Ord a, EncodeJson a, EncodeJson b) => EncodeJson (M.Map a instance encodeVoid :: EncodeJson Void where encodeJson = absurd -instance encodeRecord :: (GEncodeJson row list, RL.RowToList row list) => EncodeJson (Record row) where - encodeJson rec = fromObject $ gEncodeJson rec (RLProxy :: RLProxy list) +instance encodeRecord + :: ( GEncodeJson row list + , RL.RowToList row list + ) + => EncodeJson (Record row) where + encodeJson rec = fromObject $ gEncodeJson rec (RLProxy :: RLProxy list) class GEncodeJson (row :: # Type) (list :: RL.RowList) where gEncodeJson :: Record row -> RLProxy list -> FO.Object Json @@ -93,7 +97,7 @@ instance gEncodeJsonCons , Row.Cons field value tail' row ) => GEncodeJson row (RL.Cons field value tail) where - + gEncodeJson row _ = let sProxy :: SProxy field @@ -102,4 +106,4 @@ instance gEncodeJsonCons FO.insert (reflectSymbol sProxy) (encodeJson $ Record.get sProxy row) - (gEncodeJson row $ RLProxy :: RLProxy tail) \ No newline at end of file + (gEncodeJson row $ RLProxy :: RLProxy tail) From 2b3133b382e579dacbc249fa78e2c9725988eb84 Mon Sep 17 00:00:00 2001 From: Elliot Davies Date: Wed, 7 Nov 2018 22:01:34 +0000 Subject: [PATCH 5/6] Add roundtrip record encoding tests --- test/Test/Main.purs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/test/Test/Main.purs b/test/Test/Main.purs index d9e9b94..339478f 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -17,19 +17,44 @@ import Data.Tuple (Tuple(..)) import Effect (Effect) import Foreign.Object as FO import Test.QuickCheck (Result(..), (), (===)) +import Test.QuickCheck.Arbitrary (arbitrary) import Test.QuickCheck.Gen (Gen, resize, suchThat) import Test.Unit (TestSuite, test, suite, failure) import Test.Unit.Assert as Assert import Test.Unit.Main (runTest) import Test.Unit.QuickCheck (quickCheck) + main :: Effect Unit main = runTest do suite "Either Check" eitherCheck suite "Encode/Decode Checks" encodeDecodeCheck + suite "Encode/Decode Record Checks" encodeDecodeRecordCheck suite "Combinators Checks" combinatorsCheck suite "Error Message Checks" errorMsgCheck + +genTestRecord + :: Gen (Record + ( i :: Int + , n :: Number + , s :: String + )) +genTestRecord = arbitrary + +encodeDecodeRecordCheck :: TestSuite +encodeDecodeRecordCheck = do + test "Testing that any record can be encoded and then decoded" do + quickCheck rec_encode_then_decode + + where + rec_encode_then_decode :: Gen Result + rec_encode_then_decode = do + rec <- genTestRecord + let redecoded = decodeJson (encodeJson rec) + pure $ Right rec == redecoded (show redecoded <> " /= Right " <> show rec) + + genTestJson :: Gen Json genTestJson = resize 5 genJson From 87eca09f2cbada4bff406d2bfe1ee752cb0c2bde Mon Sep 17 00:00:00 2001 From: Elliot Davies Date: Wed, 7 Nov 2018 22:05:59 +0000 Subject: [PATCH 6/6] Add purescript-record as direct dependency --- bower.json | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/bower.json b/bower.json index 11a7893..1ca578f 100644 --- a/bower.json +++ b/bower.json @@ -26,7 +26,8 @@ "purescript-integers": "^4.0.0", "purescript-maybe": "^4.0.0", "purescript-ordered-collections": "^1.0.0", - "purescript-foreign-object": "^1.0.0" + "purescript-foreign-object": "^1.0.0", + "purescript-record": "^1.0.0" }, "devDependencies": { "purescript-test-unit": "^14.0.0"