Skip to content

Commit 7dd5188

Browse files
engborisengboris
committed
Improve code quality
1 parent 2280052 commit 7dd5188

File tree

3 files changed

+193
-53
lines changed

3 files changed

+193
-53
lines changed

‎bin/cosmog.ml‎

Lines changed: 95 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,38 +1,110 @@
1+
(** Cosmographer: Compiler from linear lambda calculus to Stellogen *)
2+
13
open Base
24
open Cmdliner
35
open Stellogen
46

5-
let run input_file =
6-
let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in input_file) in
7-
let start_pos filename =
8-
{ Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 }
7+
(** Create initial lexer position for a file *)
8+
let create_start_pos filename =
9+
{ Lexing.pos_fname = filename
10+
; pos_lnum = 1
11+
; pos_bol = 0
12+
; pos_cnum = 0
13+
}
14+
15+
(** Compile a mini-ML file to Stellogen
16+
17+
@param input_file Path to the input .ml file
18+
@param output_file Path to the output .sg file *)
19+
let compile_file input_file output_file =
20+
(* Open input file with proper resource management *)
21+
let ic =
22+
try Stdlib.open_in input_file
23+
with Sys_error msg ->
24+
failwith (Printf.sprintf "Failed to open input file '%s': %s" input_file msg)
925
in
10-
Sedlexing.set_position lexbuf (start_pos input_file);
11-
let lexer = Sedlexing.with_tokenizer Cosmog_lexer.read lexbuf in
12-
let parser =
13-
MenhirLib.Convert.Simplified.traditional2revised Cosmog_parser.expr_file
26+
27+
(* Parse and compile, ensuring input file is closed *)
28+
let output_code =
29+
Stdlib.Fun.protect
30+
~finally:(fun () -> Stdlib.close_in ic)
31+
(fun () ->
32+
(* Set up lexer *)
33+
let lexbuf = Sedlexing.Utf8.from_channel ic in
34+
Sedlexing.set_position lexbuf (create_start_pos input_file);
35+
let lexer = Sedlexing.with_tokenizer Cosmog_lexer.read lexbuf in
36+
37+
(* Parse the input *)
38+
let parser =
39+
MenhirLib.Convert.Simplified.traditional2revised Cosmog_parser.expr_file
40+
in
41+
let ast = parser lexer in
42+
43+
(* Compile to Stellogen *)
44+
let compiled = Cosmog_compile.compile ast in
45+
List.map ~f:Expr.Raw.to_string compiled
46+
|> String.concat ~sep:"\n"
47+
)
1448
in
15-
parser lexer |> Cosmog_compile.compile
16-
|> List.map ~f:Expr.Raw.to_string
17-
|> String.concat ~sep:"\n"
18-
|> fun s ->
19-
let oc = Stdlib.open_out "out.sg" in
20-
Stdlib.output_string oc s;
21-
Stdlib.close_out oc
49+
50+
(* Write output file with proper resource management *)
51+
let oc =
52+
try Stdlib.open_out output_file
53+
with Sys_error msg ->
54+
failwith (Printf.sprintf "Failed to open output file '%s': %s" output_file msg)
55+
in
56+
57+
Stdlib.Fun.protect
58+
~finally:(fun () -> Stdlib.close_out oc)
59+
(fun () ->
60+
Stdlib.output_string oc output_code;
61+
Stdlib.output_char oc '\n'
62+
)
63+
64+
(** {1 Command-line interface} *)
2265

2366
let input_file_arg =
24-
let doc = "Input file to process." in
25-
Arg.(required & pos 0 (some string) None & info [] ~docv:"FILENAME" ~doc)
67+
let doc = "Input mini-ML file to compile." in
68+
Arg.(required & pos 0 (some file) None & info [] ~docv:"INPUT" ~doc)
69+
70+
let output_file_arg =
71+
let doc = "Output Stellogen file (default: out.sg)." in
72+
Arg.(value & opt string "out.sg" & info [ "o"; "output" ] ~docv:"OUTPUT" ~doc)
2673

