Skip to content

More aeson compatibility options #11

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion bower.json
Original file line number Diff line number Diff line change
@@ -24,6 +24,7 @@
"purescript-nullable": "^1.0.0"
},
"devDependencies": {
"purescript-assert": "^1.0.0"
"purescript-assert": "^1.0.0",
"purescript-strings": "^1.0.0"
}
}
71 changes: 47 additions & 24 deletions src/Data/Foreign/Generic.purs
Original file line number Diff line number Diff line change
@@ -4,13 +4,13 @@ import Prelude

import Control.Bind ((>=>))
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
import Data.Array (zipWith, zipWithA, sortBy)
import Data.Array (zipWith, zipWithA, sortBy, length)
import Data.Either (Either(..))
import Data.Foldable (find)
import Data.Foldable (find, all)
import Data.Foreign (F, Foreign, ForeignError(..), parseJSON, toForeign, readArray,
readString, isUndefined, isNull, readBoolean, readChar, readInt,
readNumber)
import Data.Foreign.Index (prop, (!))
import Data.Foreign.Index (prop, (!), errorAt)
import Data.Function (on)
import Data.Generic (class Generic, GenericSignature(..), GenericSpine(..), toSpine,
toSignature, fromSpine)
@@ -29,6 +29,9 @@ type Options =
, unwrapSingleArgumentConstructors :: Boolean
, maybeAsNull :: Boolean
, tupleAsArray :: Boolean
, untagEnums :: Boolean
, fieldLabelModifier :: String -> String
, constructorTagModifier :: String -> String
}

data SumEncoding
@@ -47,6 +50,9 @@ defaultOptions =
, unwrapSingleArgumentConstructors: true
, maybeAsNull: true
, tupleAsArray: false
, untagEnums: false
, fieldLabelModifier: id
, constructorTagModifier: id
}

