Play

Check-in [32f58d1269]
Login
Overview
Comment:Add support for stack manipulation functions and generic function types.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 32f58d1269414b51fe81aca871521aa3f4d9be9076f4dc058dcf4df49eee7c96
User & Date: robin.hansen on 2020-04-10 12:21:50
Other Links: manifest | tags
Context
2020-04-14
17:09
Parser now understands union type definitions. check-in: 563df19e0c user: robin.hansen tags: trunk
16:25
Create new branch named "unions" check-in: 6aeef33924 user: robin.hansen tags: unions
2020-04-10
12:21
Add support for stack manipulation functions and generic function types. check-in: 32f58d1269 user: robin.hansen tags: trunk
12:20
Solve remaining issues with type checker for generic function types. Closed-Leaf check-in: 369c9800a9 user: robin.hansen tags: stack-manipulation
2020-04-05
16:06
Play now supports compund types. check-in: d3329c2b01 user: robin.hansen tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified src/Play/Codegen.elm from [aec5a26ca2] to [5de36d27b3].

1
2
3
4

5
6
7
8
9
10
11
..
71
72
73
74
75
76
77










78
79
80
81
82










83
84
85
86
87










88
89
90
91
92
93
94
...
196
197
198
199
200
201
202

























203
204
205
206
207
208
209
...
211
212
213
214
215
216
217










































218
219
220
221
222
223
224
...
239
240
241
242
243
244
245




























246
247
248
249
250
251
252
...
411
412
413
414
415
416
417
418


419
420
421
422
423






424
425















426
427
428
429
430
431
432
433
module Play.Codegen exposing (..)

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

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


type alias TypeInformation =
    { id : Int
................................................................................
    "__add_i32"


subIntFn : String
subIntFn =
    "__sub_i32"












eqIntFn : String
eqIntFn =
    "__eq_i32"












swapFn : String
swapFn =
    "__swap"













-- Base module


baseModule : Wasm.Module
baseModule =
................................................................................
                , 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 = swapFn
            , exported = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32 ]
................................................................................
                [ Wasm.Call stackPopFn
                , Wasm.Local_Set 0
                , Wasm.Call stackPopFn
                , Wasm.Local_Get 0
                , Wasm.Call stackPushFn
                , Wasm.Call stackPushFn
                ]










































            }
        |> Wasm.withFunction
            { name = addIntFn
            , exported = False
            , args = []
            , results = []
            , locals = []
................................................................................
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Sub
                , Wasm.Call stackPushFn
                ]




























            }
        |> Wasm.withFunction
            { name = eqIntFn
            , exported = False
            , args = []
            , locals = []
            , results = []
................................................................................
                        , Wasm.I32_Load -- Retrieve member
                        , Wasm.Call stackPushFn -- Push member onto stack
                        ]

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

        AST.BuiltinPlus ->


            Wasm.Call addIntFn

        AST.BuiltinMinus ->
            Wasm.Call subIntFn







        AST.BuiltinEqual ->
            Wasm.Call eqIntFn

















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
..
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
...
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
...
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
...
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
...
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
module Play.Codegen exposing (..)

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


