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,54 @@ 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 (pat, ty) ->
+          let pat = runf p pat in
+          let ty = Ty.pp ty in
+
+          let doc = Pp.parens @@ pat ^/^ string ": " ^^ ty in
+          return Prec.Highest doc
+    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 +154,139 @@ 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 pcase left right =
+    let open PPrint in
+    group @@ left ^^ string " ->" ^^ group (nest 2 (break 1 ^^ right))
+
+  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 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 expr = runf p expr in
+
+          let doc =
+            group @@ string "let" ^^ rec_flag
+            ^^ group (nest 2 (group (break 1) ^^ bindings) ^/^ string "in")
+            ^/^ expr
+          in
+          return Prec.Open doc
+      | Fun (args, expr) ->
+          let args = List.map (List1.to_list args) ~f:Pat.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 (Pat.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 (Pat.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 (Id.pp id)
+      | Construct (id, Some arg) ->
+          rinfixl Prec.Apply (Pp.infixl empty)
+            (return Prec.Highest (Id.pp id))
+            (p arg)
+      | Constraint (expr, ty) ->
+          let pat = runf p expr in
+          let ty = Ty.pp ty in
+
+          let doc = Pp.parens @@ pat ^/^ string ": " ^^ ty in
+          return Prec.Highest doc
+    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 +296,61 @@ 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}]
+
+  let pp =
+    let open PPrint in
+    function
+    | Eval expr ->
+        Expr.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 @@ Pat.pp pat ^^ group (string " =" ^/^ Expr.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 = Id.pp id in
+        let params =
+          let pparam id = string "'" ^^ Id.pp id in
+
+          match params with
+          | [] ->
+              empty
+          | [id] ->
+              pparam id ^^ space
+          | _ ->
+              let params = List.map params ~f:pparam in
+              Pp.parens (flow (comma ^^ break 1) params) ^^ space
+        in
+
+        let variants =
+          List.map variants ~f:(fun {id; arg} ->
+              group @@ Id.pp id
+              ^^ optional
+                   (fun ty -> string " of" ^^ nest 2 (break 1 ^^ Ty.pp ty))
+                   arg )
+        in
+
+        group @@ string "type"
+        ^^ group (break 1)
+        ^^ params ^^ id ^^ string " ="
+        ^^ group
+             ( break 1
+             ^^ ifflat empty (string "| ")
+             ^^ separate (break 1 ^^ string "| ") variants )
 end
 
-type structure = StrItem.t list [@@deriving show {with_path= false}]
+type structure = StrItem.t list
+
+let pp_structure str =
+  let open PPrint in
+  let str = List.map str ~f:(fun item -> StrItem.pp item) in
+  flow (string ";;" ^^ twice hardline) str

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