Skip to content
This repository was archived by the owner on Jun 15, 2023. It is now read-only.

Commit 0bb569e

Browse files
jonsterlingjonsterling
committed
SD-1575: add parser (#2)
* Add parser * add parse-render-round-trip property test; fix bugs
1 parent 0c276b5 commit 0bb569e

5 files changed

Lines changed: 322 additions & 5 deletions

File tree

‎bower.json‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@
1717
"purescript-fixed-points": "^0.1.0",
1818
"purescript-hugenums": "^1.3.1",
1919
"purescript-maps": "^0.5.7",
20+
"purescript-parsing": "^0.8.0",
2021
"purescript-strongcheck": "^0.14.7"
2122
}
2223
}

‎src/Data/Json/Extended.purs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,13 +22,16 @@ module Data.Json.Extended
2222
, array
2323

2424
, renderEJson
25+
, parseEJson
2526

2627
, arbitraryEJsonOfSize
2728
, arbitraryJsonEncodableEJsonOfSize
2829
) where
2930

3031
import Prelude
3132

33+
import Control.Lazy as Lazy
34+
3235
import Data.Eq1 (eq1)
3336
import Data.Ord1 (compare1)
3437
import Data.Argonaut.Encode (class EncodeJson, encodeJson)
@@ -45,6 +48,8 @@ import Data.Tuple as T
4548
import Test.StrongCheck as SC
4649
import Test.StrongCheck.Gen as Gen
4750

51+
import Text.Parsing.Parser as P
52+
4853
import Data.Json.Extended.Signature as Sig
4954

5055
newtype EJson = EJson (Mu.Mu Sig.EJsonF)
@@ -140,6 +145,17 @@ renderEJson (EJson x) =
140145
renderEJson
141146
(EJson <$> Mu.unroll x)
142147

148+
-- | A closed parser of SQL^2 constant expressions
149+
parseEJson
150+
∷ forall m
151+
. (Monad m)
152+
⇒ P.ParserT String m EJson
153+
parseEJson =
154+
Lazy.fix \f →
155+
roll <$>
156+
Sig.parseEJsonF f
157+
158+
143159
null ∷ EJson
144160
null = roll Sig.Null
145161

‎src/Data/Json/Extended/Signature.purs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,14 @@
11
module Data.Json.Extended.Signature
22
( module Core
33
, module Render
4+
, module Parse
45
, module Gen
56
, module Json
67
) where
78

89
import Data.Json.Extended.Signature.Core as Core
910
import Data.Json.Extended.Signature.Render as Render
11+
import Data.Json.Extended.Signature.Parse as Parse
1012
import Data.Json.Extended.Signature.Gen as Gen
1113
import Data.Json.Extended.Signature.Json as Json
1214

‎src/Data/Json/Extended/Signature/Parse.purs‎

