Skip to content

Commit e95bfdb

Browse files
paf31paf31
committed
Merge pull request #3 from paf31/new-deriving
Updates for new deriving
2 parents 566cf51 + cb66769 commit e95bfdb

File tree

4 files changed

+199
-61
lines changed

4 files changed

+199
-61
lines changed

‎bower.json‎

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -9,13 +9,18 @@
99
"bower_components",
1010
"output"
1111
],
12-
"repository": {
13-
"type": "git",
12+
"repository": {
13+
"type": "git",
1414
"url": "git://github.com/paf31/purescript-foreign-generic.git"
15-
},
15+
},
1616
"dependencies": {
1717
"purescript-console": "^0.1.0",
18-
"purescript-foreign": "~0.7.0",
19-
"purescript-generics": "^0.5.0"
18+
"purescript-eff": "^0.1.2",
19+
"purescript-exceptions": "~0.3.1",
20+
"purescript-foreign": "~0.7.1",
21+
"purescript-generics": "^0.7.0",
22+
"purescript-globals": "~0.2.1",
23+
"purescript-maps": "~0.5.2",
24+
"purescript-nullable": "~0.2.1"
2025
}
2126
}

‎docs/Data/Foreign/Generic.md‎

Lines changed: 37 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,54 @@
11
## Module Data.Foreign.Generic
22

3+
#### `Options`
4+
5+
``` purescript
6+
type Options = { sumEncoding :: SumEncoding, unwrapNewtypes :: Boolean, unwrapSingleArgumentConstructors :: Boolean, maybeAsNull :: Boolean }
7+
```
8+
9+
#### `SumEncoding`
10+
11+
``` purescript
12+
data SumEncoding
13+
= TaggedObject { tagFieldName :: String, contentsFieldName :: String }
14+
```
15+
16+
#### `defaultOptions`
17+
18+
``` purescript
19+
defaultOptions :: Options
20+
```
21+
322
#### `readGeneric`
423

524
``` purescript
6-
readGeneric :: forall a. (Generic a) => Foreign -> F a
25+
readGeneric :: forall a. (Generic a) => Options -> Foreign -> F a
726
```
827

928
Read a value which has a `Generic` type.
1029

30+
#### `toForeignGeneric`
31+
32+
``` purescript
33+
toForeignGeneric :: forall a. (Generic a) => Options -> a -> Foreign
34+
```
35+
36+
Generate a `Foreign` value compatible with the `readGeneric` function.
37+
1138
#### `readJSONGeneric`
1239

1340
``` purescript
14-
readJSONGeneric :: forall a. (Generic a) => String -> F a
41+
readJSONGeneric :: forall a. (Generic a) => Options -> String -> F a
1542
```
1643

1744
Read a value which has a `Generic` type from a JSON String
1845

46+
#### `toJSONGeneric`
47+
48+
``` purescript
49+
toJSONGeneric :: forall a. (Generic a) => Options -> a -> String
50+
```
51+
52+
Write a value which has a `Generic` type as a JSON String
53+
1954

‎src/Data/Foreign/Generic.purs‎

Lines changed: 128 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -1,50 +1,149 @@
11
module Data.Foreign.Generic where
2-
2+
33
import Prelude
44

55
import Data.Maybe
6-
import Data.Maybe.Unsafe (fromJust)
7-
import Data.Array (zipWithA)
6+
import Data.Array (zipWith, zipWithA, sortBy)
7+
import Data.Tuple
88
import Data.Either
99
import Data.Foreign
1010
import Data.Foreign.Class
1111
import Data.Foreign.Index
12+
import Data.Function (on)
13+
import Data.Nullable (toNullable)
1214
import Data.Generic
1315
import Data.Foldable (find)
1416
import Data.Traversable (for)
17+
import Data.List as L
18+
import Data.StrMap as S
1519

