Commits

camlspotter  committed e720ef7 Merge

merge

  • Participants
  • Parent commits 8d295aa, 7b3185f
  • Branches dev

Comments (0)

Files changed (4)

File pa/pa_opycaml.ml

         let sitem = super#str_item sitem in
         match sitem with
         | Ast.StMod (mloc, modname, module_expr) ->
-            let cl_name underscore_name = 
+(* does not work
+        | <:str_item@mloc< module $modname$ = $module_expr$ >> ->
+*)
+            let _cl_name underscore_name = 
               "o" ^ underscore_name
               
             in
-            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) ->
+            | Ast.MeStr (sloc, sitems) ->
+(* does not work
+            | <:module_expr@sloc< struct $sitem$ end >> ->
+*)
+                let rec iter_sitems f = function
+                  | Ast.StSem (_, sitem1, sitem2) -> iter_sitems f sitem1; iter_sitems f sitem2
+                  | i -> f i
+                in 
+(* does not work
+                let rec iter_sitems f = function
+                  | <:str_item< $sitem1$ $sitem2$ >> -> iter_sitems f sitem1; iter_sitems f sitem2
+                  | i -> f i
+                in 
+*)
                 let non_meths = ref [] in
                 let meths = ref [] in
                 iter_sitems (fun si ->
                   match si with
                   | 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
+*)
+                      | <:ctyp<$lid:tname$>> when tname = "_" ^ modname -> meths := (name, loc, ty_rest) :: !meths
                       | _ -> non_meths := si :: !non_meths
                       end
                   | _ -> non_meths := si :: !non_meths
                 ) sitem;
                 let create_meth name loc ty_rest = 
-                  let rec args pos (f, st) = function
+                  let _loc = Ast.Loc.ghost in
+                  let var pos = Printf.sprintf "v%d" pos in
+                  let tv pos = Ast.TyQuo(_loc, Printf.sprintf "a%d" pos) in (* No ' required! *)
+                  let id = <:expr@loc< $lid:name$ >> in
+
+                  let rec args pos = 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 qvars, mty, absts, args = args (pos+1) ty in
+
+                        let v = <:expr<$lid:var pos$>> in
+                        let pat = var pos 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) >>
+                              | <:ctyp< $lid:clsname$ >> -> <:expr< $v$#$clsname$ >>
                               | _ -> v
                               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
-                    | <:ctyp@loc< $lid:cls$ t >> ->
-                        let cls = cl_name cls in 
-                        f <:expr@loc< new $lid:cls$ ($st$) >> 
-                    | _ -> f st
+                        
+                        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 = tv pos in
+                                  (* Strange, but < $ctyp$ : $ctyp$; ..> *)
+                                  let oty = <:ctyp< < $lid:clsname$ : $lid:clsname$ t ; .. > >> in
+                                  tv :: qvars, 
+                                  <:ctyp< $ Ast.TyAli(_loc, oty, tv) $ -> $mty$ >>
+                              | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
+                              end
+                          | _ -> qvars, <:ctyp< $argty$ -> $mty$ >>
+                        in
+                          
+
+                        qvars, mty, absts, args
+
+                    | mty -> [], mty, [], []
                   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$ >> 
+                  let qvars, mty, absts, args = args 0 ty_rest in (* X *)
+                  let q mty = function
+                    | [] -> mty
+                    | qvs ->
+                        let rec qapp = function
+                          | [] -> assert false
+                          | [qv] -> qv
+                          | qv::qvs -> Ast.TyApp(_loc, qv, qapp qvs) (* strange but it is as an app *)
+                        in
+                        Ast.TyPol (_loc, qapp qvs, mty)
+                  in
+                  let rec app b = function
+                    | [] -> b
+                    | e::es -> app <:expr< $b$ $e$ >> es
+                  in
+                  let rec abst b = function
+                    | [] -> b
+                    | v::vs -> <:expr< fun $lid:v$ -> $abst b vs$ >>
+                  in
+                  <:class_str_item@loc< method $name$ : $q mty qvars$ = $abst (app <:expr<$id$ t>> args) absts$ >> 
                 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
-*)
-                let non_meths = 
-                  List.fold_left (fun st si ->
-                    <:str_item< $si$ $st$ >>)
-                    <:str_item<>>
-                    (List.rev !non_meths)
-                in
-                let sitem' = <:str_item< $non_meths$ 
-                                         class o t = object
-                                           $meths$
-                                           method $tname$ = (t :> $tnametyp$ t )
-                                         end>>
-                in
-                Ast.StMod (mloc, modname, Ast.MeStr (x, sitem'))
+
+                begin match !meths with
+                | [] -> sitem
+                | _ ->
+                    let meths = 
+                      let _loc = Ast.Loc.ghost in
+                      List.fold_left (fun st (name, loc, ty_rest) -> 
+                        <:class_str_item< $create_meth name loc ty_rest$ $st$ >>)
+                      <:class_str_item<>> !meths
+                    in
+                    let _loc = Ast.Loc.ghost in
+                    let tname = "_" ^ modname in
+                    let tnametyp = <:ctyp< $lid:tname$ >> in
+                    let sitems' = <:str_item< 
+                      $sitems$
+                      class o t = object
+                        $meths$
+                        method $tname$ = (t :> $tnametyp$  t )
+                      end >>
+                    in
+                    let meStr = <:module_expr@sloc< struct $sitems'$ end >> in
+                    <:str_item@mloc< module $modname$ = $meStr$ >>
+                end
             | _ -> sitem
             end
         | sitem -> sitem
+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