27-
let wrap f input_file =
28-
try Ok (f input_file) with e -> Error (`Msg (Stdlib.Printexc.to_string e))
74+
(** Wrap compilation with error handling *)
75+
let wrap_compile input_file output_file =
76+
try
77+
compile_file input_file output_file;
78+
Ok ()
79+
with
80+
| Failure msg -> Error (`Msg msg)
81+
| e -> Error (`Msg (Printf.sprintf "Unexpected error: %s" (Stdlib.Printexc.to_string e)))
2982

3083
let compile_cmd =
31-
let term = Term.(const (wrap run) $ input_file_arg |> term_result) in
32-
Cmd.v (Cmd.info "compile" ~doc:"Compile a mini ML program") term
84+
let doc = "Compile a linear mini-ML program to Stellogen interaction nets." in
85+
let man = [
86+
`S Manpage.s_description;
87+
`P "Cosmographer compiles linear lambda calculus programs written in a \
88+
mini-ML syntax to Stellogen's interaction net representation.";
89+
`P "The input program must satisfy the linearity constraint: each \
90+
variable must be used exactly once.";
91+
`S Manpage.s_examples;
92+
`P "Compile input.ml to out.sg:";
93+
`Pre " cosmog compile input.ml";
94+
`P "Compile input.ml to custom output:";
95+
`Pre " cosmog compile input.ml -o output.sg";
96+
] in
97+
let term = Term.(const wrap_compile $ input_file_arg $ output_file_arg |> term_result) in
98+
Cmd.v (Cmd.info "compile" ~doc ~man) term
3399

34100
let default_cmd =
35-
let doc = "Cosmographer: compile mini-ML to Stellogen" in
36-
Cmd.group (Cmd.info "cosmog" ~doc) [ compile_cmd ]
101+
let doc = "Cosmographer: compile linear mini-ML to Stellogen" in
102+
let man = [
103+
`S Manpage.s_description;
104+
`P "Cosmographer is a compiler from linear lambda calculus to Stellogen.";
105+
`S Manpage.s_bugs;
106+
`P "Report bugs at https://github.com/engboris/stellogen/issues";
107+
] in
108+
Cmd.group (Cmd.info "cosmog" ~version:"1.0" ~doc ~man) [ compile_cmd ]
37109

38110
let () = Stdlib.exit (Cmd.eval default_cmd)

‎src/cosmog_compile.ml‎

Lines changed: 59 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,63 +1,109 @@
1+
(** Compiler from linear lambda calculus to Stellogen
2+
3+
This module compiles a mini-ML language with linear lambda calculus
4+
to Stellogen's interaction net representation. *)
5+
16
open Base
27

8+
(** {1 Helper functions for building Stellogen expressions} *)
9+
10+
(** Create a positive polarity symbol *)
311
let pos x = Expr.Raw.Symbol ("+" ^ x)
412

13+
(** Create a negative polarity symbol *)
514
let neg x = Expr.Raw.Symbol ("-" ^ x)
615

16+
(** Add "_out" suffix to a location identifier *)
717
let out x = x ^ "_out"
818

19+
(** Create a function application node *)
920
let func es = Expr.Raw.List es
1021

22+
(** Create a variable *)
1123
let var x = Expr.Raw.Var x
1224

25+
(** Create a star (constellation) *)
1326
let star es = Expr.Raw.Cons es
1427

28+
(** Create an interact expression *)
1529
let interact e = Expr.Raw.List [ Expr.Raw.Symbol "interact"; e ]
1630

31+
(** Create a group expression *)
1732
let group es = Expr.Raw.Group es
1833

34+
(** Create a definition *)
1935
let def x t = Expr.Raw.List [ Expr.Raw.Symbol ":="; Expr.Raw.Symbol x; t ]
2036

37+
(** Create a show expression *)
2138
let show x = Expr.Raw.List [ Expr.Raw.Symbol "show"; x ]
2239

40+
(** Create an identifier call *)
2341
let id x = Expr.Raw.Call (Expr.Raw.Symbol x)
2442

25-
let add s = function
43+
(** Add a symbol to the front of a constellation *)
44+
let add_to_star s = function
2645
| Expr.Raw.Cons es -> Expr.Raw.Cons (Expr.Raw.Symbol s :: es)
2746
| e -> Expr.Raw.Cons [ Expr.Raw.Symbol s; e ]
2847

29-
let inject_lr = function
48+
(** Inject left/right labels into a binary constellation for lambda abstraction *)
49+
let inject_lr expr =
50+
match expr with
3051
| Expr.Raw.Cons [ Expr.Raw.List [ h1; a1 ]; Expr.Raw.List [ h2; a2 ] ] ->
3152
Expr.Raw.Cons
32-
[ Expr.Raw.List [ h1; add "l" a1 ]; Expr.Raw.List [ h2; add "r" a2 ] ]
33-
| _ -> failwith "Compiler error: could not apply inject_lr"
53+
[ Expr.Raw.List [ h1; add_to_star "l" a1 ]
54+
; Expr.Raw.List [ h2; add_to_star "r" a2 ]
55+
]
56+
| _ ->
57+
failwith
58+
(Printf.sprintf
59+
"Internal compiler error: inject_lr expects a binary constellation, got: %s"
60+
(Expr.Raw.to_string expr))
61+
62+
(** {1 Compilation functions} *)
3463

35-
(* FIXME *)
64+
(** Compile a linear lambda expression to Stellogen interaction nets
65+
66+
@param e The lambda expression to compile (must be linear)
67+
@raise Failure if the expression is not linear *)
3668
let rec compile_expr e =
37-
if not @@ Lambda.is_linear e then
69+
(* Verify linearity constraint *)
70+
if not (Lambda.is_linear e) then
3871
failwith
39-
(Printf.sprintf "Compiler error: term '%s' is not linear."
40-
(Lambda.to_string e) );
72+
(Printf.sprintf
73+
"Compilation error: term '%s' is not linear.\n\
74+
Linear lambda calculus requires each variable to be used exactly once."
75+
(Lambda.to_string e));
76+
4177
match e.content with
4278
| Lambda.Var _ ->
79+
(* Variable: wire connecting input to output *)
4380
[ star [ func [ pos e.loc; var "X" ]; func [ pos (out e.loc); var "X" ] ] ]
81+
4482
| Lambda.Fun (_x, _t) ->
83+
(* Lambda abstraction: labeled wire for left/right distinction *)
4584
[ star [ func [ pos e.loc; var "X" ]; func [ pos (out e.loc); var "X" ] ]
4685
|> inject_lr
4786
]
87+
4888
| Lambda.App (t1, t2) ->
89+
(* Application: connect outputs of subterms and create final output *)
4990
let cuts =
5091
star
51-
[ func [ neg (t1.loc ^ "_out"); var "X" ]
52-
; func [ neg (t2.loc ^ "_out"); var "X" ]
92+
[ func [ neg (out t1.loc); var "X" ]
93+
; func [ neg (out t2.loc); var "X" ]
5394
]
5495
in
55-
let out = star [ func [ pos (e.loc ^ "_out"); var "X" ] ] in
56-
[ cuts; out ] @ compile_expr t1 @ compile_expr t2
96+
let output = star [ func [ pos (out e.loc); var "X" ] ] in
97+
[ cuts; output ] @ compile_expr t1 @ compile_expr t2
5798

99+
(** Compile a declaration (let binding or print statement) *)
58100
let compile_decl = function
59101
| Lambda.Let (x, t) -> [ def x (group (compile_expr t)) ]
60102
| Lambda.Print x -> [ show (interact (id x)) ]
61103

104+
(** Compile a complete program
105+
106+
@param program The lambda calculus program to compile
107+
@return A list of Stellogen expressions *)
62108
let compile : Lambda.program -> Expr.Raw.t list =
63-
fun e -> List.map ~f:compile_decl e |> List.concat
109+
fun program -> List.concat_map ~f:compile_decl program

‎src/cosmog_lexer.ml‎

Lines changed: 39 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -1,27 +1,37 @@
1+
(** Lexer for the Cosmographer mini-ML language *)
2+
13
open Cosmog_parser
24

5+
(** Regular expressions for whitespace *)
36
let space = [%sedlex.regexp? Plus (' ' | '\t')]
4-
57
let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"]
68

9+
(** Regular expression for identifiers *)
10+
let identifier = [%sedlex.regexp? 'a' .. 'z', Star ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'')]
11+
12+
(** Get current position for error reporting *)
13+
let get_position lexbuf =
14+
let start_pos, _ = Sedlexing.lexing_positions lexbuf in
15+
Printf.sprintf "line %d, column %d"
16+
start_pos.Lexing.pos_lnum
17+
(start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol + 1)
18+
19+
(** Lex multi-line comments *)
720
let rec comments lexbuf =
8-
let tok =
9-
match%sedlex lexbuf with
10-
| "*)" | eof -> read lexbuf
11-
| _ ->
12-
ignore (Sedlexing.next lexbuf);
13-
comments lexbuf
14-
in
15-
tok
21+
match%sedlex lexbuf with
22+
| "*)" | eof -> read lexbuf
23+
| _ ->
24+
ignore (Sedlexing.next lexbuf);
25+
comments lexbuf
1626

27+
(** Main lexer function *)
1728
and read lexbuf =
1829
match%sedlex lexbuf with
1930
| "fun" -> FUN
2031
| "let" -> LET
2132
| "print" -> PRINT
22-
| 'a' .. 'z', Star ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'') ->
23-
let id = Sedlexing.Utf8.lexeme lexbuf in
24-
IDENT id
33+
| identifier ->
34+
IDENT (Sedlexing.Utf8.lexeme lexbuf)
2535
| '(' -> LPAR
2636
| ')' -> RPAR
2737
| "->" -> RARROW
@@ -31,28 +41,40 @@ and read lexbuf =
3141
| space -> read lexbuf
3242
| newline -> read lexbuf
3343
| eof -> EOF
34-
| _ -> failwith "Unexpected symbol in lexing."
44+
| _ ->
45+
let pos = get_position lexbuf in
46+
let lexeme = Sedlexing.Utf8.lexeme lexbuf in
47+
failwith (Printf.sprintf "Unexpected symbol '%s' at %s" lexeme pos)
3548

49+
(** Lex string literals with escape sequences *)
3650
and string_literal lexbuf =
3751
let buffer = Buffer.create 32 in
3852
let rec loop () =
3953
match%sedlex lexbuf with
4054
| '"' -> STRING (Buffer.contents buffer)
41-
| '\\', any ->
55+
| '\\' ->
4256
let escaped =
4357
match%sedlex lexbuf with
4458
| 'n' -> '\n'
4559
| 't' -> '\t'
60+
| 'r' -> '\r'
4661
| '\\' -> '\\'
4762
| '"' -> '"'
48-
| _ -> failwith "Unknown escape sequence"
63+
| _ ->
64+
let pos = get_position lexbuf in
65+
let lexeme = Sedlexing.Utf8.lexeme lexbuf in
66+
failwith (Printf.sprintf "Unknown escape sequence '\\%s' at %s" lexeme pos)
4967
in
5068
Buffer.add_char buffer escaped;
5169
loop ()
52-
| eof -> failwith "Unterminated string literal"
70+
| eof ->
71+
let pos = get_position lexbuf in
72+
failwith (Printf.sprintf "Unterminated string literal at %s" pos)
5373
| any ->
5474
Buffer.add_string buffer (Sedlexing.Utf8.lexeme lexbuf);
5575
loop ()
56-
| _ -> failwith "Invalid character in string literal"
76+
| _ ->
77+
let pos = get_position lexbuf in
78+
failwith (Printf.sprintf "Invalid character in string literal at %s" pos)
5779
in
5880
loop ()

0 commit comments

Comments
 (0)