Made json encoding/decoding configurable + Aeson compatible encoding/decoding

bower.json

@@ -24,9 +24,11 @@
   "dependencies": {
     "purescript-argonaut-core": "^0.2.0",
     "purescript-generics": "^0.7.0",
-    "purescript-integers": "^0.2.1"
+    "purescript-integers": "^0.2.1",
+    "purescript-partial": "^1.1.0"
   },
   "devDependencies": {
-    "purescript-strongcheck-generics": "^0.3.0"
+    "purescript-strongcheck-generics": "^0.3.0",
+    "purescript-assert": "~0.1.1"
   }
 }

package.json

@@ -8,7 +8,7 @@
   },
   "devDependencies": {
     "pulp": "^7.0.0",
-    "purescript": "^0.7.6",
+    "purescript": "^0.8.0",
     "rimraf": "^2.4.4"
   }
 }

src/Data/Argonaut/Aeson.purs

@@ -0,0 +1,180 @@
+-- Haskell Aeson compatible encoding/decoding:
+
+module Data.Argonaut.Aeson
+  ( gAesonEncodeJson
+  , gAesonDecodeJson
+  , aesonOptions
+  , aesonUserEncoding
+  , aesonUserDecoding
+  ) where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Argonaut.Core (Json(), jsonNull, fromBoolean, fromNumber, fromString, fromArray, fromObject, JArray, jsonNull, isNull, toObject, toArray)
+import Data.Argonaut.Options
+import Data.Argonaut.Encode
+import Data.Argonaut.Decode hiding (decodeMaybe)
+import Data.Either (Either(), either)
+import Data.Foldable (foldr)
+import Data.Generic (Generic, GenericSpine(..), toSpine, GenericSignature(..), DataConstructor(), toSignature)
+import Data.Int (toNumber)
+import Data.List (List(..), fromList)
+import Data.List as L
+import Data.Map as M
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.String (fromChar)
+import Data.StrMap as SM
+import Data.Traversable (sequence)
+import Data.Tuple (Tuple(..))
+import Type.Proxy (Proxy(..))
+import Data.Tuple (uncurry)
+import Data.Array (length, concatMap, filter, zip, zipWith)
+import qualified Data.Array.Unsafe as Unsafe
+import Partial.Unsafe (unsafeCrashWith)
+
+
+-- | Options for aeson compatible encoding/decoding.
+aesonOptions :: Options
+aesonOptions = Options {
+  constructorTagModifier : stripModulePath
+, allNullaryToStringTag  : true
+, sumEncoding            : aesonSumEncoding
+, flattenContentsArray   : true
+, unwrapUnaryRecords     : true
+, userEncoding           : aesonUserEncoding
+, userDecoding           : aesonUserDecoding
+}
+
+aesonSumEncoding :: SumEncoding
+aesonSumEncoding = TaggedObject {
+  tagFieldName           : "tag"
+, contentsFieldName      : "contents"
+}
+
+-- | Encode `Json` representation of a value which has a `Generic` type
+-- | with Aeson options. The encoded data will be compatible with Haskell Aeson,
+-- | if Aeson default options are used.
+gAesonEncodeJson :: forall a. (Generic a) => a -> Json
+gAesonEncodeJson = genericEncodeJson aesonOptions
+
+-- | Decode `Json` representation of a value which has a `Generic` type
+-- | with Aeson options. Data from Haskell, with Aeson default options can be
+-- | decoded with gAesonDecodJson.
+gAesonDecodeJson :: forall a. (Generic a) => Json -> Either String a
+gAesonDecodeJson = genericDecodeJson aesonOptions
+
+
+aesonUserEncoding :: Options -> GenericSignature -> GenericSpine -> Maybe Json
+aesonUserEncoding opts sig spine = encodeMaybe opts sig spine
+                               <|> encodeEither opts sig spine
+                               <|> fromArray <$> encodeTuple opts sig spine
+
+aesonUserDecoding :: Options -> GenericSignature -> Json -> Maybe (Either String GenericSpine)
+aesonUserDecoding opts sig json = decodeMaybe opts sig json
+                              <|> decodeEither opts sig json
+                              <|> decodeTuple opts sig json
+
+
+encodeMaybe :: Options -> GenericSignature -> GenericSpine -> Maybe Json
+encodeMaybe opts (SigProd "Data.Maybe.Maybe" sigArr) (SProd "Data.Maybe.Just" [elem]) =
+    return $ genericUserEncodeJson' opts valSig val
+  where
+    valSig = getSigFromUnaryConstructor sigArr "Data.Maybe.Just"
+    val = elem unit
+
+encodeMaybe opts (SigProd "Data.Maybe.Maybe" _) (SProd "Data.Maybe.Nothing" _) =
+    return jsonNull
+encodeMaybe _ _ _ = Nothing
+
+decodeMaybe :: Options -> GenericSignature -> Json -> Maybe (Either String GenericSpine)
+decodeMaybe opts (SigProd "Data.Maybe.Maybe" sigArr) json =
+  if isNull json
+    then return $ Right $ SProd "Data.Maybe.Nothing" []
+    else return $ do
+      let valSig = getSigFromUnaryConstructor sigArr "Data.Maybe.Just"
+      decoded <- genericUserDecodeJson' opts valSig json
+      return $ SProd "Data.Maybe.Just" [\u -> decoded ]
+decodeMaybe _ _ _ = Nothing
+
+encodeEither :: Options -> GenericSignature -> GenericSpine -> Maybe Json
+encodeEither opts (SigProd "Data.Either.Either" sigArr) (SProd eitherConstr [elem]) =
+    return
+      $ fromObject $ SM.fromList
+      $ Tuple strippedConstr (genericUserEncodeJson' opts valSig val) `Cons` Nil
+  where
+    strippedConstr = stripModulePath eitherConstr
+    valSig = getSigFromUnaryConstructor sigArr eitherConstr
+    val = elem unit
+encodeEither _ _ _ = Nothing
+
+decodeEither :: Options -> GenericSignature -> Json -> Maybe (Either String GenericSpine)
+decodeEither opts (SigProd "Data.Either.Either" sigArr) json = return $ do
+    obj <- mFail "Expeced an object when decoding Either" $ toObject json
+    fromMaybe (Left "Expected Left or Right record label when decoding Either")
+      $ decodeArg "Right" obj <|> decodeArg "Left" obj
+  where
+    decodeArg name obj = do
+      argJson <- SM.lookup name obj
+      let valSig = getSigFromUnaryConstructor sigArr $ "Data.Either." <> name
+      return $ do
+        decoded <- genericUserDecodeJson' opts valSig argJson
+        return $ SProd ("Data.Either." <> name) [\u -> decoded]
+decodeEither _ _ _ = Nothing
+
+encodeTuple :: Options -> GenericSignature ->  GenericSpine -> Maybe JArray
+encodeTuple opts (SigProd "Data.Tuple.Tuple" sigArr) (SProd "Data.Tuple.Tuple" arr) =
+    append
+      <$> encodeTuple opts (Unsafe.head signatures) (Unsafe.head spines)
+      <*> encodeTupleArgs opts (Unsafe.tail signatures) (Unsafe.tail spines)
+  <|>
+    encodeTupleArgs opts signatures spines -- Or just encode arguments
+  where
+    signatures = getSigsFromConstructor sigArr "Data.Tuple.Tuple"
+    spines = map ($ unit) arr
+encodeTuple _ _ _ = Nothing
+
+decodeTuple :: Options -> GenericSignature -> Json -> Maybe (Either String GenericSpine)
+decodeTuple opts (SigProd "Data.Tuple.Tuple" sigArr) json = return $ do
+    jsonVals <- mFail "Expected an array of values when decoding Tuple" $ toArray json
+    let sigs = getNestedTupleSigs $ getSigsFromConstructor sigArr "Data.Tuple.Tuple"
+    decoded <- sequence $ L.zipWith (genericUserDecodeJson' opts) sigs (arrToList jsonVals)
+    makeTuples decoded
+  where
+    makeTuple x1 x2 = SProd "Data.Tuple.Tuple" [\_ -> x1, \_ -> x2]
+
+    makeTuples (Cons x1 (Cons x2 xs)) = return $ makeTuples' (makeTuple x1 x2) xs
+    makeTuples _ = Left "A tuple needs to have at least two elements"
+
+    makeTuples' inner Nil = inner
+    makeTuples' inner (Cons x1 xs) = makeTuples' (makeTuple inner x1) xs
+
+
+decodeTuple _ _ _ = Nothing
+
+encodeTupleArgs :: Options -> Array GenericSignature -> Array GenericSpine -> Maybe JArray
+encodeTupleArgs opts sigs arr = return $ zipWith (genericUserEncodeJson' opts) sigs arr
+
+
+getSigFromUnaryConstructor :: Array DataConstructor -> String -> GenericSignature
+getSigFromUnaryConstructor arr name = Unsafe.head $ getSigsFromConstructor arr name
+
+getSigsFromConstructor :: Array DataConstructor -> String -> Array GenericSignature
+getSigsFromConstructor arr name =
+  let
+    constr = Unsafe.head <<< filter ((== name) <<< _.sigConstructor) $ arr
+  in
+    map ($ unit) constr.sigValues
+
+getNestedTupleSigs :: Array GenericSignature -> List GenericSignature
+getNestedTupleSigs = L.reverse <<< getNestedTupleSigs'
+
+-- Get signatures in reverse order:
+getNestedTupleSigs' :: Array GenericSignature -> List GenericSignature
+getNestedTupleSigs' [val1, val2] = case val1 of
+  SigProd "Data.Tuple.Tuple" cVals -> val2 `Cons` getNestedTupleSigs' (getSigsFromConstructor cVals "Data.Tuple.Tuple")
+  _                                -> Cons val2 (Cons val1 Nil)
+
+arrToList :: forall a. Array a -> List a
+arrToList = foldr Cons Nil

src/Data/Argonaut/Decode.purs

@@ -2,68 +2,113 @@ module Data.Argonaut.Decode
   ( DecodeJson
   , decodeJson
   , gDecodeJson
-  , gDecodeJson'
+  , genericDecodeJson
+  , genericDecodeJson'
+  , genericUserDecodeJson'
   , decodeMaybe
+  , module Data.Argonaut.Options
+  , mFail
   ) where
 
 import Prelude
 
 import Control.Alt ((<|>))
 import Control.Bind ((=<<))
 import Data.Argonaut.Core (Json(), isNull, foldJsonNull, foldJsonBoolean, foldJsonNumber, foldJsonString, toArray, toNumber, toObject, toString, toBoolean)
-import Data.Array (zipWithA)
+import Data.Argonaut.Options
+import Data.Array (zipWithA, length)
 import Data.Either (either, Either(..))
 import Data.Foldable (find)
-import Data.Generic (Generic, GenericSpine(..), GenericSignature(..), fromSpine, toSignature)
+import Data.Generic (Generic, GenericSpine(..), GenericSignature(..), DataConstructor(), fromSpine, toSignature)
 import Data.Int (fromNumber)
 import Data.List (List(..), toList)
 import Data.Map as Map
-import Data.Maybe (maybe, Maybe(..))
+import Data.Maybe (maybe, Maybe(..), fromMaybe)
 import Data.String (charAt, toChar)
 import Data.StrMap as M
 import Data.Traversable (traverse, for)
 import Data.Tuple (Tuple(..))
+import Partial.Unsafe (unsafeCrashWith)
 import Type.Proxy (Proxy(..))
+import qualified Data.Array.Unsafe as Unsafe
 
 class DecodeJson a where
   decodeJson :: Json -> Either String a
 
--- | Decode `Json` representation of a value which has a `Generic` type.
+-- | Decode `Json` representation of a value which has a `Generic` type
+-- | with Argonaut options.
 gDecodeJson :: forall a. (Generic a) => Json -> Either String a
-gDecodeJson json = maybe (Left "fromSpine failed") Right <<< fromSpine
-                 =<< gDecodeJson' (toSignature (Proxy :: Proxy a)) json
+gDecodeJson = genericDecodeJson argonautOptions
+
+-- | Decode `Json` representation of a value which has a `Generic` type.
+genericDecodeJson :: forall a. (Generic a) => Options -> Json -> Either String a
+genericDecodeJson opts json = maybe (Left "fromSpine failed") Right <<< fromSpine
+                =<< genericUserDecodeJson' opts (toSignature (Proxy :: Proxy a)) json
+
+
+-- | Generically encode to json, using a supplied userEncoding, falling back to genericEncodeJson':
+genericUserDecodeJson' :: Options -> GenericSignature -> Json -> Either String GenericSpine
+genericUserDecodeJson' opts'@(Options opts) sign json = fromMaybe (genericDecodeJson' opts' sign json)
+                                                        (opts.userDecoding opts' sign json)
+
 
 -- | Decode `Json` representation of a `GenericSpine`.
-gDecodeJson' :: GenericSignature -> Json -> Either String GenericSpine
-gDecodeJson' signature json = case signature of
-  SigNumber -> SNumber <$> mFail "Expected a number" (toNumber json)
-  SigInt -> SInt <$> mFail "Expected an integer number" (fromNumber =<< toNumber json)
-  SigString -> SString <$> mFail "Expected a string" (toString json)
-  SigChar -> SChar <$> mFail "Expected a char" (toChar =<< toString json)
-  SigBoolean -> SBoolean <$> mFail "Expected a boolean" (toBoolean json)
-  SigArray thunk -> do
-    jArr <- mFail "Expected an array" $ toArray json
-    SArray <$> traverse (map const <<< gDecodeJson' (thunk unit)) jArr
-  SigRecord props -> do
-    jObj <- mFail "Expected an object" $ toObject json
-    SRecord <$> for props \({recLabel: lbl, recValue: val}) -> do
-      pf <- mFail ("'" <> lbl <> "' property missing") (M.lookup lbl jObj)
-      sp <- gDecodeJson' (val unit) pf
-      pure { recLabel: lbl, recValue: const sp }
-  SigProd typeConstr alts -> do
-    let decodingErr msg = "When decoding a " ++ typeConstr ++ ": " ++ msg
-    jObj <- mFail (decodingErr "expected an object") (toObject json)
-    tagJson  <- mFail (decodingErr "'tag' property is missing") (M.lookup "tag" jObj)
-    tag <- mFail (decodingErr "'tag' property is not a string") (toString tagJson)
-    case find ((tag ==) <<< _.sigConstructor) alts of
-      Nothing -> Left (decodingErr ("'" <> tag <> "' isn't a valid constructor"))
-      Just { sigValues: sigValues } -> do
-        vals <- mFail (decodingErr "'values' array is missing") (toArray =<< M.lookup "values" jObj)
-        sps  <- zipWithA (\k -> gDecodeJson' (k unit)) sigValues vals
-        pure (SProd tag (const <$> sps))
+genericDecodeJson' :: Options -> GenericSignature -> Json -> Either String GenericSpine
+genericDecodeJson' opts signature json = case signature of
+ SigNumber -> SNumber <$> mFail "Expected a number" (toNumber json)
+ SigInt -> SInt <$> mFail "Expected an integer number" (fromNumber =<< toNumber json)
+ SigString -> SString <$> mFail "Expected a string" (toString json)
+ SigChar -> SChar <$> mFail "Expected a char" (toChar =<< toString json)
+ SigBoolean -> SBoolean <$> mFail "Expected a boolean" (toBoolean json)
+ SigArray thunk -> do
+   jArr <- mFail "Expected an array" $ toArray json
+   SArray <$> traverse (map const <<< genericUserDecodeJson' opts (thunk unit)) jArr
+ SigRecord props -> do
+   jObj <- mFail "Expected an object" $ toObject json
+   SRecord <$> for props \({recLabel: lbl, recValue: val}) -> do
+     pf <- mFail ("'" <> lbl <> "' property missing") (M.lookup lbl jObj)
+     sp <- genericUserDecodeJson' opts (val unit) pf
+     pure { recLabel: lbl, recValue: const sp }
+ SigProd typeConstr constrSigns -> genericDecodeProdJson' opts typeConstr constrSigns json
+
+genericDecodeProdJson' :: Options ->  String -> Array DataConstructor -> Json -> Either String GenericSpine
+genericDecodeProdJson' opts'@(Options opts) tname constrSigns json =
+  if opts.unwrapUnaryRecords && isUnaryRecord constrSigns
+  then do
+    let constr = Unsafe.head constrSigns
+    let unwrapped = Unsafe.head constr.sigValues unit
+    r <- genericUserDecodeJson' opts' unwrapped json
+    pure (SProd constr.sigConstructor [const r])
+  else
+    if opts.allNullaryToStringTag && allConstructorsNullary constrSigns
+    then decodeFromString
+    else decodeTagged
   where
-  mFail :: forall a. String -> Maybe a -> Either String a
-  mFail msg = maybe (Left msg) Right
+    decodeFromString = do
+      tag <- mFail (decodingErr "Constructor name as string expected") (toString json)
+      foundConstr <- findConstrFail tag
+      pure (SProd foundConstr.sigConstructor [])
+    decodeTagged = do
+      jObj <- mFail (decodingErr "expected an object") (toObject json)
+      tagJson  <- mFail (decodingErr "'" ++ tagL ++ "' property is missing") (M.lookup tagL jObj)
+      tag <- mFail (decodingErr "'" ++ tagL ++ "' property is not a string") (toString tagJson)
+      foundConstr <-  findConstrFail tag
+      jVals <- mFail (decodingErr "'" ++ contL ++ "' property is missing") (M.lookup contL jObj)
+      vals <- if opts.flattenContentsArray && (length foundConstr.sigValues == 1)
+              then pure [jVals]
+              else mFail (decodingErr "Expected array") (toArray jVals)
+      sps  <- zipWithA (\k -> genericUserDecodeJson' opts' (k unit)) foundConstr.sigValues vals
+      pure (SProd foundConstr.sigConstructor (const <$> sps))
+
+    decodingErr msg = "When decoding a " ++ tname ++ ": " ++ msg
+    fixConstr      = opts.constructorTagModifier
+    sumConf = case opts.sumEncoding of
+      TaggedObject conf -> conf
+      _ -> unsafeCrashWith "Only TaggedObject encoding is supported - FIX ME!"
+    tagL = sumConf.tagFieldName
+    contL = sumConf.contentsFieldName
+    findConstrFail tag = mFail (decodingErr ("'" <> tag <> "' isn't a valid constructor")) (findConstr tag)
+    findConstr tag = find ((tag ==) <<< fixConstr <<< _.sigConstructor) constrSigns
 
 instance decodeJsonMaybe :: (DecodeJson a) => DecodeJson (Maybe a) where
   decodeJson j
@@ -139,3 +184,6 @@ instance decodeMap :: (Ord a, DecodeJson a, DecodeJson b) => DecodeJson (Map.Map
 
 decodeMaybe :: forall a. (DecodeJson a) => Json -> Maybe a
 decodeMaybe json = either (const Nothing) pure $ decodeJson json
+
+mFail :: forall a. String -> Maybe a -> Either String a
+mFail msg = maybe (Left msg) Right