type alias TypeInformation =
    { id : Int
................................................................................
    "__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"



-- Base module


baseModule : Wasm.Module
baseModule =
................................................................................
                , 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
            , 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
            , args = []
            , results = []
            , locals = []
            , instructions =
                [ Wasm.Call stackPopFn
                , Wasm.Drop
                ]
            }
        |> Wasm.withFunction
            { name = swapFn
            , exported = False
            , args = []
            , results = []
            , locals = [ Wasm.Int32 ]
................................................................................
                [ 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
            , 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
            , 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
            , args = []
            , results = []
            , locals = []
................................................................................
            , instructions =
                [ Wasm.Call swapFn
                , Wasm.Call stackPopFn
                , Wasm.Call stackPopFn
                , Wasm.I32_Sub
                , Wasm.Call stackPushFn
                ]
            }
        |> Wasm.withFunction
            { name = mulIntFn
            , exported = 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
            , 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
            , args = []
            , locals = []
            , results = []
................................................................................
                        , 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


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/Data/Builtin.elm version [1194cb235c].













































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
module Play.Data.Builtin exposing (..)

import Play.Data.Type as Type exposing (WordType)


type Builtin
    = Plus
    | Minus
    | Multiply
    | Divide
    | Equal
    | StackDuplicate
    | StackDrop
    | StackSwap
    | StackRightRotate
    | StackLeftRotate


wordType : Builtin -> WordType
wordType builtin =
    case builtin of
        Plus ->
            { input = [ Type.Int, Type.Int ]
            , output = [ Type.Int ]
            }

        Minus ->
            { input = [ Type.Int, Type.Int ]
            , output = [ Type.Int ]
            }

        Multiply ->
            { input = [ Type.Int, Type.Int ]
            , output = [ Type.Int ]
            }

        Divide ->
            { input = [ Type.Int, Type.Int ]
            , output = [ Type.Int ]
            }

        Equal ->
            { input = [ Type.Int, Type.Int ]
            , output = [ Type.Int ]
            }

        StackDuplicate ->
            { input = [ Type.Generic "a_dup" ]
            , output = [ Type.Generic "a_dup", Type.Generic "a_dup" ]
            }

        StackDrop ->
            { input = [ Type.Generic "a_drop" ]
            , output = []
            }

        StackSwap ->
            { input = [ Type.Generic "a_swap", Type.Generic "b_swap" ]
            , output = [ Type.Generic "b_swap", Type.Generic "a_swap" ]
            }

        StackRightRotate ->
            { input = [ Type.Generic "a_rot", Type.Generic "b_rot", Type.Generic "c_rot" ]
            , output = [ Type.Generic "c_rot", Type.Generic "a_rot", Type.Generic "b_rot" ]
            }

        StackLeftRotate ->
            { input = [ Type.Generic "a__rot", Type.Generic "b__rot", Type.Generic "c__rot" ]
            , output = [ Type.Generic "b__rot", Type.Generic "c__rot", Type.Generic "a__rot" ]
            }

Modified src/Play/Data/Type.elm from [64e60d84ed] to [24a6daae14].

1
2
3
4
5
6

7
8
9
10
11
12
module Play.Data.Type exposing (..)


type Type
    = Int
    | Custom String



type alias WordType =
    { input : List Type
    , output : List Type
    }






>






1
2
3
4
5
6
7
8
9
10
11
12
13
module Play.Data.Type exposing (..)


type Type
    = Int
    | Custom String
    | Generic String


type alias WordType =
    { input : List Type
    , output : List Type
    }

Modified src/Play/Parser.elm from [007bdc46d7] to [0f29d96909].

295
296
297
298
299
300
301



302
303
304
305
306
307
308
    case token of
        Token.Type "Int" ->
            Ok Type.Int

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




        _ ->
            Err ()


parseTypeMembers : List Token -> List ( String, Type ) -> Result () (List ( String, Type ))
parseTypeMembers tokens acc =
    case tokens of







>
>
>







295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
    case token of
        Token.Type "Int" ->
            Ok Type.Int

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

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

        _ ->
            Err ()


parseTypeMembers : List Token -> List ( String, Type ) -> Result () (List ( String, Type ))
parseTypeMembers tokens acc =
    case tokens of

Modified src/Play/Qualifier.elm from [d38ce01e0f] to [a4d7e116e4].

1
2
3

4
5
6
7
8
9
10
11
12
..
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
..
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
132
133
134
135
136
137
138





















module Play.Qualifier exposing (..)

import Dict exposing (Dict)

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


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

type Node
    = Integer Int
    | Word String
    | ConstructType String
    | GetMember String String
    | SetMember String String
    | BuiltinPlus
    | BuiltinMinus
    | BuiltinEqual


builtinDict : Dict String Node
builtinDict =
    Dict.fromList
        [ ( "+", BuiltinPlus )
        , ( "-", BuiltinMinus )


        , ( "=", BuiltinEqual )





        ]




qualify : Parser.AST -> Result () AST
qualify ast =
    let
        ( typeErrors, qualifiedTypes ) =
            ast.types
................................................................................
            , acc
            )

        Ok qualifiedImplementation ->
            ( errors
            , Dict.insert unqualifiedWord.name
                { name = unqualifiedWord.name
                , metadata = unqualifiedWord.metadata
                , implementation = qualifiedImplementation
                }
                acc
            )


qualifyNode : Parser.AST -> Parser.AstNode -> Result () Node
................................................................................
            Ok (ConstructType typeName)

        Parser.SetMember typeName memberName ->
            Ok (SetMember typeName memberName)

        Parser.GetMember typeName memberName ->
            Ok (GetMember typeName memberName)
























>

|







 







|
<
<




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







 







|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
..
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
...
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
...
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
module Play.Qualifier exposing (..)

import Dict exposing (Dict)
import Play.Data.Builtin as Builtin exposing (Builtin)
import Play.Data.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
................................................................................

type Node
    = Integer Int
    | Word String
    | ConstructType String
    | GetMember String String
    | SetMember String String
    | Builtin Builtin




builtinDict : Dict String Node
builtinDict =

    [ ( "+", Builtin.Plus )
    , ( "-", Builtin.Minus )
    , ( "*", Builtin.Multiply )
    , ( "/", Builtin.Divide )
    , ( "=", Builtin.Equal )
    , ( "swap", Builtin.StackSwap )
    , ( "dup", Builtin.StackDuplicate )
    , ( "drop", Builtin.StackDrop )
    , ( "rotate", Builtin.StackRightRotate )
    , ( "-rotate", Builtin.StackLeftRotate )
    ]
        |> Dict.fromList
        |> Dict.map (\_ v -> Builtin v)


qualify : Parser.AST -> Result () AST
qualify ast =
    let
        ( typeErrors, qualifiedTypes ) =
            ast.types
................................................................................
            , acc
            )

        Ok qualifiedImplementation ->
            ( errors
            , Dict.insert unqualifiedWord.name
                { name = unqualifiedWord.name
                , metadata = qualifyMetadata unqualifiedWord.name unqualifiedWord.metadata
                , implementation = qualifiedImplementation
                }
                acc
            )


qualifyNode : Parser.AST -> Parser.AstNode -> Result () Node
................................................................................
            Ok (ConstructType typeName)

        Parser.SetMember typeName memberName ->
            Ok (SetMember typeName memberName)

        Parser.GetMember typeName memberName ->
            Ok (GetMember typeName memberName)


qualifyMetadata : String -> Metadata -> Metadata
qualifyMetadata baseName metadata =
    let
        helper { input, output } =
            { input = List.map (qualifyMetadataType baseName) input
            , output = List.map (qualifyMetadataType baseName) output
            }
    in
    { metadata | type_ = Maybe.map helper metadata.type_ }


qualifyMetadataType : String -> Type -> Type
qualifyMetadataType baseName type_ =
    case type_ of
        Type.Generic id ->
            Type.Generic (id ++ "_" ++ baseName)

        _ ->
            type_

Modified src/Play/TypeChecker.elm from [60728609c9] to [1a594e14f7].

1
2
3
4

5
6
7

8
9
10
11
12
13
14
..
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

46
47
48
49
50
51
52
..
54
55
56
57
58
59
60

61
62
63
64
65
66
67
..
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
...
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
...
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
module Play.TypeChecker exposing (..)

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

import Play.Data.Metadata exposing (Metadata)
import Play.Data.Type as Type exposing (Type, WordType)
import Play.Qualifier as Qualifier



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

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

type AstNode
    = IntLiteral Int
    | Word String WordType
    | ConstructType String
    | SetMember String String Type
    | GetMember String String Type
    | BuiltinPlus
    | BuiltinMinus
    | BuiltinEqual


