(*************************************************)
(* Interpréteur en appel par nom, qui utilse     *)
(* non pas des glaçons comme ceux du cours, mais *)
(* des glaçons du langage hôte.                  *)
(*************************************************)

(* Source inter_cbn.ml *)

(***********************************)
(* Signature du module des glaçons *)
(***********************************)

module type Thunk = sig

  type 'a t

  val create : (unit -> 'a) -> 'a t
  (** Créer un glaçon.

     À cause de l'appel par valeur de Caml
     il est impossible de passer le terme (Caml) directement.
     Par exemple :
       create (fun () -> fib 20)
     et non  pas :
       create (fib 20).

    Pour ce qui est de l'intepréteur, c'est l'appel récursif à
    l'intepréteur qui sera retardé. Voir ici.
  **)

  val force : 'a t -> 'a
  (* Dégeler un glaçon *)
end

(********************************************************)
(* Glaçons codés comme des fonctions de type unit -> 'a *)
(********************************************************)

module Thunk : Thunk = struct

  type 'a t = unit -> 'a

  let create f = f

  let force f = f ()

end

(***********************************************************)
(* Glaçons de la  bibliothèque Caml                        *)
(* Ils ont la propriété que le premier force               *)
(* dégèle le glaçon et remplace le glacon par le résultat. *)
(* L'effet est que le calcul du résultat est effectué au   *)
(* plus une fois. Voir Lazy.                               *)
(***********************************************************)

module StdLazy : Thunk = struct

  type 'a t = 'a Lazy.t

  let create f = lazy (f ())

  let force = Lazy.force

end

(*************************************************************)
(* Et d'ailleurs voici un  module MyLazy qui fait à peu près *)
(* la même chose à l'aide des références de Caml.            *)
(*************************************************************)

module MyLazy : Thunk = struct

  type 'a intern = Forced of 'a | NotForced of (unit -> 'a)
  (* État interne *)

  type 'a t = ('a intern) ref

  let create f = ref (NotForced f)

  let force thk = match !thk with
  | Forced v -> v
  | NotForced f ->
      let v = f () in
      thk := Forced v ;
      v

end

(********************************************************************)
(* Interpréteur proprement dit, paramétré par un module des glaçons *)
(********************************************************************)


module Make(Thunk:Thunk) = struct

  open Pcf
  open S
  open Ast

  type value = Num_v of int | Clo_v of string * t * env
  and thunk =  value Thunk.t
  and env = (string * thunk) list

  open Printf

  let print_value chan v = match v with
  | Num_v i -> fprintf chan "%i" i
  | Clo_v _ -> fprintf chan "<fun>"

  exception Error of string

  let find env x =
    try List.assoc x env
    with Not_found -> raise (Error ("variable: "^x^" undefined"))

  let rec inter env t = match t with
  (* Les valeurs *)
  | Num i -> Num_v i
  | Fun (x,t) -> Clo_v (x,t,env)
  (* Dégeler le glaçon *)
  | Var x -> Thunk.force (find env x)
  (* Rien de bien remarquable *)
  | Op (op,t1,t2) ->
      let n1 = inter_int env t1 in
      let n2 = inter_int env t2 in
      Num_v (Op.to_fun op n1 n2)
  | Ifz (t1,t2,t3) ->
      let v1 = inter_int env t1 in
      inter env (if v1 = 0 then t2 else t3)
(* Noter que les arguments sont traités par une fct 'arg' *)
  | Let (x,t1,t2) ->
      inter ((x,arg env t1)::env) t2
  | App (t1,t2) ->
      let x,t_clo,e_clo = inter_clo env t1 in
      inter ((x,arg env t2)::e_clo) t_clo
  | Fix (f,t) as fix -> inter ((f, arg env fix)::env) t

  and arg env t = match t with
(* Si l'argument est une variable, l'environnement
   lui associe déjà un glaçon. Inutile d'en fabriquer un autre. *)
  | Var x -> find env x
(* Toute l'astuce est ici.
   Le glaçon encapsule un appel à l'interpréteur, qui ne sera
   effectué que lorsque le glaçon est dégelé. *)
  | _ -> Thunk.create (fun () -> inter env t)

  and inter_int env t = match inter env t with
  | Num_v i -> i
  | Clo_v _ -> raise (Error "Int expected, got Clo")

  and inter_clo env t = match inter env t with
  | Clo_v (x,t,e) -> (x,t,e)
  | Num_v _ -> raise (Error "Clo expected, got Int")

  let print_thunk chan thk = print_value chan (Thunk.force thk)

  let loop () =
    S.Top.loop print_thunk
      (fun env t ->
        let v = inter env t in
        Thunk.create (fun () -> v))

end



module Inter = Make(MyLazy)
(* On peut remplacer MyLazy ci-dessus par Thunk ou StdLazy. *)

let () = Inter.loop ()