diff --git a/bower.json b/bower.json index 7b2a86d..a713650 100644 --- a/bower.json +++ b/bower.json @@ -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" } } diff --git a/src/Data/Foreign/Generic.purs b/src/Data/Foreign/Generic.purs index c1c4d6f..59692ee 100644 --- a/src/Data/Foreign/Generic.purs +++ b/src/Data/Foreign/Generic.purs @@ -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 diff --git a/test/Main.purs b/test/Main.purs index bcbbd86..535712c 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -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)