viewcvs.cgi/typing/typer.ml

(* I. Transform the abstract syntax of types and patterns into
      the internal form *)

open Location
open Ast

exception Pattern of string
exception NonExhaustive of Types.descr
exception MultipleLabel of Types.label
exception Constraint of Types.descr * Types.descr * string
exception ShouldHave of Types.descr * string
exception WrongLabel of Types.descr * Types.label

let raise_loc loc exn = raise (Location (loc,exn))

(* Internal representation as a graph (desugar recursive types and regexp),
   to compute freevars, etc... *)

type ti = {
  id : int; 
  mutable loc' : loc;
  mutable fv : string SortedList.t option; 
  mutable descr': descr;
  mutable type_node: Types.node option;
  mutable pat_node: Patterns.node option
} 
and descr =
   [ `Alias of string * ti
   | `Type of Types.descr
   | `Or of ti * ti
   | `And of ti * ti
   | `Diff of ti * ti
   | `Times of ti * ti
   | `Arrow of ti * ti
   | `Record of Types.label * bool * ti
   | `Capture of Patterns.capture
   | `Constant of Patterns.capture * Types.const
   ]
    

module S = struct type t = string let compare = compare end
module StringMap = Map.Make(S)
module StringSet = Set.Make(S)

let mk' =
  let counter = ref 0 in
  fun loc ->
    incr counter;
    let rec x = { 
      id = !counter; 
      loc' = loc; 
      fv = None; 
      descr' = `Alias ("__dummy__", x);  
      type_node = None; 
      pat_node = None 
    } in
    x

let cons loc d =
  let x = mk' loc in
  x.descr' <- d;
  x
    
(* Note:
   Compilation of Regexp is implemented as a ``rewriting'' of
   the parsed syntax, in order to be able to print its result
   (for debugging for instance)
   
   It would be possible (and a little more efficient) to produce
   directly ti nodes.
*)
    
module Regexp = struct
  let memo = Hashtbl.create 51
  let defs = ref []
  let name =
    let c = ref 0 in
    fun () ->
      incr c;
      "#" ^ (string_of_int !c)

  let rec seq_vars accu = function
    | Epsilon | Elem _ -> accu
    | Seq (r1,r2) | Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2
    | Star r | WeakStar r -> seq_vars accu r
    | SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r

  let rec propagate vars = function
    | Epsilon -> `Epsilon
    | Elem x -> `Elem (vars,x)
    | Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)
    | Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)
    | Star r -> `Star (propagate vars r)
    | WeakStar r -> `WeakStar (propagate vars r)
    | SeqCapture (v,x) -> propagate (StringSet.add v vars) x

  let cup r1 r2 = 
    match (r1,r2) with
      | (_, `Empty) -> r1
      | (`Empty, _) -> r2
      | (`Res t1, `Res t2) -> `Res (mk noloc (Or (t1,t2)))

  let rec compile fin e seq : [`Res of Ast.ppat | `Empty] = 
    if List.mem seq e then `Empty
    else 
      let e = seq :: e in
      match seq with
        | [] ->
            `Res fin
        | `Epsilon :: rest -> 
            compile fin e rest
        | `Elem (vars,x) :: rest -> 
            let capt = StringSet.fold
                         (fun v t -> mk noloc (And (t, (mk noloc (Capture v)))))
                         vars x in
            `Res (mk noloc (Prod (capt, guard_compile fin rest)))
        | `Seq (r1,r2) :: rest -> 
            compile fin e (r1 :: r2 :: rest)
        | `Alt (r1,r2) :: rest -> 
            cup (compile fin e (r1::rest)) (compile fin e (r2::rest))
        | `Star r :: rest -> cup (compile fin e (r::seq)) (compile fin e rest) 
        | `WeakStar r :: rest -> cup (compile fin e rest) (compile fin e (r::seq))

  and guard_compile fin seq =
    try Hashtbl.find memo seq 
    with
        Not_found ->
          let n = name () in
          let v = mk noloc (PatVar n) in
          Hashtbl.add memo seq v;
          let d = compile fin [] seq in
          (match d with
             | `Empty -> assert false
             | `Res d -> defs := (n,d) :: !defs);
          v


  let atom_nil = Types.mk_atom "nil"
  let constant_nil v t = 
    mk noloc (And (t, (mk noloc (Constant (v, Types.Atom atom_nil)))))

  let compile regexp queue : ppat =
    let vars = seq_vars StringSet.empty regexp in
    let fin = StringSet.fold constant_nil vars queue in
    let n = guard_compile fin [propagate StringSet.empty regexp] in
    Hashtbl.clear memo;
    let d = !defs in
    defs := [];
    mk noloc (Recurs (n,d))
end

let compile_regexp = Regexp.compile


