diff --git a/bower.json b/bower.json index a95895c..96e84a9 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": "~0.7.0", - "purescript-generics": "^0.5.0" + "purescript-eff": "^0.1.2", + "purescript-exceptions": "~0.3.1", + "purescript-foreign": "~0.7.1", + "purescript-generics": "^0.7.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 e050640..31ab69e 100644 --- a/docs/Data/Foreign/Generic.md +++ b/docs/Data/Foreign/Generic.md @@ -1,19 +1,54 @@ ## 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. +#### `toForeignGeneric` + +``` purescript +toForeignGeneric :: forall a. (Generic a) => Options -> a -> Foreign +``` + +Generate a `Foreign` value compatible with the `readGeneric` function. + #### `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 +#### `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 76fa4c8..48ead64 100644 --- a/src/Data/Foreign/Generic.purs +++ b/src/Data/Foreign/Generic.purs @@ -1,50 +1,149 @@ module Data.Foreign.Generic where - + import Prelude import Data.Maybe -import Data.Maybe.Unsafe (fromJust) -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.Alt ((<|>)) -import Control.Plus (empty) import Control.Bind ((>=>)) -import Control.Monad (when) - +import Control.Monad.Eff.Exception.Unsafe (unsafeThrow) + +import Global.Unsafe (unsafeStringify) + +import Type.Proxy (Proxy(..)) + +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 } = + map fromSpineUnsafe <<< go (toSignature (Proxy :: 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) + 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 || isUndefined 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)) + +-- | 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) => String -> F a -readJSONGeneric = parseJSON >=> readGeneric +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 6e1dbe4..b6ff4e2 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -7,38 +7,37 @@ 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) +-- | Balanced leaf trees +data Tree a = Leaf a | Branch (Tree (Array a)) derive instance genericTree :: (Generic a) => Generic (Tree a) -json :: String -json = """ - { - "tag": "Branch", - "values": [ - { - "tag": "Leaf", - "values": [ - true - ] - }, - { - "tag": "Leaf", - "values": [ - false - ] - } - ] -} - - """ +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 +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 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