Created
March 14, 2022 00:20
-
-
Save zehnpaard/289f7b185aafa7185d018cbe2c4a4416 to your computer and use it in GitHub Desktop.
A-Normalization example with multi-arity functions in OCaml, based on https://matt.might.net/articles/a-normalization/ + alpha conversion
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module A = Ast | |
let n = ref (-1) | |
let genid s = incr n; s ^ "." ^ string_of_int !n | |
let find = List.assoc | |
let rec g env e = match e with | |
| A.Int _ -> e | |
| A.Bool _ -> e | |
| A.Add(e1,e2) -> A.Add(g env e1, g env e2) | |
| A.Lt(e1,e2) -> A.Lt(g env e1, g env e2) | |
| A.Var s -> A.Var(find s env) | |
| A.Let(s,e1,e2) -> | |
let s' = genid s in | |
A.Let(s', g env e1, g ((s,s')::env) e2) | |
| A.If(e1,e2,e3) -> A.If(g env e1, g env e2, g env e3) | |
| A.Fn(ss,e) -> | |
let ss' = List.map genid ss in | |
A.Fn(ss', g ((List.combine ss ss') @ env) e) | |
| A.Call(e,es) -> A.Call(g env e, List.map (g env) es) | |
let f = g [] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module A = Ast | |
let n = ref (-1) | |
let gensym () = incr n; "g" ^ string_of_int !n | |
let is_value = function | |
| A.Int _ | A.Bool _ | A.Var _ | A.Fn _ -> true | |
| A.Add _ | A.Lt _ | A.Let _ | A.If _ | A.Call _ -> false | |
let id x = x | |
let rec normalize m k = match m with | |
| A.Let(v,e1,e2) -> | |
normalize e1 (fun x -> | |
A.Let(v,x, normalize e2 k)) | |
| A.If(e1,e2,e3) -> | |
normalize_name e1 (fun x -> | |
k (A.If(x, normalize e2 id, normalize e3 id))) | |
| A.Add(e1,e2) -> | |
normalize_name e1 (fun x -> | |
normalize_name e2 (fun y -> | |
k (A.Add(x,y)))) | |
| A.Lt(e1,e2) -> | |
normalize_name e1 (fun x -> | |
normalize_name e2 (fun y -> | |
k (A.Lt(x,y)))) | |
| A.Fn(vs,e) -> | |
k (A.Fn(vs,normalize e id)) | |
| A.Call(e,es) -> | |
normalize_name e (fun x -> | |
normalize_names es (fun ys -> | |
k (A.Call(x,ys)))) | |
| _ -> k m | |
and normalize_name m k = | |
normalize m (fun n -> | |
if is_value(n) then k n | |
else let g = gensym () in A.Let(g,n,k (A.Var g))) | |
and normalize_names ms k = match ms with | |
| [] -> k [] | |
| m::ms -> | |
normalize_name m (fun n -> | |
normalize_names ms (fun ns -> k (n::ns))) | |
let f m = normalize m id |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
type t = | |
| Int of int | |
| Bool of bool | |
| Add of t * t | |
| Lt of t * t | |
| Var of string | |
| Let of string * t * t | |
| If of t * t * t | |
| Fn of string list * t | |
| Call of t * t list | |
let rec to_string = function | |
| Int n -> string_of_int n | |
| Bool b -> string_of_bool b | |
| Add(n, m) -> "(+ " ^ to_string n ^ " " ^ to_string m ^ ")" | |
| Lt(n, m) -> "(< " ^ to_string n ^ " " ^ to_string m ^ ")" | |
| Var s -> s | |
| Let(v,e1,e2) -> "(let [" ^ v ^ " " ^ to_string e1 ^ "] " ^ to_string e2 ^ ")" | |
| If(e1,e2,e3) -> "(if " ^ to_string e1 ^ " " ^ to_string e2 ^ " " ^ to_string e3 ^ ")" | |
| Fn(vs,e) -> | |
let vs' = String.concat " " vs in | |
"(fn [" ^ vs' ^ "] " ^ to_string e ^ ")" | |
| Call(e,es) -> | |
let es' = String.concat " " @@ List.map to_string es in | |
"(" ^ to_string e ^ " " ^ es' ^ ")" |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{ | |
open Parser | |
} | |
let digit = ['0'-'9'] | |
let number = '-'? digit digit* | |
let whitespace = ['\t' ' ' '\n'] | |
let alpha = ['a'-'z''A'-'Z'] | |
let var = alpha (alpha|digit)* | |
rule f = parse | |
| whitespace+ { f lexbuf } | |
| "(" { LPAREN } | |
| ")" { RPAREN } | |
| "[" { LBRACK } | |
| "]" { RBRACK } | |
| "+" { PLUS } | |
| "<" { LT } | |
| "let" { LET } | |
| "if" { IF } | |
| "fn" { FN } | |
| "true" { TRUE } | |
| "false" { FALSE } | |
| number as n { INT (int_of_string n ) } | |
| var as s { VAR s } | |
| eof { EOF } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
let f s = | |
Lexing.from_string s | |
|> Parser.f Lexer.f | |
|> Alpha.f | |
|> Anormal.f | |
|> Ast.to_string | |
|> print_endline | |
let () = read_line () |> f |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
%{ | |
open Ast | |
%} | |
%token LPAREN | |
%token RPAREN | |
%token LBRACK | |
%token RBRACK | |
%token <string> VAR | |
%token EOF | |
%token <int> INT | |
%token PLUS | |
%token LET | |
%token TRUE | |
%token FALSE | |
%token LT | |
%token IF | |
%token FN | |
%start <Ast.t> f | |
%% | |
f: | |
| expr EOF { $1 } | |
expr: | |
| INT { Int $1 } | |
| TRUE { Bool true } | |
| FALSE { Bool false } | |
| VAR { Var $1 } | |
| LPAREN PLUS expr expr RPAREN { Add ($3, $4) } | |
| LPAREN LT expr expr RPAREN { Lt ($3, $4) } | |
| LPAREN LET LBRACK VAR expr RBRACK expr RPAREN { Let($4, $5, $7)} | |
| LPAREN IF expr expr expr RPAREN { If($3, $4, $5)} | |
| LPAREN FN LBRACK list(VAR) RBRACK expr RPAREN { Fn($4, $6)} | |
| LPAREN expr list(expr) RPAREN { Call($2, $3) } |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment