Initial commit

es-mode.el

@@ -0,0 +1,46 @@
+;;; es-mode.el --- an Extensible Syntax editing mode
+
+;; Author:  Erik Silkensen (silkense@colorado.edu)
+;; Version: 29 November 2011
+
+;;; Commentary:
+
+;; Installation:
+;;
+;;  - put `es-mode.el' somewhere in your emacs load path
+;;  - add these lines to your .emacs file:
+;;    (autoload 'es-mode "es-mode" nil t)
+;;    (add-to-list 'auto-mode-alist '("\\.es$" . es-mode))
+
+;;; Code:
+
+(defvar es-mode-syntax-table
+  (let ((st (make-syntax-table)))
+    (modify-syntax-entry ?/ ". 124b" st)
+    (modify-syntax-entry ?* ". 23" st)
+    (modify-syntax-entry ?\n "> b" st)
+    st)
+  "Syntax table for `es-mode'.")
+
+(defconst es-font-lock-keywords
+  (let ((module "module[ ]+\\([a-zA-Z_][a-zA-Z_0-9]*\\)")
+	(builtins (regexp-opt '("declare" "forall" "import") t))
+	(constants (regexp-opt '("::=") t))
+	(keywords (regexp-opt '("module" "types") t))
+	(identifier "|[^a-zA-Z_0-9]+\\([a-zA-Z_]+[a-zA-Z_0-9]*\\)"))
+    (list
+     (list module 1 font-lock-function-name-face)
+     (cons "\\<Type\\>" font-lock-type-face)
+     (cons (concat "\\<" builtins "\\>") font-lock-builtin-face)
+     (cons (concat "\\<" constants "\\>") font-lock-constant-face)
+     (cons (concat "\\<" keywords "\\>") font-lock-keyword-face)))
+  "Keyword highlighting specification for `es-mode'.")
+
+;;;###autoload
+(define-derived-mode es-mode fundamental-mode "Extensible Syntax"
+  "Major mode for editing Extensible Syntax files."
+  :syntax-table es-mode-syntax-table
+  (set (make-local-variable 'font-lock-defaults) '(es-font-lock-keywords)))
+
+(provide 'es-mode)
+;;; es-mode.el ends here

esc.rkt

@@ -0,0 +1,10 @@
+#lang racket
+
+(require "src/es.rkt")
+
+(let ([argv (current-command-line-arguments)])
+  (if (= 0 (vector-length argv))
+      (printf "Usage: ~a <source files>~n"
+              (find-system-path 'run-file))
+      (for ([filename argv])
+        (compile-file filename))))

examples/Functions.es

@@ -0,0 +1,21 @@
+module Functions {
+  types {
+    Type ::= T1:Type "->" T2:Type [right] == (T1 -> T2);
+  }
+
+  forall T2.
+    T1 -> T2 ::= "fun" x:Id ":" T1:Type { x:T1; e1:T2 } =>
+      (λ: ([x : T1]) e1);
+
+  forall T1 T2.
+    T2 ::= f:(T1 -> T2) x:T1 [left] => (f x);
+
+  forall T1 T2.
+    T1 -> T2 ::= "fix" f:(T1 -> T2) -> (T1 -> T2) =
+      ((λ: ([x : (Rec A (A -> (T1 -> T2)))])
+         (f (λ (y) ((x x) y))))
+       (λ: ([x : (Rec A (A -> (T1 -> T2)))])
+         (f (λ (y) ((x x) y)))));
+
+  Id ::= #px"^[:alpha:][:word:]*$";
+}

examples/ML.es

@@ -0,0 +1,31 @@
+module ML {
+  types {
+    Type ::= "Int" == Integer;
+    Type ::= "Bool" == Boolean;
+  }
+
+  // functions
+  Int ::= "|" x:Int "|" = (abs x);
+  Int ::= x:Int "+" y:Int [left 1] = (+ x y);
+  Int ::= x:Int "-" y:Int [left 1] = (- x y);
+  Int ::= x:Int "*" y:Int [left 2] = (* x y);
+  Bool ::= x:Int "<" y:Int = (< x y);
+  forall T.
+    Void ::= "print" x:T = (displayln x);
+
+  // macros
+  forall T.
+    T ::= "if" test:Bool "then" e1:T "else" e2:T =>
+      (if test e1 e2);
+  forall T1 T2.
+    T2 ::= "let" x:Id "=" e1:T1 { x:T1; e2:T2 } =>
+      (let: ([x : T1 e1]) e2);
+  forall T1 T2.
+    T2 ::= e1:T1 ";" e2:T2 [left] => (begin e1 e2);
+  forall T. 
+    T ::= "(" x:T ")" => x;
+  
+  // tokens
+  Int ::= #rx"^[0-9]+$";
+  Id ::= #rx"^[a-zA-Z_][a-zA-Z0-9_]*$";
+}

examples/Pairs.es

@@ -0,0 +1,14 @@
+module Pairs {
+  types {
+    Type ::= T1:Type "×" T2:Type == (Pairof T1 T2);
+  }
+
+  forall T1 T2.
+    T1 × T2 ::= "{" fst:T1 "," snd:T2 "}" => (cons fst snd);
+
+  forall T1 T2.
+    T1 ::= p:(T1 × T2) "." "fst" => (car p);
+ 
+  forall T1 T2.
+    T2 ::= p:(T1 × T2) "." "snd" => (cdr p);
+}

examples/Sets.es

@@ -0,0 +1,28 @@
+module Sets {
+  types {
+    Type ::= T:Type "Set" == (Setof T);
+    Type ::= T:Type "Seq" == (Listof T);
+  }
+
+  // macros
+  forall T.
+    T Set ::= "{" x:T "}" => (set x);
+  forall T.
+    T Set ::= "{" x:T xs:(T Seq) "}" => (list->set (cons x xs));
+
+  forall T.
+    T Seq ::= "," x:T => (list x);
+  forall T.
+    T Seq ::= "," x:T xs:(T Seq) => (cons x xs);
+
+  // functions
+  forall T.
+    T Set ::= s1:(T Set) "|" s2:(T Set) [left 1] =
+      (set-union s1 s2);
+  forall T.
+    T Set ::= s1 : (T Set) "&" s2:(T Set) [left 2] =
+      (set-intersect s1 s2);
+  forall T.
+    Integer ::= "|" s:(T Set) "|" =
+      (set-count s);
+}

examples/Vector.es

@@ -0,0 +1,8 @@
+module Vector {
+  types { 
+    Type ::= "Vec" == (Vectorof Integer); 
+  }
+
+  Vec ::= x:Vec "+" y:Vec [left] =
+    (vector-map + x y);
+}

examples/abc.es

@@ -0,0 +1,10 @@
+import ML, Sets;
+
+let A = {1, 2, 3} { 
+  let B = {2, 3, 4} {
+    let C = {3, 4, 5} {
+      print |A & C|;
+      print A | B & C
+    }
+  }
+}

examples/abc.rkt

@@ -0,0 +1,28 @@
+#lang typed/racket/no-check
+(define-syntax ML246 (syntax-rules () ((_ e1 e2 T1 T2) (begin e1 e2))))
+(define-syntax ML245 (syntax-rules () ((_ x e1 e2 T1 T2) (let: ((x : T1 e1)) e2))))
+(: ML241 (Integer Integer -> Integer))
+(define ML241 (λ (x y) (* x y)))
+(: ML240 (Integer Integer -> Integer))
+(define ML240 (λ (x y) (- x y)))
+(: ML239 (Integer Integer -> Integer))
+(define ML239 (λ (x y) (+ x y)))
+(: ML238 (Integer -> Integer))
+(define ML238 (λ (x) (abs x)))
+(: Sets468 (All (T) ((Setof T) -> Integer)))
+(define Sets468 (λ (s) (set-count s)))
+(define-syntax Sets465 (syntax-rules () ((_ x xs T) (cons x xs))))
+(define-syntax Sets464 (syntax-rules () ((_ x T) (list x))))
+(: ML242 (Integer Integer -> Boolean))
+(define ML242 (λ (x y) (< x y)))
+(: ML243 (All (T) (T -> Void)))
+(define ML243 (λ (x) (displayln x)))
+(: Sets467 (All (T) ((Setof T) (Setof T) -> (Setof T))))
+(define Sets467 (λ (s1 s2) (set-intersect s1 s2)))
+(: Sets466 (All (T) ((Setof T) (Setof T) -> (Setof T))))
+(define Sets466 (λ (s1 s2) (set-union s1 s2)))
+(define-syntax Sets463 (syntax-rules () ((_ x xs T) (list->set (cons x xs)))))
+(define-syntax Sets462 (syntax-rules () ((_ x T) (set x))))
+(define-syntax ML247 (syntax-rules () ((_ x T) x)))
+(define-syntax ML244 (syntax-rules () ((_ test e1 e2 T) (if test e1 e2))))
+(begin (ML245 A (Sets463 1 (Sets465 2 (Sets464 3 Integer) Integer) Integer) (ML245 B (Sets463 2 (Sets465 3 (Sets464 4 Integer) Integer) Integer) (ML245 C (Sets463 3 (Sets465 4 (Sets464 5 Integer) Integer) Integer) (ML246 (ML243 (Sets468 (Sets467 A C))) (ML243 (Sets466 A (Sets467 B C))) Void Void) (Setof Integer) Void) (Setof Integer) Void) (Setof Integer) Void))

examples/double.es

@@ -0,0 +1,10 @@
+import ML, Pairs, Functions;
+
+let maybeDouble = 
+  fun p : Bool × Int {
+    if p.fst then p.snd
+    else p.snd * 2
+  }
+{
+  print maybeDouble {1 < 0, 21}
+}

examples/fact.es

@@ -0,0 +1,12 @@
+import ML, Functions;
+
+let fact = 
+  fix fun f : Int -> Int {
+        fun n : Int {
+          if n < 2 then 1
+          else n * f (n - 1)
+        }
+      }
+{
+  print fact 5
+}

examples/let.es

@@ -0,0 +1,6 @@
+import ML;
+
+let n = 7 {
+  if n < 3 then print 6
+  else print 2 + n * 5 + 5
+}

examples/vec.es

@@ -0,0 +1,8 @@
+import Vector;
+
+declare u:Vec, v:Vec, w:Vec {
+  (let ([u #(1 2 3)]
+        [v #(4 5 6)]
+        [w #(7 8 9)])
+    u + v + w)
+}

src/bidi-edge.rkt

@@ -0,0 +1,144 @@
+;;;;;; bidi-edge.rkt - Bidirectional Edge module.    -*- Mode: Racket -*-
+;;;;;; Author: Erik Silkensen <eriksilkensen@gmail.com>
+;;;;;; Version: 3 Sep 2012
+
+#lang typed/racket/no-check
+
+(require
+ "grammar.rkt"
+ "lexer.rkt"
+ "utils.rkt")
+
+(provide (all-defined-out))
+
+(struct edge
+  (start end lhs left found right assoc prec vars code src)
+  #:transparent)
+
+(define (edge-list? x)
+  (and (list? x)
+       (andmap edge? x)))
+
+(define-match-expander edge-complete
+  (syntax-rules ()
+    [(edge-complete lhs found)
+     (edge _ _ lhs '() found '() _ _ _ _ _)]))
+
+(define (edge-complete? E)
+  (and (null? (edge-left E)) (null? (edge-right E))))
+
+(define (edge-incomplete? E)
+  (not (edge-complete? E)))
+
+(define (edge->string E)
+  (match E
+    [(edge start end lhs left found right assoc prec vars code src)
+     (format "[~a,~a, ~a -> ~a . ~a . ~a vars=~a src=~a]"
+             start end lhs (edge->string left) (edge->string found)
+             (edge->string right) vars src)]
+    [(? null? E) ""]
+    [(? list? E) (format "~a" (map edge->string E))]
+    [else (format "~a" E)]))
+
+(: edge->ast
+   (case-> [edge -> (Listof Sexp)]
+           [edge Boolean -> (Listof Sexp)]))
+(define (edge->ast E [terminals? #f])
+  (define (as? obj)
+    (or (edge? obj)
+        (and (pair? obj)
+             (or terminals?
+                 (and (rule-lhs? (car obj))
+                      (not (string? (car obj))))))))
+  (if (edge? E)
+      `(,(car (edge->ast (edge-lhs E) #f))
+        ,@(map (λ (e)
+                 (match e
+                   [(? edge? e) (edge->ast e terminals?)]
+                   [(? sexp? e) (car (edge->ast e terminals?))]
+                   [(cons (? sexp? e1) (? token? e2))
+                    (car (edge->ast (cons e1 (token-value e2)) terminals?))]
+                   [_ (error "edge->ast unexpected:" e)]))
+               (if (list1? (edge-found E))
+                   (edge-found E)
+                   (filter as? (edge-found E)))))
+      (if (and (pair? E)
+               (string? (car E)))
+          (list (car E))
+          (list E))))
+
+(: parse-type (edge -> SExpr))
+(define (parse-type E)
+  (match (edge-found E)
+    [(list (cons '*Name (? token? t)))
+     (string->symbol (token-value t))]
+    [_ (let* ([code (edge-code E)]
+              [proc (cdr code)]
+              [formals (car code)])
+         (let ([ret (proc (map (λ (f)
+                                 (lookup (edge-vars E) f))
+                               formals))])
+           (if (sexpr? ret)
+               ret
+               (error "expected SExpr; got:" ret))))]))
+
+(: lookup
+   (All (T)
+        (case-> [(HashTable LHS Any) LHS -> Any]
+                [(HashTable LHS Any) LHS (-> T) -> Any])))
+(define (lookup vars A [failure-result (λ () #f)])
+  (cond [(symbol? A)
+         (hash-ref vars A (λ ()
+                            (let ([B (symbol->string A)])
+                              (lookup vars B failure-result))))]
+        [(string? A)
+         (match (hash-ref vars A (λ () #f))
+           [(list (cons (? string? s) _))
+            (string->symbol s)]
+           [(list (cons (? edge? e) 'Type))
+            (parse-type e)]
+           [(list (cons (? edge? e) _))
+            (unparse e)]
+           [else (failure-result)])]
+        [(and (rule-lhs? A) (list? A))
+         (map (λ (a)
+                (lookup vars a (λ () a)))
+              A)]
+        [else (failure-result)]))
+
+(: unparse
+   (case-> [(U Edge-Term Term) -> String]
+           [(U Edge-Term Term) String -> String]))
+(define (unparse E [sep ""])
+  (cond [(and (edge? E) edge-complete? E)
+         (string-join (map (λ (F)
+                             (unparse F sep))
+                           (edge-found E)) sep)]
+        [(and (pair? E) (token? (cdr E))) (token-value (cdr E))]
+        [(string? E) E]
+        [(rule-lhs? E) (format "~a" E)]
+        [else (error "unparse unexpected:" E)]))
+
+(: leaf-count (Any -> Natural))
+(define (leaf-count node)
+  (match node
+    ['() 0]
+    [(list (? symbol?) (? string?)) 1]
+    [(? list? node)
+     (foldl + 0 (map leaf-count (cdr node)))]
+    [(? pair?) 1]))
+
+(: edge-leaf-count (Any -> Natural))
+(define (edge-leaf-count E)
+  (if (and (edge? E)
+           (edge-complete? E))
+      (leaf-count (edge->ast E))
+      0))
+
+(: get-last-token (edge -> (Option token)))
+(define (get-last-token e)
+  (and (not (null? (edge-found e)))
+       (match (last (edge-found e))
+         [(cons _ (? token? t)) t]
+         [(? token? t) t]
+         [(? edge? f) (get-last-token f)])))