Lines changed: 280 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,280 @@
1+
module Data.Json.Extended.Signature.Parse
2+
( parseEJsonF
3+
) where
4+
5+
import Prelude
6+
7+
import Control.Alt ((<|>))
8+
import Control.Apply ((*>), (<*))
9+
import Data.Functor ((<$), ($>))
10+
11+
import Data.Array as A
12+
import Data.Foldable as F
13+
import Data.HugeNum as HN
14+
import Data.Int as Int
15+
import Data.List as L
16+
import Data.Maybe as M
17+
import Data.String as S
18+
import Data.Tuple as T
19+
20+
import Data.Json.Extended.Signature.Core (EJsonF(..))
21+
22+
import Text.Parsing.Parser as P
23+
import Text.Parsing.Parser.Combinators as PC
24+
import Text.Parsing.Parser.String as PS
25+
26+
parens
27+
∷ ∀ m a
28+
. (Monad m)
29+
⇒ P.ParserT String m a
30+
→ P.ParserT String m a
31+
parens =
32+
PC.between
33+
(PS.string "(")
34+
(PS.string ")")
35+
36+
squares
37+
∷ ∀ m a
38+
. (Monad m)
39+
⇒ P.ParserT String m a
40+
→ P.ParserT String m a
41+
squares =
42+
PC.between
43+
(PS.string "[")
44+
(PS.string "]")
45+
46+
braces
47+
∷ ∀ m a
48+
. (Monad m)
49+
⇒ P.ParserT String m a
50+
→ P.ParserT String m a
51+
braces =
52+
PC.between
53+
(PS.string "{")
54+
(PS.string "}")
55+
56+
commaSep
57+
∷ ∀ m a
58+
. (Monad m)
59+
⇒ P.ParserT String m a
60+
→ P.ParserT String m (L.List a)
61+
commaSep =
62+
flip PC.sepBy $
63+
PS.skipSpaces
64+
*> PS.string ","
65+
<* PS.skipSpaces
66+
67+
stringLiteral
68+
∷ ∀ m
69+
. (Monad m)
70+
⇒ P.ParserT String m String
71+
stringLiteral =
72+
PC.between quote quote (A.many stringChar)
73+
<#> S.fromCharArray
74+
75+
where
76+
quote = PS.string "\""
77+
78+
stringChar =
79+
PC.try stringEscape
80+
<|> stringLetter
81+
82+
stringLetter =
83+
PS.satisfy \c →
84+
c /= '"'
85+
86+
stringEscape =
87+
PS.string "\\\"" $> '"'
88+
89+
taggedLiteral
90+
∷ ∀ m
91+
. (Monad m)
92+
⇒ String
93+
→ P.ParserT String m String
94+
taggedLiteral tag =
95+
PC.try $
96+
PS.string tag
97+
*> parens stringLiteral
98+
99+
anyString
100+
∷ ∀ m
101+
. (Monad m)
102+
⇒ P.ParserT String m String
103+
anyString =
104+
A.many PS.anyChar
105+
<#> S.fromCharArray
106+
107+
parseBoolean
108+
∷ ∀ m
109+
. (Monad m)
110+
⇒ P.ParserT String m Boolean
111+
parseBoolean =
112+
PC.choice
113+
[ true <$ PS.string "true"
114+
, false <$ PS.string "false"
115+
]
116+
117+
parseDigit
118+
∷ ∀ m
119+
. (Monad m)
120+
⇒ P.ParserT String m Int
121+
parseDigit =
122+
PC.choice
123+
[ 0 <$ PS.string "0"
124+
, 1 <$ PS.string "1"
125+
, 2 <$ PS.string "2"
126+
, 3 <$ PS.string "3"
127+
, 4 <$ PS.string "4"
128+
, 5 <$ PS.string "5"
129+
, 6 <$ PS.string "6"
130+
, 7 <$ PS.string "7"
131+
, 8 <$ PS.string "8"
132+
, 9 <$ PS.string "9"
133+
]
134+
135+
many1
136+
∷ ∀ m s a
137+
. (Monad m)
138+
⇒ P.ParserT s m a
139+
→ P.ParserT s m (L.List a)
140+
many1 p =
141+
L.Cons
142+
<$> p
143+
<*> L.many p
144+
145+
parseNat
146+
∷ ∀ m
147+
. (Monad m)
148+
⇒ P.ParserT String m Int
149+
parseNat =
150+
many1 parseDigit
151+
<#> F.foldl (\a i → a * 10 + i) 0
152+
153+
parseNegative
154+
∷ ∀ m a
155+
. (Monad m, Ring a)
156+
⇒ P.ParserT String m a
157+
→ P.ParserT String m a
158+
parseNegative p =
159+
PS.string "-"
160+
*> PS.skipSpaces
161+
*> p
162+
<#> negate
163+
164+
parsePositive
165+
∷ ∀ m a
166+
. (Monad m, Ring a)
167+
⇒ P.ParserT String m a
168+
→ P.ParserT String m a
169+
parsePositive p =
170+
PC.optional (PS.string "+" *> PS.skipSpaces)
171+
*> p
172+
173+
parseSigned
174+
∷ ∀ m a
175+
. (Monad m, Ring a)
176+
⇒ P.ParserT String m a
177+
→ P.ParserT String m a
178+
parseSigned p =
179+
parseNegative p
180+
<|> parsePositive p
181+
182+
parseInt
183+
∷ ∀ m
184+
. (Monad m)
185+
⇒ P.ParserT String m Int
186+
parseInt =
187+
parseSigned parseNat
188+
189+
parseExponent
190+
∷ ∀ m
191+
. (Monad m)
192+
⇒ P.ParserT String m Int
193+
parseExponent =
194+
(PS.string "e" <|> PS.string "E")
195+
*> parseInt
196+
197+
parsePositiveScientific
198+
∷ ∀ m
199+
. (Monad m)
200+
⇒ P.ParserT String m HN.HugeNum
201+
parsePositiveScientific = do
202+
let ten = HN.fromNumber 10.0
203+
lhs ← PC.try $ fromInt <$> parseNat <* PS.string "."
204+
rhs ← A.many parseDigit <#> F.foldr (\d f → divNum (f + fromInt d) ten) zero
205+
exp ← parseExponent
206+
pure $ (lhs + rhs) * safePow ten exp
207+
208+
where
209+
fromInt = HN.fromNumber <<< Int.toNumber
210+
211+
-- TODO: remove when HugeNum adds division
212+
divNum a b =
213+
HN.fromNumber $
214+
HN.toNumber a / HN.toNumber b
215+
216+
-- To work around: https://github.com/Thimoteus/purescript-hugenums/issues/6
217+
safePow a 0 = one
218+
safePow a n = HN.pow a n
219+
220+
parseHugeNum
221+
∷ ∀ m
222+
. (Monad m)
223+
⇒ P.ParserT String m HN.HugeNum
224+
parseHugeNum = do
225+
chars ← A.many (PS.oneOf ['0','1','2','3','4','5','6','7','8','9','-','.']) <#> S.fromCharArray
226+
case HN.fromString chars of
227+
M.Just num → pure num
228+
M.Nothing → P.fail $ "Failed to parse decimal: " <> chars
229+
230+
parseScientific
231+
∷ ∀ m
232+
. (Monad m)
233+
⇒ P.ParserT String m HN.HugeNum
234+
parseScientific =
235+
parseSigned parsePositiveScientific
236+
237+
parseDecimal
238+
∷ ∀ m
239+
. (Monad m)
240+
⇒ P.ParserT String m HN.HugeNum
241+
parseDecimal =
242+
parseHugeNum
243+
<|> parseScientific
244+
245+
-- | Parse one layer of structure.
246+
parseEJsonF
247+
∷ ∀ m a
248+
. (Monad m)
249+
⇒ P.ParserT String m a
250+
→ P.ParserT String m (EJsonF a)
251+
parseEJsonF rec =
252+
PC.choice $
253+
[ Null <$ PS.string "null"
254+
, Boolean <$> parseBoolean
255+
, Decimal <$> PC.try parseDecimal
256+
, Integer <$> parseInt
257+
, String <$> stringLiteral
258+
, Timestamp <$> taggedLiteral "TIMESTAMP"
259+
, Time <$> taggedLiteral "TIME"
260+
, Date <$> taggedLiteral "DATE"
261+
, Interval <$> taggedLiteral "INTERVAL"
262+
, ObjectId <$> taggedLiteral "OID"
263+
, OrderedSet <<< L.fromList <$> parens (commaSep rec)
264+
, Array <<< L.fromList <$> squares (commaSep rec)
265+
, Object <<< L.fromList <$> braces (commaSep parseAssignment)
266+
]
267+
268+
where
269+
parseColon ∷ P.ParserT String m String
270+
parseColon =
271+
PS.skipSpaces
272+
*> PS.string ":"
273+
<* PS.skipSpaces
274+
275+
parseAssignment ∷ P.ParserT String m (T.Tuple a a)
276+
parseAssignment =
277+
T.Tuple
278+
<$> rec <* parseColon
279+
<*> rec
280+

