Play

Check-in [5738ada043]
Login
Overview
Comment:Add support for pattern matching in multiwords. Fixes [3a3a135cf6].
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 5738ada0436ecfa0528c133e231ce69639ac53a3eaad237b7a70e5af65dfe975
User & Date: robin.hansen on 2020-05-22 12:16:29
Original Comment: Add support for pattern matching in multiwords.
Other Links: manifest | tags
Context
2020-05-30
15:19
Merge parser rewrite. check-in: fd6b5c094e user: robin.hansen tags: trunk
2020-05-28
15:29
Use elm/parser for tokenizer. check-in: eb865aaf6e user: robin.hansen tags: parser-rewrite
2020-05-22
12:16
Add support for pattern matching in multiwords. Fixes [3a3a135cf6]. check-in: 5738ada043 user: robin.hansen tags: trunk
12:15
Fixed bug where invalid pattern match syntax still compiled. Closed-Leaf check-in: cc0014e193 user: robin.hansen tags: pattern-matching
2020-05-14
17:48
Add support for quotations. Fixes [5a78656d3b]. check-in: 2e9ce9a07d user: robin.hansen tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified src/Play/Codegen.elm from [a67634836f] to [24b1ca523c].

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
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
...
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
...
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512



513
514


515
516
517










518

519
520

521




















522
523
524
525




526
527
528




















529






530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
module Play.Codegen exposing (..)

import Dict exposing (Dict)
import List.Extra as List

import Play.Data.Builtin as Builtin
import Play.Data.Type as Type exposing (Type)
import Play.TypeChecker as AST exposing (AST)
import Wasm


type alias TypeInformation =
    { id : Int
    , members : List ( String, Type )
    }



-- Constants


wasmPtrSize : Int
wasmPtrSize =
    4


stackCapacityOffset : Int
stackCapacityOffset =
    0


stackPositionOffset : Int
stackPositionOffset =
    wasmPtrSize


defaultStackSize : Int
defaultStackSize =
    1024


initialHeapPositionOffset : Int
initialHeapPositionOffset =
    stackPositionOffset + wasmPtrSize



-- Bultin function names


allocFn : String
allocFn =
    "__alloc"


copyStructFn : String
copyStructFn =
    "__copy_str"


stackPushFn : String
stackPushFn =
    "__stack_push"


stackPopFn : String
stackPopFn =
    "__stack_pop"


addIntFn : String
addIntFn =
    "__add_i32"


subIntFn : String
subIntFn =
    "__sub_i32"


mulIntFn : String
mulIntFn =
    "__mul_i32"


divIntFn : String
divIntFn =
    "__div_i32"


eqIntFn : String
eqIntFn =
    "__eq_i32"


dupFn : String
dupFn =
    "__duplicate"


dropFn : String
dropFn =
    "__drop"


swapFn : String
swapFn =
    "__swap"


rotFn : String
rotFn =
    "__rotate"


leftRotFn : String
leftRotFn =
    "__left_rotate"


stackGetElementFn : String
stackGetElementFn =
    "__stack_get"



-- Base module


baseModule : Wasm.Module
baseModule =
    Wasm.initModule
        |> Wasm.withImport "host" "memory" (Wasm.Memory 1 Nothing)
        |> Wasm.withStartFunction
            { name = "__initialize"
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = []
            , instructions =
                [ Wasm.I32_Const stackCapacityOffset
                , Wasm.I32_Const defaultStackSize
                , Wasm.I32_Store
                , Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Const (wasmPtrSize * 3)
                , Wasm.I32_Store
                , Wasm.I32_Const initialHeapPositionOffset
                , Wasm.I32_Const (defaultStackSize + wasmPtrSize)
                , Wasm.I32_Store
                ]
            }
        |> Wasm.withFunction
            { name = allocFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32 ]
            , results = [ Wasm.Int32 ]
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.I32_Const initialHeapPositionOffset
                , Wasm.I32_Const initialHeapPositionOffset
                , Wasm.I32_Load
                , Wasm.Local_Tee 1
                , Wasm.Local_Get 0
                , Wasm.I32_Add
                , Wasm.I32_Store
                , Wasm.Local_Get 1
                ]
            }
        |> Wasm.withFunction
            { name = copyStructFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32, Wasm.Int32 ]
            , results = [ Wasm.Int32 ]
            , locals = [ Wasm.Int32, Wasm.Int32 ]
            , instructions =
                [ Wasm.Local_Get 1 -- Size in bytes
                , Wasm.Call allocFn
                , Wasm.Local_Set 2 -- Save output instance
                , Wasm.Block
                    [ Wasm.Loop
                        [ Wasm.Local_Get 1
                        , Wasm.I32_EqZero
                        , Wasm.BreakIf 1 -- break out of loop
                        , Wasm.Local_Get 1
                        , Wasm.I32_Const wasmPtrSize
                        , Wasm.I32_Sub
                        , Wasm.Local_Set 1 -- Decreased pointer size
                        , Wasm.Local_Get 0 -- Source struct
                        , Wasm.Local_Get 1
                        , Wasm.I32_Add
                        , Wasm.I32_Load -- Get a byte from source struct
                        , Wasm.Local_Set 3 -- Save byte to copy
                        , Wasm.Local_Get 2 -- Dest struct
                        , Wasm.Local_Get 1
                        , Wasm.I32_Add
                        , Wasm.Local_Get 3
                        , Wasm.I32_Store -- Copy byte from source to dest struct
                        , Wasm.Break 0 -- loop
                        ]
                    ]
                , Wasm.Local_Get 2
                ]
            }
        |> Wasm.withFunction
            { name = stackPushFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32 ]
            , results = []
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Load -- Get current stack position
                , Wasm.Local_Tee 1
                , Wasm.Local_Get 0
                , Wasm.I32_Store -- Store input value in stack
                , Wasm.I32_Const stackPositionOffset
                , Wasm.Local_Get 1
                , Wasm.I32_Const wasmPtrSize
                , Wasm.I32_Add -- Bump stack size
                , Wasm.I32_Store -- Save new stack position
                ]
            }
        |> Wasm.withFunction
            { name = stackPopFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = [ Wasm.Int32 ]
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Load
                , Wasm.I32_Const wasmPtrSize
                , Wasm.I32_Sub
                , Wasm.Local_Tee 0 -- Save new stack position in local register
                , Wasm.I32_Store -- save new stack position in global variable
                , Wasm.Local_Get 0
                , Wasm.I32_Load -- Load element at top of the stack
                ]
            }
        |> Wasm.withFunction
            { name = dupFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Tee 0
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = dropFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = []
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Drop
                ]
            }
        |> Wasm.withFunction
            { name = swapFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Set 0
                , Wasm.Call stackPopFn
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = rotFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32, Wasm.Int32, Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Set 0 -- c
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 1 -- b
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 2 -- a
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 2
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 1
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = leftRotFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32, Wasm.Int32, Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Set 0 -- c
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 1 -- b
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 2 -- a
                , Wasm.Local_Get 1
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 2
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = addIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Add
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = subIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Sub
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = mulIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Mul
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = divIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Div
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = eqIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Eq
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = stackGetElementFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32 ]
            , results = [ Wasm.Int32 ]
            , locals = []
            , instructions =
                [ Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Load
                , Wasm.I32_Const wasmPtrSize
                , Wasm.Local_Get 0 -- read offset
                , Wasm.I32_Const 1
                , Wasm.I32_Add -- add one to offset
                , Wasm.I32_Mul -- offset * ptrSize
                , Wasm.I32_Sub -- stackPosition - ptrOffset
                , Wasm.I32_Load
                ]
            }



-- Codegen


codegen : AST -> Result () Wasm.Module
codegen ast =
................................................................................
            ast.types
                |> Dict.values
                |> typeMeta
    in
    ast.words
        |> Dict.values
        |> List.map (toWasmFuncDef typeMetaDict)
        |> List.foldl Wasm.withFunction baseModule
        |> Ok


typeMeta : List AST.TypeDefinition -> Dict String TypeInformation
typeMeta types =
    types
        |> List.filterMap
................................................................................
    , instructions = wasmImplementation
    }


multiFnToInstructions :
    Dict String TypeInformation
    -> AST.WordDefinition
    -> List ( Type, List AST.AstNode )
    -> List AST.AstNode
    -> Wasm.Instruction
multiFnToInstructions typeInfo def whens defaultImpl =
    let
        branches =
            List.foldl buildBranch (Wasm.Batch []) whens

        buildBranch ( type_, nodes ) ins =
            let
                typeId =



                    case type_ of
                        Type.Custom name ->


                            Dict.get name typeInfo
                                |> Maybe.map .id
                                |> Maybe.withDefault 0












                        _ ->
                            -- TODO: What if we get an Int here?

                            0




















            in
            Wasm.Block
                [ ins
                , Wasm.Local_Get 0




                , Wasm.I32_Const typeId
                , Wasm.I32_NotEq
                , Wasm.BreakIf 0 -- Move to next branch unless theres a type match




















                , Wasm.Batch (List.map (nodeToInstruction typeInfo) nodes)






                , Wasm.Return
                ]

        selfIndex =
            max 0 (List.length def.type_.input - 1)
    in
    Wasm.Batch
        [ Wasm.I32_Const selfIndex
        , Wasm.Call stackGetElementFn
        , Wasm.I32_Load
        , Wasm.Local_Set 0 -- store instance id in local
        , branches
        , Wasm.Batch (List.map (nodeToInstruction typeInfo) defaultImpl)
        ]


nodeToInstruction : Dict String TypeInformation -> AST.AstNode -> Wasm.Instruction
nodeToInstruction typeInfo node =
    case node of
        AST.IntLiteral value ->
            Wasm.Batch
                [ Wasm.I32_Const value
                , Wasm.Call stackPushFn
                ]

        AST.Word value _ ->
            Wasm.Call value

        AST.WordRef name ->
            Wasm.FunctionIndex name

        AST.ConstructType typeName ->
            case Dict.get typeName typeInfo of
                Just type_ ->
                    let
                        typeSize =
                            wasmPtrSize + (memberSize * wasmPtrSize)

                        memberSize =
                            List.length type_.members
                    in
                    Wasm.Batch
                        [ Wasm.I32_Const typeSize
                        , Wasm.Call allocFn
                        , Wasm.Local_Tee 0
                        , Wasm.I32_Const type_.id
                        , Wasm.I32_Store
                        , Wasm.I32_Const memberSize
                        , Wasm.Local_Set 1
                        , Wasm.Block
                            [ Wasm.Loop
                                [ Wasm.Local_Get 1
                                , Wasm.I32_EqZero
                                , Wasm.BreakIf 1
                                , Wasm.Local_Get 0
                                , Wasm.I32_Const wasmPtrSize
                                , Wasm.Local_Get 1
                                , Wasm.I32_Mul
                                , Wasm.I32_Add
                                , Wasm.Call stackPopFn
                                , Wasm.I32_Store
                                , Wasm.Local_Get 1
                                , Wasm.I32_Const 1
                                , Wasm.I32_Sub
                                , Wasm.Local_Set 1
                                , Wasm.Break 0
                                ]
                            ]
                        , Wasm.Local_Get 0
                        , Wasm.Call stackPushFn
                        ]

                Nothing ->
                    Debug.todo "This cannot happen."

        AST.SetMember typeName memberName memberType ->
            case Dict.get typeName typeInfo of
                Just type_ ->
                    let
                        typeSize =
                            wasmPtrSize + (memberSize * wasmPtrSize)

                        memberSize =
                            List.length type_.members
                    in
                    case getMemberType typeInfo typeName memberName of
                        Just memberIndex ->
                            Wasm.Batch
                                [ Wasm.Call swapFn -- Instance should now be at top of stack
                                , Wasm.Call stackPopFn
                                , Wasm.I32_Const typeSize
                                , Wasm.Call copyStructFn -- Return copy of instance
                                , Wasm.Local_Tee 0
                                , Wasm.I32_Const ((memberIndex + 1) * wasmPtrSize) -- Calculate member offset
                                , Wasm.I32_Add -- Calculate member address
                                , Wasm.Call stackPopFn -- Retrieve new value
                                , Wasm.I32_Store
                                , Wasm.Local_Get 0 -- Return instance
                                , Wasm.Call stackPushFn
                                ]

                        Nothing ->
                            Debug.todo "NOOOOO!"

                Nothing ->
                    Debug.todo "This cannot happen!"

        AST.GetMember typeName memberName memberType ->
            case getMemberType typeInfo typeName memberName of
                Just memberIndex ->
                    Wasm.Batch
                        [ Wasm.Call stackPopFn -- Get instance address
                        , Wasm.I32_Const ((memberIndex + 1) * wasmPtrSize) -- Calculate member offset
                        , Wasm.I32_Add -- Calculate member address
                        , Wasm.I32_Load -- Retrieve member
                        , Wasm.Call stackPushFn -- Push member onto stack
                        ]

                Nothing ->
                    Debug.todo "This cannot happen!"

        AST.Builtin builtin ->
            case builtin of
                Builtin.Plus ->
                    Wasm.Call addIntFn

                Builtin.Minus ->
                    Wasm.Call subIntFn

                Builtin.Multiply ->
                    Wasm.Call mulIntFn

                Builtin.Divide ->
                    Wasm.Call divIntFn

                Builtin.Equal ->
                    Wasm.Call eqIntFn

                Builtin.StackDuplicate ->
                    Wasm.Call dupFn

                Builtin.StackDrop ->
                    Wasm.Call dropFn

                Builtin.StackSwap ->
                    Wasm.Call swapFn

                Builtin.StackRightRotate ->
                    Wasm.Call rotFn

                Builtin.StackLeftRotate ->
                    Wasm.Call leftRotFn

                Builtin.Apply ->
                    Wasm.CallIndirect


