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..7a27473 100644 --- a/lib/ast/LAst.ml +++ b/lib/ast/LAst.ml @@ -15,7 +15,11 @@ 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}] + + let pp = + let open PPrint in + function + | Int x -> OCaml.int x | Char x -> OCaml.char x | String x -> OCaml.string x end module Ty = struct @@ -29,7 +33,40 @@ module Ty = struct - [T tconstr] when [l=[T]] - [(T1, ..., Tn) tconstr] when [l=[T1, ..., Tn]] *) - [@@deriving show {with_path= false}] + + module Prec = struct + type t = Arr | Tuple | Con | Highest [@@deriving enum] + let parens = Pp.parens + end + + let pp = + let open Pp.PrecedencePrinter (Prec) in + let rec p = + let open PPrint in + function + | Var id -> + return Prec.Highest (Id.pp id) + | Con (id, []) -> + return Prec.Highest (Id.pp id) + | Con (id, [arg]) -> + let op arg = group @@ arg ^^ space ^^ Id.pp id in + rprefix Prec.Con op (p arg) + | Con (id, args) -> + let args = List.map args ~f:(runf p) in + let doc = + group + @@ Pp.parens (flow (comma ^^ break 1) args) + ^^ space ^^ Id.pp 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 (Pp.infixr (string "-> ")) (p l) (p r) + in + + runf p end module Pat = struct @@ -45,17 +82,50 @@ module Pat = struct - [C P] when [arg] is [Some P] *) | Constraint of t * Ty.t (** [(P : T)] *) - [@@deriving show {with_path= false}] + + module Prec = struct + type t = Or | Tuple | List | Construct | Highest [@@deriving enum] + let parens = Pp.parens + end + + let pp = + let open Pp.PrecedencePrinter (Prec) in + let rec p = + let open PPrint in + function + | Any -> + return Prec.Highest (char '_') + | Var id -> + return Prec.Highest (Id.pp id) + | Const x -> + return Prec.Highest (Const.pp x) + | Construct (I "::", Some (Tuple (l, r, []))) -> + rinfixr Prec.List (Pp.infixr (string ":: ")) (p l) (p r) + | Construct (id, Some arg) -> + rinfixr Prec.Construct (Pp.infixr empty) + (return Prec.Highest (Id.pp id)) + (p arg) + | Construct (id, None) -> + return Prec.Construct (Id.pp 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 (Pp.infixl (string "| ")) (p x) (p y) + | Constraint _ -> + return Prec.Highest (string "wip") + in + + runf p 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 +150,58 @@ 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}] + + module Prec = struct + type t = Open | Seq | Tuple | Apply | Highest [@@deriving enum] + let parens = Pp.parens + end + + let pp = + let open Pp.PrecedencePrinter (Prec) in + let rec p = + let open PPrint in + function + | Id id -> + return Prec.Highest (Id.pp id) + | Const x -> + return Prec.Highest (Const.pp x) + | Let (rec_flag, bindings, expr) -> + let rec_flag = + match rec_flag with Rec -> string " rec" | Nonrec -> empty + in + let expr = runf p expr in + + let bindings = + let docs = + List.map (List1.to_list bindings) ~f:(fun {pat; expr} -> + group @@ Pat.pp pat ^^ group (string " =" ^/^ runf p expr) ) + in + separate (break 1 ^^ string "and" ^^ break 1) docs + in + + let doc = + group @@ string "let" ^^ rec_flag + ^^ group (nest 2 (group (break 1) ^^ bindings) ^/^ string "in") + ^/^ expr + in + + return Prec.Open doc + | Tuple list2 -> + let op docs = group @@ flow (comma ^^ break 1) docs in + rinfixn Prec.Tuple op (List.map (List2.to_list list2) ~f:p) + | _ -> + return Prec.Highest (string "no way") + in + + runf p 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 +211,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..debabbb 100644 --- a/lib/ast/dune +++ b/lib/ast/dune @@ -1,8 +1,8 @@ (library (name LAst) (public_name NeML.Ast) - (libraries base LMisc) + (libraries base pprint LMisc) (preprocess - (pps ppx_deriving.show)) + (pps ppx_deriving.show ppx_deriving.enum)) (instrumentation (backend bisect_ppx))) diff --git a/lib/misc/LMisc.ml b/lib/misc/LMisc.ml index 8579c9c..d225dcb 100644 --- a/lib/misc/LMisc.ml +++ b/lib/misc/LMisc.ml @@ -10,27 +10,37 @@ open! Base (** Identifiers *) module Id = struct - type t = I of string [@@deriving show {with_path= false}] + type t = I of string + + let pp (I x) = + let open PPrint in + string x 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 + +module Pp = Pp diff --git a/lib/misc/dune b/lib/misc/dune index d3da2da..3ee5c89 100644 --- a/lib/misc/dune +++ b/lib/misc/dune @@ -1,7 +1,7 @@ (library (name LMisc) (public_name NeML.Misc) - (libraries base) + (libraries base pprint) (preprocess (pps ppx_deriving.show)) (instrumentation diff --git a/lib/misc/pp.ml b/lib/misc/pp.ml new file mode 100644 index 0000000..e8f3f53 --- /dev/null +++ b/lib/misc/pp.ml @@ -0,0 +1,72 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open PPrint + +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/misc/pp.mli b/lib/misc/pp.mli new file mode 100644 index 0000000..cc7fdf2 --- /dev/null +++ b/lib/misc/pp.mli @@ -0,0 +1,50 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2024, Andrei, PavlushaSource *) + +(** SPDX-License-Identifier: MIT *) + +[@@@ocaml.text "/*"] + +open! Base +open PPrint + +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/parse/LParse.ml b/lib/parse/LParse.ml index fa4ac9f..a2cb0f9 100644 --- a/lib/parse/LParse.ml +++ b/lib/parse/LParse.ml @@ -9,4 +9,4 @@ open! Base open Angstrom -let parse s = parse_string ~consume:All PStr.p s |> Result.ok +let parse s = parse_string ~consume:All PExpr.p s |> Result.ok diff --git a/lib/parse/LParse.mli b/lib/parse/LParse.mli deleted file mode 100644 index 10de7a0..0000000 --- a/lib/parse/LParse.mli +++ /dev/null @@ -1,12 +0,0 @@ -[@@@ocaml.text "/*"] - -(** Copyright 2024, Andrei, PavlushaSource *) - -(** SPDX-License-Identifier: MIT *) - -[@@@ocaml.text "/*"] - -open! Base -open LAst - -val parse : string -> structure option diff --git a/lib/parse/test/test.ml b/lib/parse/test/test.ml index dc7e779..6f5668f 100644 --- a/lib/parse/test/test.ml +++ b/lib/parse/test/test.ml @@ -7,861 +7,153 @@ [@@@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"))) }] }) - ] - |}] + Stdio.print_endline "syntax error" + | Some x -> + PPrint.ToChannel.pretty 1. 50 Stdio.stdout (Expr.pp x) + +(* let%expect_test _ = *) +(* run *) +(* {| 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 *) +(* {| *) + (* 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 *) +(* {|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 *) +(* {| *) + (* 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 *) +(* {|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 *) +(* {| *) + (* 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 *) +(* {|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 *) +(* {| *) + (* 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->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 -> 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 -> 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 -> 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 - {| 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) |} ; + {|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 (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 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 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")))))) - }, - []) - )) - ] - |}] + run {|let a = 1 and b=2 in b|} ; + [%expect {| let a = 1 and b = 2 in b |}] let%expect_test _ = run - {| let(*sus*)rec(*firstcomment*)f n = (* second comment *) (* third - comment*) n + 1 |} ; + {|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 {| - [(Let (Rec, - ({ pat = (Var (I "f")); - expr = - (Fun (((Var (I "n")), []), - (Apply ((Apply ((Id (I "+")), (Id (I "n")))), (Const (Int 1)))))) - }, - []) - )) - ] + 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 {| 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")))] |}]