1. camlspotter
  2. olfend

Source

olfend / ttypes.ml

(* name resolution of types *) 
open Spotlib.Spot

module R = Rawtype
open Types

let dt_search dtenv name = 
  match 
    Env.search (function Env.Typedecl _ -> true | _ -> false) 
      (Rawname.Path.of_ident (Rawname.Ident.create name)) 
      dtenv
  with
  | dtenv, path, Env.Typedecl decl -> dtenv, path, decl
  | _ -> assert false

module Type = struct
  open Type

  let of_raw_var env n =
    try List.assoc n env, env with Not_found -> 
      let v = create_var () in
      v, (n,v)::env
  
  let of_raw_vars env ns = 
    List.fold_right (fun n (tys, env) ->
      let ty, env = of_raw_var env n in
      ty::tys, env) ns ([], env)
  
  let rec of_raw dtenv env = function
    | R.Var n -> 
        let res, env = of_raw_var env n in
        res, dtenv, env
    | R.Arrow (t1, t2) ->
        let t1, dtenv, env = of_raw dtenv env t1 in
        let t2, dtenv, env = of_raw dtenv env t2 in
        Arrow (t1, t2), dtenv, env
    | R.Tuple ts ->
        let rev_ts, dtenv, env = List.fold_left (fun (rev_ts,dtenv,env) t -> 
          let t, dtenv, env = of_raw dtenv env t in t::rev_ts, dtenv, env) ([],dtenv,env) ts in
        Tuple (List.rev rev_ts), dtenv, env
    | R.Constr (p, ts) ->
        let dtenv, p, desc = try dt_search dtenv p with Not_found -> failwithf "Data type %s is not found" p 
        in
        let rev_ts, dtenv, env = List.fold_left (fun (rev_ts,dtenv,env) t -> 
          let t, dtenv, env = of_raw dtenv env t in t::rev_ts, dtenv, env) ([],dtenv,env) ts in
        Constr (p, desc, List.rev rev_ts), dtenv, env
  
  let of_raws dtenv env rts = 
    List.fold_right (fun rty (tys, dtenv, env) ->
      let ty, dtenv, env = of_raw dtenv env rty in
      ty::tys, dtenv, env) rts ([], dtenv, env)
    
end

module Poly = struct

  let of_raw dtenv (R.Poly.Poly (rvars, t)) = 
    let rev_vars, env = List.fold_left (fun (rev_vars, env) var ->
      let var, env = Type.of_raw_var env var in
      var :: rev_vars, env) ([], []) rvars
    in
    let t, dtenv, env = with_level (-1) & fun () -> Type.of_raw dtenv env t in
    Poly (List.rev (List.map (function Var (n,_lev) -> n | _ -> assert false) rev_vars), t), dtenv, env
  
end
  
module Decl = struct
  module R = Rawtype.Decl

  (* CR jfuruse: we must check the newly introduced tyvars *)
  (* CR jfuruse: we must check the recursive uses of types do not have complex parameters *)
  let of_raw_kind dtenv env = function
    | R.Variant constrs ->
        begin match List.is_unique fst constrs with
        | None ->
            let constrs, dtenv = 
              List.fold_right (fun (name, rtargs) (res, dtenv) ->
                let targs, dtenv, _ = Type.of_raws dtenv env rtargs in
                (Ident.create name, targs) :: res, dtenv) constrs ([], dtenv)
            in
            Variant constrs, dtenv
        | Some ((c, _), _) ->
            failwithf "Constructor %s is used twice" c
        end
    | R.Record fields ->
        begin match List.is_unique fst fields with
        | None ->
            let fields, dtenv = 
              List.fold_right (fun (name, ty) (res, dtenv) ->
                let field, dtenv, _ = Type.of_raw dtenv env ty in
                (Ident.create name, field)::res, dtenv) fields ([], dtenv)
            in
            Record fields, dtenv
        | Some ((f,_), _) ->
            failwithf "Field %s is used twice" f
        end
    | R.Alias ty -> 
        let ty, dtenv, _ = Type.of_raw dtenv env ty in
        Alias ty, dtenv
    | R.Abstract -> Abstract, dtenv
        
  let of_raw dtenv rd = 
    (* Format.eprintf "%a@." Sexplib.Sexp.pp_hum (R.sexp_of_t rd); *)
    let params, env = with_level (-1) & fun () -> Type.of_raw_vars [] rd.R.params in
    let params = List.map (function
      | Var (n,_) -> n
      | _ -> assert false) params
    in
    match List.is_unique (fun x -> x) params with
    | Some (_var, _) -> failwithf "The same type variable used twice in data type parameters" 
    | None -> 
        (* id must be already defined *)
        let id = match 
            let _, path, _ = dt_search dtenv rd.R.name in path 
          with
          | Path.Ident id -> id
          | _ -> assert false
        in
        let kind, dtenv = of_raw_kind dtenv env rd.R.kind in
        { name   = id;
          params = params;
          kind   = kind 
        }, 
        dtenv
  
  let of_raws dtenv rds =
    (* 1st path. enrich dtenv for recursion *)
    match List.is_unique (fun rd -> rd.R.name) rds with
    | Some (rd, _) -> failwithf "duplicated type definition of %s" rd.R.name
    | None ->
        let ext = 
          List.map (fun rd -> 
            let ident = Ident.create rd.R.name in
            let decl = { name = ident; 
                         params = []; (* CR jfuruse: must check GADT issue *)
                         kind = Rec }
            in
            ident, Path.of_ident ident, Env.Typedecl decl) rds 
        in
        let dtenv = { dtenv with Env.vars = ext @ dtenv.Env.vars } in
        List.fold_right (fun rd (rds, dtenv) -> 
          let rd, dtenv = of_raw dtenv rd in
          rd::rds, dtenv) rds ([],dtenv)

end