getMemberType : Dict String TypeInformation -> String -> String -> Maybe Int
getMemberType typeInfoDict typeName memberName =
    Dict.get typeName typeInfoDict
        |> Maybe.map (List.indexedMap (\idx ( name, _ ) -> ( idx, name )) << .members)
        |> Maybe.andThen (List.find (\( _, name ) -> name == memberName))
        |> Maybe.map Tuple.first




>











<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







|





|

|

|
>
>
>
|
|
>
>
|
|
|
>
>
>
>
>
>
>
>
>
>
|
>

<
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
|
>
>
>
>
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>








|
<












|













|






|











|



|









|










|







|
|

|

|

|


|












|
|


|








|


|


|


|


|


|


|


|


|


|











1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16


























































































































































































































































































































































































































17
18
19
20
21
22
23
..
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
..
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
343
344
345
346
module Play.Codegen exposing (..)

import Dict exposing (Dict)
import List.Extra as List
import Play.Codegen.BaseModule as BaseModule
import Play.Data.Builtin as Builtin
import Play.Data.Type as Type exposing (Type)
import Play.TypeChecker as AST exposing (AST)
import Wasm


type alias TypeInformation =
    { id : Int
    , members : List ( String, Type )
    }





























































































































































































































































































































































































































-- Codegen


codegen : AST -> Result () Wasm.Module
codegen ast =
................................................................................
            ast.types
                |> Dict.values
                |> typeMeta
    in
    ast.words
        |> Dict.values
        |> List.map (toWasmFuncDef typeMetaDict)
        |> List.foldl Wasm.withFunction BaseModule.baseModule
        |> Ok


typeMeta : List AST.TypeDefinition -> Dict String TypeInformation
typeMeta types =
    types
        |> List.filterMap
................................................................................
    , instructions = wasmImplementation
    }


multiFnToInstructions :
    Dict String TypeInformation
    -> AST.WordDefinition
    -> List ( AST.TypeMatch, List AST.AstNode )
    -> List AST.AstNode
    -> Wasm.Instruction
multiFnToInstructions typeInfo def whens defaultImpl =
    let
        branches =
            List.foldr buildBranch (Wasm.Batch []) whens

        buildBranch ( type_, nodes ) previousBranch =
            let
                testForInequality =
                    makeInequalityTest type_ 0

                makeInequalityTest t_ localIdx =
                    case t_ of
                        AST.TypeMatch (Type.Custom name) conditions ->
                            let
                                typeId =
                                    Dict.get name typeInfo
                                        |> Maybe.map .id
                                        |> Maybe.withDefault 0
                            in
                            Wasm.Batch
                                [ Wasm.Local_Get localIdx
                                , Wasm.I32_Load -- Load instance id
                                , Wasm.I32_Const typeId
                                , Wasm.I32_NotEq -- Types doesn't match?
                                , Wasm.BreakIf 0 -- Move to next branch if above test is true
                                , conditions
                                    |> List.concatMap (conditionTest localIdx)
                                    |> Wasm.Batch
                                ]

                        _ ->

                            Debug.todo "Only supports custom types in when clauses"

                conditionTest localIdx ( fieldName, value ) =
                    case value of
                        AST.LiteralInt num ->
                            [ Wasm.Local_Get localIdx
                            , Wasm.Call BaseModule.stackPushFn
                            , Wasm.Call <| fieldName ++ ">"
                            , Wasm.Call BaseModule.stackPopFn
                            , Wasm.I32_Const num
                            , Wasm.I32_NotEq -- not same number?
                            , Wasm.BreakIf 0 -- move to next branch
                            ]

                        AST.LiteralType typ_ ->
                            case typ_ of
                                Type.Custom typeName ->
                                    let
                                        typeId =
                                            Dict.get typeName typeInfo
                                                |> Maybe.map .id
                                                |> Maybe.withDefault 0
                                    in


                                    [ Wasm.Local_Get localIdx
                                    , Wasm.Call BaseModule.stackPushFn
                                    , Wasm.Call <| fieldName ++ ">"
                                    , Wasm.Call BaseModule.stackPopFn
                                    , Wasm.I32_Load -- get type id
                                    , Wasm.I32_Const typeId
                                    , Wasm.I32_NotEq -- not same type?
                                    , Wasm.BreakIf 0 -- move to next branch
                                    ]

                                _ ->
                                    Debug.todo "oops"

                        AST.RecursiveMatch match ->
                            let
                                nextLocalIdx =
                                    localIdx + 1
                            in
                            [ Wasm.Local_Get localIdx
                            , Wasm.Call BaseModule.stackPushFn
                            , Wasm.Call <| fieldName ++ ">"
                            , Wasm.Call BaseModule.stackPopFn
                            , Wasm.Local_Set nextLocalIdx
                            , makeInequalityTest match nextLocalIdx
                            ]

                implementation =
                    nodes
                        |> List.map (nodeToInstruction typeInfo)
                        |> Wasm.Batch
            in
            Wasm.Block
                [ previousBranch
                , testForInequality
                , implementation
                , Wasm.Return
                ]

        selfIndex =
            max 0 (List.length def.type_.input - 1)
    in
    Wasm.Batch
        [ Wasm.I32_Const selfIndex
        , Wasm.Call BaseModule.stackGetElementFn

        , Wasm.Local_Set 0 -- store instance id in local
        , branches
        , Wasm.Batch (List.map (nodeToInstruction typeInfo) defaultImpl)
        ]


nodeToInstruction : Dict String TypeInformation -> AST.AstNode -> Wasm.Instruction
nodeToInstruction typeInfo node =
    case node of
        AST.IntLiteral value ->
            Wasm.Batch
                [ Wasm.I32_Const value
                , Wasm.Call BaseModule.stackPushFn
                ]

        AST.Word value _ ->
            Wasm.Call value

        AST.WordRef name ->
            Wasm.FunctionIndex name

        AST.ConstructType typeName ->
            case Dict.get typeName typeInfo of
                Just type_ ->
                    let
                        typeSize =
                            BaseModule.wasmPtrSize + (memberSize * BaseModule.wasmPtrSize)

                        memberSize =
                            List.length type_.members
                    in
                    Wasm.Batch
                        [ Wasm.I32_Const typeSize
                        , Wasm.Call BaseModule.allocFn
                        , Wasm.Local_Tee 0
                        , Wasm.I32_Const type_.id
                        , Wasm.I32_Store
                        , Wasm.I32_Const memberSize
                        , Wasm.Local_Set 1
                        , Wasm.Block
                            [ Wasm.Loop
                                [ Wasm.Local_Get 1
                                , Wasm.I32_EqZero
                                , Wasm.BreakIf 1
                                , Wasm.Local_Get 0
                                , Wasm.I32_Const BaseModule.wasmPtrSize
                                , Wasm.Local_Get 1
                                , Wasm.I32_Mul
                                , Wasm.I32_Add
                                , Wasm.Call BaseModule.stackPopFn
                                , Wasm.I32_Store
                                , Wasm.Local_Get 1
                                , Wasm.I32_Const 1
                                , Wasm.I32_Sub
                                , Wasm.Local_Set 1
                                , Wasm.Break 0
                                ]
                            ]
                        , Wasm.Local_Get 0
                        , Wasm.Call BaseModule.stackPushFn
                        ]

                Nothing ->
                    Debug.todo "This cannot happen."

        AST.SetMember typeName memberName memberType ->
            case Dict.get typeName typeInfo of
                Just type_ ->
                    let
                        typeSize =
                            BaseModule.wasmPtrSize + (memberSize * BaseModule.wasmPtrSize)

                        memberSize =
                            List.length type_.members
                    in
                    case getMemberType typeInfo typeName memberName of
                        Just memberIndex ->
                            Wasm.Batch
                                [ Wasm.Call BaseModule.swapFn -- Instance should now be at top of stack
                                , Wasm.Call BaseModule.stackPopFn
                                , Wasm.I32_Const typeSize
                                , Wasm.Call BaseModule.copyStructFn -- Return copy of instance
                                , Wasm.Local_Tee 0
                                , Wasm.I32_Const ((memberIndex + 1) * BaseModule.wasmPtrSize) -- Calculate member offset
                                , Wasm.I32_Add -- Calculate member address
                                , Wasm.Call BaseModule.stackPopFn -- Retrieve new value
                                , Wasm.I32_Store
                                , Wasm.Local_Get 0 -- Return instance
                                , Wasm.Call BaseModule.stackPushFn
                                ]

                        Nothing ->
                            Debug.todo "NOOOOO!"

                Nothing ->
                    Debug.todo "This cannot happen!"

        AST.GetMember typeName memberName memberType ->
            case getMemberType typeInfo typeName memberName of
                Just memberIndex ->
                    Wasm.Batch
                        [ Wasm.Call BaseModule.stackPopFn -- Get instance address
                        , Wasm.I32_Const ((memberIndex + 1) * BaseModule.wasmPtrSize) -- Calculate member offset
                        , Wasm.I32_Add -- Calculate member address
                        , Wasm.I32_Load -- Retrieve member
                        , Wasm.Call BaseModule.stackPushFn -- Push member onto stack
                        ]

                Nothing ->
                    Debug.todo "This cannot happen!"

        AST.Builtin builtin ->
            case builtin of
                Builtin.Plus ->
                    Wasm.Call BaseModule.addIntFn

                Builtin.Minus ->
                    Wasm.Call BaseModule.subIntFn

                Builtin.Multiply ->
                    Wasm.Call BaseModule.mulIntFn

                Builtin.Divide ->
                    Wasm.Call BaseModule.divIntFn

                Builtin.Equal ->
                    Wasm.Call BaseModule.eqIntFn

                Builtin.StackDuplicate ->
                    Wasm.Call BaseModule.dupFn

                Builtin.StackDrop ->
                    Wasm.Call BaseModule.dropFn

                Builtin.StackSwap ->
                    Wasm.Call BaseModule.swapFn

                Builtin.StackRightRotate ->
                    Wasm.Call BaseModule.rotFn

                Builtin.StackLeftRotate ->
                    Wasm.Call BaseModule.leftRotFn

                Builtin.Apply ->
                    Wasm.CallIndirect


getMemberType : Dict String TypeInformation -> String -> String -> Maybe Int
getMemberType typeInfoDict typeName memberName =
    Dict.get typeName typeInfoDict
        |> Maybe.map (List.indexedMap (\idx ( name, _ ) -> ( idx, name )) << .members)
        |> Maybe.andThen (List.find (\( _, name ) -> name == memberName))
        |> Maybe.map Tuple.first

Added src/Play/Codegen/BaseModule.elm version [25136384d7].



























































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
module Play.Codegen.BaseModule exposing (..)

import Wasm



-- Constants


wasmPtrSize : Int
wasmPtrSize =
    4


stackCapacityOffset : Int
stackCapacityOffset =
    0


stackPositionOffset : Int
stackPositionOffset =
    wasmPtrSize


defaultStackSize : Int
defaultStackSize =
    1024


initialHeapPositionOffset : Int
initialHeapPositionOffset =
    stackPositionOffset + wasmPtrSize



-- Bultin function names


allocFn : String
allocFn =
    "__alloc"


copyStructFn : String
copyStructFn =
    "__copy_str"


stackPushFn : String
stackPushFn =
    "__stack_push"


stackPopFn : String
stackPopFn =
    "__stack_pop"


