(*============================================================================*)
(*== UE Conception de Langages -- Octobre 2006                              ==*)
(*============================================================================*)
(*== Fichier: lb_type.ml                                                    ==*)
(*== ---------------------------------------------------------------------- ==*)
(*==  Syntaxe absraite des lambda termes étendus                            ==*)
(*==  Avec valeurs numeriques, booleennes, chaines de caracteres, paires    ==*)
(*==  Avec operateurs predefinis                                            ==*)
(*==  Définition de la table des opérateurs                                  ==*)
(*==                                                                        ==*)
(*============================================================================*)

type lterm =
    LBD of string list * lterm
  | APP of lterm list
  | VAR of string 

  | NIL
  | FST
  | SND
  | PAIR of lterm * lterm

  | QUOTE of lterm

  | OP of string

  | ALT
  | REC of string * lterm

  | SYM of string

  | NUM of int
  | STR of string
  | BOOL of bool


(*== Vers une syntaxe concrete absconse                                       *)
let of_bool b =
  if b then "TRUE" else "FALSE"

let rec to_string t =
  match t with
    LBD(xs, t)
    -> Printf.sprintf"[%s] %s" 
	(String.concat " " xs) 
	(to_string t)
  | APP ts
    -> Printf.sprintf"(%s)" (to_strings ts)
  | VAR x -> x

  | NIL -> "<>"
  | FST -> "<:"
  | SND -> ":>"
  | PAIR(t1,t2) 
    -> Printf.sprintf"<%s.%s>" (to_string t1) (to_string t2)

  | QUOTE t1 -> Printf.sprintf"'%s" (to_string t1)

  | OP x -> x

  | ALT -> "?"
  | REC(f,t) -> Printf.sprintf"!%s %s" f (to_string t)

  | SYM x -> x

  | NUM n -> string_of_int n
  | STR x -> Printf.sprintf"\"%s\"" x
  | BOOL b -> String.uppercase (string_of_bool b)

and to_strings ts =
  (String.concat " " (List.map to_string ts))

(*== Opérateurs prédéfinis                                                    *)
(*-- Table des opérateurs                                                     *)
let op_tab = Hashtbl.create 107

(*-- Prédicat: être un opérateur                                              *)
let is_op op = Hashtbl.mem op_tab op

(*-- Exception: erreur d'application (arité ou type)                          *)
exception Op_failure of string
;;

let op_failwith op args =
  raise (Op_failure (to_string (APP((OP op)::args))))
;;

(*-- Liste de opérateurs et fonctions associées                               *)
let op_list =
[
 "PAIR?",
 (function [PAIR _] -> BOOL true | _ -> BOOL false);

 "NIL?",
 (function [NIL] -> BOOL true | _ -> BOOL false);

 "AND",
 (function [BOOL v1;BOOL v2] -> BOOL(v1 & v2)
   | ts -> op_failwith "AND" ts);

 "OR",
 (function [BOOL v1;BOOL v2] -> BOOL(v1 or v2)
   | ts -> op_failwith "OR" ts);

 "NOT",
 (function [BOOL v] -> BOOL(not v)
   | ts -> op_failwith "NOT" ts);

 "EQ?",
 (function [v1;v2] -> BOOL(v1 = v2)
   | ts -> op_failwith "EQ" ts);

 "LE?",
 (function [v1;v2] -> BOOL(v1 <= v2)
   | ts -> op_failwith "LT?" ts);

 "LT?",
 (function [v1;v2] -> BOOL(v1 < v2)
   | ts -> op_failwith "LT?" ts);

 "GE?",
 (function [v1;v2] -> BOOL(v1 >= v2)
   | ts -> op_failwith "GT?" ts);

 "GT?",
 (function [v1;v2] -> BOOL(v1 > v2)
   | ts -> op_failwith "GT?" ts);

 "ADD",
 (function [NUM n1;NUM n2] -> NUM(n1+n2)
   | ts -> op_failwith "ADD" ts);

 "MUL",
 (function [NUM n1;NUM n2] -> NUM(n1*n2)
   | ts -> op_failwith "MUL" ts);

 "SUB",
 (function [NUM n1;NUM n2] -> NUM(n1-n2)
   | ts -> op_failwith "SUB" ts);

 "DIV",
 (function [NUM n1;NUM n2] -> NUM(n1/n2)
   | ts -> op_failwith "DIV" ts);

 "PRINT",
 (let rec loop ts =
   match ts with
     [] -> NIL
   | (NUM n)::ts -> print_int n; loop ts
   | (STR s)::ts -> print_string s; loop ts
   | _ -> op_failwith "PRINT" ts
  in
   function ts -> loop ts)
]
;;

(*-- Construction de la table des opérateurs                                  *)
List.iter (fun (op, fn) -> Hashtbl.add op_tab op fn) op_list
;;