├── coq
    ├── #basic.v#
    ├── #Lvl1.v#
    ├── Cases.v
    ├── Term.v
    ├── README
    ├── Util.v
    ├── Subs.v
    ├── TermFaithful.v
    ├── Unify.v
    ├── Macro.v
    └── Env.v
├── .gitignore
├── prototype
    ├── utility.rkt
    ├── demo.rkt
    ├── lang-min-macros-cps.rkt
    ├── misc
    │   ├── stepper-approach-4.rkt
    │   ├── stepper-approach-1.rkt
    │   ├── stepper-approach-3.rkt
    │   └── stepper-approach-2.rkt
    ├── performance.txt
    ├── lang-min-macros-church.rkt
    ├── resugar-redex.rkt
    ├── resugar.rkt
    ├── r6rs-macros.scm
    ├── lang-min-macros.rkt
    ├── r6rs-macros.rkt
    ├── macro.rkt
    ├── lang-min.rkt
    └── tests.rkt
├── confection
    ├── Makefile
    ├── test.grammar
    ├── README.md
    ├── Main.hs
    ├── Grammar.hs
    ├── Parse.hs
    ├── Show.hs
    ├── Test.hs
    └── Pattern.hs
├── racket
    ├── grammar.rkt
    ├── benchmark.txt
    ├── benchmark.rkt
    ├── demo.rkt
    ├── term.rkt
    ├── racket.grammar
    ├── test-racket-stepper.rkt
    ├── utility.rkt
    └── convert.rkt
└── README


/coq/#basic.v#:
--------------------------------------------------------------------------------
1 | Require Import Util.


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *.vo
2 | *.glob
3 | *.v.d
4 | *~
5 | *.hi
6 | *.o


--------------------------------------------------------------------------------
/prototype/utility.rkt:
--------------------------------------------------------------------------------
1 | (module utility racket
2 |   (provide (all-from-out "../racket/utility.rkt"))
3 |   (require "../racket/utility.rkt"))


--------------------------------------------------------------------------------
/confection/Makefile:
--------------------------------------------------------------------------------
1 | 
2 | build:
3 | 	ghc -fwarn-incomplete-patterns --make Main.hs -o Confection
4 | 
5 | test:
6 | 	ghc -fwarn-incomplete-patterns --make Test.hs -o Test
7 | 	./Test
8 | 


--------------------------------------------------------------------------------
/racket/grammar.rkt:
--------------------------------------------------------------------------------
 1 | #lang ragg
 2 | 
 3 | term: (node | list | STRING) [tags]
 4 | node: LABEL "(" terms ")"
 5 | list: "[" terms "]"
 6 | terms: [ term ("," term)* ]
 7 | 
 8 | tags: "{" "[" tag ("," tag)* "]" "}"
 9 | tag: "Head" "(" LABEL "," NUMBER "," term ")"
10 |      | "Body" | "Alien" | "!Body"


--------------------------------------------------------------------------------
/confection/test.grammar:
--------------------------------------------------------------------------------
 1 | core
 2 |   values
 3 |     CNum : Int -> Expr;
 4 |   constructors
 5 |     Plus : Expr * Expr -> Expr;
 6 | surface
 7 |   values
 8 |     SNum : Int -> Expr;
 9 |   constructors
10 |     Inc : Expr -> Expr;
11 | rules
12 |   Inc(n) -> Plus(n, CNum(1));
13 |   SNum(n) -> CNum(n) fresh unused;
14 | 


--------------------------------------------------------------------------------
/racket/benchmark.txt:
--------------------------------------------------------------------------------
 1 | Native results from benchmark.rkt:
 2 | 
 3 | 
 4 | WITH RESUGARING:
 5 | 
 6 | Big-stack factorial:
 7 | cpu time: 420 real time: 465 gc time: 120
 8 | 
 9 | Small-stack factorial:
10 | cpu time: 332 real time: 336 gc time: 68
11 | 
12 | 
13 | WITHOUT RESUGARING:
14 | 
15 | Big-stack factorial:
16 | cpu time: 376 real time: 375 gc time: 136
17 | ratio: 112%
18 | 
19 | Small-stack factorial:
20 | cpu time: 296 real time: 300 gc time: 48
21 | ratio: 112%
22 | 


--------------------------------------------------------------------------------
/coq/#Lvl1.v#:
--------------------------------------------------------------------------------
 1 | Require Import Util.
 2 | Require Import Coq.Arith.EqNat.
 3 | 
 4 | Definition vid := nat.
 5 | Definition nid := nat.
 6 | 
 7 | Inductive term :=
 8 | | var : vid -> term
 9 | | node : nid -> list term -> term.
10 | 
11 | Inductive macro :=
12 | | transf : term -> term -> macro.
13 | 
14 | Inductive env :=
15 | | mtEnv : env
16 | | bind : vid -> term -> env -> env.
17 | 
18 | Fixpoint lookup (v : vid) (e : env) : option term :=
19 |   match e with
20 |     | mtEnv => None
21 |     | bind v' t e =>
22 |       if beq_nat v v'
23 |         then Some t
24 |         else lookup v e
25 |   end.
26 | 
27 | Fixpoint subs (e : env) (t : term) : option term :=
28 |   match t with
29 |     | var v => lookup v e
30 |     | node l ts => 


--------------------------------------------------------------------------------
/confection/README.md:
--------------------------------------------------------------------------------
 1 | # Confection #
 2 | 
 3 | Usage: Resugarer grammar-file
 4 | 
 5 | Begins an interactive session.
 6 | 
 7 | Commands:
 8 | 
 9 | * `desugar *term*`
10 | * `resugar *term*`
11 | 
12 | Responses:
13 | 
14 | * `success: *term*`
15 | * `failure: *message*`
16 | * `error: *message*`
17 | 
18 | * Failure indicates that a resugaring failed for benign reasons.
19 | * Error indicates that something went wrong,
20 |   probably because of a malformed input term.
21 | * Messages are free-form strings for human reading.
22 | 
23 | 
24 | `term`s have the following grammar (a subset of Stratego ATerm grammar):
25 | 
26 |     term ::= <int> | <string> | <float>
27 |            | <label>(term, ..., term)
28 |            | [term, ..., term]
29 | 
30 | Each grammar file specifies a core and surface grammar, and a set of
31 | rewrite rules. See racket/racket.grammar for an example.
32 | 