addIntFn : String
addIntFn =
    "__add_i32"


subIntFn : String
subIntFn =
    "__sub_i32"


mulIntFn : String
mulIntFn =
    "__mul_i32"


divIntFn : String
divIntFn =
    "__div_i32"


eqIntFn : String
eqIntFn =
    "__eq_i32"


dupFn : String
dupFn =
    "__duplicate"


dropFn : String
dropFn =
    "__drop"


swapFn : String
swapFn =
    "__swap"


rotFn : String
rotFn =
    "__rotate"


leftRotFn : String
leftRotFn =
    "__left_rotate"


stackGetElementFn : String
stackGetElementFn =
    "__stack_get"



-- Base module


baseModule : Wasm.Module
baseModule =
    Wasm.initModule
        |> Wasm.withImport "host" "memory" (Wasm.Memory 1 Nothing)
        |> Wasm.withStartFunction
            { name = "__initialize"
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = []
            , instructions =
                [ Wasm.I32_Const stackCapacityOffset
                , Wasm.I32_Const defaultStackSize
                , Wasm.I32_Store
                , Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Const (wasmPtrSize * 3)
                , Wasm.I32_Store
                , Wasm.I32_Const initialHeapPositionOffset
                , Wasm.I32_Const (defaultStackSize + wasmPtrSize)
                , Wasm.I32_Store
                ]
            }
        |> Wasm.withFunction
            { name = allocFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32 ]
            , results = [ Wasm.Int32 ]
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.I32_Const initialHeapPositionOffset
                , Wasm.I32_Const initialHeapPositionOffset
                , Wasm.I32_Load
                , Wasm.Local_Tee 1
                , Wasm.Local_Get 0
                , Wasm.I32_Add
                , Wasm.I32_Store
                , Wasm.Local_Get 1
                ]
            }
        |> Wasm.withFunction
            { name = copyStructFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32, Wasm.Int32 ]
            , results = [ Wasm.Int32 ]
            , locals = [ Wasm.Int32, Wasm.Int32 ]
            , instructions =
                [ Wasm.Local_Get 1 -- Size in bytes
                , Wasm.Call allocFn
                , Wasm.Local_Set 2 -- Save output instance
                , Wasm.Block
                    [ Wasm.Loop
                        [ Wasm.Local_Get 1
                        , Wasm.I32_EqZero
                        , Wasm.BreakIf 1 -- break out of loop
                        , Wasm.Local_Get 1
                        , Wasm.I32_Const wasmPtrSize
                        , Wasm.I32_Sub
                        , Wasm.Local_Set 1 -- Decreased pointer size
                        , Wasm.Local_Get 0 -- Source struct
                        , Wasm.Local_Get 1
                        , Wasm.I32_Add
                        , Wasm.I32_Load -- Get a byte from source struct
                        , Wasm.Local_Set 3 -- Save byte to copy
                        , Wasm.Local_Get 2 -- Dest struct
                        , Wasm.Local_Get 1
                        , Wasm.I32_Add
                        , Wasm.Local_Get 3
                        , Wasm.I32_Store -- Copy byte from source to dest struct
                        , Wasm.Break 0 -- loop
                        ]
                    ]
                , Wasm.Local_Get 2
                ]
            }
        |> Wasm.withFunction
            { name = stackPushFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32 ]
            , results = []
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Load -- Get current stack position
                , Wasm.Local_Tee 1
                , Wasm.Local_Get 0
                , Wasm.I32_Store -- Store input value in stack
                , Wasm.I32_Const stackPositionOffset
                , Wasm.Local_Get 1
                , Wasm.I32_Const wasmPtrSize
                , Wasm.I32_Add -- Bump stack size
                , Wasm.I32_Store -- Save new stack position
                ]
            }
        |> Wasm.withFunction
            { name = stackPopFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = [ Wasm.Int32 ]
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Load
                , Wasm.I32_Const wasmPtrSize
                , Wasm.I32_Sub
                , Wasm.Local_Tee 0 -- Save new stack position in local register
                , Wasm.I32_Store -- save new stack position in global variable
                , Wasm.Local_Get 0
                , Wasm.I32_Load -- Load element at top of the stack
                ]
            }
        |> Wasm.withFunction
            { name = dupFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Tee 0
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = dropFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = []
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Drop
                ]
            }
        |> Wasm.withFunction
            { name = swapFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Set 0
                , Wasm.Call stackPopFn
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = rotFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32, Wasm.Int32, Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Set 0 -- c
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 1 -- b
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 2 -- a
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 2
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 1
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = leftRotFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32, Wasm.Int32, Wasm.Int32 ]
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Local_Set 0 -- c
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 1 -- b
                , Wasm.Call stackPopFn
                , Wasm.Local_Set 2 -- a
                , Wasm.Local_Get 1
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Local_Get 2
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = addIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , results = []
            , locals = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Add
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = subIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Sub
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = mulIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Mul
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = divIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Div
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = eqIntFn
            , exported = False
            , isIndirectlyCalled = False
            , args = []
            , locals = []
            , results = []
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Eq
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = stackGetElementFn
            , exported = False
            , isIndirectlyCalled = False
            , args = [ Wasm.Int32 ]
            , results = [ Wasm.Int32 ]
            , locals = []
            , instructions =
                [ Wasm.I32_Const stackPositionOffset
                , Wasm.I32_Load
                , Wasm.I32_Const wasmPtrSize
                , Wasm.Local_Get 0 -- read offset
                , Wasm.I32_Const 1
                , Wasm.I32_Add -- add one to offset
                , Wasm.I32_Mul -- offset * ptrSize
                , Wasm.I32_Sub -- stackPosition - ptrOffset
                , Wasm.I32_Load
                ]
            }

Modified src/Play/Parser.elm from [e8a4ddfdd6] to [7bf9b4ea5d].

20
21
22
23
24
25
26
27
28
29
30















31
32
33
34
35
36
37
...
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
...
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
...
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355















356
357
358
359
360





























































361
362
363
364
365
366
367
...
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421

422
423
424
425
426
427
428

429
430
431
432
433
434
435
436
...
444
445
446
447
448
449
450
















451
452
453
454
455
456
457
...
554
555
556
557
558
559
560


























    = CustomTypeDef String (List ( String, Type ))
    | UnionTypeDef String (List Type)


type alias WordDefinition =
    { name : String
    , metadata : Metadata
    , whens : List ( Type, List AstNode )
    , implementation : List AstNode
    }

















type AstNode
    = Integer Int
    | Word String
    | ConstructType String
    | GetMember String String
    | SetMember String String