type alias Context =
    { types : Dict String Qualifier.TypeDefinition
    , typedWords : Dict String WordDefinition
    , untypedWords : Dict String Qualifier.WordDefinition
    , stackEffects : List StackEffect

    , errors : List ()
    }


type StackEffect
    = Push Type
    | Pop Type
................................................................................

initContext : Qualifier.AST -> Context
initContext ast =
    { types = ast.types
    , typedWords = Dict.empty
    , untypedWords = ast.words
    , stackEffects = []

    , errors = []
    }


typeCheck : Qualifier.AST -> Result () AST
typeCheck ast =
    typeCheckHelper (initContext ast) ast
................................................................................
        Err ()


typeCheckDefinition : Qualifier.WordDefinition -> Context -> Context
typeCheckDefinition untypedDef context =
    let
        cleanContext =

            { context | stackEffects = [] }


    in
    case Dict.get untypedDef.name context.typedWords of
        Just _ ->
            cleanContext

        Nothing ->
            let
                contextWithStackEffects =
                    List.foldl typeCheckNode cleanContext untypedDef.implementation
                        |> (\ctx -> { ctx | stackEffects = List.reverse ctx.stackEffects })

                ( contextAfterWordTypeInduction, wordType ) =
                    wordTypeFromStackEffects contextWithStackEffects


                finalContext =
                    { contextAfterWordTypeInduction
                        | typedWords =
                            Dict.insert untypedDef.name
                                { name = untypedDef.name
                                , type_ = wordType
                                , metadata = untypedDef.metadata
                                , implementation = List.map (untypedToTypedNode contextAfterWordTypeInduction) untypedDef.implementation
                                }
                                contextAfterWordTypeInduction.typedWords

                        , stackEffects = []
                    }
            in
            case untypedDef.metadata.type_ of
                Just annotatedType ->




                    if annotatedType /= wordType then
                        { finalContext | errors = () :: finalContext.errors }

                    else
                        finalContext

                Nothing ->
                    finalContext


typeCheckNode : Qualifier.Node -> Context -> Context
typeCheckNode node context =
    let
        addStackEffect ctx effects =
            { ctx | stackEffects = effects ++ ctx.stackEffects }
    in
    case node of
        Qualifier.Integer _ ->
            addStackEffect context [ Push Type.Int ]

        Qualifier.Word name ->
            case Dict.get name context.typedWords of
................................................................................
                            { input = [ Type.Custom typeName ]
                            , output = [ memberType ]
                            }

                Nothing ->
                    Debug.todo "inconcievable!"

        Qualifier.BuiltinPlus ->
            addStackEffect context <| wordTypeToStackEffects { input = [ Type.Int, Type.Int ], output = [ Type.Int ] }

        Qualifier.BuiltinMinus ->
            addStackEffect context <| wordTypeToStackEffects { input = [ Type.Int, Type.Int ], output = [ Type.Int ] }

        Qualifier.BuiltinEqual ->
            addStackEffect context <| wordTypeToStackEffects { input = [ Type.Int, Type.Int ], output = [ Type.Int ] }


wordTypeToStackEffects : WordType -> List StackEffect
wordTypeToStackEffects wordType =

    List.map Push wordType.output
        ++ List.map Pop wordType.input


wordTypeFromStackEffects : Context -> ( Context, WordType )
wordTypeFromStackEffects context =
    wordTypeFromStackEffectsHelper context.stackEffects ( context, { input = [], output = [] } )


wordTypeFromStackEffectsHelper : List StackEffect -> ( Context, WordType ) -> ( Context, WordType )
wordTypeFromStackEffectsHelper effects ( context, wordType ) =
    case effects of
        [] ->
            ( context, wordType )







        (Pop type_) :: remainingEffects ->
            case wordType.output of
                [] ->
                    wordTypeFromStackEffectsHelper remainingEffects <|
                        ( context, { wordType | input = type_ :: wordType.input } )

                availableType :: remainingOutput ->


                    if availableType /= type_ then


                        ( { context | errors = () :: context.errors }, wordType )

                    else
                        wordTypeFromStackEffectsHelper remainingEffects <|
                            ( context, { wordType | output = remainingOutput } )

        (Push type_) :: remainingEffects ->
            wordTypeFromStackEffectsHelper remainingEffects <|
                ( context, { wordType | output = type_ :: wordType.output } )



















































































































































































untypedToTypedNode : Context -> Qualifier.Node -> AstNode
untypedToTypedNode context untypedNode =
    case untypedNode of
        Qualifier.Integer num ->
            IntLiteral num

................................................................................
            case getMemberType context.types typeName memberName of
                Just memberType ->
                    GetMember typeName memberName memberType

                Nothing ->
                    Debug.todo "Inconcievable!"

        Qualifier.BuiltinPlus ->
            BuiltinPlus

        Qualifier.BuiltinMinus ->
            BuiltinMinus

        Qualifier.BuiltinEqual ->
            BuiltinEqual


getMemberType : Dict String TypeDefinition -> String -> String -> Maybe Type
getMemberType typeDict typeName memberName =
    Dict.get typeName typeDict
        |> Maybe.map .members
        |> Maybe.andThen (List.find (\( name, _ ) -> name == memberName))
        |> Maybe.map Tuple.second




>



>







 







|
<
<







>







 







>







 







>
|
>
>









<



>











>





>
>
>
>
|













|







 







|
|
<
<
<
<
<
<




>
|
<











|
>
>
>
>
>
>








>
>
|
>
>
|



|





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







 







|
|
<
<
<
<
<
<








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
31
32
33
34
35
36
37
38


39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
..
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
...
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
433
434
435
436
437
438
439
440
441
442
443
444
445
446
...
472
473
474
475
476
477
478
479
480






481
482
483
484
485
486
487
488
module Play.TypeChecker exposing (..)

import Dict exposing (Dict)
import List.Extra as List
import Play.Data.Builtin as Builtin exposing (Builtin)
import Play.Data.Metadata exposing (Metadata)
import Play.Data.Type as Type exposing (Type, WordType)
import Play.Qualifier as Qualifier
import Set exposing (Set)


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

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

