Commits

camlspotter  committed ec79085 Merge

improving

  • Participants
  • Parent commits b59bf80, 70c395d
  • Branches dev

Comments (0)

Files changed (5)

File OMakefile

File contents unchanged.

File pa/pa_opycaml.ml

 open Camlp4
 open PreCast
 
-(* See tutorial at 
-   http://ambassadortothecomputers.blogspot.com/2010/03/reading-camlp4-part-5-filters.html 
+(* See tutorial at
+   http://ambassadortothecomputers.blogspot.com/2010/03/reading-camlp4-part-5-filters.html
    http://brion.inria.fr/gallium/index.php/Camlp4MapGenerator
 *)
 
 module Make (AstFilters : Sig.AstFilters) = struct
   open AstFilters
+  open Ast
 
-  let _ = 
+  (** Iteration over struct item StSem *)
+  let rec iter_sitems f = function
+    | StSem (_, sitem1, sitem2) -> iter_sitems f sitem1; iter_sitems f sitem2
+        (* does not work
+           <:str_item< $sitem1$ $sitem2$ >> -> *)
+    | i -> f i
+
+  let rec fold_sitems f st = function
+    | StSem (_, sitem1, sitem2) ->
+        (* does not work <:str_item< $sitem1$ $sitem2$ >> -> *)
+        let st1 = fold_sitems f st sitem1 in
+        fold_sitems f st1 sitem2
+    | i -> f st i
+
+  (** Concatenate class str items *)
+  let concat_class_str_items csitems =
+    let _loc = Loc.ghost in
+    List.fold_left (fun st csitem -> <:class_str_item< $st$ $csitem$ >>) <:class_str_item<>> csitems
+
+  (** Concatenate str items *)
+  let concat_str_items sitems =
+    let _loc = Loc.ghost in
+    List.fold_left (fun st sitem -> <:str_item< $st$ $sitem$ >>) <:str_item<>> sitems
+
+  let _ =
     let simplify = object
+
       inherit Ast.map as super
+
       method! str_item sitem =
         let sitem = super#str_item sitem in
+
         match sitem with
-        | Ast.StMod (mloc, modname, module_expr) ->
-            let rec iter_sitems f = function
-              | Ast.StSem (_, sitem1, sitem2) -> iter_sitems f sitem1; iter_sitems f sitem2
-              | i -> f i
-            in 
-            begin match module_expr with
-            | Ast.MeStr (x, sitem) ->
-                let meths = ref [] in
-                iter_sitems (function
-                  | Ast.StExt (loc, name, <:ctyp< [ > $cls$ ] t -> $ty_rest$>>, _slist) -> 
-                      begin match cls with
-                      | Ast.TyId (_, Ast.IdLid (_, tname)) ->
-                          if tname = "_" ^ modname then meths := (name, loc, ty_rest) :: !meths
-                      | _ -> ()
-                      end
-                  | _ -> ()
-                ) sitem;
-                let create_meth name loc ty_rest = 
-                  let rec args pos (f, st) = function
-                    | <:ctyp< $argty$ -> $ty$ >> ->
-                        let _loc = Ast.Loc.ghost in
-                        let vname = Printf.sprintf "v%d" pos in
-                        let v = <:expr<$lid:vname$>> in
-                        let e = 
-                          match argty with
-                          | <:ctyp< [ > $cls$ ] t >> -> 
-                              begin match cls with
-                              | Ast.TyId (_, Ast.IdLid (_, clsname)) ->
-                                  let tnametyp = <:ctyp< $lid: clsname$ >> in
-                                  <:expr< ($v$#$clsname$ : $tnametyp$ t) >>
-                              | _ -> <:expr< $v$#hoge >>
-                              end
-                          | _ -> v
-                        in
-                        args (pos+1) ( (fun e -> f (Ast.ExFun (Ast.Loc.ghost, Ast.McArr( Ast.Loc.ghost,
-                                                                                      Ast.PaId (Ast.Loc.ghost, Ast.IdLid (Ast.Loc.ghost, vname)),
-                                                                                      Ast.ExNil Ast.Loc.ghost,
-                                                                                      e)))), 
-                                       <:expr< $st$ $e$ >> ) ty
-                    | _ -> f st
-                  in
-                  let lid = Ast.ExId (loc, Ast.IdLid (loc, name)) in
-                  let _loc = Ast.Loc.ghost in
-                  let e = args 0 ((fun x -> x), <:expr<$lid$ t>>) ty_rest in
-                  <:class_str_item@loc< method $name$ = $e$ >> 
-                in
-                let meths = 
-                  List.fold_left (fun st (name, loc, ty_rest) -> Ast.CrSem(loc, create_meth name loc ty_rest, st)) 
-                    (Ast.CrNil Ast.Loc.ghost) !meths
-                in
-                let _loc = Ast.Loc.ghost in
-                let tname = "_" ^ modname in
-                let tnametyp = <:ctyp< $lid:tname$ >> in
-                let sitem' = Ast.StSem (Ast.Loc.ghost, sitem, 
-                                        <:str_item< class o t = object
-                                          $meths$
-                                          method $tname$ = (t :> $tnametyp$ t )
-                                        end>>)
-                in
-                Ast.StMod (mloc, modname, Ast.MeStr (x, sitem'))
-            | _ -> sitem
-            end
+        | StMod (mloc, modname, MeStr (sloc, sitems)) ->
+            (* does not work
+               | <:str_item@mloc< module $modname$ = $module_expr$ >> ->
+               | <:module_expr@sloc< struct $sitem$ end >> -> *)
+
+            (* Obtain functions which can be methods or not *)
+            let meths, non_meths = fold_sitems (fun (meths, non_meths) si ->
+              match si with
+              | StExt (loc, name, <:ctyp< [ > $cls$ ] t -> $ty_rest$>>, _slist) ->
+                  (* <:str_item< external $name$ : [ > $cls$ ] t -> $_$ = $_$>> ->     DOES NOT WORK... *)
+                  begin match cls with
+                  | <:ctyp<$lid:tname$>> when tname = "_" ^ modname ->
+                      (name, loc, ty_rest) :: meths, non_meths
+                  | _ -> meths, si :: non_meths
+                  end
+              | _ -> meths, si :: non_meths)
+              ([], [])
+              sitems
+            in
+
+            (* [> _Cls ] t ->    =>    _Cls -> *)
+            let arg v ty =
+              let _loc = Loc.ghost in
+              match ty with
+              | <:ctyp< [ > $ <:ctyp@tyloc< $lid:clsname$ >> $ ] t >> ->
+                  <:expr@_loc< $v$#$clsname$ >>, <:ctyp@tyloc< $lid:clsname$ >>
+              | _ -> v, ty
+            in
+
+            let return ty =
+              let _loc = Loc.ghost in
+              match ty with
+              | <:ctyp< $ <:ctyp@tyloc< $lid:clsname$ >> $ t >> ->
+                  (fun e -> <:expr@_loc< new $lid:clsname$ $e$ >>), <:ctyp@tyloc< $lid:clsname$ >>
+              | _ -> (fun e -> e), ty
+            in
+
+            let wrap_oo base ty =
+              let _loc = Loc.ghost in
+              let mk_id pos = Printf.sprintf "v%d" pos in
+              let mk_tyvar pos = TyQuo(_loc, Printf.sprintf "a%d" pos) in (* No ' required! *)
+
+              let rec args pos = function
+                | <:ctyp< $argty$ -> $ty$ >> ->
+
+                    let qvars, mty, absts, args, mk_return = args (pos+1) ty in
+
+                    let v = <:expr<$lid:mk_id pos$>> in
+                    let pat = mk_id pos in
+                    let e, _ = arg v argty in
+
+                    let absts = pat :: absts in
+                    let args = e :: args in
+
+                    let qvars, mty =
+                      match argty with
+                      | <:ctyp< [ > $cls$ ] t >> ->
+                          begin match cls with
+                          | <:ctyp< $lid:clsname$ >> ->  (* X *)
+                              let tv = mk_tyvar pos in
+                                  (* Strange, but < $ctyp$ : $ctyp$; ..> *)
+                              let oty = <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >> in
+                              tv :: qvars,
+                              <:ctyp< $ TyAli(_loc, oty, tv) $ -> $mty$ >>
+                          | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
+                          end
+                      | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
+                    in
+                    qvars, mty, absts, args, mk_return
+
+                | mty ->
+                    let mk_return, mty = return mty in
+                    [], mty, [], [], mk_return
+              in
+              let qvars, mty, absts, args, mk_return = args 0 ty in (* X *)
+              let q mty = function
+                | [] -> mty
+                | qvs ->
+                    let rec qapp = function
+                      | [] -> assert false
+                      | [qv] -> qv
+                      | qv::qvs -> TyApp(_loc, qv, qapp qvs) (* strange but it is as an app *)
+                    in
+                    TyPol (_loc, qapp qvs, mty)
+              in
+              let rec mk_app b = function
+                | [] -> b
+                | e::es -> mk_app <:expr< $b$ $e$ >> es
+              in
+              let rec mk_abst b = function
+                | [] -> b
+                | v::vs -> <:expr< fun $lid:v$ -> $mk_abst b vs$ >>
+              in
+              q mty qvars, mk_abst (mk_return (mk_app base args)) absts
+            in
+
+            let mk_method name loc ty_rest =
+              let id = <:expr@loc< $lid:name$ >> in
+              let poly_type, expr = wrap_oo <:expr@loc<$id$ t>> ty_rest in
+              <:class_str_item@loc<
+                  method $name$ : $poly_type$ = $expr$
+              >>
+            in
+
+            let non_meths = concat_str_items non_meths in
+
+            let meths =
+              concat_class_str_items
+                (List.map (fun (name, loc, ty_rest) -> mk_method name loc ty_rest) meths)
+            in
+            let _loc = Loc.ghost in
+            let tname = "_" ^ modname in
+            let tnametyp = <:ctyp< $lid:tname$ >> in
+            let sitems' = <:str_item<
+                      $non_meths$
+                      class $lid:tname$ = object
+                        $meths$
+                        method $tname$ = (t :> $tnametyp$  t )
+                      end >>
+            in
+            let meStr = <:module_expr@sloc< struct $sitems'$ end >> in
+            <:str_item@mloc< module $modname$ = $meStr$ >>
+
         | sitem -> sitem
     end
     in AstFilters.register_str_item_filter simplify#str_item
+camlp4of ./pa_opycaml.cmo -impl ../autoapi.mlp 
+

File pa/test.txt

-camlp4of ./pa_opycaml.cmo ../autoapi.ml 
 
 type _Closure = [_Object | `_Closure]
 
-(** the Python Object type *)
-type 'a t
+(** the Python Object type. It is contravariant, since object with richer interface can be poorer *)
+type -'a t
 
 type unit_or_fail = unit
 type bool_or_fail = bool