................................................................................
                        ( [], Ok wordImpl ) ->
                            ( errors
                            , { ast
                                | words =
                                    Dict.insert wordName
                                        { name = wordName
                                        , metadata = metadata
                                        , whens = []
                                        , implementation = wordImpl
                                        }
                                        ast.words
                              }
                            )

                        _ ->
                            ( () :: errors
................................................................................
                        ( [], [], Ok wordImpl ) ->
                            ( errors
                            , { ast
                                | words =
                                    Dict.insert wordName
                                        { name = wordName
                                        , metadata = metadata
                                        , whens = whens
                                        , implementation = wordImpl
                                        }
                                        ast.words
                              }
                            )

                        _ ->
                            ( () :: errors
................................................................................
        Token.Metadata "when" ->
            True

        _ ->
            False


parseWhen : List Token -> ( List (), List ( Type, List AstNode ) ) -> ( List (), List ( Type, List AstNode ) )
parseWhen tokens ( errors, cases ) =
    case tokens of
        (Token.Metadata "when") :: ((Token.Type _) as typeToken) :: impl ->
            let
                parsedImpl =
                    impl
                        |> parseAstNodes []
                        |> Result.combine
            in
            case ( parseType typeToken, parsedImpl ) of
                ( Ok type_, Ok wordImpl ) ->
                    ( errors
                    , ( type_, wordImpl ) :: cases
                    )

                _ ->
                    ( () :: errors
                    , cases
                    )
















        _ ->
            ( () :: errors
            , cases
            )































































parseAstNodes : List (Result () AstNode) -> List Token -> List (Result () AstNode)
parseAstNodes result remaining =
    case remaining of
        [] ->
            List.reverse result

................................................................................
        metadata =
            Metadata.default
                |> Metadata.withType (List.map Tuple.second members) [ Type.Custom typeName ]

        ctorDef =
            { name = ">" ++ typeName
            , metadata = metadata
            , whens = []
            , implementation = [ ConstructType typeName ]
            }

        generatedDefs =
            members
                |> List.concatMap setterGetterPair
                |> (::) ctorDef
                |> Dict.fromListBy .name

        setterGetterPair ( memberName, memberType ) =
            [ { name = ">" ++ memberName
              , metadata =
                    Metadata.default
                        |> Metadata.withType [ Type.Custom typeName, memberType ] [ Type.Custom typeName ]
              , whens = []

              , implementation = [ SetMember typeName memberName ]
              }
            , { name = memberName ++ ">"
              , metadata =
                    Metadata.default
                        |> Metadata.withType [ Type.Custom typeName ] [ memberType ]
              , whens = []

              , implementation = [ GetMember typeName memberName ]
              }
            ]
    in
    { ast
        | types = Dict.insert typeName typeDef ast.types
        , words = Dict.union generatedDefs ast.words
    }
................................................................................

        Token.Type name ->
            Ok <| Type.Custom name

        Token.Symbol genericName ->
            Ok <| Type.Generic genericName

















        _ ->
            Err ()


parseTypes : List (Result () Type) -> List Token -> List (Result () Type)
parseTypes result remaining =
    case remaining of
................................................................................
                    nestedListSplitHelper newBlockStart newBlockEnd splitter (nested - 1) (first :: before) rest

            else if first == splitter && nested == 0 then
                Just ( List.reverse before, rest )

            else
                nestedListSplitHelper newBlockStart newBlockEnd splitter nested (first :: before) rest

































<
|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
|







 







<
|







 







|









|










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|













|
>
|





|
>
|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
...
146
147
148
149
150
151
152

153
154
155
156
157
158
159
160
...
239
240
241
242
243
244
245

246
247
248
249
250
251
252
253
...
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
...
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
...
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
...
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
    = CustomTypeDef String (List ( String, Type ))
    | UnionTypeDef String (List Type)


type alias WordDefinition =
    { name : String
    , metadata : Metadata

    , implementation : WordImplementation
    }


type WordImplementation
    = SoloImpl (List AstNode)
    | MultiImpl (List ( TypeMatch, List AstNode )) (List AstNode)


type TypeMatch
    = TypeMatch Type (List ( String, TypeMatchValue ))


type TypeMatchValue
    = LiteralInt Int
    | LiteralType Type
    | RecursiveMatch TypeMatch


type AstNode
    = Integer Int
    | Word String
    | ConstructType String
    | GetMember String String
    | SetMember String String
................................................................................
                        ( [], Ok wordImpl ) ->
                            ( errors
                            , { ast
                                | words =
                                    Dict.insert wordName
                                        { name = wordName
                                        , metadata = metadata

                                        , implementation = SoloImpl wordImpl
                                        }
                                        ast.words
                              }
                            )

                        _ ->
                            ( () :: errors
................................................................................
                        ( [], [], Ok wordImpl ) ->
                            ( errors
                            , { ast
                                | words =
                                    Dict.insert wordName
                                        { name = wordName
                                        , metadata = metadata

                                        , implementation = MultiImpl whens wordImpl
                                        }
                                        ast.words
                              }
                            )

                        _ ->
                            ( () :: errors
................................................................................
        Token.Metadata "when" ->
            True

        _ ->
            False


parseWhen : List Token -> ( List (), List ( TypeMatch, List AstNode ) ) -> ( List (), List ( TypeMatch, List AstNode ) )
parseWhen tokens ( errors, cases ) =
    case tokens of
        (Token.Metadata "when") :: ((Token.Type _) as typeToken) :: impl ->
            let
                parsedImpl =
                    impl
                        |> parseAstNodes []
                        |> Result.combine
            in
            case ( parseTypeMatch typeToken, parsedImpl ) of
                ( Ok type_, Ok wordImpl ) ->
                    ( errors
                    , ( type_, wordImpl ) :: cases
                    )

                _ ->
                    ( () :: errors
                    , cases
                    )

        (Token.Metadata "when") :: (Token.PatternMatchStart typeName) :: remaining ->
            case semanticSplit isPatternMatchStart Token.ParenStop remaining of
                ( pattern, impl ) ->
                    let
                        parsedImpl =
                            impl
                                |> parseAstNodes []
                                |> Result.combine
                    in
                    case ( parsePatternMatch typeName pattern, parsedImpl ) of
                        ( Just ( typeMatch, [] ), Ok wordImpl ) ->
                            ( errors
                            , ( typeMatch, wordImpl ) :: cases
                            )

                        _ ->
                            ( () :: errors
                            , cases
                            )

        _ ->
            ( () :: errors
            , cases
            )


parsePatternMatch : String -> List Token -> Maybe ( TypeMatch, List Token )
parsePatternMatch typeName tokens =
    case parseType (Token.Type typeName) of
        Ok type_ ->
            case semanticSplit isPatternMatchStart Token.ParenStop tokens of
                ( pattern, rem ) ->
                    case collectPatternAttributes pattern [] of
                        Ok patterns ->
                            Just <| ( TypeMatch type_ patterns, rem )

                        Err _ ->
                            Nothing

        Err _ ->
            Nothing


collectPatternAttributes : List Token -> List ( String, TypeMatchValue ) -> Result () (List ( String, TypeMatchValue ))
collectPatternAttributes tokens result =
    case tokens of
        [] ->
            Ok (List.reverse result)

        (Token.Symbol attrValue) :: (Token.Integer val) :: rest ->
            collectPatternAttributes rest (( attrValue, LiteralInt val ) :: result)

        (Token.Symbol attrValue) :: ((Token.Type _) as tokenType) :: rest ->
            case parseType tokenType of
                Ok type_ ->
                    collectPatternAttributes rest (( attrValue, LiteralType type_ ) :: result)

                Err _ ->
                    Err ()

        (Token.Symbol attrValue) :: (Token.PatternMatchStart subName) :: rest ->
            case parsePatternMatch subName rest of
                Just ( typeMatch, remaining ) ->
                    collectPatternAttributes remaining (( attrValue, RecursiveMatch typeMatch ) :: result)

                Nothing ->
                    Err ()

        _ ->
            Err ()


isPatternMatchStart : Token -> Bool
isPatternMatchStart token =
    case token of
        Token.PatternMatchStart _ ->
            True

        _ ->
            False


parseAstNodes : List (Result () AstNode) -> List Token -> List (Result () AstNode)
parseAstNodes result remaining =
    case remaining of
        [] ->
            List.reverse result

................................................................................
        metadata =
            Metadata.default
                |> Metadata.withType (List.map Tuple.second members) [ Type.Custom typeName ]

        ctorDef =
            { name = ">" ++ typeName
            , metadata = metadata
            , implementation =
                SoloImpl [ ConstructType typeName ]
            }

        generatedDefs =
            members
                |> List.concatMap setterGetterPair
                |> (::) ctorDef
                |> Dict.fromListBy .name

        setterGetterPair ( memberName, memberType ) =
            [ { name = ">" ++ memberName
              , metadata =
                    Metadata.default
                        |> Metadata.withType [ Type.Custom typeName, memberType ] [ Type.Custom typeName ]
              , implementation =
                    SoloImpl
                        [ SetMember typeName memberName ]
              }
            , { name = memberName ++ ">"
              , metadata =
                    Metadata.default
                        |> Metadata.withType [ Type.Custom typeName ] [ memberType ]
              , implementation =
                    SoloImpl
                        [ GetMember typeName memberName ]
              }
            ]
    in
    { ast
        | types = Dict.insert typeName typeDef ast.types
        , words = Dict.union generatedDefs ast.words
    }
................................................................................

        Token.Type name ->
            Ok <| Type.Custom name

        Token.Symbol genericName ->
            Ok <| Type.Generic genericName

        _ ->
            Err ()


parseTypeMatch : Token -> Result () TypeMatch
parseTypeMatch token =
    case token of
        Token.Type "Int" ->
            Ok <| TypeMatch Type.Int []

        Token.Type name ->
            Ok <| TypeMatch (Type.Custom name) []

        Token.Symbol genericName ->
            Ok <| TypeMatch (Type.Generic genericName) []

        _ ->
            Err ()


parseTypes : List (Result () Type) -> List Token -> List (Result () Type)
parseTypes result remaining =
    case remaining of
................................................................................
                    nestedListSplitHelper newBlockStart newBlockEnd splitter (nested - 1) (first :: before) rest

            else if first == splitter && nested == 0 then
                Just ( List.reverse before, rest )

            else
                nestedListSplitHelper newBlockStart newBlockEnd splitter nested (first :: before) rest


semanticSplit : (Token -> Bool) -> Token -> List Token -> ( List Token, List Token )
semanticSplit newBlockStart newBlockEnd ls =
    semanticSplitHelper newBlockStart newBlockEnd 0 [] ls


semanticSplitHelper : (Token -> Bool) -> Token -> Int -> List Token -> List Token -> ( List Token, List Token )
semanticSplitHelper newBlockStart newBlockEnd nested before after =
    case after of
        [] ->
            ( List.reverse before, [] )

        first :: rest ->
            if newBlockStart first then
                semanticSplitHelper newBlockStart newBlockEnd (nested + 1) (first :: before) rest

            else if first == newBlockEnd then
                if nested <= 0 then
                    ( List.reverse before, rest )

                else
                    semanticSplitHelper newBlockStart newBlockEnd (nested - 1) (first :: before) rest

            else
                semanticSplitHelper newBlockStart newBlockEnd nested (first :: before) rest

Modified src/Play/Qualifier.elm from [0818fb4226] to [1db6c0db5a].

2
3
4
5
6
7
8

9
10
11
12
13
14
15
..
24
25
26
27
28
29
30
31










32
33
34
35
36
37
38
..
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
..
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
...
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

import Dict exposing (Dict)
import Play.Data.Builtin as Builtin exposing (Builtin)
import Play.Data.Metadata as Metadata exposing (Metadata)
import Play.Data.Type as Type exposing (Type)
import Play.Parser as Parser
import Result.Extra as Result



type alias AST =
    { types : Dict String TypeDefinition
    , words : Dict String WordDefinition
    }

................................................................................
    , metadata : Metadata
    , implementation : WordImplementation
    }


type WordImplementation
    = SoloImpl (List Node)
    | MultiImpl (List ( Type, List Node )) (List Node)












type Node
    = Integer Int
    | Word String
    | WordRef String
    | ConstructType String
................................................................................
            ast.types
                |> Dict.values
                |> List.foldl (qualifyType ast) ( [], Dict.empty )

        ( wordErrors, qualifiedWords ) =
            ast.words
                |> Dict.values
                |> List.foldl (qualifyDefinition ast) ( [], Dict.empty )
    in
    case ( typeErrors, wordErrors ) of
        ( [], [] ) ->
            Ok
                { types = qualifiedTypes
                , words = qualifiedWords
                }
................................................................................
        Parser.UnionTypeDef name memberTypes ->
            Dict.insert name (UnionTypeDef name memberTypes) acc
    )


qualifyDefinition :
    Parser.AST

    -> Parser.WordDefinition
    -> ( List (), Dict String WordDefinition )
    -> ( List (), Dict String WordDefinition )
qualifyDefinition ast unqualifiedWord ( errors, acc ) =
    let








        ( newWordsAfterWhens, qualifiedWhensResult ) =
            List.foldr (qualifyWhen ast unqualifiedWord.name) ( acc, [] ) unqualifiedWord.whens


                |> Tuple.mapSecond Result.combine

        ( newWordsAfterImpl, qualifiedImplementationResult ) =
            List.foldr (qualifyNode ast unqualifiedWord.name) ( newWordsAfterWhens, [] ) unqualifiedWord.implementation
                |> Tuple.mapSecond Result.combine
    in
    case ( qualifiedWhensResult, qualifiedImplementationResult ) of
        ( Ok qualifiedWhens, Ok qualifiedImplementation ) ->
            ( errors
            , Dict.insert unqualifiedWord.name
                { name = unqualifiedWord.name
................................................................................
            ( () :: errors
            , newWordsAfterImpl
            )


qualifyWhen :
    Parser.AST

    -> String
    -> ( Type, List Parser.AstNode )
    -> ( Dict String WordDefinition, List (Result () ( Type, List Node )) )
    -> ( Dict String WordDefinition, List (Result () ( Type, List Node )) )
qualifyWhen ast wordName ( type_, impl ) ( qualifiedWords, result ) =
    let
        ( newWords, qualifiedImplementationResult ) =
            List.foldr (qualifyNode ast wordName) ( qualifiedWords, [] ) impl
                |> Tuple.mapSecond Result.combine



    in
    case qualifiedImplementationResult of





        Err () ->
            ( newWords
            , Err () :: result
            )

        Ok qualifiedImplementation ->
            ( newWords
            , Ok ( type_, qualifiedImplementation ) :: result
            )








































































qualifyNode :
    Parser.AST
    -> String
    -> Parser.AstNode
    -> ( Dict String WordDefinition, List (Result () Node) )
    -> ( Dict String WordDefinition, List (Result () Node) )







>







 







|
>
>
>
>
>
>
>
>
>
>







 







|







 







>



|

>
>
>
>
>
>
>
>

<
>
>



|







 







>

|
|
|
|




>
>
>

|
>
>
>
>
>
|




|

|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
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
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
...
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
...
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

import Dict exposing (Dict)
import Play.Data.Builtin as Builtin exposing (Builtin)
import Play.Data.Metadata as Metadata exposing (Metadata)
import Play.Data.Type as Type exposing (Type)
import Play.Parser as Parser
import Result.Extra as Result
import Set exposing (Set)


type alias AST =
    { types : Dict String TypeDefinition
    , words : Dict String WordDefinition
    }

................................................................................
    , metadata : Metadata
    , implementation : WordImplementation
    }


type WordImplementation
    = SoloImpl (List Node)
    | MultiImpl (List ( TypeMatch, List Node )) (List Node)


type TypeMatch
    = TypeMatch Type (List ( String, TypeMatchValue ))


type TypeMatchValue
    = LiteralInt Int
    | LiteralType Type
    | RecursiveMatch TypeMatch


type Node
    = Integer Int
    | Word String
    | WordRef String
    | ConstructType String
................................................................................
            ast.types
                |> Dict.values
                |> List.foldl (qualifyType ast) ( [], Dict.empty )

        ( wordErrors, qualifiedWords ) =
            ast.words
                |> Dict.values
                |> List.foldl (qualifyDefinition ast qualifiedTypes) ( [], Dict.empty )
    in
    case ( typeErrors, wordErrors ) of
        ( [], [] ) ->
            Ok
                { types = qualifiedTypes
                , words = qualifiedWords
                }
................................................................................
        Parser.UnionTypeDef name memberTypes ->
            Dict.insert name (UnionTypeDef name memberTypes) acc
    )


qualifyDefinition :
    Parser.AST
    -> Dict String TypeDefinition
    -> Parser.WordDefinition
    -> ( List (), Dict String WordDefinition )
    -> ( List (), Dict String WordDefinition )
qualifyDefinition ast qualifiedTypes unqualifiedWord ( errors, acc ) =
    let
        ( whens, impl ) =
            case unqualifiedWord.implementation of
                Parser.SoloImpl defImpl ->
                    ( [], defImpl )

                Parser.MultiImpl whenImpl defImpl ->
                    ( whenImpl, defImpl )

        ( newWordsAfterWhens, qualifiedWhensResult ) =

            whens
                |> List.foldr (qualifyWhen ast qualifiedTypes unqualifiedWord.name) ( acc, [] )
                |> Tuple.mapSecond Result.combine

        ( newWordsAfterImpl, qualifiedImplementationResult ) =
            List.foldr (qualifyNode ast unqualifiedWord.name) ( newWordsAfterWhens, [] ) impl
                |> Tuple.mapSecond Result.combine
    in
    case ( qualifiedWhensResult, qualifiedImplementationResult ) of
        ( Ok qualifiedWhens, Ok qualifiedImplementation ) ->
            ( errors
            , Dict.insert unqualifiedWord.name
                { name = unqualifiedWord.name
................................................................................
            ( () :: errors
            , newWordsAfterImpl
            )


qualifyWhen :
    Parser.AST
    -> Dict String TypeDefinition
    -> String
    -> ( Parser.TypeMatch, List Parser.AstNode )
    -> ( Dict String WordDefinition, List (Result () ( TypeMatch, List Node )) )
    -> ( Dict String WordDefinition, List (Result () ( TypeMatch, List Node )) )
qualifyWhen ast qualifiedTypes wordName ( typeMatch, impl ) ( qualifiedWords, result ) =
    let
        ( newWords, qualifiedImplementationResult ) =
            List.foldr (qualifyNode ast wordName) ( qualifiedWords, [] ) impl
                |> Tuple.mapSecond Result.combine

        qualifiedMatchResult =
            qualifyMatch qualifiedTypes typeMatch
    in
    case ( qualifiedImplementationResult, qualifiedMatchResult ) of
        ( Err (), _ ) ->
            ( newWords
            , Err () :: result
            )

        ( _, Err () ) ->
            ( newWords
            , Err () :: result
            )

        ( Ok qualifiedImplementation, Ok qualifiedMatch ) ->
            ( newWords
            , Ok ( qualifiedMatch, qualifiedImplementation ) :: result
            )


qualifyMatch : Dict String TypeDefinition -> Parser.TypeMatch -> Result () TypeMatch
qualifyMatch qualifiedTypes typeMatch =
    case typeMatch of
        Parser.TypeMatch Type.Int [] ->
            Ok <| TypeMatch Type.Int []

        Parser.TypeMatch Type.Int [ ( "value", Parser.LiteralInt val ) ] ->
            Ok <| TypeMatch Type.Int [ ( "value", LiteralInt val ) ]

        Parser.TypeMatch ((Type.Custom name) as type_) patterns ->
            case Dict.get name qualifiedTypes of
                Just (CustomTypeDef _ members) ->
                    let
                        memberNames =
                            members
                                |> List.map Tuple.first
                                |> Set.fromList

                        qualifiedPatternsResult =
                            patterns
                                |> List.map (qualifyMatchValue qualifiedTypes memberNames)
                                |> Result.combine
                    in
                    case qualifiedPatternsResult of
                        Ok qualifiedPatterns ->
                            Ok <| TypeMatch type_ qualifiedPatterns

                        Err () ->
                            Err ()

                Just (UnionTypeDef _ types) ->
                    if List.isEmpty patterns then
                        Ok <| TypeMatch (Type.Union types) []

                    else
                        Err ()

                Nothing ->
                    Err ()

        _ ->
            Err ()


qualifyMatchValue :
    Dict String TypeDefinition
    -> Set String
    -> ( String, Parser.TypeMatchValue )
    -> Result () ( String, TypeMatchValue )
qualifyMatchValue qualifiedTypes memberNames ( fieldName, matchValue ) =
    if Set.member fieldName memberNames then
        case matchValue of
            Parser.LiteralInt val ->
                Ok <| ( fieldName, LiteralInt val )

            Parser.LiteralType type_ ->
                Ok <| ( fieldName, LiteralType type_ )

            Parser.RecursiveMatch typeMatch ->
                case qualifyMatch qualifiedTypes typeMatch of
                    Err () ->
                        Err ()

                    Ok match ->
                        Ok <| ( fieldName, RecursiveMatch match )

    else
        Err ()


qualifyNode :
    Parser.AST
    -> String
    -> Parser.AstNode
    -> ( Dict String WordDefinition, List (Result () Node) )
    -> ( Dict String WordDefinition, List (Result () Node) )

Modified src/Play/Tokenizer.elm from [a344f68e54] to [f9544592d3].

9
10
11
12
13
14
15


16
17
18
19
20
21
22
..
27
28
29
30
31
32
33







34
35
36
37
38
39
40
41
..
52
53
54
55
56
57
58



59
60
61
62
63
64
65
66
67
68
69
70
    | Metadata String
    | Type String
    | TypeSeperator
    | ListStart
    | ListEnd
    | QuoteStart
    | QuoteStop




tokenize : String -> Result () (List Token)
tokenize sourceCode =
    sourceCode
        |> String.words
        |> List.map recognizeToken
................................................................................
recognizeToken word =
    case String.toInt word of
        Just value ->
            Ok (Integer value)

        Nothing ->
            if stringStartsWithUpper word then







                Ok (Type word)

            else if String.endsWith ":" word then
                word
                    |> String.dropRight 1
                    |> Metadata
                    |> Ok

................................................................................

                    "[" ->
                        Ok QuoteStart

                    "]" ->
                        Ok QuoteStop




                    _ ->
                        Ok (Symbol word)


stringStartsWithUpper : String -> Bool
stringStartsWithUpper str =
    case String.uncons str of
        Just ( firstLetter, _ ) ->
            Char.isUpper firstLetter

        Nothing ->
            False







>
>







 







>
>
>
>
>
>
>
|







 







>
>
>












9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
..
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
..
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
    | Metadata String
    | Type String
    | TypeSeperator
    | ListStart
    | ListEnd
    | QuoteStart
    | QuoteStop
    | PatternMatchStart String
    | ParenStop


tokenize : String -> Result () (List Token)
tokenize sourceCode =
    sourceCode
        |> String.words
        |> List.map recognizeToken
................................................................................
recognizeToken word =
    case String.toInt word of
        Just value ->
            Ok (Integer value)

        Nothing ->
            if stringStartsWithUpper word then
                if String.endsWith "(" word then
                    word
                        |> String.dropRight 1
                        |> PatternMatchStart
                        |> Ok

                else
                    Ok (Type word)

            else if String.endsWith ":" word then
                word
                    |> String.dropRight 1
                    |> Metadata
                    |> Ok

................................................................................

                    "[" ->
                        Ok QuoteStart

                    "]" ->
                        Ok QuoteStop

                    ")" ->
                        Ok ParenStop

                    _ ->
                        Ok (Symbol word)


stringStartsWithUpper : String -> Bool
stringStartsWithUpper str =
    case String.uncons str of
        Just ( firstLetter, _ ) ->
            Char.isUpper firstLetter

        Nothing ->
            False

Modified src/Play/TypeChecker.elm from [629157f0cd] to [6494394c39].

27
28
29
30
31
32
33
34










35
36
37
38
39
40
41
...
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
...
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
...
277
278
279
280
281
282
283

















284
285
286
287
288
289
290
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
    , metadata : Metadata
    , implementation : WordImplementation
    }


type WordImplementation
    = SoloImpl (List AstNode)
    | MultiImpl (List ( Type, List AstNode )) (List AstNode)












type AstNode
    = IntLiteral Int
    | Word String WordType
    | WordRef String
    | ConstructType String
................................................................................
                                            typeCheckImplementation untypedDef defaultImpl (cleanContext context)
                                    in
                                    case inferredDefaultType.input of
                                        [] ->
                                            Debug.todo "Default impl doesn't have an input argument"

                                        firstType :: _ ->
                                            ( firstType, defaultImpl ) :: initialWhens

                        inferWhenTypes ( _, im ) ( infs, ctx ) =
                            let
                                ( inf, newCtx ) =
                                    typeCheckImplementation untypedDef im (cleanContext ctx)
                            in
                            ( inf :: infs, newCtx )
................................................................................

                        whensAreCompatible =
                            inferredWhenTypes
                                |> List.map stripFirstInput
                                |> List.map countOutput
                                |> areAllEqual

                        typeCheckWhen ( forType, inf ) =
                            case inf.input of
                                firstInput :: _ ->
                                    let
                                        compatible =
                                            case firstInput of
                                                Type.Generic _ ->
                                                    True
................................................................................

                                first :: rest ->
                                    List.all ((==) first) rest

                        inferredType =
                            List.head inferredWhenTypes
                                |> Maybe.withDefault { input = [], output = [] }
                                |> replaceFirstType (Type.Union (List.map Tuple.first whens))
                                |> joinOutputs (List.map .output inferredWhenTypes)

                        replaceFirstType with inf =
                            case inf.input of
                                _ :: rem ->
                                    { inf | input = with :: rem }

................................................................................

                                joined :: [] ->
                                    { result | output = joined }

                                _ ->
                                    result


















                        finalContext =
                            { newContext
                                | typedWords =
                                    Dict.insert untypedDef.name
                                        { name = untypedDef.name
                                        , type_ =
                                            case untypedDef.metadata.type_ of
................................................................................
                                                    }

                                                Nothing ->
                                                    inferredType
                                        , metadata = untypedDef.metadata
                                        , implementation =
                                            MultiImpl
                                                (List.map (Tuple.mapSecond (List.map (untypedToTypedNode newContext))) whens)
                                                (List.map (untypedToTypedNode newContext) defaultImpl)
                                        }
                                        newContext.typedWords
                                , errors =
                                    if whensAreConsistent && whensAreCompatible then
                                        newContext.errors








|
>
>
>
>
>
>
>
>
>
>







 







|







 







|







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







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
...
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
...
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
...
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
...
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
...
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
    , metadata : Metadata
    , implementation : WordImplementation
    }


type WordImplementation
    = SoloImpl (List AstNode)
    | MultiImpl (List ( TypeMatch, List AstNode )) (List AstNode)


type TypeMatch
    = TypeMatch Type (List ( String, TypeMatchValue ))


type TypeMatchValue
    = LiteralInt Int
    | LiteralType Type
    | RecursiveMatch TypeMatch


type AstNode
    = IntLiteral Int
    | Word String WordType
    | WordRef String
    | ConstructType String
................................................................................
                                            typeCheckImplementation untypedDef defaultImpl (cleanContext context)
                                    in
                                    case inferredDefaultType.input of
                                        [] ->
                                            Debug.todo "Default impl doesn't have an input argument"

                                        firstType :: _ ->
                                            ( Qualifier.TypeMatch firstType [], defaultImpl ) :: initialWhens

                        inferWhenTypes ( _, im ) ( infs, ctx ) =
                            let
                                ( inf, newCtx ) =
                                    typeCheckImplementation untypedDef im (cleanContext ctx)
                            in
                            ( inf :: infs, newCtx )
................................................................................

                        whensAreCompatible =
                            inferredWhenTypes
                                |> List.map stripFirstInput
                                |> List.map countOutput
                                |> areAllEqual

                        typeCheckWhen ( Qualifier.TypeMatch forType _, inf ) =
                            case inf.input of
                                firstInput :: _ ->
                                    let
                                        compatible =
                                            case firstInput of
                                                Type.Generic _ ->
                                                    True
................................................................................

                                first :: rest ->
                                    List.all ((==) first) rest

                        inferredType =
                            List.head inferredWhenTypes
                                |> Maybe.withDefault { input = [], output = [] }
                                |> replaceFirstType (Type.Union (List.map (Tuple.first >> extractType) whens))
                                |> joinOutputs (List.map .output inferredWhenTypes)

                        replaceFirstType with inf =
                            case inf.input of
                                _ :: rem ->
                                    { inf | input = with :: rem }

................................................................................

                                joined :: [] ->
                                    { result | output = joined }

                                _ ->
                                    result

                        extractType (Qualifier.TypeMatch t_ _) =
                            t_

                        mapTypeMatch (Qualifier.TypeMatch type_ cond) =
                            TypeMatch type_ (List.map mapTypeMatchValue cond)

                        mapTypeMatchValue ( fieldName, value ) =
                            case value of
                                Qualifier.LiteralInt val ->
                                    ( fieldName, LiteralInt val )

                                Qualifier.LiteralType val ->
                                    ( fieldName, LiteralType val )

                                Qualifier.RecursiveMatch val ->
                                    ( fieldName, RecursiveMatch (mapTypeMatch val) )

                        finalContext =
                            { newContext
                                | typedWords =
                                    Dict.insert untypedDef.name
                                        { name = untypedDef.name
                                        , type_ =
                                            case untypedDef.metadata.type_ of
................................................................................
                                                    }

                                                Nothing ->
                                                    inferredType
                                        , metadata = untypedDef.metadata
                                        , implementation =
                                            MultiImpl
                                                (List.map (Tuple.mapBoth mapTypeMatch (List.map (untypedToTypedNode newContext))) initialWhens)
                                                (List.map (untypedToTypedNode newContext) defaultImpl)
                                        }
                                        newContext.typedWords
                                , errors =
                                    if whensAreConsistent && whensAreCompatible then
                                        newContext.errors

Modified src/Wasm.elm from [e3efcd7ac0] to [eecc5bc806].

351
352
353
354
355
356
357







358
359
360
361
362
363
364

        Call word ->
            case List.findIndex (\f -> f.name == word) module_.functions of
                Just idx ->
                    Str <| "(call " ++ String.fromInt idx ++ ") ;; $" ++ word

                Nothing ->







                    Debug.todo "Did not expect this"

        CallIndirect ->
            Str <| "call_indirect"

        FunctionIndex word ->
            case List.findIndex (\f -> f.name == word) module_.functions of







>
>
>
>
>
>
>







351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371

        Call word ->
            case List.findIndex (\f -> f.name == word) module_.functions of
                Just idx ->
                    Str <| "(call " ++ String.fromInt idx ++ ") ;; $" ++ word

                Nothing ->
                    let
                        _ =
                            Debug.log "name" word

                        _ =
                            Debug.log "available" (List.map .name module_.functions)
                    in
                    Debug.todo "Did not expect this"

        CallIndirect ->
            Str <| "call_indirect"

        FunctionIndex word ->
            case List.findIndex (\f -> f.name == word) module_.functions of

Added test_expression.js version [38206c5380].



















































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
const compiler = require('./wasm_tests/compiler.wrapper');
const wabt = require('wabt')();

const memory = new WebAssembly.Memory({
    initial: 1
});

global.memView = new Uint32Array(memory.buffer, 0, 512);

async function init() {
    const wat = await compiler.toWat(`
        deftype: Box
        : { value: Int }

        deftype: BoxOfBox
        : { box: Box }

        defmulti: deep-one?
        when: BoxOfBox( box Box( value 1 ) )
          drop 1
        : drop 0

        def: main
        entry: true
        : 1 >Box >BoxOfBox deep-one?
    `);

    const wasmModule = wabt.parseWat('tmp', wat).toBinary({}).buffer;

    const imports = {
        host: {
            memory: memory
        }
    };

    const program = await WebAssembly.instantiate(wasmModule, imports);
    debugger;
    program.instance.exports.main();
}

init();

Modified tests/Test/Parser.elm from [1079581fec] to [f5a64c21f5].

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
...
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
...
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
...
256
257
258
259
260
261
262
263
264

265
266
267
268
269
270
271
272
273
274
...
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


343

344
345

346
347
348
349
350
351
352
...
393
394
395
396
397
398
399
400
401

402
403
404
405
406
407
408
409
410

411
412
413
414
415
416
417
418
419
420
421
422
423
424
...
468
469
470
471
472
473
474
475
476

477
478
479
480
481
482
483
484
485

486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502















503













































































































































                    expectedAst =
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Word "+"
                                        ]
                                  }
                                , { name = "dec"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Int ] [ Type.Int ]
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Word "-"
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Word "inc"
                                        , AST.Word "inc"
                                        , AST.Word "dec"
                                        , AST.Integer 2
                                        , AST.Word "="
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">True"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "True" ]
                                  , whens = []

                                  , implementation = [ AST.ConstructType "True" ]
                                  }
                                , { name = "as-int"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "True" ] [ Type.Int ]
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">Person"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Int, Type.Int ] [ Type.Custom "Person" ]
                                  , whens = []
                                  , implementation = [ AST.ConstructType "Person" ]
                                  }
                                , { name = ">age"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person", Type.Int ] [ Type.Custom "Person" ]
                                  , whens = []
                                  , implementation = [ AST.SetMember "Person" "age" ]
                                  }
                                , { name = ">jobs"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person", Type.Int ] [ Type.Custom "Person" ]
                                  , whens = []
                                  , implementation = [ AST.SetMember "Person" "jobs" ]
                                  }
                                , { name = "age>"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]
                                  , whens = []
                                  , implementation = [ AST.GetMember "Person" "age" ]
                                  }
                                , { name = "jobs>"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]
                                  , whens = []
                                  , implementation = [ AST.GetMember "Person" "jobs" ]
                                  }
                                , { name = "get-age"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]
                                  , whens = []
                                  , implementation =

                                        [ AST.Word "age>"
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                            Dict.fromListBy .name
                                [ { name = "over"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                [ Type.Generic "a", Type.Generic "b" ]
                                                [ Type.Generic "a", Type.Generic "b", Type.Generic "a" ]
                                  , whens = []
                                  , implementation =

                                        [ AST.Word "dup"
                                        , AST.Word "rotate"
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">True"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "True" ]
                                  , whens = []
                                  , implementation =

                                        [ AST.ConstructType "True"
                                        ]
                                  }
                                , { name = ">False"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "False" ]
                                  , whens = []
                                  , implementation =

                                        [ AST.ConstructType "False"
                                        ]
                                  }
                                , { name = "to-int"
                                  , metadata = Metadata.default
                                  , whens =


                                        [ ( Type.Custom "False", [ AST.Integer 0 ] )


                                        , ( Type.Custom "True", [ AST.Integer 1 ] )

                                        ]
                                  , implementation = []

                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                [ Type.Int
                                                , Type.Quotation { input = [ Type.Int ], output = [ Type.Int ] }
                                                ]
                                                [ Type.Int ]
                                  , whens = []
                                  , implementation =

                                        [ AST.Word "!"
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Quotation
                                            [ AST.Integer 1
                                            , AST.Word "+"
                                            ]
                                        , AST.Word "apply-to-num"
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                                [ Type.StackRange "a"
                                                , Type.Quotation
                                                    { input = [ Type.StackRange "a" ]
                                                    , output = [ Type.StackRange "b" ]
                                                    }
                                                ]
                                                [ Type.StackRange "b" ]
                                  , whens = []
                                  , implementation =

                                        [ AST.Word "!"
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Quotation
                                            [ AST.Integer 1
                                            , AST.Word "+"
                                            ]
                                        , AST.Word "apply-to-num"
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"

                    Ok ast ->
                        Expect.equal expectedAst ast















        ]



















































































































































<

>
|
|
|





<

>
|
|
|





<

>
|
|
|
|
|
|
|







 







|
>
|





<

>
|
|







 







|
|





|
|





|
|





|
|





|
|





<

>
|
|







 







<

>
|
|
|







 







<

>
|
|





<

>
|
|



|
>
>
|
>
>
|
>
|
<
>







 







<

>
|
|





<

>
|
|
|
|
|
|
|







 







<

>
|
|





<

>
|
|
|
|
|
|
|










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
...
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
...
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
...
257
258
259
260
261
262
263

264
265
266
267
268
269
270
271
272
273
274
275
...
319
320
321
322
323
324
325

326
327
328
329
330
331
332
333
334

335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

351
352
353
354
355
356
357
358
...
399
400
401
402
403
404
405

406
407
408
409
410
411
412
413
414

415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
...
474
475
476
477
478
479
480

481
482
483
484
485
486
487
488
489

490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664

                    expectedAst =
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default

                                  , implementation =
                                        SoloImpl
                                            [ AST.Integer 1
                                            , AST.Word "+"
                                            ]
                                  }
                                , { name = "dec"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Int ] [ Type.Int ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.Integer 1
                                            , AST.Word "-"
                                            ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint

                                  , implementation =
                                        SoloImpl
                                            [ AST.Integer 1
                                            , AST.Word "inc"
                                            , AST.Word "inc"
                                            , AST.Word "dec"
                                            , AST.Integer 2
                                            , AST.Word "="
                                            ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">True"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "True" ]
                                  , implementation =
                                        SoloImpl
                                            [ AST.ConstructType "True" ]
                                  }
                                , { name = "as-int"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "True" ] [ Type.Int ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.Integer 1
                                            ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">Person"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Int, Type.Int ] [ Type.Custom "Person" ]
                                  , implementation =
                                        SoloImpl [ AST.ConstructType "Person" ]
                                  }
                                , { name = ">age"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person", Type.Int ] [ Type.Custom "Person" ]
                                  , implementation =
                                        SoloImpl [ AST.SetMember "Person" "age" ]
                                  }
                                , { name = ">jobs"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person", Type.Int ] [ Type.Custom "Person" ]
                                  , implementation =
                                        SoloImpl [ AST.SetMember "Person" "jobs" ]
                                  }
                                , { name = "age>"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]
                                  , implementation =
                                        SoloImpl [ AST.GetMember "Person" "age" ]
                                  }
                                , { name = "jobs>"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]
                                  , implementation =
                                        SoloImpl [ AST.GetMember "Person" "jobs" ]
                                  }
                                , { name = "get-age"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.Word "age>"
                                            ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                            Dict.fromListBy .name
                                [ { name = "over"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                [ Type.Generic "a", Type.Generic "b" ]
                                                [ Type.Generic "a", Type.Generic "b", Type.Generic "a" ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.Word "dup"
                                            , AST.Word "rotate"
                                            ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">True"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "True" ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.ConstructType "True"
                                            ]
                                  }
                                , { name = ">False"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "False" ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.ConstructType "False"
                                            ]
                                  }
                                , { name = "to-int"
                                  , metadata = Metadata.default
                                  , implementation =
                                        MultiImpl
                                            [ ( TypeMatch (Type.Custom "False") []
                                              , [ AST.Integer 0 ]
                                              )
                                            , ( TypeMatch (Type.Custom "True") []
                                              , [ AST.Integer 1 ]
                                              )
                                            ]

                                            []
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                [ Type.Int
                                                , Type.Quotation { input = [ Type.Int ], output = [ Type.Int ] }
                                                ]
                                                [ Type.Int ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.Word "!"
                                            ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint

                                  , implementation =
                                        SoloImpl
                                            [ AST.Integer 1
                                            , AST.Quotation
                                                [ AST.Integer 1
                                                , AST.Word "+"
                                                ]
                                            , AST.Word "apply-to-num"
                                            ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"
................................................................................
                                                [ Type.StackRange "a"
                                                , Type.Quotation
                                                    { input = [ Type.StackRange "a" ]
                                                    , output = [ Type.StackRange "b" ]
                                                    }
                                                ]
                                                [ Type.StackRange "b" ]

                                  , implementation =
                                        SoloImpl
                                            [ AST.Word "!"
                                            ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint

                                  , implementation =
                                        SoloImpl
                                            [ AST.Integer 1
                                            , AST.Quotation
                                                [ AST.Integer 1
                                                , AST.Word "+"
                                                ]
                                            , AST.Word "apply-to-num"
                                            ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"

                    Ok ast ->
                        Expect.equal expectedAst ast
        , describe "Pattern matching"
            [ test "Single match" <|
                \_ ->
                    let
                        source =
                            [ Metadata "defmulti"
                            , Symbol "zero?"
                            , Metadata "when"
                            , PatternMatchStart "Int"
                            , Symbol "value"
                            , Token.Integer 0
                            , ParenStop
                            , Symbol ">True"
                            , Metadata ""
                            , Symbol ">False"
                            ]

                        expectedAst =
                            { types = Dict.empty
                            , words =
                                Dict.fromListBy .name
                                    [ { name = "zero?"
                                      , metadata = Metadata.default
                                      , implementation =
                                            MultiImpl
                                                [ ( TypeMatch Type.Int [ ( "value", AST.LiteralInt 0 ) ], [ AST.Word ">True" ] )
                                                ]
                                                [ AST.Word ">False" ]
                                      }
                                    ]
                            }
                    in
                    case parse source of
                        Err () ->
                            Expect.fail "Did not expect parsing to fail"

                        Ok ast ->
                            Expect.equal expectedAst ast
            , test "Recursive match" <|
                \_ ->
                    let
                        source =
                            [ Metadata "defmulti"
                            , Symbol "pair?"
                            , Metadata "when"
                            , PatternMatchStart "List"
                            , Symbol "tail"
                            , PatternMatchStart "List"
                            , Symbol "tail"
                            , Type "Nil"
                            , ParenStop
                            , ParenStop
                            , Symbol ">True"
                            , Metadata ""
                            , Symbol ">False"
                            ]

                        expectedAst =
                            { types = Dict.empty
                            , words =
                                Dict.fromListBy .name
                                    [ { name = "pair?"
                                      , metadata = Metadata.default
                                      , implementation =
                                            MultiImpl
                                                [ ( TypeMatch (Type.Custom "List")
                                                        [ ( "tail"
                                                          , AST.RecursiveMatch
                                                                (TypeMatch (Type.Custom "List")
                                                                    [ ( "tail", AST.LiteralType (Type.Custom "Nil") )
                                                                    ]
                                                                )
                                                          )
                                                        ]
                                                  , [ AST.Word ">True" ]
                                                  )
                                                ]
                                                [ AST.Word ">False" ]
                                      }
                                    ]
                            }
                    in
                    case parse source of
                        Err () ->
                            Expect.fail "Did not expect parsing to fail"

                        Ok ast ->
                            Expect.equal expectedAst ast
            , test "Multiple match" <|
                \_ ->
                    let
                        source =
                            [ Metadata "defmulti"
                            , Symbol "origo?"
                            , Metadata "when"
                            , PatternMatchStart "Pair"
                            , Symbol "first"
                            , Token.Integer 0
                            , Symbol "second"
                            , Token.Integer 0
                            , ParenStop
                            , Symbol ">True"
                            , Metadata ""
                            , Symbol ">False"
                            ]

                        expectedAst =
                            { types = Dict.empty
                            , words =
                                Dict.fromListBy .name
                                    [ { name = "origo?"
                                      , metadata = Metadata.default
                                      , implementation =
                                            MultiImpl
                                                [ ( TypeMatch (Type.Custom "Pair")
                                                        [ ( "first", AST.LiteralInt 0 )
                                                        , ( "second", AST.LiteralInt 0 )
                                                        ]
                                                  , [ AST.Word ">True" ]
                                                  )
                                                ]
                                                [ AST.Word ">False" ]
                                      }
                                    ]
                            }
                    in
                    case parse source of
                        Err () ->
                            Expect.fail "Did not expect parsing to fail"

                        Ok ast ->
                            Expect.equal expectedAst ast
            , test "Syntax error" <|
                \_ ->
                    let
                        source =
                            [ Metadata "defmulti"
                            , Symbol "origo?"
                            , Metadata "when"
                            , PatternMatchStart "Pair"
                            , Token.Integer 0
                            , Token.Integer 0
                            , ParenStop
                            , Symbol ">True"
                            , Metadata ""
                            , Symbol ">False"
                            ]
                    in
                    case parse source of
                        Err () ->
                            Expect.pass

                        Ok ast ->
                            Expect.fail "Did not expect parsing to succeed"
            ]
        ]

Modified tests/Test/Qualifier.elm from [05a10dab9a] to [aeb7758a23].

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
...
106
107
108
109
110
111
112
113
114

115
116
117
118
119
120
121
122
123
124
125
...
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
...
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
...
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
...
350
351
352
353
354
355
356
357
358

359
360
361
362
363
364
365
366
367
368
369

370
371
372
373
374
375
376
377
378
379
...
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411










412













































































































































                let
                    unqualifiedAst =
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Word "+"
                                        ]
                                  }
                                , { name = "dec"
                                  , metadata = Metadata.default
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Word "-"
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , whens = []
                                  , implementation =

                                        [ AST.Integer 1
                                        , AST.Word "inc"
                                        , AST.Word "inc"
                                        , AST.Word "dec"
                                        , AST.Integer 2
                                        , AST.Word "="
                                        ]
                                  }
                                ]
                        }

                    expectedAst =
                        { types = Dict.empty
                        , words =
................................................................................
                            Dict.fromListBy .name
                                [ { name = "over"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                [ Type.Generic "a", Type.Generic "b" ]
                                                [ Type.Generic "a", Type.Generic "b", Type.Generic "a" ]
                                  , whens = []
                                  , implementation =

                                        [ AST.Word "swap"
                                        , AST.Word "dup"
                                        , AST.Word "rotate"
                                        ]
                                  }
                                ]
                        }

                    expectedAst =
                        { types = Dict.empty
                        , words =
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">True"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "True" ]
                                  , whens = []
                                  , implementation =

                                        [ AST.ConstructType "True"
                                        ]
                                  }
                                , { name = ">False"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "False" ]
                                  , whens = []
                                  , implementation =

                                        [ AST.ConstructType "False"
                                        ]
                                  }
                                , { name = "to-int"
                                  , metadata = Metadata.default
                                  , whens =
                                        [ ( Type.Custom "False", [ AST.Integer 0 ] )
                                        , ( Type.Custom "True", [ AST.Integer 1 ] )

                                        ]
                                  , implementation = []

                                  }
                                ]
                        }

                    expectedAst =
                        { types =
                            Dict.fromListBy typeDefinitionName
................................................................................
                                            [ ConstructType "False"
                                            ]
                                  }
                                , { name = "to-int"
                                  , metadata = Metadata.default
                                  , implementation =
                                        MultiImpl
                                            [ ( Type.Custom "False", [ Integer 0 ] )
                                            , ( Type.Custom "True", [ Integer 1 ] )
                                            ]
                                            []
                                  }
                                ]
                        }
                in
                case qualify unqualifiedAst of