let rec compile env { loc = loc; descr = d } : ti = 
  match (d : Ast.ppat') with
  | PatVar s -> 
      (try StringMap.find s env
       with Not_found -> 
         raise_loc loc (Pattern ("Undefined type variable " ^ s))
      )
  | Recurs (t, b) -> compile (compile_many env b) t
  | Regexp (r,q) -> compile env (Regexp.compile r q)
  | Internal t -> cons loc (`Type t)
  | Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
  | And (t1,t2) -> cons loc (`And (compile env t1, compile env t2))
  | Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
  | Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
  | Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
  | Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
  | Constant (x,v) -> cons loc (`Constant (x,v))
  | Capture x -> cons loc (`Capture x)

and compile_many env b = 
  let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in
  let env = 
    List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
  List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
  env


let rec comp_fv seen s =
  match s.fv with
    | Some l -> l
    | None ->
        let l = 
          match s.descr' with
            | `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x
            | `Or (s1,s2) 
            | `And (s1,s2)
            | `Diff (s1,s2)
            | `Times (s1,s2)
            | `Arrow (s1,s2) -> SortedList.cup (comp_fv seen s1) (comp_fv seen s2)
            | `Record (l,opt,s) -> comp_fv seen s
            | `Type _ -> []
            | `Capture x
            | `Constant (x,_) -> [x]
        in
        if seen = [] then s.fv <- Some l;
        l


let fv = comp_fv []

let rec typ seen s : Types.descr =
  match s.descr' with
    | `Alias (v,x) ->
        if List.memq s seen then 
          raise_loc s.loc' 
            (Pattern 
               ("Unguarded recursion on variable " ^ v ^ " in this type"))
        else typ (s :: seen) x
    | `Type t -> t
    | `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
    | `And (s1,s2) ->  Types.cap (typ seen s1) (typ seen s2)
    | `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
    | `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
    | `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
    | `Record (l,o,s) -> Types.record l o (typ_node s)
    | `Capture _ | `Constant _ -> assert false

and typ_node s : Types.node =
  match s.type_node with
    | Some x -> x
    | None ->
        let x = Types.make () in
        s.type_node <- Some x;
        let t = typ [] s in
        Types.define x t;
        x

let type_node s = Types.internalize (typ_node s)

let rec pat seen s : Patterns.descr =
  if fv s = [] then Patterns.constr (type_node s) else
  match s.descr' with
    | `Alias (v,x) ->
        if List.memq s seen then 
          raise_loc s.loc' 
            (Pattern 
               ("Unguarded recursion on variable " ^ v ^ " in this pattern"))
        else pat (s :: seen) x
    | `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
    | `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
    | `Diff (s1,s2) when fv s2 = [] ->
        let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
        Patterns.cap (pat seen s1) (Patterns.constr s2)
    | `Diff _ ->
        raise_loc s.loc' (Pattern "Difference not allowed in patterns")
    | `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
    | `Record (l,false,s) -> Patterns.record l (pat_node s)
    | `Record _ ->
        raise_loc s.loc' 
          (Pattern "Optional field not allowed in record patterns")
    | `Capture x ->  Patterns.capture x
    | `Constant (x,c) -> Patterns.constant x c
    | `Arrow _ ->
        raise_loc s.loc' (Pattern "Arrow not allowed in patterns")
    | `Type _ -> assert false

and pat_node s : Patterns.node =
  match s.pat_node with
    | Some x -> x
    | None ->
        let x = Patterns.make (fv s) in
        s.pat_node <- Some x;
        let t = pat [] s in
        Patterns.define x t;
        x

let global_types = ref StringMap.empty

let mk_typ e =
  if fv e = [] then type_node e 
  else raise_loc e.loc' (Pattern "Capture variables are not allowed in types")
    

let typ e =
  mk_typ (compile !global_types e)

let pat e =
  let e = compile !global_types e in
  pat_node e

let register_global_types b =
  let env = compile_many !global_types b in
  List.iter (fun (v,_) -> 
               let d = Types.descr (mk_typ (StringMap.find v env)) in
               Types.Print.register_global v d
            ) b;
  global_types := env


(* II. Build skeleton *)

module Fv = StringSet

let rec expr { loc = loc; descr = d } = 
  let (fv,td) = 
    match d with
      | DebugTyper t -> (Fv.empty, Typed.DebugTyper (typ t))
      | Var s -> (Fv.singleton s, Typed.Var s)
      | Apply (e1,e2) -> 
          let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
          (Fv.union fv1 fv2, Typed.Apply (e1,e2))
      | Abstraction a ->
          let iface = List.map (fun (t1,t2) -> (typ t1, typ t2)) a.fun_iface in
          let t = List.fold_left 
                    (fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2)) 
                    Types.any iface in
          let iface = List.map 
                        (fun (t1,t2) -> (Types.descr t1, Types.descr t2)) 
                        iface in
          let (fv0,body) = branches a.fun_body in
          let fv = match a.fun_name with
            | None -> fv0
            | Some f -> Fv.remove f fv0 in
          (fv,
           Typed.Abstraction 
             { Typed.fun_name = a.fun_name;
               Typed.fun_iface = iface;
               Typed.fun_body = body;
               Typed.fun_typ = t;
               Typed.fun_fv = Fv.elements fv0
             }
          )
      | Cst c -> (Fv.empty, Typed.Cst c)
      | Pair (e1,e2) ->
          let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
          (Fv.union fv1 fv2, Typed.Pair (e1,e2))
      | Dot (e,l) ->
          let (fv,e) = expr e in
          (fv,  Typed.Dot (e,l))
      | RecordLitt r -> 
          (* Note: quadratic check for non duplication of labels.
             Should improve that to O(n log n) for dealing
             with huge number of attributes ?
          *)
          let fv = ref Fv.empty in
          let labs = ref [] in
          let r = List.map 
                    (fun (l,e) -> 
                       let (fv2,e) = expr e in
                       if (List.mem l !labs) then 
                         raise_loc loc (MultipleLabel l);
                       labs := l :: !labs;
                       fv := Fv.union !fv fv2;
                       (l,e)
                    ) r in
          (!fv, Typed.RecordLitt r)
      | Op (op,le) ->
          let (fvs,ltes) = List.split (List.map expr le) in
          let fv = List.fold_left Fv.union Fv.empty fvs in
          (fv, Typed.Op (op,ltes))
      | Match (e,b) -> 
          let (fv1,e) = expr e
          and (fv2,b) = branches b in
          (Fv.union fv1 fv2, Typed.Match (e, b))
      | Map (e,b) ->
          let (fv1,e) = expr e
          and (fv2,b) = branches b in
          (Fv.union fv1 fv2, Typed.Map (e, b))
  in
  fv,
  { Typed.exp_loc = loc;
    Typed.exp_typ = Types.empty;
    Typed.exp_descr = td;
  }
              
  and branches b = 
    let fv = ref Fv.empty in
    let accept = ref Types.empty in
    let b = List.map 
              (fun (p,e) ->
                 let (fv2,e) = expr e in
                 fv := Fv.union !fv fv2;
                 let p = pat p in
                 accept := Types.cup !accept (Types.descr (Patterns.accept p));
                 { Typed.br_used = false;
                   Typed.br_pat = p;
                   Typed.br_body = e }
              ) b in
    (!fv, 
     { 
       Typed.br_typ = Types.empty; 
       Typed.br_branches = b; 
       Typed.br_accept = !accept 
     } 
    )