type AstNode
    = IntLiteral Int
    | Word String WordType
    | ConstructType String
    | SetMember String String Type
    | GetMember String String Type
    | Builtin Builtin




type alias Context =
    { types : Dict String Qualifier.TypeDefinition
    , typedWords : Dict String WordDefinition
    , untypedWords : Dict String Qualifier.WordDefinition
    , stackEffects : List StackEffect
    , boundGenerics : Dict String Type
    , errors : List ()
    }


type StackEffect
    = Push Type
    | Pop Type
................................................................................

initContext : Qualifier.AST -> Context
initContext ast =
    { types = ast.types
    , typedWords = Dict.empty
    , untypedWords = ast.words
    , stackEffects = []
    , boundGenerics = Dict.empty
    , errors = []
    }


typeCheck : Qualifier.AST -> Result () AST
typeCheck ast =
    typeCheckHelper (initContext ast) ast
................................................................................
        Err ()


typeCheckDefinition : Qualifier.WordDefinition -> Context -> Context
typeCheckDefinition untypedDef context =
    let
        cleanContext =
            { context
                | stackEffects = []
                , boundGenerics = Dict.empty
            }
    in
    case Dict.get untypedDef.name context.typedWords of
        Just _ ->
            cleanContext

        Nothing ->
            let
                contextWithStackEffects =
                    List.foldl typeCheckNode cleanContext untypedDef.implementation


                ( contextAfterWordTypeInduction, wordType ) =
                    wordTypeFromStackEffects contextWithStackEffects
                        |> simplifyWordType untypedDef.name

                finalContext =
                    { contextAfterWordTypeInduction
                        | typedWords =
                            Dict.insert untypedDef.name
                                { name = untypedDef.name
                                , type_ = wordType
                                , metadata = untypedDef.metadata
                                , implementation = List.map (untypedToTypedNode contextAfterWordTypeInduction) untypedDef.implementation
                                }
                                contextAfterWordTypeInduction.typedWords
                        , boundGenerics = Dict.empty
                        , stackEffects = []
                    }
            in
            case untypedDef.metadata.type_ of
                Just annotatedType ->
                    let
                        ( _, simplifiedAnnotatedType ) =
                            simplifyWordType untypedDef.name ( contextAfterWordTypeInduction, annotatedType )
                    in
                    if simplifiedAnnotatedType /= wordType then
                        { finalContext | errors = () :: finalContext.errors }

                    else
                        finalContext

                Nothing ->
                    finalContext


typeCheckNode : Qualifier.Node -> Context -> Context
typeCheckNode node context =
    let
        addStackEffect ctx effects =
            { ctx | stackEffects = ctx.stackEffects ++ effects }
    in
    case node of
        Qualifier.Integer _ ->
            addStackEffect context [ Push Type.Int ]

        Qualifier.Word name ->
            case Dict.get name context.typedWords of
................................................................................
                            { input = [ Type.Custom typeName ]
                            , output = [ memberType ]
                            }

                Nothing ->
                    Debug.todo "inconcievable!"

        Qualifier.Builtin builtin ->
            addStackEffect context <| wordTypeToStackEffects <| Builtin.wordType builtin








wordTypeToStackEffects : WordType -> List StackEffect
wordTypeToStackEffects wordType =
    List.map Pop (List.reverse wordType.input)
        ++ List.map Push wordType.output



wordTypeFromStackEffects : Context -> ( Context, WordType )
wordTypeFromStackEffects context =
    wordTypeFromStackEffectsHelper context.stackEffects ( context, { input = [], output = [] } )


wordTypeFromStackEffectsHelper : List StackEffect -> ( Context, WordType ) -> ( Context, WordType )
wordTypeFromStackEffectsHelper effects ( context, wordType ) =
    case effects of
        [] ->
            ( context
              -- TODO: Really need to get this list reverse madness figured out and solved properly
            , { wordType
                | input = wordType.input
                , output = List.reverse wordType.output
              }
            )

        (Pop type_) :: remainingEffects ->
            case wordType.output of
                [] ->
                    wordTypeFromStackEffectsHelper remainingEffects <|
                        ( context, { wordType | input = type_ :: wordType.input } )

                availableType :: remainingOutput ->
                    let
                        ( newContext, compatible ) =
                            compatibleTypes context availableType type_
                    in
                    if not compatible then
                        ( { newContext | errors = () :: context.errors }, wordType )

                    else
                        wordTypeFromStackEffectsHelper remainingEffects <|
                            ( newContext, { wordType | output = remainingOutput } )

        (Push type_) :: remainingEffects ->
            wordTypeFromStackEffectsHelper remainingEffects <|
                ( context, { wordType | output = type_ :: wordType.output } )


compatibleTypes : Context -> Type -> Type -> ( Context, Bool )
compatibleTypes context typeA typeB =
    case ( getGenericBinding context typeA, getGenericBinding context typeB ) of
        -- A is unbound
        ( Nothing, Just boundB ) ->
            ( bindGeneric typeA boundB context, True )

        -- B is unbound
        ( Just boundA, Nothing ) ->
            ( bindGeneric typeB boundA context, True )

        -- Both are unbound
        ( Nothing, Nothing ) ->
            ( bindGeneric typeA typeB context
                |> bindGeneric typeB typeA
            , True
            )

        -- Both types are either a resolved type or bound generic
        ( Just boundA, Just boundB ) ->
            ( context, boundA == boundB )


getGenericBinding : Context -> Type -> Maybe Type
getGenericBinding context type_ =
    case type_ of
        Type.Generic genericId ->
            case Dict.get genericId context.boundGenerics of
                Just (Type.Generic nextGenericId) ->
                    case Dict.get nextGenericId context.boundGenerics of
                        Just ((Type.Generic cycleCheckId) as anotherGenericType) ->
                            if cycleCheckId == genericId then
                                Nothing

                            else
                                getGenericBinding context anotherGenericType

                        otherwise ->
                            otherwise

                otherwise ->
                    otherwise

        _ ->
            Just type_