................................................................................
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType
                                                    [ Type.Int
                                                    , Type.Quotation { input = [ Type.Int ], output = [ Type.Int ] }
                                                    ]
                                                    [ Type.Int ]
                                      , whens = []
                                      , implementation =

                                            [ AST.Word "!"
                                            ]
                                      }
                                    , { name = "main"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.asEntryPoint
                                      , whens = []
                                      , implementation =

                                            [ AST.Integer 1
                                            , AST.Quotation
                                                [ AST.Integer 1
                                                , AST.Word "+"
                                                ]
                                            , AST.Word "apply-to-num"
                                            , AST.Quotation
                                                [ AST.Integer 1
                                                , AST.Word "-"
                                                ]
                                            , AST.Word "apply-to-num"
                                            ]
                                      }
                                    ]
                            }

                        expectedAst =
                            { types = Dict.empty
                            , words =
................................................................................
                            { types = Dict.empty
                            , words =
                                Dict.fromListBy .name
                                    [ { name = "main"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.asEntryPoint
                                      , whens = []
                                      , implementation =

                                            [ AST.Integer 1
                                            , AST.Quotation
                                                [ AST.Word "inc"
                                                ]
                                            , AST.Word "!"
                                            ]
                                      }
                                    , { name = "inc"
                                      , metadata = Metadata.default
                                      , whens = []
                                      , implementation =

                                            [ AST.Integer 1
                                            , AST.Word "+"
                                            ]
                                      }
                                    ]
                            }

                        expectedAst =
                            { types = Dict.empty
                            , words =
................................................................................
                                            SoloImpl
                                                [ Integer 1
                                                , Builtin Builtin.Plus
                                                ]
                                      }
                                    ]
                            }
                    in
                    case qualify unqualifiedAst of
                        Err () ->
                            Expect.fail "Did not expect qualification to fail"

                        Ok qualifiedAst ->
                            Expect.equal expectedAst qualifiedAst
            ]










        ]




















































































































