module Env = StringMap

open Typed


let check loc t s msg =
  if not (Types.subtype t s) then raise_loc loc (Constraint (t, s, msg))

let rec type_check env e constr precise = 
 (* Format.fprintf Format.std_formatter "constr=%a precise=%b@\n"
    Types.Print.print_descr constr precise;  *)
  let d = type_check' e.exp_loc env e.exp_descr constr precise in
  e.exp_typ <- Types.cup e.exp_typ d;
  d

and type_check' loc env e constr precise = match e with
  | Abstraction a ->
      let t =
        try Types.Arrow.check_strenghten a.fun_typ constr 
        with Not_found -> 
          raise_loc loc 
          (ShouldHave
             (constr, "but the interface of the abstraction is not compatible"))
      in
      let env = match a.fun_name with
        | None -> env
        | Some f -> Env.add f a.fun_typ env in
      List.iter 
        (fun (t1,t2) ->
           ignore (type_check_branches loc env t1 a.fun_body t2 false)
        ) a.fun_iface;
      t
  | Match (e,b) ->
      let t = type_check env e b.br_accept true in
      type_check_branches loc env t b constr precise
  | Pair (e1,e2) -> 
      let rects = Types.Product.get constr in
      if Types.Product.is_empty rects then 
        raise_loc loc (ShouldHave (constr,"but it is a pair."));
      let pi1 = Types.Product.pi1 rects in

      let t1 = type_check env e1 (Types.Product.pi1 rects) 
                 (precise || (Types.Product.need_second rects))in
      let rects = Types.Product.restrict_1 rects t1 in
      let t2 = type_check env e2 (Types.Product.pi2 rects) precise in
      if precise then 
        Types.times (Types.cons t1) (Types.cons t2)
      else
        constr
  | RecordLitt r ->
      let rconstr = Types.Record.get constr in
      if Types.Record.is_empty rconstr then
        raise_loc loc (ShouldHave (constr,"but it is a record."));

      let (rconstr,res) = 
        List.fold_left 
          (fun (rconstr,res) (l,e) ->
             let rconstr = Types.Record.restrict_label_present rconstr l in
             let pi = Types.Record.project_field rconstr l in
             if Types.Record.is_empty rconstr then
               raise_loc loc 
                 (ShouldHave (constr,(Printf.sprintf 
                                        "Field %s is not allowed here."
                                        (Types.label_name l)
                                     )
                             ));
             let t = type_check env e pi true in
             let rconstr = Types.Record.restrict_field rconstr l t in
             
             let res = 
               if precise 
               then Types.cap res (Types.record l false (Types.cons t))
               else res in
             (rconstr,res)
          ) (rconstr, if precise then Types.Record.any else constr) r
      in
      res

  | _ -> 
      let t : Types.descr = compute_type' loc env e in
      check loc t constr "";
      t

