/
edn.purs
342 lines (312 loc) · 11.2 KB
/
edn.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
module Cirru.Edn
( CirruEdn(..)
, parseCirruEdn
, writeCirruEdn
) where
import Prelude
import Cirru.Node (CirruNode(..), isCirruLeaf)
import Cirru.Parser (parseCirru)
import Cirru.Writer (writeCirru)
import Data.Array (head, length, zip, (!!), (:))
import Data.Array as Array
import Data.Array as DataArr
import Data.Either (Either(..))
import Data.Map as DataMap
import Data.Map as Map
import Data.Map.Internal (Map)
import Data.Maybe (Maybe(..), fromJust)
import Data.Number as DataNum
import Data.Set (Set)
import Data.Set as DataSet
import Data.Set as Set
import Data.String.Common (joinWith)
import Data.String.NonEmpty.CodeUnits (charAt, drop)
import Data.String.NonEmpty.Internal (fromString, toString)
import Data.String.Regex (regex, test)
import Data.String.Regex.Flags (noFlags)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)
-- | only uused for displaying, internall it's using Tuple
data CrEdnKv
= CrEdnKv CirruEdn CirruEdn
instance showCrEdnKv :: Show CrEdnKv where
show (CrEdnKv k v) = "(" <> (show k) <> " " <> (show v) <> ")"
instance eqCrEdnKv :: Eq CrEdnKv where
eq (CrEdnKv k1 v1) (CrEdnKv k2 v2) = k1 == k2 && v1 == v2
-- | short handle accessing Array
arrayGet :: forall a. Array a -> Int -> a
arrayGet xs n = unsafePartial $ fromJust $ xs !! n
-- | data structure for Cirru EDN.Boolean
-- | notice that Map and Set are not fully realized
data CirruEdn
= CrEdnNil
| CrEdnBool Boolean
| CrEdnNumber Number
| CrEdnSymbol String
| CrEdnKeyword String
| CrEdnString String
| CrEdnQuote CirruNode
| CrEdnList (Array CirruEdn)
| CrEdnSet (Set CirruEdn)
| CrEdnMap (Map CirruEdn CirruEdn)
| CrEdnRecord String (Array String) (Array CirruEdn)
-- | if parsing failed, original Cirru Nodes are returned
type CrEdnParsed
= Either CirruNode CirruEdn
-- | tests if thats a float
matchFloat :: String -> Boolean
matchFloat s = case (regex "^-?(\\d+)(\\.\\d*)?$" noFlags) of
Right pattern -> test pattern s
Left failure -> false
-- | extra from Cirru Nodes
extractCirruEdn :: CirruNode -> CrEdnParsed
extractCirruEdn (CirruLeaf s) = case (fromString s) of
Just ns -> case (charAt 0 ns) of
Just '\'' -> case (drop 1 ns) of
Just result -> pure $ CrEdnSymbol $ toString result
Nothing -> Left (CirruLeaf s)
Just ':' -> case (drop 1 ns) of
Just result -> pure $ CrEdnKeyword $ toString result
Nothing -> Left (CirruLeaf s)
Just '"' -> case (drop 1 ns) of
Just result -> pure $ CrEdnString $ toString result
Nothing -> Left (CirruLeaf s)
Just '|' -> case (drop 1 ns) of
Just result -> pure $ CrEdnString $ toString result
Nothing -> Left (CirruLeaf s)
Just _ -> case s of
"true" -> pure $ CrEdnBool true
"false" -> pure $ CrEdnBool false
"nil" -> pure $ CrEdnNil
_ ->
if (matchFloat s) then case (DataNum.fromString s) of
Just n -> pure $ CrEdnNumber n
Nothing -> Left (CirruLeaf s)
else
Left (CirruLeaf s)
Nothing -> Left (CirruLeaf s)
Nothing -> Left (CirruLeaf s)
extractCirruEdn (CirruList xs) = case (xs !! 0) of
Nothing -> Left (CirruList xs)
Just x0 -> case x0 of
CirruList _ -> Left (CirruList xs)
CirruLeaf x -> case x of
"quote" -> case (xs !! 1) of
Nothing -> Left (CirruList xs)
Just content -> pure $ CrEdnQuote content
"do" -> case (xs !! 1) of
Nothing -> Left (CirruList xs)
Just content -> extractCirruEdn content
"[]" -> extractList (DataArr.drop 1 xs)
"{}" -> extractMap (DataArr.drop 1 xs)
"#{}" -> extractSet (DataArr.drop 1 xs)
"%{}" ->
if (length xs) >= 2 then
extractRecord (arrayGet xs 1) (Array.drop 2 xs)
else
Left (CirruList xs)
_ -> Left (CirruList xs)
-- | turn CirruEdn into CirruNode
assembleCirruNode :: CirruEdn -> CirruNode
assembleCirruNode edn = case edn of
CrEdnNil -> CirruLeaf "nil"
CrEdnBool t -> CirruLeaf (show t)
CrEdnNumber n -> CirruLeaf (show n)
CrEdnSymbol s -> CirruLeaf ("'" <> s)
CrEdnKeyword s -> CirruLeaf (":" <> s)
CrEdnString s -> CirruLeaf ("|" <> s)
CrEdnQuote xs -> CirruList [ CirruLeaf "quote", xs ]
CrEdnList xs -> CirruList ((CirruLeaf "[]") : (map assembleCirruNode xs))
CrEdnSet xs -> CirruList ((CirruLeaf "#{}") : (map assembleCirruNode (Set.toUnfoldable xs)))
CrEdnMap m -> CirruList ((CirruLeaf "{}") : pairs)
where
pairs =
map
( \(Tuple k v) ->
CirruList [ assembleCirruNode k, assembleCirruNode v ]
)
(Map.toUnfoldable m)
CrEdnRecord name fields values -> CirruList ((CirruLeaf "%{}") : (CirruLeaf name) : pairs)
where
pairs =
map
( \(Tuple k v) ->
CirruList [ (CirruLeaf k), assembleCirruNode v ]
)
(zip fields values)
-- | returns false if it's a leaf,
-- | returns false if there's array inside array
allLeaves :: CirruNode -> Boolean
allLeaves ys = case ys of
CirruLeaf _ -> false
CirruList xs -> case xs !! 0 of
Just x0 -> case x0 of
CirruList _ -> false
CirruLeaf _ -> allLeaves $ CirruList (DataArr.drop 1 xs)
Nothing -> true
getLeafStr :: CirruNode -> Either CirruNode String
getLeafStr (CirruList xs) = Left (CirruList xs)
getLeafStr (CirruLeaf s) = Right s
parseRecordPair :: CirruNode -> Either CirruNode (Tuple String CirruEdn)
parseRecordPair node = case node of
CirruList xs ->
if Array.length xs == 2 then case xs !! 0, xs !! 1 of
Just (CirruLeaf k), Just v -> do
edn <- extractCirruEdn v
Right (Tuple k edn)
Just a, _ -> Left node
Nothing, _ -> Left node
else
Left node
CirruLeaf _ -> Left node
extractRecord :: CirruNode -> Array CirruNode -> CrEdnParsed
extractRecord name pairs = do
nameInString <-
if isCirruLeaf name then
getLeafStr name
else
Left name
recordPairs <- traverse parseRecordPair pairs
let
fieldsString = map fst recordPairs
let
valueItems = map snd recordPairs
Right $ CrEdnRecord nameInString fieldsString valueItems
extractKeyValuePair :: CirruNode -> Either CirruNode (Tuple CirruEdn CirruEdn)
extractKeyValuePair (CirruLeaf s) = Left (CirruLeaf s)
extractKeyValuePair (CirruList xs) =
if (length xs) == 2 then do
k <- extractCirruEdn $ arrayGet xs 0
v <- extractCirruEdn $ arrayGet xs 1
Right $ Tuple k v
else
Left (CirruList xs)
-- | extract Map
extractMap :: (Array CirruNode) -> CrEdnParsed
extractMap xs = do
ys <- traverse extractKeyValuePair xs
Right $ CrEdnMap (DataMap.fromFoldable ys)
-- | extract Cirru EDN list from Cirru Nodes
extractList :: (Array CirruNode) -> CrEdnParsed
extractList xs = do
ys <- traverse extractCirruEdn xs
Right $ CrEdnList ys
-- | extract Set
extractSet :: (Array CirruNode) -> CrEdnParsed
extractSet xs = do
ys <- traverse extractCirruEdn xs
Right $ CrEdnSet (Set.fromFoldable ys)
-- | parse String content into Cirru EDN structure,
-- | returns original Cirru Nodes if pasing failed.
-- | might be hard to figure out reason sometimes since failure not detailed
parseCirruEdn :: String -> CrEdnParsed
parseCirruEdn s = case (parseCirru s) of
CirruLeaf leaf -> Left (CirruLeaf leaf)
CirruList xs ->
if xs == [] then
Left (CirruList [])
else if (length xs) /= 1 then
Left (CirruList xs)
else case (head xs) of
Just ys -> case ys of
CirruLeaf _ -> Left (CirruList xs)
CirruList _ -> extractCirruEdn ys
Nothing -> Left (CirruList xs)
-- | generate Cirru code from Cirru EDN data
writeCirruEdn :: CirruEdn -> String
writeCirruEdn edn = case assembleCirruNode edn of
CirruLeaf x -> writeCirru (CirruList [ (CirruList [ CirruLeaf "do", CirruLeaf x ]) ]) { useInline: false }
CirruList xs -> writeCirru (CirruList [ (CirruList xs) ]) { useInline: false }
instance cirruEdnEq :: Eq CirruEdn where
eq CrEdnNil CrEdnNil = true
eq (CrEdnString x) (CrEdnString y) = x == y
eq (CrEdnKeyword x) (CrEdnKeyword y) = x == y
eq (CrEdnSymbol x) (CrEdnSymbol y) = x == y
eq (CrEdnNumber x) (CrEdnNumber y) = x == y
eq (CrEdnBool x) (CrEdnBool y) = x == y
eq (CrEdnQuote x) (CrEdnQuote y) = x == y
eq (CrEdnList xs) (CrEdnList ys) = xs == ys
eq (CrEdnSet xs) (CrEdnSet ys) = xs == ys
eq (CrEdnMap xs) (CrEdnMap ys) = xs == ys
eq (CrEdnRecord xName xFields xs) (CrEdnRecord yName yFields ys) = xName == yName && xFields == yFields && xs == ys
eq _ _ = false
setToArray :: forall k. Set k -> Array k
setToArray = DataSet.toUnfoldable
tupleToPair :: (Tuple CirruEdn CirruEdn) -> CrEdnKv
tupleToPair (Tuple x y) = CrEdnKv x y
mapToArray :: forall k v. Map k v -> Array (Tuple k v)
mapToArray = DataMap.toUnfoldable
instance showCirruEdn :: Show CirruEdn where
show CrEdnNil = "nil"
show (CrEdnBool x) = show x
show (CrEdnNumber x) = show x
show (CrEdnSymbol x) = "'" <> x
show (CrEdnKeyword x) = ":" <> x
show (CrEdnString x) = "|" <> x
show (CrEdnQuote x) = "(quote " <> (show x) <> ")"
show (CrEdnList xs) = "([] " <> (joinWith " " (map show xs)) <> ")"
show (CrEdnSet xs) = "(#{} " <> (joinWith " " (map show (setToArray xs))) <> ")"
show (CrEdnMap xs) = "({} " <> (joinWith " " (map show (map tupleToPair (mapToArray xs)))) <> ")"
show (CrEdnRecord name fields values) =
"(%{} " <> name
<> " ("
<> (joinWith " " fields)
<> ")"
<> " ("
<> (joinWith " " (map show values))
<> ")"
instance ordCrEdnKv :: Ord CrEdnKv where
compare (CrEdnKv k1 v1) (CrEdnKv k2 v2) = case compare k1 k2 of
LT -> LT
GT -> GT
EQ -> compare k1 k2
instance ordCirruEdn :: Ord CirruEdn where
compare CrEdnNil CrEdnNil = EQ
compare CrEdnNil _ = LT
compare _ CrEdnNil = GT
compare (CrEdnBool false) (CrEdnBool true) = LT
compare (CrEdnBool true) (CrEdnBool false) = GT
compare (CrEdnBool _) (CrEdnBool _) = EQ
compare (CrEdnBool _) _ = LT
compare _ (CrEdnBool _) = GT
compare (CrEdnNumber x) (CrEdnNumber y) = compare x y
compare (CrEdnNumber x) _ = LT
compare _ (CrEdnNumber x) = GT
compare (CrEdnSymbol x) (CrEdnSymbol y) = compare x y
compare (CrEdnSymbol x) _ = LT
compare _ (CrEdnSymbol x) = GT
compare (CrEdnKeyword x) (CrEdnKeyword y) = compare x y
compare (CrEdnKeyword x) _ = LT
compare _ (CrEdnKeyword x) = GT
compare (CrEdnString x) (CrEdnString y) = compare x y
compare (CrEdnString x) _ = LT
compare _ (CrEdnString x) = GT
compare (CrEdnQuote x) (CrEdnQuote y) = compare x y
compare (CrEdnQuote x) _ = LT
compare _ (CrEdnQuote x) = GT
compare (CrEdnList xs) (CrEdnList ys) = case (compare (length xs) (length ys)) of
LT -> LT
GT -> GT
EQ -> compare xs ys
compare (CrEdnList xs) _ = LT
compare _ (CrEdnList xs) = GT
compare (CrEdnSet xs) (CrEdnSet ys) = case (compare (DataSet.size xs) (DataSet.size ys)) of
LT -> LT
GT -> GT
EQ -> compare xs ys
compare (CrEdnSet xs) _ = LT
compare _ (CrEdnSet xs) = GT
compare (CrEdnMap xs) (CrEdnMap ys) = case (compare (DataMap.size xs) (DataMap.size ys)) of
LT -> LT
GT -> GT
EQ -> compare xs ys
compare (CrEdnMap xs) _ = LT
compare _ (CrEdnMap xs) = GT
compare (CrEdnRecord name1 fields1 values1) (CrEdnRecord name2 fields2 values2) = case compare name1 name2 of
LT -> LT
GT -> GT
EQ -> case compare fields1 fields2 of
LT -> LT
GT -> GT
EQ -> compare values1 values2