<

>
|
|
|



<

>
|
|
|





<

>
|
|
|
|
|
|
|







 







<

>
|
|
|
|







 







<

>
|
|





<

>
|
|



|
|
|
>
|
<
>







 







|
|







 







<

>
|
|





<

>
|
|
|
|
|
|
|
|
|
|
|
|







 







<

>
|
|
|
|
|
|



<

>
|
|
|







 















>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
...
106
107
108
109
110
111
112

113
114
115
116
117
118
119
120
121
122
123
124
125
...
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
...
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
...
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
...
351
352
353
354
355
356
357

358
359
360
361
362
363
364
365
366
367
368

369
370
371
372
373
374
375
376
377
378
379
380
...
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
                let
                    unqualifiedAst =
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default

                                  , implementation =
                                        AST.SoloImpl
                                            [ AST.Integer 1
                                            , AST.Word "+"
                                            ]
                                  }
                                , { name = "dec"
                                  , metadata = Metadata.default

                                  , implementation =
                                        AST.SoloImpl
                                            [ AST.Integer 1
                                            , AST.Word "-"
                                            ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint

                                  , implementation =
                                        AST.SoloImpl
                                            [ AST.Integer 1
                                            , AST.Word "inc"
                                            , AST.Word "inc"
                                            , AST.Word "dec"
                                            , AST.Integer 2
                                            , AST.Word "="
                                            ]
                                  }
                                ]
                        }

                    expectedAst =
                        { types = Dict.empty
                        , words =
................................................................................
                            Dict.fromListBy .name
                                [ { name = "over"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                [ Type.Generic "a", Type.Generic "b" ]
                                                [ Type.Generic "a", Type.Generic "b", Type.Generic "a" ]

                                  , implementation =
                                        AST.SoloImpl
                                            [ AST.Word "swap"
                                            , AST.Word "dup"
                                            , AST.Word "rotate"
                                            ]
                                  }
                                ]
                        }

                    expectedAst =
                        { types = Dict.empty
                        , words =
................................................................................
                                ]
                        , words =
                            Dict.fromListBy .name
                                [ { name = ">True"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "True" ]

                                  , implementation =
                                        AST.SoloImpl
                                            [ AST.ConstructType "True"
                                            ]
                                  }
                                , { name = ">False"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Custom "False" ]

                                  , implementation =
                                        AST.SoloImpl
                                            [ AST.ConstructType "False"
                                            ]
                                  }
                                , { name = "to-int"
                                  , metadata = Metadata.default
                                  , implementation =
                                        AST.MultiImpl
                                            [ ( AST.TypeMatch (Type.Custom "False") [], [ AST.Integer 0 ] )
                                            , ( AST.TypeMatch (Type.Custom "True") [], [ AST.Integer 1 ] )
                                            ]

                                            []
                                  }
                                ]
                        }

                    expectedAst =
                        { types =
                            Dict.fromListBy typeDefinitionName
................................................................................
                                            [ ConstructType "False"
                                            ]
                                  }
                                , { name = "to-int"
                                  , metadata = Metadata.default
                                  , implementation =
                                        MultiImpl
                                            [ ( TypeMatch (Type.Custom "False") [], [ Integer 0 ] )
                                            , ( TypeMatch (Type.Custom "True") [], [ Integer 1 ] )
                                            ]
                                            []
                                  }
                                ]
                        }
                in
                case qualify unqualifiedAst of
