WIP

NeML.opam

@@ -17,6 +17,7 @@ depends: [
   "ocaml"
   "dune" {>= "3.15"}
   "base"
+  "pprint"
   "stdio"
   "angstrom"
   "ppx_deriving"

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))

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

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)))

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

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

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

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

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