16-
import Control.Alt ((<|>))
17-
import Control.Plus (empty)
1820
import Control.Bind ((>=>))
19-
import Control.Monad (when)
20-
21+
import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)
22+
23+
import Global.Unsafe (unsafeStringify)
24+
25+
import Type.Proxy (Proxy(..))
26+
27+
type Options =
28+
{ sumEncoding :: SumEncoding
29+
, unwrapNewtypes :: Boolean
30+
, unwrapSingleArgumentConstructors :: Boolean
31+
, maybeAsNull :: Boolean
32+
}
33+
34+
data SumEncoding
35+
= TaggedObject
36+
{ tagFieldName :: String
37+
, contentsFieldName :: String
38+
}
39+
40+
defaultOptions :: Options
41+
defaultOptions =
42+
{ sumEncoding: TaggedObject
43+
{ tagFieldName: "tag"
44+
, contentsFieldName: "contents"
45+
}
46+
, unwrapNewtypes: false
47+
, unwrapSingleArgumentConstructors: true
48+
, maybeAsNull: true
49+
}
50+
2151
-- | Read a value which has a `Generic` type.
22-
readGeneric :: forall a. (Generic a) => Foreign -> F a
23-
readGeneric = map (fromJust <<< fromSpine) <<< go (toSignature (anyProxy :: Proxy a))
52+
readGeneric :: forall a. (Generic a) => Options -> Foreign -> F a
53+
readGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, maybeAsNull } =
54+
map fromSpineUnsafe <<< go (toSignature (Proxy :: Proxy a))
2455
where
56+
fromSpineUnsafe :: GenericSpine -> a
57+
fromSpineUnsafe sp =
58+
case fromSpine sp of
59+
Nothing -> unsafeThrow "Invalid spine for signature"
60+
Just a -> a
61+
2562
go :: GenericSignature -> Foreign -> F GenericSpine
2663
go SigNumber f = map SNumber (readNumber f)
2764
go SigInt f = map SInt (readInt f)
65+
go SigChar f = map SChar (readChar f)
2866
go SigString f = map SString (readString f)
2967
go SigBoolean f = map SBoolean (readBoolean f)
30-
go (SigArray el) f = do arr <- readArray f
31-
els <- for arr \f -> do
32-
e <- go (el unit) f
33-
return (const e)
34-
return (SArray els)
35-
go (SigRecord props) f = do fs <- for props \prop -> do pf <- f ! prop.recLabel
36-
sp <- go (prop.recValue unit) pf
37-
return { recLabel: prop.recLabel, recValue: const sp }
38-
return (SRecord fs)
39-
go (SigProd alts) f = do
40-
tag <- prop "tag" f >>= readString
41-
case find (\alt -> alt.sigConstructor == tag) alts of
42-
Nothing -> Left (TypeMismatch "" tag)
43-
Just { sigValues: sigValues } -> do
44-
vals <- prop "values" f >>= readArray
45-
sps <- zipWithA (\k -> go (k unit)) sigValues vals
46-
return (SProd tag (map const sps))
47-
68+
go (SigArray el) f = do
69+
arr <- readArray f
70+
els <- for arr \f -> do
71+
e <- go (el unit) f
72+
return (const e)
73+
return (SArray els)
74+
go (SigRecord props) f = do
75+
fs <- for props \prop -> do
76+
pf <- f ! prop.recLabel
77+
sp <- go (prop.recValue unit) pf
78+
return { recLabel: prop.recLabel, recValue: const sp }
79+
return (SRecord fs)
80+
go (SigProd _ [{ sigConstructor: tag, sigValues: [sig] }]) f | unwrapNewtypes = do
81+
sp <- go (sig unit) f
82+
return (SProd tag [\_ -> sp])
83+
go (SigProd "Data.Maybe.Maybe" [{ sigValues: [just] }, _]) f | maybeAsNull = do
84+
if isNull f || isUndefined f
85+
then return (SProd "Data.Maybe.Nothing" [])
86+
else do sp <- go (just unit) f
87+
return (SProd "Data.Maybe.Just" [\_ -> sp])
88+
go (SigProd _ alts) f =
89+
case sumEncoding of
90+
TaggedObject { tagFieldName, contentsFieldName } -> do
91+
tag <- prop tagFieldName f >>= readString
92+
case find (\alt -> alt.sigConstructor == tag) alts of
93+
Nothing -> Left (TypeMismatch ("one of " <> show (map _.sigConstructor alts)) tag)
94+
Just { sigValues: [] } -> return (SProd tag [])
95+
Just { sigValues: [sig] } | unwrapSingleArgumentConstructors -> do
96+
val <- prop contentsFieldName f
97+
sp <- go (sig unit) val
98+
return (SProd tag [\_ -> sp])
99+
Just { sigValues } -> do
100+
vals <- prop contentsFieldName f >>= readArray
101+
sps <- zipWithA (\k -> go (k unit)) sigValues vals
102+
return (SProd tag (map const sps))
103+
104+
-- | Generate a `Foreign` value compatible with the `readGeneric` function.
105+
toForeignGeneric :: forall a. (Generic a) => Options -> a -> Foreign
106+
toForeignGeneric { sumEncoding, unwrapNewtypes, unwrapSingleArgumentConstructors, maybeAsNull } = go (toSignature (Proxy :: Proxy a)) <<< toSpine
107+
where
108+
go :: GenericSignature -> GenericSpine -> Foreign
109+
go _ (SNumber n) = toForeign n
110+
go _ (SInt i) = toForeign i
111+
go _ (SChar c) = toForeign c
112+
go _ (SString s) = toForeign s
113+
go _ (SBoolean b) = toForeign b
114+
go (SigArray sig) (SArray arr) = toForeign (map (go (sig unit) <<< ($ unit)) arr)
115+
go (SigRecord sigs) (SRecord sps) = toForeign (S.fromList (L.toList pairs))
116+
where
117+
pairs :: Array (Tuple String Foreign)
118+
pairs = zipWith pair (sortBy (compare `on` _.recLabel) sigs)
119+
(sortBy (compare `on` _.recLabel) sps)
120+
121+
pair sig sp | sig.recLabel == sp.recLabel = Tuple sig.recLabel (go (sig.recValue unit) (sp.recValue unit))
122+
| otherwise = unsafeThrow "Record fields do not match signature"
123+
go (SigProd "Data.Maybe.Maybe" _) (SProd "Data.Maybe.Nothing" []) | maybeAsNull = toForeign (toNullable Nothing)
124+
go (SigProd "Data.Maybe.Maybe" [{ sigValues: [just] }, _]) (SProd "Data.Maybe.Just" [sp]) | maybeAsNull = go (just unit) (sp unit)
125+
go (SigProd _ [{ sigConstructor: _, sigValues: [sig] }]) (SProd _ [sp]) | unwrapNewtypes = go (sig unit) (sp unit)
126+
go (SigProd _ alts) (SProd tag sps) =
127+
case sumEncoding of
128+
TaggedObject { tagFieldName, contentsFieldName } ->
129+
case find (\alt -> alt.sigConstructor == tag) alts of
130+
Nothing -> unsafeThrow ("No signature for data constructor " <> tag)
131+
Just { sigValues } ->
132+
case zipWith (\sig sp -> go (sig unit) (sp unit)) sigValues sps of
133+
[] -> toForeign (S.fromList (L.singleton (Tuple tagFieldName (toForeign tag))))
134+
[f] | unwrapSingleArgumentConstructors ->
135+
toForeign (S.fromList (L.toList [ Tuple tagFieldName (toForeign tag)
136+
, Tuple contentsFieldName f
137+
]))
138+
fs -> toForeign (S.fromList (L.toList [ Tuple tagFieldName (toForeign tag)
139+
, Tuple contentsFieldName (toForeign fs)
140+
]))
141+
go _ _ = unsafeThrow "Invalid spine for signature"
142+
48143
-- | Read a value which has a `Generic` type from a JSON String
49-
readJSONGeneric :: forall a. (Generic a) => String -> F a
50-
readJSONGeneric = parseJSON >=> readGeneric
144+
readJSONGeneric :: forall a. (Generic a) => Options -> String -> F a
145+
readJSONGeneric opts = parseJSON >=> readGeneric opts
146+
147+
-- | Write a value which has a `Generic` type as a JSON String
148+
toJSONGeneric :: forall a. (Generic a) => Options -> a -> String
149+
toJSONGeneric opts = toForeignGeneric opts >>> unsafeStringify