--------------------------------------------------------------------------------
/racket/benchmark.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "term.rkt")
 4 | (require "racket-stepper.rkt")
 5 | (require profile)
 6 | 
 7 | (set-silence! #t)
 8 | 
 9 | (define-syntax-rule
10 |   (run-tests expr ...)
11 |   (begin
12 |     (display "\nWITH RESUGARING:\n")
13 |     (with-resugaring expr ...)
14 |     (display "\nWITHOUT RESUGARING:\n")
15 |     (without-resugaring expr ...)))
16 | 
17 | (run-tests
18 |  (display "\nBig-stack factorial:")
19 |  (time (test-eval (define (factorial n)
20 |                     (if (eq? n 0)
21 |                         1
22 |                         (* n (factorial (- n 1)))))
23 |                   (factorial 10000)
24 |                   "ok"))
25 |  (display "\nSmall-stack factorial:")
26 |  (time (test-eval (define (factorial n acc)
27 |                     (if (eq? n 0)
28 |                         acc
29 |                         (factorial (- n 1) (* n acc))))
30 |                   (factorial 10000 1)
31 |                   "ok"))
32 | )
33 | 


--------------------------------------------------------------------------------
/coq/Cases.v:
--------------------------------------------------------------------------------
 1 | Require String. Open Scope string_scope.
 2 | 
 3 | Ltac move_to_top x :=
 4 |   match reverse goal with
 5 |   | H : _ |- _ => try move x after H
 6 |   end.
 7 | 
 8 | Tactic Notation "assert_eq" ident(x) constr(v) :=
 9 |   let H := fresh in
10 |   assert (x = v) as H by reflexivity;
11 |   clear H.
12 | 
13 | Tactic Notation "Case_aux" ident(x) constr(name) :=
14 |   first [
15 |     set (x := name); move_to_top x
16 |   | assert_eq x name; move_to_top x
17 |   | fail 1 "because we are working on a different case" ].
18 | 
19 | Tactic Notation "Case" constr(name) := Case_aux Case name.
20 | Tactic Notation "SCase" constr(name) := Case_aux SCase name.
21 | Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
22 | Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
23 | Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
24 | Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
25 | Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
26 | Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.
27 | 


--------------------------------------------------------------------------------
/racket/demo.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require "convert.rkt")
 4 | (require "racket-stepper.rkt")
 5 | 
 6 | ; See hs/racket.grammar for sugar definitions.
 7 | 
 8 | (set-debug-communication! #f)
 9 | (set-show-continuations! #t)
10 | (set-hide-external-calls! #t)
11 | (set-debug-steps! #f)
12 | 
13 | 
14 | (with-resugaring
15 |  
16 |   (test-eval (or (and #t #f) #f))
17 |  
18 |   #;(test-eval (let [[xor (lambda (x y) (or (and x y) (and (not x) (not y))))]]
19 |                (xor (xor #f #t) (xor #t #f))))
20 |  
21 |   (test-eval (let [[x (+ 1 2)] [y (+ 3 4)]] (+ x y)))
22 |   
23 |   (test-eval (+ 1 (my-external-function (lambda (x) (+ x 1)))))
24 |  
25 |   (test-eval (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (+ 4 (k (+ 5 6)) (+ 7 8)))) 9)) 10))
26 |   (test-eval (+ 1 (call/cc (lambda (k) (+ 2 (call/cc (lambda (k2) (+ 3 (k 1729)))))))))
27 |   (test-eval (let [[k (call/cc (lambda (c) c))]] (+ 2 (k (lambda (x) 3)))))
28 |   (test-eval (+ 1 (call/cc (lambda (k) (+ 2 (k 3))))))
29 |   (test-eval (call/cc (lambda (k) (k (+ (+ 1 2) (+ 3 4))))))
30 |   (test-eval ((call/cc call/cc) (lambda (x) 3)))
31 |  ;(test-eval ((call/cc call/cc) (call/cc call/cc))) ;-- loops
32 | )
33 | 
34 | (with-resugaring
35 |  (test-eval ((function (x) (+ 1 (return (+ x 2)))) (+ 3 4)))
36 |  (test-eval ((function (f) (+ 1 (return (f 2))))
37 |              (function (x) (+ 3 (return (+ x 4))))))
38 | )


--------------------------------------------------------------------------------
/racket/term.rkt:
--------------------------------------------------------------------------------
 1 | (module data racket
 2 |   (provide
 3 |    (contract-out
 4 |     (struct Node ((label symbol?) (terms list?)))
 5 |     (struct List ((terms list?)))
 6 |     (struct Tagged ((tags list?) (term any/c)))
 7 |     (struct TermList ((tags list?) (terms list?)))
 8 |     (struct TermAtom ((tags list?) (term any/c))))
 9 |    (except-out (all-defined-out)
10 |     (struct-out Node)
11 |     (struct-out List)
12 |     (struct-out Tagged)
13 |     (struct-out TermList)
14 |     (struct-out TermAtom)))
15 |   
16 |   (require "utility.rkt")
17 |   (define (check-term-list? x)
18 |     (if (list? x) #t (fail "Boom! ~a" x)))
19 | 
20 |   #| Tag ::= MacHead(macro-name, case-number, origin-term)
21 |              -- Marks root of macro-originating code.
22 |            | MacBody: Marks code that originated from a macro.
23 |            | Alien: Marks code that is not from here. |#
24 |   (struct MacHead (m c q) #:transparent)
25 |   (struct MacBody () #:transparent)
26 |   (struct MacTranspBody () #:transparent)
27 |   (struct Alien () #:transparent)
28 |   
29 |   #| AST ::= Node(Label, listof(AST))
30 |            | Tagged(listof(Tag), AST)
31 |            | Symbol
32 |            | Integer
33 |            | Float |#
34 |   (struct Node (label terms) #:transparent)
35 |   (struct List (terms) #:transparent)
36 |   (struct Tagged (tags term) #:transparent)
37 |   (struct CouldNotUnexpand ())
38 | 
39 |   #| Term ::= TermList(listof(Tag), listof(Term))
40 |             | TaggedTerm(listof(Tag), Term) |#
41 |   (struct TermList (tags terms) #:transparent)
42 |   (struct TermAtom (tags term) #:transparent)
43 | )


--------------------------------------------------------------------------------
/coq/Term.v:
--------------------------------------------------------------------------------
 1 | Require Import Coq.Arith.EqNat.
 2 | Require Import Coq.Bool.Bool.
 3 | 
 4 | 
 5 | Definition var := nat.
 6 | Definition id := nat.
 7 | Definition beq_var := beq_nat.
 8 | Definition beq_id := beq_nat.
 9 | 
10 | Inductive term :=
11 | | tvar : var -> term
12 | | const : id -> term
13 | | empty : term
14 | | cons : term -> term -> term.
15 | Notation "p :: q" := (cons p q).
16 | 
17 | 
18 | Fixpoint fvar v p : bool :=
19 |   match p with
20 |     | tvar v' => beq_var v v'
21 |     | const c => false
22 |     | empty => false
23 |     | p :: ps => fvar v p || fvar v ps
24 |   end.
25 | 
26 | Definition closed p : Prop :=
27 |   forall (v : var), fvar v p = false.
28 | 
29 | Lemma beq_var_refl : forall (x : var),
30 |   beq_var x x = true.
31 | Proof. intro. rewrite <- beq_nat_refl. reflexivity. Qed.
32 | Hint Resolve beq_var_refl.
33 | 
34 | Lemma beq_var_sym : forall (x y : var),
35 |   beq_var x y = beq_var y x.
36 | Proof.
37 |   induction x; induction y; auto.
38 |   simpl. apply IHx.
39 | Qed.
40 | 
41 | Lemma beq_var_trans : forall (x y z : var),
42 |   beq_var x y = true -> beq_var y z = true -> beq_var x z = true.
43 | Proof.
44 |   intros. unfold beq_var in *.
45 |   apply beq_nat_true in H. rewrite H. exact H0.
46 | Qed.
47 | 
48 | Lemma beq_var_true : forall x y : var, beq_var x y = true -> x = y.
49 | Proof. intros. apply beq_nat_true. assumption. Qed.
50 | 
51 | Lemma beq_id_refl : forall (n : id), beq_id n n = true.
52 | Proof. intros. rewrite (beq_nat_refl n). reflexivity. Qed.
53 | Hint Resolve beq_id_refl.
54 | 
55 | Lemma beq_id_true : forall x y : id, beq_id x y = true -> x = y.
56 | Proof. intros. apply beq_nat_true. assumption. Qed.


--------------------------------------------------------------------------------
/coq/README:
--------------------------------------------------------------------------------
 1 | These CoQ scripts formally prove the lens laws for syntax-rule-style
 2 | case-based macros. They also define and prove correct matching one
 3 | term against another, and unifying two terms. Notable definitions and
 4 | lemmas appear below.
 5 | 
 6 | File dependency order:
 7 |   Util.v
 8 |   Term.v, Env.v
 9 |   Subs.v
10 |   Match.v
11 |   Unify.v
12 |   Macro.v
13 | 
14 | 
15 | Inductive term :=
16 | | tvar : var -> term
17 | | const : id -> term
18 | | empty : term
19 | | cons : term -> term -> term.
20 | Notation "p :: q" := (cons p q).
21 | 
22 | Definition fvars_subset (q p : term) :=
23 |   forall v, fvar v q = true -> fvar v p = true.
24 | 
25 | (* (wf p) means that term t contains each variable at most once. *)
26 | Inductive macro_branch :=
27 | | branch (p q : term) : wf p = true -> wf q = true -> fvars_subset q p -> macro_branch.
28 | 
29 | Inductive macro :=
30 | | macro_mt : macro
31 | | macro_cons : macro_branch -> macro -> macro.
32 | 
33 | 
34 | Lemma lens_1 : forall m t n t',
35 |   closed t ->
36 |   expand m t = Some (n, t') ->
37 |   unexpand m t t' n = Some t.
38 | 
39 | (* (wfm m) says that m's branches are pairwise disjoint. *)
40 | Lemma lens_2 : forall m s t n t',
41 |   closed t ->
42 |   unexpand m s t n = Some t' ->
43 |   well_formed_macro m = true ->   
44 |   expand m t' = Some (n, t).
45 | 
46 | 
47 | The file TermFaithful.v gives an alternate definition of terms a
48 | conversion function from alternate terms to standard terms, and proves
49 | that 
50 |   subs e p = subs e q <-> subs' e (convert p) = subs' e (convert q).
51 | Since matching and unification are proven correct w.r.t. substitution,
52 | and macro expansion and unexpansion are defined in terms of
53 | substitution, matching, and unification, the lens laws must also hold
54 | of the alternate terms.
55 | 


--------------------------------------------------------------------------------
/prototype/demo.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require redex)
 4 | (require "resugar-redex.rkt")
 5 | (require "lang-min.rkt")
 6 | 
 7 | (set-debug-steps! #f)
 8 | 
 9 | 
10 | (define-macro Lets
11 |   [(Lets [^ [^ x e]] b)
12 |    (apply (lambda x b) e)]
13 |   [(Lets [^ [^ x e] y ys ...] b)
14 |    (apply (lambda x (! Lets [^ y ys ...] b)) e)])
15 | 
16 | (define-macro Let
17 |   [(Let x e b)
18 |    (apply (lambda x b) e)])
19 | 
20 | (define-macro Letrec
21 |   [(Letrec [^ [^ x e] ...] b)
22 |    (Lets [^ [^ x 0] ...]
23 |          (begin (set! x e) ... b))])
24 | 
25 | (define-macro Cond
26 |   [(Cond [^ $else x])   (begin x)] ; begin required so that a step is shown!
27 |   [(Cond [^ x y])       (if x y (+ 0 0))]
28 |   [(Cond [^ x y] z zs ...) (if x y (! Cond z zs ...))])
29 | 
30 | (define-macro ProcessState
31 |   [(_ "accept")
32 |    (lambda stream
33 |      (Cond
34 |        [^ (eq? "" stream) #t]
35 |        [^ $else (begin #f)]))]
36 |   [(_ [^ label $-> target] ...)
37 |    (lambda stream
38 |      (if (eq? "" stream) #f
39 |          (Lets [^ [^ head (string-first stream)]
40 |                  [^ tail (string-rest stream)]]
41 |               (Cond
42 |                [^ (eq? label head)
43 |                   (! apply target tail)]
44 |                ...
45 |                [^ $else (begin #f)]))))])
46 | 
47 | (define-macro Automaton
48 |   [(_ init-state
49 |     [^ state $: response ...]
50 |     ...)
51 |    (Letrec [^ [^ state (ProcessState response ...)] ...]
52 |      (lambda x (! apply init-state x)))])
53 | 
54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
55 | 
56 | 
57 | #;(test-trace (+ 1 (Cond (^ (eq? 1 2) (+ 1 2)) (^ (eq? 1 3) (+ 3 4)))))
58 | 
59 | (test-trace
60 |  (Let M (Automaton
61 |          init
62 |          [^ init $: [^ "c" $-> more]]
63 |          [^ more $: [^ "a" $-> more]
64 |                     [^ "d" $-> more]
65 |                     [^ "r" $-> end]]
66 |          [^ end $:  "accept"])
67 |    (apply M "cadr")))
68 | 


--------------------------------------------------------------------------------
/README:
--------------------------------------------------------------------------------
 1 | Confection is a tool that desugars and "resugars" terms according to a
 2 | sugar specification. See the preprint
 3 | http://cs.brown.edu/research/plt/dl/resugaring/v1/resugar.pdf for a
 4 | description of what it does and how it works.
 5 | 
 6 | If you want to see Confection's application to the pyret language,
 7 | checkout the pyret-lang-resugarer git repository instead.
 8 | 
 9 | This repository contains the following:
10 | 
11 | * confection/ contains the Confection tool itself. It is written in
12 |    Haskell and requires the Haskell platform.
13 | * *coq*/ contains Coq proof files giving partial proof of correctness of
14 |    Emulation.
15 | * racket/ contains the front-end attachment of Confection to the Racket
16 |    language.
17 | * prototype/ contains the initial prototype of Confection, with a Redex
18 |    front-end. Its functionality is approximately the same, but specifies
19 |    sugars in a different format
20 | 
21 | To build Confection, first install the Haskell platform. On a linux with
22 | 'apt-get', just run 'sudo apt-get install haskell-platform'. Otherwise go
23 | to http://www.haskell.org/platform/ to download it. Next, run
24 | 
25 |     cd confection
26 |     make
27 | 
28 | To run examples in Racket, first build Confection, and then run
29 | 'test-racket-stepper.rkt' from within the 'racket' directory in
30 | Racket. There are many examples in there; uncomment out the ones you want
31 | to run.
32 | 
33 | To run pyret examples, checkout the pyret-lang-resugarer repository. (The
34 | Pyret language has changed rapidly, so this repo captured it at a
35 | particular point in time and added resugaring support.)
36 | 
37 | The easiest way to play around with *newly-created* sugars is to run the
38 | prototype. After building Confection, run either prototype/demo.rkt or
39 | prototype/lang-min-macros.rkt in Racket. The sugars are defined at the top
40 | of the file, using a syntax more similar to Scheme's syntax-rules, but the
41 | semantics are the same. (Be warned that the prototype has poor error
42 | messages, though.)
43 | 


--------------------------------------------------------------------------------
/prototype/lang-min-macros-cps.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (require redex)
 4 | (require "resugar-redex.rkt")
 5 | (require "lang-min.rkt")
 6 | 
 7 | 
 8 | (define-macro Let
 9 |   [(Let x e b)
10 |    (apply (lambda x b) e)])
11 | 
12 | (define-macro CpsM
13 |   [(CpsM ($λ x y))
14 |    (lambda x (lambda k_ (! CpsT y k_)))]
15 |   [(CpsM x)
16 |    (begin x)])
17 | 
18 | (define-macro CpsT
19 |   [(CpsT ($apply x y) k)
20 |    (CpsT x (! lambda f_ (CpsT y (lambda e_ (apply f_ e_ k)))))]
21 |   [(CpsT x k_)
22 |    (Let k k_
23 |    (apply k (CpsM x)))])
24 | 
25 | (define-macro Cps
26 |   [(Cps x) (Let halt (lambda h_ h_) (CpsT x halt))])
27 | 
28 | (define-macro CpsM*
29 |   [(CpsM* ($λ v e))
30 |    (lambda v (lambda k (CpsC* e k)))]
31 |   [(CpsM* x) x])
32 | 
33 | (define-macro CpsC*
34 |   [(CpsC* ($λ v e) c)
35 |    (apply c (CpsM* ($λ v e)))]
36 |   [(CpsC* ($apply f e) c)
37 |    (CpsK* f (lambda f_ (CpsK* e (lambda e_ (apply f_ e_ c)))))]
38 |   [(CpsC* x c)
39 |    (apply c (CpsM* x))])
40 | 
41 | (define-macro CpsK*
42 |   [(CpsK* ($λ v e) k)
43 |    (apply k (CpsM* ($λ e)))]
44 |   [(CpsK* ($apply f e) k)
45 |    (CpsK* f (lambda f_ (CpsK* e (lambda e_ (apply f_ e_ k)))))]
46 |   [(CpsK* x c)
47 |    (apply c (CpsM* x))])
48 | 
49 | (define-macro Fischer
50 |   [(Fischer ($λ x y))
51 |    (lambda k (apply k
52 |      (! lambda x (! lambda k (! apply (Fischer y) (! lambda m (apply k m)))))))]
53 |   [(Fischer ($apply x y))
54 |    (lambda k (! apply (Fischer x) (! lambda m (! apply (Fischer y)
55 |      (! lambda n (apply (apply m n) (lambda a (apply k a))))))))]
56 |   [(Fischer x)
57 |    (lambda k (! apply k x))])
58 | 
59 | 
60 | (test-eval (Cps ($apply ($λ x (+ x 1)) 3)))
61 | (test-eval (Cps ($apply ($apply ($λ f ($λ x ($apply f ($apply f x))))
62 |                                 ($λ x (+ x 1)))
63 |                         (+ 1 2))))
64 | ;(test-eval (CpsT ($apply ($apply ($λ f ($λ x ($apply f ($apply f x))))
65 | ;                                   ($λ x (+ x 1)))
66 | ;                          (+ 1 2)) (lambda h h)))
67 | ;(test-eval (Cps ($apply ($λ f ($apply f 1)) ($λ x (+ x 1)))))
68 | ;(test-eval (CpsK* ($apply ($λ f ($apply f 1)) ($λ x (+ x 1)))
69 | ;                  (lambda h h)))
70 | ;(test-eval (Lets [^ [^ x 1] [^ y (+ 1 2)]] (+ x y)))
71 | 
72 | ;(test-eval (apply (Fischer ($apply ($λ x (+ x 1)) 3)) (lambda h h)))
73 | ;(test-eval (apply (Fischer ($apply ($apply ($λ f ($λ x ($apply f ($apply f x))))
74 | ;                                   ($λ x (+ x 1)))
75 | ;                          (+ 1 2))) (lambda h h)))


--------------------------------------------------------------------------------
/coq/Util.v:
--------------------------------------------------------------------------------
 1 | Require Import Coq.Lists.List.
 2 | Require Import Coq.Bool.Bool.
 3 | 
 4 | Definition applyOpt {a b : Type} (f : a -> option b) (x : option a) : option b :=
 5 |   match x with
 6 |     | None => None
 7 |     | Some x => f x
 8 |   end.
 9 | 
10 | Notation "x <- y ; z" := (applyOpt (fun x => z) y)
11 |   (at level 65, right associativity).
12 | 
13 |   
14 | Ltac break_ands :=
15 |   repeat match goal with 
16 |     | [ H : _ /\ _ |- _ ] => inversion H; clear H
17 |   end.
18 | 
19 | Ltac break_andbs :=
20 |   repeat match goal with
21 |     | [ H : _ && _ = _ |- _ ] =>
22 |       apply andb_prop in H; inversion H; clear H
23 |   end.
24 | 
25 | Ltac simpl_impls := 
26 |   repeat match goal with
27 |     | [ Imp : ?cond -> ?exp, Given : ?cond |- _ ] => 
28 |       let H' := fresh "H" in 
29 |         ((assert exp as H' by (apply Imp; exact Given)); try clear Imp)
30 |     | [ Given : ?cond, Imp : ?cond -> ?exp |- _ ] => 
31 |       let H' := fresh "H" in 
32 |         ((assert exp as H' by (apply Imp; exact Given)); try clear Imp)
33 |   end.
34 | 
35 | Ltac break_exists :=
36 |   repeat match goal with
37 |     | [ H : exists x, _ |- _] => elim H; intros; clear H
38 |   end.
39 | 
40 | 
41 | Definition composeOpt {a b c : Type}
42 |   (f : a -> option b) (g : b -> option c) : a -> option c :=
43 |   fun x : a =>
44 |     match f x with
45 |       | None => None
46 |       | Some y => g y
47 |     end.
48 | 
49 | Fixpoint sequenceOpts {a : Type}
50 |   (l : list (option a)) : option (list a) :=
51 |   match l with
52 |     | nil => Some nil
53 |     | None :: _ => None
54 |     | Some x :: l =>
55 |       match sequenceOpts l with
56 |         | None => None
57 |         | Some xs => Some (x :: xs)
58 |       end
59 |   end.
60 | 
61 | Fixpoint mapOpt {a b : Type}
62 |   (f : a -> option b) (l : list a) : option (list b) :=
63 |   match l with
64 |     | nil => Some nil
65 |     | x :: xs =>
66 |       match f x with
67 |         | None => None
68 |         | Some y =>
69 |           match mapOpt f xs with
70 |             | None => None
71 |             | Some ys => Some (y :: ys)
72 |           end
73 |       end
74 |   end.
75 | 
76 | Fixpoint mapOpt2 {a b c : Type}
77 |   (f : a -> b -> option c) (l1 : list a) (l2 : list b) : option (list c) :=
78 |   match (l1, l2) with
79 |     | (nil, nil) => Some nil
80 |     | (nil, _) => None
81 |     | (_, nil) => None
82 |     | (x :: xs, y :: ys) =>
83 |       match f x y with
84 |         | None => None
85 |         | Some z =>
86 |           match mapOpt2 f xs ys with
87 |             | None => None
88 |             | Some zs => Some (z :: zs)
89 |           end
90 |       end
91 |   end.
92 | 


--------------------------------------------------------------------------------
/prototype/misc/stepper-approach-4.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | (define $redex 'gremlin)
 4 | (define $index 'gremlin)
 5 | 
 6 | (define $stk (list))
 7 | (define $path (list))
 8 | (define ($init-stk! x)
 9 |   (set! $stk (list x)))
10 | (define ($push! n)
11 |   (set! $path (cons n $path))
12 |   (set! $stk (cons (vector-ref (car $stk) n) $stk)))
13 | (define ($pop!)
14 |   (set! $stk (cdr $stk))
15 |   (set! $path (cdr $path)))
16 | (define ($alter! x)
17 |   (set! $stk (cons x (cdr $stk)))
18 |   (when (not (empty? (cdr $stk)))
19 |     (vector-set! (cadr $stk) (car $path) x)))
20 | 
21 | 
22 | (define ($emit)
23 |   (display (format "~a\n" (show (last $stk)))))
24 | 
25 | (define-syntax-rule (test-eval x)
26 |   (Top x))
27 | 
28 | (define-struct Func (func term)
29 |   #:property prop:procedure
30 |   (λ (self . args) (apply (Func-func self) args)))
31 | 
32 | ; Prepare a term to be shown
33 | (define-syntax Adorn
34 |   (syntax-rules (λ if set! begin +)
35 |     [(Adorn (+ x y))
36 |      `#(+ ,(Adorn x) ,(Adorn y))]
37 |     [(Adorn (λ (v) x))
38 |      (let [[v 'v]] `#(λ (v) ,(Adorn x)))]
39 |     [(Adorn (f x))
40 |      `#(,(Adorn f) ,(Adorn x))]
41 |     [(Adorn x)
42 |      x]))
43 | 
44 | (define-syntax-rule (Rec x n)
45 |   (begin ($push! n)
46 |          (let [[result (Eval x)]]
47 |            ($pop!)
48 |            result)))
49 | 
50 | ; Augment code to show steps
51 | (define-syntax-rule (Top x)
52 |   (begin ($init-stk! (Adorn x))
53 |          (let [[result (Eval x)]]
54 |            ($emit)
55 |            result)))
56 | 
57 | (define-syntax Eval
58 |   (syntax-rules (λ if set! begin +)
59 |     
60 |     [(Eval (+ x y))
61 |      (let [[xv (Rec x 1)]
62 |            [yv (Rec y 2)]]
63 |        (let [[result (+ xv yv)]]
64 |          ($emit)
65 |          ($alter! result)
66 |          result))]
67 |     
68 |     [(Eval (λ (v) x))
69 |      (Func (λ (v) (Eval x)) (Adorn (λ (v) x)))]
70 |     
71 |     [(Eval (f x))
72 |      (let [[fv (Rec f 0)]
73 |            [xv (Rec x 1)]]
74 |        ($emit)
75 |        ($alter! (vector-ref (Func-term fv) 2))
76 |        (let [[result (fv xv)]]
77 |          ($alter! result)
78 |          result))]
79 |     
80 |     [(Eval x)
81 |      x]))
82 | 
83 | (define (show x)
84 |   (cond [(Func? x) (show (Func-term x))]
85 |         [(vector? x) (vector->list (vector-map show x))]
86 |         [(procedure? x) (object-name x)]
87 |         [else x]))
88 | 
89 | (test-eval (+ 1 2))
90 | (test-eval (+ (+ 1 2) (+ 3 4)))
91 | (test-eval (+ (+ (+ 1 2) (+ 3 4)) (+ 5 (+ 6 7))))
92 | (test-eval (λ (x) x))
93 | (test-eval ((λ (x) x) 3))
94 | (test-eval ((λ (x) (+ (+ 1 2) (+ 3 x))) (+ 2 3)))
95 | (test-eval (+ 3 ((λ (x) (+ x 1)) 4)))


--------------------------------------------------------------------------------
/prototype/performance.txt:
--------------------------------------------------------------------------------
 1 | Simple performance measurements.
 2 | The overhead is extremely high.
 3 | The cost appears to be constructing terms as you build up the stack.
 4 | It is (expectedly) worst when the term becomes unreasonably large,
 5 | as in dumb factorial or fibonacci.
 6 | 
 7 | 
 8 | NO_EMIT:
 9 |   Accumulating Factorial:
10 |     cpu time: 4 real time: 2 gc time: 0
11 |     cpu time: 368 real time: 371 gc time: 16
12 |   Fibonacci:
13 |     cpu time: 4 real time: 0 gc time: 0
14 |     cpu time: 15841 real time: 15853 gc time: 360
15 |   Factorial (2000):
16 |     cpu time: 4 real time: 2 gc time: 0
17 |     cpu time: 10505 real time: 10643 gc time: 236
18 | 
19 | DISABLED:
20 |   Accumulating Factorial (10000):
21 |     cpu time: 88 real time: 88 gc time: 16
22 |     cpu time: 696 real time: 693 gc time: 600
23 |   Fibonacci (20):
24 |     cpu time: 4 real time: 2 gc time: 0
25 |     cpu time: 36 real time: 35 gc time: 0
26 |   Factorial (10000):
27 |     cpu time: 568 real time: 573 gc time: 500
28 |     cpu time: 108 real time: 105 gc time: 28 // Not sure why this is faster. gc luck?
29 | 
30 | 
31 |   (define (time-fib)
32 |     (display "Fibonacci:\n")
33 |     (time (letrec ((fib (λ (n) (if (or (eq? n 0) (eq? n 1))
34 |                                    1
35 |                                    (+ (fib (- n 1)) (fib (- n 2)))))))
36 |             (begin (fib 20) (void))))
37 |     (time (test-eval (Letrec [^ [^ [^ fib n] (if (Or (eq? n 0) (eq? n 1))
38 |                                                  1
39 |                                                  (+ (fib (- n 1)) (fib (- n 2))))]]
40 |                              (begin (fib 20) (void))))))
41 |   
42 |   (define (time-factorial)
43 |     (display "Factorial:\n")
44 |     (time (letrec ((factorial (λ (n) (if (eq? n 0)
45 |                                          1
46 |                                          (* n (factorial (- n 1)))))))
47 |             (begin (factorial 10000) (void))))
48 |     (time (test-eval (Letrec [^ [^ [^ factorial n] (if (eq? n 0)
49 |                                                        1
50 |                                                        (* n (factorial (- n 1))))]]
51 |                              (begin (factorial 10000) (void))))))
52 |   
53 |   (define (time-fast-factorial)
54 |     (display "Accumulating Factorial:\n")
55 |     (time (letrec ((factorial (λ (n prod)
56 |                                 (if (eq? n 0) prod
57 |                                     (factorial (- n 1) (* n prod))))))
58 |             (begin (factorial 10000 1) (void))))
59 |     (time (test-eval (Letrec [^ [^ [^ factorial n prod]
60 |                                    (if (eq? n 0) prod (factorial (- n 1) (* n prod)))]]
61 |                              (begin (factorial 10000 1) (void))))))
62 | 
63 | 
64 | 


--------------------------------------------------------------------------------
/prototype/lang-min-macros-church.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require redex)
  4 | (require "resugar-redex.rkt")
  5 | (require "lang-min.rkt")
  6 | 
  7 | 
  8 | ;;; Let ;;;
  9 | 
 10 | (define-macro Let
 11 |   [(Let x e b)
 12 |    (apply (lambda x b) e)])
 13 | 
 14 | (define-macro Letrec
 15 |   [(Letrec x e b)
 16 |    (Let x 0 (begin (set! x e) b))])
 17 | 
 18 | (define-macro Letrecs
 19 |   [(Letrecs [^ [^ x e] ...] b)
 20 |    (Lets [^ [^ x 0] ...]
 21 |          (begin (set! x e) ... b))])
 22 | 
 23 | (define-macro Lets
 24 |   [(Lets [^ [^ x e]] b)
 25 |    (apply (lambda x b) e)]
 26 |   [(Lets [^ [^ x e] y ys ...] b)
 27 |    (apply (lambda x (! Lets [^ y ys ...] b)) e)])
 28 | 
 29 | 
 30 | ;;; Thunks ;;;
 31 | 
 32 | (define-macro Thunk
 33 |   [(Thunk body)
 34 |    (λ unused body)])
 35 | 
 36 | (define-macro Force
 37 |   [(Force thunk)
 38 |    (apply thunk "unused")])
 39 | 
 40 | 
 41 | ;;; Booleans ;;;
 42 | 
 43 | (define-macro True
 44 |   [(True)
 45 |    (λ a (λ b a))])
 46 | 
 47 | (define-macro False
 48 |   [(False)
 49 |    (λ a (λ b b))])
 50 | 
 51 | (define-macro If
 52 |   [(If x y z)
 53 |    (Force (apply x (Thunk y) (Thunk z)))])
 54 | 
 55 | (define-macro Not
 56 |   [(Not x)
 57 |    (If x (! False) (! True))])
 58 | 
 59 | (define-macro And
 60 |   [(And x y)
 61 |    (If x y (! False))])
 62 | 
 63 | (define-macro Or
 64 |   [(Or x y)
 65 |    (Not (And (Not x) (Not y)))])
 66 | 
 67 | 
 68 | ;;; Pairs ;;;
 69 | 
 70 | (define-macro Pair
 71 |   [(Pair x y)
 72 |    (λ z (apply (apply z x) y))])
 73 | 
 74 | (define-macro Fst
 75 |   [(Fst p)
 76 |    (apply p (True))])
 77 | 
 78 | (define-macro Snd
 79 |   [(Snd p)
 80 |    (apply p (False))])
 81 | 
 82 | 
 83 | ;;; Numerals ;;;
 84 | 
 85 | ; Construction
 86 | (define-macro Zero
 87 |   [(Zero)
 88 |    (Pair (! True) (True))])
 89 | 
 90 | (define-macro S
 91 |   [(S n)
 92 |    (Pair (! False) n)])
 93 | 
 94 | ; Destruction
 95 | (define-macro Zero?
 96 |   [(Zero? n)
 97 |    (Fst n)])
 98 | 
 99 | (define-macro Decr
100 |   [(Decr n)
101 |    (Snd n)])
102 | 
103 | 
104 | (test-eval (If (Not (True)) (Not (True)) (Not (False))))
105 | (test-eval (And (Or (True) (False)) (Or (False) (False))))
106 | (test-eval (Snd (Fst (Pair (Pair (True) (False)) (Pair (False) (True))))))
107 | 
108 | (test-eval (Zero? (Zero)))
109 | (test-eval (Zero? (S (S (Zero)))))
110 | (test-eval (Zero? (Decr (Decr (S (S (Zero)))))))
111 | 
112 | #| addition?
113 | (define-macro Plus ; doesn't work
114 |   [(Plus n m)
115 |    (Letrec plus
116 |            (λ n (λ m (If (Zero? n) m (apply plus (Decr n) (S m)))))
117 |            (apply plus n m))])
118 | (test-eval
119 |  (Letrec plus
120 |          (! λ n (λ m (If (Zero? n) m (apply plus (! Decr n) (! S m)))))
121 |          (apply plus (S (S (Zero))) (S (Zero)))))
122 | (test-eval (Plus (S (S (Zero))) (S (Zero))))
123 | |#


--------------------------------------------------------------------------------
/prototype/misc/stepper-approach-1.rkt:
--------------------------------------------------------------------------------
 1 | (module debug-racket racket
 2 | 
 3 | #| A simple debug stepper for racket.
 4 | 
 5 |   eval [L | x | R] = emit [L x R];
 6 |                      rec [L | x | R]
 7 | 
 8 |   rec [L | + x y | R]    =  x' := eval [L + | x | y R];
 9 |                             y' := eval [L + x' | y | R];
10 |                             + x' y'
11 | 
12 |   rec [L | if x y z | R] =  x' := eval [L if | x | y z R];
13 |                             if x'
14 |                               then eval [L | y | R]
15 |                               else eval [L | z | R]
16 | 
17 |   rec [L | f x | R]      =  f' := eval [L | f | x R];
18 |                             x' := eval [L f' | x | R];
19 |                             if Lamb? f'
20 |                               then f' L R x'
21 |                               else f' x'
22 | 
23 |   rec [L | \v -> x | R]  =  Lamb (\L R y ->
24 |                                   eval [L | (\v -> Var 'v x) y | R])
25 | 
26 |   rec [L | Var v x | R]  =  x
27 | |#
28 | 
29 |   (define-struct Lamb (fun patt) #:transparent)
30 |   
31 |   (define-struct Var (name value) #:transparent)
32 |   
33 |   (define-syntax-rule (test-eval patt)
34 |     (Eval empty-ctx patt))
35 |   
36 |   (define-syntax-rule (Eval ctx patt)
37 |     (let [[result (Rec ctx patt)]]
38 |       (emit ctx (unwrap-patt result))
39 |       (unwrap-value result)))
40 |   
41 |   (define last #f)
42 |   
43 |   (define (emit ctx patt)
44 |     (let [[str (format "~a\n" (ctx patt))]]
45 |       (when (not (equal? str last))
46 |         (display str)
47 |         (set! last str))
48 |       patt))
49 |   
50 |   (define (unwrap-value x)
51 |     (if (Var? x) (Var-value x) x))
52 |   
53 |   (define (unwrap-patt x)
54 |     (cond [(Lamb? x) (Lamb-patt x)]
55 |           [(Var? x) `(,(Var-name x) := ,(unwrap-patt (Var-value x)))]
56 |           [else x]))
57 |   
58 |   (define empty-ctx (lambda (x) x))
59 | 
60 |   (define-syntax Rec
61 |     (syntax-rules (λ lambda + if)
62 |       [(Rec ctx (+ x y))
63 |        (let* [[x* (Eval (λ (w) (ctx `(+ ,x y))) x)]
64 |               [y* (Eval (λ (w) (ctx `(+ ,(unwrap-patt x*) ,y))) y)]]
65 |          (+ x* y*))]
66 |       [(Rec ctx (if x y z))
67 |        (let [[x* (Eval (λ (w) (ctx `(if ,w y z))) x)]]
68 |          (if x
69 |              (Eval ctx y)
70 |              (Eval ctx z)))]
71 |       [(Rec ctx (λ vs x))
72 |        (Rec ctx (lambda vs x))]
73 |       [(Rec ctx (lambda (v) x))
74 |        (Lamb (λ (ctx*)
75 |                (λ (v)
76 |                  (Var 'v (Eval ctx* x))))
77 |              '(λ (v) x))]
78 |       [(Rec ctx (f x))
79 |        (let* [[f* (Eval (λ (w) (ctx `(,w x))) f)]
80 |               [x* (Eval (λ (w) (ctx `(,(unwrap-patt f*) ,w))) x)]]
81 |          (if (Lamb? f*)
82 |              (((Lamb-fun f*) ctx) x*)
83 |              (f* x*)))]
84 |       [(Rec ctx x) x]))
85 |   
86 |   (test-eval (+ 1 (+ 2 3)))
87 |   (test-eval ((λ (x) (+ x 1)) (+ 1 2)))
88 |   (test-eval (((λ (f) (λ (x) (f (f x)))) (λ (x) (+ x 1))) (+ 1 2)))
89 |   (test-eval (Var 'v 3))
90 |   (test-eval (λ (x) x))
91 | )
92 | 


--------------------------------------------------------------------------------
/confection/Main.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | module Main where
  3 | 
  4 | import Pattern
  5 | import Grammar
  6 | import Parse (parseModule, parseTerm)
  7 | import Show
  8 | #if __GLASGOW_HASKELL__ >= 700
  9 | import System.Environment
 10 | #else
 11 | import System
 12 | #endif
 13 | import System.IO
 14 | import Data.Char (isSpace)
 15 | import Data.List (stripPrefix, span)
 16 | 
 17 | {- TODO:
 18 |  -   proper arg parsing
 19 |  -   pre-compute bodyWrap
 20 |  -   check production table for duplicates
 21 |  -   extend model to handle duplicate atomic vars
 22 |  -}
 23 | 
 24 | data Command = Desugar SortName String
 25 |              | Resugar SortName String
 26 | 
 27 | commands = [("desugar ", Desugar),
 28 |             ("resugar ", Resugar)]
 29 | 
 30 | output str = do
 31 |   putStrLn str
 32 |   hFlush stdout
 33 | succeed t = output ("success: " ++ show t)
 34 | failure msg = output (removeNewlines ("failure: " ++ msg))
 35 | problem msg = output (removeNewlines ("error: " ++ msg))
 36 | 
 37 | getCommand line =
 38 |   tryCommands commands
 39 |   where
 40 |     tryCommands [] = Nothing
 41 |     tryCommands ((cmd, con):rest) =
 42 |       case stripPrefix cmd line of
 43 |         Nothing -> tryCommands rest
 44 |         Just s ->
 45 |           let (sn, s') = span (not . isSpace) s
 46 |               (_, s'') = span isSpace s' in
 47 |           Just (con (SortN sn) s'')
 48 | 
 49 | readTerm str (CompiledLanguage g) sn = do
 50 |   case parseTerm "(input)" str of
 51 |     Left err -> do
 52 |       problem ("invalid term: " ++ show err)
 53 |       return Nothing
 54 |     Right t -> case termConforms g (SortName sn) t of
 55 |       Right () -> return (Just t)
 56 |       Left err -> do
 57 |         problem (show err)
 58 |         return Nothing
 59 | 
 60 | showResult :: Either ResugarFailure Term -> IO ()
 61 | showResult (Left (ResugarError err)) = problem (show err)
 62 | showResult (Left msg) = failure (show msg)
 63 | showResult (Right t) = succeed t
 64 | 
 65 | mainLoop :: CompiledModule -> IO ()
 66 | mainLoop m@(CompiledModule l1 l2 ms) = do
 67 |   hSetEncoding stdin utf8
 68 |   hSetEncoding stdout utf8
 69 |   hSetEncoding stderr utf8
 70 |   line <- getLine
 71 |   case getCommand line of
 72 |     Nothing -> problem "invalid command"
 73 |     Just (Desugar sn s) -> do
 74 |       t <- readTerm s l2 sn
 75 |       case t of
 76 |         Nothing -> return ()
 77 |         Just t -> case expand ms t of
 78 |           Left err -> showResult (Left err)
 79 |           Right t ->
 80 |             let CompiledLanguage gt = l1 in
 81 |             case termConforms gt (SortName sn) t of
 82 |               Right () -> succeed t
 83 |               Left err ->
 84 |                 problem ("Your desugaring rules are incomplete on term: "
 85 |                           ++ showTerm False t "" ++ ". " ++ show err)
 86 |     Just (Resugar sn s) -> do
 87 |       t <- readTerm s l1 sn
 88 |       case t of
 89 |         Nothing -> return ()
 90 |         Just t -> showResult (unexpand ms t)
 91 |   mainLoop m
 92 | 
 93 | removeNewlines :: String -> String
 94 | removeNewlines = map (\c -> if c == '\n' then ' ' else c)
 95 | 
 96 | main = do
 97 |   -- TODO: proper arg parsing
 98 |   [filename] <- getArgs
 99 |   src <- readFile filename
100 |   case parseModule filename src of
101 |     Left err -> do
102 |       problem ("Parse error in module: " ++ show err)
103 |     Right m -> case compileModule m of
104 |       Left err -> problem (show err)
105 |       Right m -> mainLoop m
106 | 


--------------------------------------------------------------------------------
/prototype/misc/stepper-approach-3.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (define-syntax-rule (test-eval x)
  4 |   (Eval x))
  5 | 
  6 | (define-syntax (test-code stx)
  7 |   (syntax-case stx ()
  8 |     [(test-code x)
  9 |      (let [[z (local-expand #'(Eval x) 'expression (list))]]
 10 |        (with-syntax [[z* z]]
 11 |          #''z*))]))
 12 | 
 13 | (define-struct Func (func term)
 14 |   #:property prop:procedure
 15 |   (λ (self . args) (apply (Func-func self) args)))
 16 | 
 17 | ; Prepare a term to be shown
 18 | (define-syntax Adorn
 19 |   (syntax-rules (λ if set! begin)
 20 |     [(Adorn (begin x y))
 21 |      `(begin ,(Adorn x) ,(Adorn y))]
 22 |     [(Adorn (λ (v) x))
 23 |      (let [[v 'v]] `(λ (v) ,(Adorn x)))]
 24 |     [(Adorn (set! v x))
 25 |      (let [[v 'v]] `(set! v ,(Adorn x)))]
 26 |     [(Adorn (if x y z))
 27 |      `(if ,(Adorn x) ,(Adorn y) ,(Adorn z))]
 28 |     [(Adorn (f x))
 29 |      `(,(Adorn f) ,(Adorn x))]
 30 |     [(Adorn (f x y))
 31 |      `(,(Adorn f) ,(Adorn x) ,(Adorn y))]
 32 |     [(Adorn x)
 33 |      x]))
 34 | 
 35 | ; Augment code to show steps
 36 | (define-syntax Eval
 37 |   (syntax-rules (λ if set! begin)
 38 |     
 39 |     [(Eval (begin x y))
 40 |      (let [[$x (Call (Eval x) (λ (_) `(begin ,_ ,(Adorn y))))]]
 41 |        (emit `(begin ,$x ,(Adorn y)))
 42 |        (Eval y))]
 43 |     
 44 |     [(Eval (if x y z))
 45 |      (let [[$x (Call (Eval x) (λ (_) `(if ,_ ,(Adorn y) ,(Adorn z))))]]
 46 |        (emit `(if ,$x ,(Adorn y) ,(Adorn z)))
 47 |        (if $x (Eval y) (Eval z)))]
 48 |     
 49 |     [(Eval (λ (v) x))
 50 |      (Func (λ (v) (Eval x)) (Adorn (λ (v) x)))]
 51 |     
 52 |     [(Eval (set! v x))
 53 |      (let [[$x (Call (Eval x) (λ (_) `(set! v ,_)))]]
 54 |        (emit `(set! v ,$x))
 55 |        (set! v $x))]
 56 |     
 57 |     [(Eval (f x))
 58 |      (let [[$f (Call (Eval f) (λ (_) `(,_ ,(Adorn x))))]]
 59 |        (let [[$x (Call (Eval x) (λ (_) `(,$f ,_)))]]
 60 |          (emit `(,$f ,$x))
 61 |          (if (Func? $f)
 62 |              ($f $x)
 63 |              (Call ($f $x) (λ (_) `(?? ,_))))))]
 64 |     
 65 |     [(Eval (f x y))
 66 |      (let [[$f (Call (Eval f) (λ (_) `(,_ ,(Adorn x) ,(Adorn y))))]]
 67 |        (let [[$x (Call (Eval x) (λ (_) `(,$f ,_ ,(Adorn y))))]]
 68 |          (let [[$y (Call (Eval y) (λ (_) `(,$f ,$x ,_)))]]
 69 |            (emit `(,$f ,$x ,$y))
 70 |            (if (Func? $f)
 71 |                ($f $x $y)
 72 |                (Call ($f $x $y) (λ (_) `(?? ,_)))))))]
 73 | 
 74 |     [(Eval x) x]))
 75 | 
 76 | 
 77 | (define (show x)
 78 |   (cond [(Func? x) (show (Func-term x))]
 79 |         [(list? x) (map show x)]
 80 |         [(procedure? x) (object-name x)]
 81 |         [else x]))
 82 | 
 83 | ;;; Contexts ;;;
 84 | 
 85 | (define $val 'gremlin)
 86 | (define $ctx (list))
 87 | 
 88 | (define-syntax-rule (Call x c)
 89 |   (begin (push c)
 90 |          (set! $val x)
 91 |          (pop)
 92 |          $val))
 93 | 
 94 | (define (emit x [ctx $ctx])
 95 |   (if (empty? ctx)
 96 |       (begin (display (show x)) (newline))
 97 |       (emit ((car ctx) x) (cdr ctx))))
 98 | 
 99 | (define (push x)
100 |   (set! $ctx (cons x $ctx)))
101 | 
102 | (define (pop)
103 |   (set! $ctx (cdr $ctx)))
104 | 
105 | 
106 | (define (external f) (* 2 (f (f 223))))
107 | 
108 | (test-eval (+ 1 2))
109 | (test-eval (+ (+ 1 2) 3))
110 | (test-eval (+ 1 (+ 2 3)))
111 | (test-eval (+ (+ 1 2) (+ 3 4)))
112 | (test-eval (if (+ 1 2) (+ 3 4) (+ 5 6)))
113 | (test-eval (λ (x) (+ x 1)))
114 | (test-eval (+ 8 ((λ (x) (+ x 1)) (+ 1 2))))
115 | (test-eval ((λ (x) (+ x 1)) (+ 2 3)))
116 | (test-eval (begin (+ 1 2) (+ 3 4)))
117 | (test-eval ((λ (x) (begin (set! x (+ x 1)) (+ x 2))) (+ 3 4)))
118 | (test-eval (+ 1 (external (λ (x) (+ 1 x)))))


--------------------------------------------------------------------------------
/prototype/misc/stepper-approach-2.rkt:
--------------------------------------------------------------------------------
  1 | (module debug-racket-2 racket
  2 | 
  3 |   (define-struct Var (name value) #:transparent)
  4 |   
  5 |   (define (emit patt ctx)
  6 |     (display (format "~a\n" (ctx patt))))
  7 | 
  8 |   (define empty-ctx (λ (x) x))
  9 |   (define (unknown-ctx ctx)
 10 |     (λ (x) (ctx `(?? ,x))))
 11 |   
 12 |   (define-syntax-rule (test-eval patt)
 13 |     (Eval patt empty-ctx))
 14 |   
 15 |   (define-syntax Adorn
 16 |     (syntax-rules (λ + * if)
 17 |       [(Adorn (λ (v ...) x))
 18 |        (let [[v 'v] ...] `(λ (,v ...) ,(Adorn x)))]
 19 |       [(Adorn (+ x y))
 20 |        `(+ ,(Adorn x) ,(Adorn y))]
 21 |       [(Adorn (* x y))
 22 |        `(* ,(Adorn x) ,(Adorn y))]
 23 |       [(Adorn (if x y z))
 24 |        `(if ,(Adorn x) ,(Adorn y) ,(Adorn z))]
 25 |       [(Adorn (f x))
 26 |        `(,(Adorn f) ,(Adorn x))]
 27 |       [(Adorn c) (value->patt c)]))
 28 |   
 29 |   (define-syntax-rule (Eval patt ctx)
 30 |     (begin (emit (Adorn patt) ctx)
 31 |            (Rec patt ctx)))
 32 |   
 33 |   ; Instrumented functions
 34 |   
 35 |   (define-struct PleaseYieldFunc (ctx))
 36 |   (define-struct YieldedFunc (func))
 37 |   (define-struct PleaseYieldPatt ())
 38 |   (define-struct YieldedPatt (patt))
 39 |   
 40 |   (define (value->patt x)
 41 |     (if (procedure? x)
 42 |         (let [[p (with-handlers [[(λ (__unused) #t)
 43 |                                   (λ (__unused) x)]]
 44 |                    (x (PleaseYieldPatt)))]]
 45 |           (if (YieldedPatt? p)
 46 |               (YieldedPatt-patt p)
 47 |               x))
 48 |         x))
 49 |   
 50 |   (define-syntax Rec
 51 |     (syntax-rules (λ + * if)
 52 |       
 53 |       [(Rec (+ x y) ctx)
 54 |        (let* [[x* (Rec x (λ (_) (ctx `(+ ,_ ,(Adorn y)))))]
 55 |               [y* (Rec y (λ (_) (ctx `(+ ,x* ,_))))]
 56 |               [z* (+ x* y*)]]
 57 |          (Eval z* ctx))]
 58 |       
 59 |       [(Rec (if x y z) ctx)
 60 |        (let* [[x* (Rec x (λ (_) (ctx `(if ,_ ,(Adorn y) ,(Adorn z)))))]]
 61 |          (if x* (Eval y ctx) (Eval z ctx)))]
 62 |       
 63 |       [(Rec (λ vs x) ctx)
 64 |        ; We need to return something which *acts* like a procedure,
 65 |        ; so that it can be called by external code, but can also,
 66 |        ; * print itself nicely
 67 |        ;   (takes a (PleaseYieldPatt), wraps its output in a YieldedPatt)
 68 |        ; * take a ctx as an arg for future printing
 69 |        ;   (takes a (PleaseYieldFunc ctx), signs its output with a YieldedFunc)
 70 |        (λ (c*)
 71 |          (cond [(PleaseYieldFunc? c*)
 72 |                 (YieldedFunc (λ vs (Eval x (PleaseYieldFunc-ctx c*))))]
 73 |                [(PleaseYieldPatt? c*)
 74 |                 (YieldedPatt (Adorn (λ vs x)))]
 75 |                [else ((λ vs (Eval x (unknown-ctx ctx))) c*)]))]
 76 |       
 77 |       [(Rec (f x) ctx)
 78 |        (let* [[f* (Rec f (λ (_) (ctx `(,(Adorn _) ,(Adorn x)))))]
 79 |               [x* (Rec x (λ (_) (ctx `(,(Adorn f*) ,(Adorn _)))))]]
 80 |          (let* [[func (with-handlers [[(λ (__unused) #t)
 81 |                                       (λ (__unused) f*)]]
 82 |                        (f* (PleaseYieldFunc ctx)))]
 83 |                [result (if (YieldedFunc? func)
 84 |                            ; 'f' evaluated to an instrumented function
 85 |                            ((YieldedFunc-func func) x*)
 86 |                            ; 'f' evaluated to an ordinary function
 87 |                            (f* x*))]]
 88 |            (Eval result ctx)))]
 89 |       
 90 |       [(Rec x ctx)
 91 |        x]))
 92 |   
 93 |   (define (my-external-function f)
 94 |     (f (f 17)))
 95 |   
 96 |   (test-eval 3)
 97 |   (test-eval (+ 1 2))
 98 |   (test-eval (+ (+ 1 2) 3))
 99 |   (test-eval (+ 1 (+ 2 3)))
100 |   (test-eval (+ (+ 1 2) (+ 3 4)))
101 |   (test-eval (if #t 1 2))
102 |   (test-eval (if (+ 1 2) (+ 3 4) (+ 5 6)))
103 |   (test-eval (cons 1 (cons 1 2)))
104 |   (test-eval (λ (x) x))
105 |   (test-eval ((λ (x) (+ x 1)) 3))
106 |   (test-eval ((λ (x) (+ x x)) 3))
107 |   (test-eval ((λ (x) (+ x 1)) (+ 1 2)))
108 |   (test-eval ((λ (x) x) (λ (x) x)))
109 |   (test-eval (((λ (f) (λ (x) (f (f x)))) (λ (x) (+ x 1))) (+ 1 2)))
110 |   (test-eval (+ 1 (my-external-function (λ (x) (+ x 1)))))
111 |   
112 | )


--------------------------------------------------------------------------------
/coq/Subs.v:
--------------------------------------------------------------------------------
  1 | Require Import Coq.Arith.EqNat.
  2 | Require Import Coq.Lists.List.
  3 | Require Import Coq.Bool.Bool.
  4 | Require Import Coq.Classes.RelationClasses.
  5 | Require Import Coq.Setoids.Setoid Coq.Classes.SetoidClass.
  6 | Require Import Cases.
  7 | Require Import Term.
  8 | Require Import Env.
  9 | 
 10 | Module ValueImpl <: VALUE.
 11 |   Definition val := term.
 12 | End ValueImpl.
 13 | 
 14 | Module VarImpl <: VARIABLE.
 15 |   Definition var := var.
 16 |   Definition beq_var := beq_var.
 17 | 
 18 |   Definition beq_var_refl := beq_var_refl.
 19 |   Definition beq_var_sym := beq_var_sym.
 20 |   Definition beq_var_trans := beq_var_trans.
 21 | End VarImpl.
 22 | 
 23 | Module StdEnv := ENV(ValueImpl)(VarImpl).
 24 | Import StdEnv.
 25 | 
 26 | Definition try_lookup v a :=
 27 |   match lookup v a with
 28 |     | None => tvar v
 29 |     | Some p => p
 30 |   end.
 31 | 
 32 | Fixpoint subs a p : term :=
 33 |   match p with
 34 |     | tvar v => try_lookup v a
 35 |     | const c => const c
 36 |     | empty => empty
 37 |     | p :: ps => (subs a p) :: (subs a ps)
 38 |   end.
 39 | 
 40 | Notation "a * p" := (subs a p).
 41 | 
 42 | Definition env_eqv a b :=
 43 |   forall (v : var), try_lookup v a = try_lookup v b.
 44 | 
 45 | 
 46 | Lemma env_eqv_refl : forall a, env_eqv a a.
 47 | Proof. unfold env_eqv. reflexivity. Qed.
 48 | Lemma env_eqv_sym : forall a b, env_eqv a b -> env_eqv b a.
 49 | Proof. unfold env_eqv. intros. symmetry; auto. Qed.
 50 | Lemma env_eqv_trans : forall a b c, env_eqv a b -> env_eqv b c -> env_eqv a c.
 51 | Proof. unfold env_eqv. intros. rewrite H; auto. Qed.
 52 | 
 53 | Add Relation env env_eqv
 54 |   reflexivity proved by env_eqv_refl
 55 |   symmetry proved by env_eqv_sym
 56 |   transitivity proved by env_eqv_trans
 57 |     as Env_eqv.
 58 | 
 59 | Instance env_eqv_Setoid : Setoid env :=
 60 |   {equiv := env_eqv; setoid_equiv := Env_eqv}.
 61 | 
 62 | 
 63 | Lemma lookup_eqv : forall v a b,
 64 |   lookup v a = lookup v b -> try_lookup v a = try_lookup v b.
 65 | Proof.
 66 |   intros. unfold try_lookup. rewrite H. reflexivity.
 67 | Qed.
 68 | Hint Resolve lookup_eqv.
 69 | 
 70 | Lemma env_eqv_subs : forall a b p,
 71 |   a == b -> a * p = b * p.
 72 | Proof.
 73 |   intros. induction p; auto.
 74 |   Case "var v". simpl. unfold env_eqv in H.
 75 |     rewrite H. reflexivity.
 76 |   Case "p1 :: p2".
 77 |     simpl. rewrite IHp1. rewrite IHp2. reflexivity.
 78 | Qed.
 79 | 
 80 | Lemma subs_mtEnv : forall p, mtEnv * p = p.
 81 | Proof.
 82 |   intros. induction p; try reflexivity.
 83 |   Case "p1 :: p2".
 84 |     simpl. rewrite IHp1. rewrite IHp2. reflexivity.
 85 | Qed.
 86 | 
 87 | Lemma try_lookup_not_mem : forall v a,
 88 |   mem v a = false -> try_lookup v a = tvar v.
 89 | Proof.
 90 |   intros. assert (G : lookup v a = None).
 91 |     apply lookup_not_mem. exact H.
 92 |   unfold try_lookup. rewrite G. reflexivity.
 93 | Qed.
 94 | Hint Resolve try_lookup_not_mem.
 95 | 
 96 | Fixpoint compose (a b : env) : env :=
 97 |   match b with
 98 |     | mtEnv => a
 99 |     | bind v t b => bind v (a * t) (compose a b)
100 |   end.
101 | 
102 | Lemma compose_mtEnv_l : forall a, compose mtEnv a = a.
103 | Proof.
104 |   intros. induction a; try reflexivity.
105 |   simpl. rewrite IHa. rewrite subs_mtEnv. reflexivity.
106 | Qed.
107 | 
108 | Add Parametric Morphism : subs with signature (equiv ==> eq ==> eq) as Subs_morph.
109 | Proof.
110 |   intros. apply env_eqv_subs. assumption.
111 | Qed.
112 | 
113 | Lemma compose_subs_eq : forall a b p,
114 |   a * (b * p) = (compose a b) * p.
115 | Proof.
116 |   intros.
117 |   induction p; auto.
118 |   Case "t = var v".
119 |     simpl. induction b as [|v2 p2 b].
120 |     SCase "b = mtEnv".
121 |       reflexivity.
122 |     SCase "b = bind v2 p2 b".
123 |       simpl. unfold try_lookup, lookup.
124 |       destruct (VarImpl.beq_var v v2); auto.
125 |   Case "t = p1 :: p2".
126 |     simpl. rewrite IHp1, IHp2. reflexivity.
127 | Qed.
128 | 
129 | Lemma subs_lookup_eqv : forall a b,
130 |   a == b <-> forall p, a * p = b * p.
131 | Proof.
132 |   intros. simpl. unfold env_eqv.
133 |   split; intros.
134 |   Case "a == b -> at = bt".
135 |     induction p; auto.
136 |     SCase "t = tvar v".
137 |       simpl. apply H.
138 |     SCase "t = p1 :: p2".
139 |       simpl. rewrite IHp1, IHp2. reflexivity.
140 |   Case "at = bt -> a == b".
141 |     specialize H with (tvar v). simpl in H. exact H.
142 | Qed.
143 | 


--------------------------------------------------------------------------------
/racket/racket.grammar:
--------------------------------------------------------------------------------
  1 | core
  2 | 
  3 |   values
  4 |     Value : String -> Expr;
  5 |     True : Expr;
  6 |     False : Expr;
  7 |     Num : String -> Expr;
  8 |     Str : String -> Expr;
  9 |     Id : String -> Expr;
 10 | 
 11 |   constructors
 12 |     Lambda : [String] * Expr -> Expr;
 13 |     Begin : [Expr] -> Expr;
 14 |     Set : String * Expr -> Expr;
 15 |     If : Expr * Expr * Expr -> Expr;
 16 |     Apply : Expr * [Expr] -> Expr;
 17 | 
 18 | 
 19 | surface
 20 | 
 21 |   values
 22 |     Value : String -> Expr;
 23 |     True : Expr;
 24 |     False : Expr;
 25 |     Num : String -> Expr;
 26 |     Str : String -> Expr;
 27 |     Id : String -> Expr;
 28 | 
 29 |     Bind : String * Expr -> Bind;    
 30 |     CondCase : Expr * Expr -> CondCase;
 31 |     Accept : AutomatonTransition;
 32 |     ATransition : Expr * Expr -> AutomatonTransition;
 33 |     ACondition : String * [AutomatonTransition] -> AutomatonCondition;
 34 | 
 35 |     Delay : Expr -> Expr;
 36 | 
 37 |   constructors
 38 |     Lambda : [String] * Expr -> Expr;
 39 |     Begin : [Expr] -> Expr;
 40 |     Set : String * Expr -> Expr;
 41 |     If : Expr * Expr * Expr -> Expr;
 42 |     Apply : Expr * [Expr] -> Expr;
 43 |     
 44 |     Inc : Expr -> Expr;
 45 |     Let : [Bind] * [Expr] -> Expr;
 46 |     Letrec : [Bind] * [Expr] -> Expr;
 47 |     Cond : [CondCase] * Expr -> Expr;
 48 |     Or : [Expr] -> Expr;
 49 |     And : [Expr] -> Expr;
 50 |     ProcessState : [AutomatonTransition] -> Expr;
 51 |     Automaton : String * [AutomatonCondition] -> Expr;
 52 |     Function : [String] * Expr -> Expr;
 53 |     Return : Expr -> Expr;
 54 |     TranspTest : String * Expr -> Expr;
 55 |     CpsApp : Expr * Expr * String -> Expr;
 56 |     Cps : Expr -> Expr;
 57 | 
 58 | 
 59 | rules
 60 |   Delay(x) -> Apply(Lambda([], x), []);
 61 | 
 62 |   Inc(x) -> Apply(Id("+"), [x, Num("1")]);
 63 |   Let([Bind(v, b)], [x ...]) ->
 64 |     Apply(Lambda([v], Begin([x ...])), [b]);
 65 |   Let([Bind(v, b), Bind(v2, b2), bs ...], x) ->
 66 |     Apply(Lambda([v], !Let([Bind(v2, b2), bs ...], x)), [b]);
 67 |   Letrec([Bind(v, b) ...], [x ...]) ->
 68 |     Let([Bind(v, Apply(Id("void"), [])) ...],
 69 |       [Begin([Set(v, b) ...]), x ...]);
 70 |   Cond([], e) -> e;
 71 |   Cond([CondCase(x, y), cs ...], e) ->
 72 |     If(x, y, !Cond([cs ...], e));
 73 |   Or([x]) -> Delay(x);
 74 |   Or([x, y, ys ...]) ->
 75 |     Let([Bind("t", x)], [If(Id("t"), Id("t"), !Or([y, ys ...]))]);
 76 |   And([x]) -> Delay(x);
 77 |   And([x, y, ys ...]) ->
 78 |     If(x, And([y, ys ...]), False);
 79 | 
 80 |   ProcessState([Accept]) ->
 81 |     Lambda(["stream"],
 82 |       Cond([CondCase(Apply(Id("equal?"), [Str(""), Id("stream")]), True)],
 83 |             False));
 84 |   ProcessState([ATransition(label, target) ...]) ->
 85 |     Lambda(["stream"],
 86 |       If(Apply(Id("equal?"), [Str(""), Id("stream")]),
 87 |          False,
 88 |          Let([Bind("head", Apply(Id("string-first"), [Id("stream")])),
 89 |               Bind("tail", Apply(Id("string-rest"), [Id("stream")]))],
 90 |              [Cond([CondCase(Apply(Id("equal?"), [label, Id("head")]),
 91 |                             !Apply(target, [Id("tail")]))
 92 |                     ...],
 93 |                    False)])));
 94 |   Automaton(init_state, [ACondition(state, [response ...]) ...]) ->
 95 |     Letrec([Bind(state, ProcessState([response ...])) ...],
 96 |            [Lambda(["x"], !Apply(Id(init_state), [Id("x")]))]);
 97 | 
 98 |   TranspTest(v, x) ->
 99 |     Apply(Id("*"), [!Let([Bind(v, Num("1"))], [x]), Num("2")]);
100 |     
101 |   Function(args, body) ->
102 |     Lambda(args, Apply(Id("call/cc"), [Lambda(["%RETURN"], body)]));
103 |   Return(x) ->
104 |     Let([Bind("res", x)],
105 |         [Apply(Id("%RETURN"), [Id("res")])]);
106 | #    fresh res;
107 | 
108 |   CpsApp(x, y, k) ->
109 |     Apply(Cps(x),
110 |       [Lambda([m],
111 |         Apply(Cps(y),
112 |           [Lambda([n],
113 |             Apply(Id(m),
114 |               [Id(n), Lambda([a], Apply(Id(k), [Id(a)]))]))]))])
115 |   fresh m
116 |   fresh n
117 |   fresh a;
118 | 
119 |   Cps(Lambda([x], y)) ->  # Only single argument funs for now
120 |     Lambda([k],
121 |       Apply(Id(k),
122 |         [Lambda([x, k],
123 |            Apply(Cps(y), [Lambda([m], Apply(Id(k), [Id(m)]))]))]))
124 |   fresh k
125 |   fresh m
126 |   unsafe_overlap;
127 | 
128 |   Cps(Apply(x, [y])) ->
129 |     Lambda(["*cont*"], !CpsApp(x, y, "*cont*"))
130 |   unsafe_overlap;
131 | 
132 |   Cps(x) -> Lambda(["*cont*"], !Apply(Id("*cont*"), [x]));
133 | 


--------------------------------------------------------------------------------
/racket/test-racket-stepper.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require "convert.rkt")
  4 | (require "racket-stepper.rkt")
  5 | 
  6 | (set-debug-communication! #f)
  7 | (set-debug-steps! #f)
  8 | (set-hide-external-calls! #f)
  9 | 
 10 | 
 11 | (with-resugaring
 12 |  (test-eval (+ 1 ((function (x) (+ 1 (return (+ x 2)))) (+ 3 4)))))
 13 | 
 14 | ;;; Core stepper tests ;;;
 15 | 
 16 | #;(without-resugaring
 17 |  (test-eval "blah")
 18 |  (test-eval (lambda (x) x))
 19 |  (test-eval (+ (+ 1 2) 3))
 20 |  (test-eval (+ 1 (+ 2 3)))
 21 |  (test-eval ((lambda (x) (+ x 1)) (+ 1 2)))
 22 |  (test-eval ((lambda (x) (begin x)) 1))
 23 |  (test-eval ((lambda (x) (if (set! x (+ x 1)) (cons x x) x)) 3)))
 24 | 
 25 | 
 26 | ;;; Sugar-free tests ;;;
 27 | 
 28 | #;(with-resugaring
 29 |  (test-eval "blah")
 30 |  (test-eval (lambda (x) x))
 31 |  (test-eval 3)
 32 |  (test-eval (+ 1 2))
 33 |  (test-eval (+ (+ 1 2) (+ 3 4)))
 34 |  (test-eval ((lambda (x) (+ x 1)) (+ 1 2)))
 35 |  
 36 |   (test-eval 3)
 37 |   (test-eval (+ 1 2))
 38 |   (test-eval (+ (+ 1 2) 4))
 39 |   (test-eval (+ 1 (+ 2 4)))
 40 |   (test-eval (+ (+ 1 2) (+ 3 4)))
 41 |   (test-eval (if #t (+ 1 2) (+ 3 4)))
 42 |   (test-eval (if (+ 1 2) (+ 3 4) (+ 5 6)))
 43 |   (test-eval (lambda (x) x))
 44 |   (test-eval ((lambda (x) (+ x 1)) 3))
 45 |   (test-eval (((lambda (f) (lambda (x) (f (f x)))) (lambda (x) (+ x 1))) (+ 2 3)))
 46 |   (test-eval (+ 1 (my-external-function (lambda (x) (+ x 1)))))
 47 |   (test-eval (cons 3 7))
 48 |   (test-eval (+ 0 (car (cons (+ 1 2) (+ 3 4)))))
 49 |   (test-eval (+ 1 (begin (begin (+ 1 2)))))
 50 |   (test-eval (begin (+ 1 2) (+ 3 4)))
 51 |   (test-eval ((lambda (x) (if (set! x (+ x 1)) (cons x x) x)) 3))
 52 |   (test-eval ((lambda (x) (begin (set! x (+ x 1)) (+ x 1))) 3))
 53 |   (test-eval ((lambda (f) (begin (set! f (lambda (x) x)) (f 4))) 3))
 54 | )
 55 | 
 56 | 
 57 | ;;; Various sugars ;;;
 58 | 
 59 | #;(with-resugaring
 60 |   (test-eval (inc 3))
 61 |   (test-eval (inc (inc 3)))
 62 |   (test-eval (inc (inc (inc 3))))
 63 |   (test-eval (begin (+ 1 2) (+ 2 3) (+ 3 4)))
 64 |   (test-eval (let [[x 1]] (+ 1 2)))
 65 |   (test-eval (let [[x (+ 1 2)]] (+ x 3)))
 66 |   (test-eval (let [[x 1] [y 2]] 3))
 67 |   (test-eval (let [[x (+ 1 2)] [y (+ 3 4)]] (+ x y)))
 68 |   (test-eval (or 1))
 69 |   (test-eval (or 1 2))
 70 |   (test-eval (or (or #f #f) (or #f #t) (or #t #f)))
 71 |   (test-eval (or (zero? 3) (sub1 3)))
 72 |   (test-eval (and (not (zero? 3)) (sub1 3)))
 73 |   (test-eval (cond [else 3]))
 74 |   (test-eval (cond [#f 1] [else 2]))
 75 |   (test-eval (cond [#f 1] [(+ 1 2) (+ 3 4)] [else 7]))
 76 |   (test-eval (+ 1 (cond [#f (+ 1 2)] [(or #f #t) (+ 2 3)] [else #f])))
 77 |   (test-eval (letrec [[x 1] [y 2]] (+ x y)))
 78 |   (test-eval (letrec [[f (lambda (n) (g n))] [g (lambda (n) (+ n 1))]] (f 3)))
 79 |   
 80 |   (test-eval (let [[a (automaton
 81 |                        init
 82 |                        [init : ["c" -> more]]
 83 |                        [more : ["a" -> more]
 84 |                                ["d" -> more]
 85 |                                ["r" -> end]]
 86 |                        [end : accept])]]
 87 |                (a "cadr")))
 88 |   
 89 |   #;(test-eval (let [[a (automaton
 90 |                        init
 91 |                        [init : ["c" -> more]]
 92 |                        [more : ["a" -> more]
 93 |                                ["d" -> more]
 94 |                                ["r" -> end]]
 95 |                        [end : accept])]]
 96 |                (list (a "cadr")
 97 |                      (a "cddr")
 98 |                      (a "card"))))
 99 |   (test-eval (begin (transptest x (let ((y 1)) y))))
100 |   
101 | )
102 | 
103 | 
104 | ;;; call/cc ;;;
105 | 
106 | #;(with-resugaring
107 |   (set-show-continuations! #t)
108 |   (set-hide-external-calls! #f)
109 |  
110 |   (test-eval (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (+ 4 (k (+ 5 6)) (+ 7 8)))) 9)) 10))
111 |   (test-eval (+ 1 (call/cc (lambda (k) (+ 2 (call/cc (lambda (k2) (+ 3 (k 1729)))))))))
112 |   (test-eval (let [[k (call/cc (lambda (c) c))]] (+ 2 (k (lambda (x) 3)))))
113 |   (test-eval (+ 1 (call/cc (lambda (k) (+ 2 (k 3))))))
114 |   (test-eval (call/cc (lambda (k) (k (+ (+ 1 2) (+ 3 4))))))
115 |   (test-eval ((call/cc call/cc) (lambda (x) 3)))
116 |  ;(test-eval ((call/cc call/cc) (call/cc call/cc))) ;-- loops
117 | )
118 | 
119 | 
120 | ;;; CPS ;;;
121 | 
122 | #;(with-resugaring
123 |   (set-unexpand-vars! #t)
124 |   (test-eval ((cps (((lambda (f) (lambda (x) (f (f x))))
125 |                      (lambda (x) (+ x 1)))
126 |                     (+ 1 2)))
127 |               (lambda (result) result)))
128 |   (test-eval ((cps ((lambda (x) (+ x 1)) 3))
129 |               (lambda (result) result)))
130 |   (test-eval ((cps (((lambda (x) (lambda (y) (+ x y))) 1) 2))
131 |               (lambda (result) result)))
132 | )
133 | 


--------------------------------------------------------------------------------
/coq/TermFaithful.v:
--------------------------------------------------------------------------------
  1 | Require Import Coq.Lists.List.
  2 | Require Import Coq.Arith.EqNat.
  3 | Require Import Cases.
  4 | Require Import Term.
  5 | Require Import Env.
  6 | 
  7 | Unset Elimination Schemes.
  8 | Inductive lterm :=
  9 | | lvar : var -> lterm
 10 | | lnode : id -> list lterm -> lterm.
 11 | Set Elimination Schemes.
 12 | 
 13 | Definition lterm_rect := fun
 14 |   (P : lterm -> Type)
 15 |   (h : forall (v : var), P (lvar v))
 16 |   (g : forall (n : id), P (lnode n nil))
 17 |   (f : forall (n : id) (t : lterm) (ts : list lterm),
 18 |     P t -> P (lnode n ts) -> P (lnode n (t :: ts)))
 19 |   =>
 20 |   fix lterm_rec (t : lterm) : P t :=
 21 |   match t return P t with
 22 |     | lvar v => h v
 23 |     | lnode n ts =>
 24 |       ((fix lterms_rec (ts : list lterm) : P (lnode n ts) :=
 25 |         match ts with
 26 |           | nil => g n
 27 |           | List.cons t ts => f n t ts (lterm_rec t) (lterms_rec ts)
 28 |         end) ts)
 29 |   end.
 30 | 
 31 | Definition lterm_ind := fun
 32 |   (P : lterm -> Prop)
 33 |   (h : forall (v : var), P (lvar v))
 34 |   (g : forall (n : id), P (lnode n nil))
 35 |   (f : forall (n : id) (t : lterm) (ts : list lterm),
 36 |     P t -> P (lnode n ts) -> P (lnode n (t :: ts)))
 37 |   => lterm_rect P h g f.
 38 | 
 39 | Definition lterm_rec := fun
 40 |   (P : lterm -> Set)
 41 |   (h : forall (v : var), P (lvar v))
 42 |   (g : forall (n : id), P (lnode n nil))
 43 |   (f : forall (n : id) (t : lterm) (ts : list lterm),
 44 |     P t -> P (lnode n ts) -> P (lnode n (t :: ts)))
 45 |   => lterm_rect P h g f.
 46 | 
 47 | Module Type VALUE.
 48 |   Parameter val : Type.
 49 | End VALUE.
 50 | 
 51 | (*
 52 | Module ENV (Import Value : VALUE).
 53 | 
 54 |   Inductive env :=
 55 |   | mtEnv : env
 56 |   | bind : var -> val -> env -> env.
 57 | 
 58 |   Fixpoint lookup (v : var) (e : env) : option val :=
 59 |     match e with
 60 |       | mtEnv => None
 61 |       | bind v' t e =>
 62 |         if beq_nat v v'
 63 |           then Some t
 64 |           else lookup v e
 65 |     end.
 66 | End ENV.
 67 | *)
 68 | Module ValueM <: VALUE.
 69 |   Definition val := lterm.
 70 | End ValueM.
 71 | Module VarM <: VARIABLE.
 72 |   Definition var := var.
 73 |   Definition beq_var := beq_var.
 74 |   Definition beq_var_refl := beq_var_refl.
 75 |   Definition beq_var_sym := beq_var_sym.
 76 |   Definition beq_var_trans := beq_var_trans.
 77 | End VarM.
 78 | Module E := ENV(ValueM)(VarM).
 79 | Import E.
 80 | 
 81 | Fixpoint subs (e : env) (t : lterm) : lterm :=
 82 |   match t with
 83 |     | lvar v =>
 84 |       match E.lookup v e with
 85 |         | None => lvar v
 86 |         | Some t => t
 87 |       end
 88 |     | lnode n ts => lnode n (map (subs e) ts)
 89 |   end.
 90 | 
 91 | Fixpoint convert (t : lterm) : term :=
 92 |   let converts := fix converts (ts : list lterm) : term :=
 93 |     match ts with
 94 |       | nil => empty
 95 |       | List.cons t ts => cons (convert t) (converts ts)
 96 |     end in
 97 |   match t with
 98 |     | lvar v => tvar v
 99 |     | lnode n ts => cons (const n) (converts ts)
100 |   end.
101 | 
102 | Fixpoint subs' (e : env) (t : term) : term :=
103 |   match t with
104 |     | tvar v =>
105 |       match lookup v e with
106 |         | None => tvar v
107 |         | Some t => convert t
108 |       end
109 |     | const c => const c
110 |     | empty => empty
111 |     | cons p t2 => cons (subs' e p) (subs' e t2)
112 |   end.
113 | 
114 | Lemma subs_convert_comm : forall e t,
115 |   convert (subs e t) = subs' e (convert t).
116 | Proof.
117 |   intros.
118 |   induction t; auto.
119 |   Case "lvar v".
120 |     intros. simpl. destruct (lookup v e); auto.
121 |   Case "node n t::ts".
122 |     intros. simpl in *. rewrite IHt.
123 |     inversion IHt0. rewrite H0. reflexivity.
124 | Qed.
125 | 
126 | Lemma convert_cons : forall n n' p ps q qs,
127 |   convert (lnode n (p :: ps)) = convert (lnode n' (q :: qs)) ->
128 |   n = n' /\ convert p = convert q /\ convert (lnode n ps) = convert (lnode n qs).
129 | Proof.
130 |   intros. inversion H. simpl. rewrite H3. auto.
131 | Qed.
132 | 
133 | Lemma convert_inj : forall p q,
134 |   convert p = convert q -> p = q.
135 | Proof.
136 |   induction p as [v | n | n p ps IHp IHps]; intros.
137 |   Case "lvar v".
138 |     simpl in *. destruct q; inversion H. reflexivity.
139 |   Case "node n nil".
140 |     destruct q; inversion H. destruct l; [reflexivity | discriminate H2].
141 |   Case "node n t::ts".
142 |     induction q as [ | | n' q qs _ _]; try discriminate H.
143 |     apply convert_cons in H. inversion_clear H as (N & P & Ps).
144 |     apply IHp in P. apply IHps in Ps.
145 |     rewrite N. rewrite P. inversion Ps. reflexivity.
146 | Qed.
147 | 
148 | (* Since terms behave the same way under substitution as lterms,
149 |    we might as well use terms in place of them for convenience. *)
150 | Lemma conversion_is_faithful: forall (p q : lterm) (e : env),
151 |   subs e p = subs e q <-> subs' e (convert p) = subs' e (convert q).
152 | Proof.
153 |   intros. repeat (rewrite <- subs_convert_comm). split; intros.
154 |   Case "->".
155 |     rewrite H. reflexivity.
156 |   Case "<-".
157 |     apply convert_inj in H. exact H.
158 | Qed.


--------------------------------------------------------------------------------
/coq/Unify.v:
--------------------------------------------------------------------------------
  1 | Require Import Coq.Arith.EqNat.
  2 | Require Import Cases.
  3 | Require Import Util.
  4 | Require Import Term.
  5 | Require Import Subs.
  6 | Require Import Match.
  7 | Require Import Coq.Classes.RelationClasses.
  8 | Require Import Coq.Setoids.Setoid Coq.Classes.SetoidClass.
  9 | Import StdEnv.
 10 | 
 11 | Fixpoint unify p q : option term :=
 12 |   match (p, q) with
 13 |     | (tvar v, q) => Some q
 14 |     | (p, tvar v) => Some p
 15 |     | (const c1, const c2) => if beq_id c1 c2
 16 |                               then Some (const c1)
 17 |                               else None
 18 |     | (empty, empty) => Some empty
 19 |     | (p1 :: p2, q1 :: q2) =>
 20 |       r1 <- unify p1 q1;
 21 |       r2 <- unify p2 q2;
 22 |       Some (r1 :: r2)
 23 |     | (_, _) => None
 24 |   end.
 25 | Notation "p ^ q" := (unify p q).
 26 | 
 27 | Lemma unify_tmatch_left : forall p q r,
 28 |   p ^ q = Some r ->
 29 |   wf p = true ->
 30 |   exists a, r / p = Some a.
 31 | Proof.
 32 |   intros. generalize dependent r. generalize dependent q.
 33 |   induction p.
 34 |   Case "p = tvar".
 35 |     intros. simpl. eauto.
 36 |   Case "p = const".
 37 |     destruct q; intros; try discriminate.
 38 |     SCase "q = tvar".
 39 |       simpl in H. inversion H. simpl. rewrite beq_id_refl. eauto.
 40 |     SCase "q = const".
 41 |       simpl in H. destruct (beq_id i i0) eqn:I; inversion H.
 42 |       simpl. rewrite beq_id_refl. eauto.
 43 |   Case "p = empty".
 44 |     destruct q; intros; try discriminate.
 45 |     SCase "q = tvar".
 46 |       simpl in H. inversion H. simpl. eauto.
 47 |     SCase "q = empty".
 48 |       inversion H. simpl. eauto.
 49 |   Case "p = cons".
 50 |     intros.
 51 |     rename H0 into WF. rewrite wf_cons_iff in WF.
 52 |       inversion WF as (WF1 & WF2 & D).
 53 |     destruct q; intros; try discriminate.
 54 |     SCase "q = tvar".
 55 |       apply wf_true in WF1. inversion WF1 as (a & A).
 56 |       apply wf_true in WF2. inversion WF2 as (b & B).
 57 |       simpl in H. inversion H. simpl.
 58 |       rewrite A. rewrite B. simpl.
 59 |       rewrite fvar_disjoint_union in D; eauto.
 60 |       rewrite disjoint_iff in D. exact D.
 61 |     SCase "q = cons".
 62 |       simpl in H.
 63 |       destruct (p1 ^ q1) eqn:U1; destruct (p2 ^ q2) eqn:U2; try discriminate H.
 64 |       rename t into t1; rename t0 into t2.
 65 |       assert (E1: exists a1, t1 / p1 = Some a1) by (eapply IHp1; eauto).
 66 |       assert (E2: exists a2, t2 / p2 = Some a2) by (eapply IHp2; eauto).
 67 |       inversion E1 as (a1 & A1).
 68 |       inversion E2 as (a2 & A2).
 69 |       simpl in H. inversion H. simpl.
 70 |       rewrite A1. rewrite A2. simpl.
 71 |       rewrite fvar_disjoint_union in D; eauto.
 72 |       rewrite disjoint_iff in D. exact D.
 73 | Qed.
 74 | 
 75 | Lemma unify_tmatch_right : forall p q r,
 76 |   p ^ q = Some r ->
 77 |   wf q = true ->
 78 |   exists a, r / q = Some a.
 79 | Proof.
 80 |   intros. generalize dependent r. generalize dependent p.
 81 |   induction q.
 82 |   Case "q = tvar".
 83 |     intros. simpl. eauto.
 84 |   Case "q = const".
 85 |     destruct p; intros; try discriminate.
 86 |     SCase "p = tvar".
 87 |       simpl in H. inversion H. simpl. rewrite beq_id_refl. eauto.
 88 |     SCase "p = const".
 89 |       simpl in H. destruct (beq_id i0 i) eqn:I; inversion H.
 90 |       simpl. apply beq_id_true in I. rewrite I. rewrite beq_id_refl. eauto.
 91 |   Case "q = empty".
 92 |     destruct p; intros; try discriminate.
 93 |     SCase "p = tvar".
 94 |       simpl in H. inversion H. simpl. eauto.
 95 |     SCase "p = empty".
 96 |       inversion H. simpl. eauto.
 97 |   Case "q = cons".
 98 |     intros.
 99 |     rename H0 into WF. rewrite wf_cons_iff in WF.
100 |       inversion WF as (WF1 & WF2 & D).
101 |     destruct p; intros; try discriminate.
102 |     SCase "p = tvar".
103 |       apply wf_true in WF1. inversion WF1 as (a & A).
104 |       apply wf_true in WF2. inversion WF2 as (b & B).
105 |       simpl in H. inversion H. simpl.
106 |       rewrite A. rewrite B. simpl.
107 |       rewrite fvar_disjoint_union in D; eauto.
108 |       rewrite disjoint_iff in D. exact D.
109 |     SCase "p = cons".
110 |       simpl in H.
111 |       destruct (p1 ^ q1) eqn:U1; destruct (p2 ^ q2) eqn:U2; try discriminate H.
112 |       rename t into t1; rename t0 into t2.
113 |       assert (E1: exists a1, t1 / q1 = Some a1) by (eapply IHq1; eauto).
114 |       assert (E2: exists a2, t2 / q2 = Some a2) by (eapply IHq2; eauto).
115 |       inversion E1 as (a1 & A1).
116 |       inversion E2 as (a2 & A2).
117 |       simpl in H. inversion H. simpl.
118 |       rewrite A1. rewrite A2. simpl.
119 |       rewrite fvar_disjoint_union in D; eauto.
120 |       rewrite disjoint_iff in D. exact D.
121 | Qed.
122 | 
123 | Lemma tmatch__unify : forall p q a b,
124 |   a * p = b * q -> exists r, p ^ q = Some r.
125 | Proof.
126 |   intros.
127 |   generalize dependent q.
128 |   induction p; destruct q; try discriminate; simpl; try eauto.
129 |   Case "consts".
130 |     intros. inversion H. rewrite beq_id_refl. eauto.
131 |   Case "conss".
132 |     intros.
133 |     inversion H.
134 |     apply IHp1 in H1. inversion H1 as (r1 & R1).
135 |     apply IHp2 in H2. inversion H2 as (r2 & R2).
136 |     rewrite R1. rewrite R2. simpl. eauto.
137 | Qed.
138 | 
139 | Definition ununifyable p q :=
140 |   match unify p q with
141 |     | Some _ => false
142 |     | None => true
143 |   end.
144 | 


--------------------------------------------------------------------------------
/prototype/resugar-redex.rkt:
--------------------------------------------------------------------------------
  1 | (module resugar-redex racket
  2 |   (require redex)
  3 |   (require "resugar.rkt")
  4 |   (require "utility.rkt")
  5 |   (provide
  6 |    make-redex-language
  7 |    expand-term show-term
  8 |    define-macro macro-aware-redex-step macro-aware-traces
  9 |    macro-aware-eval ;TODO
 10 |    term->redex make-term
 11 |    ;term->pattern pattern->term ;For testing !!!
 12 |    set-debug-store! set-debug-tags! set-debug-steps!
 13 |    )
 14 |   
 15 |   (define DEBUG_STORE #f)
 16 |   (define (set-debug-store! x) (set! DEBUG_STORE x))
 17 | 
 18 |   ; Assume that Redex terms all have the form
 19 |   ; | (label origins x ...)
 20 |   ; | atom 
 21 |   ; where 'label' identifies the term type, e.g. λ, if, apply,
 22 |   ; 'origins' is a list of pattern origins,
 23 |   ; and 'x ...' are either subterms, having the same form.
 24 | 
 25 |   #|
 26 |      redex-language ctx <: language redex-term ctx:
 27 |        name :: string
 28 |        lang :: Redex language (given by define-language)
 29 |        red :: Redex reduction relation
 30 |        join :: redex-term -> ctx -> redex-term
 31 |                  e.g. expr -> store -> prog
 32 |                  e.g. x -> unit -> x
 33 |        split :: redex-term -> (cons redex-term ctx)
 34 |                   e.g. prog -> (cons expr store)
 35 |                   e.g. x -> (cons x unit)
 36 |        lookup-var :: symbol -> ctx -> (cons symbol redex-term)
 37 |   |#
 38 |   (struct redex-language language
 39 |     (red join split))
 40 |   
 41 |   (define (atomic? x)
 42 |     (or (symbol? x)
 43 |         (string? x)
 44 |         (boolean? x)
 45 |         (number? x)))
 46 |   
 47 |   (define (term->redex t)
 48 |     (match t
 49 | ;      [(term-list os (cons 'lambda ts))
 50 | ;       (cons 'lambda (cons (list 'origins (list)) (map term->redex ts)))]
 51 |       [(term-list os (cons l ts))
 52 |        (cons l (cons (list 'origins os) (map term->redex ts)))]
 53 |       [(? atomic? t)
 54 |        t]))
 55 |   
 56 |   (define (make-redex-language name lang red join split lookup-var)
 57 |     
 58 |     (define (redex->term t ctx [replace-vars #f] [recurse #f])
 59 |       (define (rec t)
 60 |         (redex->term t ctx replace-vars recurse))
 61 |       (match t
 62 |         [(? symbol? t)
 63 | ;         (when (eq? t 'tail)
 64 | ;           (display (format "|~a|\n" ctx)))
 65 |          (if replace-vars
 66 |              (let* [[x (lookup-var t ctx)]]
 67 |                (if x (if recurse
 68 |                          (let* [[var (car x)]
 69 |                                 [val (redex->term (cdr x) ctx #f #f)]
 70 |                                 [y (unexpand-term val)]]
 71 |                            (if (could-not-unexpand? y) (car x) y))
 72 |                          (car x))
 73 |                    t))
 74 |              t)]
 75 |         [(? atomic? t)
 76 |          t]
 77 | ;        [(cons 'lambda (cons _ ts))
 78 | ;         (term-list (list) (cons 'lambda (map rec ts)))]
 79 |         [(cons l (cons (list 'origins os) ts))
 80 |          (term-list os (cons l (map rec ts)))]))
 81 |     
 82 |     (redex-language name
 83 |                     term->redex
 84 |                     redex->term
 85 |                     (λ (t ctx) (map split (apply-reduction-relation red (join t ctx))))
 86 |                     "Redex langs currently do not implement language-eval"
 87 |                     (λ (t ctx [replace-vars #t] [recurse #t]) (show-term (redex->term t ctx replace-vars recurse)))
 88 |                     red
 89 |                     join
 90 |                     split))
 91 |   
 92 |   (define (macro-aware-redex-step l t n)
 93 |     (let [[split (redex-language-split l)]
 94 |           [join (redex-language-join l)]
 95 |           [term->expr (language-term->expr l)]
 96 |           [expr->term (language-expr->term l)]
 97 |           [show-expr (language-show-expr l)]]
 98 | 
 99 |     (let [[ps (macro-aware-step
100 |                l
101 |                (expr->term (car (split t)) (cdr (split t)))
102 |                (cdr (split t)))]]
103 |       (if (< (length ps) n) #f
104 |           (join (term->expr (expand-term (car (list-ref ps (- n 1)))))
105 |                 (cdr (list-ref ps (- n 1))))))))
106 | 
107 |   (define-struct hidden ())
108 |   
109 |   ; Hard code some reasonable color defaults
110 |   (light-pen-color "dim gray")
111 |   
112 |   (define (format-term-for-traces l t)
113 |     (define (make-pretty t)
114 |       (cond [(symbol-prefix? "$" t)
115 |              (string->symbol (strip-prefix "$" (symbol->string t)))]
116 |             [(and (list? t) (eq? '^ (car t)))
117 |              (map make-pretty (cdr t))]
118 |             [(list? t)
119 |              (map make-pretty t)]
120 |             [else t]))
121 |     (let [[expr->term (language-expr->term l)]
122 |           [split (redex-language-split l)]]
123 |       (if (not t) "END"
124 |           (let [[u (unexpand-term (expr->term (car (split t)) (cdr (split t)) #t #t))]]
125 |             (if (could-not-unexpand? u) (hidden) (make-pretty (term->sexpr u)))))))
126 | 
127 |   (define-syntax-rule
128 |     (macro-aware-traces l red t rest ...)
129 |     (traces red t
130 |             #:pp (lambda (s a b c)
131 |                    (default-pretty-printer
132 |                      (format-term-for-traces l s)
133 |                      a b c))
134 |             #:filter (lambda (x y) x)
135 |             rest ...))
136 | 
137 | )


--------------------------------------------------------------------------------
/prototype/resugar.rkt:
--------------------------------------------------------------------------------
  1 | (module resugar racket
  2 |   (require (except-in rackunit fail))
  3 |   (require "utility.rkt")
  4 |   (require "pattern.rkt")
  5 |   (require "macro.rkt")
  6 |   (provide
  7 |    define-macro
  8 |    make-term test-expand term-list term-list? term-list-tags term-list-terms term-id
  9 |    expand-term unexpand-term show-term term->sexpr strip-term-tags (struct-out o-external)
 10 |    could-not-unexpand?
 11 |    language language-name language-expr->term language-term->expr language-step language-show-expr
 12 |    macro-aware-step
 13 |    macro-aware-eval
 14 |    macro-aware-eval*
 15 |    set-debug-tags! set-debug-steps! debug set-debug!)
 16 |   
 17 |   (define DEBUG_TAGS #f)
 18 |   (define (set-debug-tags! x) (set! DEBUG_TAGS x))
 19 |   (define DEBUG_STEPS #f)
 20 |   (define (set-debug-steps! x) (set! DEBUG_STEPS x))
 21 |   
 22 |   #|
 23 |      A language is free to work over whatever sort of exprs and contexts it wants.
 24 |      It must take evaluation steps over (expr, context) pairs.
 25 |      Contexts are hidden and do not get unexpanded.
 26 |      term->expr and expr->term *must* be inverses of each other,
 27 |        or else the semantic properties of the stepper are lost.
 28 | 
 29 |      Language expr ctx {
 30 |        name :: string
 31 |        term->expr :: term -> expr
 32 |        expr->term :: expr -> ctx -> term
 33 |        step :: expr -> ctx -> list (cons expr ctx)
 34 |        eval :: 
 35 |        show-expr :: expr -> ctx -> string      ; for debugging
 36 |      }
 37 |  
 38 |                                  init-ctx
 39 |                                     ↓
 40 |      pattern  ===>  term  --->  (expr, ctx)
 41 |                                     ↓
 42 |      pattern  <===  term  <---  (expr, ctx)
 43 |                                     ↓
 44 |                                    ...
 45 |      (===> expansion/unexpansion)
 46 |      (---> just pairing/unpairing and term<->expr conversion)
 47 |      (↓    evaluation step)
 48 |   |#
 49 |   
 50 |   (struct language
 51 |     (name term->expr expr->term step eval show-expr))
 52 |   
 53 |   (define-syntax-rule (test-expand t)
 54 |     (expand-term (make-term t)))
 55 |   
 56 |   (define-syntax-rule (expand-term t)
 57 |     (pattern->term (expand-pattern (term->pattern t))))
 58 |   
 59 |   (struct could-not-unexpand ()); because unexpand can return #f, which is a valid term :-(
 60 |   (define-syntax-rule (unexpand-term t)
 61 |     (let [[q (unexpand-pattern (term->pattern t))]]
 62 |       (if q (pattern->term q) (could-not-unexpand))))
 63 |   
 64 |   (define last-line #f)
 65 |   (define (output-line str)
 66 |     (when (not (equal? str last-line))
 67 |       (begin
 68 |         (display str)
 69 |         (newline)
 70 |         (when DEBUG_STEPS (newline))
 71 |         (set! last-line str))))
 72 |     
 73 |   (define (show-step t)
 74 |     (output-line (if DEBUG_TAGS
 75 |                      (show-term t #t)
 76 |                      (show-term t))))
 77 |     
 78 |   (define (show-skip t)
 79 |     (when DEBUG_STEPS
 80 |       (output-line (format "SKIP: ~a" (if DEBUG_TAGS
 81 |                                           (format "~v\n" (term->pattern t))
 82 |                                           (show-term t))))))
 83 |   
 84 |   ; macro-aware-step :: Language t c -> term -> c -> list (cons term c)
 85 |   (define (macro-aware-step lang t ctx)
 86 |     (let [[expr->term (language-expr->term lang)]
 87 |           [term->expr (language-term->expr lang)]
 88 |           [show-expr (language-show-expr lang)]
 89 |           [step (language-step lang)]]
 90 |       
 91 |       (when DEBUG_STEPS
 92 |         (show-step t))
 93 |       
 94 |       (define (catmap f xs)
 95 |         (append* (map f xs)))
 96 |       
 97 |       (define (new-step e ctx)
 98 |         (catmap resugar (step e ctx)))
 99 |       
100 |       (define (resugar prog)
101 |         (let* [[e (car prog)]
102 |                [ctx (cdr prog)]
103 |                [t (expr->term e ctx)]
104 |                [p (unexpand-pattern (term->pattern t))]]
105 |           (if p
106 |               (list (cons (pattern->term p) ctx))
107 |               (begin (when DEBUG_STEPS (show-skip e #;ctx))
108 |                      (new-step e ctx)))))
109 |       
110 |       (new-step (term->expr (expand-term t)) ctx)))
111 |   
112 |   ; macro-aware-eval :: Language t c -> term -> c -> tree string
113 |   (define (macro-aware-eval lang t ctx)
114 |     (define (rec lang t ctx)
115 |       (let [[next-progs (macro-aware-step lang t ctx)]
116 |             [show-expr (language-show-expr lang)]
117 |             [term->expr (language-term->expr lang)]]
118 |         
119 |         (cons (show-expr (term->expr t) ctx)
120 |               (if (empty? next-progs)
121 |                   (list)
122 |                   (map (lambda (next-prog)
123 |                          (rec lang (car next-prog)
124 |                                    (cdr next-prog)))
125 |                        next-progs)))))
126 |     (rec lang t ctx))
127 |   
128 |   (define (emit t)
129 |     (let [[t2 (unexpand-term t)]]
130 |       (if (could-not-unexpand? t2)
131 |           (show-skip t)
132 |           (show-step t2))))
133 |   
134 |   ; macro-aware-eval* : Language expr ctx -> pattern -> void
135 |   ; A callback-based version of macro-aware-eval.
136 |   (define (macro-aware-eval* convert steps s [emit emit])
137 |     (let [[t (expand-term s)]]
138 |       (steps (convert t) emit)))
139 | )


--------------------------------------------------------------------------------
/racket/utility.rkt:
--------------------------------------------------------------------------------
  1 | (module utility racket
  2 |   (provide (all-defined-out))
  3 |   
  4 |   (define-syntax-rule (thunk x) (λ () x))
  5 |   
  6 |   (define id (λ (x) x))
  7 |   
  8 |   ; range : int -> [int]
  9 |   (define (range n)
 10 |     (if (eq? n 0) (list) (append (range (- n 1)) (list (- n 1)))))
 11 |   
 12 |   ; all-eq : [a] -> bool
 13 |   (define (all-eq? xs)
 14 |     (if (empty? xs) true
 15 |         (andmap (λ (x) (eq? x (car xs))) (cdr xs))))
 16 |   
 17 |   ; compose : a [a -> a] -> a
 18 |   (define (compose x fs)
 19 |     (if (empty? fs) x (compose ((car fs) x) (cdr fs))))
 20 |   
 21 |   ; hash-modify : (HashMap k a) (a -> a) -> (HashMap k a)
 22 |   (define (hash-modify hash func)
 23 |     (foldl (λ (key hash) (hash-update hash key func))
 24 |            hash
 25 |            (hash-keys hash)))
 26 |   
 27 |   ; hash-add-bindings : (HashMap k a) (list (pair k a)) -> (HashMap k a)
 28 |   (define (hash-add-bindings hash bindings)
 29 |     (foldl (λ (binding hash) (hash-set hash (car binding) (cdr binding)))
 30 |            hash
 31 |            bindings))
 32 |   
 33 |   ; split-list : a [a] -> (cons [a] [a]) | False
 34 |   (define (split-list delim lst)
 35 |     (let ((l (member delim (reverse lst)))
 36 |           (r (member delim lst)))
 37 |       (cond [(and (list? l) (list? r))
 38 |              (cons (reverse (cdr l)) (cdr r))]
 39 |             [else false])))
 40 |   
 41 |   ; repeat : a int -> [a]
 42 |   (define (repeat n elem)
 43 |     (if (zero? n)
 44 |         (list)
 45 |         (cons elem (repeat (- n 1) elem))))
 46 |   
 47 |   ; why can't set-union take no arguments??
 48 |   (define (set-unions sets)
 49 |     (if (empty? sets)
 50 |         (set)
 51 |         (apply set-union sets)))
 52 |   
 53 |   ; hash-union : Env ... -> Env
 54 |   ; Take the union of a list of hashmaps, assuming they are all disjoint.
 55 |   (define (hash-union . es)
 56 |     (make-immutable-hash (apply append (map hash->list es))))
 57 |   
 58 |   ; hash-remove-keys : Env(x) -> Set(x) -> Env(x)
 59 |   ; Remove all bindings from 'e' whose keys are in 's'.
 60 |   (define (hash-remove-keys e s)
 61 |     (define (remove-keys e l)
 62 |       (if (empty? l)
 63 |           e
 64 |           (remove-keys (hash-remove e (car l)) (cdr l))))
 65 |     (remove-keys e (set->list s)))
 66 |   
 67 |   ; deduplicate : list -> list
 68 |   ; Remove adjacent duplicates from a list, like unix 'uniq'
 69 |   (define (deduplicate l [same? equal?])
 70 |     (match l
 71 |       [(list) (list)]
 72 |       [(list x) (list x)]
 73 |       [(cons x (cons y ys))
 74 |        (if (same? x y)
 75 |            (deduplicate (cons y ys))
 76 |            (cons x (deduplicate (cons y ys))))]))
 77 |   
 78 |   ; all-distinct-pairs: [x] -> [(x, x)]
 79 |   ; Find all distinct pairs of elements of a given list
 80 |   ; e.g. (1 2 3) -> ((1 . 2) (1 . 3) (2 . 3))
 81 |   (define (all-distinct-pairs l)
 82 |     (if (empty? l)
 83 |         empty
 84 |         (let [[fst (car l)]
 85 |               [l (cdr l)]]
 86 |           (append (map (λ (snd) (cons fst snd)) l) (all-distinct-pairs l)))))
 87 |   
 88 |   ; symbol-begins-with? : symbol -> (char -> bool) -> bool
 89 |   (define (symbol-begins-with? sym pred)
 90 |     (and (symbol? sym)
 91 |          (> (string-length (symbol->string sym)) 0)
 92 |          (pred (string-ref (symbol->string sym) 0))))
 93 |   
 94 |   ; symbol-upper-case? : symbol -> bool
 95 |   ; Does a symbol begin with an upper-case letter?
 96 |   (define (symbol-upper-case? sym)
 97 |     (symbol-begins-with? sym char-upper-case?))
 98 |   
 99 |   ; symbol-lower-case? : symbol -> bool
100 |   ; Does a symbol begin with a lower-case letter?
101 |   (define (symbol-lower-case? sym)
102 |     (symbol-begins-with? sym char-lower-case?))
103 |   
104 |   ; string-prefix? : string -> string -> bool
105 |   ; Does 'string' begin with 'prefix'?
106 |   (define (string-prefix? prefix string)
107 |     (and (>= (string-length string) (string-length prefix))
108 |          (string=? prefix (substring string 0 (string-length prefix)))))
109 |   
110 |   ; strip-prefix : string -> string -> string | #f
111 |   ; Strip 'prefix' off of the front of 'string', else return #f
112 |   (define (strip-prefix prefix string)
113 |     (if (string-prefix? prefix string)
114 |         (substring string (string-length prefix))
115 |         #f))
116 |   
117 |   ; symbol-prefix? : string -> symbol -> bool
118 |   ; Does 'symbol' begin with 'prefix'?
119 |   (define (symbol-prefix? prefix symbol)
120 |     (and (symbol? symbol) (string-prefix? prefix (symbol->string symbol))))
121 |   
122 |   ; show : any -> string
123 |   (define (show x) (format "~a" x))
124 |   
125 |   ; shows : list<any> -> string
126 |   (define (shows xs) (string-join (map show xs) " "))
127 |   
128 |   ; set-debug! : bool -> void
129 |   (define (set-debug! x)
130 |     (set! use-debug x))
131 |   
132 |   ; use-debug : bool
133 |   (define use-debug #f)
134 |     
135 |   ; debug : format-str format-arg ... -> void
136 |   (define-syntax-rule (debug str arg ...)
137 |     (when use-debug (display (format str arg ...))))
138 | 
139 |   ; fail : format-str format-arg ... -> void
140 |   (define-syntax-rule (fail str arg ...)
141 |     (error (format str arg ...)))
142 |   
143 |   ; define-setting : symbol symbol any
144 |   ; Define a global mutable setting, e.g., for debugging
145 |   (define-syntax-rule (define-setting setting-name setter-id init-val)
146 |     (begin
147 |       (define setting-name init-val)
148 |       (define (setter-id new-val)
149 |         (set! setting-name new-val))))
150 |   
151 |   ; The define-setting test, which tests setting settings with define-setting.
152 |   (define-setting define-setting-test-setting set-define-setting-test-setting! #f)
153 |   (define (get-define-setting-test-setting) define-setting-test-setting)
154 | )


--------------------------------------------------------------------------------
/prototype/r6rs-macros.scm:
--------------------------------------------------------------------------------
  1 | 
  2 | ; TRICKY: let
  3 | ; UNENCODABLE (3): case, letrec*, let-values-helper2
  4 | ; ALMOST (3): and, or, letrec
  5 | ; DISJOINT (6): cond, let*, letrec-helper, let-values,
  6 | ;               let-values-helper1, let*-values
  7 | 
  8 | ; TRICKY!!!
  9 | (define-syntax let
 10 |   (syntax-rules ()
 11 | 	((let ((name val) ...) body1 body2 ...)
 12 | 	 ((lambda (name ...) body1 body2 ...)
 13 | 	  val ...))
 14 | 	((let tag ((name val) ...) body1 body2 ...)
 15 | 	 ((letrec ((tag (lambda (name ...)
 16 | 					  body1 body2 ...)))
 17 | 		tag)
 18 | 	  val ...))))
 19 | 
 20 | ; TRICKY!!!
 21 | (define-syntax let-values-helper2
 22 |   ;; create temporaries for the formals
 23 |   (syntax-rules ()
 24 | 	((let-values-helper2
 25 | 	  ()
 26 | 	  temp-formals
 27 | 	  expr1
 28 | 	  assocs
 29 | 	  bindings
 30 | 	  body1 body2 ...)
 31 | 	 (call-with-values
 32 | 		 (lambda () expr1)
 33 | 	   (lambda temp-formals
 34 | 		 (let-values-helper1
 35 | 		  assocs
 36 | 		  bindings
 37 | 		  body1 body2 ...))))
 38 | 	((let-values-helper2
 39 | 	  (first . rest)
 40 | 	  (temp ...)
 41 | 	  expr1
 42 | 	  (assoc ...)
 43 | 	  bindings
 44 | 	  body1 body2 ...)
 45 | 	 (let-values-helper2
 46 | 	  rest
 47 | 	  (temp ... newtemp)
 48 | 	  expr1
 49 | 	  (assoc ... (first newtemp))
 50 | 	  bindings
 51 | 	  body1 body2 ...))
 52 | 	((let-values-helper2
 53 | 	  rest-formal
 54 | 	  (temp ...)
 55 | 	  expr1
 56 | 	  (assoc ...)
 57 | 	  bindings
 58 | 	  body1 body2 ...)
 59 | 	 (call-with-values
 60 | 		 (lambda () expr1)
 61 | 	   (lambda (temp ... . newtemp)
 62 | 		 (let-values-helper1
 63 | 		  (assoc ... (rest-formal newtemp))
 64 | 		  bindings
 65 | 		  body1 body2 ...))))))
 66 | 
 67 | ; ALMOST DISJOINT
 68 | (define-syntax and
 69 |   (syntax-rules ()
 70 |     ((and) #t)
 71 |     ((and test) test)
 72 |     ((and test1 test2 ...)
 73 |      (if test1 (and test2 ...) #f))))
 74 | 
 75 | ; ALMOST DISJOINT
 76 | (define-syntax or
 77 |   (syntax-rules ()
 78 |     ((or) #f)
 79 |     ((or test) test)
 80 |     ((or test1 test2 ...)
 81 |      (let ((x test1))
 82 | 	   (if x x (or test2 ...))))))
 83 | 
 84 | ; ALMOST DISJOINT
 85 | (define-syntax case
 86 |   (syntax-rules (else)
 87 | 	((case expr0
 88 | 	   ((key ...) res1 res2 ...)
 89 | 	   ...
 90 | 	   (else else-res1 else-res2 ...))
 91 | 	 (let ((tmp expr0))
 92 | 	   (cond
 93 | 		((memv tmp ’(key ...)) res1 res2 ...)
 94 | 		...
 95 | 		(else else-res1 else-res2 ...))))
 96 | 	((case expr0
 97 | 	   ((keya ...) res1a res2a ...)
 98 | 	   ((keyb ...) res1b res2b ...)
 99 | 	   ...)
100 | 	 (let ((tmp expr0))
101 | 	   (cond
102 | 		((memv tmp ’(keya ...)) res1a res2a ...)
103 | 		((memv tmp ’(keyb ...)) res1b res2b ...)
104 | 		...)))))
105 | 
106 | ; ALMOST DISJOINT
107 | (define-syntax letrec
108 |   (syntax-rules ()
109 | 	((letrec () body1 body2 ...)
110 | 	 (let () body1 body2 ...))
111 | 	((letrec ((var init) ...) body1 body2 ...)
112 | 	 (letrec-helper
113 | 	  (var ...)
114 | 	  ()
115 | 	  ((var init) ...)
116 | 	  body1 body2 ...))))
117 | 
118 | ; DISJOINT?
119 | (define-syntax cond
120 |   (syntax-rules (else =>)
121 |     ((cond (else result1 result2 ...))
122 |      (begin result1 result2 ...))
123 |     ((cond (test => result))
124 |      (let ((temp test))
125 |        (if temp (result temp))))
126 |     ((cond (test => result) clause1 clause2 ...)
127 |      (let ((temp test))
128 |        (if temp
129 |            (result temp)
130 |            (cond clause1 clause2 ...))))
131 | 	((cond (test)) test)
132 | 	((cond (test) clause1 clause2 ...)
133 | 	 (let ((temp test))
134 | 	   (if temp
135 | 		   temp
136 | 		   (cond clause1 clause2 ...))))
137 | 	((cond (test result1 result2 ...))
138 | 	 (if test (begin result1 result2 ...)))
139 | 	((cond (test result1 result2 ...)
140 | 		   clause1 clause2 ...)
141 | 	 (if test
142 | 		 (begin result1 result2 ...)
143 | 		 (cond clause1 clause2 ...)))))
144 | 
145 | ; DISJOINT
146 | (define-syntax let*
147 |   (syntax-rules ()
148 | 	((let* () body1 body2 ...)
149 | 	 (let () body1 body2 ...))
150 | 	((let* ((name1 expr1) (name2 expr2) ...)
151 | 	   body1 body2 ...)
152 | 	 (let ((name1 expr1))
153 | 	   (let* ((name2 expr2) ...)
154 | 		 body1 body2 ...)))))
155 | 
156 | ; DISJOINT
157 | (define-syntax letrec-helper
158 |   (syntax-rules ()
159 | 	((letrec-helper
160 | 	  ()
161 | 	  (temp ...)
162 | 	  ((var init) ...)
163 | 	  body1 body2 ...)
164 | 	 (let ((var <undefined>) ...)
165 | 	   (let ((temp init) ...)
166 | 		 (set! var temp)
167 | 		 ...)
168 | 	   (let () body1 body2 ...)))
169 | 	((letrec-helper
170 | 	  (x y ...)
171 | 	  (temp ...)
172 | 	  ((var init) ...)
173 | 	  body1 body2 ...)
174 | 	 (letrec-helper
175 | 	  (y ...)
176 | 	  (newtemp temp ...)
177 | 	  ((var init) ...)
178 | 	  body1 body2 ...))))
179 | 
180 | ; DISJOINT
181 | (define-syntax letrec*
182 |   (syntax-rules ()
183 | 	((letrec* ((var1 init1) ...) body1 body2 ...)
184 | 	 (let ((var1 <undefined>) ...)
185 | 	   (set! var1 init1)
186 | 	   ...
187 | 	   (let () body1 body2 ...)))))
188 | 
189 | ; DISJOINT
190 | (define-syntax let-values
191 |   (syntax-rules ()
192 | 	((let-values (binding ...) body1 body2 ...)
193 | 	 (let-values-helper1
194 | 	  ()
195 | 	  (binding ...)
196 | 	  body1 body2 ...))))
197 | 
198 | ; DISJOINT
199 | (define-syntax let-values-helper1
200 |   ;; map over the bindings
201 |   (syntax-rules ()
202 | 	((let-values
203 | 		 ((id temp) ...)
204 | 	   ()
205 | 	   body1 body2 ...)
206 | 	 (let ((id temp) ...) body1 body2 ...))
207 | 	((let-values
208 | 		 assocs
209 | 	   ((formals1 expr1) (formals2 expr2) ...)
210 | 	   body1 body2 ...)
211 | 	 (let-values-helper2
212 | 	  formals1
213 | 	  ()
214 | 	  expr1
215 | 	  assocs
216 | 	  ((formals2 expr2) ...)
217 | 	  body1 body2 ...))))
218 | 
219 | ; DISJOINT
220 | (define-syntax let*-values
221 |   (syntax-rules ()
222 | 	((let*-values () body1 body2 ...)
223 | 	 (let () body1 body2 ...))
224 | 	((let*-values (binding1 binding2 ...)
225 | 	   body1 body2 ...)
226 | 	 (let-values (binding1)
227 | 	   (let*-values (binding2 ...)
228 | 		 body1 body2 ...)))))
229 | 


--------------------------------------------------------------------------------
/prototype/lang-min-macros.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require redex)
  4 | (require "resugar-redex.rkt")
  5 | (require "lang-min.rkt")
  6 | 
  7 |   ;;;;;;;;;;;;;;
  8 |   ;;; Macros ;;;
  9 |   ;;;;;;;;;;;;;;
 10 | 
 11 | ; * Sometimes a macro RHS must be wrapped in 'begin' for two reasons:
 12 | ;   - So that it's reduction shows as a step (otherwise, e.g. (or (+ 1 2)) -> 3)
 13 | ;   - So that a calling macro doesn't inadvertently tag a constant.
 14 | 
 15 | (define-macro Thunk
 16 |   [(Thunk body)
 17 |    (lambda unused body)])
 18 | 
 19 | (define-macro Force
 20 |   [(Force thunk)
 21 |    (apply thunk "unused")])
 22 | 
 23 | (define-macro Let
 24 |   [(Let x e b)
 25 |    (apply (lambda x b) e)])
 26 | 
 27 | (define-macro Or
 28 |   [(Or x) (begin x)]
 29 |   [(Or x y ys ...)
 30 |    (Let t x (if t t (! Or y ys ...)))])
 31 | 
 32 | (define-macro Letrec
 33 |   [(Letrec x e b)
 34 |    (Let x 0 (begin (set! x e) b))])
 35 | 
 36 | (define-macro Lambdas
 37 |   [(Lambdas [^ var] body)
 38 |    (lambda var body)]
 39 |   [(Lambdas [^ v1 v2 vs ...] body)
 40 |    (lambda v1 (Lambdas [^ v2 vs ...] body))])
 41 | 
 42 | (define-macro Lets
 43 |   [(Lets [^ [^ x e]] b)
 44 |    (apply (lambda x b) e)]
 45 |   [(Lets [^ [^ x e] y ys ...] b)
 46 |    (apply (lambda x (! Lets [^ y ys ...] b)) e)])
 47 | 
 48 | (define-macro Sets
 49 |   [(Sets [^ [^ x e]] b)
 50 |    (begin (set! x e) b)]
 51 |   [(Sets [^ [^ x e] y ys ...] b)
 52 |    (begin (set! x e) (! Sets [^ y ys ...] b))])
 53 | 
 54 | (define-macro Letrecs
 55 |   [(Letrecs [^ [^ x e] ...] b)
 56 |    (Lets [^ [^ x 0] ...]
 57 |          (begin (set! x e) ... b))])
 58 | 
 59 | (define-macro Cond
 60 |   [(Cond [^ $else x])   (begin x)] ; begin required so that a step is shown!
 61 |   [(Cond [^ x y])       (if x y (+ 0 0))]
 62 |   [(Cond [^ x y] z zs ...) (if x y (! Cond z zs ...))])
 63 | 
 64 | (define-macro AmbCond
 65 |   [(AmbCond [^ $else x])      (begin x)]
 66 |   [(AmbCond [^ x y])          (if x y (+ 0 0))]
 67 |   [(AmbCond [^ x y] z zs ...) (if x (amb y (! AmbCond z zs ...))
 68 |                                     (! AmbCond z zs ...))])
 69 | 
 70 | ; TODO: bug!
 71 | (define-macro Condfalse 
 72 |   [(Condfalse)
 73 |    (Cond [^ $else #f])])
 74 | 
 75 | (define-macro ProcessState
 76 |   [(_ "accept")
 77 |    (lambda stream
 78 |      (Cond
 79 |        [^ (eq? "" stream) #t]
 80 |        [^ $else (begin #f)]))]
 81 |   [(_ [^ label $-> targets ...] ...)
 82 |    (lambda stream
 83 |      (if (eq? "" stream) #f
 84 |          (Lets [^ [^ head (string-first stream)]
 85 |                   [^ tail (string-rest stream)]]
 86 |                (Cond
 87 |                 [^ (eq? label head)
 88 |                    (amb (! apply targets tail) ...)]
 89 |                 ...
 90 |                 [^ $else #f]))))])
 91 | 
 92 | (define-macro Automaton
 93 |   [(_ init-state
 94 |     [^ state $: response ...]
 95 |     ...)
 96 |    (Letrecs [^ [^ state (ProcessState response ...)] ...]
 97 |      (lambda x (! apply init-state x)))])
 98 | 
 99 | (define-macro List
100 |   [(List) empty]
101 |   [(List x xs ...) (cons x (List xs ...))])
102 | 
103 | (define-macro TwiceEvaled
104 |   [(TwiceEvaled x) 0]
105 |   [(TwiceEvaled x y z ...)
106 |    (apply (lambda w (TwiceEvaled x (+ z w) ...))
107 |           (apply (lambda v x) y))])
108 | 
109 | (define-macro Cdavr
110 |   [(Cdavr input)
111 |    (Letrecs [^ [^ init (λ x
112 |                   (if (eq? x "") #f
113 |                       (Lets [^ [^ head (string-first x)]
114 |                                [^ tail (string-rest x)]]
115 |                             (Cond [^ (eq? "c" head) (! apply more tail)]
116 |                                   [^ $else #f]))))]
117 |                [^ more (λ x
118 |                   (if (eq? x "") #f
119 |                       (Lets [^ [^ head (string-first x)]
120 |                                [^ tail (string-rest x)]]
121 |                             (Cond [^ (eq? "a" head) (! apply more tail)]
122 |                                   [^ (eq? "d" head) (! apply more tail)]
123 |                                   [^ (eq? "r" head) (! apply end tail)]
124 |                                   [^ $else #f]))))]
125 |                [^ end (λ x
126 |                   (eq? x ""))]]
127 |      (! apply init input))])
128 | 
129 | 
130 | 
131 | 
132 | 
133 | ;;; Tests are here ;;;
134 | 
135 | ; uncomment the tests you want to run
136 | 
137 | (test-eval (Cond [^ (empty? (cons 1 2)) 3] [^ #f 4] [^ $else (+ 5 6)]))
138 | 
139 | #;(begin
140 | (test-eval (+ 1 2))
141 | (test-eval (apply (lambda x (+ x 1)) (+ 1 2)))
142 | (test-eval (Let x 3 (+ x x)))
143 | (test-eval (Letrec x (lambda y x) (apply x 6)))
144 | (test-eval (Cond (^ #f (+ 1 2))))
145 | (test-eval (Lets [^ [^ x 1] [^ y 2]] (+ x y)))
146 | (test-eval (Letrecs [^ [^ x 1]] x))
147 | (test-eval (Letrecs [^ [^ x 1] [^ y 2]] (+ x y)))
148 | (test-eval (+ 1 (Cond [^ #f (+ 1 2)] [^ (Or #f #t) (+ 2 3)])))
149 | (test-eval (Or (eq? 1 2) (eq? 2 2) (eq? 3 2)))
150 | (test-eval (Lets [^ [^ f (λ x (+ x 1))]] (apply f 3)))
151 | (test-eval (Cdavr "cadr"))
152 | (test-eval (Cdavr "cdad"))
153 | (test-eval (Letrecs [^ [^ y (+ x 1)] [^ x 1]] (+ x y)))
154 | (test-eval
155 |  (Let M (Automaton
156 |          init
157 |          [^ init $: [^ "c" $-> more]]
158 |          [^ more $: [^ "a" $-> more]
159 |                     [^ "d" $-> more]
160 |                     [^ "r" $-> end]]
161 |          [^ end $:  "accept"])
162 |    (apply M "cadr")))
163 | (test-trace
164 |  (Let M (Automaton
165 |          init
166 |          [^ init $: [^ "c" $-> more]]
167 |          [^ more $: [^ "a" $-> more]
168 |                     [^ "d" $-> more]
169 |                     [^ "r" $-> end init]]
170 |          [^ end $:  "accept"])
171 |    (apply M "carcadr")))
172 | (test-eval
173 |  (Let M (Automaton
174 |          init
175 |          [^ init $: [^ "c" $-> more]]
176 |          [^ more $: [^ "a" $-> more]
177 |                     [^ "d" $-> more]
178 |                     [^ "r" $-> end]]
179 |          [^ end $:  "accept"])
180 |    (apply M "cdad")))
181 | 
182 | (test-trace (amb (+ 1 2) (+ 3 4) (+ 5 6)))
183 | (test-trace (AmbCond [^ #t (+ 1 2)]
184 |                      [^ #f (+ 3 4)]
185 |                      [^ #t (+ 5 6)]))
186 | 
187 | (test-eval (Letrecs [^ [^ f (λ n (if (eq? n 0) 77 (apply f (! + 0 0))))]]
188 |                     (apply f (+ 1 2))))
189 | )


--------------------------------------------------------------------------------
/confection/Grammar.hs:
--------------------------------------------------------------------------------
  1 | module Grammar where
  2 | 
  3 | import qualified Data.Map as Map
  4 | import Data.Map (Map)
  5 | import Control.Monad (liftM, zipWithM_)
  6 | 
  7 | 
  8 | import Pattern hiding (unify)
  9 | 
 10 | 
 11 | newtype SortName = SortN String
 12 |                  deriving (Eq, Ord)
 13 | 
 14 | data Sort = SortName SortName
 15 |           | SortList Sort
 16 |           | IntSort
 17 |           | FloatSort
 18 |           | StringSort
 19 |           | AnySort
 20 |           deriving (Eq)
 21 | 
 22 | data Grammar = Grammar [Production]
 23 |              deriving (Eq)
 24 | 
 25 | data Production = Production Constructor SortName
 26 |                   deriving (Eq)
 27 | 
 28 | data Constructor = Constructor Label [Sort]
 29 |                    deriving (Eq)
 30 | 
 31 | data Rules = Rules [Rule]
 32 |            deriving (Eq)
 33 | 
 34 | data Language = Language Grammar Grammar
 35 |               deriving (Eq)
 36 | 
 37 | data Module = Module Language Language Rules
 38 |             deriving (Eq)
 39 | 
 40 | data CompiledModule =
 41 |   CompiledModule CompiledLanguage CompiledLanguage MacroTable
 42 | 
 43 | data CompiledLanguage =
 44 |   CompiledLanguage ProductionTable
 45 | 
 46 | type ProductionTable = Map Label Production
 47 | 
 48 | data SortError = SortUnifyFailure Sort Sort
 49 |                | NoSuchConstructor Label
 50 |                | WrongArity Pattern Int
 51 |                | InvalidRule Rule
 52 |                | SortErrorInRule SortError Rule
 53 | 
 54 | data CompilationError = SortError SortError
 55 |                       | WFError WFError
 56 | 
 57 | data ConformanceError = NonConformant Term Sort
 58 |                       | NonConformantC Label
 59 | 
 60 | 
 61 | rulesToMacros :: Rules -> MacroTable
 62 | rulesToMacros (Rules rs) = f (reverse rs) Map.empty
 63 |   where
 64 |     f [] ms = ms
 65 |     f (c@(Rule (PNode _ l _) _ _ _) : rs) ms =
 66 |       let ms' = case Map.lookup l ms of
 67 |             Nothing ->
 68 |               Map.insert l (Macro l [c]) ms
 69 |             Just (Macro l cs) ->
 70 |               Map.insert l (Macro l (c : cs)) ms
 71 |       in f rs ms'
 72 |     f _ _ = internalError
 73 |             "rulesToMacros: invalid rule not caught by sort checking."
 74 | 
 75 | -- TODO: check for duplicates
 76 | grammarToProductionTable :: Grammar -> ProductionTable
 77 | grammarToProductionTable (Grammar ps) =
 78 |   convert ps Map.empty
 79 |     where
 80 |       convert [] m = m
 81 |       convert (p@(Production (Constructor l ss) s) : ps) m =
 82 |         convert ps (Map.insert l p m)
 83 | 
 84 | compileModule :: Module -> Either CompilationError CompiledModule
 85 | compileModule (Module l1 l2 rs) =
 86 |   let l1' = compileLanguage l1
 87 |       l2' = compileLanguage l2
 88 |       Language (Grammar g1) (Grammar g2) = l1
 89 |       Language (Grammar g3) (Grammar g4) = l2
 90 |       wholeGrammar = Grammar (g1 ++ g2 ++ g3 ++ g4)
 91 |       ms = rulesToMacros rs
 92 |       table = grammarToProductionTable wholeGrammar in do
 93 |   sortCheckRules table rs
 94 |   wfCheck (Map.elems ms)
 95 |   return (CompiledModule l1' l2' ms)
 96 |     where
 97 |       wfCheck ms = case mapM_ wellFormedMacro ms of
 98 |         Left err -> Left (WFError err)
 99 |         Right () -> Right ()
100 | 
101 | compileLanguage :: Language -> CompiledLanguage
102 | compileLanguage (Language (Grammar g1) (Grammar g2)) =
103 |   let g = Grammar (g1 ++ g2) in
104 |   CompiledLanguage (grammarToProductionTable g)
105 | 
106 | constToSort :: Const -> Sort
107 | constToSort (CInt _) = IntSort
108 | constToSort (CDbl _) = FloatSort
109 | constToSort (CStr _) = StringSort
110 | 
111 | termConforms :: ProductionTable -> Sort -> Term ->
112 |                 Either ConformanceError ()
113 | termConforms g s t =
114 |   let nonconformant = Left (NonConformant t s)
115 |       noSuchConstructor l = Left (NonConformantC l) in
116 |   case t of
117 |     TConst c -> if constToSort c == s
118 |                 then return ()
119 |                 else nonconformant
120 |     TList ts -> case s of
121 |       SortList s -> mapM_ (termConforms g s) ts
122 |       _ -> nonconformant
123 |     TTag _ t -> termConforms g s t
124 |     TNode l ts -> case Map.lookup l g of
125 |       Nothing -> noSuchConstructor l
126 |       Just (Production (Constructor l' ss) s') ->
127 |         if l == l' && length ts == length ss && s == SortName s'
128 |         then zipWithM_ (termConforms g) ss ts
129 |         else nonconformant
130 | 
131 | sortCheckRules :: ProductionTable -> Rules -> Either CompilationError ()
132 | sortCheckRules g (Rules rs) = mapM_ checkRule rs
133 |   where
134 |     checkRule r = case sortCheckRule g r of
135 |       Left err -> Left (SortError (SortErrorInRule err r))
136 |       Right () -> return ()
137 | 
138 | sortCheckRule :: ProductionTable -> Rule -> Either SortError ()
139 | sortCheckRule g rule@(Rule p q fs _) = do
140 |   case p of
141 |     PNode _ l _ -> do
142 |       case Map.lookup l g of
143 |         Nothing -> Left (NoSuchConstructor l)
144 |         Just (Production c s0) -> do
145 |           s <- sortInfer g p
146 |           s' <- sortInfer g q
147 |           unify s (SortName s0)
148 |           unify s' (SortName s0)
149 |           return ()
150 |     _ -> Left (InvalidRule rule)
151 | 
152 | sortInfer :: ProductionTable -> Pattern -> Either SortError Sort
153 | -- Infer the sort of a pattern.
154 | sortInfer _ (PVar v) = return AnySort -- no duplicate vars, so no unification
155 | sortInfer _ (PConst (CInt _)) = return IntSort
156 | sortInfer _ (PConst (CDbl _)) = return FloatSort
157 | sortInfer _ (PConst (CStr _)) = return StringSort
158 | sortInfer g (PList ps) =
159 |   liftM SortList (unifies =<< (mapM (sortInfer g) ps))
160 | sortInfer g (PRep ps p) =
161 |   liftM SortList (unifies =<< (mapM (sortInfer g) (p:ps)))
162 | sortInfer g (PNode _ l ps) =
163 |   case Map.lookup l g of
164 |     Nothing -> Left (NoSuchConstructor l)
165 |     Just (Production (Constructor _ ss) s) ->
166 |       if length ss /= length ps
167 |       then Left (WrongArity (PNode noInfo l ps) (length ss))
168 |       else do
169 |         zipWithM_ (sortCheck g) ps ss
170 |         return (SortName s)
171 | sortInfer _ (PTag _ _) =
172 |   internalError "Tag encountered while checking sorts."
173 | 
174 | sortCheck :: ProductionTable -> Pattern -> Sort -> Either SortError Sort
175 | -- Ensure that a pattern has a given sort.
176 | sortCheck g p s = do
177 |   s' <- sortInfer g p
178 |   unify s s'
179 | 
180 | unifies :: [Sort] -> Either SortError Sort
181 | unifies [] = return AnySort
182 | unifies [s] = return s
183 | unifies (s1:s2:ss) = do
184 |   s <- unify s1 s2
185 |   unifies (s:ss)
186 |     
187 | unify :: Sort -> Sort -> Either SortError Sort
188 | unify AnySort      s                       = return s
189 | unify s            AnySort                 = return s
190 | unify (SortName n) (SortName n') | n == n' = return (SortName n)
191 | unify (SortList s) (SortList s')           = liftM SortList (unify s s')
192 | unify IntSort      IntSort                 = return IntSort
193 | unify FloatSort    FloatSort               = return FloatSort
194 | unify StringSort   StringSort              = return StringSort
195 | unify s            s'                      = Left (SortUnifyFailure s s')
196 | 


--------------------------------------------------------------------------------
/prototype/r6rs-macros.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | (require "resugar.rkt")
  4 | (require "resugar-racket.rkt")
  5 | 
  6 | ; All macros defined in R6RS
  7 | 
  8 | ; Translatable (7/9):
  9 | ;   Let And Or Letrec Cond Let* Letrec*
 10 | ; Not translatable (1/9):
 11 | ;   Let-values
 12 | ; Translatable, but stepper doesn't support (1/9):
 13 | ;   Case
 14 | 
 15 | ; NOT DISJOINT!
 16 | (define-macro Let
 17 |   ((Let (^ (^ name val) ...) body1 body2 ...)
 18 |    ((lambda (name ...) body1 body2 ...)
 19 |     val ...)))
 20 | ;  ((Let tag ((name val) ...) body1 body2 ...)
 21 | ;   ((Letrec ((tag (lambda (name ...)
 22 | ;                    body1 body2 ...)))
 23 | ;            tag)
 24 | ;    val ...))))
 25 | 
 26 | ; ALMOST DISJOINT
 27 | (define-macro And
 28 |   ((And) #t)
 29 |   ((And test) test)
 30 |   ((And test1 test2 tests ...)
 31 |    (if test1 (! And test2 tests ...) #f)))
 32 | 
 33 | ; ALMOST DISJOINT
 34 | (define-macro Or
 35 |   ((Or) #f)
 36 |   ((Or test) test)
 37 |   ((Or test1 test2 tests ...)
 38 |    (Let (^ (^ x test1))
 39 |         (if x x (! Or test2 tests ...)))))
 40 | 
 41 | ; ALMOST DISJOINT
 42 | (define-macro Case
 43 |   ((Case expr0
 44 |      (^ (^ key ...) res1 res2 ...)
 45 |      ...
 46 |      (^ $else else-res1 else-res2 ...))
 47 |    (Let (^ (^ tmp expr0))
 48 |         (Cond
 49 |           (^ (memv tmp ’(key ...)) res1 res2 ...)
 50 |           ...
 51 |           ($else else-res1 else-res2 ...))))
 52 |   ((Case expr0
 53 |      (^ (^ keya ...) res1a res2a ...)
 54 |      ;((keyb ...) res1b res2b ...)
 55 |      ...)
 56 |    (Let (^ (^ tmp expr0))
 57 |         (Cond
 58 |           (^ (memv tmp ’(keya ...)) res1a res2a ...)
 59 |           ;(^ (memv tmp ’(keyb ...)) res1b res2b ...)
 60 |           ...))))
 61 | 
 62 | ; ALMOST DISJOINT
 63 | (define-macro Letrec
 64 |   ((Letrec (^) body1 body2 ...)
 65 |    (Let (^) body1 body2 ...))
 66 |   ((Letrec (^ (^ var init) (^ vars inits) ...) body1 body2 ...)
 67 |    (Letrec-helper
 68 |     (^ var vars ...)
 69 |     (^)
 70 |     (^ (^ var init) (^ vars inits) ...)
 71 |     body1 body2 ...)))
 72 | 
 73 | ; DISJOINT?
 74 | (define-macro Cond
 75 |   ((Cond (^ $else result1 result2 ...))
 76 |    (begin result1 result2 ...))
 77 |   ((Cond (^ test $=> result))
 78 |    (Let ((temp test))
 79 |         (if temp (result temp))))
 80 |   ((Cond (^ test $=> result) clause1 clause2 ...)
 81 |    (Let ((temp test))
 82 |         (if temp
 83 |             (result temp)
 84 |             (Cond clause1 clause2 ...))))
 85 |   ((Cond (^ test)) test)
 86 |   ((Cond (^ test) clause1 clause2 ...)
 87 |    (Let (^ (^ temp test))
 88 |         (if temp
 89 |             temp
 90 |             (Cond clause1 clause2 ...))))
 91 |   ((Cond (^ test result1 result2 ...))
 92 |    (if test (begin result1 result2 ...)))
 93 |   ((Cond (^ test result1 result2 ...)
 94 |          clause1 clause2 ...)
 95 |    (if test
 96 |        (begin result1 result2 ...)
 97 |        (Cond clause1 clause2 ...))))
 98 | 
 99 | ; DISJOINT
100 | (define-macro Let*
101 |   ((Let* (^) body1 body2 ...)
102 |    (Let (^) body1 body2 ...))
103 |   ((Let* (^ (^ name1 expr1) (^ name2 expr2) ...)
104 |          body1 body2 ...)
105 |    (Let (^ (^ name1 expr1))
106 |         (Let* (^ (^ name2 expr2) ...)
107 |               body1 body2 ...))))
108 | 
109 | ; DISJOINT
110 | (define-macro Letrec-helper
111 |   ((Letrec-helper
112 |     (^)
113 |     (^ temp ...)
114 |     (^ (^ var init) ...)
115 |     body1 body2 ...)
116 |    (Let (^ (^ var (void)) ...)
117 |         (Let (^ (^ temp init) ...)
118 |              (set! var temp)
119 |              ...)
120 |         (Let (^) body1 body2 ...)))
121 |   ((Letrec-helper
122 |     (^ x y ...)
123 |     (^ temp ...)
124 |     (^ (^ var init) ...)
125 |     body1 body2 ...)
126 |    (Letrec-helper
127 |     (^ y ...)
128 |     (^ magic-gensym temp ...) ; magic-gensym should be newtemp -- hygene problem
129 |     (^ (^ var init) ...)
130 |     body1 body2 ...)))
131 | 
132 | ; DISJOINT
133 | (define-macro Letrec*
134 |   ((Letrec* (^ (^ var1 init1) ...) body1 body2 ...)
135 |    (Let (^ (^ var1 (void)) ...)
136 |         (set! var1 init1)
137 |         ...
138 |         (Let (^) body1 body2 ...))))
139 | 
140 | #|
141 | ; DISJOINT
142 | (define-macro Let-values
143 |   ((Let-values (^ binding ...) body1 body2 ...)
144 |    (Let-values-helper1
145 |     (^)
146 |     (^ binding ...)
147 |     body1 body2 ...)))
148 | 
149 | ; DISJOINT
150 | (define-macro Let-values-helper1
151 |   ;; map over the bindings
152 |   ((Let-values
153 |     (^ (^ id temp) ...)
154 |     (^)
155 |     body1 body2 ...)
156 |    (Let (^ (^ id temp) ...) body1 body2 ...))
157 |   ((Let-values
158 |     assocs
159 |     (^ (^ formals1 expr1) (^ formals2 expr2) ...)
160 |     body1 body2 ...)
161 |    (Let-values-helper2
162 |     formals1
163 |     (^)
164 |     expr1
165 |     assocs
166 |     (^ (^ formals2 expr2) ...)
167 |     body1 body2 ...)))
168 | 
169 | ; TRICKY!!!
170 | (define-macro Let-values-helper2
171 |   ;; create temporaries for the formals
172 |   ((Let-values-helper2
173 |     (^)
174 |     temp-formals
175 |     expr1
176 |     assocs
177 |     bindings
178 |     body1 body2 ...)
179 |    (call-with-values
180 |     (lambda () expr1)
181 |     (lambda temp-formals
182 |       (Let-values-helper1
183 |        assocs
184 |        bindings
185 |        body1 body2 ...))))
186 |   ((Let-values-helper2
187 |     (^ first rest ...)
188 |     (^ temp ...)
189 |     expr1
190 |     (^ assoc ...)
191 |     bindings
192 |     body1 body2 ...)
193 |    (Let-values-helper2
194 |     (^ rest ...)
195 |     (^ temp ... newtemp)
196 |     expr1
197 |     (^ assoc ... (first newtemp))
198 |     bindings
199 |     body1 body2 ...))
200 |   ((Let-values-helper2
201 |     rest-formal
202 |     (^ temp ...)
203 |     expr1
204 |     (^ assoc ...)
205 |     bindings
206 |     body1 body2 ...)
207 |    (call-with-values
208 |     (lambda () expr1)
209 |     (lambda (temp ... . newtemp)
210 |       (Let-values-helper1
211 |        (^ assoc ... (rest-formal newtemp))
212 |        bindings
213 |        body1 body2 ...)))))
214 | 
215 | (set-debug-steps! #f)
216 | 
217 | ; DISJOINT
218 | (define-macro Let*-values
219 |   ((Let*-values (^) body1 body2 ...)
220 |    (Let (^) body1 body2 ...))
221 |   ((Let*-values (^ binding1 binding2 ...)
222 |                 body1 body2 ...)
223 |    (Let-values (^ binding1)
224 |                (Let*-values (^ binding2 ...)
225 |                             body1 body2 ...))))
226 | |#
227 | 
228 | ; Illustrates the problem with Case: the stepper doesn't support quotation.
229 | (define-macro Q
230 |   [(Q x) 'x])
231 | 
232 | (test-eval (Let [^ [^ x 1]] x))
233 | (test-eval (Letrec (^) 3))
234 | (test-eval (Letrec [^ [^ x 1]] x))
235 | (test-eval (Let [^ [^ x 3]] x))
236 | (test-eval (Let [^ [^ x 1] [^ y (+ 1 2)]] (+ x y)))
237 | (test-eval (And #t #t #f #t))
238 | (test-eval (Or #f #f #t #f))
239 | (test-eval (Letrec [^ [^ x 1] [^ y 2]] (+ x y)))
240 | (test-eval (Letrec (^ [^ is-even? (lambda (n) (Or (zero? n) (is-odd? (sub1 n))))]
241 |                       [^ is-odd? (lambda (n) (And (not (zero? n)) (is-even? (sub1 n))))])
242 |                    (cons (is-even? 11) (is-odd? 11))))
243 | (test-eval (Let* [^ [^ x 1] [^ y x]] (+ x y)))
244 | (test-eval (Letrec* [^ [^ x 1] [^ y x]] (+ x y)))
245 | ; The following fail:
246 | ;(test-eval (Q 3))
247 | ;(test-eval (Case (* 2 3) (^ (^ 2 3 5 7) 'prime) (^ (^ 1 4 6 8 9) 'composite)))


--------------------------------------------------------------------------------
/confection/Parse.hs:
--------------------------------------------------------------------------------
  1 | module Parse where
  2 | 
  3 | import Prelude hiding (const)
  4 | import Text.ParserCombinators.Parsec hiding (label)
  5 | import qualified Text.ParserCombinators.Parsec.Token as P
  6 | import Control.Monad (liftM, liftM2, liftM3)
  7 | import Data.Maybe (maybe)
  8 | import Data.Set (Set)
  9 | import qualified Data.Set as Set
 10 | 
 11 | import Pattern
 12 | import Grammar
 13 | import Show
 14 | 
 15 | 
 16 | lexer = P.makeTokenParser $ P.LanguageDef {
 17 |   P.commentStart = "(*",
 18 |   P.commentEnd = "*)",
 19 |   P.commentLine = "#",
 20 |   P.nestedComments = True,
 21 |   P.identStart = upper,
 22 |   P.identLetter = letter <|> digit <|> char '_',
 23 |   P.opStart = lower,
 24 |   P.opLetter = letter <|> digit <|> char '_',
 25 |   P.reservedNames = [rulesStr, surfaceStr, coreStr,
 26 |                      intSortStr, floatSortStr, stringSortStr,
 27 |                      macHeadStr, macBodyStr, freshStr],
 28 |   P.reservedOpNames = [],
 29 |   P.caseSensitive = True
 30 |   }
 31 | stringLiteral = P.stringLiteral lexer
 32 | natural = P.natural lexer
 33 | integer = P.integer lexer
 34 | float = P.float lexer
 35 | space = P.whiteSpace lexer
 36 | symbol = P.symbol lexer
 37 | iden = P.identifier lexer
 38 | op = P.operator lexer
 39 | reservedOp = P.reservedOp lexer
 40 | 
 41 | commaSep = P.commaSep lexer
 42 | commaSep1 = P.commaSep1 lexer
 43 | parens = P.parens lexer
 44 | brackets = P.brackets lexer
 45 | braces = P.braces lexer
 46 | 
 47 | parse = Text.ParserCombinators.Parsec.parse
 48 | 
 49 | parseModule = Parse.parse top
 50 | parseTerm = Parse.parse term
 51 | 
 52 | top :: Parser Module
 53 | top = do
 54 |   symbol coreStr
 55 |   l1 <- language
 56 |   symbol surfaceStr
 57 |   l2 <- language
 58 |   rs <- rules
 59 |   return $ compile $ Module l1 l2 rs
 60 | 
 61 | compile :: Module -> Module
 62 | -- Fill in pattern `Info`s.
 63 | compile (Module l1@(Language (Grammar v1) _)
 64 |                 l2@(Language (Grammar v2) _) (Rules rs)) =
 65 |   Module l1 l2 (Rules (map fillRuleInfo rs))
 66 |     where
 67 |       ls = prodLabels (v1 ++ v2)
 68 |       
 69 |       prodLabels :: [Production] -> Set Label
 70 |       prodLabels = Set.fromList . map getLabel
 71 |         where getLabel (Production (Constructor l _) _) = l
 72 |     
 73 |       fillRuleInfo :: Rule -> Rule
 74 |       fillRuleInfo (Rule p q fs i) =
 75 |         Rule (fillPattInfo p) (fillPattInfo q) fs i
 76 |     
 77 |       fillPattInfo :: Pattern -> Pattern
 78 |       fillPattInfo (PVar v) = PVar v
 79 |       fillPattInfo (PConst c) = PConst c
 80 |       fillPattInfo (PNode (Info z _) l ps) =
 81 |         PNode (Info z (Set.member l ls)) l (map fillPattInfo ps)
 82 |       fillPattInfo (PRep ps p) =
 83 |         PRep (map fillPattInfo ps) (fillPattInfo p)
 84 |       fillPattInfo (PList ps) = PList (map fillPattInfo ps)
 85 |       fillPattInfo (PTag o p) = PTag o (fillPattInfo p)
 86 | 
 87 | language :: Parser Language
 88 | language = do
 89 |   symbol valueStr
 90 |   g1 <- grammar
 91 |   symbol constrStr
 92 |   g2 <- grammar
 93 |   return (Language g1 g2)
 94 | 
 95 | grammar :: Parser Grammar
 96 | grammar = do
 97 |   ps <- many production
 98 |   return (Grammar ps)
 99 | 
100 | production :: Parser Production
101 | production = try shortProduction <|> longProduction
102 |   where
103 |     longProduction :: Parser Production
104 |     longProduction = do
105 |       l <- label
106 |       symbol hasTypeStr
107 |       ss <- sort `sepBy` (symbol typeProdStr)
108 |       symbol typeArrowStr
109 |       s <- iden
110 |       symbol terminalStr
111 |       return (Production (Constructor l ss) (SortN s))
112 | 
113 |     shortProduction :: Parser Production
114 |     shortProduction = do
115 |       l <- label
116 |       symbol hasTypeStr
117 |       s <- iden
118 |       symbol terminalStr
119 |       return (Production (Constructor l []) (SortN s))
120 | 
121 | 
122 | sort :: Parser Sort
123 | sort = intSort <|> floatSort <|> stringSort <|> sortList <|> simpleSort
124 |   where
125 |     simpleSort = liftM SortName sortName
126 |     sortList = liftM SortList (brackets sort)
127 |     intSort = reservedOp intSortStr >> return IntSort
128 |     floatSort = reservedOp floatSortStr >> return FloatSort
129 |     stringSort = reservedOp stringSortStr >> return StringSort
130 | 
131 | rules :: Parser Rules
132 | rules = do
133 |   symbol rulesStr
134 |   rs <- many rule
135 |   return (Rules rs)
136 | 
137 | rule :: Parser Rule
138 | rule = do
139 |   p <- pattern
140 |   symbol rewriteStr
141 |   q <- pattern
142 |   fs <- many fresh
143 |   overlapFlag <- optionBool (symbol "unsafe_overlap")
144 |   symbol terminalStr
145 |   return (Rule p q fs (RuleFlags overlapFlag))
146 | 
147 | fresh :: Parser Var
148 | fresh = do
149 |   symbol freshStr
150 |   f <- op
151 |   return (Var f)
152 | 
153 | pattern :: Parser Pattern
154 | pattern = do
155 |   p <- untaggedPattern
156 |   ts <- optionMaybe tags
157 |   case ts of
158 |     Nothing -> return p
159 |     Just ts -> return (addTags ts p)
160 |   where
161 |     untaggedPattern :: Parser Pattern
162 |     untaggedPattern = pVar <|> pConst <|> pNode <|> pList
163 |       where
164 |         pVar = liftM PVar var
165 |         pConst = liftM PConst const
166 |         pList = brackets pListElems
167 |         pNode = do
168 |           transp <- optionBool (symbol transpStr)
169 |           l <- label
170 |           args <- optionMaybe (parens (commaSep pattern))
171 |           let nodeArgs = maybe [] id args
172 |           return (PNode (Info transp False) l nodeArgs) -- v filled in later
173 |         pListElems = do
174 |           xs <- commaSep pattern
175 |           r <- optionMaybe (symbol repStr)
176 |           case r of
177 |             Nothing -> return (PList xs)
178 |             Just _ -> case xs of
179 |               [] -> fail "Invalid list."
180 |               _:_ -> return (PRep (init xs) (last xs))
181 | 
182 |     addTags [] p = p
183 |     addTags (o:os) p = addTags os (PTag o p)
184 | 
185 | term :: Parser Term
186 | term = do
187 |   t <- untaggedTerm
188 |   os <- optionMaybe tags
189 |   case os of
190 |     Nothing -> return t
191 |     Just os -> return (addTags os t)
192 |   where    
193 |     untaggedTerm = tConst <|> tNode <|> tList
194 |       where
195 |         tConst = liftM TConst const
196 |         tNode = liftM2 TNode label (parens (commaSep term))
197 |         tList = liftM TList (brackets (commaSep term))
198 |     addTags [] t = t
199 |     addTags (o:os) t = addTags os (TTag o t)
200 | 
201 | tags :: Parser [Origin]
202 | tags = braces (brackets (commaSep origin))
203 | 
204 | const :: Parser Const
205 | const = try parseInt <|> parseDbl <|> parseStr
206 |   where
207 |     parseInt = liftM (CInt . fromIntegral) integer
208 |     parseDbl = liftM CDbl float
209 |     parseStr = liftM CStr stringLiteral
210 | 
211 | var :: Parser Var
212 | var = do
213 |   symbol varStr
214 |   t <- op
215 |   return (Var t)
216 | 
217 | sortName :: Parser SortName
218 | sortName = liftM SortN iden
219 | 
220 | origin :: Parser Origin
221 | origin = origBody <|> origTransp <|> origAlien <|> origHead
222 |   where
223 |     origBody = reservedOp macBodyStr >> return MacBody
224 |     origTransp = reservedOp macTranspBodyStr >> return MacTranspBody
225 |     origAlien = reservedOp macAlienStr >> return MacAlien
226 |     origHead = do
227 |       symbol macHeadStr
228 |       symbol "("
229 |       m <- label
230 |       symbol ","
231 |       i <- natural
232 |       symbol ","
233 |       t <- term
234 |       symbol ")"
235 |       return (MacHead m (fromIntegral i) t)
236 | 
237 | label :: Parser Label
238 | label = liftM Label iden
239 | 
240 | optionBool :: Parser a -> Parser Bool
241 | optionBool p = do
242 |   m <- optionMaybe p
243 |   return (maybe False (\_ -> True) m)
244 | 


--------------------------------------------------------------------------------
/confection/Show.hs:
--------------------------------------------------------------------------------
  1 | module Show (rulesStr, surfaceStr, coreStr, valueStr, constrStr,
  2 |              varStr, rewriteStr, assignStr, terminalStr, freshStr,
  3 |              hasTypeStr, typeProdStr, typeArrowStr, transpStr,
  4 |              intSortStr, floatSortStr, stringSortStr, repStr,
  5 |              macBodyStr, macTranspBodyStr, macAlienStr, macHeadStr, tagStr,
  6 |              showTerm) where
  7 | 
  8 | import Pattern
  9 | import Grammar
 10 | 
 11 | 
 12 | {- Syntax Parameters -}
 13 | 
 14 | surfaceStr = "surface"
 15 | coreStr = "core"
 16 | valueStr = "values"
 17 | constrStr = "constructors"
 18 | rulesStr = "rules"
 19 | freshStr = "fresh"
 20 | 
 21 | varStr = ""
 22 | rewriteStr = "->"
 23 | assignStr = "="
 24 | terminalStr = ";"
 25 | hasTypeStr = ":"
 26 | typeProdStr = "*"
 27 | typeArrowStr = "->"
 28 | repStr = "..."
 29 | transpStr = "!"
 30 | 
 31 | macBodyStr = "Body"
 32 | macTranspBodyStr = "!Body"
 33 | macHeadStr = "Head"
 34 | macAlienStr = "Alien"
 35 | tagStr = "Tag"
 36 | 
 37 | intSortStr = "Int"
 38 | floatSortStr = "Float"
 39 | stringSortStr = "String"
 40 | 
 41 | 
 42 | {- Printing -}
 43 | 
 44 | str = showString
 45 | 
 46 | sep :: String -> [ShowS] -> ShowS
 47 | sep _ []       = id
 48 | sep _ [x]      = x
 49 | sep s (x:y:ys) = x . str s . sep s (y:ys)
 50 | 
 51 | commaSep = sep ", "
 52 | spaceSep = sep " "
 53 | newlineSep = sep "\n"
 54 | 
 55 | surround :: String -> String -> ShowS -> ShowS
 56 | surround l r x = str l . x . str r
 57 | 
 58 | parens   = surround "(" ")"
 59 | brackets = surround "[" "]"
 60 | braces   = surround "{" "}"
 61 | 
 62 | instance Show Pattern where
 63 |   showsPrec _ (PVar v) = shows v
 64 |   showsPrec _ (PConst c) = shows c
 65 |   showsPrec _ (PList ps) = brackets (commaSep (map shows ps))
 66 |   showsPrec _ (PRep ps p) =
 67 |     brackets (commaSep (map shows ps ++ [shows p]) . str repStr)
 68 |   showsPrec _ (PTag o p) = showTags [o] p
 69 |     where
 70 |       showTags os (PTag o p) = showTags (o:os) p
 71 |       showTags os p          =
 72 |         shows p . braces (brackets (commaSep (map shows os)))
 73 |   showsPrec _ (PNode (Info z _) l []) = showTransp z . shows l
 74 |   showsPrec _ (PNode (Info z _) l ps) =
 75 |     showTransp z . shows l . parens (commaSep (map shows ps))
 76 | 
 77 | showTransp False = id
 78 | showTransp True = str transpStr
 79 | 
 80 | showTerm :: Bool -> Term -> ShowS
 81 | -- show-tags?, term
 82 | showTerm _ (TConst c) = shows c
 83 | showTerm z (TList ts) = brackets (commaSep (map (showTerm z) ts))
 84 | showTerm z (TNode l ts) = shows l . parens (commaSep (map (showTerm z) ts))
 85 | showTerm z (TTag o t) = if z then showTags [o] t else showTerm z t
 86 |   where
 87 |     showTags os (TTag o t) = showTags (o:os) t
 88 |     showTags os t =
 89 |       showTerm z t . braces (brackets (commaSep (map (showOrigin z) os)))
 90 | 
 91 | showOrigin :: Bool -> Origin -> ShowS
 92 | showOrigin z (MacHead m i t) =
 93 |   str macHeadStr . parens (commaSep [shows m, shows i, showTerm z t])
 94 | showOrigin _ MacAlien = str macAlienStr
 95 | showOrigin _ MacBody = str macBodyStr
 96 | showOrigin _ MacTranspBody = str macTranspBodyStr
 97 | 
 98 | instance Show Term where
 99 |   showsPrec _ t = showTerm True t
100 | 
101 | instance Show Origin where
102 |   showsPrec _ o = showOrigin True o
103 | 
104 | instance Show Const where
105 |   showsPrec _ (CInt x) = shows x
106 |   showsPrec _ (CDbl x) = shows x
107 |   showsPrec _ (CStr x) = shows x
108 | 
109 | instance Show Var where
110 |   showsPrec _ (Var v) = str varStr . str v
111 | 
112 | instance Show Binding where
113 |   showsPrec _ (BList bs) = brackets (commaSep (map shows bs))
114 |   showsPrec _ (BTerm t) = shows t
115 | 
116 | instance Show Macro where
117 |   showsPrec _ (Macro m cs) =
118 |     spaceSep [shows m, str assignStr, braces (commaSep (map shows cs))]
119 | 
120 | instance Show Rule where
121 |   showsPrec _ (Rule p q fs _) =
122 |     spaceSep ([shows p, str rewriteStr, shows q] ++
123 |               (map (\(Var f) -> str freshStr . str " " . str f) fs)) .
124 |     str terminalStr
125 | 
126 | instance Show SortName where
127 |   showsPrec _ (SortN s) = str s
128 | 
129 | instance Show Sort where
130 |   showsPrec _ AnySort = str "?"
131 |   showsPrec _ (SortName s) = shows s
132 |   showsPrec _ (SortList s) = brackets (shows s)
133 |   showsPrec _ IntSort = str intSortStr
134 |   showsPrec _ FloatSort = str floatSortStr
135 |   showsPrec _ StringSort = str stringSortStr
136 | 
137 | instance Show Constructor where
138 |   showsPrec _ (Constructor l ss) =
139 |     spaceSep [shows l, str hasTypeStr,
140 |               sep (" " ++ typeProdStr ++ " ") (map shows ss)]
141 | 
142 | instance Show Production where
143 |   showsPrec _ (Production c s) =
144 |     spaceSep [shows c, str typeArrowStr, shows s] . str terminalStr
145 | 
146 | instance Show Grammar where
147 |   showsPrec _ (Grammar ps) =
148 |     newlineSep (map shows ps)
149 | 
150 | instance Show Rules where
151 |   showsPrec _ (Rules rs) =
152 |     newlineSep (str rulesStr : map shows rs)
153 | 
154 | instance Show Language where
155 |   showsPrec _ (Language g1 g2) =
156 |     newlineSep [str valueStr, shows g1,
157 |                 str constrStr, shows g2]
158 | 
159 | instance Show Module where
160 |   showsPrec _ (Module l1 l2 rs) =
161 |     newlineSep [str coreStr, shows l1, str surfaceStr, shows l2, shows rs]
162 | 
163 | instance Show ResugarError where
164 |   showsPrec _ (NoMatchingCase l t cs) =
165 |     str "No matching case for constructor " . shows l .
166 |     str " with term " . shows t .
167 |     str ". The relevant rules are: " . shows (Rules cs)
168 |   showsPrec _ (NoSuchMacro l) =
169 |     str "The label " . shows l . str (" appears in a core term tag," ++
170 |       "but there is no corresponding desugaring rule.")
171 |   showsPrec _ (NoSuchCase l i) =
172 |     str "A tag refers to case " . shows i . str " in constructor " .
173 |     shows l . str ", but no such case exists."
174 |   showsPrec _ (UnboundSubsVar v) =
175 |     str "Unbound variable " . shows v
176 |   showsPrec _ (DepthMismatch v) =
177 |     str "The variable " . shows v . str " appears at an inappropriate depth."
178 | 
179 | instance Show ResugarFailure where
180 |   showsPrec _ (MatchFailure t p) =
181 |     str "Could not match " . shows t . str " against " . shows p
182 |   showsPrec _ TermIsOpaque =
183 |     str "The term being unexpanded is opaque"
184 |   showsPrec _ (ResugarError err) = shows err
185 | 
186 | instance Show SortError where
187 |   showsPrec _ (SortUnifyFailure s1 s2) =
188 |     str "Could not unify " . shows s1 . str " with " . shows s2
189 |   showsPrec _ (NoSuchConstructor l) =
190 |     str "There is no constructor named " . shows l
191 |   showsPrec _ (WrongArity p n) =
192 |     str "Expected arity " . shows n . str " in pattern " . shows p
193 |   showsPrec _ (InvalidRule r) =
194 |     str "Invalid rule: " . shows r
195 |   showsPrec _ (SortErrorInRule e r) =
196 |     shows e . str " in rule " . shows r
197 | 
198 | instance Show WFError where
199 |   showsPrec _ (CasesOverlap l p q pq) =
200 |     str "In the rules for sugar " . shows l . str ", cases " .
201 |     shows p . str " and " . shows q . str " overlap with unification " .
202 |     shows pq
203 |   showsPrec _ (UnboundVar v) =
204 |     str "The variable " . shows v . str " is unbound"
205 |   showsPrec _ (EmptyEllipsis l) =
206 |     str "In a rule for sugar " . shows l .
207 |     str ", an ellipsis pattern contains no variables."
208 |   showsPrec _ (DuplicateVar v) =
209 |     str "The variable " . shows v .
210 |     str " appears more than once in a pattern."
211 | 
212 | instance Show CompilationError where
213 |   showsPrec _ (SortError e) = shows e
214 |   showsPrec _ (WFError e) = shows e
215 | 
216 | instance Show ConformanceError where
217 |   showsPrec _ (NonConformant t s) =
218 |     str "Nonconformant term. The subterm " . shows t .
219 |     str " does not match the expected sort " . shows s
220 |   showsPrec _ (NonConformantC l) =
221 |     str "There is no constructor named " . shows l
222 | 


--------------------------------------------------------------------------------
/prototype/macro.rkt:
--------------------------------------------------------------------------------
  1 | (module macros racket
  2 |   (provide
  3 |    define-macro lookup-macro
  4 |    expand-pattern unexpand-pattern
  5 |    ; testing:
  6 |    unchecked-unexpand
  7 |    NotUnexpandable?
  8 |    Macro Macro-cases MacroCase expand-macro)
  9 |   (require "utility.rkt")
 10 |   (require "pattern.rkt")
 11 |   
 12 |   
 13 |   ;;; Defining Macros ;;;
 14 |   
 15 |   (struct MacroCase (left right) #:transparent)
 16 |   (struct Macro (name cases) #:transparent)
 17 |   
 18 |   (define global-macro-dictionary (make-hash)) ; { macro-name -> macro }
 19 |   
 20 |   (define-syntax (compile-macro stx)
 21 |     (syntax-case stx ()
 22 |       [(compile-macro name [(_ p ...) q] ...)
 23 |        (with-syntax ([(pc ...) (generate-temporaries #'((p ...) ...))] ; why (p ...)?
 24 |                      [(qc ...) (generate-temporaries #'(q ...))])
 25 |          #'(let [[pc (sexpr->pattern '(name p ...) #f #f)] ...]
 26 |            (let [[qc (sexpr->pattern 'q (set->list (free-vars pc)) #t)] ...]
 27 |              (validate-macro (Macro 'name (list (MacroCase pc qc) ...))))))]))
 28 |   
 29 |   
 30 |   (define-syntax-rule (define-macro name case ...)
 31 |     (hash-set! global-macro-dictionary 'name
 32 |                (compile-macro name case ...)))
 33 |   
 34 |   (define (lookup-macro name)
 35 |     (if (hash-has-key? global-macro-dictionary name)
 36 |         (hash-ref global-macro-dictionary name)
 37 |         #f))
 38 |   
 39 |   
 40 |   ;;; Validating Macros ;;;
 41 |   
 42 |   (define (check-wf-macro m)
 43 |     
 44 |     (define (check-wf-case c)
 45 |       
 46 |       (define (union-vars vs)
 47 |         (cond [(empty? vs) (set)]
 48 |               [(eq? (length vs) 1) (car vs)]
 49 |               [else (let [[overlap (set-intersect (car vs) (cadr vs))]]
 50 |                       (if (set-empty? overlap)
 51 |                           (union-vars (cons (set-union (car vs) (cadr vs))
 52 |                                             (cddr vs)))
 53 |                           (duplicate-var-failure m (first (set->list overlap)) c)))]))
 54 |       
 55 |       (define (check-wf-lhs p)
 56 |         (match p
 57 |           [(pvar v) (set v)]
 58 |           [(literal _) (set)]
 59 |           [(constant _) (set)]
 60 |           [(tag p _) (check-wf-lhs p)]
 61 |           [(plist _ ps) (union-vars (map check-wf-lhs ps))]
 62 |           [(ellipsis _ ps r qs)
 63 |            (let [[fvr (check-wf-lhs r)]]
 64 |              (if (set-empty? fvr)
 65 |                  (empty-ellipsis-failure m c)
 66 |                  (union-vars (append (map check-wf-lhs ps)
 67 |                                      (list fvr)
 68 |                                      (map check-wf-lhs qs)))))]))
 69 |       
 70 |       ; TODO: check that each var on the rhs appears under at least as many
 71 |       ;       ellipses as it does in the lhs.
 72 |       ; TODO: Figure out duplicate rhs variables.
 73 |       (define (check-wf-rhs p)
 74 |         (match p
 75 |           [(pvar v) (set v)]
 76 |           [(literal _) (set)]
 77 |           [(constant _) (set)]
 78 |           [(tag p _) (check-wf-rhs p)]
 79 |           [(plist _ ps) (set-unions (map check-wf-rhs ps))]
 80 |           [(ellipsis _ ps r qs)
 81 |            (let [[fvr (check-wf-rhs r)]]
 82 |              (if (set-empty? fvr)
 83 |                  (empty-ellipsis-failure m c)
 84 |                  (set-unions (append (map check-wf-rhs ps)
 85 |                                      (list fvr)
 86 |                                      (map check-wf-rhs qs)))))]))
 87 | 
 88 |       (begin (check-wf-lhs (MacroCase-left c))
 89 |              (check-wf-rhs (MacroCase-right c))))
 90 |     
 91 |     (for-each check-wf-case (Macro-cases m)))
 92 |   
 93 |   (define (validate-macro m)
 94 |     (define (validate-pair pair)
 95 |       (let* [[c1 (car pair)]
 96 |              [c2 (cdr pair)]
 97 |              [p1 (MacroCase-left c1)]
 98 |              [p2 (MacroCase-left c2)]
 99 |              [q1 (MacroCase-right c1)]
100 |              [q2 (MacroCase-right c2)]
101 |              [union (attempt-unification (unify p1 p2))]]
102 |         (when (not (unification-failure? union))
103 |           (validation-failure m c1 c2 union))))
104 | 
105 |     (begin (check-wf-macro m)
106 |            (for-each validate-pair (all-distinct-pairs (Macro-cases m)))
107 |            m))
108 |   
109 |   (define (show-macro-case c)
110 |     (format "[~a => ~a]"
111 |             (show-pattern (MacroCase-left c))
112 |             (show-pattern (MacroCase-right c))))
113 |   
114 |   (define (validation-failure m c1 c2 p)
115 |     (fail "Invalid macro ~a. Cases ~a and ~a overlap on input ~a."
116 |           (Macro-name m) (show-macro-case c1) (show-macro-case c2) (show-pattern p)))
117 |   
118 |   (define (duplicate-var-failure m v c)
119 |     (fail "Invalid macro ~a. Duplicate variable ~a in case ~a."
120 |           (Macro-name m) v (show-macro-case c)))
121 |   
122 |   (define (empty-ellipsis-failure m c)
123 |     (fail "Invaid macro ~a. Variableless ellipsis in case ~a."
124 |           (Macro-name m) (show-macro-case c)))
125 |   
126 |   
127 |   ;;; Expanding & Unexpanding Macros ;;;
128 |   
129 |   (struct NotUnexpandable (pattern) #:transparent)
130 |   
131 |   (define (expand-macro m x [i 0])
132 |     (define (insert-orig-env e p i)
133 |       (tag p (o-macro (Macro-name m) i e)))
134 |     (match m
135 |       [(Macro name (list))
136 |        (fail "No matching pattern in macro ~a for ~a" name (show-pattern x))]
137 |       [(Macro name (cons (MacroCase p q) cs))
138 |        (let* [[e (attempt-unification (minus x p))]]
139 |          (if (unification-failure? e)
140 |              (expand-macro (Macro name cs) x (+ i 1))
141 |              (tag (substitute e q) (o-macro (Macro-name m)
142 |                                             i
143 |                                             (hash-remove-keys e (free-vars q))))))]
144 |       [#f (fail "Could not expand: ~a" (show-pattern x))]))
145 |   
146 |   (define (unexpand-macro x origin)
147 |     (match origin
148 |       [(o-macro m i q)
149 |        (let* [[c (list-ref (Macro-cases (lookup-macro m)) i)]
150 |               [lhs (MacroCase-left c)]
151 |               [rhs (MacroCase-right c)]]
152 |          (substitute (hash-union q (minus x rhs (o-branch))) lhs))]))
153 |   
154 |   (define (expand-pattern e)
155 |     (match e
156 |       [(constant c)       (constant c)]
157 |       [(literal l)        (literal l)]
158 |       [(tag p o)          (tag (expand-pattern p) o)]
159 |       [(plist t ps)
160 |        (cond [(t-macro? t)
161 |               (expand-pattern (expand-macro (lookup-macro (t-macro-name t)) e))]
162 |              [(t-apply? t)
163 |               (plist t (map expand-pattern ps))]
164 |              [(t-syntax? t)
165 |               (fail "expand-pattern: extraneous syntax-parens (^) in ~a" (show-pattern e))])]))
166 |   
167 |   (define (unchecked-unexpand p)
168 |     (define (check-unlittered p)
169 |       (match p
170 |         [(constant c)   (constant c)]
171 |         [(literal l)    (literal l)]
172 |         [(plist t ps)   (plist t (map check-unlittered ps))]
173 |         [(tag p o)      (raise (NotUnexpandable (tag p o)))]))
174 |     (define (rec p)
175 |       (match p
176 |         [(constant c)   (constant c)]
177 |         [(literal l)    (literal l)]
178 |         [(plist (t-apply) ps) (plist (t-apply) (map rec ps))]
179 |         [(tag p2 o)     (match o
180 |                           [(o-macro m i q) (unexpand-macro (rec p2) o)]
181 |                           [(o-branch)
182 |                            (match p2
183 |                              ; Fail to unexpand if a macro is tainted
184 |                              [p2 (tag (rec p2) o)])]
185 |                           [(o-branch) (tag (rec p2) o)]
186 |                           [(o-external) (tag (rec p2) o)])]
187 |         [_              (raise (NotUnexpandable p))]))
188 |     (check-unlittered (rec p)))
189 |   
190 |   (define (unexpand-pattern p)
191 |     (with-handlers [[(λ (x) (or (NotUnexpandable? x) (CantMatch? x)))
192 |                      (λ (x) #f)]]
193 |       (unchecked-unexpand p)))
194 | )


--------------------------------------------------------------------------------
/confection/Test.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE TypeSynonymInstances #-}
  2 | module Main where
  3 | 
  4 | import Pattern
  5 | import Grammar
  6 | import Show
  7 | import Parse
  8 | import Debug.Trace (trace)
  9 | import Prelude hiding (const)
 10 | import Test.QuickCheck hiding (label)
 11 | import Control.Monad (liftM, liftM2, liftM3, liftM4)
 12 | import Data.Maybe (isJust)
 13 | import Control.Exception (assert)
 14 | import qualified Data.Map as Map
 15 | import Data.Map (Map)
 16 | 
 17 | smallList :: Arbitrary a => Gen [a]
 18 | smallList = oneof (map (\i -> vectorOf i arbitrary)
 19 |                    [1, 1, 2, 2, 3])
 20 | 
 21 | mediumList :: Arbitrary a => Gen [a]
 22 | mediumList = oneof (map (\i -> vectorOf i arbitrary)
 23 |                     [1, 1, 2, 2, 2, 2, 3, 3, 3, 4, 4, 5, 6, 7])
 24 | 
 25 | instance Arbitrary Label where
 26 |   arbitrary = oneof (map (return . Label) ["Plus", "Times", "M", "MM"])
 27 | 
 28 | instance Arbitrary Macro where
 29 |   arbitrary = liftM (Macro (Label "M")) (vectorOf 3 arbitrary)
 30 | 
 31 | instance Arbitrary Rule where
 32 |   arbitrary = liftM4 Rule arbitrary arbitrary arbitrary
 33 |                           (return (RuleFlags False))
 34 | 
 35 | instance Arbitrary Rules where
 36 |   arbitrary = liftM Rules mediumList
 37 | 
 38 | instance Arbitrary Grammar where
 39 |   arbitrary = liftM Grammar mediumList
 40 | 
 41 | instance Arbitrary Language where
 42 |   arbitrary = do
 43 |     g1 <- arbitrary
 44 |     g2 <- arbitrary
 45 |     return (Language g1 g2)
 46 | 
 47 | instance Arbitrary Module where
 48 |   arbitrary = liftM3 Module arbitrary arbitrary arbitrary
 49 | 
 50 | instance Arbitrary Production where
 51 |   arbitrary = liftM2 Production (liftM2 Constructor arbitrary smallList)
 52 |                                 (oneof sorts)
 53 |     where
 54 |       sorts = map (return . SortN) ["Expr", "Struct", "Other"]
 55 | 
 56 | instance Arbitrary SortName where
 57 |   arbitrary = oneof [return (SortN "Expr"),
 58 |                      return (SortN "Struct")]
 59 | 
 60 | instance Arbitrary Sort where
 61 |   arbitrary = oneof [liftM SortName arbitrary,
 62 |                      liftM SortName arbitrary,
 63 |                      liftM SortName arbitrary,
 64 |                      return IntSort,
 65 |                      return StringSort,
 66 |                      liftM SortList arbitrary,
 67 |                      liftM SortList arbitrary]
 68 | 
 69 | instance Arbitrary Var where
 70 |   arbitrary = oneof $ map (return . Var) ["x", "y", "z"]
 71 | 
 72 | instance Arbitrary Pattern where
 73 |   arbitrary = sized $ \n ->
 74 |     let smaller = resize (n `div` 2 - 1) in
 75 |     if n == 0
 76 |     then oneof [liftM PVar arbitrary,
 77 |                 liftM PVar arbitrary,
 78 |                 liftM PConst arbitrary]
 79 |     else oneof [liftM PVar arbitrary,
 80 |                 liftM PVar arbitrary,
 81 |                 liftM PConst arbitrary,
 82 |                 liftM3 PNode arbitrary (smaller arbitrary) (smaller arbitrary),
 83 |                 liftM3 PNode arbitrary (smaller arbitrary) (smaller arbitrary),
 84 |                 liftM PList (smaller arbitrary),
 85 |                 liftM2 PRep (smaller arbitrary) (smaller arbitrary),
 86 |                 liftM2 PTag arbitrary (smaller arbitrary)]
 87 | 
 88 | instance Arbitrary Info where
 89 |   arbitrary = liftM2 Info arbitrary arbitrary
 90 | 
 91 | termGen :: Gen Term
 92 | termGen = arbitrary
 93 | 
 94 | instance Arbitrary Term where
 95 |   arbitrary = sized $ \n ->
 96 |     let n' = n `div` 2 - 1 in
 97 |     if n == 0
 98 |     then oneof [return (TConst (CInt 2)),
 99 |                 return (TConst (CInt 3))]
100 |     else oneof [liftM2 TTag  (resize n' arbitrary)
101 |                              (resize n' arbitrary),
102 |                 liftM2 TNode (resize n' arbitrary)
103 |                              (resize n' arbitrary)]
104 | 
105 | instance Arbitrary Const where
106 |   -- No need to check doubles and strings
107 |   arbitrary = oneof $ map return [CInt 2, CInt 3, CInt 4]
108 | 
109 | instance Arbitrary Origin where
110 |   arbitrary = oneof [return MacBody,
111 |                      return MacBody,
112 |                      return (MacHead (Label "M") 0 (TConst (CStr "t")))]
113 | 
114 | data CoreTerm = CoreTerm Int Term
115 |               deriving Show
116 | 
117 | instance Arbitrary CoreTerm where
118 |   arbitrary = oneof [makeCoreTerm 0, makeCoreTerm 1, makeCoreTerm 2]
119 |     where
120 |       makeCoreTerm i = do
121 |         t <- arbitrary
122 |         return (CoreTerm i t)
123 | 
124 | deepCheck x n = do
125 |   quickCheckWith stdArgs {maxSuccess = n} x
126 | 
127 | prop_parse p x =
128 |   case parse p "(quickcheck-test)" (show x) of
129 |     Left _ -> False
130 |     Right y -> x == y
131 | 
132 | prop_match t p =
133 |   isLeft (wellFormedPattern (Label "M") p) ==>
134 |   case match t p of
135 |     Left _ -> True
136 |     Right e -> case (subs e p) of
137 |       Left _ -> False
138 |       Right t' -> t == t'
139 | 
140 | prop_get_put m t =
141 |   if isLeft (wellFormedMacro m)
142 |   then True
143 |   else trace "." $ case expandMacro m t of
144 |     Left _ -> True
145 |     Right t' -> case unexpandMacro m t' t of
146 |       Left _ -> False
147 |       Right t2 -> t2 == t
148 |   where types = t :: Term
149 | 
150 | prop_put_get :: Macro -> Term -> CoreTerm -> Bool
151 | prop_put_get m t (CoreTerm i t') =
152 |   if isLeft (wellFormedMacro m)
153 |   then True
154 |   else case unexpandMacro m (i, t') t of
155 |     Left _ -> True
156 |     Right t -> trace "." $ case expandMacro m t of
157 |       Left _ -> False
158 |       Right t2' -> t2' == (i, t')
159 | 
160 | testMacroTable = Map.fromList $ [(Label "Swap", Macro (Label "Swap") [rule])]
161 |   where
162 |     rule = Rule (PList [(PVar (Var "x")), (PVar (Var "y"))])
163 |                 (PList [(PVar (Var "y")), (PVar (Var "x"))])
164 |                 []
165 |                 (RuleFlags False)
166 | 
167 | main = do
168 |   tests "matching" [
169 |     (subsTest (TConst (CInt 1))
170 |               (PConst (CInt 1))),
171 |     (subsTest (TConst (CInt 1))
172 |               (PVar (Var "x"))),
173 |     (subsTest (TNode (Label "l") [TConst (CInt 1)])
174 |               (PNode (Info False False) (Label "l") [PVar (Var "y")])),
175 |     (subsTest (TList [])
176 |               (PList [])),
177 |     (subsTest (TList [TConst (CStr "one")])
178 |               (PList [PConst (CStr "one")])),
179 |     (subsTest (TList [TConst (CStr "one")])
180 |               (PRep [] (PVar (Var "x")))),
181 |     (subsTest (TList [TConst (CStr "one"), TConst (CStr "two")])
182 |               (PRep [] (PVar (Var "x")))),
183 |     (subsTest (TList [TConst (CStr "one"), TConst (CStr "two")])
184 |               (PRep [PVar (Var "x"), PVar (Var "y")] (PVar (Var "z")))),
185 |     (subsTest (TList [TConst (CStr "one"), TConst (CStr "two")])
186 |               (PRep [PVar (Var "x")] (PVar (Var "y")))),
187 |     (subsTest (TList [])
188 |               (PRep [] (PVar (Var "x"))))]
189 |   tests "macros" [
190 |     (macroTest testMacroTable
191 |      (TList [TConst (CInt 1), TList [TConst (CInt 2)]]))]
192 | 
193 | --  sample (arbitrary :: Gen Grammar)
194 | --  sample (arbitrary :: Gen Pattern)
195 | --  sample (arbitrary :: Gen Rules)
196 | --  sample (arbitrary :: Gen Pattern)
197 | --  sample (arbitrary :: Gen Module)
198 | 
199 |   putStrLn "\nTesting parsing..."
200 |   quickCheck (prop_parse label)
201 |   quickCheck (prop_parse sort)
202 |   quickCheck (prop_parse const)
203 |   quickCheck (prop_parse origin)
204 |   quickCheck (prop_parse term)
205 |   quickCheck (prop_parse pattern)
206 |   quickCheck (prop_parse grammar)
207 |   quickCheck (prop_parse rule)
208 |   quickCheck (prop_parse language)
209 |   quickCheck (prop_parse top)
210 |   putStrLn "\nTesting algorithms..."
211 |   deepCheck prop_match 250
212 |   deepCheck prop_match 250
213 |   deepCheck prop_match 250
214 |   deepCheck prop_match 250
215 |   -- useless (precondition rarely ever satisfied):
216 | --  deepCheck prop_get_put 1000
217 | --  deepCheck prop_put_get 1000
218 | 
219 | subsTest :: Term -> Pattern -> (Either ResugarFailure Term,
220 |                                 Either ResugarFailure Term)
221 | subsTest t p = (match t p >>= (\e -> subs e p), Right t)
222 | 
223 | macroTest :: MacroTable -> Term -> (Either ResugarFailure Term,
224 |                                     Either ResugarFailure Term)
225 | macroTest ms t = (expand ms t >>= unexpand ms, Right t)
226 | 
227 | tests :: (Show a, Eq a) => String -> [(a, a)] -> IO ()
228 | tests msg ts = do
229 |   putStrLn ("\nTesting " ++ msg ++ "...")
230 |   results <- mapM test ts
231 |   let failures = sum results
232 |   if failures == 0
233 |     then putStrLn ("OK, passed " ++ show (length ts) ++ " tests.")
234 |     else putStrLn ("Failed " ++ show failures ++ " out of "
235 |                    ++ show (length ts) ++ " tests.")
236 |   where
237 |     test (x, y) =
238 |       if x == y
239 |       then return 0
240 |       else do
241 |         putStrLn ("*** FAILURE: Expected " ++ show y ++ ", found " ++ show x)
242 |         return 1
243 | 


--------------------------------------------------------------------------------
/prototype/lang-min.rkt:
--------------------------------------------------------------------------------
  1 | (module lang-min racket
  2 |   (provide
  3 |    Min red
  4 |    test-eval test-expand
  5 |    test-trace
  6 |    )
  7 | 
  8 | ; Assembled from Matthias' letrec (personal correspondence)
  9 | ; and redex/example/letrex.rkt.
 10 | ; The language is probably mostly correct.
 11 | 
 12 | (require rackunit)
 13 | (require redex)
 14 | (require "resugar-redex.rkt")
 15 | 
 16 | 
 17 |   ;;;;;;;;;;;;;;;;
 18 |   ;;; Language ;;;
 19 |   ;;;;;;;;;;;;;;;;
 20 | 
 21 | (define-language Min
 22 |   (p (top s e))
 23 |   (e (apply o e ...)
 24 |      (op o e ...)
 25 |      (set! o x e)
 26 |      (begin o e e ...)
 27 |      (if o e e e)
 28 |      (rec o x e)
 29 |      (amb o e ...)
 30 |      x
 31 |      v
 32 |      (x := e))
 33 |   (op + cons first rest empty? eq? string-first string-rest)
 34 |   (s (store (x x v) ...))
 35 |   (v (lambda o x e)
 36 |      number
 37 |      boolean
 38 |      string
 39 |      empty
 40 |      (cons o v v))
 41 |   (x variable-not-otherwise-mentioned)
 42 |   (pc (top (store (x x v) ...) ec))
 43 |   (ec (apply o v ... ec e ...)
 44 |       (op o v ... ec e ...)
 45 |       (set! o variable ec)
 46 |       (begin o ec e e ...)
 47 |       (if o ec e e)
 48 |       hole)
 49 |   (o (origins any)))
 50 | 
 51 | (define-metafunction Min
 52 |   swap : x x any -> any
 53 |   [(swap x_1 x_2 x_1) x_2]
 54 |   [(swap x_1 x_2 x_2) x_1]
 55 |   [(swap x_1 x_2 (any_1 ...)) ((swap x_1 x_2 any_1) ...)]
 56 |   [(swap x_1 x_2 any_1) any_1])
 57 | 
 58 | (define-metafunction Min
 59 |   subs : x e e -> e
 60 |   [(subs x_1 e_1 (lambda o x_1 e_2))
 61 |    (lambda o x_1 e_2)]
 62 |   [(subs x_1 e_1 (lambda o x_2 e_2))
 63 |    ,(term-let ([x_new (variable-not-in (term e_1) (term x_2))])
 64 |               (term (lambda o x_new (subs x_1 e_1 (swap x_2 x_new e_2)))))]
 65 |   [(subs x_1 e_1 (set! o x_2 e_2))
 66 |    (set! o (subs x_1 e_1 x_2) (subs x_1 e_1 e_2))]
 67 |   [(subs x_1 e_1 (rec o x_2 e_2))
 68 |    ,(term-let ([x_new (variable-not-in (term e_1) (term x_2))])
 69 |               (term (rec o x_new (subs x_1 e_1 (swap x_2 x_new e_2)))))]  
 70 |   [(subs x_1 e_1 x_1) e_1]
 71 |   [(subs x_1 e_1 x_2) x_2]
 72 |   [(subs x_1 e_1 (apply o e_2 ...))
 73 |    (apply o (subs x_1 e_1 e_2) ...)]
 74 |   [(subs x e number) number]
 75 |   [(subs x e (name a boolean)) a]
 76 |   [(subs x e (name a string)) a]
 77 |   [(subs x e (if o e_1 e_2 e_3))
 78 |    (if o (subs x e e_1) (subs x e e_2) (subs x e e_3))]
 79 |   [(subs x e (begin o e_1 ...))
 80 |    (begin o (subs x e e_1) ...)]
 81 |   [(subs x e (amb o e_1 ...))
 82 |    (amb o (subs x e e_1) ...)]
 83 |   [(subs x e (op o e_1 ...))
 84 |    (op o (subs x e e_1) ...)]
 85 |   [(subs x e (cons o e_1 e_2))
 86 |    (cons o (subs x e e_1) (subs x e e_2))]
 87 |   [(subs x e empty) empty])
 88 | 
 89 | (define-metafunction Min
 90 |   look : x (store (x x v) ...) -> v
 91 |   [(look x (store (x_1 x_11 v_1) ... (x x_10 v) (x_2 x_12 v_2) ...))
 92 |    v
 93 |    (side-condition (not (member (term x) (term (x_1 ...)))))])
 94 | 
 95 | (define-metafunction Min
 96 |   set : x v (store (x x v) ...) -> (store (x x v) ...)
 97 |   [(set x v_new (store (x_1 x_11 v_1) ... (x x_10 v) (x_2 x_12 v_2) ...))
 98 |    (store (x_1 x_11 v_1) ... (x x_10 v_new) (x_2 x_12 v_2) ...)
 99 |    (side-condition (not (member (term x) (term (x_1 ...)))))])
100 | 
101 | (define (string-first str)
102 |   (substring str 0 1))
103 | (define (string-rest str)
104 |   (substring str 1))
105 |   
106 | (define red
107 |   (reduction-relation
108 |    Min
109 |    (--> (in-hole pc_1 (begin o v e_1 e_2 ...))
110 |         (in-hole pc_1 (begin o e_1 e_2 ...))
111 |         "begin-many")
112 |    
113 |    (--> (in-hole pc_1 (begin o e_1))
114 |         (in-hole pc_1 e_1)
115 |         "begin-one")
116 |    
117 |    (--> (in-hole pc (amb o e_1 ... e e_2 ...))
118 |         (in-hole pc e)
119 |         "amb")
120 |  
121 |    (--> (in-hole pc (empty? o empty))               (in-hole pc #t))
122 |    (--> (in-hole pc (empty? o (cons o_1 v_1 v_2)))  (in-hole pc #f))
123 |    (--> (in-hole pc (+ o v ...))                    (in-hole pc ,(apply + (term (v ...)))))
124 |    (--> (in-hole pc (eq? o v_1 v_2))                (in-hole pc ,(equal? (term v_1) (term v_2))))
125 |    (--> (in-hole pc (first o_1 (cons o_2 v_1 v_2))) (in-hole pc v_1))
126 |    (--> (in-hole pc (rest o_1 (cons o_2 v_1 v_2)))  (in-hole pc v_2))
127 |    (--> (in-hole pc (string-first o v))             (in-hole pc ,(string-first (term v))))
128 |    (--> (in-hole pc (string-rest o v))              (in-hole pc ,(string-rest (term v))))
129 |    
130 |    (--> (top s (in-hole ec x))
131 |         (top s (in-hole ec (look x s)))
132 |         "variable")
133 |    
134 |    (--> (top s           (in-hole ec (set! o_2 x v)))
135 |         (top (set x v s) (in-hole ec v))
136 |         "set!")
137 | 
138 |    (--> (top (store (x_1 x_2 v_1) ...)
139 |              (in-hole ec (apply o_1 (lambda o_2 x e) v)))
140 |         (top (store (x_1 x_2 v_1) ... (x_new x v))
141 |              (in-hole ec (subs x x_new e)))
142 |         (fresh x_new)
143 |         "apply-one")
144 | 
145 |    (--> (top (store (x_1 x_2 v_1) ...)
146 |              (in-hole ec (apply o_1 (lambda o_2 x e) v_2 v_3 v_4 ...)))
147 |         (top (store (x_1 x_2 v_1) ... (x_new x v_2))
148 |              (in-hole ec (apply o_1 (subs x x_new e) v_3 v_4 ...)))
149 |         (where x_new ,(variable-not-in (term (x_1 ...)) 'x))
150 |         "apply-many")
151 |    
152 |    (--> (in-hole pc (if o #t e_1 e_2))
153 |         (in-hole pc e_1)
154 |         "if-true")
155 |   
156 |    (--> (in-hole pc (if o #f e_1 e_2))
157 |         (in-hole pc e_2)
158 |         "if-false")))
159 | 
160 |    ;with [(--> a ,(collect (term b))) (==> a b)]))
161 | 
162 | 
163 |   ;;;;;;;;;;;;;;;;;;;;;;;;
164 |   ;;; Language Testing ;;;
165 |   ;;;;;;;;;;;;;;;;;;;;;;;;
166 | 
167 | (define (run-eval e)
168 |   (third (car (apply-reduction-relation* red `(top (store) ,e)))))
169 | 
170 | (define o '(origins ()))
171 | 
172 | (define-syntax-rule
173 |   (eval-tests [actual expected] ...)
174 |   (begin (check-equal? (run-eval actual) expected) ...))
175 | 
176 | (eval-tests
177 |  [`(apply ,o (lambda ,o x x) 3) 3]
178 |  [`(+ ,o 2 3) 5]
179 |  [`(eq? ,o "a" "a") #t]
180 |  [`(eq? ,o "a" "b") #f]
181 |  [`(empty? ,o empty) #t]
182 |  [`(empty? ,o (cons ,o "a" "b")) #f]
183 |  [`(cons ,o (+ ,o 1 2) (+ ,o 3 4)) `(cons ,o 3 7)]
184 |  [`(+ ,o (+ ,o 1 2) (+ ,o 3 4)) 10]
185 |  [`(rest ,o (first ,o (cons ,o (cons ,o "a" (cons ,o "b" empty)) "c")))
186 |   `(cons ,o "b" empty)]
187 |  [`(apply ,o (lambda ,o x (begin ,o (set! ,o x 1) x)) 3)    1]
188 |  [`(apply ,o (lambda ,o x (apply ,o (lambda ,o x x) 2)) 1)  2]
189 |  [`(apply ,o (lambda ,o x (+ ,o x 1)) (+ ,o 1 2))           4]
190 |  [`(apply ,o (lambda ,o x (lambda ,o y (+ ,o x y))) 2 3)    5]
191 |  [`(apply ,o (lambda ,o x (begin ,o
192 |      (set! ,o x (+ ,o x 1))
193 |      (set! ,o x (apply ,o (lambda ,o x (begin ,o (set! ,o x (+ ,o x 2)) (+ ,o x x))) x))
194 |      (+ ,o x x x)))
195 |    7)                                                      60]
196 |  [`(begin ,o (+ ,o 1 2) (+ ,o 3 4) (+ ,o 5 6))             11]
197 |  [`(if ,o #t 1 2) 1]
198 |  [`(if ,o #f 1 2) 2]
199 |  [`(string-first ,o "abc") "a"]
200 |  [`(string-rest ,o "abc") "bc"]
201 |  )
202 |   
203 | ;;; Resugaring Integration ;;;
204 | 
205 | (define empty-store (term (store)))
206 | 
207 | (define (join expr store)
208 |   `(top ,store ,expr))
209 | 
210 | (define (split top)
211 |   (let [[store (second top)]
212 |         [expr (third top)]]
213 |     (cons expr store)))
214 | 
215 | (define (lookup-var var store)
216 |   (define (lookup var bindings)
217 |     (match bindings
218 |       [(list) #f]
219 |       [(cons (list x name v) bindings)
220 |        (if (symbol=? var x) (cons name v) (lookup var bindings))]))
221 |   (lookup var (cdr store)))
222 | 
223 | (define MAMin
224 |   (make-redex-language "Min" Min red join split lookup-var))
225 | 
226 | (define (flatten-eval-tree tree)
227 |   (if (empty? (cdr tree))
228 |       (list (car tree))
229 |       (cons (car tree) (flatten-eval-tree (second tree)))))
230 | 
231 | (define-syntax-rule (test-eval t)
232 |   (begin
233 |     (for-each (λ (x) (display (format "~a\n" x)))
234 |               (flatten-eval-tree
235 |                (macro-aware-eval MAMin (make-term t) empty-store)))
236 |     (display "\n")))
237 | 
238 | (define-syntax-rule (make-redex-term t)
239 |   (term->redex (expand-term (make-term t))))
240 | 
241 | (define (nondeterm-step tree)
242 |   (display tree) (newline)
243 |   (if (empty? (cdr tree))
244 |       #f
245 |       (cdr tree)))
246 |   
247 | (define (determ-step tree)
248 |   (if (empty? (cdr tree))
249 |       #f
250 |       (cadr tree)))
251 |   
252 | (define marred
253 |   (reduction-relation Min
254 |     (--> p ,(macro-aware-redex-step MAMin (term p) 1))
255 |     (--> p ,(macro-aware-redex-step MAMin (term p) 2))
256 |     (--> p ,(macro-aware-redex-step MAMin (term p) 3))))
257 | 
258 | (define-syntax-rule (test-trace t)
259 |   (macro-aware-traces MAMin marred (join (make-redex-term t) empty-store)))
260 | 
261 | (define-syntax-rule (test-expand t)
262 |   (show-term (expand-term (make-term t))))
263 | 
264 | )


--------------------------------------------------------------------------------
/prototype/tests.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require "utility.rkt")
  3 | (require (except-in rackunit fail))
  4 | (require "pattern.rkt")
  5 | (require "macro.rkt")
  6 | (require "resugar.rkt")
  7 | 
  8 | 
  9 | ;;;;;;;;;;;;
 10 | ;; Syntax ;;
 11 | ;;;;;;;;;;;;
 12 | 
 13 | (define test-lits '(else A B C))
 14 | (define test-macs '(cond and))
 15 | (define test-vars '(x y z xs ys zs))
 16 | 
 17 | (define test-origin (list))
 18 | 
 19 | (define-syntax-rule (test-pattern p)
 20 |   (sexpr->pattern 'p (list 'x 'xs 'y 'ys 'z 'zs)))
 21 | 
 22 | (define-syntax test-subs-rhs
 23 |   (syntax-rules (@ @...)
 24 |     [(_ (@... (x ...) y (z ...)))
 25 |      (inter-ellipsis (t-apply)
 26 |                      (list (test-subs-rhs x) ...)
 27 |                      (test-subs-rhs y)
 28 |                      (list (test-subs-rhs z) ...))]
 29 |     [(_ (@ x ...))
 30 |      (inter-list (t-apply) (list (test-subs-rhs x) ...))]
 31 |     [(_ x) (test-pattern x)]))
 32 | 
 33 | (define-syntax-rule (mk-hash (v x) ...)
 34 |   (make-immutable-hash (list (cons 'v (test-subs-rhs x)) ...)))
 35 | 
 36 | (define (test-plist . elems)
 37 |   (plist test-origin (apply list elems)))
 38 | 
 39 | (check-equal? (sexpr->pattern '(Cond (^ (^ x y) (^ xs ys) ... (if (^ $else x)))))
 40 |   (plist (t-macro 'Cond)
 41 |    (list (ellipsis (t-syntax)
 42 |                    (list (plist (t-syntax)
 43 |                                 (list (pvar 'x) (pvar 'y))))
 44 |                    (plist (t-syntax)
 45 |                           (list (pvar 'xs) (pvar 'ys)))
 46 |                    (list (plist (t-apply)
 47 |                                 (list (pvar 'if)
 48 |                                       (plist (t-syntax)
 49 |                                              (list (literal '$else) (pvar 'x))))))))))
 50 | 
 51 | (define-syntax-rule (test-show ptn str)
 52 |   (check-equal? (show-pattern (test-pattern ptn)) str))
 53 | 
 54 | (test-show x "x")
 55 | (test-show $else "$else")
 56 | (test-show c "c")
 57 | (test-show 3 "3")
 58 | (test-show () "()")
 59 | (test-show (x) "(x)")
 60 | (test-show (x y) "(x y)")
 61 | (test-show (1 x #t y "string") "(1 x #t y \"string\")")
 62 | (test-show (M x y ...) "(M x y ...)")
 63 | (test-show (x ...) "(x ...)")
 64 | (test-show (x y ...) "(x y ...)")
 65 | (test-show (x ... y) "(x ... y)")
 66 | (test-show (x y x ... y x) "(x y x ... y x)")
 67 | (test-show (() (() (x))) "(() (() (x)))")
 68 | 
 69 | 
 70 | ;;;;;;;;;;;
 71 | ;; Terms ;;
 72 | ;;;;;;;;;;;
 73 | 
 74 | (check-equal? (term->pattern (term-id (list 'o1 'o2) (term-list (list) (list 1 "two"))))
 75 |               (tag (tag (plist (t-apply) (list (constant 1) (constant "two"))) 'o2) 'o1))
 76 | 
 77 | (define-syntax-rule (check-term<->pattern p)
 78 |   (check-equal? (make-pattern p) (term->pattern (pattern->term (make-pattern p)))))
 79 | 
 80 | (define-syntax-rule (check-pattern<->term t)
 81 |   (check-equal? (make-term t) (pattern->term (term->pattern (make-term t)))))
 82 | 
 83 | (check-term<->pattern (M $x "y" (Q z)))
 84 | (check-pattern<->term (M $x y (Q "z")))
 85 | 
 86 | ;;;;;;;;;;;;;;;;;
 87 | ;; Unification ;;
 88 | ;;;;;;;;;;;;;;;;;
 89 | 
 90 | (define-syntax-rule (check-unify x y z)
 91 |   (check-equal? (unify (test-pattern x) (test-pattern y))
 92 |                 (test-pattern z)))
 93 | 
 94 | (define-syntax-rule (check-unify-fail x y)
 95 |   (begin
 96 |     (check-exn CantUnify? (thunk (unify (test-pattern x) (test-pattern y))))
 97 |     (check-exn CantUnify? (thunk (unify (test-pattern y) (test-pattern x))))))
 98 | 
 99 | (check-unify x x x)
100 | (check-unify x y x) ; y is also reasonable
101 | (check-unify x a a)
102 | (check-unify a x a)
103 | (check-unify-fail x $a)
104 | (check-unify x () ())
105 | (check-unify () x ())
106 | (check-unify x (y ...) (y ...))
107 | (check-unify (x ...) y (x ...))
108 | (check-unify a a a)
109 | (check-unify-fail a b)
110 | (check-unify-fail a $a)
111 | (check-unify-fail a ())
112 | (check-unify-fail a (x ...))
113 | (check-unify-fail $a ())
114 | (check-unify-fail $a (x ...))
115 | (check-unify () () ())
116 | (check-unify (a $b c) (a $b c) (a $b c))
117 | (check-unify (x $a b) (a $a y) (a $a b))
118 | (check-unify (x a $c) (y a $c) (x a $c))
119 | (check-unify-fail (a a) (a a a))
120 | (check-unify-fail (x $a b) (a z y))
121 | (check-unify () (x ...) ())
122 | (check-unify (x ...) () ())
123 | (check-unify (x ...) (y ...) (x ...))
124 | (check-unify-fail (a b c d e) (a b x ... d))
125 | (check-unify (a b c d) (a b x ... c d) (a b c d))
126 | (check-unify (a b c d e f) (a b x ... e f) (a b c d e f))
127 | (check-unify-fail (a b c d e f) (a b (x) ... e f))
128 | (check-unify ((a b) (a x) ... (c d)) ((a b) (z y) ...) ((a b) (a x) ... (c d)))
129 | (check-unify ((a b) (z y) ...) ((a b) (a x) ... (c d)) ((a b) (a x) ... (c d)))
130 | (check-unify (a (b b) x ...)   (a (y y) ...)     (a (b b) (y y) ...))
131 | (check-unify (x ... (b b) a)   ((y y) ... a)     ((y y) ... (b b) a))
132 | (check-unify (a b z ...)       (x y ...)         (a b z ...))
133 | (check-unify (z ... a b)       (y ... x)         (z ... a b))
134 | (check-unify (((x a) ...) ...) (((y a) ...) ...) (((x a) ...) ...))
135 | (check-unify (((x a) ...) ...) ((y a) ...)       ())
136 | (check-unify ((x x) ...)       ((a a) y ...)     ((a a) (x x) ...))
137 | (check-unify ((x x) ...)       (y ... (a a))     ((x x) ... (a a)))
138 | (check-unify ((x y) ...)       ((a b) (a c))     ((a b) (a c)))
139 | 
140 | ;;;;;;;;;;;;;;
141 | ;; Matching ;;
142 | ;;;;;;;;;;;;;;
143 | 
144 | (define-syntax-rule (check-minus x y z)
145 |   (check-equal? (minus (test-pattern x) (test-pattern y))
146 |                 z))
147 | 
148 | (define-syntax-rule (check-minus-fail x y)
149 |   (check-exn CantMatch? (thunk (minus (test-pattern x) (test-pattern y)))))
150 | 
151 | (check-minus x x (mk-hash (x x)))
152 | (check-minus x y (mk-hash (y x)))
153 | (check-minus-fail x $a)
154 | (check-minus-fail $a x)
155 | (check-minus a x (mk-hash (x a)))
156 | (check-minus-fail x a)
157 | (check-minus () x (mk-hash (x ())))
158 | (check-minus-fail x ())
159 | (check-minus (y ...) x (mk-hash (x (y ...))))
160 | (check-minus-fail x (y ...))
161 | (check-minus $a $a (mk-hash))
162 | (check-minus-fail $a $b)
163 | (check-minus-fail a $a)
164 | (check-minus-fail $a a)
165 | (check-minus a a (mk-hash))
166 | (check-minus-fail a b)
167 | (check-minus-fail a ())
168 | (check-minus-fail a (x ...))
169 | (check-minus-fail () a)
170 | (check-minus-fail (x ...) a)
171 | (check-minus-fail $a ())
172 | (check-minus-fail $a (x ...))
173 | (check-minus-fail () $a)
174 | (check-minus-fail (x ...) $a)
175 | (check-minus () () (mk-hash)) ; !!!
176 | (check-minus-fail (x ...) ())
177 | (check-minus ()              (x ...) (mk-hash (x (@))))
178 | (check-minus (x ...)         (y ...) (mk-hash (y (@... () x ()))))
179 | (check-minus (a x ... b)     (y ...) (mk-hash (y (@... (a) x (b)))))
180 | (check-minus (a b x ... b c) (y ...) (mk-hash (y (@... (a b) x (b c)))))
181 | (check-minus-fail (x ...) (a y ...))
182 | (check-minus-fail (x ...) (y ... a))
183 | (check-minus-fail (a x ...) (a y ... a))
184 | (check-minus (a (x ...) ...) (y ...) (mk-hash (y (@... (a) (x ...) ()))))
185 | 
186 | 
187 | ;;;;;;;;;;;;;;;;;;
188 | ;; Substitution ;;
189 | ;;;;;;;;;;;;;;;;;;
190 | 
191 | 
192 | (define-syntax-rule (check-subs-into x y z w)
193 |   (check-equal? (substitute (minus (test-pattern x) (test-pattern y))
194 |                             (test-pattern z))
195 |                 (test-pattern w)))
196 | 
197 | (define-syntax-rule (check-subs x y)
198 |   (check-subs-into x y y x))
199 | 
200 | (define-syntax-rule (check-unify-subs x y)
201 |   (let ((px (test-pattern x))
202 |         (py (test-pattern y)))
203 |     (let ((pz (unify px py)))
204 |       (check-equal? (substitute (minus pz px) px) pz)
205 |       (check-equal? (substitute (minus pz py) py) pz))))
206 | 
207 | (check-subs a a)
208 | (check-subs a x)
209 | (check-subs (x ...) (y ...))
210 | (check-subs (a x ... b) (y ...))
211 | (check-subs (a b c) (a x ...))
212 | (check-subs ((x ...) b (y ...)) (z ...))
213 | (check-subs-into (a b c) (x ... y) ((x y) ...) ((a c) (b c)))
214 | (check-subs-into ((x ...) ...) (y ...) (y ...) ((x ...) ...))
215 | (check-unify-subs x a)
216 | (check-unify-subs x ())
217 | (check-unify-subs x (y ...))
218 | (check-unify-subs x ((y ...) ...))
219 | (check-unify-subs (x ...) (y ...))
220 | 
221 | (check-unify-subs (a (b b) x ...) (a (y y) ...))
222 | (check-unify-subs (x ... (b b) a) ((y y) ... a))
223 | (check-unify-subs (a b z ...) (x y ...))
224 | (check-unify-subs (z ... a b) (y ... x))
225 | (check-unify-subs (((x a) ...) ...) (((y a) ...) ...))
226 | (check-unify-subs (((x a) ...) ...) ((y a) ...))
227 | (check-unify-subs ((x x) ...) ((a a) y ...))
228 | (check-unify-subs ((x x) ...) (y ... (a a)))
229 | (check-unify-subs ((x y) ...) ((a b) (a c)))
230 | 
231 | 
232 | ;;;;;;;;;;;;;;;;;;
233 | ;; Environments ;;
234 | ;;;;;;;;;;;;;;;;;;
235 | 
236 | (check-exn OccursCheck? (thunk (bind 'x (pvar 'x) empty-env)))
237 | (check-exn OccursCheck? (thunk (bind 'x (pvar 'y) (singleton-env 'y (pvar 'x)))))
238 | (check-equal? (bind 'x (test-pattern (y a))
239 |                     (mk-hash (y (a (z else) ...))))
240 |               (mk-hash (x ((a (z else) ...) a))
241 |                        (y (a (z else) ...))))
242 | 
243 | 
244 | ;;;;;;;;;;;;;
245 | ;; Utility ;;
246 | ;;;;;;;;;;;;;
247 | 
248 | (check-equal? (range 3) (list 0 1 2))
249 | 
250 | (check-eq? (all-eq? (list 1 2 1)) false)
251 | (check-eq? (all-eq? (list 1 1 1)) true)
252 | 
253 | (check-equal? (compose 1 (list (λ (x) (+ x 1)) (λ (x) (* x 2))))
254 |               4)
255 | 
256 | (check-equal? (hash-modify (make-immutable-hash '((x . 1) (y . 2))) (λ (x) (+ x 1)))
257 |               (make-immutable-hash '((x . 2) (y . 3))))
258 | 
259 | (check-equal? (hash-add-bindings (make-immutable-hash '((x . 1) (y . 2)))
260 |                                  '((y . 3) (z . 4)))
261 |               (make-immutable-hash '((x . 1) (y . 3) (z . 4))))
262 | 
263 | (check-equal? (split-list '... '()) false)
264 | (check-equal? (split-list '... '(a b ... c d)) (cons '(a b) '(c d)))
265 | (check-equal? (split-list '... '(a b c d)) false)
266 | 
267 | (check-equal? (repeat 3 'a) '(a a a))
268 | 
269 | (check-equal? (all-distinct-pairs '(1 2 3)) '((1 . 2) (1 . 3) (2 . 3)))
270 | 
271 | (check-equal? (make-immutable-hash '((2 . 3)))
272 |               (hash-remove-keys (make-immutable-hash '((1 . 2) (2 . 3) (3 . 4)))
273 |                                 (set '1 '3)))
274 | 
275 | (check-equal? (get-define-setting-test-setting) #f)
276 | (set-define-setting-test-setting! 24738)
277 | (check-equal? (get-define-setting-test-setting) 24738)
278 | 
279 | (display "ok\n")
280 | 
281 | ;;;;;;;;;;;;
282 | ;; Macros ;;
283 | ;;;;;;;;;;;;
284 | 
285 | 
286 | (define-macro Cond
287 |   [(_ (^ $else x))    x]
288 |   [(_ (^ x y))       (if x y (void))]
289 |   [(_ (^ x y) z zs ...) (! if x y (Cond z zs ...))])
290 | 
291 | (define-macro ForgetfulSam
292 |   [(_ x) 107])
293 | 
294 | (define cond-origin* (t-macro 'Cond))
295 | (define (plist* o . xs) (plist o (apply list xs)))
296 | 
297 | (check-equal? (lookup-macro 'Bob) #f)
298 | 
299 | (define-syntax-rule (test-expand-unexpand p)
300 |   (check-equal? (unexpand-pattern (expand-pattern (test-pattern p)))
301 |                 (test-pattern p)))
302 | 
303 | (test-expand-unexpand (Cond [^ 1 2]))
304 | (test-expand-unexpand (Cond [^ $else 2]))
305 | (test-expand-unexpand (Cond [^ (+ a 2) 1] [^ $else (+ 1 2)]))
306 | (test-expand-unexpand (Cond [^ $else (+ 1 1)]))
307 | (test-expand-unexpand (Cond [^ (+ a 2) 1] [^ $else 2]))
308 | (test-expand-unexpand (ForgetfulSam 11))
309 | 
310 | (define-macro M
311 |   ((M x y ...)
312 |    '((x y) ...)))
313 | 
314 | (check-equal? (show-term (expand-term (make-term (M (a) b c))))
315 |               "'(((a) b) ((a) c))")
316 | 
317 | 


--------------------------------------------------------------------------------
/racket/convert.rkt:
--------------------------------------------------------------------------------
  1 | (module term racket
  2 |   (provide (all-defined-out))
  3 |   (require parser-tools/lex)
  4 |   (require ragg/support)
  5 |   (require (except-in rackunit fail))
  6 |   (require racket/serialize)
  7 |   (require "term.rkt")
  8 |   (require "utility.rkt")
  9 |   (require "grammar.rkt")
 10 |   
 11 |   (define-setting DEBUG_COMMUNICATION set-debug-communication! #f)
 12 |   
 13 |   
 14 |   #| PRINTING |#
 15 |   
 16 |   (define (show-term t)
 17 |     (define (parens x) (format "(~a)" x))
 18 |     (define (braces x) (format "{~a}" x))
 19 |     (define (brackets x) (format "[~a]" x))
 20 |     (define (comma-sep xs) (string-join xs ", "))
 21 |     (define (origins->string os)
 22 |       (braces (brackets (comma-sep (map show-origin os)))))
 23 |     (define (show-node l . ts)
 24 |       (string-append (symbol->string l) (parens (comma-sep ts))))
 25 |     (define (show-string s) (format "~v" s))
 26 |     (define (show-symbol s) (format "~v" (symbol->string s)))
 27 |     (define (show-number n) (show-string (number->string n)))
 28 |     (define (show-origin o)
 29 |       (match o
 30 |         [(MacHead m c q)
 31 |          (string-append "Head"
 32 |             (parens (comma-sep (list (symbol->string m) (number->string c) (show-term q)))))]
 33 |         [(MacBody)
 34 |          "Body"]
 35 |         [(MacTranspBody)
 36 |          "!Body"]
 37 |         [(Alien)
 38 |          "Alien"]))
 39 |     (define (show-list xs)
 40 |       (brackets (comma-sep xs)))
 41 |     (define (show-binding b)
 42 |       (match b [(list v x)
 43 |                 (show-node 'Bind (show-symbol v) (show-term x))]))
 44 |     (define (show-cond-case c)
 45 |       (match c
 46 |         [(list c x)
 47 |          (show-node 'CondCase (show-term c) (show-term x))]))
 48 |     (define (show-automaton-case c)
 49 |       (match c [(list s ': ts ...)
 50 |                 (show-node 'ACondition
 51 |                            (show-symbol s)
 52 |                            (show-list (map show-automaton-transition ts)))]))
 53 |     (define (show-automaton-transition t)
 54 |       (match t ['accept (show-node 'Accept)]
 55 |                [(list s '-> l) (show-node 'ATransition (show-term s) (show-term l))]))
 56 |     (match t
 57 |       [(Tagged os t)
 58 |        (string-append (show-term t) (origins->string os))]
 59 |       [(list 'delay x)
 60 |        (show-node 'Delay (show-term x))]
 61 |       ; Surface
 62 |       [(list 'let (list bs ...) xs ...)
 63 |        (show-node 'Let (show-list (map show-binding bs))
 64 |                        (show-list (map show-term xs)))]
 65 |       [(list 'letrec (list bs ...) xs ...)
 66 |        (show-node 'Letrec (show-list (map show-binding bs))
 67 |                           (show-list (map show-term xs)))]
 68 |       [(list 'cond cs ... (list 'else c))
 69 |        (show-node 'Cond (show-list (map show-cond-case cs)) (show-term c))]
 70 |       [(list 'inc x)
 71 |        (show-node 'Inc (show-term x))]
 72 |       [(list 'or xs ...)
 73 |        (show-node 'Or (show-list (map show-term xs)))]
 74 |       [(list 'and xs ...)
 75 |        (show-node 'And (show-list (map show-term xs)))]
 76 |       [(list 'automaton init cases ...)
 77 |        (show-node 'Automaton (show-symbol init) (show-list (map show-automaton-case cases)))]
 78 |       [(list 'transptest v x)
 79 |        (show-node 'TranspTest (show-symbol v) (show-term x))]
 80 |       [(list 'function (list (? symbol? vs) ...) x)
 81 |        (show-node 'Function (show-list (map show-symbol vs)) (show-term x))]
 82 |       [(list 'return x)
 83 |        (show-node 'Return (show-term x))]
 84 |       [(list 'cps-app x y (? symbol? k))
 85 |        (show-node 'CpsApp (show-term x) (show-term y) (show-symbol k))]
 86 |       [(list 'cps x)
 87 |        (show-node 'Cps (show-term x))]
 88 |       ; Core
 89 |       [(? boolean? t)
 90 |        (if t (show-node 'True) (show-node 'False))]
 91 |       [(? number? t)
 92 |        (show-node 'Num (show-number t))]
 93 |       [(? string? t)
 94 |        (show-node 'Str (show-string t))]
 95 |       [(? symbol? t)
 96 |        (show-node 'Id (show-string (symbol->string t)))]
 97 |       [(list 'lambda (list (? symbol? vs) ...) x)
 98 |        (show-node 'Lambda (show-list (map show-symbol vs))
 99 |                           (show-term x))]
100 |       [(list 'begin x xs ...)
101 |        (show-node 'Begin (show-list (map show-term (cons x xs))))]
102 |       [(list 'set! (? symbol? v) x)
103 |        (show-node 'Set (show-symbol v) (show-term x))]
104 |       [(list 'if x y z)
105 |        (show-node 'If (show-term x) (show-term y) (show-term z))]
106 |       [(list f xs ...)
107 |        (show-node 'Apply (show-term f) (show-list (map show-term xs)))]
108 |       ; Value
109 |       [t (show-node 'Value (show-string (format "~s" (serialize t))))]))
110 |   
111 |   
112 |   #| PARSING |#
113 |   ; (also see grammar.rkt)
114 |   
115 |   (define (read-term str)
116 |     (define (extract-list xs)
117 |       (cond [(empty? xs) (list)]
118 |             [(and (cons? xs) (string? (car xs))) (extract-list (cdr xs))]
119 |             [(cons? xs) (cons (car xs) (extract-list (cdr xs)))]))
120 |     (define (strip-quotes str)
121 |       (substring str 1 (- (string-length str) 1)))
122 |     (define (ast->term x)
123 |       (match x
124 |         [(? string? x)       (strip-quotes x)]
125 |         [`(tag "Body")       (MacBody)]
126 |         [`(tag "!Body")      (MacTranspBody)]
127 |         [`(tag "Alien")      (Alien)]
128 |         [`(tag "Head" ,_ ,l ,_ ,i ,_ ,t ,_)
129 |                              (MacHead (string->symbol l) (string->number i) (ast->term t))]
130 |         [`(tags . ,xs)       (map ast->term (extract-list xs))]
131 |         [`(terms . ,xs)      (map ast->term (extract-list xs))]
132 |         [`(list ,_ ,xs ,_)   (ast->term xs)]
133 |         [`(node ,l ,_ ,x ,_) (Node (string->symbol l) (ast->term x))]
134 |         [`(term ,x)          (ast->term x)]
135 |         [`(term ,x ,o)       (Tagged (ast->term o) (ast->term x))]))
136 |     (define (convert-origin o)
137 |       (match o
138 |         [(MacBody) (MacBody)]
139 |         [(MacTranspBody) (MacTranspBody)]
140 |         [(MacHead m i t) (MacHead m i (convert t))]
141 |         [(Alien) (Alien)]))
142 |     (define (convert t)
143 |       (match t
144 |         [(Tagged os x)
145 |          (Tagged (map convert-origin os) (convert x))]
146 |         [(Node 'Delay (list x))
147 |          (list 'delay (convert x))]
148 |         ; Core
149 |         [(Node 'True (list)) #t]
150 |         [(Node 'False (list)) #f]
151 |         [(Node 'Num (list x)) (string->number x)]
152 |         [(Node 'Str (list x)) x]
153 |         [(Node 'Id (list x)) (string->symbol x)]
154 |         [(Node 'Lambda (list vs x))
155 |          (list 'lambda (map string->symbol vs) (convert x))]
156 |         [(Node 'Begin (list xs))
157 |          (cons 'begin (map convert xs))]
158 |         [(Node 'Set (list v x))
159 |          (list 'set! (string->symbol v) (convert x))]
160 |         [(Node 'If (list x y z))
161 |          (list 'if (convert x) (convert y) (convert z))]
162 |         [(Node 'Apply (list f xs))
163 |          (map convert (cons f xs))]
164 |         ; Surface
165 |         [(Node 'Function (list vs x))
166 |          (list 'function (map string->symbol vs) (convert x))]
167 |         [(Node 'Return (list x))
168 |          (list 'return (convert x))]
169 |         [(Node 'Bind (list v b))
170 |          (list (string->symbol v) (convert b))]
171 |         [(Node 'Let (list bs xs))
172 |          (cons 'let (cons (map convert bs) (map convert xs)))]
173 |         [(Node 'Letrec (list bs xs))
174 |          (cons 'letrec (cons (map convert bs) (map convert xs)))]
175 |         [(Node 'Else (list x))
176 |          (list (convert x))]
177 |         [(Node 'CondCase (list c x))
178 |          (list (convert c) (convert x))]
179 |         [(Node 'Cond (list xs e))
180 |          (cons 'cond (append (map convert xs) (list (list 'else (convert e)))))]
181 |         [(Node 'Inc (list x))
182 |          (list 'inc (convert x))]
183 |         [(Node 'Or (list xs))
184 |          (cons 'or (map convert xs))]
185 |         [(Node 'And (list xs))
186 |          (cons 'and (map convert xs))]
187 |         [(Node 'Accept (list))
188 |          'accept]
189 |         [(Node 'ATransition (list s l))
190 |          (list (convert s) '-> (convert l))]
191 |         [(Node 'ACondition (list s ts))
192 |          (cons (string->symbol s) (cons ': (map convert ts)))]
193 |         [(Node 'ProcessState (list xs))
194 |          (map convert xs)] ;??
195 |         [(Node 'Automaton (list init cases))
196 |          (cons 'automaton (cons (string->symbol init) (map convert cases)))]
197 |         [(Node 'TranspTest (list v x))
198 |          (list 'transptest (string->symbol v) (convert x))]
199 |         [(Node 'CpsApp (list x y k))
200 |          (list 'cps-app (convert x) (convert y) (string->symbol k))]
201 |         [(Node 'Cps (list x))
202 |          (list 'cps (convert x))]
203 |     ; Value
204 |         [(Node 'Value (list x))
205 |          (deserialize (read (open-input-string x)))]
206 |         [_ (fail (format "Could not parse term: ~a" t))]))
207 |     (let [[result
208 |     (convert (ast->term (syntax->datum (parse (tokenize (open-input-string str))))))
209 |     ]]
210 |       result))
211 |   
212 |   (define (tokenize file)
213 |     ; Glommed together from Danny Yoo's Ragg example & pyret lang lexer
214 |     (port-count-lines! file)
215 |     (define lexer
216 |       (lexer-src-pos
217 |        ;; numbers
218 |        [(concatenation
219 |          (repetition 1 +inf.0 numeric)
220 |          (union ""
221 |                 (concatenation
222 |                  #\.
223 |                  (repetition 1 +inf.0 numeric))))
224 |         (token 'NUMBER lexeme)]
225 |        ;; strings
226 |        [(concatenation
227 |          "\""
228 |          (repetition 0 +inf.0 (union "\\\"" (intersection
229 |                                              (char-complement #\")
230 |                                              (char-complement #\newline))))
231 |          "\"")
232 |         (token 'STRING lexeme)] ; escaping?
233 |        ;; tags
234 |        [(union "Head" "Body" "!Body" "Alien")
235 |         (token lexeme lexeme)]
236 |        ;; brackets
237 |        [(union "[" "]" "{" "}" "(" ")" ",")
238 |         (token lexeme lexeme)]
239 |        ;; whitespace
240 |        [whitespace
241 |         (token 'WS lexeme #:skip? #t)]
242 |        ;; labels
243 |        [(repetition 1 +inf.0 alphabetic)
244 |         (token 'LABEL lexeme)]
245 |        [(eof) (void)]))
246 |     (lambda () (lexer file)))
247 |   
248 |   (define (test-conversion x)
249 |     (check-equal? x (read-term (show-term x))))
250 | 
251 |   
252 |   (test-conversion (Tagged (list (MacBody) (MacBody))
253 |                            (list '+ 'foo "bar" 3)))
254 |   (test-conversion (Tagged (list (Alien))
255 |                            `(+ (- x) 3)))
256 |   (test-conversion (Tagged (list (MacHead 'Macro 2 `(+ x 1)))
257 |                            `(+ x y)))
258 |   (test-conversion `(lambda (x y) (+ x y)))
259 |   (test-conversion `(let [] 3))
260 |   (test-conversion `(let [[x 1] [y 2]] (+ x y)))
261 |   (test-conversion `#t)
262 |   (test-conversion `(set! x 3))
263 |   (test-conversion '(cond [1 2] [3 4] [else 5]))
264 |   (test-conversion '(or 1 2 3))
265 |   (test-conversion `(delay 1))
266 |   (test-conversion `(letrec [[x 1] [y 2]] (+ x y)))
267 |   (test-conversion `(automaton
268 |                      init
269 |                      [init : ["c" -> more]]
270 |                      [more : ["a" -> more]
271 |                              ["d" -> more]
272 |                              ["r" -> end]]
273 |                      [end : accept]))
274 | 
275 |   
276 |   #| RESUGARING |#
277 |   
278 |   (define expand-term (make-parameter #f))
279 |   (define unexpand-term (make-parameter #f))
280 | )


--------------------------------------------------------------------------------
/coq/Macro.v:
--------------------------------------------------------------------------------
  1 | Require Import Coq.Lists.List.
  2 | Require Import Coq.Bool.Bool.
  3 | Require Import Coq.Arith.EqNat.
  4 | Require Import Cases.
  5 | Require Import Util.
  6 | Require Import Term.
  7 | Require Import Subs.
  8 | Require Import Match.
  9 | Require Import Unify.
 10 | Require Import Coq.Classes.RelationClasses.
 11 | Require Import Coq.Setoids.Setoid Coq.Classes.SetoidClass.
 12 | Import StdEnv.
 13 | 
 14 | Definition fvars_subset (q p : term) :=
 15 |   forall v, fvar v q = true -> fvar v p = true.
 16 | 
 17 | Inductive macro_branch :=
 18 | | branch (p q : term) : wf p = true -> wf q = true -> fvars_subset q p -> macro_branch.
 19 | 
 20 | Inductive macro :=
 21 | | macro_mt : macro
 22 | | macro_cons : macro_branch -> macro -> macro.
 23 | 
 24 | Fixpoint expand_branch m t : option term :=
 25 |   match m with
 26 |     | branch p q _ _ _ =>
 27 |       match t / p with
 28 |         | None => None
 29 |         | Some e => Some (e * q)
 30 |       end
 31 |   end.
 32 | 
 33 | Fixpoint unexpand_branch m s t : option term :=
 34 |   match m with
 35 |     | branch p q _ _ _ =>
 36 |       match t / q with
 37 |         | None => None
 38 |         | Some e1 =>
 39 |           match s / p with
 40 |             | None => None
 41 |             | Some e2 => Some (e2 * (e1 * p))
 42 |           end
 43 |       end
 44 |   end.
 45 | 
 46 | Fixpoint expand m t : option (nat * term) :=
 47 |   match m with
 48 |     | macro_mt => None
 49 |     | macro_cons b m =>
 50 |       match expand_branch b t with
 51 |         | None => match expand m t with
 52 |                     | None => None
 53 |                     | Some (n, t) => Some (S n, t)
 54 |                   end
 55 |         | Some t => Some (0, t)
 56 |       end
 57 |   end.
 58 | 
 59 | Fixpoint unexpand m s t n : option term :=
 60 |   match m with
 61 |     | macro_mt => None
 62 |     | macro_cons b m =>
 63 |       match n with
 64 |         | 0 => unexpand_branch b s t
 65 |         | S n => unexpand m s t n
 66 |       end
 67 |   end.
 68 | 
 69 | Definition disjoint_branches b b' :=
 70 |   match (b, b') with
 71 |     | (branch p _ _ _ _, branch p' _ _ _ _) =>
 72 |       ununifyable p p'
 73 |   end.
 74 | 
 75 | Fixpoint wfm m :=
 76 |   let wfb := fix wfb m := fun b =>
 77 |     match m with
 78 |       | macro_mt => true
 79 |       | macro_cons b' m =>
 80 |         disjoint_branches b b' && wfb m b
 81 |     end in
 82 |   match m with
 83 |     | macro_mt => true
 84 |     | macro_cons b m =>
 85 |       wfb m b && wfm m
 86 |   end.
 87 | 
 88 | (* Just for prettier proofs. *)
 89 | Fixpoint wfb m b :=
 90 |   match m with
 91 |     | macro_mt => true
 92 |     | macro_cons b' m =>
 93 |       disjoint_branches b b' && wfb m b
 94 |   end.
 95 | 
 96 | 
 97 | Lemma wfm_cons : forall b m,
 98 |   wfm (macro_cons b m) = true -> wfm m = true.
 99 | Proof.
100 |   intros. simpl in H.
101 |   destruct m; auto. simpl in *.
102 |   rewrite andb_true_iff in H. inversion H. apply H1.
103 | Qed.
104 | 
105 | Lemma wfm_cons_cons : forall b b' m,
106 |   wfm (macro_cons b (macro_cons b' m)) = true ->
107 |   wfm (macro_cons b m) = true.
108 | Proof.
109 |   intros.
110 |   induction m as [ | b'' m]; auto.
111 |   unfold wfm in *. fold wfb in *.
112 |   break_andbs.
113 |   repeat (rewrite andb_true_iff).
114 |   repeat (split; try assumption).
115 | Qed.
116 | 
117 | Lemma disjoint_branches_overlap : forall b b' t,
118 |   disjoint_branches b b' = true ->
119 |   (exists t', expand_branch b  t = Some t') ->
120 |   (exists t', expand_branch b' t = Some t') ->
121 |   False.
122 | Proof.
123 |   intros.
124 |   destruct b as [p q wfp wfq fv].
125 |   destruct b' as [p' q' wfp' wfq' fv'].
126 |   unfold disjoint_branches in H.
127 |   simpl in H0, H1. inversion_clear H0. inversion_clear H1.
128 |   destruct (t / p) eqn:M; try discriminate.
129 |   destruct (t / p') eqn:M'; try discriminate.
130 |   apply tmatch_subs_eq in M. apply tmatch_subs_eq in M'.
131 |   rewrite <- M' in M. apply tmatch__unify in M. inversion M as [r C].
132 |   unfold ununifyable in H. destruct (p ^ p'); try discriminate.
133 | Qed.
134 | 
135 | Lemma wfm_cons_cons_overlap : forall b b' m t,
136 |   wfm (macro_cons b (macro_cons b' m)) = true ->
137 |   (exists t', expand_branch b t = Some t') ->
138 |   (exists t', expand_branch b' t = Some t') ->
139 |   False.
140 | Proof.
141 |   intros.
142 |   assert (D: disjoint_branches b b' = true).
143 |     simpl in H. apply andb_prop in H; inversion H.
144 |     apply andb_prop in H2; inversion H2; assumption.
145 |   apply disjoint_branches_overlap with (b:=b) (b':=b') (t:=t);
146 |     assumption.
147 | Qed.
148 | 
149 | Lemma expand_cons : forall b m t n t',
150 |   expand (macro_cons b m) t = Some (n, t') ->
151 |   expand_branch b t = Some t' \/
152 |     (expand_branch b t = None /\ expand m t = Some (pred n, t')).
153 | Proof.
154 |   intros. generalize dependent n.
155 |   induction m as [ | b' m]; intros.
156 |   Case "macro_mt".
157 |     simpl in H. destruct (expand_branch b t); try discriminate.
158 |     inversion H. left. reflexivity.
159 |   Case "macro_cons".
160 |     simpl in *. destruct (expand_branch b t).
161 |     SCase "first branch".
162 |       inversion H; subst. left. reflexivity.
163 |     SCase "later branch".
164 |       right. split. reflexivity.
165 |       destruct (expand_branch b' t).
166 |       SSCase "b' => Some (n, t')".
167 |         inversion H. reflexivity.
168 |       SSCase "b' => None".
169 |         destruct (expand m t); try discriminate.
170 |         SSSCase "m => Some (n, t')".
171 |           destruct p. inversion H. reflexivity.
172 | Qed.
173 | 
174 | Lemma wfm_expand : forall b m t t1 t2,
175 |   wfm (macro_cons b m) = true ->
176 |   expand_branch b t = Some t1 ->
177 |   expand m t = Some t2 ->
178 |   False.
179 | Proof.
180 |   intros. destruct t2 as [n2 t2]. generalize dependent n2.
181 |   induction m; try discriminate; intros.
182 |   (* m := (cons b (cons b' m)) *)
183 |   rename m into b'. rename m0 into m.
184 |   (* destruct t2 as [n t2]. *)
185 |   apply expand_cons in H1; inversion_clear H1.
186 |   Case "b' => Some t2".
187 |     assert False.
188 |       apply wfm_cons_cons_overlap with (b:=b) (b':=b') (m:=m) (t:=t);
189 |         eauto.
190 |     assumption.
191 |   Case "b' => None, m => Some t2".
192 |     inversion_clear H2 as [B' M].
193 |     apply IHm with (n2:=pred n2).
194 |       apply wfm_cons_cons in H. exact H.
195 |       assumption.
196 | Qed.
197 | 
198 | Definition env_closed a := forall v t,
199 |   lookup v a = Some t -> closed t.
200 | 
201 | Lemma mtEnv_closed : env_closed mtEnv.
202 | Proof.
203 |   intros. unfold env_closed; intros. discriminate H.
204 | Qed.
205 | 
206 | Lemma union_closed : forall a b c,
207 |   a & b = Some c ->
208 |   env_closed a ->
209 |   env_closed b ->
210 |   env_closed c.
211 | Proof.
212 |   unfold env_closed in *; intros a b c C Ha Hb v t L.
213 |   rewrite lookup_union with (a:=a) (b:=b) in L; try assumption.
214 |   destruct (mem v a).
215 |     apply Ha in L; exact L.
216 |     apply Hb in L; exact L.
217 | Qed.
218 | 
219 | Definition closed_tmatch_defn t a := closed t -> env_closed a.
220 | Lemma closed_tmatch_proof : forall t p a, t / p = Some a -> closed_tmatch_defn t a.
221 | Proof.
222 |   apply tmatch_ind; unfold closed_tmatch_defn; intros.
223 |   Case "q = tvar".
224 |     unfold env_closed; intros u t L.
225 |     simpl in L. destruct (VarImpl.beq_var u v); inversion L.
226 |     rewrite <- H1. exact H.
227 |   Case "p, q = const n".
228 |     apply mtEnv_closed.
229 |   Case "p, q = empty".
230 |     apply mtEnv_closed.
231 |   Case "p, q = cons".
232 |     apply closed_uncons in H4. inversion H4 as (Cp & Cps).
233 |     apply H1 in Cp. apply H2 in Cps.
234 |     apply union_closed with (a:=p_q) (b:=ps_qs); assumption.
235 | Qed.
236 | Lemma closed_tmatch : forall t p a,
237 |   t / p = Some a -> closed t -> env_closed a.
238 | Proof.
239 |   intros.
240 |   assert (closed_tmatch_defn t a) by
241 |     (apply closed_tmatch_proof with (p:=p); assumption).
242 |   unfold closed_tmatch_defn in H1. auto.
243 | Qed.
244 | 
245 | Lemma lookup_compose : forall a b v,
246 |   lookup v (compose a b) =
247 |   match lookup v b with
248 |     | None => lookup v a
249 |     | Some t => Some (a * t)
250 |   end.
251 | Proof.
252 |   intros.
253 |   induction b as [ | u t b]; try reflexivity.
254 |   simpl. destruct (VarImpl.beq_var v u); auto.
255 | Qed.
256 | 
257 | Lemma try_lookup__subs : forall v a,
258 |   try_lookup v a = a * (tvar v).
259 | Proof. intros. reflexivity. Qed.
260 | 
261 | Lemma lens_helper : forall t p q t_p a,
262 |   closed t ->
263 |   (forall v, fvar v q = true -> fvar v p = true) ->
264 |   t / p = Some t_p ->
265 |   t_p * q / q = Some a ->
266 |   compose t_p a == t_p.
267 | Proof.
268 |   intros. intro v.
269 |   apply lookup_eqv.
270 |   assert (E: forall v t', lookup v a = Some t' -> lookup v t_p = Some t').
271 |     intros.
272 |     apply lookup_subs_tmatch_eq with (ap_p:=a) (p:=q); intros; try assumption.
273 |     rewrite <- fvar_mem with (p:=t) (q:=p); try assumption.
274 |     apply H0. exact H4.
275 |   assert (Ct_p := H1). apply closed_tmatch in Ct_p; auto.
276 |   assert (Ca: env_closed a).
277 |     unfold env_closed in *. intros va ta La.
278 |     apply Ct_p with (v:=va). apply E. exact La.
279 |   rewrite lookup_compose.
280 |   destruct (lookup v a) as [t'|] eqn:L.
281 |   Case "v in a".
282 |     assert (Ct' := L). apply Ca in Ct'. rewrite closed_subs; try assumption.
283 |     rewrite E with (t':=t'); try assumption. reflexivity.
284 |   Case "v not in a".
285 |     reflexivity.
286 | Qed.
287 | 
288 | Lemma beq_var_false : forall u v,
289 |   beq_var u v = false -> u =/= v.
290 | Proof.
291 |   intros u v H C.
292 |   simpl in C. unfold beq_var_eq in C. unfold VarImpl.beq_var in C.
293 |   rewrite H in C. discriminate C.
294 | Qed.
295 | 
296 | Lemma mem_compose : forall v a b,
297 |   mem v (compose a b) = true -> mem v a = true \/ mem v b = true.
298 | Proof.
299 |   intros.
300 |   induction b; auto.
301 |   destruct (beq_var v v0) eqn:EQ.
302 |   Case "v == v0".
303 |     rewrite mem_bind_same. right; reflexivity. apply EQ.
304 |   Case "v =/= v0".
305 |     simpl in H. apply mem_bind_diff in H.
306 |     SCase "Main proof".
307 |       apply IHb in H. inversion H.
308 |       SSCase "v in a".
309 |         left; assumption.
310 |       SSCase "v in b".
311 |         right. apply mem_bind_diff with (v':=v0) (t:=v1).
312 |           apply beq_var_false; assumption.
313 |         rewrite mem_bind; auto. rewrite mem_bind; auto.
314 |     SCase "Side condition".
315 |       apply beq_var_false; assumption.
316 | Qed.
317 | 
318 | Lemma simple_lens_1 : forall m t t',
319 |   closed t ->
320 |   expand_branch m t = Some t' ->
321 |   unexpand_branch m t t' = Some t.
322 | Proof.
323 |   intros m t t' C H.
324 |   destruct m as [p q WFp WFq FV].
325 |   simpl in *. destruct (t / p) as [t_p|] eqn:TP; inversion_clear H.
326 |   destruct (t_p * q / q) eqn:TPQ.
327 |   Case "Prove the equivalence".
328 |     rewrite compose_subs_eq.
329 |     assert (E: compose t_p e == t_p).
330 |       apply lens_helper with (t:=t) (p:=p) (q:=q); assumption.
331 |     rewrite E. rewrite tmatch_subs_eq with (p:=t); auto.
332 |   Case "Contradiction : t_p * q / q exists".
333 |     rewrite wf_tmatch_iff in WFq. inversion WFq.
334 |     rewrite H in TPQ. discriminate TPQ.
335 | Qed.
336 | 
337 | Lemma simple_lens_2 : forall m s t t',
338 |   closed t ->
339 |   unexpand_branch m s t = Some t' ->
340 |   expand_branch m t' = Some t.
341 | Proof.
342 |   intros m s t t' C H.
343 |   destruct m as [p q WFp WFq FV].
344 |   simpl in *. destruct (t / q) as [t_q|] eqn:TQ; try discriminate.
345 |   destruct (s / p) as [s_p|] eqn:SP; try discriminate.
346 |   destruct (t' / p) eqn:TP.
347 |   Case "Prove the equivalence".
348 |     inversion H as [T'].
349 |     rewrite compose_subs_eq in T'.
350 |     rewrite <- T' in TP.
351 |     apply subs_tmatch_eq in TP.
352 |     rewrite <- TP.
353 |     rewrite <- compose_subs_eq.
354 |     assert (E1: t_q * q = t).
355 |       apply tmatch_subs_eq; assumption.
356 |     assert (E2: s_p * t = t).
357 |       apply closed_subs; assumption.
358 |     rewrite E1, E2. reflexivity.
359 |     SCase "FV condition".
360 |       intros v M. apply mem_compose in M. inversion M.
361 |         erewrite fvar_mem; eauto.
362 |         rewrite FV. reflexivity. erewrite fvar_mem; eauto.
363 |   Case "Contradiction : t' / p exists".
364 |     inversion H as [T'].
365 |     rewrite compose_subs_eq in T'.
366 |     rewrite <- T' in TP.
367 |     apply wf__tmatch with (a := compose s_p t_q) in WFp.
368 |     inversion WFp. rewrite H0 in TP. discriminate TP.
369 | Qed.
370 | 
371 | Lemma lens_1 : forall m t n t',
372 |   closed t ->
373 |   expand m t = Some (n, t') ->
374 |   unexpand m t t' n = Some t.
375 | Proof.
376 |   intros. generalize dependent n.
377 |   induction m; intros.
378 |   Case "no branches".
379 |     discriminate H0.
380 |   Case "some branches".
381 |     simpl in *.
382 |     destruct (expand_branch m t) eqn:B.
383 |     SCase "first branch works".
384 |       inversion H0. rewrite H3 in *.
385 |       apply simple_lens_1; try assumption.
386 |     SCase "first branch fails".
387 |       destruct (expand m0 t).
388 |       SSCase "rest of branches work".
389 |         destruct p. inversion H0. subst.
390 |         apply IHm. reflexivity.
391 |       SSCase "rest of branches fail".
392 |         inversion H0.
393 | Qed.
394 | 
395 | Lemma lens_2 : forall m s t n t',
396 |   closed t ->
397 |   unexpand m s t n = Some t' ->
398 |   wfm m = true ->
399 |   expand m t' = Some (n, t).
400 | Proof.
401 |   intros. rename H1 into WFM. generalize dependent n.
402 |   induction m as [ | b m].
403 |   Case "no branches".
404 |     intros; discriminate H0.
405 |   Case "some branches".
406 |     intros n E.
407 |     simpl.
408 |     destruct n.
409 |     SCase "first branch".
410 |       apply simple_lens_2 in E; try assumption.
411 |       rewrite E. reflexivity.
412 |     SCase "not first branch".
413 |       assert (WFM' := WFM). apply wfm_cons in WFM'.
414 |       apply IHm in E; try assumption. rewrite E.
415 |       destruct (expand_branch b t') eqn:Eb; try reflexivity.
416 |       SSCase "b => Some t0".
417 |         apply wfm_expand with (m:=m) (t2:=(n,t)) in Eb; try assumption.
418 |           elim Eb.
419 | Qed.
420 | 


--------------------------------------------------------------------------------
/coq/Env.v:
--------------------------------------------------------------------------------
  1 | Require Import Coq.Arith.EqNat.
  2 | Require Import Coq.Lists.List.
  3 | Require Import Coq.Bool.Bool.
  4 | Require Import Coq.Classes.RelationClasses.
  5 | Require Import Cases.
  6 | 
  7 | Module Type VALUE.
  8 |   Parameter val : Type.
  9 | End VALUE.
 10 | 
 11 | Module Type VARIABLE.
 12 |   Parameter var : Type.
 13 |   Parameter beq_var : var -> var -> bool.
 14 | 
 15 |   Parameter beq_var_refl : forall (v : var),
 16 |     beq_var v v = true.
 17 |   Parameter beq_var_sym : forall (x y : var),
 18 |     beq_var x y = beq_var y x.
 19 |   Parameter beq_var_trans : forall (x y z : var),
 20 |     beq_var x y = true -> beq_var y z = true -> beq_var x z = true.
 21 | End VARIABLE.
 22 | 
 23 | Module ENV (Import Value : VALUE) (Import Var : VARIABLE).
 24 | 
 25 |   Require Import Coq.Setoids.Setoid Coq.Classes.SetoidClass.
 26 | 
 27 |   Definition beq_var_eq v1 v2 := beq_var v1 v2 = true.
 28 |   Lemma beq_var_eq_refl : forall v, beq_var_eq v v. 
 29 |     Proof. apply beq_var_refl. Qed.
 30 |   Lemma beq_var_eq_sym : forall v1 v2, beq_var_eq v1 v2 -> beq_var_eq v2 v1.
 31 |     Proof. intros. unfold beq_var_eq. rewrite beq_var_sym. auto. Qed.
 32 |   Lemma beq_var_eq_trans : forall v1 v2 v3, beq_var_eq v1 v2 -> beq_var_eq v2 v3 -> beq_var_eq v1 v3.
 33 |     Proof. unfold beq_var_eq; intros. apply beq_var_trans with v2; auto. Qed.
 34 |   Add Relation var beq_var_eq
 35 |   reflexivity proved by beq_var_eq_refl
 36 |   symmetry proved by beq_var_eq_sym
 37 |   transitivity proved by beq_var_eq_trans
 38 |     as Beq_var.
 39 | 
 40 |   Instance Beq_var_Setoid : Setoid var :=
 41 |     {equiv := beq_var_eq; setoid_equiv := Beq_var}.
 42 | 
 43 |   Require Import Coq.Logic.Decidable.
 44 |   Lemma beq_var_eq_dec : forall v1 v2, decidable (v1 == v2).
 45 |   Proof. unfold decidable. intros. destruct (beq_var v1 v2) eqn:v1v2. 
 46 |     left; auto. rewrite <- Bool.not_true_iff_false in v1v2. right; auto.
 47 |   Qed.
 48 | 
 49 |   Inductive env :=
 50 |   | mtEnv : env
 51 |   | bind : var -> val -> env -> env.
 52 | 
 53 |   Fixpoint lookup (v : var) (e : env) : option val :=
 54 |     match e with
 55 |       | mtEnv => None
 56 |       | bind v' t e =>
 57 |         if beq_var v v'
 58 |           then Some t
 59 |           else lookup v e
 60 |     end.
 61 | 
 62 |   Definition mem (v : var) (e : env) : bool :=
 63 |     match lookup v e with
 64 |       | None => false
 65 |       | Some _ => true
 66 |     end.
 67 | 
 68 |   Add Parametric Morphism : lookup with signature (equiv ==> eq ==> eq) as Lookup_beq_var.
 69 |   Proof.
 70 |     intros. induction y0; auto.
 71 |     simpl. destruct (beq_var x v) eqn:xv; destruct (beq_var y v) eqn:yv;
 72 |     try change (x == v) in xv; try change (y == v) in yv; try rewrite <- Bool.not_true_iff_false in *;
 73 |     try change (y =/= v) in yv; try change (x =/= v) in xv; auto. 
 74 |     rewrite <- xv in yv.
 75 |     symmetry in H; contradiction. rewrite <- yv in xv; contradiction.
 76 |   Qed.
 77 | 
 78 |   Add Parametric Morphism : mem with signature (equiv ==> eq ==> eq) as mem_beq_var.
 79 |   Proof.
 80 |     unfold mem. intros. rewrite H. reflexivity.
 81 |   Qed.
 82 | 
 83 | 
 84 |   Fixpoint disjoint (e1 e2 : env) : bool :=
 85 |     match e1 with
 86 |       | mtEnv => true
 87 |       | bind v _ e1 => negb (mem v e2) && disjoint e1 e2
 88 |     end.
 89 | 
 90 |   (* Juxtposition *)
 91 |   Fixpoint concat (e1 e2 : env) : env :=
 92 |     match e1 with
 93 |       | mtEnv => e2
 94 |       | bind v t e => bind v t (concat e e2)
 95 |     end.
 96 |   Notation "e1 ++ e2" := (concat e1 e2).
 97 | 
 98 |   (* Disjoint union *)
 99 |   Definition union (e1 e2 : env) : option env :=
100 |     if disjoint e1 e2
101 |       then Some (e1 ++ e2)
102 |       else None.
103 |   Notation "x & y" := (union x y) (at level 60).
104 | 
105 | 
106 | (*******************)
107 | (*** Easy Lemmas ***)
108 | (*******************)
109 | 
110 |   Lemma mem_mtEnv : forall (v : var), mem v mtEnv = false.
111 |   Proof. intros. unfold mem. simpl. reflexivity. Qed.
112 | 
113 |   Lemma mem_bind : forall (v v' : var) (t : val) (e : env),
114 |     mem v e = true -> mem v (bind v' t e) = true.
115 |   Proof.
116 |     intros.
117 |     unfold mem in H. unfold mem.
118 |     unfold lookup in H. unfold lookup.
119 |     destruct (beq_var v v').
120 |       reflexivity.
121 |       exact H.
122 |   Qed.
123 | 
124 |   Lemma mem_bind_same : forall (v v' : var) (t : val) (e : env),
125 |     v == v' -> mem v (bind v' t e) = true.
126 |   Proof.
127 |     intros. rewrite H. unfold mem. simpl. rewrite beq_var_refl; auto.
128 |   Qed.
129 | 
130 |   Lemma mem_bind_diff : forall (v v' : var) (t : val) (e : env),
131 |     v =/= v' -> mem v (bind v' t e) = true -> mem v e = true.
132 |   Proof.
133 |     intros. unfold mem in *. simpl in H0.
134 |     destruct (beq_var v v') eqn:vv'. contradiction. auto.
135 |   Qed.
136 | 
137 |   Lemma lookup_bind_eq : forall (v : var) (t : val) (e : env),
138 |     lookup v (bind v t e) = Some t.
139 |   Proof.
140 |     intros. unfold lookup. rewrite beq_var_refl. reflexivity.
141 |   Qed.
142 | 
143 |   Lemma lookup_bind_eqv : forall (v v' : var) (t : val) (e : env),
144 |     v == v' -> lookup v (bind v' t e) = Some t.
145 |   Proof.
146 |     intros. unfold lookup.
147 |     rewrite H. reflexivity.
148 |   Qed.
149 | 
150 |   Lemma lookup_bind_diff : forall (v v' : var) (t : val) (e : env),
151 |     v =/= v' -> lookup v (bind v' t e) = lookup v e.
152 |   Proof.
153 |     intros. unfold lookup. destruct (beq_var v v') eqn:vv'. 
154 |     change (v == v') in vv'; contradiction. reflexivity.
155 |   Qed.
156 | 
157 |   Lemma disjoint_mtEnv_l : forall e, disjoint mtEnv e = true.
158 |   Proof. reflexivity. Qed.
159 | 
160 |   Lemma disjoint_mtEnv_r : forall e, disjoint e mtEnv = true.
161 |   Proof. intros. induction e; auto. Qed.
162 | 
163 |   Lemma disjoint_bind_r : forall v t e1 e2,
164 |     disjoint (bind v t e1) e2 = negb (mem v e2) && disjoint e1 e2.
165 |   Proof. auto. Qed.
166 | 
167 |   Lemma disjoint_bind_l : forall e1 v t e2,
168 |     disjoint e1 (bind v t e2) = negb (mem v e1) && disjoint e1 e2.
169 |   Proof.
170 |     intros.
171 |     induction e1 as [|v1 t1 e1].
172 |     Case "e1 = mtEnv".
173 |       reflexivity.
174 |     Case "e1 = bind v1 t1 e1".
175 |       simpl. rewrite IHe1.
176 |       assert (L: forall u v t e,
177 |         negb (mem u (bind v t e)) = negb (beq_var u v) && negb (mem u e)).
178 |       intros. rewrite <- negb_orb.
179 |         unfold mem, lookup.
180 |         destruct (beq_var u v0); simpl; reflexivity.
181 |       rewrite L. rewrite L. rewrite beq_var_sym.
182 |       assert (Z: forall a b c d, a && b && (c && d) = a && c && (b && d)).
183 |         intros. destruct a, b, c, d; reflexivity.
184 |       apply Z.
185 |   Qed.
186 | 
187 |   Lemma disjoint_sym : forall e1 e2, disjoint e1 e2 = disjoint e2 e1.
188 |   Proof.
189 |     intros.
190 |     induction e1 as [|v1 t1 e1]; intros.
191 |     Case "mtEnv".
192 |       rewrite disjoint_mtEnv_r. reflexivity.
193 |     Case "e1 = bind v1 t1 e1".
194 |       rewrite disjoint_bind_l, disjoint_bind_r, IHe1.
195 |       reflexivity.
196 |   Qed.
197 | 
198 |   Lemma disjoint_overlap : forall v e1 e2,
199 |     mem v e1 = true -> mem v e2 = true -> disjoint e1 e2 = false.
200 |   Proof.
201 |     intros. induction e1 as [|v1 t1 e1].
202 |     Case "e1 = mtEnv". inversion H.
203 |     Case "e1 = bind v1 t1 e1". simpl.
204 |       destruct (mem v1 e2) eqn:M; try reflexivity.
205 |       destruct (beq_var_eq_dec v v1).
206 |       SCase "v == v1".
207 |         rewrite H1 in *. rewrite H0 in M. inversion M.
208 |       SCase "v != v1".
209 |         apply mem_bind_diff in H. apply IHe1 in H. simpl. exact H.
210 |         exact H1.
211 |   Qed.
212 | 
213 |   Lemma disjoint_false : forall e1 e2,
214 |     disjoint e1 e2 = false -> e1 & e2 = None.
215 |   Proof. intros. unfold union. rewrite H. reflexivity. Qed.
216 | 
217 |   Lemma disjoint_true : forall e1 e2,
218 |     disjoint e1 e2 = true -> e1 & e2 = Some (e1 ++ e2).
219 |   Proof. intros. unfold union. rewrite H. reflexivity. Qed.
220 | 
221 |   Lemma disjoint_iff : forall e1 e2,
222 |     disjoint e1 e2 = true <-> exists e12, e1 & e2 = Some e12.
223 |   Proof.
224 |     intros. split.
225 |     Case "disjoint".
226 |       intros. apply disjoint_true in H.
227 |       exists (e1 ++ e2). exact H.
228 |     Case "not disjoint".
229 |       intros. inversion H. unfold union in H0.
230 |       destruct (disjoint e1 e2); auto. inversion H0.
231 |   Qed.
232 | 
233 | 
234 | (*********************)
235 | (*** Concat Lemmas ***)
236 | (*********************)
237 | 
238 | 
239 |   Lemma concat_mtEnv_l : forall e, mtEnv ++ e = e.
240 |   Proof. reflexivity. Qed.
241 | 
242 |   Lemma concat_mtEnv_r : forall e, e ++ mtEnv = e.
243 |   Proof. intros. induction e; simpl; try rewrite IHe; auto. Qed.
244 | 
245 |   Lemma lookup_concat : forall v e1 e2,
246 |     lookup v (e1 ++ e2) = if mem v e1 then lookup v e1 else lookup v e2.
247 |   Proof.
248 |     intros. generalize dependent e2. induction e1 as [ | v1 t1 e1].
249 |     Case "e1 = mtEnv".
250 |       intros. reflexivity.
251 |     Case "e1 = bind v1 t1 e1".
252 |       intros. simpl.
253 |       unfold mem, lookup in *.
254 |       destruct (beq_var v v1); auto.
255 |   Qed.
256 |   Hint Resolve lookup_concat.
257 | 
258 |   Lemma lookup_concat_mem : forall v e1 e2,
259 |     mem v e1 = true -> lookup v (e1 ++ e2) = lookup v e1.
260 |   Proof. intros. rewrite lookup_concat. rewrite H. reflexivity. Qed.
261 |   Hint Resolve lookup_concat_mem.
262 |   
263 |   Lemma lookup_concat_not_mem : forall v e1 e2,
264 |     mem v e1 = false -> lookup v (e1 ++ e2) = lookup v e2.
265 |   Proof. intros. rewrite lookup_concat. rewrite H. reflexivity. Qed.
266 |   Hint Resolve lookup_concat_not_mem.
267 | 
268 |   Lemma lookup_union : forall v a b c,
269 |     a & b = Some c ->
270 |     lookup v c = if mem v a then lookup v a else lookup v b.
271 |   Proof.
272 |     intros. unfold union in H.
273 |     destruct (disjoint a b); inversion H.
274 |     rewrite lookup_concat. reflexivity.
275 |   Qed.
276 | 
277 |   Lemma lookup_not_mem : forall (v : var) (e : env),
278 |     mem v e = false <-> lookup v e = None.
279 |   Proof.
280 |     intros; split. intros.
281 |     destruct (lookup v e) eqn:ve; auto. unfold mem in H. unfold mem in H.
282 |     rewrite ve in H. discriminate H.
283 |     intro. unfold mem.
284 |     destruct (lookup v e); [inversion H | reflexivity].
285 |   Qed.
286 |   Hint Resolve lookup_not_mem.
287 | 
288 |   Lemma lookup_mem : forall (v : var) (a : env),
289 |     mem v a = true <-> exists b, lookup v a = Some b.
290 |   Proof.
291 |     intros. unfold mem. destruct (lookup v a).
292 |     split; eauto.
293 |     split; intros; inversion H; discriminate.
294 |   Qed.
295 | 
296 | (********************)
297 | (*** Union Lemmas ***)
298 | (********************)
299 | 
300 |   Lemma union_mtEnv_l : forall (e : env), mtEnv & e = Some e.
301 |   Proof. reflexivity. Qed.
302 | 
303 |   Lemma union_mtEnv_r : forall (e : env), e & mtEnv = Some e.
304 |   Proof.
305 |     intros. induction e.
306 |     Case "mtEnv". reflexivity.
307 |     Case "bind v t e". unfold union.
308 |       rewrite disjoint_mtEnv_r. rewrite concat_mtEnv_r. reflexivity.
309 |   Qed.
310 | 
311 |   Lemma union_overlap : forall (e1 e2 : env) (v : var),
312 |     mem v e1 = true -> mem v e2 = true -> e1 & e2 = None.
313 |   Proof.
314 |     intros. apply disjoint_false.
315 |     apply disjoint_overlap with (v:=v); auto.
316 |   Qed.
317 |   
318 |   Lemma env_comm : forall (e1 e2 e12 : env),
319 |     disjoint e1 e2 = true -> forall v, lookup v (e1 ++ e2) = lookup v (e2 ++ e1).
320 |   Proof.
321 |     intros. rename H into D12.
322 |     assert (D21: disjoint e2 e1 = true) by
323 |       (rewrite disjoint_sym; assumption).
324 |     assert (D12' := D12).
325 |     apply disjoint_true in D12. apply disjoint_true in D21.
326 |     destruct (e2 & e1) as [e21|] eqn:E21; try inversion D21.
327 |     (* Prove e1 ++ e2 == e2 ++ e1 *)
328 |     destruct (mem v e1) eqn:M1; destruct (mem v e2) eqn:M2.
329 |     Case "v in e1, e2".
330 |       assert (C: disjoint e1 e2 = false).
331 |         apply disjoint_overlap with (v:=v); auto.
332 |       rewrite D12' in C; inversion C.
333 |     Case "v in e1, not in e2".
334 |       assert (L1: lookup v (e1 ++ e2) = lookup v e1) by auto.
335 |       assert (L2: lookup v (e2 ++ e1) = lookup v e1) by auto.
336 |       rewrite L1; rewrite L2; reflexivity.
337 |     Case "v in e2, not in e1".
338 |       assert (L1: lookup v (e1 ++ e2) = lookup v e2) by auto.
339 |       assert (L2: lookup v (e2 ++ e1) = lookup v e2) by auto.
340 |       rewrite L1; rewrite L2; reflexivity.
341 |     Case "v not in e1, e2".
342 |       assert (L12: lookup v (e1 ++ e2) = lookup v e2) by auto.
343 |       assert (L21: lookup v (e2 ++ e1) = lookup v e1) by auto.
344 |       assert (L1: lookup v e1 = None) by (apply lookup_not_mem; auto).
345 |       assert (L2: lookup v e2 = None) by (apply lookup_not_mem; auto).
346 |       rewrite L12, L21, L1, L2. reflexivity.
347 |   Qed.
348 | 
349 |   (* needed? *)
350 |   Lemma env_comm2 : forall (e1 e2 e12 : env),
351 |     e1 & e2 = Some e12 -> exists e21,
352 |       e2 & e1 = Some e21 /\
353 |       forall v, lookup v e12 = lookup v e21.
354 |   Proof.
355 |     intros.
356 |     assert (D12: disjoint e1 e2 = true) by
357 |       (apply disjoint_iff; exists e12; assumption).
358 |     assert (D21: disjoint e2 e1 = true) by
359 |       (rewrite disjoint_sym; assumption).
360 |     assert (G: forall v, lookup v (e1 ++ e2) = lookup v (e2 ++ e1)).
361 |       apply env_comm. constructor. assumption.
362 |     exists (e2 ++ e1). split.
363 |       apply disjoint_true in D21; assumption.
364 |       apply disjoint_true in D12.
365 |       rewrite D12 in H; inversion H; assumption.
366 |   Qed.
367 | 
368 | (* Compose *)
369 | 
370 | 
371 | (* Composition *)
372 | 
373 |   Lemma lookup__mem : forall v e t,
374 |     lookup v e = Some t -> mem v e = true.
375 |   Proof. intros. unfold mem. rewrite H; auto. Qed.
376 | 
377 |   Lemma not_lookup__not_mem : forall v e,
378 |     lookup v e = None -> mem v e = false.
379 |   Proof. intros. unfold mem. rewrite H; auto. Qed.
380 | 
381 |   Lemma union_mem : forall v a b c,
382 |     a & b = Some c ->
383 |     mem v c = true -> mem v a = true \/ mem v b = true.
384 |   Proof.
385 |     intros.
386 |     repeat (rewrite lookup_mem in *).
387 |     inversion H0. destruct (lookup v a) as [t|] eqn:L.
388 |       left. exists t. auto.
389 |       right. rewrite <- lookup_not_mem in L.
390 |         rewrite lookup_union with (a:=a) (b:=b) in H1.
391 |         rewrite L in H1. rewrite H1. eauto. auto.
392 |   Qed.
393 | 
394 |   Lemma union_mem_left : forall v a b c,
395 |     a & b = Some c ->
396 |     mem v a = true ->
397 |     lookup v c = lookup v a.
398 |   Proof.
399 |     intros. rewrite lookup_union with (a:=a) (b:=b).
400 |     rewrite H0. reflexivity. assumption.
401 |   Qed.
402 |   Hint Resolve union_mem_left.
403 | 
404 |   Lemma union_mem_right : forall v a b c,
405 |     a & b = Some c ->
406 |     mem v b = true ->
407 |     lookup v c = lookup v b.
408 |   Proof.
409 |     intros. rewrite lookup_union with (a:=a) (b:=b); auto.
410 |     destruct (mem v a) eqn:D; auto.
411 |     rewrite union_overlap with (v:=v) in H; inversion H; auto.
412 |   Qed.
413 |   Hint Resolve union_mem_right.
414 | 
415 | End ENV.


--------------------------------------------------------------------------------
/confection/Pattern.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | module Pattern where
  3 | 
  4 | import qualified Data.Map as Map
  5 | import Data.Map (Map)
  6 | import qualified Data.Set as Set
  7 | import Data.Set (Set)
  8 | import Control.Monad (liftM, liftM2, zipWithM, when, replicateM)
  9 | import System.Random (randomIO)
 10 | import System.IO.Unsafe (unsafePerformIO) -- it's only to generate nonces, I swear!
 11 | import Data.Char (chr)
 12 | import Debug.Trace (trace)
 13 | 
 14 | 
 15 | newtype Var = Var String deriving (Eq, Ord)
 16 | newtype Label = Label String deriving (Eq, Ord)
 17 | 
 18 | type MacroTable = Map Label Macro
 19 | 
 20 | data Macro = Macro Label [Rule]
 21 |             
 22 | data Rule = Rule Pattern Pattern [Var] RuleFlags
 23 |             deriving (Eq) -- from, to, fresh vars
 24 | 
 25 | data RuleFlags = RuleFlags Bool -- overlap override
 26 |                  deriving (Eq)
 27 | 
 28 | data Info = Info Bool Bool -- transp marked, always transparent
 29 | noInfo = Info False False
 30 | 
 31 | data Pattern =
 32 |     PVar Var
 33 |   | PConst Const
 34 |   | PNode Info Label [Pattern]
 35 |   | PRep [Pattern] Pattern
 36 |   | PList [Pattern]
 37 |   | PTag Origin Pattern
 38 |     deriving (Eq)
 39 | 
 40 | data Term =
 41 |     TConst Const
 42 |   | TNode Label [Term]
 43 |   | TList [Term]
 44 |   | TTag Origin Term
 45 |     deriving (Eq)
 46 | 
 47 | data Origin =
 48 |     MacHead Label Int Term
 49 |   | MacBody
 50 |   | MacTranspBody
 51 |   | MacAlien
 52 | 
 53 | data Const =
 54 |     CInt Int
 55 |   | CDbl Double
 56 |   | CStr String
 57 |     deriving (Eq, Ord)
 58 | 
 59 | instance Eq Info where
 60 |   (==) = const (const True)
 61 | 
 62 | instance Eq Origin where
 63 |   MacBody == MacBody = True
 64 |   MacTranspBody == MacTranspBody = True
 65 |   MacHead m _ _ == MacHead m' _ _ = m == m'
 66 |   _ == _ = False
 67 | 
 68 | data Binding =
 69 |     BList [Binding]
 70 |   | BTerm Term
 71 | 
 72 | type Env = Map Var Binding
 73 | 
 74 | 
 75 | data UnifyFailure = UnifyFailure Pattern Pattern
 76 | 
 77 | -- This means something really went wrong;
 78 | -- should never occur on good-faith user input.
 79 | data ResugarError = NoMatchingCase Label Term [Rule]
 80 |                   | NoSuchMacro Label
 81 |                   | NoSuchCase Label Int
 82 |                   | UnboundSubsVar Var
 83 |                   | DepthMismatch Var
 84 |                   deriving (Eq)
 85 | 
 86 | -- Except for `ResugarError`, this just means the term couldn't be resugared.
 87 | data ResugarFailure = MatchFailure Term Pattern
 88 |                     | TermIsOpaque
 89 |                     | ResugarError ResugarError
 90 |                     deriving (Eq)
 91 | 
 92 | data WFError = CasesOverlap Label Pattern Pattern Pattern
 93 |              | UnboundVar Var
 94 |              | EmptyEllipsis Label
 95 |              | DuplicateVar Var
 96 | 
 97 | instance Show Label where
 98 |   show (Label l) = l
 99 | 
100 | 
101 | -- These should never occur, even on malformed or malicious user input.
102 | internalError msg = error ("Internal error: " ++ msg)
103 | 
104 | varName :: Var -> String
105 | varName (Var name) = name
106 | 
107 | fvarList :: Pattern -> [Var]
108 | fvarList (PVar v) = [v]
109 | fvarList (PConst _) = []
110 | fvarList (PNode _ _ ps) = concat (map fvarList ps)
111 | fvarList (PRep ps p) = (concat (map fvarList ps)) ++ fvarList p
112 | fvarList (PList ps) = concat (map fvarList ps)
113 | fvarList (PTag _ p) = fvarList p
114 | 
115 | findDuplicate :: Ord a => [a] -> Maybe a
116 | findDuplicate xs = findDup xs Set.empty
117 |   where
118 |     findDup [] _ = Nothing
119 |     findDup (x:xs) s =
120 |       if Set.member x s
121 |       then Just x
122 |       else findDup xs (Set.insert x s)
123 | 
124 | fvars :: Pattern -> Set Var
125 | fvars (PVar v) = Set.singleton v
126 | fvars (PConst _) = Set.empty
127 | fvars (PNode _ _ ps) = Set.unions (map fvars ps)
128 | fvars (PRep ps p) = Set.union (Set.unions (map fvars ps)) (fvars p)
129 | fvars (PList ps) = Set.unions (map fvars ps)
130 | fvars (PTag _ p) = fvars p
131 | 
132 | bodyWrap :: Bool -> Pattern -> Pattern
133 | -- Enclose all of a pattern's subpatterns in MacBody tags.
134 | bodyWrap z p = wrap p
135 |   where
136 |     wrap :: Pattern -> Pattern
137 |     wrap (PVar v) = PVar v
138 |     wrap (PConst c) = PConst c
139 |     wrap (PNode i@(Info z' v) l ps) =
140 |       if z'
141 |       then opacify (not z) (PNode i l (map (bodyWrap (not z)) ps))
142 |       else opacify z (PNode i l (map wrap ps))
143 |     wrap (PRep ps p) = PRep (map wrap ps) (wrap p)
144 |     wrap (PList ps) = PList (map wrap ps)
145 |     wrap (PTag o p) = opacify z (skipTags (PTag o p))
146 |       where
147 |         skipTags (PTag o p) = PTag o (skipTags p)
148 |         skipTags p = wrap p
149 |     
150 |     opacify :: Bool -> Pattern -> Pattern
151 |     opacify z n@(PNode (Info _ True) _ _) = n -- never, ever tag these nodes
152 |     opacify z p = PTag (if z then MacBody else MacTranspBody) p
153 | 
154 | 
155 | {- Matching -}
156 | 
157 | match :: Term -> Pattern -> Either ResugarFailure Env
158 | match (TConst c)   (PConst c')    | c == c' = return mtEnv
159 | match t            (PVar v)                 = return (singletonEnv v t)
160 | match (TTag o t)   (PTag o' p)    | o == o' = match t p
161 | match (TNode l ts) (PNode i l' ps)| l == l' = matchNode i l ts ps
162 | match (TList ts)   (PList ps)     | length ts == length ps =
163 |   liftM Map.unions (zipWithM match ts ps)
164 | match (TList ts)   (PRep ps p)    | length ts >= length ps = do
165 |   e1 <- liftM Map.unions (zipWithM match (take (length ps) ts) ps)
166 |   e2 <- matchList (drop (length ps) ts) p
167 |   return (unifyEnv e1 e2)
168 | match t            p                        = Left (MatchFailure t p)
169 | 
170 | matchNode :: Info -> Label -> [Term] -> [Pattern] -> Either ResugarFailure Env
171 | matchNode _ _ [] [] = return mtEnv
172 | matchNode i l (t:ts) (p:ps) = liftM2 unifyEnv (match t p) (matchNode i l ts ps)
173 | matchNode i l ts ps = Left (MatchFailure (TNode l ts) (PNode i l ps))
174 | 
175 | matchList :: [Term] -> Pattern -> Either ResugarFailure Env
176 | matchList []     p = return $ Map.fromList $
177 |   map (\v -> (v, BList [])) (Set.toList (fvars p))
178 | matchList (t:ts) p = liftM mergeEnvs (zipWithM match (t:ts) (repeat p))
179 | 
180 | mergeEnvs :: [Env] -> Env
181 | mergeEnvs [] = internalError "mergeEnvs: Unexpected empty env list"
182 | mergeEnvs es = foldl1 merge (map singletonWrap es)
183 |   where
184 |     singletonWrap = Map.map (\t -> BList [t])
185 |     merge e1 e2 = Map.intersectionWith concatBindings e1 e2
186 |     concatBindings (BList bs) (BList bs') = BList (bs ++ bs')
187 |     concatBindings _ _ = internalError "concatBindings: unexpected"
188 | 
189 | 
190 | {- Substitution -}
191 | 
192 | subs :: Env -> Pattern -> Either ResugarFailure Term
193 | subs e (PVar v) = case Map.lookup v e of
194 |   Nothing -> Left (ResugarError (UnboundSubsVar v))
195 |   Just (BTerm t) -> return t
196 |   Just (BList _) -> Left (ResugarError (DepthMismatch v))
197 | subs e (PConst c)     = return (TConst c)
198 | subs e (PNode _ l ps) = liftM (TNode l) (mapM (subs e) ps)
199 | subs e (PList ps)     = liftM TList (mapM (subs e) ps)
200 | subs e (PRep ps p)    = liftM TList (liftM2 (++) (mapM (subs e) ps) (subsList e p))
201 | subs e (PTag o p)     = liftM (TTag o) (subs e p)
202 | 
203 | subsList e p = do
204 |   let vs = Set.toList (fvars p)
205 |   if null vs
206 |     then internalError
207 |          "Empty ellipsis: should have been caught by wf check"
208 |     else do
209 |     es <- splitEnv e (Set.toList (fvars p))
210 |     mapM (\e -> subs e p) es
211 | 
212 | mtEnv = Map.empty
213 | singletonEnv v t = Map.singleton v (BTerm t)
214 | unifyEnv = Map.union
215 | 
216 | composeEnvs :: Env -> Env -> Env
217 | composeEnvs e1 e2 = Map.union e2 e1
218 | 
219 | splitEnv :: Env -> [Var] -> Either ResugarFailure [Env]
220 | splitEnv e vs = do
221 |   n <- n
222 |   mapM (\i -> mapWithKeyM (split i) e) [0 .. n-1]
223 |   where
224 |     -- Caller must check that vs nonempty!
225 |     n = case Map.lookup (head vs) e of
226 |       Nothing -> Left (ResugarError (UnboundSubsVar (head vs)))
227 |       Just (BTerm _) -> Left (ResugarError (DepthMismatch (head vs)))
228 |       Just (BList bs) -> return (length bs)
229 |     split i v b =
230 |       if elem v vs
231 |       then case b of
232 |         BTerm _ -> Left (ResugarError (DepthMismatch v))
233 |         BList bs -> return (bs !! i)
234 |       else return b
235 | 
236 | 
237 | {- Unification (incomplete) -}
238 | 
239 | unify :: Pattern -> Pattern -> Either UnifyFailure Pattern
240 | unify (PConst c)   (PConst c')       | c == c' = return (PConst c)
241 | unify (PVar v)     p                           = return p
242 | unify p            (PVar v)                    = return p
243 | unify (PTag o p)   (PTag o' p')      | o == o' = liftM (PTag o) (unify p p')
244 | unify (PList ps)   (PList qs)        | length ps == length qs
245 |   = liftM PList (zipWithM unify ps qs)
246 | unify (PList ps)   (PRep qs q)       | length qs <= length ps = do
247 |   head <- zipWithM unify (take (length qs) ps) qs
248 |   tail <- zipWithM unify (drop (length qs) ps) (repeat q)
249 |   return (PRep (head ++ tail) q)
250 | unify (PRep ps p)  (PList qs)        | length ps <= length qs = do
251 |   head <- zipWithM unify ps         (take (length ps) qs)
252 |   tail <- zipWithM unify (repeat p) (drop (length ps) qs)
253 |   return (PRep (head ++ tail) p)
254 | unify (PRep ps p) (PRep qs q)        | length ps <= length qs = do
255 |   head <- zipWithM unify ps (take (length ps) qs)
256 |   midd <- zipWithM unify (repeat p) (drop (length ps) qs)
257 |   tail <- unify p q
258 |   return (PRep (head ++ midd) tail)
259 | unify (PRep ps p) (PRep qs q)        | length ps > length qs = do
260 |   head <- zipWithM unify (take (length qs) ps) qs
261 |   midd <- zipWithM unify (drop (length qs) ps) (repeat q)
262 |   tail <- unify p q
263 |   return (PRep (head ++ midd) tail)
264 | unify (PRep ps p)  (PRep ps' p')               = error "unify: "
265 | unify (PNode i l ps) (PNode _ l' ps') | l == l' && length ps == length ps'
266 |   = liftM (PNode i l) (zipWithM unify ps ps')
267 | unify p q = Left (UnifyFailure p q)
268 | 
269 | subsumed :: Pattern -> Pattern -> Bool
270 | subsumed _            (PVar _)                 = True
271 | subsumed (PConst c)   (PConst c')    | c == c' = True
272 | subsumed (PTag o p)   (PTag o' p')   | o == o' = subsumed p p'
273 | subsumed (PList ps)   (PList qs)     | length ps == length qs
274 |   = and (zipWith subsumed ps qs)
275 | subsumed (PList ps) (PRep qs q)      | length ps >= length qs
276 |   = and (zipWith subsumed (take (length qs) ps) qs) &&
277 |     and (zipWith subsumed (drop (length qs) ps) (repeat q))
278 | subsumed (PRep ps p)  (PRep qs q)    | length ps >= length qs
279 |   = and (zipWith subsumed (take (length qs) ps) qs) &&
280 |     and (zipWith subsumed (drop (length qs) ps) (repeat q)) &&
281 |     subsumed p q
282 | subsumed (PNode _ l ps) (PNode _ l' ps') | l == l' && length ps == length ps'
283 |   = and (zipWith subsumed ps ps')
284 | subsumed _            _                        = False
285 | 
286 | 
287 | {- Macros -}
288 | 
289 | gensym :: String -> String
290 | gensym prefix =
291 |   prefix ++ unsafePerformIO (replicateM 8 randLetter)
292 |   where
293 |     randLetter :: IO Char
294 |     randLetter = do
295 |       c <- randomIO :: IO Int
296 |       return (chr ((c `mod` 26) + 65))
297 | 
298 | addFreshVars :: [Var] -> Env -> Env
299 | addFreshVars [] env = env
300 | addFreshVars (Var f:fs) env =
301 |   addFreshVars fs $
302 |   Map.insert (Var f) (BTerm (TConst (CStr (gensym f)))) env
303 | 
304 | expandMacro :: Macro -> Term -> Either ResugarFailure (Int, Term)
305 | expandMacro (Macro name cs) t = expandCases 0 cs
306 |   where
307 |     expandCases _ [] = Left (ResugarError (NoMatchingCase name t cs))
308 |     expandCases i (c:cs) = eitherOr (expandCase i c) (expandCases (i + 1) cs)
309 |     
310 |     expandCase i (Rule p p' fs _) = do
311 |       e <- match t p -- (bodyWrap False p) -- no good reason for LHS !s
312 |       t <- subs (addFreshVars fs e) (bodyWrap True p')
313 |       return (i, t)
314 | 
315 | unexpandMacro :: Macro -> (Int, Term) -> Term -> Either ResugarFailure Term
316 | unexpandMacro (Macro l cs) (i, t') t =
317 |   if i >= length cs
318 |   then Left (ResugarError (NoSuchCase l i))
319 |   else unexpandCase (cs !! i)
320 |     where
321 |       unexpandCase (Rule p p' _ _) = do
322 |         e <- match t p -- (bodyWrap False p)
323 |         e' <- match t' (bodyWrap True p')
324 |         subs (composeEnvs e e') p
325 | 
326 | 
327 | {- Well-formedness Checking -}
328 | 
329 | checkDuplicateVar :: Pattern -> Either WFError ()
330 | checkDuplicateVar p = case findDuplicate (fvarList p) of
331 |   Nothing -> return ()
332 |   Just v -> Left (DuplicateVar v)
333 | 
334 | wellFormedMacro :: Macro -> Either WFError ()
335 | wellFormedMacro (Macro l cs) = do
336 |   mapM_ disjointCases (allDistinctPairs cs)
337 |   mapM_ (wellFormedCase l) cs
338 |   where
339 |     disjointCases ((Rule p _ _ (RuleFlags True)), _) =
340 |       return ()
341 |     disjointCases ((Rule p _ _ _), (Rule q _ _ _)) =
342 |       case unify p q of
343 |         Left _ -> return ()
344 |         Right r -> Left (CasesOverlap l p q r)
345 | 
346 | wellFormedCase :: Label -> Rule -> Either WFError ()
347 | wellFormedCase l (Rule p q fs _) = do
348 |   checkDuplicateVar p
349 |   -- TODO: figure out how to handle dup vars systematically
350 |   -- checkDuplicateVar q
351 |   wellFormedPattern l p
352 |   wellFormedPattern l q
353 |   varSubset p q
354 |   where
355 |     varSubset p q =
356 |       let pVars = Set.union (fvars p) (Set.fromList fs)
357 |           qVars = fvars q in
358 |       case Set.toList (Set.difference qVars pVars) of
359 |         [] -> return ()
360 |         (v:_) -> Left (UnboundVar v)
361 | 
362 | wellFormedPattern :: Label -> Pattern -> Either WFError ()
363 | wellFormedPattern _ (PVar _) = return ()
364 | wellFormedPattern _ (PConst _) = return ()
365 | wellFormedPattern l (PTag _ p) = wellFormedPattern l p
366 | wellFormedPattern l (PNode _ _ ps) = mapM_ (wellFormedPattern l) ps
367 | wellFormedPattern l (PList ps) = mapM_ (wellFormedPattern l) ps
368 | wellFormedPattern l (PRep ps p) = do
369 |   mapM_ (wellFormedPattern l) ps
370 |   wellFormedPattern l p
371 |   when (Set.null (fvars p)) (Left (EmptyEllipsis l))
372 | 
373 | 
374 | {- Expansion and Unexpansion -}
375 | 
376 | lookupMacro :: Label -> MacroTable -> Maybe Macro
377 | lookupMacro l ms = Map.lookup l ms
378 | 
379 | expand :: MacroTable -> Term -> Either ResugarFailure Term
380 | expand _ (TConst c) = return (TConst c)
381 | expand ms (TTag o t) = liftM (TTag o) ((expand ms) t)
382 | expand ms (TList ts) = liftM TList (mapM (expand ms) ts)
383 | expand ms t@(TNode l ts) =
384 |   case lookupMacro l ms of
385 |     Nothing -> liftM (TNode l) (mapM (expand ms) ts)
386 |     Just m -> do
387 |       (i, t') <- expandMacro m t
388 |       expand ms (TTag (MacHead l i (TNode l ts)) t')
389 | 
390 | unexpand :: MacroTable -> Term -> Either ResugarFailure Term
391 | unexpand ms t = do
392 |   t' <- rec t
393 |   if unlittered t'
394 |     then return (stripTags t')
395 |     else Left TermIsOpaque
396 |   where
397 |     unlittered :: Term -> Bool
398 |     unlittered (TConst c) = True
399 |     unlittered (TList ts) = and (map unlittered ts)
400 |     unlittered (TNode _ ts) = and (map unlittered ts)
401 |     unlittered (TTag MacTranspBody t) = unlittered t
402 |     unlittered (TTag _ _) = False
403 |     
404 |     stripTags :: Term -> Term
405 |     stripTags (TConst c) = TConst c
406 |     stripTags (TList ts) = TList (map stripTags ts)
407 |     stripTags (TNode l ts) = TNode l (map stripTags ts)
408 |     stripTags (TTag _ t) = stripTags t
409 |     
410 |     rec :: Term -> Either ResugarFailure Term
411 |     rec (TConst c) = return (TConst c)
412 |     rec (TList ts) = liftM TList (mapM rec ts)
413 |     rec (TNode l ts) = liftM (TNode l) (mapM rec ts)
414 |     rec (TTag (MacHead l i t) t') =
415 |       case lookupMacro l ms of
416 |         Nothing -> Left (ResugarError (NoSuchMacro l))
417 |         Just l -> do
418 |           t' <- rec t'
419 |           unexpandMacro l (i, t') t
420 |     rec (TTag o t') = liftM (TTag o) (rec t')
421 | 
422 | 
423 | {- Errors as Eithers -}
424 | #if __GLASGOW_HASKELL__ < 700
425 | instance Monad (Either a) where
426 |   return x = Right x
427 |   e >>= f = case e of 
428 |     Left err -> Left err
429 |     Right x -> f x
430 | #endif
431 | 
432 | eitherOr :: Either e a -> Either e a -> Either e a
433 | eitherOr e1 e2 = case e1 of
434 |   Left _ -> e2
435 |   Right x -> Right x
436 | 
437 | isLeft e  = case e of Left _ -> True;  Right _ -> False
438 | isRight e = case e of Left _ -> False; Right _ -> True
439 | 
440 | 
441 | {- Utility -}
442 | 
443 | allDistinctPairs :: [a] -> [(a, a)]
444 | allDistinctPairs [] = []
445 | allDistinctPairs [_] = []
446 | allDistinctPairs (x:xs) = map (\y -> (x, y)) xs ++ allDistinctPairs xs
447 | 
448 | mapWithKeyM :: (Monad m, Ord k) => (k -> a -> m b) -> Map k a -> m (Map k b)
449 | mapWithKeyM f m = liftM Map.fromList (mapM f' (Map.toList m))
450 |   where
451 |     f' (k, x) = f k x >>= return . (\x -> (k, x))
452 | 
453 | 


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