From ffdcfd27893c383e5e3a82571123cfe03bd0f000 Mon Sep 17 00:00:00 2001 From: Aly Date: Tue, 9 Mar 2021 09:55:22 -0800 Subject: [PATCH] Make the pretty-printer cleaner for records --- pretty.ml | 36 +++++++++++++++++++ save_context.ml | 93 ++++++++++++++++++++++--------------------------- 2 files changed, 77 insertions(+), 52 deletions(-) diff --git a/pretty.ml b/pretty.ml index c20eadc..0b4f227 100644 --- a/pretty.ml +++ b/pretty.ml @@ -3,3 +3,39 @@ open import "prelude.ml" class pretty 'a begin val pretty : 'a -> int -> string end + +type prettyable = + | S : show 'a => 'a -> prettyable + | P : pretty 'a => 'a -> prettyable + +let dummy_pretty = pretty + +instance pretty prettyable begin + let pretty x w = + match x with + | S a -> show a + | P a -> dummy_pretty a w +end + +class prettyrecord 'r begin + val name : 'r -> string + val fields : 'r -> list (string * prettyable) +end + +instance prettyrecord 'a => pretty 'a begin + let pretty a w = + let rec smul s n = + if n <= 0 then + "" + else + s ^ (smul s (n - 1)) + let x = w + 2 + let prep = smul " " w + let rf = fields a + let rec field_str acc l = + match l with + | [] -> acc + | Cons ((name, field), xs) -> field_str (acc ^ prep ^ " " ^ name ^ " = " ^ (pretty field x) ^ ",\n") xs + let body = field_str "" rf + (name a) ^ " {\n" ^ body ^ prep ^ "}" +end diff --git a/save_context.ml b/save_context.ml index 5230d7d..e04669b 100644 --- a/save_context.ml +++ b/save_context.ml @@ -28,24 +28,19 @@ instance decode item_equips begin } end -instance pretty item_equips begin - let pretty (ItemEquips item_equips) w = - let rec smul s n = - if n <= 0 then - "" - else - s ^ (smul s (n - 1)) - let prep = smul " " w - let header = "ItemEquips {\n" - let button_item_b = header ^ prep ^ " button_item_b = " ^ (show item_equips.button_item_b) ^ ",\n" - let button_item_c_left = button_item_b ^ prep ^ " button_item_c_left = " ^ (show item_equips.button_item_c_left) ^ ",\n" - let button_item_c_down = button_item_c_left ^ prep ^ " button_item_c_down = " ^ (show item_equips.button_item_c_down) ^ ",\n" - let button_item_c_right = button_item_c_down ^ prep ^ " button_item_c_right = " ^ (show item_equips.button_item_c_right) ^ ",\n" - let button_slot_c_left = button_item_c_right ^ prep ^ " button_slot_c_left = " ^ (show item_equips.button_slot_c_left) ^ ",\n" - let button_slot_c_down = button_slot_c_left ^ prep ^ " button_slot_c_down = " ^ (show item_equips.button_slot_c_down) ^ ",\n" - let button_slot_c_right = button_slot_c_down ^ prep ^ " button_slot_c_right = " ^ (show item_equips.button_slot_c_right) ^ ",\n" - let equipment = button_slot_c_right ^ prep ^ " equipment = " ^ (show item_equips.equipment) ^ ",\n" - equipment ^ prep ^ "}" +instance prettyrecord item_equips begin + let name _ = "ItemEquips" + let fields (ItemEquips x) = + [ + ("button_item_b", S x.button_item_b), + ("button_item_c_left", S x.button_item_c_left), + ("button_item_c_down", S x.button_item_c_down), + ("button_item_c_right", S x.button_item_c_right), + ("button_slot_c_left", S x.button_slot_c_left), + ("button_slot_c_down", S x.button_slot_c_down), + ("button_slot_c_right", S x.button_slot_c_right), + ("equipment", S x.equipment) + ] end type save_context = SaveContext of { @@ -106,38 +101,32 @@ instance decode save_context begin } end -instance pretty save_context begin - let pretty (SaveContext save_context) w = - let rec smul s n = - if n <= 0 then - "" - else - s ^ (smul s (n - 1)) - let x = w + 2 - let prep = smul " " w - let header = "SaveContext {\n" - let entrance_index = header ^ prep ^ " entrance_index = " ^ (show save_context.entrance_index) ^ ",\n" - let link_age = entrance_index ^ prep ^ " link_age = " ^ (show save_context.link_age) ^ ",\n" - let cutscene_index = link_age ^ prep ^ " cutscene_index = " ^ (show save_context.cutscene_index) ^ ",\n" - let day_time = cutscene_index ^ prep ^ " day_time = " ^ (show save_context.day_time) ^ ",\n" - let night_flag = day_time ^ prep ^ " night_flag = " ^ (show save_context.night_flag) ^ ",\n" - let num_days = night_flag ^ prep ^ " num_days = " ^ (show save_context.num_days) ^ ",\n" - let claim_days = num_days ^ prep ^ " claim_days = " ^ (show save_context.claim_days) ^ ",\n" - let deaths = claim_days ^ prep ^ " deaths = " ^ (show save_context.deaths) ^ ",\n" - let n64dd_flag = deaths ^ prep ^ " n64dd_flag = " ^ (show save_context.n64dd_flag) ^ ",\n" - let health_capacity = n64dd_flag ^ prep ^ " health_capacity = " ^ (show save_context.health_capacity) ^ ",\n" - let health = health_capacity ^ prep ^ " health = " ^ (show save_context.health) ^ ",\n" - let magic_level = health ^ prep ^ " magic_level = " ^ (show save_context.magic_level) ^ ",\n" - let magic = magic_level ^ prep ^ " magic = " ^ (show save_context.magic) ^ ",\n" - let rupees = magic ^ prep ^ " rupees = " ^ (show save_context.rupees) ^ ",\n" - let sword_health = rupees ^ prep ^ " sword_health = " ^ (show save_context.sword_health) ^ ",\n" - let navi_timer = sword_health ^ prep ^ " navi_timer = " ^ (show save_context.navi_timer) ^ ",\n" - let magic_acquired = navi_timer ^ prep ^ " magic_acquired = " ^ (show save_context.magic_acquired) ^ ",\n" - let double_magic = magic_acquired ^ prep ^ " double_magic = " ^ (show save_context.double_magic) ^ ",\n" - let double_defense = double_magic ^ prep ^ " double_defense = " ^ (show save_context.double_defense) ^ ",\n" - let bgs_flag = double_defense ^ prep ^ " bgs_flag = " ^ (show save_context.bgs_flag) ^ ",\n" - let ocarina_game_reward = bgs_flag ^ prep ^ " ocarina_game_reward = " ^ (show save_context.ocarina_game_reward) ^ ",\n" - let child_equips = ocarina_game_reward ^ prep ^ " child_equips = " ^ (pretty save_context.child_equips x) ^ ",\n" - let adult_equips = child_equips ^ prep ^ " adult_equips = " ^ (pretty save_context.adult_equips x) ^ ", \n" - adult_equips ^ prep ^ "}" +instance prettyrecord save_context begin + let name _ = "SaveContext" + let fields (SaveContext x) = + [ + ("entrance_index", S x.entrance_index), + ("link_age", S x.link_age), + ("cutscene_index", S x.cutscene_index), + ("day_time", S x.day_time), + ("night_flag", S x.night_flag), + ("num_days", S x.num_days), + ("claim_days", S x.claim_days), + ("deaths", S x.deaths), + ("n64dd_flag", S x.n64dd_flag), + ("health_capacity", S x.health_capacity), + ("health", S x.health), + ("magic_level", S x.magic_level), + ("magic", S x.magic), + ("rupees", S x.rupees), + ("sword_health", S x.sword_health), + ("navi_timer", S x.navi_timer), + ("magic_acquired", S x.magic_acquired), + ("double_magic", S x.double_magic), + ("double_defense", S x.double_defense), + ("bgs_flag", S x.bgs_flag), + ("ocarina_game_reward", S x.ocarina_game_reward), + ("child_equips", P x.child_equips), + ("adult_equips", P x.adult_equips) + ] end