From d2d743e1c255bfa2faeb181bbce4a9585df66ee5 Mon Sep 17 00:00:00 2001 From: Andrei Date: Mon, 11 Nov 2024 02:20:46 +0300 Subject: [PATCH] feat: pretty printer for AST --- NeML.opam | 1 + dune-project | 2 +- lib/ast/LAst.ml | 14 +- lib/ast/dune | 2 - lib/misc/LMisc.ml | 10 +- lib/misc/dune | 2 - lib/parse/test/ParseTest.ml | 267 +++++++ lib/parse/test/{test.mli => ParseTest.mli} | 0 lib/parse/test/dune | 2 +- lib/parse/test/test.ml | 867 --------------------- lib/print/LPrint.ml | 17 + lib/print/PpExpr.ml | 136 ++++ lib/print/PpExpr.mli | 11 + lib/print/PpPat.ml | 50 ++ lib/print/PpPat.mli | 11 + lib/print/PpStr.ml | 67 ++ lib/print/PpStr.mli | 12 + lib/print/PpTy.ml | 43 + lib/print/PpTy.mli | 11 + lib/print/common.ml | 80 ++ lib/print/common.mli | 55 ++ lib/print/dune | 8 + lib/print/test/PrintTest.ml | 383 +++++++++ lib/print/test/PrintTest.mli | 7 + lib/print/test/dune | 6 + 25 files changed, 1177 insertions(+), 887 deletions(-) create mode 100644 lib/parse/test/ParseTest.ml rename lib/parse/test/{test.mli => ParseTest.mli} (100%) delete mode 100644 lib/parse/test/test.ml create mode 100644 lib/print/LPrint.ml create mode 100644 lib/print/PpExpr.ml create mode 100644 lib/print/PpExpr.mli create mode 100644 lib/print/PpPat.ml create mode 100644 lib/print/PpPat.mli create mode 100644 lib/print/PpStr.ml create mode 100644 lib/print/PpStr.mli create mode 100644 lib/print/PpTy.ml create mode 100644 lib/print/PpTy.mli create mode 100644 lib/print/common.ml create mode 100644 lib/print/common.mli create mode 100644 lib/print/dune create mode 100644 lib/print/test/PrintTest.ml create mode 100644 lib/print/test/PrintTest.mli create mode 100644 lib/print/test/dune diff --git a/NeML.opam b/NeML.opam index 32e3fa6..2e60d3d 100644 --- a/NeML.opam +++ b/NeML.opam @@ -17,6 +17,7 @@ depends: [ "ocaml" "dune" {>= "3.15"} "base" + "pprint" "stdio" "angstrom" "ppx_deriving" diff --git a/dune-project b/dune-project index a7e9ed5..8c6fb16 100644 --- a/dune-project +++ b/dune-project @@ -21,4 +21,4 @@ (name NeML) (synopsis "NeML compiler") (description "A compiler for some non-existent programming language") - (depends ocaml dune base stdio angstrom ppx_deriving ppx_expect)) + (depends ocaml dune base pprint stdio angstrom ppx_deriving ppx_expect)) diff --git a/lib/ast/LAst.ml b/lib/ast/LAst.ml index ca6cce1..38ca6c9 100644 --- a/lib/ast/LAst.ml +++ b/lib/ast/LAst.ml @@ -15,7 +15,6 @@ module Const = struct | Char of char (** Character such as ['c'] *) | String of string (** Constant string such as ["constant"] or [{|other constant|}] *) - [@@deriving show {with_path= false}] end module Ty = struct @@ -29,7 +28,6 @@ module Ty = struct - [T tconstr] when [l=[T]] - [(T1, ..., Tn) tconstr] when [l=[T1, ..., Tn]] *) - [@@deriving show {with_path= false}] end module Pat = struct @@ -45,17 +43,15 @@ module Pat = struct - [C P] when [arg] is [Some P] *) | Constraint of t * Ty.t (** [(P : T)] *) - [@@deriving show {with_path= false}] end module Expr = struct - type rec_flag = Rec | Nonrec [@@deriving show {with_path= false}] + type rec_flag = Rec | Nonrec type value_binding = {pat: Pat.t; expr: t} - [@@deriving show {with_path= false}] (** Pattern matching case *) - and case = {left: Pat.t; right: t} [@@deriving show {with_path= false}] + and case = {left: Pat.t; right: t} and t = | Id of Id.t (** Identifiers such as [x], [fact] *) @@ -80,17 +76,14 @@ module Expr = struct | If of t * t * t option (** [if E1 then E2 else E3] *) | Seq of t List2.t (** [E1; E2] *) | Constraint of t * Ty.t (** [(E : T)] *) - [@@deriving show {with_path= false}] end module StrItem = struct (** Constructor declaration. E.g. [A of string] *) type construct_decl = {id: Id.t; arg: Ty.t option} - [@@deriving show {with_path= false}] (** Variant type declaration *) type type_decl = {id: Id.t; params: Id.t list; variants: construct_decl list} - [@@deriving show {with_path= false}] type t = | Eval of Expr.t (** [E] *) @@ -100,7 +93,6 @@ module StrItem = struct - [let P1 = E1 and ... and Pn = EN] when [flag] is [Nonrec] - [let rec P1 = E1 and ... and Pn = EN ] when [flag] is [Rec] *) - [@@deriving show {with_path= false}] end -type structure = StrItem.t list [@@deriving show {with_path= false}] +type structure = StrItem.t list diff --git a/lib/ast/dune b/lib/ast/dune index 1292c50..208c1c1 100644 --- a/lib/ast/dune +++ b/lib/ast/dune @@ -2,7 +2,5 @@ (name LAst) (public_name NeML.Ast) (libraries base LMisc) - (preprocess - (pps ppx_deriving.show)) (instrumentation (backend bisect_ppx))) diff --git a/lib/misc/LMisc.ml b/lib/misc/LMisc.ml index 8579c9c..cfc1779 100644 --- a/lib/misc/LMisc.ml +++ b/lib/misc/LMisc.ml @@ -10,27 +10,31 @@ open! Base (** Identifiers *) module Id = struct - type t = I of string [@@deriving show {with_path= false}] + type t = I of string end (** List containing at least 1 element *) module List1 = struct - type 'a t = 'a * 'a list [@@deriving show {with_path= false}] + type 'a t = 'a * 'a list let of_list_exn : 'a list -> 'a t = function | hd :: tl -> (hd, tl) | [] -> raise (Invalid_argument "empty list") + + let to_list : 'a t -> 'a list = fun (hd, tl) -> hd :: tl end (** List containing at least 2 elements *) module List2 = struct - type 'a t = 'a * 'a * 'a list [@@deriving show {with_path= false}] + type 'a t = 'a * 'a * 'a list let of_list_exn : 'a list -> 'a t = function | fst :: snd :: tl -> (fst, snd, tl) | _ :: [] | [] -> raise (Invalid_argument "not enough elements") + + let to_list : 'a t -> 'a list = fun (fst, snd, tl) -> fst :: snd :: tl end diff --git a/lib/misc/dune b/lib/misc/dune index d3da2da..c539ad5 100644 --- a/lib/misc/dune +++ b/lib/misc/dune @@ -2,7 +2,5 @@ (name LMisc) (public_name NeML.Misc) (libraries base) - (preprocess - (pps ppx_deriving.show)) (instrumentation (backend bisect_ppx))) diff --git a/lib/parse/test/ParseTest.ml b/lib/parse/test/ParseTest.ml new file mode 100644 index 0000000..1612915 --- /dev/null +++ b/lib/parse/test/ParseTest.ml @@ -0,0 +1,267 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open Stdio + +let run s = + match LParse.parse s with + | None -> + print_endline "syntax error" + | Some str -> + PPrint.ToChannel.pretty 1. 40 stdout (LPrint.pp_structure str) + +let%expect_test _ = + run {| let rec fact n = if n <= 1 then 1 else n * fact (n - 1) |} ; + [%expect + {| + let rec fact = + fun n -> + if <= n 1 + then 1 else * n (fact (- n 1)) + |}] + +(* ======= Patterns ======= *) + +let%expect_test _ = + run {| let Cons (hd, tl) = () |} ; + [%expect {| let Cons (hd, tl) = () |}] + +let%expect_test _ = + run {| let C _ | a, b = () |} ; + [%expect {| let C _ | a, b = () |}] + +let%expect_test _ = + run {| let a | (b | c) | d = () |} ; + [%expect {| let a | (b | c) | d = () |}] + +let%expect_test _ = + run {| let a, (b, c), d = () |} ; + [%expect {| let a, (b, c), d = () |}] + +let%expect_test _ = + run {| let a, b | c, d = () |} ; + [%expect {| let a, b | c, d = () |}] + +let%expect_test _ = + run {| let a::(b::c)::d = () |} ; + [%expect {| let a :: (b :: c) :: d = () |}] + +let%expect_test _ = + run {| let a::b::c,d|e = () |} ; + [%expect {| let a :: b :: c, d | e = () |}] + +let%expect_test _ = + run {| let [a;b;c] = () |} ; [%expect {| let a :: b :: c :: [] = () |}] + +let%expect_test _ = run {| let [a] = () |} ; [%expect {| let a :: [] = () |}] + +let%expect_test _ = run {| let [] = () |} ; [%expect {| let [] = () |}] + +let%expect_test _ = + run {| let hd1::hd2::tl = () |} ; + [%expect {| let hd1 :: hd2 :: tl = () |}] + +let%expect_test _ = + run {| let ( x : int ) = 1 |} ; + [%expect {| let (x : int) = 1 |}] + +let%expect_test _ = + run {| let Some Some (x : int) = Some (Some 1) |} ; + [%expect {| let Some Some (x : int) = Some (Some 1) |}] + +let%expect_test _ = + run {| let Some Some x : int option option = Some (Some 1) |} ; + [%expect + {| + let (Some Some x : (int option) option) = + Some (Some 1) + |}] + +(* ======= Expressions ======= *) + +let%expect_test _ = + run {| function | a -> true | b -> false |} ; + [%expect {| function a -> true | b -> false |}] + +let%expect_test _ = + run {| fun x y -> x + y |} ; [%expect {| fun x y -> + x y |}] + +let%expect_test _ = run {| a0b'c_d |} ; [%expect {| a0b'c_d |}] + +let%expect_test _ = + run "a >>= b ++ c ** d !+ e" ; + [%expect {| >>= a (++ b (** c (d (!+ e)))) |}] + +let%expect_test _ = + run {| let rec a = 1 and b = 2 in let e = 3 in a |} ; + [%expect {| + let rec a = 1 and b = 2 in + let e = 3 in a + |}] + +let%expect_test _ = + run {| if a then (if b then c) else d |} ; + [%expect {| if a then if b then c else d |}] + +let%expect_test _ = + run {| if a; b then c; d |} ; + [%expect {| if a; b then c; d |}] + +let%expect_test _ = + run {| if a; b then (c; d) |} ; + [%expect {| if a; b then c; d |}] + +let%expect_test _ = + run {| match a with b -> c | d -> e |} ; + [%expect {| match a with b -> c | d -> e |}] + +let%expect_test _ = + run {| match a with | b | c | d -> e | f -> g |} ; + [%expect {| match a with b | c | d -> e | f -> g |}] + +let%expect_test _ = run {| Nil |} ; [%expect {| Nil |}] + +let%expect_test _ = run {| Some x |} ; [%expect {| Some x |}] + +let%expect_test _ = run {| Cons (1, Nil) |} ; [%expect {| Cons (1, Nil) |}] + +let%expect_test _ = + run {| [a;b;c] |} ; [%expect {| :: (a, :: (b, :: (c, []))) |}] + +let%expect_test _ = + run {| [a;(b;c)] |} ; [%expect {| :: (a, :: ((b; c), [])) |}] + +let%expect_test _ = run {| [a] |} ; [%expect {| :: (a, []) |}] + +let%expect_test _ = run {| [] |} ; [%expect {| [] |}] + +let%expect_test _ = + run {| (a :: b) :: c :: d :: [] |} ; + [%expect {| :: (:: (a, b), :: (c, :: (d, []))) |}] + +let%expect_test _ = + run {| (a ; b) ; c ; d ; e |} ; + [%expect {| (a; b); c; d; e |}] + +let%expect_test _ = run {| a, (b, c), d, e |} ; [%expect {| a, (b, c), d, e |}] + +let%expect_test _ = run {| a, (b, c) |} ; [%expect {| a, (b, c) |}] + +let%expect_test _ = run {| (a, b), c |} ; [%expect {| (a, b), c |}] + +let%expect_test _ = run {| 1 + - + + 3 |} ; [%expect {| + 1 (~- (~+ (~+ 3))) |}] + +let%expect_test _ = run {| !%< 123; !0 |} ; [%expect {| !%< 123; ! 0 |}] + +let%expect_test _ = run {| --+1 |} ; [%expect {| ~- (~- (~+ 1)) |}] + +let%expect_test _ = run {| f(1+2+3) |} ; [%expect {| f (+ (+ 1 2) 3) |}] + +let%expect_test _ = + run {| if(a && b) then(1+2) else(3) |} ; + [%expect {| if && a b then + 1 2 else 3 |}] + +let%expect_test _ = + run {| id let a = 1 in a |} ; + [%expect {| id (let a = 1 in a) |}] + +let%expect_test _ = + run {| ! let a = 1 in a |} ; [%expect {| ! (let a = 1 in a) |}] + +let%expect_test _ = + run {| 1 + let a = 1 in a |} ; + [%expect {| + 1 (let a = 1 in a) |}] + +let%expect_test _ = run {| ( a : int ) |} ; [%expect {| (a : int) |}] + +let%expect_test _ = + run {| (fun x -> x : int -> int) |} ; + [%expect {| (fun x -> x : int -> int) |}] + +let%expect_test _ = + run {| let f x y : int = 1 in f |} ; + [%expect {| let f = fun x y -> (1 : int) in f |}] + +(* ======= Types ======= *) + +let%expect_test _ = + run {| type foo = A of int |} ; + [%expect {| type foo = A of int |}] + +let%expect_test _ = + run {| type foo = A of int list |} ; + [%expect {| type foo = A of int list |}] + +let%expect_test _ = + run {| type foo = A of (int, string) map |} ; + [%expect {| type foo = A of (int, string) map |}] + +let%expect_test _ = + run {| type foo = A of 'a -> 'b -> 'c |} ; + [%expect {| type foo = A of a -> b -> c |}] + +let%expect_test _ = + run {| type foo = A of 'a * 'b * 'c |} ; + [%expect {| type foo = A of a * b * c |}] + +let%expect_test _ = + run {| type foo = A of 'some_type_var |} ; + [%expect {| type foo = A of some_type_var |}] + +let%expect_test _ = + run + {| type foo = A of + ('a -> int * (string, unit, 'b -> 'c) foo bar option) -> e |} ; + [%expect + {| + type foo = + | A of + ( + a -> int + * (((string, unit, b -> c) foo) bar) option + ) -> e + |}] + +(* ======= Some other stuff ======= *) + +let%expect_test _ = + run {| let (f, s) = (f + s, f - s) |} ; + [%expect {| let f, s = + f s, - f s |}] + +let%expect_test _ = + run {| let (>>=) a b = a ** b |} ; + [%expect {| let >>= = fun a b -> ** a b |}] + +let%expect_test _ = + run {| let (++) a b = a + b |} ; + [%expect {| let ++ = fun a b -> + a b |}] + +let%expect_test _ = + run + {| let(*sus*)rec(*firstcomment*)f n = (* second comment *) (* third + comment*) n + 1 |} ; + [%expect {| let rec f = fun n -> + n 1 |}] + +let%expect_test _ = + run {| letrec f n = n + 1 |} ; + [%expect {| = (letrec f n) (+ n 1) |}] + +let%expect_test _ = run {| let reca = 1 |} ; [%expect {| let reca = 1 |}] + +let%expect_test _ = + run {| type 'a list = Nil | Cons of 'a * 'a list |} ; + [%expect {| type 'a list = Nil | Cons of a * a list |}] + +let%expect_test _ = run {| 1a |} ; [%expect {| syntax error |}] + +let%expect_test _ = run {| 1 ;; a |} ; [%expect {| + 1;; + + a + |}] diff --git a/lib/parse/test/test.mli b/lib/parse/test/ParseTest.mli similarity index 100% rename from lib/parse/test/test.mli rename to lib/parse/test/ParseTest.mli diff --git a/lib/parse/test/dune b/lib/parse/test/dune index 0a515aa..0df425c 100644 --- a/lib/parse/test/dune +++ b/lib/parse/test/dune @@ -1,6 +1,6 @@ (library (name ParseTest) - (libraries base stdio LAst LParse) + (libraries base stdio LAst LParse LPrint) (preprocess (pps ppx_expect)) (inline_tests)) diff --git a/lib/parse/test/test.ml b/lib/parse/test/test.ml deleted file mode 100644 index dc7e779..0000000 --- a/lib/parse/test/test.ml +++ /dev/null @@ -1,867 +0,0 @@ -[@@@ocaml.text "/*"] - -(** Copyright 2024, Andrei, PavlushaSource *) - -(** SPDX-License-Identifier: MIT *) - -[@@@ocaml.text "/*"] - -open! Base -open Stdio -open LAst - -let run s = - match LParse.parse s with - | None -> - print_endline "syntax error" - | Some str -> - print_endline (show_structure str) - -let%expect_test _ = - run {| let rec fact n = if n <= 1 then 1 else n * fact (n - 1) |} ; - [%expect - {| - [(Let (Rec, - ({ pat = (Var (I "fact")); - expr = - (Fun (((Var (I "n")), []), - (If ( - (Apply ((Apply ((Id (I "<=")), (Id (I "n")))), (Const (Int 1)))), - (Const (Int 1)), - (Some (Apply ((Apply ((Id (I "*")), (Id (I "n")))), - (Apply ((Id (I "fact")), - (Apply ((Apply ((Id (I "-")), (Id (I "n")))), - (Const (Int 1)))) - )) - ))) - )) - )) - }, - []) - )) - ] - |}] - -(* ======= Patterns ======= *) - -let%expect_test _ = - run {| let Cons (hd, tl) = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Construct ((I "Cons"), - (Some (Tuple ((Var (I "hd")), (Var (I "tl")), []))))); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let C _ | a, b = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Or ((Construct ((I "C"), (Some Any))), - (Tuple ((Var (I "a")), (Var (I "b")), [])))); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let a | (b | c) | d = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Or ((Or ((Var (I "a")), (Or ((Var (I "b")), (Var (I "c")))))), - (Var (I "d")))); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let a, (b, c), d = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Tuple - ((Var (I "a")), (Tuple ((Var (I "b")), (Var (I "c")), [])), - [(Var (I "d"))])); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let a, b | c, d = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Or ((Tuple ((Var (I "a")), (Var (I "b")), [])), - (Tuple ((Var (I "c")), (Var (I "d")), [])))); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let a::(b::c)::d = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Construct ((I "::"), - (Some (Tuple - ((Var (I "a")), - (Construct ((I "::"), - (Some (Tuple - ((Construct ((I "::"), - (Some (Tuple - ((Var (I "b")), (Var (I "c")), - []))) - )), - (Var (I "d")), []))) - )), - []))) - )); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let a::b::c,d|e = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Or ( - (Tuple - ((Construct ((I "::"), - (Some (Tuple - ((Var (I "a")), - (Construct ((I "::"), - (Some (Tuple ((Var (I "b")), (Var (I "c")), []))) - )), - []))) - )), - (Var (I "d")), [])), - (Var (I "e")))); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let [a;b;c] = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Construct ((I "::"), - (Some (Tuple - ((Var (I "a")), - (Construct ((I "::"), - (Some (Tuple - ((Var (I "b")), - (Construct ((I "::"), - (Some (Tuple - ((Var (I "c")), - (Construct ((I "[]"), None)), - []))) - )), - []))) - )), - []))) - )); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let [a] = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Construct ((I "::"), - (Some (Tuple ((Var (I "a")), (Construct ((I "[]"), None)), []))))); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let [] = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = (Construct ((I "[]"), None)); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let hd1::hd2::tl = () |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Construct ((I "::"), - (Some (Tuple - ((Var (I "hd1")), - (Construct ((I "::"), - (Some (Tuple ((Var (I "hd2")), (Var (I "tl")), []))))), - []))) - )); - expr = (Construct ((I "()"), None)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let ( x : int ) = 1 |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = (Constraint ((Var (I "x")), (Con ((I "int"), [])))); - expr = (Const (Int 1)) }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let Some Some (x : int) = Some (Some 1) |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Construct ((I "Some"), - (Some (Construct ((I "Some"), - (Some (Constraint ((Var (I "x")), (Con ((I "int"), []))))) - ))) - )); - expr = - (Construct ((I "Some"), - (Some (Construct ((I "Some"), (Some (Const (Int 1)))))))) - }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let Some Some x : int option option = Some (Some 1) |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = - (Constraint ( - (Construct ((I "Some"), - (Some (Construct ((I "Some"), (Some (Var (I "x")))))))), - (Con ((I "option"), [(Con ((I "option"), [(Con ((I "int"), []))]))] - )) - )); - expr = - (Construct ((I "Some"), - (Some (Construct ((I "Some"), (Some (Const (Int 1)))))))) - }, - []) - )) - ] - |}] - -(* ======= Expressions ======= *) - -let%expect_test _ = - run {| function | a -> true | b -> false |} ; - [%expect - {| - [(Eval - (Function - ({ left = (Var (I "a")); right = (Construct ((I "true"), None)) }, - [{ left = (Var (I "b")); right = (Construct ((I "false"), None)) }]))) - ] - |}] - -let%expect_test _ = - run {| fun x y -> x + y |} ; - [%expect - {| - [(Eval - (Fun (((Var (I "x")), [(Var (I "y"))]), - (Apply ((Apply ((Id (I "+")), (Id (I "x")))), (Id (I "y"))))))) - ] - |}] - -let%expect_test _ = - run {| a0b'c_d |} ; [%expect {| [(Eval (Id (I "a0b'c_d")))] |}] - -let%expect_test _ = - run "a >>= b ++ c ** d !+ e" ; - [%expect - {| - [(Eval - (Apply ((Apply ((Id (I ">>=")), (Id (I "a")))), - (Apply ((Apply ((Id (I "++")), (Id (I "b")))), - (Apply ((Apply ((Id (I "**")), (Id (I "c")))), - (Apply ((Id (I "d")), (Apply ((Id (I "!+")), (Id (I "e")))))))) - )) - ))) - ] - |}] - -let%expect_test _ = - run {| let rec a = 1 and b = 2 in let e = 3 in a |} ; - [%expect - {| - [(Eval - (Let (Rec, - ({ pat = (Var (I "a")); expr = (Const (Int 1)) }, - [{ pat = (Var (I "b")); expr = (Const (Int 2)) }]), - (Let (Nonrec, ({ pat = (Var (I "e")); expr = (Const (Int 3)) }, []), - (Id (I "a")))) - ))) - ] - |}] - -let%expect_test _ = - run {| if a then (if b then c) else d |} ; - [%expect - {| - [(Eval - (If ((Id (I "a")), (If ((Id (I "b")), (Id (I "c")), None)), - (Some (Id (I "d")))))) - ] - |}] - -let%expect_test _ = - run {| if a; b then c; d |} ; - [%expect - {| - [(Eval - (If ((Tuple ((Id (I "a")), (Id (I "b")), [])), - (Tuple ((Id (I "c")), (Id (I "d")), [])), None))) - ] - |}] - -let%expect_test _ = - run {| if a; b then (c; d) |} ; - [%expect - {| - [(Eval - (If ((Tuple ((Id (I "a")), (Id (I "b")), [])), - (Tuple ((Id (I "c")), (Id (I "d")), [])), None))) - ] - |}] - -let%expect_test _ = - run {| match a with b -> c | d -> e |} ; - [%expect - {| - [(Eval - (Match ((Id (I "a")), - ({ left = (Var (I "b")); right = (Id (I "c")) }, - [{ left = (Var (I "d")); right = (Id (I "e")) }]) - ))) - ] - |}] - -let%expect_test _ = - run {| match a with | b | c | d -> e | f -> g |} ; - [%expect - {| - [(Eval - (Match ((Id (I "a")), - ({ left = (Or ((Or ((Var (I "b")), (Var (I "c")))), (Var (I "d")))); - right = (Id (I "e")) }, - [{ left = (Var (I "f")); right = (Id (I "g")) }]) - ))) - ] - |}] - -let%expect_test _ = - run {| Nil |} ; [%expect {| [(Eval (Construct ((I "Nil"), None)))] |}] - -let%expect_test _ = - run {| Some x |} ; - [%expect {| [(Eval (Construct ((I "Some"), (Some (Id (I "x"))))))] |}] - -let%expect_test _ = - run {| Cons (1, Nil) |} ; - [%expect - {| - [(Eval - (Construct ((I "Cons"), - (Some (Tuple ((Const (Int 1)), (Construct ((I "Nil"), None)), [])))))) - ] - |}] - -let%expect_test _ = - run {| [a;b;c] |} ; - [%expect - {| - [(Eval - (Construct ((I "::"), - (Some (Tuple - ((Tuple ((Id (I "a")), (Id (I "b")), [(Id (I "c"))])), - (Construct ((I "[]"), None)), []))) - ))) - ] - |}] - -let%expect_test _ = - run {| [a;(b;c)] |} ; - [%expect - {| - [(Eval - (Construct ((I "::"), - (Some (Tuple - ((Tuple - ((Id (I "a")), (Tuple ((Id (I "b")), (Id (I "c")), [])), - [])), - (Construct ((I "[]"), None)), []))) - ))) - ] - |}] - -let%expect_test _ = - run {| [a] |} ; - [%expect - {| - [(Eval - (Construct ((I "::"), - (Some (Tuple ((Id (I "a")), (Construct ((I "[]"), None)), [])))))) - ] - |}] - -let%expect_test _ = - run {| [] |} ; [%expect {| [(Eval (Construct ((I "[]"), None)))] |}] - -let%expect_test _ = - run {| (a :: b) :: c :: d :: [] |} ; - [%expect - {| - [(Eval - (Construct ((I "::"), - (Some (Tuple - ((Construct ((I "::"), - (Some (Tuple ((Id (I "a")), (Id (I "b")), []))))), - (Construct ((I "::"), - (Some (Tuple - ((Id (I "c")), - (Construct ((I "::"), - (Some (Tuple - ((Id (I "d")), - (Construct ((I "[]"), None)), - []))) - )), - []))) - )), - []))) - ))) - ] - |}] - -let%expect_test _ = - run {| (a ; b) ; c ; d ; e |} ; - [%expect - {| - [(Eval - (Tuple - ((Tuple ((Id (I "a")), (Id (I "b")), [])), (Id (I "c")), - [(Id (I "d")); (Id (I "e"))]))) - ] - |}] - -let%expect_test _ = - run {| a, (b, c), d, e |} ; - [%expect - {| - [(Eval - (Tuple - ((Id (I "a")), (Tuple ((Id (I "b")), (Id (I "c")), [])), - [(Id (I "d")); (Id (I "e"))]))) - ] - |}] - -let%expect_test _ = - run {| a, (b, c) |} ; - [%expect - {| [(Eval (Tuple ((Id (I "a")), (Tuple ((Id (I "b")), (Id (I "c")), [])), [])))] |}] - -let%expect_test _ = - run {| (a, b), c |} ; - [%expect - {| [(Eval (Tuple ((Tuple ((Id (I "a")), (Id (I "b")), [])), (Id (I "c")), [])))] |}] - -let%expect_test _ = - run {| 1 + - + + 3 |} ; - [%expect - {| - [(Eval - (Apply ((Apply ((Id (I "+")), (Const (Int 1)))), - (Apply ((Id (I "~-")), - (Apply ((Id (I "~+")), (Apply ((Id (I "~+")), (Const (Int 3)))))))) - ))) - ] - |}] - -let%expect_test _ = - run {| !%< 123; !0 |} ; - [%expect - {| - [(Eval - (Tuple - ((Apply ((Id (I "!%<")), (Const (Int 123)))), - (Apply ((Id (I "!")), (Const (Int 0)))), []))) - ] - |}] - -let%expect_test _ = - run {| --+1 |} ; - [%expect - {| - [(Eval - (Apply ((Id (I "~-")), - (Apply ((Id (I "~-")), (Apply ((Id (I "~+")), (Const (Int 1))))))))) - ] - |}] - -let%expect_test _ = - run {| f(1+2+3) |} ; - [%expect - {| - [(Eval - (Apply ((Id (I "f")), - (Apply ( - (Apply ((Id (I "+")), - (Apply ((Apply ((Id (I "+")), (Const (Int 1)))), (Const (Int 2)) - )) - )), - (Const (Int 3)))) - ))) - ] - |}] - -let%expect_test _ = - run {| if(a && b) then(1+2) else(3) |} ; - [%expect - {| - [(Eval - (If ((Apply ((Apply ((Id (I "&&")), (Id (I "a")))), (Id (I "b")))), - (Apply ((Apply ((Id (I "+")), (Const (Int 1)))), (Const (Int 2)))), - (Some (Const (Int 3)))))) - ] - |}] - -let%expect_test _ = - run {| id let a = 1 in a |} ; - [%expect - {| - [(Eval - (Apply ((Id (I "id")), - (Let (Nonrec, ({ pat = (Var (I "a")); expr = (Const (Int 1)) }, []), - (Id (I "a")))) - ))) - ] - |}] - -let%expect_test _ = - run {| ! let a = 1 in a |} ; - [%expect - {| - [(Eval - (Apply ((Id (I "!")), - (Let (Nonrec, ({ pat = (Var (I "a")); expr = (Const (Int 1)) }, []), - (Id (I "a")))) - ))) - ] - |}] - -let%expect_test _ = - run {| 1 + let a = 1 in a |} ; - [%expect - {| - [(Eval - (Apply ((Apply ((Id (I "+")), (Const (Int 1)))), - (Let (Nonrec, ({ pat = (Var (I "a")); expr = (Const (Int 1)) }, []), - (Id (I "a")))) - ))) - ] - |}] - -let%expect_test _ = - run {| ( a : int ) |} ; - [%expect {| [(Eval (Constraint ((Id (I "a")), (Con ((I "int"), [])))))] |}] - -let%expect_test _ = - run {| (fun x -> x : int -> int) |} ; - [%expect - {| - [(Eval - (Constraint ((Fun (((Var (I "x")), []), (Id (I "x")))), - (Arr ((Con ((I "int"), [])), (Con ((I "int"), []))))))) - ] - |}] - -let%expect_test _ = - run {| let f x y : int = 1 in f |} ; - [%expect - {| - [(Eval - (Let (Nonrec, - ({ pat = (Var (I "f")); - expr = - (Fun (((Var (I "x")), [(Var (I "y"))]), - (Constraint ((Const (Int 1)), (Con ((I "int"), [])))))) - }, - []), - (Id (I "f"))))) - ] - |}] - -(* ======= Types ======= *) - -let%expect_test _ = - run {| type foo = A of int |} ; - [%expect - {| - [(Type - { id = (I "foo"); params = []; - variants = [{ id = (I "A"); arg = (Some (Con ((I "int"), []))) }] }) - ] - |}] - -let%expect_test _ = - run {| type foo = A of int list |} ; - [%expect - {| - [(Type - { id = (I "foo"); params = []; - variants = - [{ id = (I "A"); - arg = (Some (Con ((I "list"), [(Con ((I "int"), []))]))) } - ] - }) - ] - |}] - -let%expect_test _ = - run {| type foo = A of (int, string) map |} ; - [%expect - {| - [(Type - { id = (I "foo"); params = []; - variants = - [{ id = (I "A"); - arg = - (Some (Con ((I "map"), - [(Con ((I "int"), [])); (Con ((I "string"), []))]))) - } - ] - }) - ] - |}] - -let%expect_test _ = - run {| type foo = A of 'a -> 'b -> 'c |} ; - [%expect - {| - [(Type - { id = (I "foo"); params = []; - variants = - [{ id = (I "A"); - arg = - (Some (Arr ((Var (I "a")), (Arr ((Var (I "b")), (Var (I "c"))))))) } - ] - }) - ] - |}] - -let%expect_test _ = - run {| type foo = A of 'a * 'b * 'c |} ; - [%expect - {| - [(Type - { id = (I "foo"); params = []; - variants = - [{ id = (I "A"); - arg = (Some (Tuple ((Var (I "a")), (Var (I "b")), [(Var (I "c"))]))) - } - ] - }) - ] - |}] - -let%expect_test _ = - run {| type foo = A of 'some_type_var |} ; - [%expect - {| - [(Type - { id = (I "foo"); params = []; - variants = [{ id = (I "A"); arg = (Some (Var (I "some_type_var"))) }] }) - ] - |}] - -let%expect_test _ = - run - {| type foo = A of - ('a -> int * (string, unit, 'b -> 'c) foo bar option) -> e |} ; - [%expect - {| - [(Type - { id = (I "foo"); params = []; - variants = - [{ id = (I "A"); - arg = - (Some (Arr ( - (Arr ((Var (I "a")), - (Tuple - ((Con ((I "int"), [])), - (Con ((I "option"), - [(Con ((I "bar"), - [(Con ((I "foo"), - [(Con ((I "string"), [])); - (Con ((I "unit"), [])); - (Arr ((Var (I "b")), (Var (I "c"))))] - )) - ] - )) - ] - )), - [])) - )), - (Con ((I "e"), []))))) - } - ] - }) - ] - |}] - -(* ======= Some other stuff ======= *) - -let%expect_test _ = - run {| let (f, s) = (f + s, f - s) |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = (Tuple ((Var (I "f")), (Var (I "s")), [])); - expr = - (Tuple - ((Apply ((Apply ((Id (I "+")), (Id (I "f")))), (Id (I "s")))), - (Apply ((Apply ((Id (I "-")), (Id (I "f")))), (Id (I "s")))), - [])) - }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let (>>=) a b = a ** b |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = (Var (I ">>=")); - expr = - (Fun (((Var (I "a")), [(Var (I "b"))]), - (Apply ((Apply ((Id (I "**")), (Id (I "a")))), (Id (I "b")))))) - }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| let (++) a b = a + b |} ; - [%expect - {| - [(Let (Nonrec, - ({ pat = (Var (I "++")); - expr = - (Fun (((Var (I "a")), [(Var (I "b"))]), - (Apply ((Apply ((Id (I "+")), (Id (I "a")))), (Id (I "b")))))) - }, - []) - )) - ] - |}] - -let%expect_test _ = - run - {| let(*sus*)rec(*firstcomment*)f n = (* second comment *) (* third - comment*) n + 1 |} ; - [%expect - {| - [(Let (Rec, - ({ pat = (Var (I "f")); - expr = - (Fun (((Var (I "n")), []), - (Apply ((Apply ((Id (I "+")), (Id (I "n")))), (Const (Int 1)))))) - }, - []) - )) - ] - |}] - -let%expect_test _ = - run {| letrec f n = n + 1 |} ; - [%expect - {| - [(Eval - (Apply ( - (Apply ((Id (I "=")), - (Apply ((Apply ((Id (I "letrec")), (Id (I "f")))), (Id (I "n")))))), - (Apply ((Apply ((Id (I "+")), (Id (I "n")))), (Const (Int 1))))))) - ] - |}] - -let%expect_test _ = - run {| let reca = 1 |} ; - [%expect - {| [(Let (Nonrec, ({ pat = (Var (I "reca")); expr = (Const (Int 1)) }, [])))] |}] - -let%expect_test _ = - run {| type 'a list = Nil | Cons of 'a * 'a list |} ; - [%expect - {| - [(Type - { id = (I "list"); params = [(I "a")]; - variants = - [{ id = (I "Nil"); arg = None }; - { id = (I "Cons"); - arg = - (Some (Tuple - ((Var (I "a")), (Con ((I "list"), [(Var (I "a"))])), []))) - } - ] - }) - ] - |}] - -let%expect_test _ = run {| 1a |} ; [%expect {| syntax error |}] - -let%expect_test _ = - run {| 1 ;; a |} ; - [%expect {| [(Eval (Const (Int 1))); (Eval (Id (I "a")))] |}] diff --git a/lib/print/LPrint.ml b/lib/print/LPrint.ml new file mode 100644 index 0000000..ad5acd8 --- /dev/null +++ b/lib/print/LPrint.ml @@ -0,0 +1,17 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base + +let pp_id = Common.pp_id +let pp_const = Common.pp_const +let pp_ty = PpTy.pp +let pp_pat = PpPat.pp +let pp_expr = PpExpr.pp +let pp_stritem = PpStr.pp_stritem +let pp_structure = PpStr.pp_structure diff --git a/lib/print/PpExpr.ml b/lib/print/PpExpr.ml new file mode 100644 index 0000000..d85372e --- /dev/null +++ b/lib/print/PpExpr.ml @@ -0,0 +1,136 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open LMisc +open PPrint +open Common + +module Prec = struct + type t = Open | Seq | Tuple | Apply | Highest [@@deriving enum] + let parens = parens +end + +let pcase left right = + group @@ left ^^ string " ->" ^^ group (nest 2 (break 1 ^^ right)) + +let pp = + let open LAst.Expr in + let open PrecedencePrinter (Prec) in + let rec p = function + | Id id -> + return Prec.Highest (pp_id id) + | Const x -> + return Prec.Highest (pp_const x) + | Let (rec_flag, bindings, expr) -> + let rec_flag = + match rec_flag with Rec -> string " rec" | Nonrec -> empty + in + + let bindings = + let docs = + List.map (List1.to_list bindings) ~f:(fun {pat; expr} -> + nest 2 @@ group @@ PpPat.pp pat + ^^ group (string " =" ^/^ runf p expr) ) + in + separate (break 1 ^^ string "and" ^^ nest 2 (break 1)) docs + in + let expr = runf p expr in + + let doc = + group @@ string "let" ^^ rec_flag + ^^ group (group (break 1) ^^ bindings ^/^ string "in") + ^/^ expr + in + return Prec.Open doc + | Fun (args, expr) -> + let args = List.map (List1.to_list args) ~f:PpPat.pp in + let expr = runf p expr in + + let doc = + group @@ string "fun" + ^^ group (break 1) + ^^ flow (break 1) args + ^^ string " ->" + ^^ nest 2 (break 1 ^^ expr) + in + return Prec.Open doc + | Function cases -> + let cases = + List.map (List1.to_list cases) ~f:(fun {left; right} -> + pcase (PpPat.pp left) (runf p right) ) + in + + let doc = + group @@ string "function" + ^/^ ifflat empty (string "| ") + ^^ separate (break 1 ^^ string "| ") cases + in + return Prec.Open doc + | Match (expr, cases) -> + let expr = runf p expr in + let cases = + List.map (List1.to_list cases) ~f:(fun {left; right} -> + pcase (PpPat.pp left) (runf p right) ) + in + + let doc = + group @@ string "match" + ^^ nest 2 (break 1 ^^ expr) + ^/^ string "with" + ^^ group + ( break 1 + ^^ ifflat empty (string "| ") + ^^ separate (break 1 ^^ string "| ") cases ) + in + return Prec.Open doc + | Apply (expr, arg) -> + let op expr arg = group @@ expr ^^ group (nest 2 (break 1 ^^ arg)) in + rinfixl Prec.Apply op (p expr) (p arg) + | If (if_, then_, else_) -> + let if_ = runf p if_ in + let then_ = runf p then_ in + let else_ = Option.map ~f:(runf p) else_ in + + let pelse = + optional + (fun else_ -> + group @@ break 1 ^^ string "else" + ^^ group (nest 2 (break 1 ^^ else_)) ) + else_ + in + + let doc = + group @@ string "if" + ^^ group (nest 2 (break 1 ^^ if_)) + ^/^ string "then" + ^^ group (nest 2 (break 1 ^^ then_)) + ^^ pelse + in + return Prec.Open doc + | Seq list2 -> + let op docs = group @@ flow (semi ^^ break 1) docs in + rinfixn Prec.Seq op (List.map (List2.to_list list2) ~f:p) + | Tuple list2 -> + let op docs = group @@ flow (comma ^^ break 1) docs in + rinfixn Prec.Tuple op (List.map (List2.to_list list2) ~f:p) + | Construct (id, None) -> + return Prec.Apply (pp_id id) + | Construct (id, Some arg) -> + rinfixl Prec.Apply (infixl empty) + (return Prec.Highest (pp_id id)) + (p arg) + | Constraint (expr, ty) -> + let pat = runf p expr in + let ty = PpTy.pp ty in + + let doc = parens @@ pat ^/^ string ": " ^^ ty in + return Prec.Highest doc + in + + runf p diff --git a/lib/print/PpExpr.mli b/lib/print/PpExpr.mli new file mode 100644 index 0000000..8d1c42d --- /dev/null +++ b/lib/print/PpExpr.mli @@ -0,0 +1,11 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base + +val pp : LAst.Expr.t -> PPrint.document diff --git a/lib/print/PpPat.ml b/lib/print/PpPat.ml new file mode 100644 index 0000000..976c24e --- /dev/null +++ b/lib/print/PpPat.ml @@ -0,0 +1,50 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open LMisc +open PPrint +open Common + +module Prec = struct + type t = Or | Tuple | List | Construct | Highest [@@deriving enum] + let parens = parens +end + +let pp = + let open LAst.Pat in + let open PrecedencePrinter (Prec) in + let rec p = function + | Any -> + return Prec.Highest (char '_') + | Var id -> + return Prec.Highest (pp_id id) + | Const x -> + return Prec.Highest (pp_const x) + | Construct (I "::", Some (Tuple (l, r, []))) -> + rinfixr Prec.List (infixr (string ":: ")) (p l) (p r) + | Construct (id, Some arg) -> + rinfixr Prec.Construct (infixr empty) + (return Prec.Highest (pp_id id)) + (p arg) + | Construct (id, None) -> + return Prec.Construct (pp_id id) + | Tuple list2 -> + let op docs = group @@ flow (comma ^^ break 1) docs in + rinfixn Prec.Tuple op (List.map (List2.to_list list2) ~f:p) + | Or (x, y) -> + rinfixl Prec.Or (infixl (string "| ")) (p x) (p y) + | Constraint (pat, ty) -> + let pat = runf p pat in + let ty = PpTy.pp ty in + + let doc = parens @@ pat ^/^ string ": " ^^ ty in + return Prec.Highest doc + in + + runf p diff --git a/lib/print/PpPat.mli b/lib/print/PpPat.mli new file mode 100644 index 0000000..60929bb --- /dev/null +++ b/lib/print/PpPat.mli @@ -0,0 +1,11 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base + +val pp : LAst.Pat.t -> PPrint.document diff --git a/lib/print/PpStr.ml b/lib/print/PpStr.ml new file mode 100644 index 0000000..aab8e7b --- /dev/null +++ b/lib/print/PpStr.ml @@ -0,0 +1,67 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open LMisc +open PPrint +open Common + +let pp_stritem = + let open LAst.StrItem in + function + | Eval expr -> + PpExpr.pp expr + | Let (rec_flag, bindings) -> + let rec_flag = + match rec_flag with Rec -> string " rec" | Nonrec -> empty + in + + let bindings = + let docs = + List.map (List1.to_list bindings) ~f:(fun {pat; expr} -> + group @@ PpPat.pp pat ^^ group (string " =" ^/^ PpExpr.pp expr) ) + in + separate (break 1 ^^ string "and" ^^ break 1) docs + in + + group @@ string "let" ^^ rec_flag ^^ nest 2 (group (break 1) ^^ bindings) + | Type {id; params; variants} -> + let id = pp_id id in + let params = + let pparam id = string "'" ^^ pp_id id in + + match params with + | [] -> + empty + | [id] -> + pparam id ^^ space + | _ -> + let params = List.map params ~f:pparam in + parens (flow (comma ^^ break 1) params) ^^ space + in + + let variants = + List.map variants ~f:(fun {id; arg} -> + group @@ pp_id id + ^^ optional + (fun ty -> string " of" ^^ nest 2 (break 1 ^^ PpTy.pp ty)) + arg ) + in + + group @@ string "type" + ^^ group (break 1) + ^^ params ^^ id ^^ string " =" + ^^ group + ( break 1 + ^^ ifflat empty (string "| ") + ^^ separate (break 1 ^^ string "| ") variants ) + +let pp_structure str = + let open PPrint in + let str = List.map str ~f:(fun item -> pp_stritem item) in + flow (string ";;" ^^ twice hardline) str diff --git a/lib/print/PpStr.mli b/lib/print/PpStr.mli new file mode 100644 index 0000000..3132b1e --- /dev/null +++ b/lib/print/PpStr.mli @@ -0,0 +1,12 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base + +val pp_stritem : LAst.StrItem.t -> PPrint.document +val pp_structure : LAst.structure -> PPrint.document diff --git a/lib/print/PpTy.ml b/lib/print/PpTy.ml new file mode 100644 index 0000000..45fccbe --- /dev/null +++ b/lib/print/PpTy.ml @@ -0,0 +1,43 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open LMisc +open PPrint +open Common + +module Prec = struct + type t = Arr | Tuple | Con | Highest [@@deriving enum] + let parens = parens +end + +let pp = + let open LAst.Ty in + let open PrecedencePrinter (Prec) in + let rec p = function + | Var id -> + return Prec.Highest (pp_id id) + | Con (id, []) -> + return Prec.Highest (pp_id id) + | Con (id, [arg]) -> + let op arg = group @@ arg ^^ space ^^ pp_id id in + rprefix Prec.Con op (p arg) + | Con (id, args) -> + let args = List.map args ~f:(runf p) in + let doc = + group @@ parens (flow (comma ^^ break 1) args) ^^ space ^^ pp_id id + in + return Prec.Con doc + | Tuple list2 -> + let op docs = group @@ flow (break 1 ^^ string "* ") docs in + rinfixn Prec.Tuple op (List.map (List2.to_list list2) ~f:p) + | Arr (l, r) -> + rinfixr Prec.Arr (infixr (string "-> ")) (p l) (p r) + in + + runf p diff --git a/lib/print/PpTy.mli b/lib/print/PpTy.mli new file mode 100644 index 0000000..7b4845f --- /dev/null +++ b/lib/print/PpTy.mli @@ -0,0 +1,11 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base + +val pp : LAst.Ty.t -> PPrint.document diff --git a/lib/print/common.ml b/lib/print/common.ml new file mode 100644 index 0000000..fac763f --- /dev/null +++ b/lib/print/common.ml @@ -0,0 +1,80 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open LMisc +open PPrint + +let pp_id (Id.I x) = string x + +let pp_const = + let open LAst.Const in + function + | Int x -> OCaml.int x | Char x -> OCaml.char x | String x -> OCaml.string x + +let parens p = + group @@ align @@ char '(' ^^ align (break 0 ^^ p) ^^ break 0 ^^ char ')' + +let infixl op l r = group @@ l ^^ group (break 1 ^^ op ^^ r) +let infixr op l r = group @@ l ^^ group (break 1) ^^ op ^^ r + +module PrecedencePrinter (Prec : sig + type t + val min : int + val to_enum : t -> int + + val parens : document -> document +end) = +struct + type 'a t = P of (int -> 'a) + + let run' (P f) = f + let run (P f) = f Prec.min + let runf p x = run (p x) + + let ( let* ) p f = P (fun lvl -> run' (f (run' p lvl)) lvl) + + let cur_lvl = P Fn.id + + let pure x = P (fun _ -> x) + + let return' lvl doc = + let* cur = cur_lvl in + pure @@ if cur > lvl then Prec.parens doc else doc + + let return lvl = return' (Prec.to_enum lvl) + + let with_lvl lvl p = pure @@ run' p lvl + + let rprefix lvl op p = + let lvl = Prec.to_enum lvl in + let* doc = with_lvl (lvl + 1) p in + return' lvl (op doc) + + let rinfixl lvl op l r = + let lvl = Prec.to_enum lvl in + let* l = with_lvl lvl l in + let* r = with_lvl (lvl + 1) r in + return' lvl (op l r) + + let rinfixr lvl op l r = + let lvl = Prec.to_enum lvl in + let* l = with_lvl (lvl + 1) l in + let* r = with_lvl lvl r in + return' lvl (op l r) + + let rinfixn lvl op ps = + let lvl = Prec.to_enum lvl in + let* docs = + List.fold_right ps ~init:(pure []) ~f:(fun p acc -> + let* acc = acc in + let* doc = with_lvl (lvl + 1) p in + pure (doc :: acc) ) + in + return' lvl (op docs) +end diff --git a/lib/print/common.mli b/lib/print/common.mli new file mode 100644 index 0000000..8fbfb4b --- /dev/null +++ b/lib/print/common.mli @@ -0,0 +1,55 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open LMisc +open LAst +open PPrint + +val pp_id : Id.t -> document +val pp_const : Const.t -> document + +val parens : document -> document +val infixl : document -> document -> document -> document +val infixr : document -> document -> document -> document + +module PrecedencePrinter : functor + (Prec : sig + type t + + val min : int + val to_enum : t -> int + val parens : document -> document + end) + -> sig + type 'a t + + val run : document t -> document + val runf : ('a -> document t) -> 'a -> document + + val return : Prec.t -> document -> document t + + val rprefix : Prec.t -> (document -> document) -> document t -> document t + + val rinfixl : + Prec.t + -> (document -> document -> document) + -> document t + -> document t + -> document t + + val rinfixr : + Prec.t + -> (document -> document -> document) + -> document t + -> document t + -> document t + + val rinfixn : + Prec.t -> (document list -> document) -> document t list -> document t +end diff --git a/lib/print/dune b/lib/print/dune new file mode 100644 index 0000000..a77c616 --- /dev/null +++ b/lib/print/dune @@ -0,0 +1,8 @@ +(library + (name LPrint) + (public_name NeML.Print) + (libraries base pprint LAst LMisc) + (preprocess + (pps ppx_deriving.enum)) + (instrumentation + (backend bisect_ppx))) diff --git a/lib/print/test/PrintTest.ml b/lib/print/test/PrintTest.ml new file mode 100644 index 0000000..5e0f77f --- /dev/null +++ b/lib/print/test/PrintTest.ml @@ -0,0 +1,383 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open Stdio + +let run s = + match LParse.parse s with + | None -> + print_endline "syntax error" + | Some str -> + PPrint.ToChannel.pretty 1. 50 stdout (LPrint.pp_structure str) + +let%expect_test _ = + run + {|let (33|1|2|3|1|2|3|(1|2|3)|1|2|3|1|2|3|1|2|3|1|2|(3|2|3|1|2|3|1|2|3|1|2|3|1|2|3|1)|2|1|2|3|(22|3|2|3|2|3|2|3|2|3|2|3|2|3|2|3|2|3|2|3|2|3|2|3|2|3|3|4)) = ()|} ; + [%expect + {| + let 33 | 1 | 2 | 3 | 1 | 2 | 3 | (1 | 2 | 3) | 1 + | 2 | 3 | 1 | 2 | 3 | 1 | 2 | 3 | 1 | 2 + | ( + 3 | 2 | 3 | 1 | 2 | 3 | 1 | 2 | 3 | 1 | 2 | 3 + | 1 | 2 | 3 | 1 + ) | 2 | 1 | 2 | 3 + | ( + 22 | 3 | 2 | 3 | 2 | 3 | 2 | 3 | 2 | 3 | 2 + | 3 | 2 | 3 | 2 | 3 | 2 | 3 | 2 | 3 | 2 | 3 + | 2 | 3 | 2 | 3 | 3 | 4 + ) = () + |}] + +let%expect_test _ = + run + {|let 1,2,3,4,5,6,(7,8,98,98,98,98,98,98,98,98,98,98,98,98,98,98,98,98,98,98,98,9),10,(11|2),12,13,14,15,16 = ()|} ; + [%expect + {| + let 1, 2, 3, 4, 5, 6, + ( + 7, 8, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, + 98, 98, 98, 98, 98, 98, 98, 98, 98, 9 + ), 10, (11 | 2), 12, 13, 14, 15, 16 = () + |}] + +let%expect_test _ = + run + {|let a::b, f::(c::dd::e,ed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::eed::ee::ee::f::f)::g::h::jh::jh::jh::jh::jh::jh::jh::jh::jh::jh::j = ()|} ; + [%expect + {| + let a :: b, + f :: ( + c :: dd :: e, + ed :: eed :: eed :: eed :: eed :: eed :: eed + :: eed :: eed :: eed :: eed :: eed :: eed :: eed + :: eed :: eed :: eed :: eed :: eed :: ee :: ee + :: f :: f + ) :: g :: h :: jh :: jh :: jh :: jh :: jh :: jh + :: jh :: jh :: jh :: jh :: j = () + |}] + +let%expect_test _ = + run + {|let Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some Some (1,2,3,3,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5) = ()|} ; + [%expect + {| + let Some Some Some Some Some Some Some Some Some Some + Some Some Some Some Some Some Some Some Some Some + Some Some Some Some Some Some Some Some Some Some + Some Some Some ( + 1, 2, 3, 3, 4, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5 + ) = () + |}] + +let%expect_test _ = + run + {|(a, b, (c, d) e, f, e, ef, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e,f, e, e) e|} ; + [%expect + {| + ( + a, b, (c, d) e, f, e, ef, e, e, f, e, e, f, e, e, + f, e, e, f, e, e, f, e, e, f, e, e, f, e, e, f, e, + e, f, e, e, f, e, e, f, e, e, f, e, e, f, e, e + ) e + |}] + +let%expect_test _ = + run + {|(a : a->b->cb->cb->cb->cb->cb->cb->cb->ccb->cbcb->cbcb->cbcb->(cbcb->cbcb->cbcb->cbcb->cbcb->cbcb->cbcb->cbcb->cbcb->cbcb->cbcb->cbcb->cbcb)->cbcb->cbcb->cb)|} ; + [%expect + {| + ( + a + : a -> b -> cb -> cb -> cb -> cb -> cb -> cb -> cb + -> ccb -> cbcb -> cbcb -> cbcb -> ( + cbcb -> cbcb -> cbcb + -> cbcb -> cbcb + -> cbcb -> cbcb + -> cbcb -> cbcb + -> cbcb -> cbcb + -> cbcb -> cbcb + ) -> cbcb -> cbcb + -> cb + ) + |}] + +let%expect_test _ = + run + {|(a: (a -> b) * cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*(cc*cc*cc*cc*cc*cc)*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*cc*c*c)|} ; + [%expect + {| + ( + a + : (a -> b) * cc * cc * cc * cc * cc * cc * cc + * cc * cc * cc * cc * cc + * (cc * cc * cc * cc * cc * cc) * cc * cc * cc + * cc * cc * cc * cc * cc * cc * cc * cc * cc * cc + * cc * cc * c * c + ) + |}] + +let%expect_test _ = + run + {|let a,b,c,d,e,f,c,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a = 1 and a,b,c,d,e,f,c,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a = a,b,c,d,e,f,c,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a and b =2 and c =3 in a,b,c,d,e,f,c,a,a,a,let b= a in 1,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a|} ; + [%expect + {| + let a, b, c, d, e, f, c, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a = 1 + and + a, b, c, d, e, f, c, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a = + a, b, c, d, e, f, c, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a + and + b = 2 + and + c = 3 + in + a, b, c, d, e, f, c, a, a, a, + ( + let b = a in + 1, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a + ) + |}] + +let%expect_test _ = + run {|let a = 1 and b=2 in b|} ; + [%expect {| let a = 1 and b = 2 in b |}] + +let%expect_test _ = + run + {|1,2,3,4,5,let a = let a = 1 and b = 2 in b,b,b,b,b,b,b,(let a= 2 in b,c),c,c,c,c,c,c,c,c,c,c,c,c in b|} ; + [%expect + {| + 1, 2, 3, 4, 5, + ( + let a = + let a = 1 and b = 2 in + b, b, b, b, b, b, b, (let a = 2 in b, c), c, c, + c, c, c, c, c, c, c, c, c, c + in + b + ) + |}] + +let%expect_test _ = + run + {|fun a b c d b c d b c d b c d b c d b c d b c d b c d b c d b c d b c d b c d -> aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa|} ; + [%expect + {| + fun a b c d b c d b c d b c d b c d b c d b c d b + c d b c d b c d b c d b c d -> + aaaa, aaaa, aaaa, aaaa, aaaa, aaaa, aaaa, aaaa, + aaaa, aaaa, aaaa, aaaa, aaaa, aaaa + |}] + +let%expect_test _ = + run + {|fun a b c d d,dd,d d,d d,d d,d d,d d,d d,d d,d d,d d,d d,d d,d d,d d,d ,d -> aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa,aaaa|} ; + [%expect + {| + fun a b c d d, dd, d d, d d, d d, d d, d d, d d, d + d, d d, d d, d d, d d, d d, d d, d, d -> + aaaa, aaaa, aaaa, aaaa, aaaa, aaaa, aaaa, aaaa, + aaaa, aaaa, aaaa, aaaa, aaaa, aaaa + |}] + +let%expect_test _ = + run + {|f x y d x x x x x x (xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,xx,x,x) x x x x x x x x x x x x x x x x x x|} ; + [%expect + {| + f x y d x x x x x x + ( + xx, xx, xx, xx, xx, xx, xx, xx, xx, xx, xx, xx, + xx, xx, xx, xx, xx, x, x + ) x x x x x x x x x x x x x x x x x x + |}] + +let%expect_test _ = run {|function a -> b|} ; [%expect {| function a -> b |}] + +let%expect_test _ = + run {|function a -> b | c -> d|} ; + [%expect {| function a -> b | c -> d |}] + +let%expect_test _ = + run + {|function a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d -> a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d | a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d -> a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d | a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d -> a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d|} ; + [%expect + {| + function + | a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d -> + a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d + | a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d -> + a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d + | a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d -> + a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d + |}] + +let%expect_test _ = + run + {|match a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a,a with a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d -> a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d | a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d -> a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d | a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d -> a,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d,d|} ; + [%expect + {| + match + a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, a, + a, a, a, a, a, a, a, a, a, a, a + with + | a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d -> + a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d + | a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d -> + a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d + | a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d -> + a, d, d, d, d, d, d, d, d, d, d, d, d, d, d, d, + d, d, d + |}] + +let%expect_test _ = + run {| match a with a -> b | c -> d|} ; + [%expect {| match a with a -> b | c -> d |}] + +let%expect_test _ = + run + {| match aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa with b -> c | c-> d|} ; + [%expect + {| + match + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + with b -> c | c -> d + |}] + +let%expect_test _ = + run + {| match aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa with b -> c | c-> d|} ; + [%expect + {| + match + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + with b -> c | c -> d + |}] + +let%expect_test _ = + run + {|if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa then aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa else aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|} ; + [%expect + {| + if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + then aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + else + aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + |}] + +let%expect_test _ = + run {|if a then b else c|} ; [%expect {| if a then b else c |}] + +let%expect_test _ = + run {|if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa then b|} ; + [%expect + {| + if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + then b + |}] + +let%expect_test _ = + run + {|if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa then bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb else c|} ; + [%expect + {| + if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + then + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + else c + |}] + +let%expect_test _ = + run + {|a;b;c;d;e;f;g;hf;g;hf;g;hf;g;hf;g;hf;g;hf;g;hf;g;hf;g;hf;g;hf;g;hf;g;hf;g;h|} ; + [%expect + {| + a; b; c; d; e; f; g; hf; g; hf; g; hf; g; hf; g; + hf; g; hf; g; hf; g; hf; g; hf; g; hf; g; hf; g; + hf; g; h + |}] + +let%expect_test _ = + run + {|let x = A (1,2,3,4,5,6,3,4,5,6,3,4,5,6,3,4,5,6,3,4,5,6,3,4,5,6,3,4,5,6,3,4,5,6,3,4,5,6,7) in x|} ; + [%expect + {| + let x = + A + ( + 1, 2, 3, 4, 5, 6, 3, 4, 5, 6, 3, 4, 5, 6, 3, 4, + 5, 6, 3, 4, 5, 6, 3, 4, 5, 6, 3, 4, 5, 6, 3, 4, + 5, 6, 3, 4, 5, 6, 7 + ) + in + x + |}] + +let%expect_test _ = + run + {|(avvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv: aa->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->ba->b->b)|} ; + [%expect + {| + ( + avvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + : aa -> ba -> ba -> ba -> ba -> ba -> ba -> ba -> ba + -> ba -> ba -> ba -> ba -> ba -> ba -> ba -> ba -> ba + -> ba -> ba -> ba -> b -> b + ) + |}] + +let%expect_test _ = + run + {|type foo = A of string -> string -> string -> string -> string -> string | B of int |} ; + [%expect + {| + type foo = + | A of + string -> string -> string -> string -> string -> string + | B of int + |}] + +let%expect_test _ = + run + {|type ('a, 'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a)foo = A of string -> string -> string -> string -> string -> string | B of int |} ; + [%expect + {| + type ( + 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, + 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a + ) foo = + | A of + string -> string -> string -> string -> string -> string + | B of int + |}] + +let%expect_test _ = + run + {|type ('a, 'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a,'a) foo = A of string |} ; + [%expect + {| + type ( + 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a, + 'a, 'a, 'a, 'a, 'a, 'a, 'a + ) foo = A of string + |}] diff --git a/lib/print/test/PrintTest.mli b/lib/print/test/PrintTest.mli new file mode 100644 index 0000000..2e4221c --- /dev/null +++ b/lib/print/test/PrintTest.mli @@ -0,0 +1,7 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] diff --git a/lib/print/test/dune b/lib/print/test/dune new file mode 100644 index 0000000..986dc54 --- /dev/null +++ b/lib/print/test/dune @@ -0,0 +1,6 @@ +(library + (name PrintTest) + (libraries base stdio LAst LParse LPrint) + (preprocess + (pps ppx_expect)) + (inline_tests))