From 264311804538a1d7ddc28b0fe55819ddda165ca3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Th=C3=A9ophile=20Bastian?= <contact@tobast.fr>
Date: Thu, 15 Feb 2018 22:01:46 +0100
Subject: [PATCH] Add pretty printer for Top

---
 src/Main.ml                |  1 +
 src/prettify/PrettyTop.ml  | 59 ++++++++++++++++++++++++++++++++++++++
 src/prettify/PrettyTop.mli |  1 +
 3 files changed, 61 insertions(+)
 create mode 100644 src/prettify/PrettyTop.ml
 create mode 100644 src/prettify/PrettyTop.mli

diff --git a/src/Main.ml b/src/Main.ml
index eed0b13..0b9badb 100644
--- a/src/Main.ml
+++ b/src/Main.ml
@@ -90,6 +90,7 @@ let process filename =
   |> dump "PrettyTail" PrettyTail.show
   |> Defun.defun_term
   |> dump "Top" Top.show_program
+  |> dump "PrettyTop" PrettyTop.show
   |> Finish.finish_program
   |> dump "C" C.show_program
   |> output
diff --git a/src/prettify/PrettyTop.ml b/src/prettify/PrettyTop.ml
new file mode 100644
index 0000000..3501637
--- /dev/null
+++ b/src/prettify/PrettyTop.ml
@@ -0,0 +1,59 @@
+module S = Top
+open PrettyCommon
+
+let fmt_tag fmt tag = Format.fprintf fmt "%d" tag
+
+let fmt_block fmt (S.Con(tag, args)) =
+    Format.fprintf fmt "Block[%a](%a)"
+        fmt_tag tag
+        fmt_vals args
+
+let rec fmt_term fmt (term: S.term) = match term with
+| S.Exit -> Format.fprintf fmt "Exit"
+| S.TailCall (fct, args) ->
+        Format.fprintf fmt "Call %a %a"
+            fmt_var fct
+            fmt_vals args
+| S.Print (value, next) ->
+        Format.fprintf fmt "Print %a@ %a"
+            fmt_val value
+            fmt_term next
+| S.LetVal (name, value, next) ->
+        Format.fprintf fmt "@[<v 4>letv %a = %a in@]@ %a"
+            fmt_var name
+            fmt_val value
+            fmt_term next
+| S.LetBlo (name, block, next) ->
+        Format.fprintf fmt "@[<v 4>let %a = %a in@]@ %a"
+            fmt_var name
+            fmt_block block
+            fmt_term next
+| S.Swi (value, branches) ->
+        Format.fprintf fmt "@[<v 4>switch(%a)" fmt_val value ;
+        List.iter
+            (fun branch -> Format.fprintf fmt "@ %a" fmt_branch branch)
+            branches ;
+        Format.fprintf fmt "@]"
+
+and fmt_branch fmt (S.Branch (tag, args, body)) =
+    Format.fprintf fmt "@[<v 4>Case %a [%a]:@ %a@]"
+        fmt_tag tag
+        fmt_vars args
+        fmt_term body
+
+let fmt_function fmt (S.Fun(name, args, body)) =
+    Format.fprintf fmt "@[<v 4>Fun %a %a =@ %a@]"
+        fmt_var name
+        fmt_vars args
+        fmt_term body
+
+let fmt_program fmt (S.Prog(funcs, body)) =
+    Format.fprintf fmt "@[<v 0>" ;
+    List.iter
+        (fun fct ->
+            Format.fprintf fmt "%a@ @ " fmt_function fct)
+        funcs ;
+    Format.fprintf fmt "%a@ @]" fmt_term body
+
+let show (prog: S.program) =
+    Format.asprintf "%a" fmt_program prog
diff --git a/src/prettify/PrettyTop.mli b/src/prettify/PrettyTop.mli
new file mode 100644
index 0000000..a73b982
--- /dev/null
+++ b/src/prettify/PrettyTop.mli
@@ -0,0 +1 @@
+val show: Top.program -> string