bindGeneric : Type -> Type -> Context -> Context
bindGeneric toBind target context =
    case toBind of
        Type.Generic name ->
            { context | boundGenerics = Dict.insert name target context.boundGenerics }

        _ ->
            context


simplifyWordType : String -> ( Context, WordType ) -> ( Context, WordType )
simplifyWordType defName ( context, wordType ) =
    let
        oldSignature =
            wordType.input ++ wordType.output

        inputLength =
            List.length wordType.input

        aliases =
            oldSignature
                |> List.filterMap genericName
                -- remove duplicates
                |> (Set.fromList >> Set.toList)
                |> List.map (findAliases context)
                |> List.foldl reverseLookup Dict.empty

        newSignature =
            List.map reduceGenericName oldSignature
                |> List.foldl renameGenerics ( 'a', Dict.empty, [] )
                |> (\( _, _, ns ) -> ns)
                |> List.reverse

        reduceGenericName type_ =
            case type_ of
                Type.Generic genName ->
                    case getGenericBinding context type_ of
                        Just boundType ->
                            boundType

                        Nothing ->
                            case Dict.get genName aliases of
                                Just actualName ->
                                    Type.Generic actualName

                                Nothing ->
                                    type_

                _ ->
                    type_

        renameGenerics type_ ( nextId, seenGenerics, acc ) =
            case type_ of
                Type.Generic genName ->
                    case Dict.get genName seenGenerics of
                        Just newName ->
                            ( nextId, seenGenerics, Type.Generic newName :: acc )

                        Nothing ->
                            let
                                newName =
                                    String.fromChar nextId ++ "_" ++ defName
                            in
                            ( nextId
                                |> Char.toCode
                                |> (+) 1
                                |> Char.fromCode
                            , Dict.insert genName newName seenGenerics
                            , Type.Generic newName :: acc
                            )

                _ ->
                    ( nextId, seenGenerics, type_ :: acc )
    in
    ( context
    , { input = List.take inputLength newSignature
      , output = List.drop inputLength newSignature
      }
    )


genericName : Type -> Maybe String
genericName type_ =
    case type_ of
        Type.Generic name ->
            Just name

        _ ->
            Nothing


findAliases : Context -> String -> ( String, List String )
findAliases context generic =
    ( generic
    , context.boundGenerics
        |> Dict.keys
        |> List.filterMap (\key -> isAliasOf context Set.empty generic key key)
    )


isAliasOf : Context -> Set String -> String -> String -> String -> Maybe String
isAliasOf context visitedKeys targetKey topKey currentKey =
    case Dict.get currentKey context.boundGenerics of
        Just (Type.Generic genericKey) ->
            if Set.member genericKey visitedKeys then
                Nothing

            else if genericKey == targetKey then
                Just topKey

            else
                isAliasOf context (Set.insert currentKey visitedKeys) targetKey topKey genericKey

        _ ->
            Nothing


reverseLookup : ( String, List String ) -> Dict String String -> Dict String String
reverseLookup ( name, aliases ) acc =
    let
        targetName =
            Dict.get name acc
                |> Maybe.withDefault name
    in
    aliases
        |> List.filter (\a -> not <| Dict.member a acc)
        |> List.filter (\a -> a /= targetName)
        |> List.foldl (\alias newAcc -> Dict.insert alias targetName newAcc) acc


untypedToTypedNode : Context -> Qualifier.Node -> AstNode
untypedToTypedNode context untypedNode =
    case untypedNode of
        Qualifier.Integer num ->
            IntLiteral num

................................................................................
            case getMemberType context.types typeName memberName of
                Just memberType ->
                    GetMember typeName memberName memberType

                Nothing ->
                    Debug.todo "Inconcievable!"

        Qualifier.Builtin builtin ->
            Builtin builtin








getMemberType : Dict String TypeDefinition -> String -> String -> Maybe Type
getMemberType typeDict typeName memberName =
    Dict.get typeName typeDict
        |> Maybe.map .members
        |> Maybe.andThen (List.find (\( name, _ ) -> name == memberName))
        |> Maybe.map Tuple.second

Modified src/Wasm.elm from [181df993e7] to [c6551ae3ec].

70
71
72
73
74
75
76

77
78
79
80

81
82
83
84
85
86
87
...
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
    | Local_Get Int
    | Local_Set Int
    | Local_Tee Int
    | I32_Const Int
    | I32_Add
    | I32_Sub
    | I32_Mul

    | I32_Eq
    | I32_EqZero
    | I32_Store
    | I32_Load



instructionToString : Module -> Instruction -> String
instructionToString ((Module module_) as fullModule) ins =
    case ins of
        NoOp ->
            "nop"
................................................................................

        I32_Sub ->
            "i32.sub"

        I32_Mul ->
            "i32.mul"




        I32_Eq ->
            "i32.eq"

        I32_EqZero ->
            "i32.eqz"

        I32_Store ->
            "i32.store"

        I32_Load ->
            "i32.load"





maximumLocalIndex : Instruction -> Maybe Int
maximumLocalIndex ins =
    case ins of
        Batch insList ->
            List.filterMap maximumLocalIndex insList
                |> List.maximum







>




>







 







>
>
>












>
>
>







70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
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
    | Local_Get Int
    | Local_Set Int
    | Local_Tee Int
    | I32_Const Int
    | I32_Add
    | I32_Sub
    | I32_Mul
    | I32_Div
    | I32_Eq
    | I32_EqZero
    | I32_Store
    | I32_Load
    | Drop


instructionToString : Module -> Instruction -> String
instructionToString ((Module module_) as fullModule) ins =
    case ins of
        NoOp ->
            "nop"
................................................................................

        I32_Sub ->
            "i32.sub"

        I32_Mul ->
            "i32.mul"

        I32_Div ->
            "i32.div_s"

        I32_Eq ->
            "i32.eq"

        I32_EqZero ->
            "i32.eqz"

        I32_Store ->
            "i32.store"

        I32_Load ->
            "i32.load"

        Drop ->
            "drop"