and compute_type env e =
  type_check env e Types.any true

and compute_type' loc env = function
  | DebugTyper t -> Types.descr t
  | Var s -> Env.find s env
  | Apply (e1,e2) ->
      let t1 = type_check env e1 Types.Arrow.any true in
      let t1 = Types.Arrow.get t1 in
      let dom = Types.Arrow.domain t1 in
      if Types.Arrow.need_arg t1 then
        let t2 = type_check env e2 dom true in
        Types.Arrow.apply t1 t2
      else
        (ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
  | Cst c -> Types.constant c
  | Dot (e,l) ->
      let t = type_check env e Types.Record.any true in
         (try (Types.Record.project t l) 
          with Not_found -> raise_loc loc (WrongLabel(t,l)))
  | Op (op, el) ->
      let args = List.map (fun e -> (e.exp_loc, compute_type env e)) el in
      type_op loc op args
  | Map (e,b) ->
      let t = compute_type env e in
      Sequence.map (fun t -> type_check_branches loc env t b Types.any true) t
  | _ -> assert false

and type_check_branches loc env targ brs constr precise =
  if Types.is_empty targ then Types.empty 
  else (
    brs.br_typ <- Types.cup brs.br_typ targ;
    branches_aux loc env targ 
      (if precise then Types.empty else constr) 
      constr precise brs.br_branches
  )
    
and branches_aux loc env targ tres constr precise = function
  | [] -> raise_loc loc (NonExhaustive targ)
  | b :: rem ->
      let p = b.br_pat in
      let acc = Types.descr (Patterns.accept p) in

      let targ' = Types.cap targ acc in
      if Types.is_empty targ' 
      then branches_aux loc env targ tres constr precise rem
      else 
        ( b.br_used <- true;
          let res = Patterns.filter targ' p in
          let env' = List.fold_left 
                       (fun env (x,t) -> Env.add x (Types.descr t) env) 
                       env res in
          let t = type_check env' b.br_body constr precise in
          let tres = if precise then Types.cup t tres else tres in
          let targ'' = Types.diff targ acc in
          if (Types.non_empty targ'') then 
            branches_aux loc env targ'' tres constr precise rem 
          else
            tres
        )

and type_op loc op args =
  match (op,args) with
    | ("+", [loc1,t1; loc2,t2]) ->
        type_int_binop Intervals.add loc1 t1 loc2 t2
    | ("*", [loc1,t1; loc2,t2]) ->
        type_int_binop (fun i1 i2 -> Intervals.any) loc1 t1 loc2 t2
    | ("@", [loc1,t1; loc2,t2]) ->
        check loc1 t1 Sequence.any
          "The first argument of @ must be a sequence";
        Sequence.concat t1 t2
    | ("flatten", [loc1,t1]) ->
        check loc1 t1 Sequence.seqseq 
          "The argument of flatten must be a sequence of sequences";
        Sequence.flatten t1
    | _ -> assert false

and type_int_binop f loc1 t1 loc2 t2 =
  if not (Types.Int.is_int t1) then
    raise_loc loc1 
      (Constraint 
         (t1,Types.Int.any,
          "The first argument must be an integer"));
  if not (Types.Int.is_int t2) then
    raise_loc loc2
      (Constraint 
               (t1,Types.Int.any,
                "The second argument must be an integer"));
  Types.Int.put
    (f (Types.Int.get t1) (Types.Int.get t2));
  

1	(* I. Transform the abstract syntax of types and patterns into
2	the internal form *)
3
4	open Location
5	open Ast
6
7	exception Pattern of string
8	exception NonExhaustive of Types.descr
9	exception MultipleLabel of Types.label
10	exception Constraint of Types.descr * Types.descr * string
11	exception ShouldHave of Types.descr * string
12	exception WrongLabel of Types.descr * Types.label
13
14	let raise_loc loc exn = raise (Location (loc,exn))
15
16	(* Internal representation as a graph (desugar recursive types and regexp),
17	to compute freevars, etc... *)
18
19	type ti = {
20	id : int;
21	mutable loc' : loc;
22	mutable fv : string SortedList.t option;
23	mutable descr': descr;
24	mutable type_node: Types.node option;
25	mutable pat_node: Patterns.node option
26	}
27	and descr =
28	[ `Alias of string * ti
29	\| `Type of Types.descr
30	\| `Or of ti * ti
31	\| `And of ti * ti
32	\| `Diff of ti * ti
33	\| `Times of ti * ti
34	\| `Arrow of ti * ti
35	\| `Record of Types.label * bool * ti
36	\| `Capture of Patterns.capture
37	\| `Constant of Patterns.capture * Types.const
38	]
39
40
41
42	module S = struct type t = string let compare = compare end
43	module StringMap = Map.Make(S)
44	module StringSet = Set.Make(S)
45
46	let mk' =
47	let counter = ref 0 in
48	fun loc ->
49	incr counter;
50	let rec x = {
51	id = !counter;
52	loc' = loc;
53	fv = None;
54	descr' = `Alias ("__dummy__", x);
55	type_node = None;
56	pat_node = None
57	} in
58	x
59
60	let cons loc d =
61	let x = mk' loc in
62	x.descr' <- d;
63	x
64
65	(* Note:
66	Compilation of Regexp is implemented as a ``rewriting'' of
67	the parsed syntax, in order to be able to print its result
68	(for debugging for instance)
69
70	It would be possible (and a little more efficient) to produce
71	directly ti nodes.
72	*)
73
74	module Regexp = struct
75	let memo = Hashtbl.create 51
76	let defs = ref []
77	let name =
78	let c = ref 0 in
79	fun () ->
80	incr c;
81	"#" ^ (string_of_int !c)
82
83	let rec seq_vars accu = function
84	\| Epsilon \| Elem _ -> accu
85	\| Seq (r1,r2) \| Alt (r1,r2) -> seq_vars (seq_vars accu r1) r2
86	\| Star r \| WeakStar r -> seq_vars accu r
87	\| SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r
88
89	let rec propagate vars = function
90	\| Epsilon -> `Epsilon
91	\| Elem x -> `Elem (vars,x)
92	\| Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)
93	\| Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)
94	\| Star r -> `Star (propagate vars r)
95	\| WeakStar r -> `WeakStar (propagate vars r)
96	\| SeqCapture (v,x) -> propagate (StringSet.add v vars) x
97
98	let cup r1 r2 =
99	match (r1,r2) with
100	\| (_, `Empty) -> r1
101	\| (`Empty, _) -> r2
102	\| (`Res t1, `Res t2) -> `Res (mk noloc (Or (t1,t2)))
103
104	let rec compile fin e seq : [`Res of Ast.ppat \| `Empty] =
105	if List.mem seq e then `Empty
106	else
107	let e = seq :: e in
108	match seq with
109	\| [] ->
110	`Res fin
111	\| `Epsilon :: rest ->
112	compile fin e rest
113	\| `Elem (vars,x) :: rest ->
114	let capt = StringSet.fold
115	(fun v t -> mk noloc (And (t, (mk noloc (Capture v)))))
116	vars x in
117	`Res (mk noloc (Prod (capt, guard_compile fin rest)))
118	\| `Seq (r1,r2) :: rest ->
119	compile fin e (r1 :: r2 :: rest)
120	\| `Alt (r1,r2) :: rest ->
121	cup (compile fin e (r1::rest)) (compile fin e (r2::rest))
122	\| `Star r :: rest -> cup (compile fin e (r::seq)) (compile fin e rest)
123	\| `WeakStar r :: rest -> cup (compile fin e rest) (compile fin e (r::seq))
124
125	and guard_compile fin seq =
126	try Hashtbl.find memo seq
127	with
128	Not_found ->
129	let n = name () in
130	let v = mk noloc (PatVar n) in
131	Hashtbl.add memo seq v;
132	let d = compile fin [] seq in
133	(match d with
134	\| `Empty -> assert false
135	\| `Res d -> defs := (n,d) :: !defs);
136	v
137
138
139	let atom_nil = Types.mk_atom "nil"
140	let constant_nil v t =
141	mk noloc (And (t, (mk noloc (Constant (v, Types.Atom atom_nil)))))
142
143	let compile regexp queue : ppat =
144	let vars = seq_vars StringSet.empty regexp in
145	let fin = StringSet.fold constant_nil vars queue in
146	let n = guard_compile fin [propagate StringSet.empty regexp] in
147	Hashtbl.clear memo;
148	let d = !defs in
149	defs := [];
150	mk noloc (Recurs (n,d))
151	end
152
153	let compile_regexp = Regexp.compile
154
155
156	let rec compile env { loc = loc; descr = d } : ti =
157	match (d : Ast.ppat') with
158	\| PatVar s ->
159	(try StringMap.find s env
160	with Not_found ->
161	raise_loc loc (Pattern ("Undefined type variable " ^ s))
162	)
163	\| Recurs (t, b) -> compile (compile_many env b) t
164	\| Regexp (r,q) -> compile env (Regexp.compile r q)
165	\| Internal t -> cons loc (`Type t)
166	\| Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
167	\| And (t1,t2) -> cons loc (`And (compile env t1, compile env t2))
168	\| Diff (t1,t2) -> cons loc (`Diff (compile env t1, compile env t2))
169	\| Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
170	\| Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
171	\| Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
172	\| Constant (x,v) -> cons loc (`Constant (x,v))
173	\| Capture x -> cons loc (`Capture x)
174
175	and compile_many env b =
176	let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in
177	let env =
178	List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
179	List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
180	env
181
182
183	let rec comp_fv seen s =
184	match s.fv with
185	\| Some l -> l
186	\| None ->
187	let l =
188	match s.descr' with
189	\| `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x
190	\| `Or (s1,s2)
191	\| `And (s1,s2)
192	\| `Diff (s1,s2)
193	\| `Times (s1,s2)
194	\| `Arrow (s1,s2) -> SortedList.cup (comp_fv seen s1) (comp_fv seen s2)
195	\| `Record (l,opt,s) -> comp_fv seen s
196	\| `Type _ -> []
197	\| `Capture x
198	\| `Constant (x,_) -> [x]
199	in
200	if seen = [] then s.fv <- Some l;
201	l
202
203
204	let fv = comp_fv []
205
206	let rec typ seen s : Types.descr =
207	match s.descr' with
208	\| `Alias (v,x) ->
209	if List.memq s seen then
210	raise_loc s.loc'
211	(Pattern
212	("Unguarded recursion on variable " ^ v ^ " in this type"))
213	else typ (s :: seen) x
214	\| `Type t -> t
215	\| `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
216	\| `And (s1,s2) -> Types.cap (typ seen s1) (typ seen s2)
217	\| `Diff (s1,s2) -> Types.diff (typ seen s1) (typ seen s2)
218	\| `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
219	\| `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
220	\| `Record (l,o,s) -> Types.record l o (typ_node s)
221	\| `Capture _ \| `Constant _ -> assert false
222
223	and typ_node s : Types.node =
224	match s.type_node with
225	\| Some x -> x
226	\| None ->
227	let x = Types.make () in
228	s.type_node <- Some x;
229	let t = typ [] s in
230	Types.define x t;
231	x
232
233	let type_node s = Types.internalize (typ_node s)
234
235	let rec pat seen s : Patterns.descr =
236	if fv s = [] then Patterns.constr (type_node s) else
237	match s.descr' with
238	\| `Alias (v,x) ->
239	if List.memq s seen then
240	raise_loc s.loc'
241	(Pattern
242	("Unguarded recursion on variable " ^ v ^ " in this pattern"))
243	else pat (s :: seen) x
244	\| `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
245	\| `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
246	\| `Diff (s1,s2) when fv s2 = [] ->
247	let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
248	Patterns.cap (pat seen s1) (Patterns.constr s2)
249	\| `Diff _ ->
250	raise_loc s.loc' (Pattern "Difference not allowed in patterns")
251	\| `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
252	\| `Record (l,false,s) -> Patterns.record l (pat_node s)
253	\| `Record _ ->
254	raise_loc s.loc'
255	(Pattern "Optional field not allowed in record patterns")
256	\| `Capture x -> Patterns.capture x
257	\| `Constant (x,c) -> Patterns.constant x c
258	\| `Arrow _ ->
259	raise_loc s.loc' (Pattern "Arrow not allowed in patterns")
260	\| `Type _ -> assert false
261
262	and pat_node s : Patterns.node =
263	match s.pat_node with
264	\| Some x -> x
265	\| None ->
266	let x = Patterns.make (fv s) in
267	s.pat_node <- Some x;
268	let t = pat [] s in
269	Patterns.define x t;
270	x
271
272	let global_types = ref StringMap.empty
273
274	let mk_typ e =
275	if fv e = [] then type_node e
276	else raise_loc e.loc' (Pattern "Capture variables are not allowed in types")
277
278
279	let typ e =
280	mk_typ (compile !global_types e)
281
282	let pat e =
283	let e = compile !global_types e in
284	pat_node e
285
286	let register_global_types b =
287	let env = compile_many !global_types b in
288	List.iter (fun (v,_) ->
289	let d = Types.descr (mk_typ (StringMap.find v env)) in
290	Types.Print.register_global v d
291	) b;
292	global_types := env
293
294
295	(* II. Build skeleton *)
296
297	module Fv = StringSet
298
299	let rec expr { loc = loc; descr = d } =
300	let (fv,td) =
301	match d with
302	\| DebugTyper t -> (Fv.empty, Typed.DebugTyper (typ t))
303	\| Var s -> (Fv.singleton s, Typed.Var s)
304	\| Apply (e1,e2) ->
305	let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
306	(Fv.union fv1 fv2, Typed.Apply (e1,e2))
307	\| Abstraction a ->
308	let iface = List.map (fun (t1,t2) -> (typ t1, typ t2)) a.fun_iface in
309	let t = List.fold_left
310	(fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
311	Types.any iface in
312	let iface = List.map
313	(fun (t1,t2) -> (Types.descr t1, Types.descr t2))
314	iface in
315	let (fv0,body) = branches a.fun_body in
316	let fv = match a.fun_name with
317	\| None -> fv0
318	\| Some f -> Fv.remove f fv0 in
319	(fv,
320	Typed.Abstraction
321	{ Typed.fun_name = a.fun_name;
322	Typed.fun_iface = iface;
323	Typed.fun_body = body;
324	Typed.fun_typ = t;
325	Typed.fun_fv = Fv.elements fv0
326	}
327	)
328	\| Cst c -> (Fv.empty, Typed.Cst c)
329	\| Pair (e1,e2) ->
330	let (fv1,e1) = expr e1 and (fv2,e2) = expr e2 in
331	(Fv.union fv1 fv2, Typed.Pair (e1,e2))
332	\| Dot (e,l) ->
333	let (fv,e) = expr e in
334	(fv, Typed.Dot (e,l))
335	\| RecordLitt r ->
336	(* Note: quadratic check for non duplication of labels.
337	Should improve that to O(n log n) for dealing
338	with huge number of attributes ?
339	*)
340	let fv = ref Fv.empty in
341	let labs = ref [] in
342	let r = List.map
343	(fun (l,e) ->
344	let (fv2,e) = expr e in
345	if (List.mem l !labs) then
346	raise_loc loc (MultipleLabel l);
347	labs := l :: !labs;
348	fv := Fv.union !fv fv2;
349	(l,e)
350	) r in
351	(!fv, Typed.RecordLitt r)
352	\| Op (op,le) ->
353	let (fvs,ltes) = List.split (List.map expr le) in
354	let fv = List.fold_left Fv.union Fv.empty fvs in
355	(fv, Typed.Op (op,ltes))
356	\| Match (e,b) ->
357	let (fv1,e) = expr e
358	and (fv2,b) = branches b in
359	(Fv.union fv1 fv2, Typed.Match (e, b))
360	\| Map (e,b) ->
361	let (fv1,e) = expr e
362	and (fv2,b) = branches b in
363	(Fv.union fv1 fv2, Typed.Map (e, b))
364	in
365	fv,
366	{ Typed.exp_loc = loc;
367	Typed.exp_typ = Types.empty;
368	Typed.exp_descr = td;
369	}
370
371	and branches b =
372	let fv = ref Fv.empty in
373	let accept = ref Types.empty in
374	let b = List.map
375	(fun (p,e) ->
376	let (fv2,e) = expr e in
377	fv := Fv.union !fv fv2;
378	let p = pat p in
379	accept := Types.cup !accept (Types.descr (Patterns.accept p));
380	{ Typed.br_used = false;
381	Typed.br_pat = p;
382	Typed.br_body = e }
383	) b in
384	(!fv,
385	{
386	Typed.br_typ = Types.empty;
387	Typed.br_branches = b;
388	Typed.br_accept = !accept
389	}
390	)
391
392	module Env = StringMap
393
394	open Typed
395
396
397	let check loc t s msg =
398	if not (Types.subtype t s) then raise_loc loc (Constraint (t, s, msg))
399
400	let rec type_check env e constr precise =
401	(* Format.fprintf Format.std_formatter "constr=%a precise=%b@\n"
402	Types.Print.print_descr constr precise; *)
403	let d = type_check' e.exp_loc env e.exp_descr constr precise in
404	e.exp_typ <- Types.cup e.exp_typ d;
405	d
406
407	and type_check' loc env e constr precise = match e with
408	\| Abstraction a ->
409	let t =
410	try Types.Arrow.check_strenghten a.fun_typ constr
411	with Not_found ->
412	raise_loc loc
413	(ShouldHave
414	(constr, "but the interface of the abstraction is not compatible"))
415	in
416	let env = match a.fun_name with
417	\| None -> env
418	\| Some f -> Env.add f a.fun_typ env in
419	List.iter
420	(fun (t1,t2) ->
421	ignore (type_check_branches loc env t1 a.fun_body t2 false)
422	) a.fun_iface;
423	t
424	\| Match (e,b) ->
425	let t = type_check env e b.br_accept true in
426	type_check_branches loc env t b constr precise
427	\| Pair (e1,e2) ->
428	let rects = Types.Product.get constr in
429	if Types.Product.is_empty rects then
430	raise_loc loc (ShouldHave (constr,"but it is a pair."));
431	let pi1 = Types.Product.pi1 rects in
432
433	let t1 = type_check env e1 (Types.Product.pi1 rects)
434	(precise \|\| (Types.Product.need_second rects))in
435	let rects = Types.Product.restrict_1 rects t1 in
436	let t2 = type_check env e2 (Types.Product.pi2 rects) precise in
437	if precise then
438	Types.times (Types.cons t1) (Types.cons t2)
439	else
440	constr
441	\| RecordLitt r ->
442	let rconstr = Types.Record.get constr in
443	if Types.Record.is_empty rconstr then
444	raise_loc loc (ShouldHave (constr,"but it is a record."));
445
446	let (rconstr,res) =
447	List.fold_left
448	(fun (rconstr,res) (l,e) ->
449	let rconstr = Types.Record.restrict_label_present rconstr l in
450	let pi = Types.Record.project_field rconstr l in
451	if Types.Record.is_empty rconstr then
452	raise_loc loc
453	(ShouldHave (constr,(Printf.sprintf
454	"Field %s is not allowed here."
455	(Types.label_name l)
456	)
457	));
458	let t = type_check env e pi true in
459	let rconstr = Types.Record.restrict_field rconstr l t in
460
461	let res =
462	if precise
463	then Types.cap res (Types.record l false (Types.cons t))
464	else res in
465	(rconstr,res)
466	) (rconstr, if precise then Types.Record.any else constr) r
467	in
468	res
469
470	\| _ ->
471	let t : Types.descr = compute_type' loc env e in
472	check loc t constr "";
473	t
474
475	and compute_type env e =
476	type_check env e Types.any true
477
478	and compute_type' loc env = function
479	\| DebugTyper t -> Types.descr t
480	\| Var s -> Env.find s env
481	\| Apply (e1,e2) ->
482	let t1 = type_check env e1 Types.Arrow.any true in
483	let t1 = Types.Arrow.get t1 in
484	let dom = Types.Arrow.domain t1 in
485	if Types.Arrow.need_arg t1 then
486	let t2 = type_check env e2 dom true in
487	Types.Arrow.apply t1 t2
488	else
489	(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
490	\| Cst c -> Types.constant c
491	\| Dot (e,l) ->
492	let t = type_check env e Types.Record.any true in
493	(try (Types.Record.project t l)
494	with Not_found -> raise_loc loc (WrongLabel(t,l)))
495	\| Op (op, el) ->
496	let args = List.map (fun e -> (e.exp_loc, compute_type env e)) el in
497	type_op loc op args
498	\| Map (e,b) ->
499	let t = compute_type env e in
500	Sequence.map (fun t -> type_check_branches loc env t b Types.any true) t
501	\| _ -> assert false
502
503	and type_check_branches loc env targ brs constr precise =
504	if Types.is_empty targ then Types.empty
505	else (
506	brs.br_typ <- Types.cup brs.br_typ targ;
507	branches_aux loc env targ
508	(if precise then Types.empty else constr)
509	constr precise brs.br_branches
510	)
511
512	and branches_aux loc env targ tres constr precise = function
513	\| [] -> raise_loc loc (NonExhaustive targ)
514	\| b :: rem ->
515	let p = b.br_pat in
516	let acc = Types.descr (Patterns.accept p) in
517
518	let targ' = Types.cap targ acc in
519	if Types.is_empty targ'
520	then branches_aux loc env targ tres constr precise rem
521	else
522	( b.br_used <- true;
523	let res = Patterns.filter targ' p in
524	let env' = List.fold_left
525	(fun env (x,t) -> Env.add x (Types.descr t) env)
526	env res in
527	let t = type_check env' b.br_body constr precise in
528	let tres = if precise then Types.cup t tres else tres in
529	let targ'' = Types.diff targ acc in
530	if (Types.non_empty targ'') then
531	branches_aux loc env targ'' tres constr precise rem
532	else
533	tres
534	)
535
536	and type_op loc op args =
537	match (op,args) with
538	\| ("+", [loc1,t1; loc2,t2]) ->
539	type_int_binop Intervals.add loc1 t1 loc2 t2
540	\| ("*", [loc1,t1; loc2,t2]) ->
541	type_int_binop (fun i1 i2 -> Intervals.any) loc1 t1 loc2 t2
542	\| ("@", [loc1,t1; loc2,t2]) ->
543	check loc1 t1 Sequence.any
544	"The first argument of @ must be a sequence";
545	Sequence.concat t1 t2
546	\| ("flatten", [loc1,t1]) ->
547	check loc1 t1 Sequence.seqseq
548	"The argument of flatten must be a sequence of sequences";
549	Sequence.flatten t1
550	\| _ -> assert false
551
552	and type_int_binop f loc1 t1 loc2 t2 =
553	if not (Types.Int.is_int t1) then
554	raise_loc loc1
555	(Constraint
556	(t1,Types.Int.any,
557	"The first argument must be an integer"));
558	if not (Types.Int.is_int t2) then
559	raise_loc loc2
560	(Constraint
561	(t1,Types.Int.any,
562	"The second argument must be an integer"));
563	Types.Int.put
564	(f (Types.Int.get t1) (Types.Int.get t2));
565
566