[r2005-06-13 12:08:21 by afrisch] Nested OCaml modules

Original author: afrisch
Date: 2005-06-13 12:08:21+00:00

typing/typer.ml

@@ -504,24 +504,8 @@ let rec expr env loc = function
       let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
       let n = if env.keep_ns then Some env.ns else None in
       exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2,n))
-  | Dot (LocatedExpr (_,Var cu), id, tyargs) when not (has_value cu env) ->
-      (match find_cu loc cu env with
-	 | ECDuce cu ->
-	     if tyargs != [] then
-	       error loc "CDuce externals cannot have type argument";
-	     let id = ident env loc id in
-	     let t = find_value_global loc cu id env in
-	     exp loc Fv.empty (Typed.ExtVar (cu, id, t))
-	 | EOCaml cu ->
-	     extern loc env (cu ^ "." ^ U.get_str id) tyargs
-	       (* TODO: allow nested OCaml modules A.B.C.x *)
-	 | ESchema _ ->
-	     error loc "Schema don't export values")
-  | Dot (e,l,[]) ->
-      let (fv,e) = expr env loc e in
-      exp loc fv (Typed.Dot (e,parse_label env loc l))
-  | Dot (_,_,_::_) ->
-      error loc "Field access cannot have type arguments"
+  | Dot _ as e ->
+      dot loc env e
   | RemoveField (e,l) ->
       let (fv,e) = expr env loc e in
       exp loc fv (Typed.RemoveField (e,parse_label env loc l))
@@ -588,6 +572,39 @@ and if_then_else loc cond yes no =
     Typed.br_accept = Builtin_defs.bool;
   } in
   exp' loc (Typed.Match (cond,b))
+
+
+and dot loc env e =
+  let dot_access loc (fv,e) l =
+    exp loc fv (Typed.Dot (e,parse_label env loc l)) in
+  let rec aux loc fields args = function
+    | Var cu when not (has_value cu env) -> 
+	(match find_cu loc cu env with
+	   | ECDuce cu ->
+	       if args != [] then
+		 error loc "CDuce externals cannot have type argument";
+	       let id,fields = 
+		 (match fields with (hd,_)::tl -> hd,tl | _ -> assert false) in
+	       let id = ident env loc id in
+	       let t = find_value_global loc cu id env in
+	       let e = exp loc Fv.empty (Typed.ExtVar (cu, id, t)) in
+	       List.fold_left (fun e (x,loc) -> dot_access loc e x) e fields
+	   | EOCaml cu ->
+	       let fields = List.map fst fields in
+	       let s = String.concat "." (cu :: List.map U.get_str fields) in
+	       extern loc env s args
+	   | ESchema _ ->
+ 	       error loc "Schema don't export values")
+    | LocatedExpr (loc,e) -> aux loc fields args e
+    | Dot (e,id,a) -> aux loc ((id,loc) :: fields) (a @ args) e
+    | e ->
+	if args != [] then
+	  error loc "Field access cannot have type arguments"
+	else
+	  let e = expr env loc e in
+	  List.fold_left (fun e (x,loc) -> dot_access loc e x) e fields
+  in
+  aux loc [] [] e
 	
 and extern loc env s args = 
   let args = List.map (typ env) args in