Add compiler from linear lambda-calculus to stellogen

bin/cosmog.ml

@@ -0,0 +1,110 @@
+(** Cosmographer: Compiler from linear lambda calculus to Stellogen *)
+
+open Base
+open Cmdliner
+open Stellogen
+
+(** Create initial lexer position for a file *)
+let create_start_pos filename =
+  { Lexing.pos_fname = filename
+  ; pos_lnum = 1
+  ; pos_bol = 0
+  ; pos_cnum = 0
+  }
+
+(** Compile a mini-ML file to Stellogen
+
+    @param input_file Path to the input .ml file
+    @param output_file Path to the output .sg file *)
+let compile_file input_file output_file =
+  (* Open input file with proper resource management *)
+  let ic =
+    try Stdlib.open_in input_file
+    with Sys_error msg ->
+      failwith (Printf.sprintf "Failed to open input file '%s': %s" input_file msg)
+  in
+
+  (* Parse and compile, ensuring input file is closed *)
+  let output_code =
+    Stdlib.Fun.protect
+      ~finally:(fun () -> Stdlib.close_in ic)
+      (fun () ->
+        (* Set up lexer *)
+        let lexbuf = Sedlexing.Utf8.from_channel ic in
+        Sedlexing.set_position lexbuf (create_start_pos input_file);
+        let lexer = Sedlexing.with_tokenizer Cosmog_lexer.read lexbuf in
+
+        (* Parse the input *)
+        let parser =
+          MenhirLib.Convert.Simplified.traditional2revised Cosmog_parser.expr_file
+        in
+        let ast = parser lexer in
+
+        (* Compile to Stellogen *)
+        let compiled = Cosmog_compile.compile ast in
+        List.map ~f:Expr.Raw.to_string compiled
+        |> String.concat ~sep:"\n"
+      )
+  in
+
+  (* Write output file with proper resource management *)
+  let oc =
+    try Stdlib.open_out output_file
+    with Sys_error msg ->
+      failwith (Printf.sprintf "Failed to open output file '%s': %s" output_file msg)
+  in
+
+  Stdlib.Fun.protect
+    ~finally:(fun () -> Stdlib.close_out oc)
+    (fun () ->
+      Stdlib.output_string oc output_code;
+      Stdlib.output_char oc '\n'
+    )
+
+(** {1 Command-line interface} *)
+
+let input_file_arg =
+  let doc = "Input mini-ML file to compile." in
+  Arg.(required & pos 0 (some file) None & info [] ~docv:"INPUT" ~doc)
+
+let output_file_arg =
+  let doc = "Output Stellogen file (default: out.sg)." in
+  Arg.(value & opt string "out.sg" & info [ "o"; "output" ] ~docv:"OUTPUT" ~doc)
+
+(** Wrap compilation with error handling *)
+let wrap_compile input_file output_file =
+  try
+    compile_file input_file output_file;
+    Ok ()
+  with
+  | Failure msg -> Error (`Msg msg)
+  | e -> Error (`Msg (Printf.sprintf "Unexpected error: %s" (Stdlib.Printexc.to_string e)))
+
+let compile_cmd =
+  let doc = "Compile a linear mini-ML program to Stellogen interaction nets." in
+  let man = [
+    `S Manpage.s_description;
+    `P "Cosmographer compiles linear lambda calculus programs written in a \
+        mini-ML syntax to Stellogen's interaction net representation.";
+    `P "The input program must satisfy the linearity constraint: each \
+        variable must be used exactly once.";
+    `S Manpage.s_examples;
+    `P "Compile input.ml to out.sg:";
+    `Pre "  cosmog compile input.ml";
+    `P "Compile input.ml to custom output:";
+    `Pre "  cosmog compile input.ml -o output.sg";
+  ] in
+  let term = Term.(const wrap_compile $ input_file_arg $ output_file_arg |> term_result) in
+  Cmd.v (Cmd.info "compile" ~doc ~man) term
+
+let default_cmd =
+  let doc = "Cosmographer: compile linear mini-ML to Stellogen" in
+  let man = [
+    `S Manpage.s_description;
+    `P "Cosmographer is a compiler from linear lambda calculus to Stellogen.";
+    `S Manpage.s_bugs;
+    `P "Report bugs at https://github.com/engboris/stellogen/issues";
+  ] in
+  Cmd.group (Cmd.info "cosmog" ~version:"1.0" ~doc ~man) [ compile_cmd ]
+
+let () = Stdlib.exit (Cmd.eval default_cmd)

bin/dune