maximumLocalIndex : Instruction -> Maybe Int
maximumLocalIndex ins =
    case ins of
        Batch insList ->
            List.filterMap maximumLocalIndex insList
                |> List.maximum

Modified tests/Test/Parser.elm from [56ed5689f9] to [b911c1ec4c].

214
215
216
217
218
219
220










































221
222
223
224
225
226
227
228
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]
                                  , implementation =
                                        [ AST.Word "age>"
                                        ]
                                  }
                                ]
                        }










































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

                    Ok ast ->
                        Expect.equal expectedAst ast
        ]







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








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
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Int ]
                                  , implementation =
                                        [ AST.Word "age>"
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"

                    Ok ast ->
                        Expect.equal expectedAst ast
        , test "Parser understands generic types" <|
            \_ ->
                let
                    source =
                        [ Metadata "def"
                        , Symbol "over"
                        , Metadata "type"
                        , Symbol "a"
                        , Symbol "b"
                        , TypeSeperator
                        , Symbol "a"
                        , Symbol "b"
                        , Symbol "a"
                        , Metadata ""
                        , Symbol "dup"
                        , Symbol "rotate"
                        ]

                    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.Word "dup"
                                        , AST.Word "rotate"
                                        ]
                                  }
                                ]
                        }
                in
                case parse source of
                    Err () ->
                        Expect.fail "Did not expect parsing to fail"

                    Ok ast ->
                        Expect.equal expectedAst ast
        ]

Modified tests/Test/Qualifier.elm from [ec7132c8ba] to [7f3aa53ef5].

1
2
3
4
5

6

7
8
9
10
11
12
13
..
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
module Test.Qualifier exposing (..)

import Dict
import Dict.Extra as Dict
import Expect

import Play.Data.Metadata as Metadata

import Play.Parser as AST
import Play.Qualifier exposing (..)
import Test exposing (Test, describe, test)


suite : Test
suite =
................................................................................
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ Integer 1
                                        , BuiltinPlus
                                        ]
                                  }
                                , { name = "dec"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ Integer 1
                                        , BuiltinMinus
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , implementation =
                                        [ Integer 1
                                        , Word "inc"
                                        , Word "inc"
                                        , Word "dec"
                                        , Integer 2
                                        , BuiltinEqual


















































                                        ]
                                  }
                                ]
                        }
                in
                case qualify unqualifiedAst of
                    Err () ->
                        Expect.fail "Did not expect qualification to fail"

                    Ok qualifiedAst ->
                        Expect.equal expectedAst qualifiedAst
        ]





>

>







 







|






|












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












1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
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
module Test.Qualifier exposing (..)

import Dict
import Dict.Extra as Dict
import Expect
import Play.Data.Builtin as Builtin
import Play.Data.Metadata as Metadata
import Play.Data.Type as Type
import Play.Parser as AST
import Play.Qualifier exposing (..)
import Test exposing (Test, describe, test)


suite : Test
suite =
................................................................................
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ Integer 1
                                        , Builtin Builtin.Plus
                                        ]
                                  }
                                , { name = "dec"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ Integer 1
                                        , Builtin Builtin.Minus
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , implementation =
                                        [ Integer 1
                                        , Word "inc"
                                        , Word "inc"
                                        , Word "dec"
                                        , Integer 2
                                        , Builtin Builtin.Equal
                                        ]
                                  }
                                ]
                        }
                in
                case qualify unqualifiedAst of
                    Err () ->
                        Expect.fail "Did not expect qualification to fail"

                    Ok qualifiedAst ->
                        Expect.equal expectedAst qualifiedAst
        , test "Generic function types" <|
            \_ ->
                let
                    unqualifiedAst =
                        { 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.Word "swap"
                                        , AST.Word "dup"
                                        , AST.Word "rotate"
                                        ]
                                  }
                                ]
                        }

                    expectedAst =
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "over"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                [ Type.Generic "a_over", Type.Generic "b_over" ]
                                                [ Type.Generic "a_over"
                                                , Type.Generic "b_over"
                                                , Type.Generic "a_over"
                                                ]
                                  , implementation =
                                        [ Builtin Builtin.StackSwap
                                        , Builtin Builtin.StackDuplicate
                                        , Builtin Builtin.StackRightRotate
                                        ]
                                  }
                                ]
                        }
                in
                case qualify unqualifiedAst of
                    Err () ->
                        Expect.fail "Did not expect qualification to fail"

                    Ok qualifiedAst ->
                        Expect.equal expectedAst qualifiedAst
        ]

Modified tests/Test/TypeChecker.elm from [8a9ecd20c4] to [d1288728ad].

1
2
3
4
5

6
7
8
9
10
11
12
..
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
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
...
238
239
240
241
242
243
244
245
246



















247




























































module Test.TypeChecker exposing (..)

import Dict
import Dict.Extra as Dict
import Expect

import Play.Data.Metadata as Metadata exposing (Metadata)
import Play.Data.Type as Type
import Play.Qualifier as QAST
import Play.TypeChecker exposing (..)
import Test exposing (Test, describe, test)


................................................................................
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.BuiltinPlus
                                        ]
                                  }
                                , { name = "dec"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.BuiltinMinus
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.Word "inc"
                                        , QAST.Word "inc"
                                        , QAST.Word "dec"
                                        , QAST.Integer 2
                                        , QAST.BuiltinEqual
                                        ]
                                  }
                                ]
                        }

                    expectedResult =
                        { types = Dict.empty
................................................................................
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , type_ = { input = [ Type.Int ], output = [ Type.Int ] }
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ IntLiteral 1
                                        , BuiltinPlus
                                        ]
                                  }
                                , { name = "dec"
                                  , type_ = { input = [ Type.Int ], output = [ Type.Int ] }
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ IntLiteral 1
                                        , BuiltinMinus
                                        ]
                                  }
                                , { name = "main"
                                  , type_ = { input = [], output = [ Type.Int ] }
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , implementation =
                                        [ IntLiteral 1
                                        , Word "inc" { input = [ Type.Int ], output = [ Type.Int ] }
                                        , Word "inc" { input = [ Type.Int ], output = [ Type.Int ] }
                                        , Word "dec" { input = [ Type.Int ], output = [ Type.Int ] }
                                        , IntLiteral 2
                                        , BuiltinEqual
                                        ]
                                  }
                                ]
                        }
                in
                case typeCheck input of
                    Err () ->