................................................................................
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType
                                                    [ Type.Int
                                                    , Type.Quotation { input = [ Type.Int ], output = [ Type.Int ] }
                                                    ]
                                                    [ Type.Int ]

                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.Word "!"
                                                ]
                                      }
                                    , { name = "main"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.asEntryPoint

                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.Integer 1
                                                , AST.Quotation
                                                    [ AST.Integer 1
                                                    , AST.Word "+"
                                                    ]
                                                , AST.Word "apply-to-num"
                                                , AST.Quotation
                                                    [ AST.Integer 1
                                                    , AST.Word "-"
                                                    ]
                                                , AST.Word "apply-to-num"
                                                ]
                                      }
                                    ]
                            }

                        expectedAst =
                            { types = Dict.empty
                            , words =
................................................................................
                            { types = Dict.empty
                            , words =
                                Dict.fromListBy .name
                                    [ { name = "main"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.asEntryPoint

                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.Integer 1
                                                , AST.Quotation
                                                    [ AST.Word "inc"
                                                    ]
                                                , AST.Word "!"
                                                ]
                                      }
                                    , { name = "inc"
                                      , metadata = Metadata.default

                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.Integer 1
                                                , AST.Word "+"
                                                ]
                                      }
                                    ]
                            }

                        expectedAst =
                            { types = Dict.empty
                            , words =
................................................................................
                                            SoloImpl
                                                [ Integer 1
                                                , Builtin Builtin.Plus
                                                ]
                                      }
                                    ]
                            }
                    in
                    case qualify unqualifiedAst of
                        Err () ->
                            Expect.fail "Did not expect qualification to fail"

                        Ok qualifiedAst ->
                            Expect.equal expectedAst qualifiedAst
            ]
        , describe "Pattern matching"
            [ test "Basic example" <|
                \_ ->
                    let
                        unqualifiedAst =
                            { types =
                                Dict.fromListBy AST.typeDefinitionName
                                    [ AST.UnionTypeDef "Bool"
                                        [ Type.Custom "True"
                                        , Type.Custom "False"
                                        ]
                                    , AST.CustomTypeDef "True" []
                                    , AST.CustomTypeDef "False" []
                                    , AST.CustomTypeDef "Box"
                                        [ ( "value", Type.Int ) ]
                                    ]
                            , words =
                                Dict.fromListBy .name
                                    [ { name = ">True"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [] [ Type.Custom "True" ]
                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.ConstructType "True"
                                                ]
                                      }
                                    , { name = ">False"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [] [ Type.Custom "False" ]
                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.ConstructType "False"
                                                ]
                                      }
                                    , { name = ">Box"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [ Type.Int ] [ Type.Custom "Box" ]
                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.ConstructType "Box"
                                                ]
                                      }
                                    , { name = ">value"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [ Type.Int, Type.Custom "Box" ] [ Type.Custom "Box" ]
                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.SetMember "Box" "value"
                                                ]
                                      }
                                    , { name = "<value"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [ Type.Custom "Box" ] [ Type.Int ]
                                      , implementation =
                                            AST.SoloImpl
                                                [ AST.GetMember "Box" "value"
                                                ]
                                      }
                                    , { name = "zero?"
                                      , metadata = Metadata.default
                                      , implementation =
                                            AST.MultiImpl
                                                [ ( AST.TypeMatch (Type.Custom "Box") [ ( "value", AST.LiteralInt 0 ) ], [ AST.Word ">True" ] )
                                                ]
                                                [ AST.Word ">False" ]
                                      }
                                    ]
                            }

                        expectedAst =
                            { types =
                                Dict.fromListBy typeDefinitionName
                                    [ UnionTypeDef "Bool"
                                        [ Type.Custom "True"
                                        , Type.Custom "False"
                                        ]
                                    , CustomTypeDef "True" []
                                    , CustomTypeDef "False" []
                                    , CustomTypeDef "Box"
                                        [ ( "value", Type.Int ) ]
                                    ]
                            , words =
                                Dict.fromListBy .name
                                    [ { name = ">True"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [] [ Type.Custom "True" ]
                                      , implementation =
                                            SoloImpl
                                                [ ConstructType "True"
                                                ]
                                      }
                                    , { name = ">False"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [] [ Type.Custom "False" ]
                                      , implementation =
                                            SoloImpl
                                                [ ConstructType "False"
                                                ]
                                      }
                                    , { name = ">Box"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [ Type.Int ] [ Type.Custom "Box" ]
                                      , implementation =
                                            SoloImpl
                                                [ ConstructType "Box"
                                                ]
                                      }
                                    , { name = ">value"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [ Type.Int, Type.Custom "Box" ] [ Type.Custom "Box" ]
                                      , implementation =
                                            SoloImpl
                                                [ SetMember "Box" "value"
                                                ]
                                      }
                                    , { name = "<value"
                                      , metadata =
                                            Metadata.default
                                                |> Metadata.withType [ Type.Custom "Box" ] [ Type.Int ]
                                      , implementation =
                                            SoloImpl
                                                [ GetMember "Box" "value"
                                                ]
                                      }
                                    , { name = "zero?"
                                      , metadata = Metadata.default
                                      , implementation =
                                            MultiImpl
                                                [ ( TypeMatch (Type.Custom "Box") [ ( "value", LiteralInt 0 ) ], [ Word ">True" ] )
                                                ]
                                                [ Word ">False" ]
                                      }
                                    ]
                            }
                    in
                    case qualify unqualifiedAst of
                        Err () ->
                            Expect.fail "Did not expect qualification to fail"

                        Ok qualifiedAst ->
                            Expect.equal expectedAst qualifiedAst
            ]
        ]