@@ -1,6 +1,6 @@
 (executables
- (public_names sgen)
- (names sgen)
+ (public_names sgen cosmog)
+ (names sgen cosmog)
  (libraries stellogen base cmdliner))
 
 (env

src/cosmog_compile.ml

@@ -0,0 +1,109 @@
+(** Compiler from linear lambda calculus to Stellogen
+
+    This module compiles a mini-ML language with linear lambda calculus
+    to Stellogen's interaction net representation. *)
+
+open Base
+
+(** {1 Helper functions for building Stellogen expressions} *)
+
+(** Create a positive polarity symbol *)
+let pos x = Expr.Raw.Symbol ("+" ^ x)
+
+(** Create a negative polarity symbol *)
+let neg x = Expr.Raw.Symbol ("-" ^ x)
+
+(** Add "_out" suffix to a location identifier *)
+let out x = x ^ "_out"
+
+(** Create a function application node *)
+let func es = Expr.Raw.List es
+
+(** Create a variable *)
+let var x = Expr.Raw.Var x
+
+(** Create a star (constellation) *)
+let star es = Expr.Raw.Cons es
+
+(** Create an interact expression *)
+let interact e = Expr.Raw.List [ Expr.Raw.Symbol "interact"; e ]
+
+(** Create a group expression *)
+let group es = Expr.Raw.Group es
+
+(** Create a definition *)
+let def x t = Expr.Raw.List [ Expr.Raw.Symbol ":="; Expr.Raw.Symbol x; t ]
+
+(** Create a show expression *)
+let show x = Expr.Raw.List [ Expr.Raw.Symbol "show"; x ]
+
+(** Create an identifier call *)
+let id x = Expr.Raw.Call (Expr.Raw.Symbol x)
+
+(** Add a symbol to the front of a constellation *)
+let add_to_star s = function
+  | Expr.Raw.Cons es -> Expr.Raw.Cons (Expr.Raw.Symbol s :: es)
+  | e -> Expr.Raw.Cons [ Expr.Raw.Symbol s; e ]
+
+(** Inject left/right labels into a binary constellation for lambda abstraction *)
+let inject_lr expr =
+  match expr with
+  | Expr.Raw.Cons [ Expr.Raw.List [ h1; a1 ]; Expr.Raw.List [ h2; a2 ] ] ->
+    Expr.Raw.Cons
+      [ Expr.Raw.List [ h1; add_to_star "l" a1 ]
+      ; Expr.Raw.List [ h2; add_to_star "r" a2 ]
+      ]
+  | _ ->
+    failwith
+      (Printf.sprintf
+         "Internal compiler error: inject_lr expects a binary constellation, got: %s"
+         (Expr.Raw.to_string expr))
+
+(** {1 Compilation functions} *)
+
+(** Compile a linear lambda expression to Stellogen interaction nets
+
+    @param e The lambda expression to compile (must be linear)
+    @raise Failure if the expression is not linear *)
+let rec compile_expr e =
+  (* Verify linearity constraint *)
+  if not (Lambda.is_linear e) then
+    failwith
+      (Printf.sprintf
+         "Compilation error: term '%s' is not linear.\n\
+          Linear lambda calculus requires each variable to be used exactly once."
+         (Lambda.to_string e));
+
+  match e.content with
+  | Lambda.Var _ ->
+    (* Variable: wire connecting input to output *)
+    [ star [ func [ pos e.loc; var "X" ]; func [ pos (out e.loc); var "X" ] ] ]
+
+  | Lambda.Fun (_x, _t) ->
+    (* Lambda abstraction: labeled wire for left/right distinction *)
+    [ star [ func [ pos e.loc; var "X" ]; func [ pos (out e.loc); var "X" ] ]
+      |> inject_lr
+    ]
+
+  | Lambda.App (t1, t2) ->
+    (* Application: connect outputs of subterms and create final output *)
+    let cuts =
+      star
+        [ func [ neg (out t1.loc); var "X" ]
+        ; func [ neg (out t2.loc); var "X" ]
+        ]
+    in
+    let output = star [ func [ pos (out e.loc); var "X" ] ] in
+    [ cuts; output ] @ compile_expr t1 @ compile_expr t2
+
+(** Compile a declaration (let binding or print statement) *)
+let compile_decl = function
+  | Lambda.Let (x, t) -> [ def x (group (compile_expr t)) ]
+  | Lambda.Print x -> [ show (interact (id x)) ]
+
+(** Compile a complete program
+
+    @param program The lambda calculus program to compile
+    @return A list of Stellogen expressions *)
+let compile : Lambda.program -> Expr.Raw.t list =
+  fun program -> List.concat_map ~f:compile_decl program

src/cosmog_lexer.ml

@@ -0,0 +1,80 @@
+(** Lexer for the Cosmographer mini-ML language *)
+
+open Cosmog_parser
+
+(** Regular expressions for whitespace *)
+let space = [%sedlex.regexp? Plus (' ' | '\t')]
+let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"]
+
+(** Regular expression for identifiers *)
+let identifier = [%sedlex.regexp? 'a' .. 'z', Star ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'')]
+
+(** Get current position for error reporting *)
+let get_position lexbuf =
+  let start_pos, _ = Sedlexing.lexing_positions lexbuf in
+  Printf.sprintf "line %d, column %d"
+    start_pos.Lexing.pos_lnum
+    (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol + 1)
+
+(** Lex multi-line comments *)
+let rec comments lexbuf =
+  match%sedlex lexbuf with
+  | "*)" | eof -> read lexbuf
+  | _ ->
+    ignore (Sedlexing.next lexbuf);
+    comments lexbuf
+
+(** Main lexer function *)
+and read lexbuf =
+  match%sedlex lexbuf with
+  | "fun" -> FUN
+  | "let" -> LET
+  | "print" -> PRINT
+  | identifier ->
+    IDENT (Sedlexing.Utf8.lexeme lexbuf)
+  | '(' -> LPAR
+  | ')' -> RPAR
+  | "->" -> RARROW
+  | "=" -> EQ
+  | "(*" -> comments lexbuf
+  | '"' -> string_literal lexbuf
+  | space -> read lexbuf
+  | newline -> read lexbuf
+  | eof -> EOF
+  | _ ->
+    let pos = get_position lexbuf in
+    let lexeme = Sedlexing.Utf8.lexeme lexbuf in
+    failwith (Printf.sprintf "Unexpected symbol '%s' at %s" lexeme pos)
+
+(** Lex string literals with escape sequences *)
+and string_literal lexbuf =
+  let buffer = Buffer.create 32 in
+  let rec loop () =
+    match%sedlex lexbuf with
+    | '"' -> STRING (Buffer.contents buffer)
+    | '\\' ->
+      let escaped =
+        match%sedlex lexbuf with
+        | 'n' -> '\n'
+        | 't' -> '\t'
+        | 'r' -> '\r'
+        | '\\' -> '\\'
+        | '"' -> '"'
+        | _ ->
+          let pos = get_position lexbuf in
+          let lexeme = Sedlexing.Utf8.lexeme lexbuf in
+          failwith (Printf.sprintf "Unknown escape sequence '\\%s' at %s" lexeme pos)
+      in
+      Buffer.add_char buffer escaped;
+      loop ()
+    | eof ->
+      let pos = get_position lexbuf in
+      failwith (Printf.sprintf "Unterminated string literal at %s" pos)
+    | any ->
+      Buffer.add_string buffer (Sedlexing.Utf8.lexeme lexbuf);
+      loop ()
+    | _ ->
+      let pos = get_position lexbuf in
+      failwith (Printf.sprintf "Invalid character in string literal at %s" pos)
+  in
+  loop ()

src/cosmog_parser.mly

@@ -0,0 +1,47 @@
+%{
+open Lambda
+
+let counter = ref 0
+
+let fresh_loc content =
+  let n = !counter in
+  counter := n + 1;
+  { content; loc = string_of_int n }
+%}
+
+%token <string> IDENT
+%token <string> STRING
+%token FUN
+%token RARROW
+%token EQ
+%token LET
+%token PRINT
+%token LPAR RPAR
+%token EOF
+
+%start <Lambda.program> expr_file
+
+%%
+
+let delimited_opt(l, x, r) :=
+  | ~=x; <>
+  | ~=delimited(l, x, r); <>
+
+let pars(x) == ~=delimited(LPAR, x, RPAR); <>
+
+let expr_file :=
+  | EOF; { [] }
+  | es=decl+; EOF; { es }
+
+let decl :=
+  | LET; x=IDENT; EQ; e=expr; { Let (x, fresh_loc e) }
+  | PRINT; ~=IDENT; <Print>
+
+let expr :=
+  | ~=pars(expr); <>
+  | x=IDENT;
+    { Var x }
+  | FUN; x=IDENT; RARROW; e=expr;
+    { Fun (fresh_loc x, fresh_loc e) }
+  | LPAR; e1=expr; e2=expr; RPAR;
+    { App (fresh_loc e1, fresh_loc e2) }

src/dune

@@ -12,3 +12,7 @@
 (menhir
  (modules parser)
  (flags --table --dump --explain))
+
+(menhir
+ (modules cosmog_parser)
+ (flags --table --dump --explain))