-- | Read a value which has a `Generic` type.
@@ -56,6 +62,9 @@ readGeneric { sumEncoding
, unwrapSingleArgumentConstructors
, maybeAsNull
, tupleAsArray
, untagEnums
, fieldLabelModifier
, constructorTagModifier
} = map fromSpineUnsafe <<< go (toSignature (Proxy :: Proxy a))
where
fromSpineUnsafe :: GenericSpine -> a
@@ -79,9 +88,11 @@ readGeneric { sumEncoding
pure (SArray els)
go (SigRecord props) f = do
fs <- for props \prop -> do
pf <- f ! prop.recLabel
sp <- go (prop.recValue unit) pf
pure { recLabel: prop.recLabel, recValue: const sp }
let label = fieldLabelModifier prop.recLabel
pf <- f ! label
case go (prop.recValue unit) pf of
Right sp -> pure { recLabel: label, recValue: const sp }
Left err -> Left $ errorAt label err
pure (SRecord fs)
go (SigProd _ [{ sigConstructor: tag, sigValues: [sig] }]) f | unwrapNewtypes = do
sp <- go (sig unit) f
@@ -98,22 +109,27 @@ readGeneric { sumEncoding
x <- go (_1 unit) a
y <- go (_2 unit) b
pure $ SProd "Data.Tuple.Tuple" [\_ -> x, \_ -> y]
_ -> Left (TypeMismatch "array of length 2" "array")
_ -> Left (TypeMismatch ["array of length 2"] "array")
go (SigProd _ alts) f | untagEnums && all (\a -> length a.sigValues == 0) alts = do
tag <- readString f
case find (\alt -> (constructorTagModifier alt.sigConstructor) == tag) alts of
Nothing -> Left (TypeMismatch (map (constructorTagModifier <<< _.sigConstructor) alts) tag)
Just { sigConstructor } -> pure (SProd sigConstructor [])
go (SigProd _ alts) f =
case sumEncoding of
TaggedObject { tagFieldName, contentsFieldName } -> do
tag <- prop tagFieldName f >>= readString
case find (\alt -> alt.sigConstructor == tag) alts of
Nothing -> Left (TypeMismatch ("one of " <> show (map _.sigConstructor alts)) tag)
Just { sigValues: [] } -> pure (SProd tag [])
Just { sigValues: [sig] } | unwrapSingleArgumentConstructors -> do
case find (\alt -> constructorTagModifier alt.sigConstructor == tag) alts of
Nothing -> Left (TypeMismatch (map (constructorTagModifier <<< _.sigConstructor) alts) tag)
Just { sigConstructor, sigValues: [] } -> pure (SProd sigConstructor [])
Just { sigConstructor, sigValues: [sig] } | unwrapSingleArgumentConstructors -> do
val <- prop contentsFieldName f
sp <- go (sig unit) val
pure (SProd tag [\_ -> sp])
Just { sigValues } -> do
pure (SProd sigConstructor [\_ -> sp])
Just { sigConstructor, sigValues } -> do
vals <- prop contentsFieldName f >>= readArray
sps <- zipWithA (\k -> go (k unit)) sigValues vals
pure (SProd tag (map const sps))
pure (SProd sigConstructor (map const sps))

-- | Generate a `Foreign` value compatible with the `readGeneric` function.
toForeignGeneric :: forall a. (Generic a) => Options -> a -> Foreign
@@ -122,6 +138,9 @@ toForeignGeneric { sumEncoding
, unwrapSingleArgumentConstructors
, maybeAsNull
, tupleAsArray
, untagEnums
, fieldLabelModifier
, constructorTagModifier
} = go (toSignature (Proxy :: Proxy a)) <<< toSpine
where
go :: GenericSignature -> GenericSpine -> Foreign
@@ -137,28 +156,32 @@ toForeignGeneric { sumEncoding
pairs = zipWith pair (sortBy (compare `on` _.recLabel) sigs)
(sortBy (compare `on` _.recLabel) sps)

pair sig sp | sig.recLabel == sp.recLabel = Tuple sig.recLabel (go (sig.recValue unit) (sp.recValue unit))
pair sig sp | sig.recLabel == sp.recLabel = Tuple (fieldLabelModifier sig.recLabel) (go (sig.recValue unit) (sp.recValue unit))
| otherwise = unsafeThrow "Record fields do not match signature"
go (SigProd "Data.Maybe.Maybe" _) (SProd "Data.Maybe.Nothing" []) | maybeAsNull = toForeign (toNullable Nothing)
go (SigProd "Data.Maybe.Maybe" [{ sigValues: [just] }, _]) (SProd "Data.Maybe.Just" [sp]) | maybeAsNull = go (just unit) (sp unit)
go (SigProd "Data.Tuple.Tuple" [{ sigValues: [_1, _2] }]) (SProd "Data.Tuple.Tuple" [a, b]) | tupleAsArray = do
toForeign [ go (_1 unit) (a unit), go (_2 unit) (b unit) ]
go (SigProd _ [{ sigConstructor: _, sigValues: [sig] }]) (SProd _ [sp]) | unwrapNewtypes = go (sig unit) (sp unit)
go (SigProd _ alts) (SProd tag sps) | untagEnums && all (\a -> length a.sigValues == 0) alts =
toForeign (constructorTagModifier tag)
go (SigProd _ alts) (SProd tag sps) =
case sumEncoding of
TaggedObject { tagFieldName, contentsFieldName } ->
case find (\alt -> alt.sigConstructor == tag) alts of
Nothing -> unsafeThrow ("No signature for data constructor " <> tag)
Just { sigValues } ->
case zipWith (\sig sp -> go (sig unit) (sp unit)) sigValues sps of
[] -> toForeign (S.fromList (L.singleton (Tuple tagFieldName (toForeign tag))))
[f] | unwrapSingleArgumentConstructors ->
toForeign (S.fromList (L.fromFoldable [ Tuple tagFieldName (toForeign tag)
, Tuple contentsFieldName f
]))
fs -> toForeign (S.fromList (L.fromFoldable [ Tuple tagFieldName (toForeign tag)
, Tuple contentsFieldName (toForeign fs)
]))
case zipWith (\sig sp -> go (sig unit) (sp unit)) sigValues sps of
[] -> toForeign (S.fromList (L.singleton (Tuple tagFieldName (toForeign ctag))))
[f] | unwrapSingleArgumentConstructors ->
toForeign (S.fromList (L.fromFoldable [ Tuple tagFieldName (toForeign ctag)
, Tuple contentsFieldName f
]))
fs -> toForeign (S.fromList (L.fromFoldable [ Tuple tagFieldName (toForeign ctag)
, Tuple contentsFieldName (toForeign fs)
]))
where
ctag = constructorTagModifier tag
go _ _ = unsafeThrow "Invalid spine for signature"

-- | Read a value which has a `Generic` type from a JSON String
112 changes: 75 additions & 37 deletions test/Main.purs
Original file line number Diff line number Diff line change
@@ -1,16 +1,20 @@
module Test.Main where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Bifunctor (bimap)
import Data.Either (Either(..))
import Data.Foreign (F)
import Data.Foreign.Generic (Options, defaultOptions, readJSONGeneric, toJSONGeneric)
import Data.Generic (class Generic, gEq, gShow)
import Data.Either (Either(..), fromRight)
import Data.Foreign (F, Foreign, ForeignError(..))
import Data.Foreign.Class (class IsForeign, read)
import Data.Foreign.Generic (Options, SumEncoding(..), defaultOptions, readJSONGeneric, toJSONGeneric, readGeneric)
import Data.Generic (class Generic, toSignature, toSpine, fromSpine, gEq, gShow, GenericSpine(..), GenericSignature(..))
import Data.Maybe (Maybe(..))
import Data.String (lastIndexOf, drop, toLower)
import Data.String.Regex (regex, noFlags, replace)
import Data.Tuple (Tuple(..))
import Test.Assert (assert, assert', ASSERT())
import Partial.Unsafe (unsafePartial)
import Test.Assert (assert, assert', ASSERT)

-- | Balanced binary leaf trees
data Tree a = Leaf a | Branch (Tree (Tuple a a))
@@ -25,14 +29,11 @@ buildTree f n a = Branch $ buildTree (bimap f f) (n - 1) (f a)
tree :: Tree Int
tree = buildTree (\i -> Tuple (2 * i) (2 * i + 1)) 5 0

opts :: Options
opts = defaultOptions { unwrapNewtypes = true, tupleAsArray = true }

readTree :: forall a. (Generic a) => String -> F (Tree a)
readTree = readJSONGeneric opts
readTree :: forall a. (Generic a) => Options -> String -> F (Tree a)
readTree opts = readJSONGeneric opts

writeTree :: forall a. (Generic a) => Tree a -> String
writeTree = toJSONGeneric opts
writeTree :: forall a. (Generic a) => Options -> Tree a -> String
writeTree opts = toJSONGeneric opts

data WrappedArray a = WrappedArray (Array a)
derive instance genericWrappedArray :: (Generic a) => Generic (WrappedArray a)
@@ -43,35 +44,71 @@ derive instance genericWrappedArrayN :: (Generic a) => Generic (WrappedArrayN a)
data TupleArray a b = TupleArray (Array (Tuple a b))
derive instance genericTupleArray :: (Generic a, Generic b) => Generic (TupleArray a b)

newtype WrappedRecord
= WrappedRecord
{ propFoo :: String
, propBAR :: Int
, order :: Ordering
}
derive instance genericWrappedRecord :: Generic WrappedRecord

shortNames :: String -> String
shortNames s =
case lastIndexOf "." s of
Nothing -> s
Just i -> drop (i + 1) s

camelTo :: String -> String -> String
camelTo to str =
toLower (replace rx (to <> "$1") str)
where
rx = unsafePartial (fromRight (regex "([A-Z]+)" opts))
opts = noFlags { global = true }

main :: forall eff. Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
main = do
testTree
test "hello, world"
test 'c'
test 1
test 1.0
test false

test (Right "hi" :: Either String String)
test (Left "hi" :: Either String String)
test (Tuple "foo" 1)

let arr = [Tuple "foo" 1, Tuple "bar" 2]
test arr
test (WrappedArray arr)
test (WrappedArrayN arr)
test (TupleArray arr)
testOpts defaultOptions
testOpts defaultOptions { untagEnums = true, constructorTagModifier = shortNames }
testOpts defaultOptions { untagEnums = true, fieldLabelModifier = camelTo "_" }

testOpts :: forall eff. Options -> Eff (console :: CONSOLE, assert :: ASSERT | eff) Unit
testOpts opts = do
testTree opts
test' "hello, world"
test' 'c'
test' 1
test' 1.0
test' false
test' GT

test' (Right "hi" :: Either String String)
test' (Left "hi" :: Either String String)
test' (Tuple "fooBar" 1)

let arr = [Tuple "fooBar" 1, Tuple "baz" 2]
test' arr
test' (WrappedArray arr)
test' (WrappedArrayN arr)
test' (TupleArray arr)
test' (WrappedRecord { propFoo: "hi", propBAR: 3, order: GT })

where
test' :: forall a. Generic a
=> a
-> Eff ( console :: CONSOLE , assert :: ASSERT | eff) Unit
test' = test opts

testTree
:: forall eff
. Eff ( console :: CONSOLE
. Options
-> Eff ( console :: CONSOLE
, assert :: ASSERT
| eff
) Unit
testTree = do
let json = writeTree tree
testTree opts = do
let json = writeTree opts tree
log json
case readTree json of
case readTree opts json of
Right tree1 -> do
log (gShow tree1)
assert (gEq tree tree1)
@@ -81,19 +118,20 @@ testTree = do
test
:: forall a eff
. Generic a
=> a
=> Options
-> a
-> Eff ( console :: CONSOLE
, assert :: ASSERT
| eff
) Unit
test thing = do
test opts thing = do
log ""
log ("testing: " <> gShow thing)
log "==="
log ""
let json = toJSONGeneric defaultOptions thing
let json = toJSONGeneric opts thing
log json
case readJSONGeneric defaultOptions json :: F a of
case readJSONGeneric opts json :: F a of
Right thing1 -> do
log ("result: " <> gShow thing1)
assert (gEq thing thing1)