Modified tests/Test/Tokenizer.elm from [9f3551c843] to [744e9e4caa].

151
152
153
154
155
156
157





























158
159
160
161
162
163
164
165
                        , Integer 1
                        , QuoteStart
                        , Integer 1
                        , Symbol "+"
                        , QuoteStop
                        , Symbol "apply-to-num"
                        ]





























                in
                case tokenize source of
                    Err () ->
                        Expect.fail "Did not expect tokenization to fail"

                    Ok tokens ->
                        Expect.equalLists expectedTokens tokens
        ]







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








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
                        , Integer 1
                        , QuoteStart
                        , Integer 1
                        , Symbol "+"
                        , QuoteStop
                        , Symbol "apply-to-num"
                        ]
                in
                case tokenize source of
                    Err () ->
                        Expect.fail "Did not expect tokenization to fail"

                    Ok tokens ->
                        Expect.equalLists expectedTokens tokens
        , test "Pattern matching" <|
            \_ ->
                let
                    source =
                        """
                        defmulti: some
                        when: Type( age: 0 ) >True
                        : >False
                        """

                    expectedTokens =
                        [ Metadata "defmulti"
                        , Symbol "some"
                        , Metadata "when"
                        , PatternMatchStart "Type"
                        , Metadata "age"
                        , Integer 0
                        , ParenStop
                        , Symbol ">True"
                        , Metadata ""
                        , Symbol ">False"
                        ]
                in
                case tokenize source of
                    Err () ->
                        Expect.fail "Did not expect tokenization to fail"

                    Ok tokens ->
                        Expect.equalLists expectedTokens tokens
        ]

Modified tests/Test/TypeChecker.elm from [bcf2a915f8] to [3fc385a1bb].

377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
...
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
...
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
...
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
...
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
                    let
                        input =
                            template
                                { name = "to-int"
                                , metadata = Metadata.default
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( Type.Custom "False"
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        , ( Type.Custom "True"
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 1
                                            ]
                                          )
                                        ]
                                        []
                                }
................................................................................
                            template
                                { name = "to-int"
                                , metadata =
                                    Metadata.default
                                        |> Metadata.withType [ Type.Custom "Bool" ] [ Type.Int ]
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( Type.Custom "False"
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        , ( Type.Custom "True"
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 1
                                            ]
                                          )
                                        ]
                                        []
                                }
................................................................................
                            template
                                { name = "to-int"
                                , metadata =
                                    Metadata.default
                                        |> Metadata.withType [ Type.Custom "Bool" ] [ Type.Int ]
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( Type.Custom "False"
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        ]
                                        [ QAST.Builtin Builtin.StackDrop
                                        , QAST.Integer 1
................................................................................
                    let
                        input =
                            template
                                { name = "to-int"
                                , metadata = Metadata.default
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( Type.Custom "False"
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        ]
                                        [ QAST.Builtin Builtin.StackDrop
                                        , QAST.Integer 1
................................................................................
                                                [ QAST.SetMember "Dog" "man-years"
                                                ]
                                      }
                                    , { name = "add-to-age"
                                      , metadata = Metadata.default
                                      , implementation =
                                            QAST.MultiImpl
                                                [ ( Type.Custom "Person"
                                                  , [ QAST.Word ">age"
                                                    ]
                                                  )
                                                , ( Type.Custom "Dog"
                                                  , [ QAST.Integer 4
                                                    , QAST.Builtin Builtin.Multiply
                                                    , QAST.Word ">man-years"
                                                    ]
                                                  )
                                                ]
                                                []
                                      }
                                    , { name = "get-man-age"
                                      , metadata = Metadata.default
                                      , implementation =
                                            QAST.MultiImpl
                                                [ ( Type.Custom "Person"
                                                  , [ QAST.Word "age>" ]
                                                  )
                                                , ( Type.Custom "Dog"
                                                  , [ QAST.Word "man-years>" ]
                                                  )
                                                ]
                                                []
                                      }
                                    , { name = "main"
                                      , metadata =
................................................................................
                                                [ QAST.ConstructType "False"
                                                ]
                                      }
                                    , { name = "not"
                                      , metadata = Metadata.default
                                      , implementation =
                                            QAST.MultiImpl
                                                [ ( Type.Custom "True"
                                                  , [ QAST.Builtin Builtin.StackDrop
                                                    , QAST.Word ">False"
                                                    ]
                                                  )
                                                , ( Type.Custom "False"
                                                  , [ QAST.Builtin Builtin.StackDrop
                                                    , QAST.Word ">True"
                                                    ]
                                                  )
                                                ]
                                                []
                                      }







|




|







 







|




|







 







|







 







|







 







|



|












|


|







 







|




|







377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
...
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
...
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
...
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
...
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
                    let
                        input =
                            template
                                { name = "to-int"
                                , metadata = Metadata.default
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( QAST.TypeMatch (Type.Custom "False") []
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        , ( QAST.TypeMatch (Type.Custom "True") []
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 1
                                            ]
                                          )
                                        ]
                                        []
                                }
................................................................................
                            template
                                { name = "to-int"
                                , metadata =
                                    Metadata.default
                                        |> Metadata.withType [ Type.Custom "Bool" ] [ Type.Int ]
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( QAST.TypeMatch (Type.Custom "False") []
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        , ( QAST.TypeMatch (Type.Custom "True") []
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 1
                                            ]
                                          )
                                        ]
                                        []
                                }
................................................................................
                            template
                                { name = "to-int"
                                , metadata =
                                    Metadata.default
                                        |> Metadata.withType [ Type.Custom "Bool" ] [ Type.Int ]
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( QAST.TypeMatch (Type.Custom "False") []
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        ]
                                        [ QAST.Builtin Builtin.StackDrop
                                        , QAST.Integer 1
................................................................................
                    let
                        input =
                            template
                                { name = "to-int"
                                , metadata = Metadata.default
                                , implementation =
                                    QAST.MultiImpl
                                        [ ( QAST.TypeMatch (Type.Custom "False") []
                                          , [ QAST.Builtin Builtin.StackDrop
                                            , QAST.Integer 0
                                            ]
                                          )
                                        ]
                                        [ QAST.Builtin Builtin.StackDrop
                                        , QAST.Integer 1
................................................................................
                                                [ QAST.SetMember "Dog" "man-years"
                                                ]
                                      }
                                    , { name = "add-to-age"
                                      , metadata = Metadata.default
                                      , implementation =
                                            QAST.MultiImpl
                                                [ ( QAST.TypeMatch (Type.Custom "Person") []
                                                  , [ QAST.Word ">age"
                                                    ]
                                                  )
                                                , ( QAST.TypeMatch (Type.Custom "Dog") []
                                                  , [ QAST.Integer 4
                                                    , QAST.Builtin Builtin.Multiply
                                                    , QAST.Word ">man-years"
                                                    ]
                                                  )
                                                ]
                                                []
                                      }
                                    , { name = "get-man-age"
                                      , metadata = Metadata.default
                                      , implementation =
                                            QAST.MultiImpl
                                                [ ( QAST.TypeMatch (Type.Custom "Person") []
                                                  , [ QAST.Word "age>" ]
                                                  )
                                                , ( QAST.TypeMatch (Type.Custom "Dog") []
                                                  , [ QAST.Word "man-years>" ]
                                                  )
                                                ]
                                                []
                                      }
                                    , { name = "main"
                                      , metadata =
................................................................................
                                                [ QAST.ConstructType "False"
                                                ]
                                      }
                                    , { name = "not"
                                      , metadata = Metadata.default
                                      , implementation =
                                            QAST.MultiImpl
                                                [ ( QAST.TypeMatch (Type.Custom "True") []
                                                  , [ QAST.Builtin Builtin.StackDrop
                                                    , QAST.Word ">False"
                                                    ]
                                                  )
                                                , ( QAST.TypeMatch (Type.Custom "False") []
                                                  , [ QAST.Builtin Builtin.StackDrop
                                                    , QAST.Word ">True"
                                                    ]
                                                  )
                                                ]
                                                []
                                      }

Modified wasm_tests/multiword.test.js from [5d2fa1caec] to [bd081af685].

87
88
89
90
91
92
93

          -
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(20);
});








>
87
88
89
90
91
92
93
94
          -
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(20);
});

Added wasm_tests/pattern_match.test.js version [fa37862344].





















































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
const compiler = require('./compiler.wrapper');

test('Basic pattern match', async () => {
    const wat = await compiler.toWat(`
        deftype: Box
        : { value: Int }

        defmulti: not
        when: Box( value 0 )
          drop 1
        when: Box
          drop 0

        def: main
        entry: true
        : 0 >Box not
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(1);
});

test('Basic pattern match with default implementation', async () => {
    const wat = await compiler.toWat(`
        deftype: Box
        : { value: Int }

        defmulti: not
        when: Box( value 0 )
          drop 1
        : drop 0

        def: main
        entry: true
        : 0 >Box not
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(1);
});

test('Basic pattern match reverse case', async () => {
    const wat = await compiler.toWat(`
        deftype: Box
        : { value: Int }

        defmulti: not
        when: Box( value 0 )
          drop 1
        : drop 0

        def: main
        entry: true
        : 1 >Box not
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(0);
});

test('Multiple arguments', async () => {
    const wat = await compiler.toWat(`
        deftype: Point
        : { 
          first: Int
          second: Int
        }

        defmulti: origo?
        when: Point( first 0 second 0 )
          drop 1
        : drop 0

        def: main
        entry: true
        : 0 0 >Point origo?
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(1);
});

test('Multiple arguments reverse case', async () => {
    const wat = await compiler.toWat(`
        deftype: Point
        : { 
          first: Int
          second: Int
        }

        defmulti: origo?
        when: Point( first 0 second 0 )
          drop 1
        : drop 0

        def: main
        entry: true
        : 0 1 >Point origo?
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(0);
});

test('Recursive match', async () => {
    const wat = await compiler.toWat(`
        deftype: Box
        : { value: Int }

        deftype: BoxOfBox
        : { box: Box }

        defmulti: deep-one?
        when: BoxOfBox( box Box( value 1 ) )
          drop 1
        : drop 0

        def: main
        entry: true
        : 1 >Box >BoxOfBox deep-one?
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(1);
});

test('Recursive match reverse case', async () => {
    const wat = await compiler.toWat(`
        deftype: Box
        : { value: Int }

        deftype: BoxOfBox
        : { box: Box }

        defmulti: deep-one?
        when: BoxOfBox( box Box( value 1 ) )
          drop 1
        : drop 0

        def: main
        entry: true
        : 2 >Box >BoxOfBox deep-one?
    `);

    const result = await compiler.run(wat, 'main');

    expect(result.stackElement()).toBe(0);
});