‎test/Main.purs‎

Lines changed: 24 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -7,38 +7,37 @@ import Data.Generic
77
import Data.Foreign
88
import Data.Foreign.Generic
99

10+
import Control.Monad.Eff
1011
import Control.Monad.Eff.Console
1112

12-
data Tree a = Leaf a | Branch (Tree a) (Tree a)
13+
-- | Balanced leaf trees
14+
data Tree a = Leaf a | Branch (Tree (Array a))
1315

1416
derive instance genericTree :: (Generic a) => Generic (Tree a)
1517

16-
json :: String
17-
json = """
18-
{
19-
"tag": "Branch",
20-
"values": [
21-
{
22-
"tag": "Leaf",
23-
"values": [
24-
true
25-
]
26-
},
27-
{
28-
"tag": "Leaf",
29-
"values": [
30-
false
31-
]
32-
}
33-
]
34-
}
35-
36-
"""
18+
buildTree :: forall a. (a -> Array a) -> Int -> a -> Tree a
19+
buildTree _ 0 a = Leaf a
20+
buildTree f n a = Branch $ buildTree (map f) (n - 1) (f a)
21+
22+
-- A balanced binary tree of depth 5
23+
tree :: Tree Int
24+
tree = buildTree (\i -> [2 * i, 2 * i + 1]) 5 0
25+
26+
opts :: Options
27+
opts = defaultOptions { unwrapNewtypes = true }
3728

3829
readTree :: forall a. (Generic a) => String -> F (Tree a)
39-
readTree = readJSONGeneric
30+
readTree = readJSONGeneric opts
31+
32+
writeTree :: forall a. (Generic a) => Tree a -> String
33+
writeTree = toJSONGeneric opts
4034

35+
main :: forall eff. Eff (console :: CONSOLE | eff) Unit
4136
main = do
42-
case readTree json :: F (Tree Boolean) of
43-
Right tree -> log (gShow tree)
37+
let json = writeTree tree
38+
log json
39+
case readTree json of
40+
Right tree1 -> do
41+
log (gShow tree1)
42+
print (gEq tree tree1)
4443
Left err -> print err

0 commit comments

Comments
 (0)