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,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 +48,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 | Other [@@deriving enum]
+  end
+
+  let pp =
+    let open PrecedencePrinter (Prec) in
+    let rec p =
+      let open PPrint in
+      function
+      | Any ->
+          return Prec.Other (char '_')
+      | Var x ->
+          return Prec.Other (Id.pp x)
+      | Const x ->
+          return Prec.Other (Const.pp x)
+      | Construct (I "::", Some (Tuple (hd, tl, []))) ->
+          let op l r = group @@ l ^^ group (break 1 ^^ string ":: ") ^^ r in
+          pinfixr Prec.List op (p hd) (p tl)
+      | Construct (id, Some arg) ->
+          let op id arg = group @@ id ^^ group (break 1) ^^ arg in
+          pinfixr Prec.Construct op (return Prec.Other (Id.pp id)) (p arg)
+      | Construct (id, None) ->
+          return Prec.Construct (Id.pp id)
+      | Tuple (fst, snd, tl) ->
+          let op docs = group @@ flow (comma ^^ break 1) docs in
+          pinfixn Prec.Tuple op (List.map ~f:p (fst :: snd :: tl))
+      | Or (x, y) ->
+          let op l r = group @@ l ^^ group (break 1 ^^ string "| " ^^ r) in
+          pinfixl Prec.Or op (p x) (p y)
+      | _ ->
+          return Prec.Other (string "wip")
+    in
+
+    fun x -> run (p x)
 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 +116,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 +133,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,118 @@ 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 PrecedencePrinter (Prec : sig
+  type t
+  val min : int
+  val to_enum : t -> int
+end) : sig
+  open PPrint
+
+  type 'a t
+
+  val run : document t -> document
+
+  val return : Prec.t -> document -> document t
+
+  val pprefix : Prec.t -> (document -> document) -> document t -> document t
+
+  val pinfixl :
+       Prec.t
+    -> (document -> document -> document)
+    -> document t
+    -> document t
+    -> document t
+
+  val pinfixr :
+       Prec.t
+    -> (document -> document -> document)
+    -> document t
+    -> document t
+    -> document t
+
+  val pinfixn :
+    Prec.t -> (document list -> document) -> document t list -> document t
+end = struct
+  type 'a t = Prec of (int -> 'a)
+
+  let run' (Prec f) = f
+  let run (Prec f) = f Prec.min
+
+  let ( let* ) p f = Prec (fun lvl -> run' (f (run' p lvl)) lvl)
+
+  let cur_lvl = Prec Fn.id
+
+  let pure x = Prec (fun _ -> x)
+
+  let parens p =
+    let open PPrint in
+    group @@ align @@ char '(' ^^ align (break 0 ^^ p) ^^ break 0 ^^ char ')'
+
+  let return' lvl doc =
+    let* cur = cur_lvl in
+    pure @@ if cur > lvl then parens doc else doc
+
+  let return lvl = return' (Prec.to_enum lvl)
+
+  let with_lvl lvl p = pure @@ run' p lvl
+
+  let pprefix lvl op p =
+    let lvl = Prec.to_enum lvl in
+    let* doc = with_lvl (lvl + 1) p in
+    return' lvl (op doc)
+
+  let pinfixl 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 pinfixr 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 pinfixn 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/dune

@@ -1,7 +1,7 @@
 (library
  (name LMisc)
  (public_name NeML.Misc)
- (libraries base)
+ (libraries base pprint)
  (preprocess
   (pps ppx_deriving.show))
  (instrumentation

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 PPat.p s |> Result.ok

lib/parse/LParse.mli

@@ -9,4 +9,4 @@
 open! Base
 open LAst
 
-val parse : string -> structure option
+val parse : string -> Pat.t option