................................................................................
                                [ { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Int ] []
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.Integer 2
                                        , QAST.BuiltinEqual
                                        ]
                                  }
                                ]
                        }
                in
                case typeCheck input of
                    Err () ->
................................................................................
                                  , { name = "inc-age"
                                    , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Custom "Person" ]
                                    , implementation =
                                        [ QAST.Word "age>"
                                        , QAST.Integer 1
                                        , QAST.BuiltinPlus
                                        , QAST.Word ">Person"
                                        ]
                                    }
                                  )
                                , ( "main"
                                  , { name = "main"
                                    , metadata =
................................................................................
                                ]
                        }
                in
                case typeCheck source of
                    Err () ->
                        Expect.fail "Did not expect type check to fail"

                    Ok _ ->
                        Expect.pass



















        ]

































































>







 







|






|












|







 







|







|













|







 







|







 







|







 









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
..
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
...
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
...
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
...
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
module Test.TypeChecker exposing (..)

import Dict
import Dict.Extra as Dict
import Expect
import Play.Data.Builtin as Builtin
import Play.Data.Metadata as Metadata exposing (Metadata)
import Play.Data.Type as Type
import Play.Qualifier as QAST
import Play.TypeChecker exposing (..)
import Test exposing (Test, describe, test)


................................................................................
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.Builtin Builtin.Plus
                                        ]
                                  }
                                , { name = "dec"
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.Builtin Builtin.Minus
                                        ]
                                  }
                                , { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.Word "inc"
                                        , QAST.Word "inc"
                                        , QAST.Word "dec"
                                        , QAST.Integer 2
                                        , QAST.Builtin Builtin.Equal
                                        ]
                                  }
                                ]
                        }

                    expectedResult =
                        { types = Dict.empty
................................................................................
                        , words =
                            Dict.fromListBy .name
                                [ { name = "inc"
                                  , type_ = { input = [ Type.Int ], output = [ Type.Int ] }
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ IntLiteral 1
                                        , Builtin Builtin.Plus
                                        ]
                                  }
                                , { name = "dec"
                                  , type_ = { input = [ Type.Int ], output = [ Type.Int ] }
                                  , metadata = Metadata.default
                                  , implementation =
                                        [ IntLiteral 1
                                        , Builtin Builtin.Minus
                                        ]
                                  }
                                , { name = "main"
                                  , type_ = { input = [], output = [ Type.Int ] }
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.asEntryPoint
                                  , implementation =
                                        [ IntLiteral 1
                                        , Word "inc" { input = [ Type.Int ], output = [ Type.Int ] }
                                        , Word "inc" { input = [ Type.Int ], output = [ Type.Int ] }
                                        , Word "dec" { input = [ Type.Int ], output = [ Type.Int ] }
                                        , IntLiteral 2
                                        , Builtin Builtin.Equal
                                        ]
                                  }
                                ]
                        }
                in
                case typeCheck input of
                    Err () ->
................................................................................
                                [ { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Int ] []
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.Integer 2
                                        , QAST.Builtin Builtin.Equal
                                        ]
                                  }
                                ]
                        }
                in
                case typeCheck input of
                    Err () ->
................................................................................
                                  , { name = "inc-age"
                                    , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Custom "Person" ] [ Type.Custom "Person" ]
                                    , implementation =
                                        [ QAST.Word "age>"
                                        , QAST.Integer 1
                                        , QAST.Builtin Builtin.Plus
                                        , QAST.Word ">Person"
                                        ]
                                    }
                                  )
                                , ( "main"
                                  , { name = "main"
                                    , metadata =
................................................................................
                                ]
                        }
                in
                case typeCheck source of
                    Err () ->
                        Expect.fail "Did not expect type check to fail"

                    Ok _ ->
                        Expect.pass
        , test "Generic types" <|
            \_ ->
                let
                    input =
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Int ]
                                  , implementation =
                                        [ QAST.Integer 1
                                        , QAST.Integer 2
                                        , QAST.Word "over"
                                        , QAST.Builtin Builtin.Plus
                                        , QAST.Builtin Builtin.Minus
                                        , QAST.Integer 2
                                        , QAST.Builtin Builtin.Equal
                                        ]
                                  }
                                , { name = "over"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType
                                                -- Most would start at a and increment, but we need to check that
                                                -- the typechecker cares about the relationship between these generic
                                                -- variables, not the names themselves
                                                [ Type.Generic "b_over", Type.Generic "c_over" ]
                                                [ Type.Generic "b_over", Type.Generic "c_over", Type.Generic "b_over" ]
                                  , implementation =
                                        [ QAST.Builtin Builtin.StackSwap
                                        , QAST.Builtin Builtin.StackDuplicate
                                        , QAST.Builtin Builtin.StackRightRotate
                                        ]
                                  }
                                ]
                        }
                in
                case typeCheck input of
                    Err () ->
                        Expect.fail "Did not expect type check to fail."

                    Ok _ ->
                        Expect.pass
        , test "Generic types with type annotation" <|
            \_ ->
                let
                    input =
                        { types = Dict.empty
                        , words =
                            Dict.fromListBy .name
                                [ { name = "main"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [] [ Type.Int ]
                                  , implementation =
                                        [ QAST.Integer 5
                                        , QAST.Word "square"
                                        ]
                                  }
                                , { name = "square"
                                  , metadata =
                                        Metadata.default
                                            |> Metadata.withType [ Type.Int ] [ Type.Int ]
                                  , implementation =
                                        [ QAST.Builtin Builtin.StackDuplicate
                                        , QAST.Builtin Builtin.Multiply
                                        ]
                                  }
                                ]
                        }
                in
                case typeCheck input of
                    Err () ->
                        Expect.fail "Did not expect type check to fail."

                    Ok _ ->
                        Expect.pass
        ]

