diff --git a/bower.json b/bower.json index fb870e6..4c23b4a 100644 --- a/bower.json +++ b/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" } } diff --git a/package.json b/package.json index 2f825ca..c3bf507 100644 --- a/package.json +++ b/package.json @@ -8,7 +8,7 @@ }, "devDependencies": { "pulp": "^7.0.0", - "purescript": "^0.7.6", + "purescript": "^0.8.0", "rimraf": "^2.4.4" } } diff --git a/src/Data/Argonaut/Aeson.purs b/src/Data/Argonaut/Aeson.purs new file mode 100644 index 0000000..7b6f658 --- /dev/null +++ b/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 diff --git a/src/Data/Argonaut/Decode.purs b/src/Data/Argonaut/Decode.purs index 1d9b303..61a04dd 100644 --- a/src/Data/Argonaut/Decode.purs +++ b/src/Data/Argonaut/Decode.purs @@ -2,8 +2,12 @@ module Data.Argonaut.Decode ( DecodeJson , decodeJson , gDecodeJson - , gDecodeJson' + , genericDecodeJson + , genericDecodeJson' + , genericUserDecodeJson' , decodeMaybe + , module Data.Argonaut.Options + , mFail ) where import Prelude @@ -11,59 +15,100 @@ 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 diff --git a/src/Data/Argonaut/Encode.purs b/src/Data/Argonaut/Encode.purs index 5351d52..def9581 100644 --- a/src/Data/Argonaut/Encode.purs +++ b/src/Data/Argonaut/Encode.purs @@ -2,45 +2,110 @@ module Data.Argonaut.Encode ( EncodeJson , encodeJson , gEncodeJson - , gEncodeJson' + , genericEncodeJson + , genericEncodeJson' + , genericUserEncodeJson' + , module Data.Argonaut.Options ) where import Prelude import Data.Argonaut.Core (Json(), jsonNull, fromBoolean, fromNumber, fromString, fromArray, fromObject) +import Data.Argonaut.Options import Data.Either (Either(), either) import Data.Foldable (foldr) -import Data.Generic (Generic, GenericSpine(..), toSpine) +import Data.Generic (Generic, GenericSpine(..), toSpine, GenericSignature(..), DataConstructor(), toSignature) import Data.Int (toNumber) import Data.List (List(..), fromList) import Data.Map as M -import Data.Maybe (Maybe(..)) +import Data.Maybe (Maybe(..), fromMaybe) import Data.String (fromChar) import Data.StrMap as SM 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) class EncodeJson a where encodeJson :: a -> Json --- | Encode any `Generic` data structure into `Json`. +-- | Encode any `Generic` data structure into `Json`, +-- | formatted according to argonautOptions gEncodeJson :: forall a. (Generic a) => a -> Json -gEncodeJson = gEncodeJson' <<< toSpine +gEncodeJson = genericEncodeJson argonautOptions + +genericEncodeJson :: forall a. (Generic a) => Options -> a -> Json +genericEncodeJson opts = genericUserEncodeJson' opts sign <<< toSpine + where sign = toSignature (Proxy :: Proxy a) + + +-- | Generically encode to json, using a supplied userEncoding, falling back to genericEncodeJson': +genericUserEncodeJson' :: Options -> GenericSignature -> GenericSpine -> Json +genericUserEncodeJson' opts'@(Options opts) sign spine = fromMaybe (genericEncodeJson' opts' sign spine) + (opts.userEncoding opts' sign spine) -- | Encode `GenericSpine` into `Json`. -gEncodeJson' :: GenericSpine -> Json -gEncodeJson' spine = case spine of - SInt x -> fromNumber $ toNumber x - SString x -> fromString x - SChar x -> fromString $ fromChar x - SNumber x -> fromNumber x - SBoolean x -> fromBoolean x - SArray thunks -> fromArray (gEncodeJson' <<< (unit #) <$> thunks) - SProd constr args -> fromObject - $ SM.insert "tag" (encodeJson constr) - $ SM.singleton "values" (encodeJson (gEncodeJson' <<< (unit #) <$> args)) - SRecord fields -> fromObject $ foldr addField SM.empty fields - where addField field = SM.insert field.recLabel - (gEncodeJson' $ field.recValue unit) +-- | This function is mutually recursive with `genericUserEncodeJson'`, as for all descendent spines +-- | `genericUserEncodeJson'` is invoked. +genericEncodeJson' :: Options -> GenericSignature -> GenericSpine -> Json +genericEncodeJson' opts sign spine = case spine of + SInt x -> fromNumber $ toNumber x + SString x -> fromString x + SChar x -> fromString $ fromChar x + SNumber x -> fromNumber x + SBoolean x -> fromBoolean x + SArray thunks -> case sign of + SigArray elemSign -> fromArray (genericUserEncodeJson' opts (elemSign unit) <<< (unit #) <$> thunks) + _ -> unsafeCrashWith "Signature does not match value, please don't do that!" + SProd constr args -> case sign of + SigProd _ constrSigns -> genericEncodeProdJson' opts constrSigns constr args + _ -> unsafeCrashWith "Signature does not match value, please don't do that!" + SRecord fields -> case sign of + SigRecord sigs -> genericEncodeRecordJson' opts sigs fields + _ -> unsafeCrashWith "Signature does not match value, please don't do that!" + +genericEncodeRecordJson' :: Options + -> Array { recLabel :: String, recValue :: Unit -> GenericSignature } + -> Array { recLabel :: String, recValue :: Unit -> GenericSpine } + -> Json +genericEncodeRecordJson' opts sigs fields = fromObject <<< foldr (uncurry addField) SM.empty $ zip sigs fields + where + addField sig field = SM.insert field.recLabel (genericUserEncodeJson' opts (sig.recValue unit) (field.recValue unit)) + +genericEncodeProdJson' :: Options -> Array DataConstructor -> String -> Array (Unit -> GenericSpine) -> Json +genericEncodeProdJson' opts'@(Options opts) constrSigns constr args = + if opts.unwrapUnaryRecords && isUnaryRecord constrSigns + then + genericUserEncodeJson' opts' + (Unsafe.head (Unsafe.head constrSigns).sigValues unit) + (Unsafe.head args unit) + else + if opts.allNullaryToStringTag && allConstructorsNullary constrSigns + then fromString fixedConstr + else fromObject + $ SM.insert sumConf.tagFieldName (encodeJson fixedConstr) + $ SM.singleton sumConf.contentsFieldName contents + where + sumConf = case opts.sumEncoding of + TaggedObject conf -> conf + fixedConstr = opts.constructorTagModifier constr + encodedArgs = genericEncodeProdArgs opts' constrSigns constr args + contents = if opts.flattenContentsArray && length encodedArgs == 1 + then Unsafe.head encodedArgs + else encodeJson encodedArgs + + + +genericEncodeProdArgs :: Options -> Array DataConstructor -> String -> Array (Unit -> GenericSpine) -> Array (Json) +genericEncodeProdArgs opts constrSigns constr args = zipWith (genericUserEncodeJson' opts) sigValues values + where + lSigValues = concatMap (\c -> c.sigValues) + <<< filter (\c -> c.sigConstructor == constr) $ constrSigns + sigValues = (unit #) <$> lSigValues + values = (unit #) <$> args + instance encodeJsonMaybe :: (EncodeJson a) => EncodeJson (Maybe a) where encodeJson Nothing = jsonNull diff --git a/src/Data/Argonaut/Options.purs b/src/Data/Argonaut/Options.purs new file mode 100644 index 0000000..b8c0fe8 --- /dev/null +++ b/src/Data/Argonaut/Options.purs @@ -0,0 +1,79 @@ +module Data.Argonaut.Options where + +import Prelude +import Data.Argonaut.Core (Json()) +import Data.Foldable (all) +import Data.String (lastIndexOf, drop) +import Data.Generic (DataConstructor()) +import Data.Array (null, length) +import Data.Generic (Generic, GenericSpine(..), toSpine, GenericSignature(..), DataConstructor(), toSignature) +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..)) + + +newtype Options = Options { -- newtype necessary to avoid: https://github.com/purescript/purescript/wiki/Error-Code-CycleInTypeSynonym + -- | Modify the tag, e.g. strip module path with: `stripModulePath` + constructorTagModifier :: String -> String + -- | If all constructors of a sum type are nullary, just serialize the constructor name as a string. +, allNullaryToStringTag :: Boolean + -- | Options on how to do encoding of sum types. +, sumEncoding :: SumEncoding + -- | If a constructor has exactly one field, do not serialize as array. +, flattenContentsArray :: Boolean -- Flatten array to simple value, if constructor only takes a single value + -- | You need a newtype wrapper encoding/decoding of records, set this + -- | to true if you want the plain Javascript object without a wrapping tagged object. +, unwrapUnaryRecords :: Boolean +-- | You can choose to encode some data types differently than the generic default. +-- | Just return Nothing if you want to relay to generic encoding. +, userEncoding :: Options -> GenericSignature -> GenericSpine -> Maybe Json +-- | You can choose to decode some data types differently than the generic default. +-- | Just return Nothing, to relay to generic decoding. +, userDecoding :: Options -> GenericSignature -> Json -> Maybe (Either String GenericSpine) +} + +data SumEncoding = + -- | Serialize as tagged object. + -- | The Javascript object will have a tag field, with the + -- | `constructorTagModifier constructorName` name as contents + -- | and a contents field, which contains an array with the constructor + -- | parameters. + TaggedObject { + tagFieldName :: String + , contentsFieldName :: String + } + +-- | Default for straight forward argonaut encoding. +argonautOptions :: Options +argonautOptions = Options { + constructorTagModifier : id +, allNullaryToStringTag : false +, sumEncoding : argonautSumEncoding +, flattenContentsArray : false +, unwrapUnaryRecords : false +, userEncoding : dummyUserEncoding +, userDecoding : dummyUserDecoding +} + +argonautSumEncoding :: SumEncoding +argonautSumEncoding = TaggedObject { + tagFieldName : "tag" +, contentsFieldName : "values" +} + +dummyUserEncoding :: Options -> GenericSignature -> GenericSpine -> Maybe Json +dummyUserEncoding _ _ _ = Nothing + +dummyUserDecoding :: Options -> GenericSignature -> Json -> Maybe (Either String GenericSpine) +dummyUserDecoding _ _ _ = Nothing + +allConstructorsNullary :: Array DataConstructor -> Boolean +allConstructorsNullary = all (null <<< _.sigValues) + +isUnaryRecord :: Array DataConstructor -> Boolean +isUnaryRecord constrSigns = length constrSigns == 1 -- Only one constructor + && all ((== 1) <<< length <<< _.sigValues) constrSigns -- Only one parameter + +stripModulePath :: String -> String +stripModulePath constr = case lastIndexOf "." constr of + Nothing -> constr + Just i -> drop (i+1) constr diff --git a/test/Test/Main.purs b/test/Test/Main.purs index 02d26d1..7fbc204 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -2,20 +2,29 @@ module Test.Main where import Prelude -import Data.Argonaut.Core -import Data.Argonaut.Decode (decodeJson, DecodeJson, gDecodeJson, gDecodeJson') -import Data.Argonaut.Encode (encodeJson, EncodeJson, gEncodeJson, gEncodeJson') -import Data.Argonaut.Combinators ((:=), (~>), (?>>=), (.?)) +import Data.Argonaut.Core hiding (toNumber) +import Data.Argonaut.Options +import Data.Argonaut.Aeson +import Data.Argonaut.Decode (decodeJson, DecodeJson, genericDecodeJson, genericDecodeJson') +import Data.Argonaut.Encode (encodeJson, EncodeJson, genericEncodeJson, genericEncodeJson') +import Data.Argonaut.Combinators ((:=), (~>), (?>>=)) import Data.Either +import Data.Int (toNumber) import Data.Tuple import Data.Maybe import Data.Array import Data.Generic import Data.Foldable (foldl) import Data.List (toList, List(..)) +import Data.StrMap as SM + +import Control.Monad.Eff (Eff()) +import Control.Monad.Eff.Exception (EXCEPTION()) +import Control.Monad.Eff.Random (RANDOM()) import Control.Monad.Eff.Console import qualified Data.StrMap as M +import Test.Assert (assert', ASSERT) import Test.StrongCheck import Test.StrongCheck.Gen import Test.StrongCheck.Generic @@ -67,7 +76,7 @@ prop_decode_then_encode (TestJson json) = let decoded = (decodeJson json) :: Either String Json in Right json == (decoded >>= (encodeJson >>> pure)) - +encodeDecodeCheck :: forall e. Eff ( err :: EXCEPTION, random :: RANDOM, console :: CONSOLE | e ) Unit encodeDecodeCheck = do log "Showing small sample of JSON" showSample (genJson 10) @@ -118,7 +127,7 @@ assert_maybe_msg = - +combinatorsCheck :: forall e. Eff ( err :: EXCEPTION, random :: RANDOM, console :: CONSOLE | e ) Unit combinatorsCheck = do log "Check assoc builder `:=`" quickCheck' 20 prop_assoc_builder_str @@ -143,31 +152,87 @@ data User = Anonymous } derive instance genericUser :: Generic User -prop_iso_generic :: GenericValue -> Boolean -prop_iso_generic genericValue = - Right val.spine == gDecodeJson' val.signature (gEncodeJson' val.spine) + +data AllNullary = Nullary1 | Nullary2 | Nullary3 +derive instance genericAllNullary :: Generic AllNullary +instance genericEqAllNullary :: Eq AllNullary where + eq = gEq + +data MultipleArgs = MArgs Int Int String | NArgs +derive instance genericMultipleArgs :: Generic MultipleArgs +instance genericEqMArgs :: Eq MultipleArgs where + eq = gEq + +newtype NewTypeWrapper1 = NewTypeWrapper1 { test :: String } +derive instance genericNewTypeWrapper1 :: Generic NewTypeWrapper1 +instance eqNewTypeWrapper1 :: Eq NewTypeWrapper1 where + eq = gEq +data NewTypeWrapper2 = NewTypeWrapper2 {test :: Int} +derive instance genericNewTypeWrapper2 :: Generic NewTypeWrapper2 +instance eqNewTypeWrapper2 :: Eq NewTypeWrapper2 where + eq = gEq + +prop_iso_generic :: Options -> GenericValue -> Boolean +prop_iso_generic opts genericValue = + Right val.spine == genericDecodeJson' opts val.signature (genericEncodeJson' opts val.signature val.spine) where val = runGenericValue genericValue -prop_decoded_spine_valid :: GenericValue -> Boolean -prop_decoded_spine_valid genericValue = - Right true == (isValidSpine val.signature <$> gDecodeJson' val.signature (gEncodeJson' val.spine)) +prop_decoded_spine_valid :: Options -> GenericValue -> Boolean +prop_decoded_spine_valid opts genericValue = + Right true == (isValidSpine val.signature <$> genericDecodeJson' opts val.signature (genericEncodeJson' opts val.signature val.spine)) where val = runGenericValue genericValue -genericsCheck = do - log "Check that decodeJson' and encodeJson' form an isomorphism" - quickCheck prop_iso_generic +checkAesonCompat :: Boolean +checkAesonCompat = + let + myTuple = Tuple (Tuple 1 2) "Hello" + myJust = Just "Test" + myNothing = Nothing :: Maybe Int + myLeft = Left "Foo" :: Either String String + myRight = Right "Bar" :: Either Int String + in + gAesonEncodeJson myTuple == fromArray [fromNumber $ toNumber 1, fromNumber $ toNumber 2, fromString "Hello"] + && gAesonEncodeJson myJust == fromString "Test" + && gAesonEncodeJson myNothing == jsonNull + && gAesonEncodeJson myLeft == fromObject (SM.fromList (Tuple "Left" (fromString "Foo") `Cons` Nil)) + && gAesonEncodeJson myRight == fromObject (SM.fromList (Tuple "Right" (fromString "Bar") `Cons` Nil)) + + +genericsCheck :: forall e. Options -> Eff ( err :: EXCEPTION , random :: RANDOM , console :: CONSOLE, assert :: ASSERT | e) Unit +genericsCheck opts= do + let vNullary = Nullary2 + let mArgs = MArgs 9 20 "Hello" + let ntw1 = NewTypeWrapper1 { test : "hello" } + let ntw2 = NewTypeWrapper2 { test : 9 } + let mJust = Just "Test" + let mNothing = Nothing :: Maybe Int + let mRight = Right 9 :: Either String Int + let mLeft = Right (Left 2) :: Either String (Either Int Int) + let mTuple = Tuple (Tuple (Tuple 2 3) "haha") "test" + log "Check that decodeJson' and encodeJson' form an isomorphism .." + assert' " Check all nullary:" (valEncodeDecode opts vNullary) + assert' " Check multiple args:" (valEncodeDecode opts mArgs) + assert' " Check new type wrapper (1) encoding:" (valEncodeDecode opts ntw1) + assert' " Check new type wrapper (2) encoding:" (valEncodeDecode opts ntw2) + assert' " Check Just" (valEncodeDecode opts mJust) + assert' " Check Nothing" (valEncodeDecode opts mNothing) + assert' " Check Right" (valEncodeDecode opts mRight) + assert' " Check Left" (valEncodeDecode opts mLeft) + assert' " Check tuple" (valEncodeDecode opts mTuple) + + quickCheck (prop_iso_generic opts) log "Check that decodeJson' returns a valid spine" - quickCheck prop_decoded_spine_valid - log "Print samples of values encoded with gEncodeJson" - print $ gEncodeJson 5 - print $ gEncodeJson [1, 2, 3, 5] - print $ gEncodeJson (Just "foo") - print $ gEncodeJson (Right "foo" :: Either String String) - print $ gEncodeJson $ MyRecord { foo: "foo", bar: 2} - print $ gEncodeJson "foo" - print $ gEncodeJson Anonymous - print $ gEncodeJson $ Guest "guest's handle" - print $ gEncodeJson $ Registered { name: "user1" + quickCheck (prop_decoded_spine_valid opts) + log "Print samples of values encoded with genericEncodeJson" + print $ genericEncodeJson opts 5 + print $ genericEncodeJson opts [1, 2, 3, 5] + print $ genericEncodeJson opts (Just "foo") + print $ genericEncodeJson opts (Right "foo" :: Either String String) + print $ genericEncodeJson opts $ MyRecord { foo: "foo", bar: 2} + print $ genericEncodeJson opts "foo" + print $ genericEncodeJson opts Anonymous + print $ genericEncodeJson opts $ Guest "guest's handle" + print $ genericEncodeJson opts $ Registered { name: "user1" , age: 5 , balance: 26.6 , banned: false @@ -181,8 +246,18 @@ genericsCheck = do , tweets: ["Hi"] , followers: [] }]} + print $ genericEncodeJson opts Nullary1 + print $ genericEncodeJson opts Nullary2 + print $ genericEncodeJson opts $ MArgs 9 22 "Test" + print $ genericEncodeJson opts NArgs + print $ genericEncodeJson opts ntw1 + print $ genericEncodeJson opts ntw2 + where + valEncodeDecode :: forall a. (Eq a, Generic a) => Options -> a -> Boolean + valEncodeDecode opts val = ((Right val) ==) <<< genericDecodeJson opts <<< genericEncodeJson opts $ val +eitherCheck :: forall e. Eff ( err :: EXCEPTION, random :: RANDOM, console :: CONSOLE | e ) Unit eitherCheck = do log "Test EncodeJson/DecodeJson Either instance" quickCheck \(x :: Either String String) -> @@ -193,8 +268,17 @@ eitherCheck = do Left err -> false err +main:: forall e. Eff ( err :: EXCEPTION, random :: RANDOM, console :: CONSOLE, assert :: ASSERT | e ) Unit main = do eitherCheck encodeDecodeCheck combinatorsCheck - genericsCheck + assert' "aesonCompatcheck: " checkAesonCompat + log "genericsCheck check for argonautOptions" + genericsCheck argonautOptions + log "genericsCheck check for aesonOptions" + genericsCheck aesonOptions + log "genericsCheck check for unwrapUnaryOptions" + let unwrapOpts = case aesonOptions of Options a -> a + let unwrapUnaryOptions = Options $ unwrapOpts { unwrapUnaryRecords = true } + genericsCheck unwrapUnaryOptions