From 6e78c990348b8b6ae67601823280589539603852 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 17 Nov 2015 20:25:18 -0800 Subject: [PATCH 1/3] Updates for new deriving --- bower.json | 2 +- docs/Data/Foreign/Generic.md | 23 ++++++++- src/Data/Foreign/Generic.purs | 97 +++++++++++++++++++++++++---------- test/Main.purs | 27 +++++----- 4 files changed, 103 insertions(+), 46 deletions(-) diff --git a/bower.json b/bower.json index a95895c..3df6a02 100644 --- a/bower.json +++ b/bower.json @@ -15,7 +15,7 @@ }, "dependencies": { "purescript-console": "^0.1.0", - "purescript-foreign": "~0.7.0", + "purescript-foreign": "*", "purescript-generics": "^0.5.0" } } diff --git a/docs/Data/Foreign/Generic.md b/docs/Data/Foreign/Generic.md index e050640..328a9b5 100644 --- a/docs/Data/Foreign/Generic.md +++ b/docs/Data/Foreign/Generic.md @@ -1,9 +1,28 @@ ## Module Data.Foreign.Generic +#### `Options` + +``` purescript +type Options = { sumEncoding :: SumEncoding, unwrapNewtypes :: Boolean, unwrapSingleArgumentConstructors :: Boolean, maybeAsNull :: Boolean } +``` + +#### `SumEncoding` + +``` purescript +data SumEncoding + = TaggedObject { tagFieldName :: String, contentsFieldName :: String } +``` + +#### `defaultOptions` + +``` purescript +defaultOptions :: Options +``` + #### `readGeneric` ``` purescript -readGeneric :: forall a. (Generic a) => Foreign -> F a +readGeneric :: forall a. (Generic a) => Options -> Foreign -> F a ``` Read a value which has a `Generic` type. @@ -11,7 +30,7 @@ Read a value which has a `Generic` type. #### `readJSONGeneric` ``` purescript -readJSONGeneric :: forall a. (Generic a) => String -> F a +readJSONGeneric :: forall a. (Generic a) => Options -> String -> F a ``` Read a value which has a `Generic` type from a JSON String diff --git a/src/Data/Foreign/Generic.purs b/src/Data/Foreign/Generic.purs index 76fa4c8..f95dc12 100644 --- a/src/Data/Foreign/Generic.purs +++ b/src/Data/Foreign/Generic.purs @@ -1,9 +1,8 @@ module Data.Foreign.Generic where - + import Prelude import Data.Maybe -import Data.Maybe.Unsafe (fromJust) import Data.Array (zipWithA) import Data.Either import Data.Foreign @@ -13,38 +12,80 @@ import Data.Generic import Data.Foldable (find) import Data.Traversable (for) -import Control.Alt ((<|>)) -import Control.Plus (empty) import Control.Bind ((>=>)) -import Control.Monad (when) - + +type Options = + { sumEncoding :: SumEncoding + , unwrapNewtypes :: Boolean + , unwrapSingleArgumentConstructors :: Boolean + , maybeAsNull :: Boolean + } + +data SumEncoding + = TaggedObject + { tagFieldName :: String + , contentsFieldName :: String + } + +defaultOptions :: Options +defaultOptions = + { sumEncoding: TaggedObject + { tagFieldName: "tag" + , contentsFieldName: "contents" + } + , unwrapNewtypes: false + , unwrapSingleArgumentConstructors: true + , maybeAsNull: true + } + -- | Read a value which has a `Generic` type. -readGeneric :: forall a. (Generic a) => Foreign -> F a -readGeneric = map (fromJust <<< fromSpine) <<< go (toSignature (anyProxy :: Proxy a)) +readGeneric :: forall a. (Generic a) => Options -> Foreign -> F a +readGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, maybeAsNull } = + go (toSignature (anyProxy :: Proxy a)) >=> + fromSpine >>> maybe (Left (TypeMismatch "valid spine" "invalid spine")) Right where go :: GenericSignature -> Foreign -> F GenericSpine go SigNumber f = map SNumber (readNumber f) go SigInt f = map SInt (readInt f) + go SigChar f = map SChar (readChar f) go SigString f = map SString (readString f) go SigBoolean f = map SBoolean (readBoolean f) - go (SigArray el) f = do arr <- readArray f - els <- for arr \f -> do - e <- go (el unit) f - return (const e) - return (SArray els) - go (SigRecord props) f = do fs <- for props \prop -> do pf <- f ! prop.recLabel - sp <- go (prop.recValue unit) pf - return { recLabel: prop.recLabel, recValue: const sp } - return (SRecord fs) - go (SigProd alts) f = do - tag <- prop "tag" f >>= readString - case find (\alt -> alt.sigConstructor == tag) alts of - Nothing -> Left (TypeMismatch "" tag) - Just { sigValues: sigValues } -> do - vals <- prop "values" f >>= readArray - sps <- zipWithA (\k -> go (k unit)) sigValues vals - return (SProd tag (map const sps)) - + go (SigArray el) f = do + arr <- readArray f + els <- for arr \f -> do + e <- go (el unit) f + return (const e) + return (SArray els) + go (SigRecord props) f = do + fs <- for props \prop -> do + pf <- f ! prop.recLabel + sp <- go (prop.recValue unit) pf + return { recLabel: prop.recLabel, recValue: const sp } + return (SRecord fs) + go (SigProd _ [{ sigConstructor: tag, sigValues: [sig] }]) f | unwrapNewtypes = do + sp <- go (sig unit) f + return (SProd tag [\_ -> sp]) + go (SigProd "Data.Maybe.Maybe" [{ sigValues: [just] }, _]) f | maybeAsNull = do + if isNull f + then return (SProd "Data.Maybe.Nothing" []) + else do sp <- go (just unit) f + return (SProd "Data.Maybe.Just" [\_ -> sp]) + 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: [] } -> return (SProd tag []) + Just { sigValues: [sig] } | unwrapSingleArgumentConstructors -> do + val <- prop contentsFieldName f + sp <- go (sig unit) val + return (SProd tag [\_ -> sp]) + Just { sigValues } -> do + vals <- prop contentsFieldName f >>= readArray + sps <- zipWithA (\k -> go (k unit)) sigValues vals + return (SProd tag (map const sps)) + -- | Read a value which has a `Generic` type from a JSON String -readJSONGeneric :: forall a. (Generic a) => String -> F a -readJSONGeneric = parseJSON >=> readGeneric +readJSONGeneric :: forall a. (Generic a) => Options -> String -> F a +readJSONGeneric opts = parseJSON >=> readGeneric opts diff --git a/test/Main.purs b/test/Main.purs index 6e1dbe4..7c20388 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -2,11 +2,13 @@ module Test.Main where import Prelude +import Data.Maybe import Data.Either import Data.Generic import Data.Foreign import Data.Foreign.Generic +import Control.Monad.Eff import Control.Monad.Eff.Console data Tree a = Leaf a | Branch (Tree a) (Tree a) @@ -16,29 +18,24 @@ derive instance genericTree :: (Generic a) => Generic (Tree a) json :: String json = """ { - "tag": "Branch", - "values": [ + "tag": "Test.Main.Branch", + "contents": [ { - "tag": "Leaf", - "values": [ - true - ] + "tag": "Test.Main.Leaf", + "contents": true }, { - "tag": "Leaf", - "values": [ - false - ] + "tag": "Test.Main.Leaf", + "contents": null } ] -} - - """ +}""" readTree :: forall a. (Generic a) => String -> F (Tree a) -readTree = readJSONGeneric +readTree = readJSONGeneric defaultOptions +main :: forall eff. Eff (console :: CONSOLE | eff) Unit main = do - case readTree json :: F (Tree Boolean) of + case readTree json :: F (Tree (Maybe Boolean)) of Right tree -> log (gShow tree) Left err -> print err From ffec40732312415fbe68997766cc1368c58dbefa Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 18 Nov 2015 10:58:34 -0800 Subject: [PATCH 2/3] Add toForeignGeneric, toJSONGeneric, and improve tests --- bower.json | 15 +++++--- docs/Data/Foreign/Generic.md | 16 +++++++++ src/Data/Foreign/Generic.purs | 64 ++++++++++++++++++++++++++++++++--- test/Main.purs | 41 +++++++++++----------- 4 files changed, 108 insertions(+), 28 deletions(-) diff --git a/bower.json b/bower.json index 3df6a02..e198f84 100644 --- a/bower.json +++ b/bower.json @@ -9,13 +9,18 @@ "bower_components", "output" ], - "repository": { - "type": "git", + "repository": { + "type": "git", "url": "git://github.com/paf31/purescript-foreign-generic.git" - }, + }, "dependencies": { "purescript-console": "^0.1.0", - "purescript-foreign": "*", - "purescript-generics": "^0.5.0" + "purescript-eff": "^0.1.2", + "purescript-exceptions": "~0.3.1", + "purescript-foreign": "~0.7.1", + "purescript-generics": "^0.5.0", + "purescript-globals": "~0.2.1", + "purescript-maps": "~0.5.2", + "purescript-nullable": "~0.2.1" } } diff --git a/docs/Data/Foreign/Generic.md b/docs/Data/Foreign/Generic.md index 328a9b5..31ab69e 100644 --- a/docs/Data/Foreign/Generic.md +++ b/docs/Data/Foreign/Generic.md @@ -27,6 +27,14 @@ readGeneric :: forall a. (Generic a) => Options -> Foreign -> F a Read a value which has a `Generic` type. +#### `toForeignGeneric` + +``` purescript +toForeignGeneric :: forall a. (Generic a) => Options -> a -> Foreign +``` + +Generate a `Foreign` value compatible with the `readGeneric` function. + #### `readJSONGeneric` ``` purescript @@ -35,4 +43,12 @@ readJSONGeneric :: forall a. (Generic a) => Options -> String -> F a Read a value which has a `Generic` type from a JSON String +#### `toJSONGeneric` + +``` purescript +toJSONGeneric :: forall a. (Generic a) => Options -> a -> String +``` + +Write a value which has a `Generic` type as a JSON String + diff --git a/src/Data/Foreign/Generic.purs b/src/Data/Foreign/Generic.purs index f95dc12..c9e884c 100644 --- a/src/Data/Foreign/Generic.purs +++ b/src/Data/Foreign/Generic.purs @@ -3,16 +3,24 @@ module Data.Foreign.Generic where import Prelude import Data.Maybe -import Data.Array (zipWithA) +import Data.Array (zipWith, zipWithA, sortBy) +import Data.Tuple import Data.Either import Data.Foreign import Data.Foreign.Class import Data.Foreign.Index +import Data.Function (on) +import Data.Nullable (toNullable) import Data.Generic import Data.Foldable (find) import Data.Traversable (for) +import Data.List as L +import Data.StrMap as S import Control.Bind ((>=>)) +import Control.Monad.Eff.Exception.Unsafe (unsafeThrow) + +import Global.Unsafe (unsafeStringify) type Options = { sumEncoding :: SumEncoding @@ -41,9 +49,14 @@ defaultOptions = -- | Read a value which has a `Generic` type. readGeneric :: forall a. (Generic a) => Options -> Foreign -> F a readGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, maybeAsNull } = - go (toSignature (anyProxy :: Proxy a)) >=> - fromSpine >>> maybe (Left (TypeMismatch "valid spine" "invalid spine")) Right + map fromSpineUnsafe <<< go (toSignature (anyProxy :: Proxy a)) where + fromSpineUnsafe :: GenericSpine -> a + fromSpineUnsafe sp = + case fromSpine sp of + Nothing -> unsafeThrow "Invalid spine for signature" + Just a -> a + go :: GenericSignature -> Foreign -> F GenericSpine go SigNumber f = map SNumber (readNumber f) go SigInt f = map SInt (readInt f) @@ -66,7 +79,7 @@ readGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, may sp <- go (sig unit) f return (SProd tag [\_ -> sp]) go (SigProd "Data.Maybe.Maybe" [{ sigValues: [just] }, _]) f | maybeAsNull = do - if isNull f + if isNull f || isUndefined f then return (SProd "Data.Maybe.Nothing" []) else do sp <- go (just unit) f return (SProd "Data.Maybe.Just" [\_ -> sp]) @@ -86,6 +99,49 @@ readGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, may sps <- zipWithA (\k -> go (k unit)) sigValues vals return (SProd tag (map const sps)) +-- | Generate a `Foreign` value compatible with the `readGeneric` function. +toForeignGeneric :: forall a. (Generic a) => Options -> a -> Foreign +toForeignGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, maybeAsNull } = go (toSignature (Proxy :: Proxy a)) <<< toSpine + where + go :: GenericSignature -> GenericSpine -> Foreign + go _ (SNumber n) = toForeign n + go _ (SInt i) = toForeign i + go _ (SChar c) = toForeign c + go _ (SString s) = toForeign s + go _ (SBoolean b) = toForeign b + go (SigArray sig) (SArray arr) = toForeign (map (go (sig unit) <<< ($ unit)) arr) + go (SigRecord sigs) (SRecord sps) = toForeign (S.fromList (L.toList pairs)) + where + pairs :: Array (Tuple String Foreign) + 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)) + | 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 _ [{ sigConstructor: _, sigValues: [sig] }]) (SProd _ [sp]) | unwrapNewtypes = go (sig unit) (sp unit) + 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.toList [ Tuple tagFieldName (toForeign tag) + , Tuple contentsFieldName f + ])) + fs -> toForeign (S.fromList (L.toList [ Tuple tagFieldName (toForeign tag) + , Tuple contentsFieldName (toForeign fs) + ])) + go _ _ = unsafeThrow "Invalid spine for signature" + -- | Read a value which has a `Generic` type from a JSON String readJSONGeneric :: forall a. (Generic a) => Options -> String -> F a readJSONGeneric opts = parseJSON >=> readGeneric opts + +-- | Write a value which has a `Generic` type as a JSON String +toJSONGeneric :: forall a. (Generic a) => Options -> a -> String +toJSONGeneric opts = toForeignGeneric opts >>> unsafeStringify diff --git a/test/Main.purs b/test/Main.purs index 7c20388..b93ffc9 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -11,31 +11,34 @@ import Data.Foreign.Generic import Control.Monad.Eff import Control.Monad.Eff.Console -data Tree a = Leaf a | Branch (Tree a) (Tree a) +-- | Balanced leaf trees +data Tree a = Leaf a | Branch (Tree (Array a)) derive instance genericTree :: (Generic a) => Generic (Tree a) -json :: String -json = """ - { - "tag": "Test.Main.Branch", - "contents": [ - { - "tag": "Test.Main.Leaf", - "contents": true - }, - { - "tag": "Test.Main.Leaf", - "contents": null - } - ] -}""" +buildTree :: forall a. (a -> Array a) -> Int -> a -> Tree a +buildTree _ 0 a = Leaf a +buildTree f n a = Branch $ buildTree (map f) (n - 1) (f a) + +-- A balanced binary tree of depth 5 +tree :: Tree Int +tree = buildTree (\i -> [2 * i, 2 * i + 1]) 5 0 + +opts :: Options +opts = defaultOptions { unwrapNewtypes = true } readTree :: forall a. (Generic a) => String -> F (Tree a) -readTree = readJSONGeneric defaultOptions +readTree = readJSONGeneric opts + +writeTree :: forall a. (Generic a) => Tree a -> String +writeTree = toJSONGeneric opts main :: forall eff. Eff (console :: CONSOLE | eff) Unit main = do - case readTree json :: F (Tree (Maybe Boolean)) of - Right tree -> log (gShow tree) + let json = writeTree tree + log json + case readTree json of + Right tree1 -> do + log (gShow tree1) + print (gEq tree tree1) Left err -> print err From cb66769b312ebf15273fdc3a729c6344b3a3ad2b Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Wed, 18 Nov 2015 13:50:28 -0800 Subject: [PATCH 3/3] Bump dependencies --- bower.json | 2 +- src/Data/Foreign/Generic.purs | 4 +++- test/Main.purs | 1 - 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/bower.json b/bower.json index e198f84..96e84a9 100644 --- a/bower.json +++ b/bower.json @@ -18,7 +18,7 @@ "purescript-eff": "^0.1.2", "purescript-exceptions": "~0.3.1", "purescript-foreign": "~0.7.1", - "purescript-generics": "^0.5.0", + "purescript-generics": "^0.7.0", "purescript-globals": "~0.2.1", "purescript-maps": "~0.5.2", "purescript-nullable": "~0.2.1" diff --git a/src/Data/Foreign/Generic.purs b/src/Data/Foreign/Generic.purs index c9e884c..48ead64 100644 --- a/src/Data/Foreign/Generic.purs +++ b/src/Data/Foreign/Generic.purs @@ -22,6 +22,8 @@ import Control.Monad.Eff.Exception.Unsafe (unsafeThrow) import Global.Unsafe (unsafeStringify) +import Type.Proxy (Proxy(..)) + type Options = { sumEncoding :: SumEncoding , unwrapNewtypes :: Boolean @@ -49,7 +51,7 @@ defaultOptions = -- | Read a value which has a `Generic` type. readGeneric :: forall a. (Generic a) => Options -> Foreign -> F a readGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, maybeAsNull } = - map fromSpineUnsafe <<< go (toSignature (anyProxy :: Proxy a)) + map fromSpineUnsafe <<< go (toSignature (Proxy :: Proxy a)) where fromSpineUnsafe :: GenericSpine -> a fromSpineUnsafe sp = diff --git a/test/Main.purs b/test/Main.purs index b93ffc9..b6ff4e2 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -2,7 +2,6 @@ module Test.Main where import Prelude -import Data.Maybe import Data.Either import Data.Generic import Data.Foreign