Make the pretty-printer cleaner for records
This commit is contained in:
parent
31f9808a93
commit
ffdcfd2789
2 changed files with 77 additions and 52 deletions
36
pretty.ml
36
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue