CC/typechecker_print.ml at master · RSAsterix/CC · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
open Printf
open Typechecker_types
open Format

let rec string_of_enum = function
	| [] -> ""
	| [e,None] -> e
	| (e,None)::rest -> e ^ " | " ^ (string_of_enum rest);;
(* meer is nog niet supported *)

let rec string_of_type = function
	| Var s -> sprintf "%s" s
	| Imp (t1,t2) -> sprintf "%s -> %s" (string_of_type t1) (string_of_type t2)
	| Tup (t1,t2) -> sprintf "(%s,%s)" (string_of_type t1) (string_of_type t2)
	| Lis t -> sprintf "[%s]" (string_of_type t)
	| Enum enum -> string_of_enum enum
	| Int -> sprintf "Int"
	| Bool -> sprintf "Bool"
	| Char -> sprintf "Char"
	| Void -> sprintf "Void";;

let print_subs out subs =
	let rec subs_print_help out = function
	| [] -> ()
	| [(x,nx)] -> fprintf out "%s |-> %s" x (string_of_type nx)
	| el::xs -> fprintf out "%a\n %a" subs_print_help [el] subs_print_help xs in
	fprintf out "[%a\n]" subs_print_help subs;;

let print_list list =
	let rec help = function
	| [] -> ""
	| [a] -> sprintf "%s" a
	| a::rest -> sprintf "%s, %s" a (help rest) in
	sprintf "forall (%s)," (help list);;

(* let print_env env =                                                            *)
(* 	let rec subs_print_help = function                                           *)
(* 	| [] -> ""                                                                   *)
(* 	| [el] ->                                                                    *)
(* 		(match el.bound with                                                       *)
(* 		| [] -> sprintf "%s |-> %s" el.id (string_of_type el.t)                    *)
(* 		| x -> sprintf "%s |-> %s %s" el.id (print_list x) (string_of_type el.t))  *)
(* 	| el::xs -> sprintf "%s\n %s" (subs_print_help [el]) (subs_print_help xs) in *)
(* 	sprintf "[%s\n]" (subs_print_help !env);;                                    *)

let prettyprint_env env =
	(* id :: type *)
	let print_variable (el : Env_var.elt) =
		sprintf "'%s' :: '%s'" el.id (string_of_type el.t) in

	let print_forall (list : SS.elt list) =
		(let rec helper = function
			| [] -> ""
			| [f] -> sprintf "%s" f
			| f::fs -> sprintf "%s, %s" f (helper fs) in
		match list with
		| [] -> ""
		| fs -> sprintf "forall (%s), " (helper fs)) in

	(* []? -> ""*)
	(* l?  -> \n var*)
	(* ls? -> \n var rest *)
	let print_locals (list : Env_var.elt list) =
		(let rec helper = function
  		| [] -> ""
  		| [l] -> sprintf "@;<0 2>%s" (print_variable l)
  		| l::ls -> sprintf "@;<0 2>%s%s" (print_variable l) (helper ls) in
		match list with
		| [] -> ""
		| ls -> sprintf "Locals:%s@," (helper ls)) in

	let print_function el =
		sprintf "%s :: %s%s@;<0 2>@[<v 0>%s@]" el.id (print_forall (SS.elements el.bound)) (string_of_type el.t) (print_locals (Env_var.elements el.locals)) in

	let varstring = ref "" in
	let vars v = Env_var.iter (fun el -> varstring := (sprintf "@[<v 0>%s@]@." (print_variable el)) ^ !varstring) v in

	let funstring = ref "" in
	let funs f = Env_fun.iter (fun el -> funstring := (sprintf "@[<v 0>%s@]@." (print_function el)) ^ !funstring) f in

	vars env.vars;
	funs env.funs;

	sprintf "%s\n%s" !varstring !funstring;;

let unexpected expected found =
	sprintf "Found type '%s' where type '%s' was expected." (string_of_type found) (string_of_type expected);;