‎test/Main.purs‎

Lines changed: 23 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,9 @@ import Control.Monad.Eff.Console (CONSOLE)
99
import Data.Argonaut.Decode (decodeJson)
1010
import Data.Argonaut.Encode (encodeJson)
1111
import Data.Either as E
12-
import Data.Json.Extended (EJson, arbitraryJsonEncodableEJsonOfSize)
12+
import Data.Json.Extended (EJson, arbitraryJsonEncodableEJsonOfSize, arbitraryEJsonOfSize, renderEJson, parseEJson)
13+
14+
import Text.Parsing.Parser as P
1315

1416
import Test.StrongCheck as SC
1517

@@ -19,14 +21,30 @@ type TestEffects =
1921
, console ∷ CONSOLE
2022
)
2123

24+
newtype ArbJsonEncodableEJson = ArbJsonEncodableEJson EJson
2225
newtype ArbEJson = ArbEJson EJson
2326

27+
instance arbitraryArbJsonEncodableEJson ∷ SC.Arbitrary ArbJsonEncodableEJson where
28+
arbitrary = ArbJsonEncodableEJson <$> arbitraryJsonEncodableEJsonOfSize 2
29+
2430
instance arbitraryArbEJson ∷ SC.Arbitrary ArbEJson where
25-
arbitrary = ArbEJson <$> arbitraryJsonEncodableEJsonOfSize 2
31+
arbitrary = ArbEJson <$> arbitraryEJsonOfSize 2
2632

27-
main :: Eff TestEffects Unit
28-
main = do
29-
SC.quickCheck \(ArbEJson x) →
33+
testJsonSerialization ∷ Eff TestEffects Unit
34+
testJsonSerialization =
35+
SC.quickCheck \(ArbJsonEncodableEJson x) →
3036
case decodeJson (encodeJson x) of
3137
E.Right y → x == y SC.<?> "Mismatch:\n" <> show x <> "\n" <> show y
3238
E.Left err → SC.Failed $ "Parse error: " <> err
39+
40+
testRenderParse ∷ Eff TestEffects Unit
41+
testRenderParse =
42+
SC.quickCheck \(ArbEJson x) →
43+
case P.runParser (renderEJson x) parseEJson of
44+
E.Right y → x == y SC.<?> "Mismatch:\n" <> show x <> "\n" <> show y
45+
E.Left err → SC.Failed $ "Parse error: " <> show err <> " when parsing:\n\n " <> renderEJson x <> "\n\n"
46+
47+
main :: Eff TestEffects Unit
48+
main = do
49+
testJsonSerialization
50+
testRenderParse

0 commit comments

Comments
 (0)