Source

olfend / env.ml

Full commit
(* typing environment *)
(* CR jfuruse: Name crash with Vm.Env, probably confusing *)

open Spotlib.Spot
open Sexplib.Conv
open Types
open Vmmisc (* for Digest.t *)

type desc =
  | Value    of Poly.t
  | Constr   of Tag.t * Poly.t                   (** constructors *)
  | Field    of Tag.t * Path.t * Decl.t * Type.t (** record field accessors *)
  | Module   of signature * t
  | Typedecl of Types.decl

and vars = (Ident.t * Path.t * desc) list

and t = { vars : vars;
          globals : (Ident.t * Digest.t) list (** module availabe in file system *)
        }

with sexp

module Ppr = struct
  open Treeprint.Printer

  let rec ppr_desc = function
    | Value pty -> string ":" ++ space ++ Poly.ppr pty
    | Constr (tag, pty) -> string "constr(" ++ Tag.ppr tag ++ string ") : " ++ Poly.ppr pty
    | Field (tag, path, decl, ty) -> 
        string "field(" ++ Tag.ppr tag ++ string ", " 
                        ++ Path.ppr path ++ string ", " 
                        ++ Ident.ppr decl.name ++ string ") : " 
        ++ Type.ppr ty
    | Module (_sg, t) -> string ":" ++ space ++ box 0 (ppr t)
    | Typedecl decl -> string "= " ++ box 2 (string "type " ++ Decl.ppr decl)

  and ppr_vars vars = 
    box 0 (list 1.0 (string ";" ++ space ++ cut)
             (List.map (fun (id, path, desc) ->
               box 2 (Ident.ppr id ++ string " : " ++ Path.ppr path ++ space ++ cut ++
                        ppr_desc desc)) vars))

  and ppr env = 
    vbox 0 (ppr_vars env.vars ++ space ++ cut (* break *) ++ string "globals= " ++ list 0.0 (string ";" ++ space ++ cut) (List.map (fun (id, md5) -> Ident.ppr id ++ string " : " ++ string md5) env.globals))
end

include Ppr

(** prepare env extension for variant data type *)
let variant_constructors decl = match decl.kind with
  | Variant constrs ->
      let p = Path.of_ident decl.name in
      List.rev (List.mapi (fun tag (id, tyargs) -> 
        let pty = 
          Poly (decl.params, 
                Type.create_arrows tyargs 
                  (Types.Constr (p, decl, 
                                 List.map (fun x -> Types.Var (x,-1)) decl.params)))
        in
        id, 
        Path.Dot (p, id, -1 (* no real value *)), 
        Constr (Tag.of_int tag, pty)) constrs)
  | _ -> assert false


(** prepare env extension for record data type *)
let record_accessors decl = match decl.kind with
  | Record fields ->
      let p = Path.of_ident decl.name in
      List.rev (List.mapi (fun tag (id, tyarg) -> 
        id, 
        Path.of_ident id, 
         Field (Tag.of_int tag, p, decl, tyarg)) fields)
  | _ -> assert false

let decl_pseudo_values decl = match decl.kind with
  | Variant _ -> variant_constructors decl
  | Record _ -> record_accessors decl
  | Abstract | Alias _ -> []
  | Rec -> assert false

(** create the poly type of a record accessor *)
(* CR jfuruse: why accessor is treated strangely? Field should have this information! *)
let record_accessor_poly_type p decl rty =
  Types.Poly (decl.params, 
        Type.create_arrows [Types.Constr (p, decl, List.map (fun x -> Types.Var (x,-1)) decl.params)] rty)

(* Create an environment of signature [sg] ad a path [as_path] *)
let of_signature as_path sg =
  let tbl = Sig.object_entry_table sg in

  let of_decl_vals decl = 
    List.map (fun (id, path, desc) ->
      let localize_desc = function
        | Constr (tag, pty) -> Constr (tag, Poly.localize as_path pty)
        | Field (tag, p, decl, ty) -> Field (tag, Path.localize as_path [] p, Decl.localize as_path decl, Type.localize as_path ty)
        | _ -> assert false
      in
      Ident.recreate id, Path.localize as_path [] path, localize_desc desc
      ) (decl_pseudo_values decl)
  in

  let of_sigitem = function
    | Types.Value (id, pty) -> 
        [ Ident.recreate id, Path.Dot (as_path, id, List.assoc id tbl), Value (Poly.localize as_path pty) ]
    | Types.Type decls -> 
        List.concat_map (fun decl ->
          let decl = Decl.localize as_path decl in
          ( Ident.recreate decl.name, 
            Path.Dot (as_path, decl.name, -1 (* no object *)),
            Typedecl decl )
          :: of_decl_vals decl
            
        ) decls
  in
  { vars = List.concat_map of_sigitem sg; globals = [] } 

let search_vars_by_name p s : vars -> (Ident.t * Path.t * desc) option = 
  let rec search = function
    | (id,_,desc as elem)::_ when s = Ident.name id && p desc -> 
        Some elem
    | _::xs -> search xs
    | [] -> None
  in 
  search

(* pos has no meaning if the env is not a sig *)
let load_external_module s = 
  try
    let id = Ident.create_with_stamp s (-1) in
    let path = Path.of_ident id in
    let name = String.lowercase s in
    let sg, checksum = Sig.load (name ^ Filepath.ext_signature) in
    Some (id, path, Module (sg, of_signature path sg), checksum)
  with
  | _ -> None

let search_vars_by_ident id : vars -> (Path.t * desc) option = 
  let rec search = function
    | [] -> None
    | (ident, path, desc)::_ when ident = id -> Some (path, desc)
    | _::xs -> search xs
  in
  search

let rec search p s t = match s with
  | Rawname.Path.Ident s ->
      begin match search_vars_by_name p s t.vars with
      | Some (_id, path, desc) -> t, path, desc
      | None ->
            (* It may be global module *)
            match s.[0] with
            | 'A'..'Z' ->
                begin match load_external_module s with
                | Some (id, path, desc, checksum) ->
                    Format.eprintf "Adding global %a@." Path.format path;
                    { vars = t.vars @ [id,path,desc]; globals = (id, checksum) :: t.globals },
                    path, desc
                | None -> failwithf "Global module not found: %s" s
                end
            | _ -> failwithf "Symbol not found: %s" s
      end
  | Rawname.Path.Dot (mdl, s) ->
      let t, _path, desc = search (function Module _ -> true | _ -> false) mdl t in
      match desc with
      | (Value _ | Constr _ | Field _ | Typedecl _ ) -> assert false
      | Module (_sg, env) ->
          match search_vars_by_name p s env.vars with
          | Some (_id', path, desc) -> t, path, desc
          | None -> assert false