Added wasm_tests/basics.test.js version [981cd381d2].

























































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

test('Simple expression', async () => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        : 1 1 +
    `);

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

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

test('Function calls', async () => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        : 1 inc inc

        def: inc
        : 1 +
    `);

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

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

Added wasm_tests/compiler.wrapper.js version [c5416ae3ae].















































































































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

exports.toWat = function toWat(sourceCode) {
    return new Promise((resolve, reject) => {
        const compiler = Compiler.Elm.Main.init({});

        compiler.ports.compileFinished.subscribe(([ok, output]) => {
            if (ok) {
                resolve(output);
            } else {
                reject(output);
            }
        });

        compiler.ports.compileString.send(sourceCode);
    });
}

exports.run = async function run(wat, functionName) {
    const wasmModule = wabt.parseWat('tmp', wat).toBinary({}).buffer;

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

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

    const program = await WebAssembly.instantiate(wasmModule, imports);
    program.instance.exports[functionName]();

    return new ExecutionResult(memory.buffer);
}

class ExecutionResult {
    constructor(memoryBuffer) {
        this.memoryView = new Uint32Array(memoryBuffer, 0, 512);
    }

    stackElement(index) {
        // The first three I32 positions are used for stack and heap information
        // The fourth position is the first element of the stack
        return this.memoryView[3 + (index || 0)];
    }

    typeIdForPointer(index) {
        const pointer = this.stackElement(index || 0);
        const wordPointer = pointer / 4;
        return this.memoryView[wordPointer];
    }
}

Added wasm_tests/math.test.js version [427aff9e64].



































































































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

test('Addition', async () => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        : 3 3 +
    `);

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

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

test('Subtraction', async () => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        : 10 1 -
    `);

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

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

test('Multiplication', async () => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        : 5 3 *
    `);

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

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

test('Division', async () => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        : 10 5 /
    `);

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

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

Added wasm_tests/record.test.js version [df052b5a01].







































































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

test('Enum type', async () => {
    const wat = await compiler.toWat(`
       deftype: True 
       deftype: False

       def: main
       entry: true
       : >True
    `);

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

    // types are sorted alphabetically, so False will get id 0, and True gets id 1.
    expect(result.typeIdForPointer()).toBe(1);
});

test('Compound type', async () => {
    const wat = await compiler.toWat(`
        deftype: Person
        : { age: Int }

        def: inc-age
        : age> 1 + >Person

        def: main
        entry: true
        : 1 >Person 19 >age inc-age age>
    `);

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

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

Added wasm_tests/stack.test.js version [493c219118].













































































































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

test('Square', async () => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        type: -- Int
        : 5 square

        def: square
        type: Int -- Int
        : dup *
    `);

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

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

test('Over', async() => {
    const wat = await compiler.toWat(`
        def: main
        entry: true
        type: -- Int
        : 1 2 over - + 2 =

        def: over
        type: a b -- a b a
        : swap dup rotate
    `);

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

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

test('Under', async() => {
    // Not sure if under is actually a known function in forth
    // This is mainly to test -rotate
    const wat = await compiler.toWat(`
        def: main
        entry: true
        type: -- Int
        : 1 2 under - + 3 =

        def: under
        type: a b -- b b a
        : dup -rotate
    `);

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

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

Deleted wasm_tests/wasm.test.js version [5da770b938].

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

test('Simple expression', async () => {
    const wat = await compileToWat(`
        def: main
        entry: true
        : 1 1 +
    `);

    const result = await runCode(wat, 'main');

    expect(result.valueOnBottomOfStack()).toBe(2);
});

test('Function calls', async () => {
    const wat = await compileToWat(`
        def: main
        entry: true
        : 1 inc inc

        def: inc
        : 1 +
    `);

    const result = await runCode(wat, 'main');

    expect(result.valueOnBottomOfStack()).toBe(3);
});

test('Enum type', async () => {
    const wat = await compileToWat(`
       deftype: True 
       deftype: False

       def: main
       entry: true
       : >True
    `);

    const result = await runCode(wat, 'main');

    // types are sorted alphabetically, so False will get id 0, and True gets id 1.
    expect(result.typeIdForPointer()).toBe(1);
});

test('Compound type', async () => {
    const wat = await compileToWat(`
        deftype: Person
        : { age: Int }

        def: inc-age
        : age> 1 + >Person

        def: main
        entry: true
        : 1 >Person 19 >age inc-age age>
    `);

    const result = await runCode(wat, 'main');

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

// Helpers

function compileToWat(sourceCode) {
    return new Promise((resolve, reject) => {
        const compiler = Compiler.Elm.Main.init({});

        compiler.ports.compileFinished.subscribe(([ok, output]) => {
            if (ok) {
                resolve(output);
            } else {
                reject(output);
            }
        });

        compiler.ports.compileString.send(sourceCode);
    });
}

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

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

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

    const program = await WebAssembly.instantiate(wasmModule, imports);
    program.instance.exports[functionName]();

    return new ExecutionResult(memory.buffer);
}

class ExecutionResult {
    constructor(memoryBuffer) {
        this.memoryView = new Uint32Array(memoryBuffer, 0, 512);
    }

    valueOnBottomOfStack() {
        // The first three I32 positions are used for stack and heap information
        // The fourth position is the first element of the stack
        return this.memoryView[3];
    }

    typeIdForPointer() {
        const pointer = this.valueOnBottomOfStack();
        const wordPointer = pointer / 4;
        return this.memoryView[wordPointer];
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<