├── .travis.yml
├── LICENSE
├── Makefile
├── README.md
├── blynn.c
├── check.sh
├── check_compile.sh
├── classy
├── classy.hs
├── default.nix
└── examples
    └── bignum.hs


/.travis.yml:
--------------------------------------------------------------------------------
1 | language: nix
2 | script: nix-build .
3 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | MIT License
 2 | 
 3 | Copyright (c) 2019 Ben Siraphob
 4 | 
 5 | Permission is hereby granted, free of charge, to any person obtaining a copy
 6 | of this software and associated documentation files (the "Software"), to deal
 7 | in the Software without restriction, including without limitation the rights
 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | all:
2 | 	gcc -ansi -O3 -o blynn blynn.c
3 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # A compiler for a subset of Haskell to Combinatory Logic
 2 | [![Build Status](https://travis-ci.org/siraben/mini-haskell.svg?branch=master)](https://travis-ci.org/siraben/mini-haskell)
 3 | ## Adapted from the original version by Ben Lynn
 4 | This is an elaboration and annotation of [Ben Lynn's Haskell
 5 | compiler](https://crypto.stanford.edu/~blynn/compiler/type.html) and
 6 | [C VM](https://crypto.stanford.edu/~blynn/compiler/c.html).  The main
 7 | aim is to improve upon the compiler, in various layers (see [Future plans](#future-plans)).
 8 | 
 9 | ## Features
10 | - Valid subset of Haskell!  Code works on GHC as long as you have
11 |   curly braces and delimiters as needed (see `classy.hs`)
12 | - Type inference, type classes, algebraic data types
13 | - Pure! The last function defined should be a function of type `String
14 |   -> String`, which will receive input from stdin and whose output
15 |   will be printed to the console
16 | - VM (~350 SLOC) is written in ANSI C and works on 32 and 64-bit
17 |   systems
18 | - Compiles to combinatory logic (CL), evaluation proceeds via graph
19 |   reduction
20 | 
21 | ## Usage
22 | ```
23 | ./blynn <binary> <input> <output>
24 | ```
25 | Where `binary` is the CL program to run, `input` is the
26 | file whose contents are passed to the program, and `output` is the file
27 | to write the output to.
28 | 
29 | ## Building
30 | ### Requirements
31 | - An ANSI C compiler and `make`.  That's it!
32 | 
33 | ### Testing
34 | To check self-compilation, run `./check.sh classy.hs`.  It does the
35 | following:
36 | 
37 | - Run `classy` (compiler binary) on `classy.hs` (compiler source),
38 |   producing `classy2`
39 | - Run `classy2` on `classy.hs`, producing `classy3`
40 | - Check that `classy2` and `classy3` are identical
41 | 
42 | If you've made a change to what `classy.hs` _outputs_, (e.g. an
43 | optimization to code generation), run `./check_compile.sh classy.hs`
44 | instead.  It adds another step to the same process in `check.sh` to
45 | ensure that the changes propagate.
46 | 
47 | ## <a name="future-plans">Future plans</a>
48 | ### Bootstrapping
49 | - [ ] Create bootstrapping path from original classy compiler
50 | 
51 | ### C runtime
52 | - [ ] Monadic I/O
53 |     - [ ] `putc`, `getc`, filesystems
54 |     - [ ] Combinators should take a continuation, doing I/O then
55 |           passing the result to the continuation
56 | - [ ] Alternate VM in Forth?
57 | 
58 | ### Compiler
59 | Initial phase; parsing and totality, then reduce heap usage.
60 | 
61 | - [x] Use more typeclasses in this compiler
62 | - [ ] Remove undefined, only use total functions
63 | - [ ] "Don't pay for what you don't use" (only emit code for functions
64 |       referenced from main)
65 | - [ ] Convert to CPS and perform partial evaluation
66 | 
67 | ### Parser
68 | - [x] Rewrite in applicative style with typeclasses
69 | - [x] Add block comments
70 | - [x] Use Parsec-style parsing
71 | - [ ] Better parser error messages
72 |   - [ ] Writer show instance for `Msg`
73 | - [ ] `do` notation
74 |   - [ ] Implement layout parsing, as in [this
75 | paper](https://www.cs.cmu.edu/~ckaestne/pdf/sle12.pdf)
76 | 
77 | ### Types
78 | - [ ] Separation of `Char` and `Int` types
79 | - [ ] Add more types to the standard prelude
80 | - [ ] Allow class constraint in class declaration
81 |       like (`class Functor f => Applicative f where ...`)
82 | - [ ] Multi-parameter typeclasses
83 | - [ ] Dependent/linear types?
84 | 


--------------------------------------------------------------------------------
/blynn.c:
--------------------------------------------------------------------------------
  1 | typedef unsigned u;
  2 | #include <stdio.h>
  3 | #include <stdlib.h>
  4 | #include <string.h>
  5 | 
  6 | enum { FORWARD = 27, REDUCING = 9 };
  7 | 
  8 | void die(char *s) {
  9 |   fprintf(stderr, "Error: %s\n", s);
 10 |   exit(1);
 11 | }
 12 | 
 13 | enum { TOP = 1 << 23, TABMAX = 1 << 10, BUFMAX = 1 << 20 };
 14 | u arena[2][TOP];
 15 | char input[BUFMAX] = {0};
 16 | u *mem, *altmem, *sp, *spTop, hp, tab[TABMAX], tabn;
 17 | u gc_count;
 18 | void stats() {
 19 |   printf("[HP = %u, SP = %p, GC called %u time%s]\n", hp, (void*)(spTop - sp),
 20 |          gc_count, gc_count == 1 ? "" : "s");
 21 | }
 22 | 
 23 | #define isAddr(n) (n >= 128)
 24 | 
 25 | u copy(u n) {
 26 |   if (!isAddr(n))
 27 |     return n;
 28 |   u x = mem[n];
 29 |   while (isAddr(x) && mem[x] == 'T') {
 30 |     mem[n] = mem[n + 1];
 31 |     mem[n + 1] = mem[x + 1];
 32 |     x = mem[n];
 33 |   }
 34 |   if (isAddr(x) && mem[x] == 'K') {
 35 |     mem[n + 1] = mem[x + 1];
 36 |     x = mem[n] = 'I';
 37 |   }
 38 |   u y = mem[n + 1];
 39 |   switch (x) {
 40 |   case FORWARD:
 41 |     return y;
 42 |   case REDUCING:
 43 |     if (hp >= TOP - 2)
 44 |       die("OOM");
 45 |     mem[n] = FORWARD;
 46 |     mem[n + 1] = hp;
 47 |     hp += 2;
 48 |     return mem[n + 1];
 49 |   case 'I':
 50 |     mem[n] = REDUCING;
 51 |     y = copy(y);
 52 |     if (mem[n] == FORWARD) {
 53 |       altmem[mem[n + 1]] = 'I';
 54 |       altmem[mem[n + 1] + 1] = y;
 55 |     } else {
 56 |       mem[n] = FORWARD;
 57 |       mem[n + 1] = y;
 58 |     }
 59 |     return mem[n + 1];
 60 |   default:
 61 |     break;
 62 |   }
 63 |   if (hp >= TOP - 2)
 64 |     die("OOM");
 65 |   u z = hp;
 66 |   hp += 2;
 67 |   mem[n] = FORWARD;
 68 |   mem[n + 1] = z;
 69 |   altmem[z] = copy(x);
 70 |   altmem[z + 1] = x == 'a' || x == '#' ? y : copy(y);
 71 |   return z;
 72 | }
 73 | 
 74 | /* Garbage collection */
 75 | void gc() {
 76 |   /* Reset the heap pointer */
 77 |   hp = 128;
 78 |   /* Set the stack pointer to point to the top of altmem */
 79 |   sp = altmem + TOP - 1;
 80 |   /* Run copy starting from the top of the old stack */
 81 |   *sp = copy(*spTop);
 82 |   spTop = sp;
 83 |   /* Swap the addresses of mem and altmem */
 84 |   u *tmp = mem;
 85 |   mem = altmem;
 86 |   altmem = tmp;
 87 |   gc_count++;
 88 | }
 89 | 
 90 | /* An application of two nodes is represented by adjacent memory */
 91 | /* locations. */
 92 | u app(u f, u x) {
 93 |   mem[hp] = f;
 94 |   mem[hp + 1] = x;
 95 |   hp += 2;
 96 |   return hp - 2;
 97 | }
 98 | 
 99 | u tab[TABMAX], tabn;
100 | 
101 | u parseTerm(u (*get)()) {
102 |   u n, c;
103 |   do
104 |     c = get();
105 |   while (c == '\n');
106 |   switch (c) {
107 |   case '`':
108 |     c = parseTerm(get);
109 |     return app(c, parseTerm(get));
110 |   case '#':
111 |     return app('#', get());
112 |   case '@':
113 |     return tab[get() - ' '];
114 |   case '(':
115 |     n = 0;
116 |     while ((c = get()) != ')')
117 |       n = 10 * n + c - '0';
118 |     return app('#', n);
119 |   case '[':
120 |     n = 0;
121 |     while ((c = get()) != ']')
122 |       n = 10 * n + c - '0';
123 |     return tab[n];
124 |   default:
125 |     return c;
126 |   }
127 | }
128 | 
129 | void reset(u root) { *(sp = spTop) = root; }
130 | 
131 | void parseMore(u (*get)()) {
132 |   for (;;) {
133 |     u c = parseTerm(get);
134 |     if (!c) {
135 |       reset(app(app(app(tab[tabn - 1], app('0', '?')), '.'), app('T', '1')));
136 |       return;
137 |     }
138 |     if (tabn == TABMAX)
139 |       die("Table overflow");
140 |     tab[tabn++] = c;
141 |     if (get() != ';')
142 |       die("Expected ';'");
143 |   }
144 | }
145 | 
146 | char *str;
147 | u str_get() { return *(unsigned char *)str++; }
148 | 
149 | void parse(char *s) {
150 |   hp = 128;
151 |   tabn = 0;
152 |   str = s;
153 |   parseMore(str_get);
154 | }
155 | 
156 | /* Since we store application nodes as [f, x] in adjacent memory */
157 | /* locations, we can get the nth argument by: */
158 | u arg(u n) { return mem[sp[n] + 1]; }
159 | 
160 | /* If the argument is a number, then we call arg to get the pointer to */
161 | /* the number in memory, then find its value by indexing into mem. */
162 | u num(u n) { return mem[arg(n) + 1]; }
163 | 
164 | void lazy(u height, u f, u x) {
165 |   u *p = mem + sp[height];
166 |   *p = f;
167 |   *++p = x;
168 |   sp += height;
169 | }
170 | 
171 | u apparg(u i, u j) { return app(arg(i), arg(j)); }
172 | 
173 | void run(u (*get)(), void (*put)(u)) {
174 |   u c;
175 |   for (;;) {
176 |     /* static int ctr; if (++ctr == (1<<25)) stats(), ctr = 0; */
177 |     if (mem + hp > sp - 8)
178 |       gc();
179 |     u x = *sp;
180 |     if (isAddr(x))
181 |       *--sp = mem[x];
182 |     else
183 |       switch (x) {
184 |       case FORWARD:
185 |         stats();
186 |         die("stray forwarding pointer");
187 |       case '.':
188 |         return;
189 |       case 'Y':
190 |         /* fix */
191 |         /* Y x = x (x (x ...)) */
192 |         lazy(1, arg(1), sp[1]);
193 |         break;
194 |       case 'S':
195 |         /* ap */
196 |         /* S x y z = x z (y z) */
197 |         lazy(3, apparg(1, 3), apparg(2, 3));
198 |         break;
199 |       case 'B':
200 |         /* (.) */
201 |         /* B x y z = x (y z) */
202 |         lazy(3, arg(1), apparg(2, 3));
203 |         break;
204 |       case 'C':
205 |         /* flip */
206 |         /* C x y z = x z y */
207 |         lazy(3, apparg(1, 3), arg(2));
208 |         break;
209 |       case 'R':
210 |         /* flip flip */
211 |         /* R x y z = y z x */
212 |         lazy(3, apparg(2, 3), arg(1));
213 |         break;
214 |       case 'I':
215 |         /* id */
216 |         /* I x = x */
217 |         sp[1] = arg(1);
218 |         sp++;
219 |         break;
220 |       case 'T':
221 |         /* (&) */
222 |         /* T x y = y x */
223 |         lazy(2, arg(2), arg(1));
224 |         break;
225 |       case 'K':
226 |         /* K x y = x */
227 |         lazy(2, 'I', arg(1));
228 |         break;
229 |       case ':':
230 |         /* "cons" */
231 |         /* : a b c d = (d a) b */
232 |         lazy(4, apparg(4, 1), arg(2));
233 |         break;
234 |       case '0':
235 |         /* Read a character c from the input */
236 |         /* If c == 0, then I K (represents nil) */
237 |         /* else : (# c) (0 ?)  (represents a list of the first */
238 |         /*                      character and the rest of the input) */
239 |         c = get();
240 |         !c ? lazy(1, 'I', 'K') : lazy(1, app(':', app('#', c)), app('0', '?'));
241 |         break;
242 |       case '#':
243 |         /* reduce # n f to f (# n) */
244 |         lazy(2, arg(2), sp[1]);
245 |         break;
246 |       case '1':
247 |         put(num(1));
248 |         lazy(2, app(arg(2), '.'), app('T', '1'));
249 |         break;
250 |       case '=':
251 |         num(1) == num(2) ? lazy(2, 'I', 'K') : lazy(2, 'K', 'I');
252 |         break;
253 |       case 'L':
254 |         num(1) <= num(2) ? lazy(2, 'I', 'K') : lazy(2, 'K', 'I');
255 |         break;
256 |       case '*':
257 |         lazy(2, '#', num(1) * num(2));
258 |         break;
259 |       case '/':
260 |         lazy(2, '#', num(1) / num(2));
261 |         break;
262 |       case '%':
263 |         lazy(2, '#', num(1) % num(2));
264 |         break;
265 |       case '+':
266 |         lazy(2, '#', num(1) + num(2));
267 |         break;
268 |       case '-':
269 |         lazy(2, '#', num(1) - num(2));
270 |         break;
271 |       case '|':
272 |         lazy(2, '#', num(1) | num(2));
273 |         break;
274 |       case '&':
275 |         lazy(2, '#', num(1) & num(2));
276 |         break;
277 |       case '^':
278 |         lazy(2, '#', num(1) ^ num(2));        
279 |       case 'G':
280 |         /* getc k w = k n w */
281 |         /* Where k is the continuation, w is the "world" */
282 |         lazy(2, app(arg(1), getchar()), arg(2));
283 |         break;
284 |       case 'P':
285 |         /* putc n k w = k w */
286 |         /* k is the continuation, w is the "world" */
287 |         putchar(num(1));
288 |         lazy(3, arg(2),arg(3));
289 |         break;
290 |       default:
291 |         printf("?%u\n", x);
292 |         die("Unknown combinator");
293 |       }
294 |   }
295 | }
296 | 
297 | char buf[BUFMAX];
298 | char *bufptr, *buf_end;
299 | void buf_reset() { bufptr = buf; }
300 | void buf_put(u c) {
301 |   if (bufptr == buf_end)
302 |     die("Buffer overflow");
303 |   *bufptr++ = c;
304 | }
305 | 
306 | FILE *file;
307 | void pcFile(u c) {
308 |   putc(c, file);
309 |   fflush(file);
310 | }
311 | FILE *fp;
312 | void fp_reset(const char *f) {
313 |   fp = fopen(f, "r");
314 |   if (!fp) {
315 |     fprintf(stderr, "Error: File %s not found!\n", f);
316 |     exit(1);
317 |   }
318 | }
319 | 
320 | u fp_get() {
321 |   u c = fgetc(fp);
322 |   return c == EOF ? fclose(fp), 0 : c;
323 | }
324 | 
325 | void pc(u c) {
326 |   putchar(c);
327 |   fflush(stdout);
328 | }
329 | 
330 | void lvlup(char *prog) {
331 |   parse(buf);
332 |   str = prog;
333 |   buf_reset();
334 |   run(str_get, buf_put);
335 |   *bufptr = 0;
336 | }
337 | 
338 | void lvlup_file(const char *filename) {
339 |   printf("Loading %s...\n", filename);
340 |   parse(buf);
341 |   fp_reset(filename);
342 |   buf_reset();
343 |   run(fp_get, buf_put);
344 |   *bufptr = 0;
345 | }
346 | 
347 | u getc_stdin() { return getchar(); }
348 | 
349 | void init_vm() {
350 |   mem = arena[0];
351 |   altmem = arena[1];
352 |   buf_end = buf + BUFMAX;
353 |   spTop = mem + TOP - 1;
354 |   strcpy(buf, "I;");
355 |   bufptr = buf + 2;
356 |   gc_count = 0;
357 | }
358 | 
359 | void run_with_input(char *prog, char *input) {
360 |   buf_reset();
361 |   str = input;
362 |   strncpy(buf, prog, strlen(prog));
363 |   parse(buf);
364 |   run(str_get, pc);
365 | }
366 | 
367 | void get_input() {
368 |   input[0] = 0;
369 |   do {
370 |     if (fgets(input, sizeof(input), stdin) == 0) {
371 |       exit(0);
372 |     }
373 |   } while (input[0] == '\0');
374 | }
375 | int main(int argc, const char **argv) {
376 |   if (argc != 4) {
377 |     printf("Usage: ./blynn <binary> <input> <output>\n");
378 |     exit(1);
379 |   }
380 |   FILE *f = fopen(argv[2], "r");
381 |   if (!f) {
382 |     printf("File not found: %s\n", argv[1]);
383 |     exit(1);
384 |   }
385 |   fclose(f);
386 |   f = fopen(argv[3], "a");
387 |   if (!f) {
388 |     printf("File not found: %s\n", argv[2]);
389 |     exit(1);
390 |   }
391 |   fclose(f);
392 |   init_vm();
393 | 
394 |   /* Load lvlup_file into memory */
395 |   lvlup_file(argv[1]);
396 |   stats();
397 |   /* Parse the lvlup_file. (upgrades the compiler from ION assembly to */
398 |   /* a subset of Haskell) */
399 |   parse(buf);
400 | 
401 |   /* Reset the input file to be argv[1], and open as writable. */
402 |   fp_reset(argv[2]);
403 |   file = fopen(argv[3], "w");
404 |   /* Run it!  Input comes from the file argv[1], output goes to the */
405 |   /* file argv[2]. */
406 |   run(fp_get, pcFile);
407 |   fclose(file);
408 |   printf("Input file compiled.\n");
409 |   printf("Run binary on input from stdin? [Y/n] ");
410 |   fflush(stdout);
411 | 
412 |   get_input();
413 |   if (input[0] == '\n' || input[0] == 'y') {
414 |     input[0] = 0;
415 |     init_vm();
416 |     lvlup_file(argv[3]);
417 |     parse(buf);
418 |     printf("Input: ");
419 |     fflush(stdout);
420 |     get_input();
421 |     str = input;
422 |     run(str_get, pc);
423 |     puts("");
424 |     stats();
425 |   }
426 |   return 0;
427 | }
428 | 


--------------------------------------------------------------------------------
/check.sh:
--------------------------------------------------------------------------------
 1 | #!/bin/bash
 2 | 
 3 | TIMEOUT=60
 4 | # Check that self-compiling works
 5 | stage1() {
 6 |     echo 'n' | timeout $TIMEOUT ./blynn classy "$1" classy2 ||
 7 |         (echo 'Stage 1 fail' && exit 1)
 8 | }
 9 | 
10 | stage2() {
11 |     echo 'n' | timeout $TIMEOUT ./blynn classy2 "$1" classy3 ||
12 |         (echo 'Stage 2 fail' && exit 1)
13 | }
14 | 
15 | check() {
16 |     stage1 "$1" &&
17 |     stage2 "$1" &&
18 |     printf '\n' &&
19 |     diff -qs classy2 classy3
20 | } 
21 | if [[ $1 == "" ]]
22 | then
23 |    echo "./check.sh <compiler source>"
24 |    exit
25 | fi
26 | check "$1"
27 | 


--------------------------------------------------------------------------------
/check_compile.sh:
--------------------------------------------------------------------------------
 1 | #!/bin/bash
 2 | 
 3 | TIMEOUT=60
 4 | # Very meta. We self-compile three times because if a change was made
 5 | # the compiler's output in classy.hs, we need to compile two more
 6 | # times to propagate that change.
 7 | stage1() {
 8 |     echo 'n' | timeout $TIMEOUT ./blynn classy "$1" classy2 ||
 9 |         (echo 'Stage 1 fail' && exit 1)
10 | }
11 | 
12 | stage2() {
13 |     echo 'n' | timeout $TIMEOUT ./blynn classy2 "$1" classy3 ||
14 |         (echo 'Stage 2 fail' && exit 1)
15 | }
16 | 
17 | stage3() {
18 |     echo 'n' | timeout $TIMEOUT ./blynn classy3 "$1" classy4 ||
19 |         (echo 'Stage 3 fail' && exit 1)
20 | }
21 | 
22 | check_compile() {
23 |     stage1 "$1" &&
24 |     stage2 "$1" &&
25 |     stage3 "$1" &&
26 |     printf '\n' &&
27 |     diff -qs classy3 classy4
28 | } 
29 | if [[ $1 == "" ]]
30 | then
31 |     echo "./check_compile.sh <compiler source>"
32 |     exit
33 | fi
34 | check_compile "$1"
35 | 


--------------------------------------------------------------------------------
/classy:
--------------------------------------------------------------------------------
 1 | ``BT`T%;``BT`T/;``BT`T*;``BT`T-;``BT`T+;`T`(1)+;I;I;``BT`TL;``BT`T=;C;Y;``BK``BK``BKT;``BK``BK``B`BKT;``BK``B`BK``B`BKT;``BK``BKK;I;``B`BK``B`BK``B`BK``B`BK``BCT;``BK``BK``BK``B`BKT;``BK``BK``B`BK``B`BKT;``BK``B`BK``B`BK``B`BKT;``BK``BK``BKK;I;``B`B`BK``B`B`BK``B`B`BK``B`BC``BCT;``B`B`BK``B`B`BK``B`B`B`BK``B`BC``BCT;``BK``B`BK``B`BKT;``B`B`BK``B`B`BK``B`B`BK``BCT;I;``BCT;I;``BCT;I;``BCT;I;`K`KI;`KK;``BKK;I;``BKT;``B`BKT;I;``B`B`BK``B`BC``BCT;``B`BKT;I;``B`BC``BCT;I;T;I;``BCT;I;``BCT;I;``B`BC``BCT;I;``BK``BK``BK``BKT;``B`BK``B`BK``B`BK``B`B`BK``BCT;``B`BK``B`BK``B`B`BK``B`B`BK``BCT;``BK``B`BK``B`BK``B`BKT;``B`BK``B`BK``B`BK``B`BKT;I;``B`BK``B`BK``BCT;``BK``B`BKT;``B`BK``B`BKT;I;``BKT;``B`BKT;I;``BKT;``B`BKT;I;``BKT;K;I;`KI;K;I;``BCT;I;``B`BK``BCT;K;I;`T`KI;`TK;`T`KI;`TK;`TI;`TI;`TI;`T[9];[2];[4];[3];[0];[1];`[11]I;I;I;K;C;T;[85];``B`C``BB``BB[83][85];``B`R`KI``B`B[95]`C[101];``C``BC`C[101][97];[77];``RK[77];``R`KI[77];``B`C``B[95][104]`B[76];``B`C``B[95][104]`C``BB[76];[75];``C``C[75][73][74];B;``C``BB``C[109][74]``C``C[109][74][73];``C``BC``C``BB[109]``C``C[109][74][73][73];``S``BS``B`B[113]``B`B[110]`[87][88][8];[80];``B[11]``B`B`C``BS``C``BB[80]``C``C[115][74]`K`K[73]``B`B`C``BB``BB``C[115][73]``C``BC``B`BC``B`B`BC``B`B`B`BC``B`B`B`B`BC``BC``B`BB``B`BC``B`B`BB``B`B`B[109][87][73];``BT[116];``B`B`B[110][87];`[11]``B`C``BS[115]``B`B`C``BB[78]C;``BC`C[72];[72];``BT``B`[120]``[78]#N``[78]#o``[78]#t``[78]#h``[78]#i``[78]#n``[78]#g[79]``B`B`[119]``[78]#J``[78]#u``[78]#s``[78]#t``[78]# [79][86];`T``B`[120][71]`[111][70];````BCT[70]`C``B`[120][71]`[10]`[85][123];````BCT[70]`C`[120][71];``C``BC`C[121][96];`[11]``B`B`S``BC`C[115]`S``BB``BC`BB;``B`S``C[115][71]``B`BK``B`BK``C``B[127]``B`B`B[70]`S``BC`C[121][71];``BC``C``B[127]``B`B`CBC[96];``B`C``C[115][71]``B`B`B[70][129];``C``BC``B`B[127]``C``BC``B`BC``B`B`B[109]``BC[87][74][73];``C``B[127]``C``BS`B[109][70][71];``[127][119][79];``C[78][79];``C``B[127]`B[78][79];``B`B[133][135];`T[135];````BCT[134]`[98][136];````BCT[134]``C``BB`[81][138]``C``BB`[81][138]`B`[95]`[82][138];`[11]``B`B`C``C[115][79]``B`S``BB``BB[78]`B`C``BB[78];``B`C``C[115][79]``B`C``BB[78][140];``B`[111][133][141];`[142]``[78]# [79];``B`B`[119]``[78]#[[79]``C``BC``B`B[119]``B`B`[142]``[78]#,[79]``B[135][86]``[78]#][79];``B`S``C[80]``[78]#[``[78]#][79]``B`BK``B`BK[144];``B`B[133][135];``S``C``B[109]``R#
 2 | `[87][88]``[78]#\``[78]#n[79]``S``C``B[109]``R#\`[87][88]``[78]#\``[78]#\[79]``C[78][79];``B`[119]``[78]#"[79]``C``B[119]`[146][147]``[78]#"[79];``B[109]``[87][88](0);`[11]``B`S``C[149][96]``C``BS``B`B[111]``CB``R(10)[93]``B[78]``B[7]``B`[90](48)``R(10)[92];``S``C[149]`[78]#0[150];`T``C[151][79];`T[148];``BT[145];``C``B[127]``C``BC`B[109][74][73];``C``BC``B`B[127]``B`B`C``BB[104]``B`BC``B`B`BC``C``BC``B`BC``B`B`BB`B`B[109][70][71];``B[156][87];``[129]`[98][78][79];`[11]``B`B`C``BB``C[80][79]``B`B`C``BB``BB``C[80][79]`S``BC``B`BB``B`BC``B`B`BB`B`B[78];`[159][76];``B`[78]#(``C[119]``[78]#)[79];``C[51]``B`B[143]``B`B`[78]``[78]#r``[78]#o``[78]#w``[78]#:[79]``C``BB``B[78]`[86][152]``B`[78]``[78]#c``[78]#o``[78]#l``[78]#:``[78]# [79]``C``B[78]`[86][152][79];`T[162];``C[49]``B`B[143]``C``BB``B[78]`[86][153]``C``B[78]``B[161]`[86][163][79];`T[164];``C[48]``[50](1)(1);``RI[47];``C``BB[167][166];``B`B`[95][46]``C``BS``B`BC``C``BB``BC``B`B[40][167]``B`C``C[43]``B[39][42]``B`B`BK`B[167]``B`B[38]``B`C``C[43][42]``B`B`BK``B`B`RI``B`B`RI``B`B`B[40]`B[167];``B`[95][46]``B`S[49]``B`BK``B`B`B[39]``C``BC``B`BB[41]``C``C[44][79][79];````BCT[170][169];`T``B`C`[81][171]`B[170];````BCT[170]``C``BB`[81][171]``C``BB`[81][171]`B[170];``C``BB[51]``C``BS``B`BB``C``BB``B[109]``R#
 3 | `[87][88]``R(0)``B[50]``R(1)[90]``C``BB[50]``R(1)[90];``B`[95][46]``B`C[49]``B`C``BS``C``BB[80]``B[39]``B[42]``C``C[44]``[78]#e``[78]#n``[78]#d``[78]# ``[78]#o``[78]#f``[78]# ``[78]#i``[78]#n``[78]#p``[78]#u``[78]#t[79][79]``C``BS``B`BS``B`B`BC``C``BB``BS``B`BB`B[109]``S``BS``B`BC``C``BC``B`BB``B`BB``B`B`B[38]``B`C``BC[41]``C``C[44][79][79][48][174]``B`B[39]``B`B[42]``C``BC``C``BB[44]``C[78][79][79];``C``BB[45]``C``BB``BB``BB[45]``B`B`BK``B`B`BK``C``BC``B`BB``B`BB[44][119];``B`B`B`B[39]``C``BC``B`BB``B`BB[41][176];``B`B[39]``B`B[42][176];``B`B`[95][46]``C``BC``B`BC``C``BB``BS``B`B[40][167]``S``BS``B`BC``B`B`C[43]``C``BC``B`BC``C``BC``B`BB``B`B[40][167]``S``BC``B`C[43][178]`C``BC[177][38]``C``BC``B`BC``B`B`BC``B`B`B`BC``C``BC``B`BB``B`BB``B`BB``B`B[40][167]``S``BS``B`BS``B`B`BC``B`B`B`C[43][177]``B`B`BK``B`B`BK[177][38][38];``B`[95][46]``C``BC``C``BC``B`B[40][167][39]``C``C[43]``B[39][42]``B`B`B[38][41];``B[179][180];`[11]``C``BC``B`B[181]`S```[101][172][173][78]``[84][173][79];``S```[101][172][173][78][182];``C``BB[45]``B`B`BK``B`C``BC[44]``C[78][79];``B`B`[95][46]``C``BC``B`BC``C``BB``BC``B`B[40][167]``B`B[39]``S``BC``B`C[43]``B`B[42]`C[184]``B`C``BC``B`BB[41]`C[184][38];`[175]`[97][74];``S``BB```[101][172][173][78]``B`B[182]`C``[102][173][172];``C``BC``B`B[181][187]``[84][173][79];``S``B[185]``B[175]`[10]`[87][88]`[86][152];`[11]``B`S``C[80]``[84][173][79]``C``BB``BC``B`BC``B`B`B``[102][173][172]`C``BB``B``[102][173][172][189]`[84][173];``S``BS``B`BC``B`B`BB``B`B`BB`C[102]``B`BC`C[103];````[102][173][172]`[189]#-`````[191][172][173]`[189]#-`[189]#
 4 | `[182]`[175]``[10]`[118][88]#
 5 | ;````[102][173][172]``[179]`[175]``[10]`[118][88]#-````[102][173][172]`[189]#-`[175]``[10]`[118][88]#}``[84][173][79];`[11]``B``C``B``[102][173][172]````[191][172][173]`[190]``[78]#{``[78]#-[79]`[190]``[78]#-``[78]#}[79]``[84][173][79]``B[182]``C[181][193];`[182]``[179]``[179]```[100][172]`[84][139]`[175]``S``B[112]``R# `[87][88]``R#
 6 | `[87][88][192][194];``C``[103][173][172][195];``[111][196][189];``B`B`B`[95][46]``S``BS``B`BC``B`B`BC``B`B`C``BC``B`B[40][167]``B`B`B[39]``B`B`C``C[43][42]``C``BB``BC``B`BC``B`B`BS``C``BS``B`BB``B`BB`B[109][41]``B`B[42]`C[184]``B`B`B[38]``B`B`C``C[43][42]``C``BB``BC``B`BC``B`B`BS``C``BS``B`BB``B`BB`B[109][41]``B`B[42]`C[184];`C``S``B[198]`[10]`[87]`[117][88]I;````[191][172][173]`[197]#(`[197]#);``[185]`[175]``S``B[112]``S``B[113]``R#z[8]`[8]#a``R#_`[87][88]``[78]#l``[78]#o``[78]#w``[78]#e``[78]#r[79];``[185]`[175]``S``B[113]``R#Z[8]`[8]#A``[78]#u``[78]#p``[78]#p``[78]#e``[78]#r[79];``[185]`[175]``S``B[113]``R#9[8]`[8]#0``[78]#d``[78]#i``[78]#g``[78]#i``[78]#t[79];``[185]``[179][201][202]``[78]#a``[78]#l``[78]#p``[78]#h``[78]#a[79];`````[101][172][173][78][201]`[182]``[179]``[179][204][203]`[189]#';`[196]`````[101][172][173][78][202]`[182]``[179]``[179][204][203]`[189]#';``B[196]`[199][205];`[196]```[198]``B[110]``S``B[112]``C`[87]`[117][88]``[78]#o``[78]#f[79]``C`[87]`[117][88]``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e[79]``[78]#v``[78]#a``[78]#r``[78]#i``[78]#a``[78]#b``[78]#l``[78]#e[79][205];`[183]`[175]``[10]`[131][88]``[78]#:``[78]#!``[78]##``[78]#$``[78]#%``[78]#&``[78]#*``[78]#+``[78]#.``[78]#/``[78]#<``[78]#=``[78]#>``[78]#?``[78]#@``[78]#\``[78]#^``[78]#|``[78]#-``[78]#~[79];``[179]`[196][209]`````[191][172][173]`[197]#``[197]#`[208];``[179][208]`[200]`[196][209];``C``B`[100][172][84]`[196]`[175]`[97][74];``B```[102][173][172]`[197]#\``B````[101][172][173]`[98]`[127][55]`[183][208]``B```[102][173][172]`[189]#-```[102][173][172]`[197]#>;``C[85]``[127]``B[56]`[56]`[57]``[78]#:[79]`[57]``[78]#[``[78]#][79];````[102][173][172]`[189]#\``[179]`[175]``[10]`[131][88]``[78]#'``[78]#"``[78]#\[79]```[100][172]`[97]#
 7 | `[189]#n;``B``[100][172]``B[58]``B`[78]##`[84][139]``B`[181][215]``B[175]`[10]`[118][88];```[100][172]``[111][58]``[111]`[78]#(``[10][119]``[78]#)[79]`[196]`[183][203];``[214][172]`````[191][172][173]`[189]#"`[197]#"`[182]`[216]#";`````[191][172][173]`[189]#'`[197]#'`[216]#';``[179]``[179][218][219][217];``B`[214][172]``B````[191][172][173]`[197]#[`[197]#]``C[188]`[197]#,;``B``[83][173]```[100][172][76]``[181]``[181][206]```[100][172]`[84][139]`[200]``[179]`[197]#:`[197]#,`````[101][172][173][78]`[197]#[```[100][172]`[84][139]`[197]#]``B````[101][172][173]`[98]`[127][55]`[182][208]``B```[102][173][172]`[189]#-```[102][173][172]`[197]#>;``B````[191][172][173]`[197]#{`[197]#}``C[188]`[197]#;;``B[223][222];``B`S``B`[129][56]``B[57]`[136]``[111]`[78]#|[105]``C``BB[78]`[135][106];``S``B```[101][172][173][225]````[191][172][173]`[207]``[78]#c``[78]#a``[78]#s``[78]#e[79]`[207]``[78]#o``[78]#f[79][224];``B```[102][173][172]`[197]#,``C``B[181]``[100][172]`C``B[56]`[56]`[57]``[78]#,[79]``[84][173]`[56]`[57]``[78]#,[79];``S```[101][172][173][99]``C``B[181]``B`[181]```[100][172]``B[56][57][210][227]``[84][173][96];``[83][173]```[100][172]``B[56]``B`[56]`[57]``[78]#\``[78]#C[79][57]``[179][210]```[100][172]`[84][139]`[197]#,;``B[200]``S``B[179][228][229];`[11]``C``BC``B`BC``S``BS``B`BC``B`S``BC``B`C``C[59]`K[73]`C`[87]`[117][88]``S``BS``B`BC``B`B`BB`B`B[112]I`S``BC``B`BB``B`B[113]`[118]`[117][88]`K[73];``RI``BS``S``BS``B`B[109][231]``B`B`[56]`[57]``[78]#\``[78]#Y[79][55];``B````[101][172][173][76][211]``B``[83][173]```[100][172]`[98]`[127][55]`[182][208]```[102][173][172]`[197]#=;`C`[127]``C``BB[104]``C``BS``B`BB``B`B[95]``B`B[56]`C[55][232];``S``B```[101][172][173][234]``B````[191][172][173]`[207]``[78]#l``[78]#e``[78]#t[79]`[207]``[78]#i``[78]#n[79]``B[223][233]I;``C``B[181]``C``B[181]``C``B[181]``S``B[181]``S``B[179]``S``B[181]``S``B[179][235][221][226][213][230]````[102][173][172]`[200]`[197]#,``[84][173]`[57]``[78]#,[79]```[100][172][57]``[179][206][211][220];``B``[100][172]``[111]`[126][94]`[130][56]``B[183][236];`[11]`SI;`T``C``C``C[37]``[78]#N``[78]#A``[78]#s``[78]#s``[78]#o``[78]#c[79]``[78]#L``[78]#A``[78]#s``[78]#s``[78]#o``[78]#c[79]``[78]#R``[78]#A``[78]#s``[78]#s``[78]#o``[78]#c[79];``C``BS``C``BS``C``BB[37]``C``C``C[37][74][73][73]``C``C``C[37][73][74][73]``C``C``C[37][73][73][74];`T[240];``C``BC``B`BC``B`B`R(5)``B`B`B[121][157][105];``C``BC``B`BC``C``BC``B`BC``B`B`B[121][157][35][106];``C``BC``C``BC``B`B[198]``B`C``BB`[87][88]`C`[242]`[117][88]``[78]#p``[78]#r``[78]#e``[78]#c``[78]#T``[78]#a``[78]#b[79][210];``B`S``BS``B`C[80][70]``C``BC``B`BC``B`B`BC``B`B`B`BC``S``BB``BB``BS``B`BS``B`B`B[72]``B`B[132]``B`B`B[110]``S``BC``B`BB``B`B`[87][241]`C``B`[243]`[117][88][105]`C``B`[243]`[117][88][105]``C``BS``B`BS``B`B`BC``B`B`B`BC``C``BS``B`BB``B`BC``B`B`BC``C``BB``BS``B`BB``B`B[37]`C``B`[243]`[117][88][105]``C``BC``B`BC``B`B`C[80]``B`B`[95][70]``B`C[104]``B`B[56]`C``B[56][57]`K`K[71]``B`B`[95][70]`[129]``B`C[104]``B`B[56]`C``B[56][57]``B`B`[95][70]`C``[127]``C``BB[104]`C``BB``BC``B`B[56]``B[56][57][96]`K[71];``B`[95][238]``C``BS``B`BC``B`B`S``B[109]``R(9)[8]``S``BS``B`BS``B`B`B`[83][173]``C``BB``BB``B`[100][172]``B`[111]`[111]`[126][94][245]``CB[5]``B`B`B[182]``C``BB``BS``B`B```[101][172][173][76][244]``CB[5]``B[237]`T(0);``B[60]`[60]`[62]``[78]#-``[78]#>[79];``B``[100][172]``[111]`[126][94]`[130][60][183];``B``[100][172]``[111]`[126][94]`[128][247]``C``B[188][248]`[196]``[199][209]``[78]#-``[78]#>[79];```[100][172]``S``C``B[109]``C`[87]`[117][88]``[78]#S``[78]#t``[78]#r``[78]#i``[78]#n``[78]#g[79]``[60]`[62]``[78]#[``[78]#][79]`[62]``[78]#I``[78]#n``[78]#t[79][62][206];`[11]``S``B[181]``C``B[181]``C``B[181]``B[200]``S``B```[101][172][173][99][249]``C``B[181]``B```[102][173][172]`[197]#,``B``[100][172]`C``B[60]`[60]`[62]``[78]#,[79][249]``[84][173][96][250]```[100][172][61][208]``B```[102][173][172]`[197]#[``B`[181]````[102][173][172]`[197]#]``[84][173]`[62]``[78]#[``[78]#][79]``B``[100][172]`[60]`[62]``[78]#[``[78]#][79]``C``B``[103][173][172][249]`[197]#];``C``BB``B`[129][60][62]`[135][61];`````[101][172][173][26]`````[191][172][173]`[207]``[78]#d``[78]#a``[78]#t``[78]#a[79]`[197]#=`````[101][172][173][252][206]`[182][208]``[188]`````[101][172][173][32][206]`[182][251]`[197]#|;```[100][172]``C``B[91][6]`[6]#0`[196][203];``C``BB``BB[85]``B`B`[10][76]`C[76];``C``BB``C``B``[191][172][173][207]`[197]#;``C``C``B``[101][172][173]`[255][137][254]``[188][210]`[197]#,;``[181]``[181]``[256]``[78]#i``[78]#n``[78]#f``[78]#i``[78]#x``[78]#l[79][35]``[256]``[78]#i``[78]#n``[78]#f``[78]#i``[78]#x``[78]#r[79][34]``[256]``[78]#i``[78]#n``[78]#f``[78]#i``[78]#x[79][36];`[28][79];`````[101][172][173][76][211]````[102][173][172]````[102][173][172]`[189]#:`[197]#:`[249][251];````[102][173][172]`[207]``[78]#c``[78]#l``[78]#a``[78]#s``[78]#s[79]```[83][173]```[83][173]```[100][172][24][206]```[100][172][61][208]````[102][173][172]`[207]``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e[79]`[223][259];`[249][251];``B```[102][173][172]`[207]``[78]#i``[78]#n``[78]#s``[78]#t``[78]#a``[78]#n``[78]#c``[78]#e[79]``B``[83][173]```[83][173]```[83][173]```[100][172]``B`C``BB[23][28]``[181]`````[101][172][173]``[111]`[111]`[84][139][30][206]````[103][173][172][261]````[102][173][172]`[189]#=`[197]#>``[84][173][79][206][261]``B```[102][173][172]`[207]``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e[79]``B[223][233];``C``B[188]``S``B[181]``C``B[181]``B`[181][253]``B``[100][172][25]``B[233]``R(0)[246][260]``B[262]``R(0)[246]`[197]#;;````[102][173][172][195]```[81][171]```[100][172][133]`[182][257][263];```[40]``[95]`[168][264]``[119]``[78]#c``[78]#l``[78]#a``[78]#s``[78]#s``[78]# ``[78]#E``[78]#q``[78]# ``[78]#a``[78]# ``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e``[78]# ``[78]#{``[78]# ``[78]#(``[78]#=``[78]#=``[78]#)``[78]# ``[78]#:``[78]#:``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#B``[78]#o``[78]#o``[78]#l``[78]# ``[78]#}``[78]#;``[78]#
 8 | [79]``[119]``[78]#c``[78]#l``[78]#a``[78]#s``[78]#s``[78]# ``[78]#S``[78]#h``[78]#o``[78]#w``[78]# ``[78]#a``[78]# ``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e``[78]# ``[78]#{``[78]# ``[78]#s``[78]#h``[78]#o``[78]#w``[78]# ``[78]#:``[78]#:``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#S``[78]#t``[78]#r``[78]#i``[78]#n``[78]#g``[78]# ``[78]#}``[78]#;``[78]#
 9 | [79]``[119]``[78]#c``[78]#l``[78]#a``[78]#s``[78]#s``[78]# ``[78]#F``[78]#u``[78]#n``[78]#c``[78]#t``[78]#o``[78]#r``[78]# ``[78]#f``[78]# ``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e``[78]# ``[78]#{``[78]# ``[78]#f``[78]#m``[78]#a``[78]#p``[78]# ``[78]#:``[78]#:``[78]# ``[78]#(``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#b``[78]#)``[78]# ``[78]#-``[78]#>``[78]# ``[78]#f``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#f``[78]# ``[78]#b``[78]# ``[78]#}``[78]#;``[78]#
10 | [79]``[119]``[78]#c``[78]#l``[78]#a``[78]#s``[78]#s``[78]# ``[78]#A``[78]#p``[78]#p``[78]#l``[78]#i``[78]#c``[78]#a``[78]#t``[78]#i``[78]#v``[78]#e``[78]# ``[78]#f``[78]# ``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e``[78]# ``[78]#{``[78]# ``[78]#p``[78]#u``[78]#r``[78]#e``[78]# ``[78]#:``[78]#:``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#f``[78]# ``[78]#a``[78]#;``[78]# ``[78]#(``[78]#<``[78]#*``[78]#>``[78]#)``[78]# ``[78]#:``[78]#:``[78]# ``[78]#f``[78]# ``[78]#(``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#b``[78]#)``[78]# ``[78]#-``[78]#>``[78]# ``[78]#f``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#f``[78]# ``[78]#b``[78]# ``[78]#}``[78]#;``[78]#
11 | [79]``[119]``[78]#c``[78]#l``[78]#a``[78]#s``[78]#s``[78]# ``[78]#M``[78]#o``[78]#n``[78]#a``[78]#d``[78]# ``[78]#m``[78]# ``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e``[78]# ``[78]#{``[78]# ``[78]#r``[78]#e``[78]#t``[78]#u``[78]#r``[78]#n``[78]# ``[78]#:``[78]#:``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#m``[78]# ``[78]#a``[78]# ``[78]#;``[78]# ``[78]#(``[78]#>``[78]#>``[78]#=``[78]#)``[78]# ``[78]#:``[78]#:``[78]# ``[78]#m``[78]# ``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#(``[78]#a``[78]# ``[78]#-``[78]#>``[78]# ``[78]#m``[78]# ``[78]#b``[78]#)``[78]# ``[78]#-``[78]#>``[78]# ``[78]#m``[78]# ``[78]#b``[78]#}``[78]#;``[78]#
12 | [79]``[78]#i``[78]#n``[78]#s``[78]#t``[78]#a``[78]#n``[78]#c``[78]#e``[78]# ``[78]#E``[78]#q``[78]# ``[78]#I``[78]#n``[78]#t``[78]# ``[78]#w``[78]#h``[78]#e``[78]#r``[78]#e``[78]# ``[78]#{``[78]# ``[78]#(``[78]#=``[78]#=``[78]#)``[78]# ``[78]#=``[78]# ``[78]#i``[78]#n``[78]#t``[78]#E``[78]#q``[78]# ``[78]#}``[78]#;``[78]#
13 | [79]``R``BKK``C[43]`K[94]``R``BKK``C[43]`K[94];```[100][172]`[119]``[119][265]``[78]``[26]``[60]`[62]``[78]#[``[78]#][79]`[61]``[78]#a[79]``[78]``[32]``[78]#[``[78]#][79][79]``[78]``[32]``[78]#:[79]``[78]`[61]``[78]#a[79]``[78]``[60]`[62]``[78]#[``[78]#][79]`[61]``[78]#a[79][79][79]``[78]``[26]``[60]``[60]`[62]``[78]#,[79]`[61]``[78]#a[79]`[61]``[78]#b[79]``[78]``[32]``[78]#,[79]``[78]`[61]``[78]#a[79]``[78]`[61]``[78]#b[79][79][79][79][264];```S``C``BC``B`B`B`[95]`[135]`[108]`[107][258]``C``BB``BS``B`B[119]``B`B`[78]``[76]``[78]#\``[78]#Y[79]``[76]``[247]``[247]`[61]``[78]#a[79]`[61]``[78]#a[79]`[61]``[78]#a[79]`[58]``[78]#Y[79]``B`B`[78]``[76]``[78]#\``[78]#C[79]``[76]``[247]``[247]`[61]``[78]#a[79]``[247]`[61]``[78]#b[79]`[61]``[78]#c[79]``[247]`[61]``[78]#b[79]``[247]`[61]``[78]#a[79]`[61]``[78]#c[79]`[58]``[78]#C[79]``B`S``B[78]``B`[76]``[78]#i``[78]#n``[78]#t``[78]#E``[78]#q[79]``B`[76]``[247]`[62]``[78]#I``[78]#n``[78]#t[79]``[247]`[62]``[78]#I``[78]#n``[78]#t[79]`[62]``[78]#B``[78]#o``[78]#o``[78]#l[79]`T``[78]#=[79]``B`C``B[78]``B`[76]``[78]#<``[78]#=[79]``B`[76]``[247]`[62]``[78]#I``[78]#n``[78]#t[79]``[247]`[62]``[78]#I``[78]#n``[78]#t[79]`[62]``[78]#B``[78]#o``[78]#o``[78]#l[79]`T``[78]#L[79]``S``B[78]``B`[76]``[78]#c``[78]#h``[78]#r[79]``C[76]`[58]``[78]#I[79]``S``B[78]``B`[76]``[78]#o``[78]#r``[78]#d[79]``C[76]`[58]``[78]#I[79]``C``B[78]``B`[76]``[78]#s``[78]#u``[78]#c``[78]#c[79]``C[76]`[58]``[78]#```[78]#T``[78]#```[78]#(``[78]#1``[78]#)``[78]#+[79][79]``C``BC``B`B[135]``B`B`S``B[76]``B`[78]#.``C[119]``[78]#.[79]``BB[76]``[78]``[78]#+[79]``[78]``[78]#-[79]``[78]``[78]#*[79]``[78]``[78]#/[79]``[78]``[78]#%[79][79]``B`[95][58]`[119]``[78]#```[78]#```[78]#B``[78]#T``[78]#```[78]#T[79]`[247]`[62]``[78]#I``[78]#n``[78]#t[79]``[247]`[62]``[78]#I``[78]#n``[78]#t[79]`[62]``[78]#I``[78]#n``[78]#t[79];``B`C``BC``B`B`R(0)``BCT``B[11]``B`B`C``BB``BB``C[80][71]``C``BB``BS``B`BS``B`B`BC``B`B`B`BB``C``BC``B`BB``B`BC``B`B`B[109]``C``BC``B`BB[87][105]``B[70]``B`[78]#[``C[151]``[78]#][79]``C``BC``B`BB``B`BCC[5];`[11]``C``BC``B`BC``C``BC``B`BC``B`S``BC``B`C``C[59][70]`[268]`[117][88]``S``BS``B`BC``B`B`BB`B`B```[101][123][124]``B`B`[78]#`[119]I`K`K[71]`K[71];`[11]``C``BC``B`BC``S``BS``B`BC``B`S``BC``B`C``C[59]``B`[95]`[84][124]``B[19][58]``B`B`[95]`[84][124]`C``S``B[127]``C``BC``B`BB``C``BC``B`B[109]`C`[87]`[117][88][21][20]``B[19][57]``S``BS``B`BC``B`B`BB``B`B`B`[83][124]`B`B``[100][123][17]I``B`B`B`B``[100][123][18]``C``BBB`C[78]`K[71];``S``BC``B`C``C``C[16]`[13]`[14]``[56]``[56]`[58]``[78]#S[79]`[58]``[78]#I[79]`[58]``[78]#I[79]``B[13]``B[14]`[56]`[58]``[78]#T[79]``B`B[13]`T`[14]``[56]`[58]``[78]#S[79]`[58]``[78]#I[79]``B`B[13]`T`[14]`[58]``[78]#T[79];``S``BS``B`BC``B`S``BC``S``BC``B`C[16]``B[13][14]``B`B[14][56]``B`B`B[13]``CB``B[14]`[56]`[58]``[78]#B[79]``B`B`B[12]``CB[14];``S``BS``B`BC``S``BS``B`BC``S``BS``B`BC``B`B`C[16]``B`B[13]``C``BC``SB`T`[14]`[58]``[78]#S[79]`[14]`[58]``[78]#I[79]``B`B`B[13]``BC``CB``B[14]`[56]`[58]``[78]#R[79]``B`B`B[13]``SB`T`[14]`[58]``[78]#S[79]``B`B`B[13]``SB`T`[14]`[58]``[78]#C[79];``S``BS``B`BC``S``BS``B`BC``B`S``BC``B`C[16][13]``B`B`B[12]``C``BC`BB[14]``B`B`B[13]``SB`T`[14]`[58]``[78]#B[79]`B`B[12];`[11]``S``BC``B`BS``S``BC``B`BS``S``BC``B`BS``B`C``BB[16][271]``BC[272]``BC[273]``BC[274];`[11]``S``BC``S``BC``C``BC``B`C``C[22][15]`B[12][14]``C``BC``B`RI``C``BC``C``BC`B[16]`[14]`[58]``[78]#I[79]``B[14]`[56]`[58]``[78]#K[79]`[275]`[14]`[58]``[78]#K[79]``S``BC``B`BB`B[275]I;``C``B`[81][125]`[270][79]``C``C``C``C``B[16][276][71][70]`K[71]`K[71];`[11]``B`B`C``C[80]``[82][125][79]``B`B`C``BB``B`[81][125]``B[277][106]``B`S``BB``BC``B`B`[81][125][269]``C``BC``B`BC``B`B`BB`B`B`[81][125]``B`B`[82][125]``C``BB[119]`[78]#;;``S[278]I;`[11]``B`S``BC``B`S``S[63]K``B`C``BB[126]`C`[157]`[117][88]``S``BS``B`BC``B`B`BB`B`B[60]I;``S``BC``B`B[119]``B[135]``B[108][280]I;`[11]``B`S``BC``B`C``C[63]`K[73]`[87]`[117][88]``S``BS``B`BC``B`B`BB`B`B[112]I;``S``BS``S``BS``B`S[63]``B`BK``B`B`[84][124]``B`B`[84][139][76]``S``BB``BC``C``BC``B`B[109]`C`[87]`[117][88]``[84][124][79]``B`B`[84][124]``B`B`[84][139][76]``B`BK``B`BK``S``BS``C``BC``B`B[109][282][71]``B`B`[84][124]``B`B`[84][139][76];`[11]``B`B`S``BS``C``BS``S``BB[63]``C``BC``B`BC``B`C``BC``C``BB[63]``C``BC``C``BC``B`B[109]`[87]`[117][88]``[84][124][79][71]`C[283]`K`K[71]`C[283]``B`B`C``BC``B`BB``B`BB``B`C``C[63]`K[71]`C[283]`S``BB``BC``B`BB`BC;`[11]``B`B`B`[120][71]``B`B`B`S``B`[85][123]`[10][281]``C``BC``B`BB``B`BS``C``BB``BB[284]`C[280]`C[280];`[11]``B`C``BS``B`BS``C``BS``B`BS``S``BB``BB[63]``B`B`BK``B`B[76][76]``S``BS``B`BC``B`S``BS``B`B[72]`C`[157]`[117][88]``S``BC``B`BS``C``BB``BB``BS``B`B[76]``B`C[76]``R(1)[90]`C``BC``B`B[78][76]``B`B[61]``B`C[119]``B`[78]#_``C[151][79]``BC``B`B[76]`C[76]``S``BC``B`BC``B`B`BC``B`B`B`BB``B`B`B`B[95]``B`B`B`B[104]``B`BCC``B`B`C``BB``B[95][104]``C``BC``B`BC``B`B`BB``B`B`BC``B`B`B`B[95]``B`B`B`B[104]`BC``B`C``BB``B[95][104]``BC``B`BC``B`B`B[76]``B`B[76][60];``C``BB[31]``C``BB``BB``B[95][104]``B`B`C``BB``B[95][104]``C``BB``BB``BC``B`BB``B`B[107]``B`B[107]``B`C``B[111]`[10][78][30]``BC[286];``C``BB[29]``C``BC``B`BB``B`B[95]``B`B[104]``B`[127][287]``C``B[76]`[76][79][79]``B`C``BB``B[95][104]``B`B`C``BB``B[107][28]``B`B`B[105]``BC[286];`[11]``B`B`B`B`S``B[95][104]``C``BC``B`BC``B`B`BC``B`B`B`BC``B`B`B`B`BC``B`B`B`B`B`BS``C``BC``B`BC``B`B`BC``B`B`B`BC``B`B`B`B`BC``B`B`B`B`B`BC``B`B`B`B`B`B`BC``S``BS``B`BS``B`B`BC``B`B`B`BC``B`B`B`B`BS``B`B`B`B`B`BS``B`B`B`B`B`B`BS``B`S``BS``B`BC``B`B`BC``B`B`B`BS``B`B`B`B`BS``B`B`B`B`B`BB``B`B`S``BS``B`BB``B`BB``S``BB[59]``B`BK``B[76]`[76]`[62]``[78]#I``[78]#n``[78]#t[79]``C``BC``B`BS``B`B`BB``B`B`BC``B`B`B`BC``B`B`B`B`BC``B`C``BB``BB``BB``BS``B`B[121]`C`[157]`[117][88]``C``BB``BB``BB``BC``B`B[95]``C``BC``B`B[121]`C`[157]`[117][88][94]``B`B`C``BC``B`B[95]``B`B[104]`C``B[288][105]``B`B`C``BB[29]``C``BB``BB``BC``B`BC``B`B`B[76]``B`B`C[76]``C``BB`[129][56]`[135][54][76]``B`C``B[111]`[98][76]`[98][76]``S``BS``B`BS``B`B`BC``B`B`B`BC``B`B`B`B`BB``B`B`B`B`BC``B`B`B`B`B`BB``B`B`B`B`B`B[95]``B`B`B`B`B`B[104]``C``BC``B`BC``B`B`BB``B`B`BB`B`BC``C``BB[76]``R(1)[90]``B`B`B`B`B`C``BB``B[95][104]``C``BC``B`BC``B`B`BB``B`B`BC``B`B`B`BC``B`B`B`B`BB``B`B`B`B`BB``B`B`B`B`B[95]`B`B`B`B[104]``B`B`B`C``BB``B[95][104]``S``BB``BC``B`BB``B`BB``B`BC``B`B`B[76]``C``BB``BB[76][56]``B`BC``B`B`B[107]``B`C``BB[285]`C[247]``B`B`B`B`B`S``BS``B`BB``B`B[107]``B`B`C``B[95][104]``C``BB``BC``B`BB``B`B[76][247][55]``C``BC``B`BC``B`B`BB``B`B`BB``B`B`BC``B`B`B`BC``B`B`B`B`BC``C``BC``B`BB``B`BB`BB`C``BC``B`B[78]`C[76]``C``BB[76]``R(1)[90]`K[94]``B[61]``B`[78]#_``C[151][79];``B`C[31]`C``BB[30];`[11]``B`C``BS``C``BS``C``BB[63]``C``BC``C``BC``C``BB[63]`C`[87]`[117][88]`K[73]`K`K[73]``C``BC``C``BB``C[63]`K[73]`C`[87]`[117][88]`K`K[73]``B`C``BB``BB``C``C[63]`K[73]`K[73]``S``BC``B`BB``B`BC``B`B`BB`B`B[113]I;`T[291];``C``BB[31]``C``BB``BB[31]``C``BB``BC``B`BB``B`B[113]`[87]`[117][88]`[87][292];`T[293];``B[290][280];``C``B[127]`[111][113][74];``C``B[127]``B`RI``B`BS``C``BS``B`BB`B[109][78][79];``BC``B`B[297]``C``BC``B`BC``C``BC``B`BC``B`B`B[121]``BC``B`B[132]``B[10][87][73]`[97][74];``C``BC``S``BS``B`B[109]``S``BS``B`B[95]``B`B[296]``C``BB``BS``B`B`[87][292]``C``BB[280][61]``C``BB[280][61]``C``BB``B`[298]`[117][88]`[135][105]`[135][105]``B`B`[95][70][119][71];`[11]``B`C``BS``C``BS``C``BB[63]``C``BC``C``BC``C``BB[63]``C``BC``C``BC``B`B[109]`[87]`[117][88]``[82][125][79][71]`K[71]`K`K[71]``B`B`[82][125]``C``BC``B`B[78]`C[76][79]``B`C``BB``BB``C``C[63]`K[71]`K[71]``S``BC``B`BB``B`BC``B`B`BB`B`B`[81][125]``C``BC``B`BC``B`B`BB`B`B`[81][125][299];``B`C[31]``BK[300];`[11]``B`C``RI``RI[63]``B`B`B[133]``B`B`B`[78]``[78]#([79]``S``BC``B`BB`B[78]``B`B`[78]``[78]# [79]``C``BC`B[78]``[78]``[78]#)[79][79];`T[302];``C[31]``C``BB[119]``C``B[119]``B`[78]# `[86][303]``[78]# ``[78]#=``[78]#>``[78]# [79];`[11]``B`B`S``BS``B`BC``B`B`C[80]``C``BB``B[95][104]``C``BC``B`BS``C``BC``B`BC``B`B`BS``B`B`B`B[76]``C``BC``B`BB``B`BC``B`B`B[76]``BC``B`B[78][76]``R(1)[90][57]``B`[78]#*``C[151][79]``B`B`B`B`C``BB[29]``C``BS``B`BS``B`B`BS``B`B`B`BC``B`B`B`B`BB``B`B`B`B`BS`B`B`S``BB``BC``B`B[72]`C[301]``B`B`BC``B`B`B`BC``C``BB``BB``BB``BC``B`B[129]``B`B`C``BB``B[95][104]``B`B`B`B`C``B[108][56]``C``BBB[295]``C``BB``BB[76]``B`B[57]``C``BB[31]``B`BK``B`B`[95][304]`C[30];`[11]``B`B`B`S``B[95][104]``B`B`B`B`BK``C``BC``B`BC``B`B`BS``B`B`B`BC``B`B`S``BB``BC``B`B[72]`[156]`[87][294]``B`B`S``BB[31]``B`B`B`B`BK``B`S``BB``BB``BC``C``BC``B`B[72]`C`[157]`[117][88][94]``B`BC`B[305]``C``BB[76][57];`[11]``C``BS``B`BS``B`B`BS``B`B`B`BC``S``BS``B`BS``B`B`BS``B`B`B`BC``B`B`B`S``BC``S``BS``B`S[59]``B`BK[76]``B`BK[76]``S``BS``B`BS``B`B`BB``B`B`BB``B`B`BC``B`B`B`B`C``B[95][104]``B`B`B`B`B`C``B[108][56]`B`BCI`B`B`B`C``BB``B[108][55]``B`BC``C``BB``BB[306][295];``B`C``BB``B[95][104]``C``BS``B`BB``B`BC``B`B`B[95]``B`B`B[104]``C``BC[307]``[76][79](0)``B`B`C``BB``B[95][104]``B`B`B`BK``C``BC``B`BB``B`BS``B`B`B[76]``B`B`C``B[28]`[135][105][280]`[127]``[111][55][106];`[11]``B`C``BS``B`B[95]``C``BB[115]`[76][79]``B`S``BC``B`BB``B`B[107]``B`B[78]``B`C[76]``B`[78]#*``C[151][79]``C``BB``BC`B[95]``R(1)[90];``B`B`B`C``B[95][104]``B`S``BB``BB``BC``B`B[95]``B`B[104]``C``BC``C[289][79]``[76]`[70][79](0)``B`C``BB``BC``B`BB``B`BB``C``BC``B`B[72]`C`[157]`[117][88][94]``B`B`B`C``BB``B[95][104]``B`B`B`B`C``BB``C[72][94]``B`B`B`C``BC``B`BB``B`B[95]``B`B[104]``B[288][105]``B`B`B`B`C``BB[29]``B`B`B`B`B`C``BB``C[80][94]``B`B`B`B`B`B`BK``B`C``BB``BB``BB``BB``BB[29]``B`B`B`B`B`C``BB``BB[31]``B`B`B`B`B`B`BK``B`B`B`B`B`B`C``BC``C``BC``B`B[72]`C[300][94]``B`B`B`C``BC``B`BC``B`B`BC``B`B`B`B[95]``B`B`B`B[104]`C``BC``B`BC``B`B`B[288]``B`C``BB``B[95][28]`C[280]``B`B`B`BK``B`B`B`C[29]``B`C``BB``BB``BB``B[95][104]``B`S``BB``BC``B`BC``B`B`BB``C``BC``B`BC``B`B`B[72]``BC``B`B[300][280][94]``B`B`B`B`B`[95][106]``B`B`BC``C``BC``B`BB``B`BC``C``BB``BB[307]`C[281]``R(0)[309];``S``B`[127][55]``B`[95]`[55]``[78]#*[79]``B`[95]``[129][56]`[57]``[78]#*[79]`[135][57]I;``B`B`C``B[95][104]``B`B`B`C``B[95][104]``B`B`B`S``BB[29]``C``BC``B`BB``B`BC``B`B`BC``B`B`B`BC``B`B`B`B`BB``B`B`B`B`B`S[76]``B`B`B`B`B`B`[95]`[76]``[95][258]`[62]``[78]#D``[78]#I``[78]#C``[78]#T[79]``B`B`B`B`B`C``B[95][232]``C``BC``B`BC``B`B`BC``B`B`B`BB``B`B`B`B`[127]``[111][55][106]``B`B`B`S``B`[129][56]``B`[95][311]`[135][105]``B`B`B[135][310]``B`[95][105]``R(0)[309]``B`B`[95][304][30];`[11]``B`B`C``BS``B`B[95]``C``BB[115]``B`[95][67][158]``S``BS``B`BS``B`B`BC``B`B`B`BS``B`B`B`C``BB[69]``B`B`B`B`C``B[95][104]``B`B`S``BB``BS``B`BC``B`B`B[95]``B`B`B[104]``C``BC``B`BC``C``BB``BB``C[289][79][232]``[76]`[70][79](0)``B`B`B`B`B`B`C``B[95][104]``B`B`B`B`B`B`BK``B`S``BB``BB``BS``B`BC``B`B`BC``C``BB``BC``B`BC``B`B`B[72]``B`B`[85][123][308]``B[68]`[119]``[78]#b``[78]#a``[78]#d``[78]# ``[78]#t``[78]#y``[78]#p``[78]#e``[78]#:``[78]# [79]``C``BC``B`BB``B`BC``B`B`BB`B`BB`C``BC``B`B[78][76]``C``BS``B`BB``B`BC`B`BB``RI``BS``B`BC``B`B`B[78][312];``RK[33];``B`S``B[76]`[136]``[111]`[78]#|[314]``C``BC``B`B[76]``B`B`[95][258]``C``BB``B[95][247]``[127]``[111][247]``C[33]`K``[127][247]`[61]``[78]#c``[78]#a``[78]#s``[78]#e[79]`[61]``[78]#c``[78]#a``[78]#s``[78]#e[79]``[95]`[55]``[78]#x[79]`[57]``[78]#x[79];``[111][106]``[129]``BK``C[104]``S``BB``B[76]`[78]#*[78]``[76]``[78]#*[79][79];``B`C``BS``B`B`[127][55]``B`[129]``C``BB[56][57][57]`C[119];``B`B`C[33]``B`B`S``BB[76]``C``BB``BB``BS``B`B[76]``B`B`[95][258]`[127][247]``C``BC``B`BB``B`B[95]``B[317]`[135][314][316];``S``BS``B`B[78][315]``RI``BS``B`B[135][318];[53];`[11]``B`B`C``BS``B`B[95]``C``BB[115]`[76][71]``B`S``BS``B`BS``B`B`BS``C``BB``BS``B`BB`B[109]``B`C``BB``B[76][70]`C[119]``C``BC``B`BB``B`BB`BC`C[78];``C``BS``B`BB``B`BC``B`B`B[95]``B`B`B[104]``C``BC``B`BC``B`B[321]``C``BC``B`B[111]``B[10][87][105][79]``C``BS``B`BC``B`B`BS``B`B`C``BB[72]``B`B[78]``C``BB[76]``C[78][79]``BC``B`B[78]``B[108][78];``B`B`[95]`[55]``[78]#*[79]``B`B`[95]`[56]`[57]``[78]#*[79]`C``B`[127]``[111][55]``[111]`[78]#*[105]``B`[95][57]`[78]#*;``[127]``B`C``B[95][320]``C``BS``B`BS``B`B`BS``C``BS``B`BS``B`B`BS``C``BS``B`BS``B`B`BS``C``BB``BB``BB[27]``C``BC``B`BB``B`BB``B`BB[52]`C``BC``B`B[119][319]``B`BC``C``BB``BB[52]`C``B[78][68]``C``BC``B`BB``B`BB``B`BB``B`BB[52]`C``BC``B`BC``B`B`B[119]``B`RI``B`BS``B`B`B[135]``B`B`B`C``B[95][104]``B`B`B`S``BB[76]``C``BC``B`BB``B`BB``B`BC``B`B`B[76]``B`B[28]``C``BC``B`B[78][30][79][323]``B`BC``B`B`BC``B`B`B`BC``C``BB``BS``B`BS``B`B`BB``B`B`B[52]`C``BC`[322]`[117][88]`C``BC``B`BC``B`B`B[78]``B`B`B[67]``C``BB``BB[76][76]```[52][79][79][267];``C``B[320][324][313];``C[29]``C``BB``B[119]`[136][304]`[86][303];`T[326];``C``C[43]`K``[78]#p``[78]#a``[78]#r``[78]#s``[78]#e``[78]# ``[78]#e``[78]#r``[78]#r``[78]#o``[78]#r[79]``BK``BK``C``RI``B[69][325]`[136]``C``B[95][104]``C``BB[119]``B`[119]``[78]# ``[78]#:``[78]#:``[78]# [79]``C``B[119]``B`[86][327][105]``[78]#
14 | [79];``C``C``B[40]`[168][266][328][328];``C``C[43]`K``[78]#p``[78]#a``[78]#r``[78]#s``[78]#e``[78]# ``[78]#e``[78]#r``[78]#r``[78]#o``[78]#r[79]``BK``BK``C``RI``B[69][325]``B`[126][94]``B`[95][279]`[135]`[108][106];``C``C``B[40]`[168][266][330][330];


--------------------------------------------------------------------------------
/classy.hs:
--------------------------------------------------------------------------------
   1 | ------------------------------------------------------------------------
   2 | -- A mini Haskell compiler with typeclasses.
   3 | -- Originally written by Ben Lynn, modified by Ben Siraphob
   4 | ------------------------------------------------------------------------
   5 | -- Delete code below and uncomment the block to compile in GHC
   6 | {-
   7 | {-# LANGUAGE FlexibleInstances #-}
   8 | {-# LANGUAGE OverlappingInstances #-}
   9 | {-# LANGUAGE TypeSynonymInstances #-}
  10 | {-# LANGUAGE CPP #-}
  11 | {-# LANGUAGE TupleSections #-}
  12 | {-# LANGUAGE NoMonomorphismRestriction #-}
  13 | module Compiler where
  14 | import Prelude (Char, Int, String, succ)
  15 | import Data.Char (chr, ord)
  16 | import qualified Prelude
  17 | a <= b = if a Prelude.<= b then True else False
  18 | (*) = (Prelude.*)
  19 | (+) = (Prelude.+)
  20 | (-) = (Prelude.-)
  21 | (/) = Prelude.div
  22 | (%) = Prelude.mod
  23 | class Eq a where { (==) :: a -> a -> Bool };
  24 | class Show a where { show :: a -> String };
  25 | class Functor f where { fmap :: (a -> b) -> f a -> f b };
  26 | class Applicative f where { pure :: a -> f a; (<*>) :: f (a -> b) -> f a -> f b };
  27 | class Monad m where { return :: a -> m a ; (>>=) :: m a -> (a -> m b) -> m b};
  28 | instance Eq Char where { (==) x y = if x Prelude.== y then True else False };
  29 | instance Eq Int where { (==) x y = if x Prelude.== y then True else False };
  30 | instance Show Char where { show = Prelude.show };
  31 | infixr 5 ++;
  32 | infixr 9 .;
  33 | infixl 4 <*> , <$> , <* , *>;
  34 | infixl 3 <|>, <||>;
  35 | infixr 0 $;
  36 | infixl 7 *;
  37 | infixl 6 + , -;
  38 | -}
  39 | infixr 5 :, ++;
  40 | infixr 9 .;
  41 | infixl 4 <*> , <$> , <* , *>;
  42 | infixl 3 <|>, <||>;
  43 | infixr 0 $;
  44 | infixl 7 *;
  45 | infixl 6 + , -;
  46 | (*) = (.*.);
  47 | (+) = (.+.);
  48 | (-) = (.-.);
  49 | (%) = (.%.);
  50 | (/) = (./.);
  51 | -- Delete code above and uncomment the block to compile in GHC
  52 | undefined = undefined;
  53 | ($) f = f;
  54 | id x = x;
  55 | const x y = x;
  56 | flip f x y = f y x;
  57 | (&) x f = f x;
  58 | (<$>) = fmap;
  59 | liftA2 f x = (<*>) (fmap f x);
  60 | (*>) = liftA2 $ \x y -> y;
  61 | (<*) = liftA2 const;
  62 | data Bool = True | False;
  63 | data Maybe a = Nothing | Just a;
  64 | data Either a b = Left a | Right b;
  65 | data Error a = Error String | Okay a;
  66 | -- fpair = flip curry
  67 | fpair p f = case p of { (,) x y -> f x y };
  68 | fst p = case p of { (,) x y -> x };
  69 | snd p = case p of { (,) x y -> y };
  70 | first f p = fpair p $ \x y -> (f x, y);
  71 | second f p = fpair p $ \x y -> (x, f y);
  72 | ife a b c = case a of { True -> b ; False -> c };
  73 | not a = case a of { True -> False; False -> True };
  74 | (.) f g x = f (g x);
  75 | (||) f g = ife f True (ife g True False);
  76 | (&&) f g = ife f (ife g True False) False;
  77 | (<) a b = not (a == b) && (a <= b);
  78 | -- fold a list
  79 | -- flist :: [a] -> b -> (a -> [a] -> b) -> b
  80 | flst xs n c = case xs of { [] -> n; (:) h t -> c h t };
  81 | -- (==) on lists
  82 | lstEq xs ys = case xs of
  83 |   { []       -> flst ys True (\h t -> False)
  84 |   ; (:) x xt -> flst ys False (\y yt -> ife (x == y) (lstEq xt yt) False)
  85 |   };
  86 | instance Eq a => Eq [a] where { (==) = lstEq };
  87 | (/=) x y = not (x == y);
  88 | -- Append two lists
  89 | (++) xs ys = flst xs ys (\x xt -> x:xt ++ ys);
  90 | -- maybe :: b -> (a -> b) -> Maybe a -> b
  91 | maybe n j m = case m of { Nothing -> n; Just x -> j x };
  92 | -- fold a maybe
  93 | -- fmaybe :: Maybe a -> b -> (a -> b) -> b
  94 | fmaybe m n j = case m of { Nothing -> n; Just x -> j x };
  95 | instance Show a => Show (Maybe a) where
  96 |   { show = maybe "Nothing" (\x -> "Just " ++ show x) };
  97 | instance Functor Maybe where
  98 |   { fmap f = maybe Nothing (Just . f) };
  99 | instance Applicative Maybe where
 100 |   { pure = Just ; (<*>) f y = maybe Nothing (`fmap` y) f};
 101 | instance Monad Maybe where
 102 |   { return = Just ; (>>=) ma f = maybe Nothing f ma };
 103 | fromMaybe a m = fmaybe m a id;
 104 | foldr c n l = flst l n (\h t -> c h (foldr c n t));
 105 | -- TODO: foldr1 should have type 
 106 | -- foldr1 :: Monoid a => (a -> a -> a) -> [a] -> a
 107 | -- Later, when we add foldables and traversables, it should be
 108 | -- foldr1 :: (Monoid m, Foldable t) => (m -> m -> m) -> t m -> m
 109 | -- foldr1' :: (a -> a -> a) -> [a] -> Maybe a
 110 | foldr1' c l =
 111 |     flst
 112 |        l
 113 |        Nothing
 114 |        (\h t ->
 115 |           foldr
 116 |             (\x m -> Just (fmaybe m x (c x)))
 117 |             Nothing
 118 |             l);
 119 | 
 120 | foldl f a bs = foldr (\b g x -> g (f x b)) id bs a;
 121 | -- foldl1' :: (p -> p -> p) -> [p] -> Maybe p
 122 | -- See above comments on the status of foldr1'
 123 | foldl1' f l = flst l Nothing (\x xs -> Just (foldl f x xs));
 124 | elem k = foldr (\x t -> ife (x == k) True t) False;
 125 | find f = foldr (\x t -> ife (f x) (Just x) t) Nothing;
 126 | concat = foldr (++) [];
 127 | itemize c = [c];
 128 | map f = foldr (\x xs -> f x : xs) [];
 129 | concatMap f l = concat (map f l);
 130 | instance Functor [] where { fmap = map };
 131 | instance Monad [] where { return = itemize ; (>>=) = flip concatMap };
 132 | instance Applicative [] where
 133 |   { pure = itemize
 134 |   ; (<*>) fs xs = fs >>= \f -> xs >>= \x -> return $ f x};
 135 | prependToAll s l = flst l [] (\x xs -> s : x : prependToAll s xs);
 136 | intersperse s l = flst l [] (\x xs -> x : prependToAll s xs);
 137 | 
 138 | -- Show a non-empty list
 139 | intercalate d = concat . intersperse d;
 140 | unwords = intercalate " ";
 141 | showList' l = "[" ++ intercalate "," (map show l) ++ "]";
 142 | showList l = case l of {
 143 |                []       -> "[]";
 144 |                (:) x xs -> showList' l
 145 | };
 146 | 
 147 | mapconcat f l = concat (map f l);
 148 | escapeC c = ife (c == '\n') "\\n"
 149 |             (ife (c == '\\') "\\\\"
 150 |              [c]);
 151 | showString s = "\"" ++ mapconcat escapeC s ++ "\"";
 152 | 
 153 | ifz n = ife (0 == n);
 154 | showInt' n = ifz n id (showInt' (n/10) . (:) (chr (48+(n%10))));
 155 | showInt n = ifz n ('0':) (showInt' n);
 156 | 
 157 | -- N.B. using show on Ints will make GHC fail to compile to due GHC
 158 | -- having multiple numeric types.
 159 | instance Show Int where { show n = showInt n "" };
 160 | 
 161 | instance Show String where { show = showString };
 162 | instance Show a => Show [a] where { show = showList };
 163 | 
 164 | any f = foldr (\x t -> ife (f x) True t) False;
 165 | -- lookupWith :: (a -> b -> Bool) -> a -> [(b, a)] -> Maybe a
 166 | lookupWith eq s =
 167 |   foldr (\h t -> fpair h (\k v -> ife (eq s k) (Just v) t)) Nothing;
 168 | 
 169 | lstLookup = lookupWith (==);
 170 | 
 171 | reverse = foldl (flip (:)) [];
 172 | zipWith f xs ys =
 173 |   case xs of
 174 |   { [] -> []
 175 |   ; (:) x xt ->
 176 |     case ys of
 177 |     { [] -> []
 178 |     ; (:) y yt -> f x y : zipWith f xt yt
 179 |     }
 180 |   };
 181 | zip = zipWith (,);
 182 | 
 183 | -- Representation of types
 184 | --          type ctor.  type var.  type app.
 185 | data Type = TC String | TV String | TAp Type Type;
 186 | -- Representation of AST
 187 | data Ast
 188 |   = R String     -- raw combinator assembly
 189 |   | V String     -- variable
 190 |   | A Ast Ast    -- application
 191 |   | L String Ast -- lambda abstraction
 192 |   | Proof Pred;  -- proof for typeclass instantiation?
 193 | 
 194 | --  * instance environment
 195 | --  * definitions, including those of instances
 196 | --  * Typed ASTs, ready for compilation, including ADTs and methods,
 197 | --    e.g. (==), (Eq a => a -> a -> Bool, select-==)
 198 | data Neat =
 199 |   Neat
 200 |     [(String, [Qual])]
 201 |     [Either (String, Ast) (String, (Qual, [(String, Ast)]))]
 202 |     [(String, (Qual, Ast))];
 203 | 
 204 | -- Parser combinators (applicative style)
 205 | -- From the paper "Parsec: A practical parsing library"
 206 | -- Written in a contrived way for use with mini-Haskell (e.g. no
 207 | -- nested pattern matching)
 208 | 
 209 | -- Position is a line, column
 210 | data Pos = Pos Int Int;
 211 | 
 212 | data State = State String Pos;
 213 | data Parsec a = Parsec (State -> Consumed a);
 214 | data Msg = Msg Pos String [String];
 215 | 
 216 | data Reply a = Err Msg
 217 |              | Ok a State Msg;
 218 | 
 219 | data Consumed a = Empty    (Reply a)
 220 |                 | Consumed (Reply a);
 221 | 
 222 | parens s = '(':(s ++ ")");
 223 | showPos p = case p of { Pos r c -> unwords ["row:" , show r
 224 |                                            , "col: " , show c]};
 225 | instance Show Pos where { show = showPos };
 226 | showState s = case s of { State s p -> unwords [show s, parens (show p)]};
 227 | instance Show State where { show = showState };
 228 | -- showMsg m = case m of { Msg pos s1 s2 ->
 229 | --                          unwords ["Msg", show pos, show s1, show s2]};
 230 | 
 231 | -- instance Show Msg where
 232 | --   { show = showMsg };
 233 | 
 234 | -- showReply r = case r of { Err m -> unwords ["Err", show m]
 235 | --                         ; Ok a s m -> unwords ["Ok", show a, show s, show m]};
 236 | -- instance Show a => Show (Reply a) where { show = showReply };
 237 | -- showConsumed c = case c of { Empty m    -> unwords ["Empty", show m]
 238 | --                            ; Consumed m -> unwords ["Consumed", show m] };
 239 | -- instance Show a => Show (Consumed a) where
 240 | --   { show = showConsumed };
 241 | -- fromString :: String -> State
 242 | fromString s = State s (Pos 1 1);
 243 | -- parsec :: Parsec a -> State -> Consumed a
 244 | parsec p = case p of { Parsec f -> f };
 245 | -- parse :: Parsec a -> String -> Consumed a
 246 | parse p s = parsec p (fromString s);
 247 | -- bind :: Parsec a -> (a -> Parsec b) -> Parsec b
 248 | bind p f = Parsec $
 249 |            \state -> case parsec p state of
 250 |                        { Empty m ->
 251 |                          case m of
 252 |                            { Err msg         -> Empty (Err msg)
 253 |                            ; Ok x state' msg -> parsec (f x) state' }
 254 |                        ; Consumed m ->
 255 |                          Consumed
 256 |                          (case m of
 257 |                          { Err msg -> Err msg
 258 |                          ; Ok x state' msg ->
 259 |                            case parsec (f x) state' of
 260 |                              { Empty m    -> m
 261 |                              ; Consumed m -> m}})};
 262 | -- parsecpure :: a -> Parsec a
 263 | parsecpure x = Parsec $ \state ->
 264 |                 case state of
 265 |                 { State s pos -> Empty (Ok x state (Msg pos [] [])) };
 266 | 
 267 | instance Monad Parsec where
 268 |   { return = parsecpure
 269 |   ; (>>=) = bind };
 270 | instance Functor Parsec where
 271 |   { fmap f x = x >>= \x -> parsecpure (f x) };
 272 | instance Applicative Parsec where
 273 |   { pure = parsecpure
 274 |   ; (<*>) x y = x >>= \f -> y >>= \x -> parsecpure (f x) };
 275 | 
 276 | -- nextPos :: Pos -> Char -> Pos
 277 | nextPos p c = case p of
 278 |   { Pos line col ->
 279 |     ife (c == '\n') (Pos (line + 1) 0) (Pos line (col + 1))};
 280 | 
 281 | -- sat :: (Char -> Bool) -> Parsec Char
 282 | sat test = Parsec $ \state ->
 283 |                           case state of
 284 |                           { State input pos ->
 285 |                               case input of
 286 |                               { [] -> Empty (Err (Msg pos "end of input" []))
 287 |                               ; (:) c cs ->
 288 |                                   ife (test c)
 289 |                                   (let { newPos = nextPos pos c
 290 |                                        ; newState = State cs newPos }
 291 |                                     in Consumed (Ok c newState
 292 |                                                   (Msg pos [] [])))
 293 |                                   (Empty (Err (Msg pos [c] [])))}};
 294 | 
 295 | 
 296 | mergeMsg m1 m2 = case m1 of
 297 |               { Msg pos inp exp1 ->
 298 |                   case m2 of
 299 |                     { Msg _ _ exp2 -> Msg pos inp (exp1 ++ exp2)}};
 300 | 
 301 | mergeOk x inp msg1 msg2 = Empty (Ok x inp (mergeMsg msg1 msg2));
 302 | 
 303 | mergeError msg1 msg2 = Empty (Err (mergeMsg msg1 msg2));
 304 | 
 305 | -- (<|>) :: Parsec a -> Parsec a -> Parsec a
 306 | 
 307 | -- Given two parsers p, q, run p on the input. If it fails, then
 308 | -- continue by running q. The input is not backtracked before running
 309 | -- q.
 310 | -- p <|> q ::= <p> | <q>
 311 | (<|>) p q = Parsec $
 312 |             \state ->
 313 |               case parsec p state of
 314 |               { Empty m ->
 315 |                   case m of
 316 |                   { Err msg1 ->
 317 |                       case parsec q state of
 318 |                       { Empty m ->
 319 |                         case m of
 320 |                         { Err msg2 ->
 321 |                           mergeError msg1 msg2
 322 |                         ; Ok x inp msg2 ->
 323 |                           mergeOk x inp msg1 msg2 }
 324 |                       ; Consumed m -> Consumed m }
 325 |                   ; Ok x inp msg1 ->
 326 |                     case parsec q state of
 327 |                       { Empty m ->
 328 |                         case m of
 329 |                           { Err msg2 ->
 330 |                             mergeOk x inp msg1 msg2
 331 |                           ; Ok _ _ msg2 ->
 332 |                             mergeOk x inp msg1 msg2 }
 333 |                       ; Consumed m -> Consumed m }}
 334 |               ; Consumed m -> Consumed m };
 335 | 
 336 | -- Run parser p, if it consumed input and failed, pretend like it
 337 | -- didn't consume anything.
 338 | try p = Parsec $ \state -> case parsec p state of
 339 |                              { Empty m -> Empty m
 340 |                              ; Consumed m ->
 341 |                                case m of
 342 |                                  { Err msg ->
 343 |                                      Empty (Err msg)
 344 |                                  ; Ok x st msg ->
 345 |                                      Consumed (Ok x st msg)}};
 346 | 
 347 | (<||>) p q = try p <|> q;
 348 | -- many p ::= <p>*
 349 | many p = liftA2 (:) p (many p) <||> pure [];
 350 | -- many1 p ::= <p>+
 351 | many1 p = liftA2 (:) p (many p);
 352 | expect m exp = case m of { Msg pos inp _ -> Msg pos inp [exp] };
 353 | 
 354 | -- (<?>) :: Parsec a -> String -> Parsec a
 355 | (<?>) p exp = Parsec $ \state ->
 356 |                          case parsec p state of
 357 |                            { Empty m ->
 358 |                                Empty
 359 |                                (case m of
 360 |                                    { Err msg ->
 361 |                                        Err (expect msg exp)
 362 |                                    ; Ok x st msg ->
 363 |                                        Ok x st (expect msg exp)})
 364 |                            ; Consumed m -> Consumed m };
 365 | item = sat (const True);
 366 | -- sepBy1 p sep ::= <p> (<sep> <p>)*
 367 | sepBy1 p sep = liftA2 (:) p (many (sep *> p));
 368 | sepBy p sep = sepBy1 p sep <||> pure [];
 369 | char c = sat (== c) <?> show c;
 370 | string s =
 371 |   case s of
 372 |   { []       -> pure []
 373 |   ; (:) c cs -> char c *> string cs *> pure s};
 374 | 
 375 | -- between x y p ::=  <x> <p> <y>
 376 | between x y p = x *> (p <* y);
 377 | -- Parse line comments
 378 | -- com ::= '-' '-' <char c: c != '\n'>* '\n'
 379 | com = char '-' *> between (char '-') (char '\n') (many (sat (/= '\n')));
 380 | -- Block comments
 381 | -- notComEnd ::= <char c: c != '-'> | '-' <char c: c != '}'>
 382 | notComEnd = (sat (/= '-') <|> (char '-' *> sat (/= '}'))) *> pure [];
 383 | -- blockcom ::= "{-" (<blockcom> | <notComEnd>) "-}"
 384 | blockcom = let { content = many (blockcom <||> notComEnd) }
 385 |            in between (string "{-") (string "-}") content *> pure [];
 386 | -- Parse whitespace
 387 | sp =
 388 |   many
 389 |     ((pure <$> sat (\c -> (c == ' ') || (c == '\n'))) <|> com <|> blockcom);
 390 | -- Tokenize a parser, producing a parser that consumes trailing
 391 | -- whitespace.
 392 | -- tok p ::= <p> <sp>
 393 | tok p = p <* sp;
 394 | -- Parse a character (tokenized)
 395 | tokc = tok . char;
 396 | -- wantWith :: (a -> Bool) -> String -> Parser a -> Parser a
 397 | -- TODO: Consider backtracking the input on failure (similar to sat)?
 398 | wantWith pred str p = Parsec $ \s ->
 399 |                   case parsec p s of
 400 |                   { Empty m ->
 401 |                     Empty (case m of
 402 |                       { Err m -> Err m
 403 |                       ; Ok a state' m -> ife (pred a)
 404 |                                          (Ok a state' m)
 405 |                                          (Err (expect m str)) })
 406 |                   ; Consumed m ->
 407 |                     Consumed (case m of
 408 |                                 { Err m -> Err m
 409 |                                 ; Ok a state' m ->
 410 |                                     ife (pred a)
 411 |                                         (Ok a state' m)
 412 |                                         (Err (expect m str))})
 413 |                   };
 414 | -- want :: Eq a => Parser a -> a -> Parser a
 415 | want f s = wantWith (== s) s f;
 416 | -- paren a ::= '(' <a> ')'
 417 | paren = between (tokc '(') (tokc ')');
 418 | -- lower ::= 'a' | 'b' | 'c' ... 'z' | '_'
 419 | lower = sat (\x -> ((x <= 'z') && ('a' <= x)) || (x == '_')) <?> "lower";
 420 | -- upper ::= 'A' | 'B' | 'C' ... 'Z'
 421 | upper = sat (\x -> (x <= 'Z') && ('A' <= x)) <?> "upper";
 422 | -- digit ::= '0' | '1' | '2' ... '9'
 423 | digit = sat (\x -> (x <= '9') && ('0' <= x)) <?> "digit";
 424 | -- alpha ::= <lower> | <upper>
 425 | alpha = (lower <|> upper) <?> "alpha";
 426 | -- varLex ::= <lower> (<alpha> | <digit> | '\'')*
 427 | varLex = liftA2 (:) lower (many (alpha <|> digit <|> char '\''));
 428 | -- Constructor identifier
 429 | conId = tok (liftA2 (:) upper (many (alpha <|> digit <|> char '\'')));
 430 | keyword s = tok (want varLex s);
 431 | varId = tok (wantWith (\s -> not ((s == "of") || (s == "where"))) "variable" varLex);
 432 | -- Operator characters
 433 | opLex = many1 (sat (`elem` ":!#$%&*+./<=>?@\\^|-~"));
 434 | -- Operators
 435 | op = tok opLex <|> between (tokc '`') (tokc '`') varId;
 436 | var = varId <|> paren (tok opLex);
 437 | anyOne = pure <$> tok (sat (const True));
 438 | -- Lambda
 439 | -- lam r ::= '\\' <varId>+ "->" <r>
 440 | lam r =
 441 |   tokc '\\' *>
 442 |   liftA2 (flip (foldr L)) (many1 varId) (char '-' *> (tokc '>' *> r));
 443 | 
 444 | listify = fmap (foldr (\h t -> A (A (V ":") h) t) (V "[]"));
 445 | -- Escape characters
 446 | escChar = char '\\' *> (sat (`elem` "'\"\\") <|> (const '\n' <$> char 'n'));
 447 | litOne delim = (\c -> R ('#' : pure c)) <$> (escChar <||> sat (/= delim));
 448 | -- Integer literals
 449 | litInt = R . ('(' :) . (++ ")") <$> tok (many1 digit);
 450 | -- String literals
 451 | -- Notice that we do not consume whitespace after parsing the first ",
 452 | -- hence the use of char.
 453 | litStr = listify (between (char '"') (tokc '"') (many (litOne '"')));
 454 | -- Character literals
 455 | litChar = between (char '\'') (tokc '\'') (litOne '\'');
 456 | lit = litStr <|> litChar <|> litInt;
 457 | -- sqLst r ::= '[' <sepBy r ','> ']'
 458 | sqLst r = listify (between (tokc '[') (tokc ']') (sepBy r (tokc ',')));
 459 | -- alt r ::= ((<conId> | '(' (':' | ',') ')') | "[]") <varId>* "->" r
 460 | alt r =
 461 |   (,) <$>
 462 |   (conId <||> (pure <$> paren (tokc ':' <|> tokc ',')) <||>
 463 |    liftA2 (:) (tokc '[') (pure <$> tokc ']')) <*>
 464 |   liftA2 (flip (foldr L)) (many varId) (char '-' *> (tokc '>' *> r));
 465 | -- braceSep f ::= '{' <sepBy f ';'> '}'
 466 | braceSep f = between (tokc '{') (tokc '}') (sepBy f (tokc ';'));
 467 | -- alts r ::= <braceSep <alt r>>
 468 | alts r = braceSep (alt r);
 469 | cas' x as = foldl A (V (concatMap (('|' :) . fst) as)) (x : map snd as);
 470 | -- Case expressions
 471 | -- cas r ::= "case" r "of" <alts r>
 472 | cas r = liftA2 cas' (between (keyword "case") (keyword "of") r) (alts r);
 473 | -- thenComma r ::= ',' <r>
 474 | thenComma r =
 475 |   tokc ',' *> (((\x y -> A (A (V ",") y) x) <$> r) <||> pure (A (V ",")));
 476 | -- parenExpr r ::= <r> (<op> | <thenComma r>)
 477 | parenExpr r =
 478 |   liftA2
 479 |     (&)
 480 |     r
 481 |     (((\v a -> A (V v) a) <$> op) <||> thenComma r <||> pure id);
 482 | 
 483 | -- rightSect r ::= (<op> | ',') <r>
 484 | rightSect r =
 485 |   ((\v a -> A (A (V "\\C") (V v)) a) <$> (op <|> (pure <$> tokc ','))) <*> r;
 486 | 
 487 | -- Sections
 488 | -- section ::= '(' (<parenExpr r> | <rightSect r>) ')'
 489 | section r = paren (parenExpr r <|> rightSect r);
 490 | 
 491 | -- isFree :: String -> Ast -> Bool
 492 | -- Checks if a string v occurs free in expr.
 493 | isFree v expr = case expr of
 494 |   { R s     -> False
 495 |   ; V s     -> s == v
 496 |   ; A x y   -> isFree v x || isFree v y
 497 |   ; L w t   -> (v /= w) && isFree v t
 498 |   ; Proof _ -> False
 499 |   };
 500 | 
 501 | maybeFix s x = ife (isFree s x) (A (V "\\Y") (L s x)) x;
 502 | 
 503 | -- Definitions
 504 | -- def r ::= <var> <varId>* '=' <r>
 505 | def r =
 506 |   liftA2 (,) var (flip (foldr L) <$> many varId <*> (tokc '=' *> r));
 507 | 
 508 | -- Convert a list of let bindings and the let body into a single AST.
 509 | addLets ls x =
 510 |   foldr (\p t -> fpair p (\name def -> A (L name t) $ maybeFix name def)) x ls;
 511 | 
 512 | -- let r ::= "let" '{' <sepBy def r> '}' "in" <r>
 513 | letin r =
 514 |   liftA2
 515 |     addLets
 516 |     (between (keyword "let") (keyword "in") (braceSep (def r)))
 517 |     r;
 518 | -- atom r ::= <letin r> | <sqLst r> | <cas r> | <lam r> | <section r>
 519 | --          | '(' ',' ')' | (<conId> | <var>) | <lit>
 520 | atom r =
 521 |   letin r                             <|>
 522 |   sqLst r                             <||>
 523 |   cas r                               <|>
 524 |   lam r                               <||>
 525 |   section r                           <||>
 526 |   (paren (tokc ',') *> pure (V ","))  <||>
 527 |   (V <$> (conId <|> var))             <||>
 528 |   lit;
 529 | 
 530 | aexp r = fromMaybe undefined . foldl1' A <$> many1 (atom r);
 531 | fix f = f (fix f);
 532 | 
 533 | -- Parse infix operators
 534 | --            infix   infixl   infixr
 535 | data Assoc = NAssoc | LAssoc | RAssoc;
 536 | 
 537 | instance Show Assoc where
 538 |   { show a =
 539 |      case a of
 540 |      { NAssoc -> "NAssoc"
 541 |      ; LAssoc -> "LAssoc"
 542 |      ; RAssoc -> "RAssoc" } };
 543 | 
 544 | eqAssoc x y = case x of
 545 |   { NAssoc -> case y of { NAssoc -> True  ; LAssoc -> False ; RAssoc -> False }
 546 |   ; LAssoc -> case y of { NAssoc -> False ; LAssoc -> True  ; RAssoc -> False }
 547 |   ; RAssoc -> case y of { NAssoc -> False ; LAssoc -> False ; RAssoc -> True }
 548 |   };
 549 | instance Eq Assoc where { (==) = eqAssoc };
 550 | 
 551 | precOf s precTab = fmaybe (lstLookup s precTab) 5 fst;
 552 | assocOf s precTab = fmaybe (lstLookup s precTab) LAssoc snd;
 553 | opWithPrec precTab n = wantWith (\s -> n == precOf s precTab) "precTab" op;
 554 | -- opFold'
 555 | --   :: [(String, (a, Assoc))] -> Ast -> [(String, Ast)] -> Maybe Ast
 556 | opFold' precTab e xs =
 557 |   case xs of
 558 |   { [] -> Just e
 559 |   ; (:) x xt ->
 560 |       case find
 561 |              (\y ->
 562 |                 not (assocOf (fst x) precTab == assocOf (fst y) precTab))
 563 |              xt of
 564 |       { Nothing ->
 565 |           case assocOf (fst x) precTab of
 566 |           { NAssoc ->
 567 |               case xt of
 568 |               {  []       -> Just $ fpair x (\op y -> A (A (V op) e) y)
 569 |               ;  (:) y yt -> Nothing }
 570 |           ; LAssoc -> Just $ foldl (\a b -> fpair b (\op y -> A (A (V op) a) y)) e xs
 571 |           ; RAssoc ->
 572 |               Just $ foldr (\a b -> fpair a (\op y e -> A (A (V op) e) (b y))) id xs e }
 573 |       ; Just y -> Nothing }};
 574 | 
 575 | expr precTab =
 576 |   fix $ \r n ->
 577 |     ife
 578 |       (n <= 9)
 579 |       ((fromMaybe undefined .) . opFold' precTab <$> r (succ n) <*>
 580 |        many (liftA2 (,) (opWithPrec precTab n) (r (succ n))))
 581 |       (aexp (r 0));
 582 | 
 583 | data Constr = Constr String [Type];
 584 | data Pred = Pred String Type;
 585 | data Qual = Qual [Pred] Type;
 586 | 
 587 | data Top = Adt Type [Constr]
 588 |          | Def (String, Ast)
 589 |          | Class String Type [(String, Type)]
 590 |          | Inst String Qual [(String, Ast)];
 591 | 
 592 | -- arrow type constructor
 593 | arr a = TAp (TAp (TC "->") a);
 594 | -- Parse type applications
 595 | bType r = fromMaybe undefined . foldl1' TAp <$> many1 r;
 596 | 
 597 | -- Parse types
 598 | _type r = fromMaybe undefined . foldr1' arr <$> sepBy (bType r) (tok (want opLex "->"));
 599 | typeConstant =
 600 |   (\s -> ife (s == "String") (TAp (TC "[]") (TC "Int")) (TC s)) <$> conId;
 601 | 
 602 | aType =
 603 |   paren
 604 |     (liftA2
 605 |        (&)
 606 |        (_type aType)
 607 |        ((tokc ',' *> ((\a b -> TAp (TAp (TC ",") b) a) <$> _type aType)) <||>
 608 |         pure id)) <||>
 609 |   typeConstant <||>
 610 |   (TV <$> varId) <||>
 611 |   (tokc '[' *>
 612 |    (tokc ']' *> pure (TC "[]") <||>
 613 |     TAp (TC "[]") <$> (_type aType <* tokc ']')));
 614 | 
 615 | simpleType c vs = foldl TAp (TC c) (map TV vs);
 616 | -- Data declarations
 617 | -- TODO: Add type, newtype declarations, deriving?
 618 | -- adt ::= "data" '=' <conId> <varId>* <sepBy (<conId> | <aType>*) '|'>
 619 | adt =
 620 |   liftA2
 621 |     Adt
 622 |     (between (keyword "data") (tokc '=') (liftA2 simpleType conId (many varId)))
 623 |     (sepBy (liftA2 Constr conId (many aType)) (tokc '|'));
 624 | 
 625 | -- Precedence
 626 | -- prec ::= <digit> <sp>
 627 | prec = (\c -> ord c - ord '0') <$> tok digit;
 628 | fixityList a n = fmap (, (n, a));
 629 | -- Fixity declaration
 630 | -- fixityDecl "kw" a ::= "kw" <prec> <sepBy <op> ','> ';'
 631 | fixityDecl kw a =
 632 |   between
 633 |     (keyword kw)
 634 |     (tokc ';')
 635 |     (liftA2 (fixityList a) prec (sepBy op (tokc ',')));
 636 | 
 637 | fixity =
 638 |   fixityDecl "infixl" LAssoc <||>
 639 |   fixityDecl "infixr" RAssoc <||>
 640 |   fixityDecl "infix" NAssoc;
 641 | 
 642 | noQual = Qual [];
 643 | -- genDecl ::= "::" <_type aType>
 644 | genDecl = liftA2 (,) var (char ':' *> tokc ':' *> _type aType);
 645 | 
 646 | -- Class declarations
 647 | -- classDecl ::= "class" <conId> <varId> "where" <braceSep genDecl>
 648 | classDecl =
 649 |   keyword "class" *>
 650 |   (Class <$> conId <*> (TV <$> varId) <*> (keyword "where" *> braceSep genDecl));
 651 | 
 652 | -- inst ::= <_type aType>
 653 | inst = _type aType;
 654 | 
 655 | -- Instance declarations
 656 | -- instDecl r ::= "instance" (<conId> <inst> "=>")? <conId> <inst>
 657 | --                "where" <braceSep <def r>>
 658 | instDecl r =
 659 |   keyword "instance" *>
 660 |   ((\ps cl ty defs -> Inst cl (Qual ps ty) defs) <$>
 661 |    (liftA2 ((pure .) . Pred) conId (inst <* (char '=' *> tokc '>')) <||>
 662 |     pure []) <*>
 663 |    conId <*>
 664 |    inst <*>
 665 |    (keyword "where" *> braceSep (def r)));
 666 | 
 667 | -- Top level declarations
 668 | -- tops ::= <sepBy (<adt> | <def> | <classDecl> | <instDecl>) ';'>
 669 | tops precTab =
 670 |   sepBy
 671 |     (adt <||> Def <$> def (expr precTab 0) <||> classDecl <||>
 672 |      instDecl (expr precTab 0))
 673 |     (tokc ';');
 674 | 
 675 | -- A program consists of whitespace, followed by fixity declarations,
 676 | -- then top level declarations
 677 | -- program' ::= <sp> <fixity>* <tops>
 678 | program' = sp *> (concat <$> many fixity) >>= tops;
 679 | 
 680 | eqPre = case parse program' $
 681 |   "class Eq a where { (==) :: a -> a -> Bool };\n" ++
 682 |   "class Show a where { show :: a -> String };\n" ++
 683 |   "class Functor f where { fmap :: (a -> b) -> f a -> f b };\n" ++
 684 |   "class Applicative f where { pure :: a -> f a; (<*>) :: f (a -> b) -> f a -> f b };\n" ++
 685 |   "class Monad m where { return :: a -> m a ; (>>=) :: m a -> (a -> m b) -> m b};\n" ++
 686 |   "instance Eq Int where { (==) = intEq };\n" of
 687 |   { Empty m ->
 688 |     case m of
 689 |       -- TODO: replace with show msg
 690 |       { Err msg  -> undefined
 691 |       ; Ok l _ _ -> l}
 692 |   ; Consumed m ->
 693 |     case m of
 694 |       -- TODO: replace with show msg
 695 |       { Err msg  -> undefined
 696 |       ; Ok l _ _ -> l}
 697 |   };
 698 | program =
 699 |   ((eqPre ++
 700 |       -- data [] a = [] | (:) a ([] a)
 701 |     [ Adt
 702 |         (TAp (TC "[]") (TV "a"))
 703 |         [Constr "[]" [], Constr ":" [TV "a", TAp (TC "[]") (TV "a")]]
 704 |     -- data (,) a b = (,) a b
 705 |     , Adt (TAp (TAp (TC ",") (TV "a")) (TV "b")) [Constr "," [TV "a", TV "b"]]
 706 |     ]) ++) <$>
 707 |   program';
 708 | 
 709 | 
 710 | -- Primitives
 711 | -- prims :: [(String, (Qual, Ast))]
 712 | prims =
 713 |   let { ii = arr (TC "Int") (TC "Int")
 714 |       ; iii = arr (TC "Int") ii
 715 |       ; bin s = R $ "``BT`T" ++ s }
 716 |    in map (second (first noQual)) $
 717 |       [ ("\\Y", (arr (arr (TV "a") (TV "a")) (TV "a"), R "Y"))
 718 |       , ( "\\C"
 719 |         , ( arr
 720 |               (arr (TV "a") (arr (TV "b") (TV "c")))
 721 |               (arr (TV "b") (arr (TV "a") (TV "c")))
 722 |           , R "C"))
 723 |       , ("intEq", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin "="))
 724 |       , ("<=", (arr (TC "Int") (arr (TC "Int") (TC "Bool")), bin "L"))
 725 |       , ("chr", (ii, R "I"))
 726 |       , ("ord", (ii, R "I"))
 727 |       , ("succ", (ii, R "`T`(1)+"))
 728 |       ] ++
 729 |       map (\s -> ('.':s ++ ".", (iii, bin s))) ["+", "-", "*", "/", "%"];
 730 | 
 731 | -- Total variant
 732 | rank ds v =
 733 |   let { loop l v c =
 734 |          case l of
 735 |          { [] -> Nothing
 736 |          ; (:) x xs ->
 737 |             ife (v == fst x) (Just ('[' : showInt c "]")) (loop xs v (succ c)) } }
 738 |    in loop ds v 0;
 739 | 
 740 | -- showC :: [(String, b)] -> Ast -> String
 741 | -- Total version of showC
 742 | showC ds t = case t of
 743 |   { R s     -> Just s
 744 |   ; V v     -> rank ds v
 745 |   ; A x y   -> liftA2 (\a b -> '`':a ++ b) (showC ds x) (showC ds y)
 746 |   ; L w t   -> Nothing
 747 |   ; Proof _ -> Nothing
 748 |   };
 749 | 
 750 | -- De Bruijn encoding of lambda calculus terms
 751 | --        z    s       lift ast   abs.   app.
 752 | data LC = Ze | Su LC | Pass Ast | La LC | App LC LC;
 753 | 
 754 | -- Convert the AST into a nameless representation
 755 | -- debruijn :: [String] -> Ast ->  LC
 756 | debruijn n e = case e of
 757 |   { R s     -> pure $ Pass (R s)
 758 |   ; V v     -> pure $ foldr (\h m -> ife (h == v) Ze (Su m)) (Pass (V v)) n
 759 |   ; A x y   -> App <$> debruijn n x <*> debruijn n y
 760 |   ; L s t   -> La <$> debruijn (s:n) t
 761 |   ; Proof _ -> Nothing
 762 |   };
 763 | 
 764 | -- See Kiselyov's paper - "Lambda to SKI, semantically", pages 10 - 11
 765 | --         V       C            N          W
 766 | data Sem = Defer | Closed Ast | Need Sem | Weak Sem;
 767 | -- ($$) algorithm
 768 | 
 769 | -- ($$), case Defer
 770 | -- Parameters: r == self
 771 | ldef r y = case y of
 772 |   { -- (V, V)   -> N (C S.(S $! I $! I))
 773 |     Defer    -> Need (Closed (A (A (R "S") (R "I")) (R "I")))
 774 |     -- (V, C d) -> N (C S.(kC $! kI $! d))
 775 |   ; Closed d -> Need (Closed (A (R "T") d))
 776 |     -- (V, N e) -> N (C S.(kS $! kI) $$ e)
 777 |   ; Need e   -> Need (r (Closed (A (R "S") (R "I"))) e)
 778 |     -- (V, W e) -> N (C (S.(kS $! kI)) $$ e)
 779 |   ; Weak e   -> Need (r (Closed (R "T")) e)
 780 |   };
 781 | 
 782 | -- ($$), case Closed
 783 | -- d is the argument to Closed (i.e. lclo r (Closed d) y = ...)
 784 | lclo r d y = case y of
 785 |   { -- (C d, V)     -> N (C d)
 786 |     Defer     -> Need (Closed d)
 787 |     -- (C d1, C d2) -> C (S.(d1 $! d2))
 788 |   ; Closed dd -> Closed (A d dd)
 789 |     -- (C d, N e)   -> N (C S.(kB $! d) $$ e)
 790 |   ; Need e    -> Need (r (Closed (A (R "B") d)) e)
 791 |     -- (C d, W e)   -> W (C d $$ e)
 792 |   ; Weak e    -> Weak (r (Closed d) e)
 793 |   };
 794 | 
 795 | -- ($$), case Need
 796 | -- e is the argument to Need (i.e. lnee r (Need e) y = ...)
 797 | lnee r e y = case y of
 798 |   { -- (N e, V)     -> N (C S.kS $$ e $$ C S.kI)
 799 |     Defer    -> Need (r (r (Closed (R "S")) e) (Closed (R "I")))
 800 |     -- (N e, C d)   -> N (C S.(kC $! kC $! d) $$ e)
 801 |   ; Closed d -> Need (r (Closed (A (R "R") d)) e)
 802 |     -- (N e1, N e2) -> N ((C S.kS) $$ e1 $$ e2)
 803 |   ; Need ee  -> Need (r (r (Closed (R "S")) e) ee)
 804 |     -- (N e1, W e2) -> N ((C S.kC) $$ e1 $$ e2)
 805 |   ; Weak ee  -> Need (r (r (Closed (R "C")) e) ee)
 806 |   };
 807 | 
 808 | -- ($$), case Weak
 809 | -- e is the argument to Weak (i.e. lweak r (Weak e) y = ...)
 810 | lwea r e y = case y of
 811 |   { -- (W e, V)     -> N e
 812 |     Defer    -> Need e
 813 |     -- (W e, C d)   -> W (e $$ C d)
 814 |   ; Closed d -> Weak (r e (Closed d))
 815 |     -- (W e1, N e2) -> N ((C S.kB) $$ e1 $$ e2)
 816 |   ; Need ee  -> Need (r (r (Closed (R "B")) e) ee)
 817 |     -- (W e1, W e2) -> W (e1 $$ e2)
 818 |   ; Weak ee  -> Weak (r e ee)
 819 |   };
 820 | 
 821 | -- ($$), the full thing.
 822 | babsa x y = case x of
 823 |   { Defer    -> ldef babsa y
 824 |   ; Closed d -> lclo babsa d y
 825 |   ; Need e   -> lnee babsa e y
 826 |   ; Weak e   -> lwea babsa e y
 827 |   };
 828 | 
 829 | -- Full bracket abstraction algorithm, from De Bruijn to combinators
 830 | -- babs :: LC -> Sem
 831 | babs t = case t of
 832 |   { -- let z : (a*y, a) repr = V
 833 |     Ze -> Defer
 834 |     -- let s: (b*y, a) repr -> (_*(b*y), a) repr = fun e -> W e
 835 |     -- Looks like this version recurs on e.
 836 |   ; Su e -> Weak (babs e)
 837 |     -- A lifted AST is closed.
 838 |   ; Pass s -> Closed s
 839 |     -- See "lam" function on page 10 of Kiselyov
 840 |     -- Lambda abstraction
 841 |   ; La t -> case babs t of
 842 |     { -- V     -> C S.kI
 843 |       Defer    -> Closed (R "I")
 844 |       -- C d   -> C S.(kK $! d)
 845 |       -- Remark: d is a closed body of a lambda abstraction, so the
 846 |       -- variable being abstracted over is not used and thus we can
 847 |       -- use the K combinator
 848 |     ; Closed d -> Closed (A (R "K") d)
 849 |       -- N e   -> e
 850 |     ; Need e   -> e
 851 |       -- W e   -> (C S.kK) $$ e
 852 |     ; Weak e   -> babsa (Closed (R "K")) e
 853 |     }
 854 |     -- Application
 855 |   ; App x y -> babsa (babs x) (babs y)
 856 |   };
 857 | 
 858 | -- Convert an AST into debruijn form, then perform bracket abstraction,
 859 | -- return if and only if we have a closed form.
 860 | -- nolam :: Ast -> Maybe Ast
 861 | nolam x = debruijn [] x >>= \x ->
 862 |   case babs x of
 863 |   { Defer    -> Nothing
 864 |   ; Closed d -> Just d
 865 |   ; Need e   -> Nothing
 866 |   ; Weak e   -> Nothing
 867 |   };
 868 | 
 869 | dump tab ds =
 870 |   case ds of
 871 |   { [] -> return []
 872 |   ; (:) h t ->
 873 |     nolam (snd h) >>= \a ->
 874 |     showC tab a   >>= \b ->
 875 |     dump tab t    >>= \c ->
 876 |     return (b ++ (';' : c)) };
 877 | 
 878 | asm ds = dump ds ds;
 879 | 
 880 | -- Apply substitutions to a tree
 881 | apply sub t = case t of
 882 |   { TC v    -> t
 883 |     -- Lookup v in the substitutions, if not found, replace it with t
 884 |   ; TV v    -> fromMaybe t (lstLookup v sub)
 885 |   ; TAp a b -> TAp (apply sub a) (apply sub b)
 886 |   };
 887 | 
 888 | -- Combine two substitution lists while applying the substitutions in
 889 | -- the first.
 890 | (@@) s1 s2 = map (second (apply s1)) s2 ++ s1;
 891 | 
 892 | -- Occurs check
 893 | -- occurs :: String -> Type -> Bool
 894 | occurs s t = case t of
 895 |   { TC v    -> False
 896 |   ; TV v    -> s == v
 897 |   ; TAp a b -> occurs s a || occurs s b
 898 |   };
 899 | 
 900 | -- Bind the type variable s to the type t
 901 | varBind s t = case t of
 902 |   { --         Just (pure (s, t)) is clearer
 903 |     TC v    -> pure (pure (s, t))
 904 |     -- Binding a variable with another variable
 905 |   ; TV v    -> ife (v == s) (pure []) (pure (pure (s, t)))
 906 |     -- Infinite types not allowed
 907 |   ; TAp a b -> ife (occurs s t) Nothing (pure (pure (s, t)))
 908 |   };
 909 | 
 910 | -- Most general unifier.  Given two type trees, possibly return the
 911 | -- assignments that make them equal.
 912 | 
 913 | -- We pass unify as an argument to achieve mutual recursion.
 914 | mgu unify t u = case t of
 915 |   { TC a -> case u of
 916 |     { TC b    -> ife (a == b) (pure []) Nothing
 917 |     ; TV b    -> varBind b t
 918 |     ; TAp a b -> Nothing
 919 |     }
 920 |   ; TV a -> varBind a u
 921 |   ; TAp a b -> case u of
 922 |     { TC b    -> Nothing
 923 |     ; TV b    -> varBind b t
 924 |     ; TAp c d -> unify b d (mgu unify a c)
 925 |     }
 926 |   };
 927 | 
 928 | unify a b =
 929 |   maybe Nothing (\s -> fmap (@@ s) (mgu unify (apply s a) (apply s b)));
 930 | 
 931 | -- instantiate' ::
 932 | --   Type -> Int -> [(String, Type)] -> ((Type, Int), [(String, Type)])
 933 | instantiate' t n tab = case t of
 934 |   { TC s -> ((t, n), tab)
 935 |   ; TV s -> case lstLookup s tab of
 936 |     { Nothing -> let { va = TV (s ++ '_':showInt n "") }
 937 |                  in ((va, n + 1), (s, va):tab)
 938 |     ; Just v -> ((v, n), tab)
 939 |     }
 940 |   ; TAp x y ->
 941 |     fpair (instantiate' x n tab) $ \tn1 tab1 ->
 942 |     fpair tn1 $ \t1 n1 ->
 943 |     fpair (instantiate' y n1 tab1) $ \tn2 tab2 ->
 944 |     fpair tn2 $ \t2 n2 -> ((TAp t1 t2, n2), tab2)
 945 |   };
 946 | 
 947 | instantiatePred pred xyz =
 948 |   case pred of
 949 |   { Pred s t ->
 950 |       fpair xyz $ \xy tab ->
 951 |         fpair xy $ \out n ->
 952 |           first (first ((: out) . Pred s)) (instantiate' t n tab) };
 953 | 
 954 | -- instantiate :: Qual -> Int -> (Qual, Int)
 955 | instantiate qt n =
 956 |   case qt of
 957 |   { Qual ps t ->
 958 |       fpair (foldr instantiatePred (([], n), []) ps) $ \xy tab ->
 959 |         fpair xy $ \ps1 n1 -> first (Qual ps1) (fst (instantiate' t n1 tab)) };
 960 | 
 961 | 
 962 | -- type SymTab = [(String, (Qual, Ast))];
 963 | -- type Subst = [(String, Type)];
 964 | 
 965 | -- infer' ::
 966 | --   [(String, (Qual, b))]
 967 | --   -> [(String, Type)]
 968 | --   -> Ast
 969 | --   -> (Maybe [(String, Type)], Int)
 970 | --   -> ((Type, Ast), (Maybe [(String, Type)], Int))
 971 | infer' typed loc ast csn =
 972 |   fpair csn $ \cs n ->
 973 |     let { va = TV ('_' : showInt n "") }
 974 |      in case ast of
 975 |         {  -- Raw code is treated as Int
 976 |            R s -> ((TC "Int", ast), csn)
 977 |         ;  V s ->
 978 |              fmaybe
 979 |                (lstLookup s loc)
 980 |                (fmaybe (lstLookup s typed) undefined $ \ta ->
 981 |                   fpair (instantiate (fst ta) n) $ \q n1 ->
 982 |                     case q of {
 983 |                       Qual preds ty ->
 984 |                         ((ty, foldl A ast (map Proof preds)), (cs, n1))
 985 |                     })
 986 |                (flip (,) csn . flip (,) ast)
 987 |         ;  A x y ->
 988 |              fpair (infer' typed loc x (cs, n + 1)) $ \tax csn1 ->
 989 |                fpair tax $ \tx ax ->
 990 |                  fpair (infer' typed loc y csn1) $ \tay csn2 ->
 991 |                    fpair tay $ \ty ay ->
 992 |                      ((va, A ax ay), first (unify tx (arr ty va)) csn2)
 993 |            -- Lambda abstraction.  Infer the body of the lambda with
 994 |            -- the substitution list extended with s := <newvar>
 995 |         ;  L s x ->
 996 |              first
 997 |                (\ta -> fpair ta $ \t a -> (arr va t, L s a))
 998 |                (infer' typed ((s, va) : loc) x (cs, n + 1))
 999 |         ;  Proof _ -> undefined };
1000 | 
1001 | 
1002 | onType f pred = case pred of { Pred s t -> Pred s (f t) };
1003 | 
1004 | -- typeEq :: Type -> Type -> Bool
1005 | typeEq t u = case t of
1006 |   { TC s -> case u of
1007 |     { TC t    -> t == s
1008 |     ; TV _    -> False
1009 |     ; TAp _ _ -> False
1010 |     }
1011 |   ; TV s ->  case u of
1012 |     { TC _    -> False
1013 |     ; TV t    -> t == s
1014 |     ; TAp _ _ -> False
1015 |     }
1016 |   ; TAp a b -> case u of
1017 |     { TC _    -> False
1018 |     ; TV _    -> False
1019 |     ; TAp c d -> typeEq a c && typeEq b d
1020 |     }
1021 |   };
1022 | 
1023 | instance Eq Type where { (==) = typeEq };
1024 | predEq p q = case p of { Pred s a -> case q of { Pred t b ->
1025 |   (s == t) && (a == b) }};
1026 | 
1027 | instance Eq Pred where { (==) = predEq };
1028 | predApply sub = onType (apply sub);
1029 | 
1030 | all f = foldr ((&&) . f) True;
1031 | filter f = foldr (\x xs -> ife (f x) (x:xs) xs) [];
1032 | 
1033 | intersect xs ys = filter (\x -> fmaybe (find (== x) ys) False (const True)) xs;
1034 | 
1035 | merge s1 s2 =
1036 |   ife
1037 |     (all (\v -> apply s1 (TV v) == apply s2 (TV v)) $
1038 |      map fst s1 `intersect` map fst s2)
1039 |     (Just $ s1 ++ s2)
1040 |     Nothing;
1041 | 
1042 | match h t = case h of
1043 |   { TC a -> case t of
1044 |     { TC b    -> ife (a == b) (return []) Nothing
1045 |     ; TV b    -> Nothing
1046 |     ; TAp a b -> Nothing
1047 |     }
1048 |   ; TV a -> return [(a, t)]
1049 |   ; TAp a b -> case t of
1050 |     { TC b -> Nothing
1051 |     ; TV b -> Nothing
1052 |     ; TAp c d -> match a c >>= \ac ->
1053 |                  match b d >>= \bd ->
1054 |                  merge ac bd}};
1055 | 
1056 | matchPred h p = case p of { Pred _ t -> match h t };
1057 | 
1058 | -- TODO: Add support for printing of infix type operators.
1059 | showType t = case t of
1060 |   { TC s    -> s
1061 |   ; TV s    -> s
1062 |   ; TAp a b -> concat ["(", showType a, " ", showType b, ")"]
1063 |   };
1064 | 
1065 | instance Show Type where { show = showType };
1066 | showPred p = case p of { Pred s t -> s ++ (' ':show t) ++ " => "};
1067 | 
1068 | findInst r qn p insts =
1069 |   case insts of
1070 |   {  [] ->
1071 |        fpair qn $ \q n ->
1072 |          let { v = '*' : showInt n "" }
1073 |           in (((p, v) : q, n + 1), V v)
1074 |   ;  (:) i is ->
1075 |        case i of {
1076 |          Qual ps h ->
1077 |            case matchPred h p of
1078 |              { Nothing -> findInst r qn p is
1079 |              ; Just u ->
1080 |                foldl
1081 |                  (\qnt p ->
1082 |                     fpair qnt $ \qn1 t -> second (A t) (r (predApply u p) qn1))
1083 |                  ( qn
1084 |                  , V (case p of
1085 |                        { Pred s _ -> showPred $ Pred s h }))
1086 |                  ps }}};
1087 | 
1088 | 
1089 | findProof is pred psn = fpair psn $ \ps n -> case lookupWith (==) pred ps of
1090 |   { Nothing -> case pred of { Pred s t -> case lstLookup s is of
1091 |     { Nothing    -> undefined  -- No instances!
1092 |     ; Just insts -> findInst (findProof is) psn pred insts
1093 |     }}
1094 |   ; Just s -> (psn, V s)
1095 |   };
1096 | 
1097 | prove' ienv sub psn a = case a of
1098 |   { R _ -> (psn, a)
1099 |   ; V _ -> (psn, a)
1100 |   ; A x y -> let { p1 = prove' ienv sub psn x } in fpair p1 $ \psn1 x1 ->
1101 |     second (A x1) (prove' ienv sub psn1 y)
1102 |   ; L s t -> second (L s) (prove' ienv sub psn t)
1103 |   ; Proof raw -> findProof ienv (predApply sub raw) psn
1104 |   };
1105 | 
1106 | -- prove :: [(String, [Qual])] -> (Type, Ast) -> Subst -> (Qual, Ast)
1107 | prove ienv ta sub =
1108 |   fpair ta $ \t a ->
1109 |     fpair (prove' ienv sub ([], 0) a) $ \psn x ->
1110 |       fpair psn $ \ps _ ->
1111 |         (Qual (map fst ps) (apply sub t), foldr (L . snd) x ps);
1112 | 
1113 | dictVars ps n =
1114 |   flst ps ([], n) $ \p pt ->
1115 |     first ((p, '*' : showInt n "") :) (dictVars pt $ n + 1);
1116 | 
1117 | -- qi = Qual of instance, e.g. Eq t => [t] -> [t] -> Bool
1118 | inferMethod ienv typed qi def = fpair def $ \s expr ->
1119 |   fpair (infer' typed [] expr (Just [], 0)) $ \ta msn ->
1120 |   case lstLookup s typed of
1121 |     { Nothing -> undefined -- No such method.
1122 |     -- e.g. qac = Eq a => a -> a -> Bool, some AST (product of single method)
1123 |     ; Just qac -> fpair msn $ \ms n -> case ms of
1124 |       { Nothing -> undefined  -- Type check fails.
1125 |       ; Just sub -> fpair (instantiate (fst qac) n) $ \q1 n1 -> case q1 of
1126 |         { Qual psc tc -> case psc of
1127 |         { [] -> undefined  -- Unreachable.
1128 |         ; (:) headPred shouldBeNull -> case qi of { Qual psi ti ->
1129 |           case headPred of { Pred _ headT -> case match headT ti of
1130 |           { Nothing -> undefined
1131 |           -- e.g. Eq t => [t] -> [t] -> Bool
1132 |           -- instantiate and match it against type of ta
1133 |           ; Just subc ->
1134 |             fpair (instantiate (Qual psi $ apply subc tc) n1) $ \q2 n2 ->
1135 |             case q2 of { Qual ps2 t2 -> fpair ta $ \tx ax ->
1136 |               case match (apply sub tx) t2 of
1137 |                 { Nothing -> undefined  -- Class/instance type conflict.
1138 |                 ; Just subx -> snd $ prove' ienv (subx @@ sub) (dictVars ps2 0) ax
1139 |               }}}}}}}}};
1140 | 
1141 | genProduct ds = foldr L (L "*" $ foldl A (V "*") $ map V ds) ds;
1142 | 
1143 | inferInst ienv typed inst = fpair inst $ \cl qds -> fpair qds $ \q ds ->
1144 |   case q of { Qual ps t -> let { s = showPred $ Pred cl t } in
1145 |   (s, (,) (noQual $ TC "DICT") $ maybeFix s $
1146 |   foldr (L . snd)
1147 |     (foldl A (genProduct $ map fst ds)
1148 |        (map (inferMethod ienv typed q) ds))
1149 |     (fst $ dictVars ps 0)
1150 |   )
1151 |   };
1152 |   
1153 | inferDefs ienv defs typed =
1154 |   flst defs (Right $ reverse typed) $ \edef rest ->
1155 |     case edef of
1156 |     { Left def ->
1157 |         fpair def $ \s expr ->
1158 |           fpair (infer' typed [] (maybeFix s expr) (Just [], 0)) $ \ta msn ->
1159 |             fpair msn $ \ms _ ->
1160 |               case fmap (prove ienv ta) ms of
1161 |               { Nothing -> Left ("bad type: " ++ s)
1162 |               ; Just qa -> inferDefs ienv rest ((s, qa) : typed)}
1163 |     ; Right inst -> inferDefs ienv rest (inferInst ienv typed inst : typed)};
1164 | 
1165 | conOf con = case con of { Constr s _ -> s };
1166 | mkCase t cs =
1167 |   ( concatMap (('|' :) . conOf) cs
1168 |   , ( noQual $
1169 |       arr t $
1170 |       foldr
1171 |         (arr .
1172 |          (\c ->
1173 |             case c of
1174 |             {  Constr _ ts -> foldr arr (TV "case") ts }))
1175 |         (TV "case")
1176 |         cs
1177 |     , L "x" $ V "x"));
1178 | 
1179 | mkStrs = snd . foldl (\p u -> fpair p (\s l -> ('*':s, s : l))) ("*", []);
1180 | 
1181 | -- For example, creates `Just = \x a b -> b x`.
1182 | -- Scott encoding
1183 | scottEncode vs s ts = foldr L (foldl (\a b -> A a (V b)) (V s) ts) (ts ++ vs);
1184 | scottConstr t cs c = case c of { Constr s ts -> (s,
1185 |   ( noQual $ foldr arr t ts
1186 |   , scottEncode (map conOf cs) s $ mkStrs ts)) };
1187 | mkAdtDefs t cs = mkCase t cs : map (scottConstr t cs) cs;
1188 | 
1189 | fneat neat f = case neat of { Neat a b c -> f a b c };
1190 | 
1191 | select f xs acc =
1192 |   flst xs (Nothing, acc) $ \x xt ->
1193 |     ife (f x) (Just x, xt ++ acc) (select f xt (x : acc));
1194 | 
1195 | addInstance s q is = fpair (select ((== s) . fst) is []) $ \m xs -> case m of
1196 |   { Nothing  -> (s, [q]):xs
1197 |   ; Just sqs -> second (q:) sqs:xs
1198 |   };
1199 | 
1200 | mkSel ms s = L "*" $ A (V "*") $ foldr (L . ('*' :) . fst) (V $ '*' : s) ms;
1201 | 
1202 | untangle = foldr (\top acc -> fneat acc $ \ienv fs typed -> case top of
1203 |   { Adt t cs -> Neat ienv fs (mkAdtDefs t cs ++ typed)
1204 |   ; Def f -> Neat ienv (Left f : fs) typed
1205 |   ; Class classId v ms -> Neat ienv fs (
1206 |     map (\st -> fpair st $ \s t -> (s, (Qual [Pred classId v] t, mkSel ms s))) ms
1207 |     ++ typed)
1208 |   ; Inst cl q ds -> Neat (addInstance cl q ienv) (Right (cl, (q, ds)):fs) typed
1209 |   }) (Neat [] [] prims);
1210 | 
1211 | infer prog = fneat (untangle prog) inferDefs;
1212 | 
1213 | showQual q = case q of { Qual ps t -> concatMap showPred ps ++ show t };
1214 | 
1215 | instance Show Qual where { show = showQual };
1216 | dumpTypes' m =
1217 |   case m of
1218 |     { Err msg -> "parse error"
1219 |     ; Ok prog _ _ ->
1220 |         case infer prog of
1221 |           { Left err -> err
1222 |           ; Right typed ->
1223 |               concatMap
1224 |               (\p -> fpair p $ \s qa -> s ++ " :: " ++ show (fst qa) ++ "\n")
1225 |               typed}};
1226 | dumpTypes s = case parse program s of
1227 |   { Empty m    -> dumpTypes' m
1228 |   ; Consumed m -> dumpTypes' m };
1229 | 
1230 | -- TODO: replace with show msg
1231 | compile' m = case m of
1232 |       { Err msg -> "parse error"
1233 |       ; Ok prog _ _ ->
1234 |           case infer prog of
1235 |             { Left err  -> err
1236 |             ; Right qas -> fromMaybe undefined (asm $ map (second snd) qas)}};
1237 | 
1238 | compile s = case parse program s of
1239 |   { Empty m    -> compile' m
1240 |   ; Consumed m -> compile' m };
1241 | 


--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
 1 | with import <nixpkgs> {};
 2 | 
 3 | stdenv.mkDerivation rec {
 4 |   name = "mini-haskell";
 5 |   src = ./.;
 6 |   doCheck = true;
 7 |   buildInputs = [ gnumake gcc ];
 8 |   checkPhase = ''
 9 |      ./check_compile.sh classy.hs
10 |   '';
11 |   installPhase = ''
12 |     mkdir -p $out
13 |     cp blynn $out/bin
14 |   '';
15 | }
16 | 


--------------------------------------------------------------------------------
/examples/bignum.hs:
--------------------------------------------------------------------------------
  1 | infixr 5 :, ++;
  2 | infixr 9 .;
  3 | infixl 4 <*> , <$> , <* , *>;
  4 | infixl 3 <|>, <||>;
  5 | infixr 0 $;
  6 | infixl 7 *;
  7 | infixl 6 + , -;
  8 | (*) = (.*.);
  9 | (+) = (.+.);
 10 | (-) = (.-.);
 11 | (%) = (.%.);
 12 | (/) = (./.);
 13 | -- Delete code above and uncomment the block to compile in GHC
 14 | undefined = undefined;
 15 | ($) f = f;
 16 | id x = x;
 17 | const x y = x;
 18 | flip f x y = f y x;
 19 | (&) x f = f x;
 20 | (<$>) = fmap;
 21 | liftA2 f x = (<*>) (fmap f x);
 22 | (*>) = liftA2 $ \x y -> y;
 23 | (<*) = liftA2 const;
 24 | data Bool = True | False;
 25 | data Maybe a = Nothing | Just a;
 26 | data Either a b = Left a | Right b;
 27 | -- fpair = flip curry
 28 | fpair p f = case p of { (,) x y -> f x y };
 29 | fst p = case p of { (,) x y -> x };
 30 | snd p = case p of { (,) x y -> y };
 31 | first f p = fpair p $ \x y -> (f x, y);
 32 | second f p = fpair p $ \x y -> (x, f y);
 33 | ife a b c = case a of { True -> b ; False -> c };
 34 | not a = case a of { True -> False; False -> True };
 35 | (.) f g x = f (g x);
 36 | (||) f g = ife f True (ife g True False);
 37 | (&&) f g = ife f (ife g True False) False;
 38 | (<) a b = not (a == b) && (a <= b);
 39 | -- fold a list
 40 | -- flist :: [a] -> b -> (a -> [a] -> b) -> b
 41 | flst xs n c = case xs of { [] -> n; (:) h t -> c h t };
 42 | -- (==) on lists
 43 | lstEq xs ys = case xs of
 44 |   { []       -> flst ys True (\h t -> False)
 45 |   ; (:) x xt -> flst ys False (\y yt -> ife (x == y) (lstEq xt yt) False)
 46 |   };
 47 | instance Eq a => Eq [a] where { (==) = lstEq };
 48 | (/=) x y = not (x == y);
 49 | -- Append two lists
 50 | (++) xs ys = flst xs ys (\x xt -> x:xt ++ ys);
 51 | -- maybe :: b -> (a -> b) -> Maybe a -> b
 52 | maybe n j m = case m of { Nothing -> n; Just x -> j x };
 53 | -- fold a maybe
 54 | -- fmaybe :: Maybe a -> b -> (a -> b) -> b
 55 | fmaybe m n j = case m of { Nothing -> n; Just x -> j x };
 56 | instance Show a => Show (Maybe a) where
 57 |   { show = maybe "Nothing" (\x -> "Just " ++ show x) };
 58 | instance Functor Maybe where
 59 |   { fmap f = maybe Nothing (Just . f) };
 60 | instance Applicative Maybe where
 61 |   { pure = Just ; (<*>) f y = maybe Nothing (`fmap` y) f};
 62 | instance Monad Maybe where
 63 |   { return = Just ; (>>=) ma f = maybe Nothing f ma };
 64 | fromMaybe a m = fmaybe m a id;
 65 | unmaybe = fromMaybe undefined;
 66 | foldr c n l = flst l n (\h t -> c h (foldr c n t));
 67 | -- foldr1' :: (a -> a -> a) -> [a] -> Maybe a
 68 | foldr1' c l =
 69 |     flst
 70 |        l
 71 |        Nothing
 72 |        (\h t ->
 73 |           foldr
 74 |             (\x m -> Just (fmaybe m x (c x)))
 75 |             Nothing
 76 |             l);
 77 | 
 78 | foldl f a bs = foldr (\b g x -> g (f x b)) id bs a;
 79 | -- foldl1' :: (p -> p -> p) -> [p] -> Maybe p
 80 | foldl1' f l = flst l Nothing (\x xs -> Just (foldl f x xs));
 81 | scanl f q ls = q : (case ls of
 82 |                        { []       -> []
 83 |                        ; (:) x xs -> scanl f (f q x) xs});
 84 | 
 85 | elem k = foldr (\x t -> ife (x == k) True t) False;
 86 | find f = foldr (\x t -> ife (f x) (Just x) t) Nothing;
 87 | concat = foldr (++) [];
 88 | itemize c = [c];
 89 | map f = foldr (\x xs -> f x : xs) [];
 90 | concatMap f l = concat (map f l);
 91 | instance Functor [] where { fmap = map };
 92 | instance Monad [] where { return = itemize ; (>>=) = flip concatMap };
 93 | instance Applicative [] where
 94 |   { pure = itemize
 95 |   ; (<*>) fs xs = fs >>= \f -> xs >>= \x -> return $ f x};
 96 | prependToAll s l = flst l [] (\x xs -> s : x : prependToAll s xs);
 97 | intersperse s l = flst l [] (\x xs -> x : prependToAll s xs);
 98 | 
 99 | -- Show a non-empty list
100 | intercalate d = concat . intersperse d;
101 | unwords = intercalate " ";
102 | showList' l = "[" ++ intercalate "," (map show l) ++ "]";
103 | showList l = case l of {
104 |                []       -> "[]";
105 |                (:) x xs -> showList' l
106 | };
107 | 
108 | mapconcat f l = concat (map f l);
109 | escapeC c = ife (c == '\n') "\\n"
110 |             (ife (c == '\\') "\\\\"
111 |              [c]);
112 | showString s = "\"" ++ mapconcat escapeC s ++ "\"";
113 | 
114 | ifz n = ife (0 == n);
115 | showInt' n = ifz n id (showInt' (n/10) . (:) (chr (48+(n%10))));
116 | showInt n = ifz n ('0':) (showInt' n);
117 | 
118 | -- N.B. using show on Ints will make GHC fail to compile to due GHC
119 | -- having multiple numeric types.
120 | instance Show Int where { show n = showInt n "" };
121 | 
122 | instance Show String where { show = showString };
123 | instance Show a => Show [a] where { show = showList };
124 | 
125 | any f = foldr (\x t -> ife (f x) True t) False;
126 | lookupWith eq s =
127 |   foldr (\h t -> fpair h (\k v -> ife (eq s k) (Just v) t)) Nothing;
128 | 
129 | lstLookup = lookupWith (==);
130 | (!!) l i = case l of {
131 |              []       -> undefined;
132 |              (:) x xs -> ifz i x (xs !! (i - 1))
133 | };
134 | tail l = case l of {
135 |              []       -> undefined;
136 |              (:) x xs -> xs
137 |          };
138 | reverse = foldl (flip (:)) [];
139 | zipWith f xs ys = case xs of
140 |   { [] -> []
141 |   ; (:) x xt -> case ys of
142 |     { []       -> []
143 |     ; (:) y yt -> f x y : zipWith f xt yt
144 |     }
145 |   };
146 | zip = zipWith (,);
147 | data Nat = Nat [Int];
148 | unwrap x = case x of { Nat l -> l };
149 | 
150 | dropWhile p l = flst l [] (\x xs -> ife (p x) (dropWhile p xs) l);
151 | replicate x n = ifz n [] (x:(replicate x (n - 1)));
152 | dropWhileEnd p = foldr (\x xs -> ife ((p x) && (xs == [])) [] (x : xs)) [];
153 | 
154 | -- Since cell sizes are 2^32, we can use C's multiplication to
155 | -- multiply numbers up to 2^16 without overflow.  Since we want an
156 | -- easy way to print out the number, the base we choose must be a
157 | -- power of 10.
158 | -- baseSize = floor(log(2^16))
159 | baseSize = 4;
160 | -- base = 10^floor(log(2^16))
161 | base = 10000;
162 | 
163 | showNatDigit' i r = ifz i (replicate '0' r)
164 |                           (chr ((i%10) + ord '0')
165 |                            : (showNatDigit' (i/10) (r - 1)));
166 | showNatDigit i = showNatDigit' i baseSize;
167 | showNat l = case unwrap l of
168 |               { [] -> "0"
169 |               ; (:) _ _ ->
170 |                  (dropWhile (== '0')
171 |                   (concatMap (reverse . showNatDigit)
172 |                     (reverse (unwrap l)))) };
173 | instance Show Nat where { show = showNat };
174 | 
175 | -- Will the addition of numbers a and b lead to an overflow?
176 | willOverflow a b = (base - 1) < (a + b);
177 | -- Increment a Nat list.
178 | inc' l = case l of { [] -> [1]
179 |                    ; (:) x xs ->
180 |                        ife (x == (base - 1))
181 |                             (0 : inc' xs)
182 |                             (x + 1 : xs)};
183 | add' a b = case a of
184 |              { [] -> b
185 |              ; (:) x xs ->
186 |                case b of
187 |                  { [] -> a
188 |                  ; (:) y ys ->
189 |                    ((x + y)%base):((ife (willOverflow x y) inc' id) (add' xs ys))
190 |                  }};
191 | add a b = Nat (add' (unwrap a) (unwrap b));
192 | -- Since for any n > 0, Nat (replicate n 0) represents 0, we must
193 | -- check for this.
194 | allZero l = case l of { [] -> True ; (:) x xs -> (x == 0) && allZero xs };
195 | isZero n = case unwrap n of { [] -> True ; (:) x xs -> allZero (x:xs) };
196 | 
197 | pow' i n = ifz i n (pow' (i - 1) (0:n));
198 | -- Shift a Nat by the base.
199 | shift i n = Nat (ifz i [] (pow' i (unwrap n)));
200 | fromInt' x = ifz x [] ((x%base):fromInt' (x/base));
201 | 
202 | fromInt = Nat . fromInt';
203 | 
204 | length l = flst l 0 (\_ xs -> 1 + length xs);
205 | numDigits = length . unwrap;
206 | splitAt' m l = case l of { [] -> ([], [])
207 |                          ; (:) x xs ->
208 |                            ife (m == 1)
209 |                                ([x], xs)
210 |                                (fpair (splitAt' (m - 1) xs)
211 |                                    (\xs' xs'' -> (x:xs', xs''))) };
212 | splitAt n ls = ifz n ([], ls) (splitAt' n ls);
213 | splitDigits ab n = fpair (splitAt n (unwrap ab)) (\x y -> (Nat x, Nat y));
214 | 
215 | dec' l = case l of { [] -> []
216 |                     ; (:) x xs ->
217 |                         ifz x
218 |                             (base - 1 : dec' xs)
219 |                             (x - 1 : xs)};
220 | dec n = Nat (dec' (unwrap n));
221 | -- if a < b, then sub returns 0
222 | -- Written in CPS so we can return 0 immediately when a is 0 but b is
223 | -- not.
224 | sub' a b k = case a of
225 |                { [] ->
226 |                    case b of
227 |                      { []      -> k []
228 |                      -- Even if b is represented as Nat [0,0,0], 0 - 0 == 0.
229 |                      ; (:) _ _ -> [] }
230 |                ; (:) x xs ->
231 |                    case b of
232 |                      { [] -> k a
233 |                      ; (:) y ys ->
234 |                          ife (x < y)
235 |                          (sub' (dec' xs) ys (\r -> k (x + base - y : r)))
236 |                          (sub' xs ys (\r -> k (x - y : r)))}};
237 | sub x y = Nat $ sub' (unwrap x) (unwrap y) (dropWhileEnd (== 0));
238 | max a b = ife (a < b) b a;
239 | mul x y = case unwrap x of
240 |             { [] -> Nat [] -- 0 * y = 0
241 |             ; (:) a as ->
242 |               case unwrap y of
243 |                 { [] -> Nat [] -- x * 0 = 0
244 |                 ; (:) b bs ->
245 |                     ife ((as == []) && (bs == []))
246 |                     (fromInt (a * b))
247 |                     (let { digits = max (numDigits x) (numDigits y)
248 |                          ; ba = splitDigits x (digits / 2)
249 |                          ; dc = splitDigits y (digits / 2)
250 |                          ; a = snd ba ; b = fst ba
251 |                          ; c = snd dc ; d = fst dc
252 |                          ; z0 = mul b d
253 |                          ; z1 = mul (add a b) (add c d)
254 |                          ; z2 = mul a c
255 |                          }
256 |                       in
257 |                         add (shift ((digits / 2) * 2) z2)
258 |                         (add z0 (shift (digits / 2) (sub (sub z1 z2) z0))))}};
259 | fibs = Nat [] : Nat [1] : zipWith add fibs (tail fibs);
260 | numsFrom n = n : numsFrom (add (Nat [1]) n);
261 | intsFrom n = n : intsFrom (succ n);
262 | facs = scanl mul (Nat [1]) (numsFrom (Nat [1]));
263 | take n l = ifz n [] (case l of { [] -> [] ; (:) x xs -> x : take (n - 1) xs });
264 | main s = concat ["The 3000th Fibonacci number is\n", show (fibs !! 3000),
265 |                  "\n70000^2 = ", show (mul (fromInt 70000) (fromInt 70000)),
266 |                  "\n300! is\n", show (facs !! 300)];
267 | 


--------------------------------------------------------------------------------