Commit 97790713 authored by Mário Pereira's avatar Mário Pereira

Code extraction: extraction of type declarations (wip)

parent 0211e117
......@@ -25,9 +25,9 @@ Thi-Minh-Tuyen Nguyen <thi-minh-tuyen.nguyen@inria.fr> <nguyen@acces.lri.fr>
Thi-Minh-Tuyen Nguyen <thi-minh-tuyen.nguyen@inria.fr> <nguyenthiminhtuyen@minhtuyen.local>
Thi-Minh-Tuyen Nguyen <thi-minh-tuyen.nguyen@inria.fr> <thi-minh-tuyen.nguyen@inria.fr>
Andrei Paskevich <andrei@lri.fr> <andrei@tertium.org>
Mário José Parreira Pereira <mpereira@lri.fr> <mario.j.p.pereira@gmail.com>
Mário José Parreira Pereira <mpereira@lri.fr> <parreira@lri.fr>
Mário José Parreira Pereira <mpereira@lri.fr> <mpereira@lri.fr>
Mário Pereira <mpereira@lri.fr> <mario.j.p.pereira@gmail.com>
Mário Pereira <mpereira@lri.fr> <parreira@lri.fr>
Mário Pereira <mpereira@lri.fr> <mpereira@lri.fr>
Asma Tafat-Bouzid <atafat@lri.fr> <atafat@lri.fr>
Asma Tafat-Bouzid <atafat@lri.fr> <atafat@atafat-desktop.(none)>
Piotr Trojanek <piotr.trojanek@altran.com> <piotr.trojanek@gmail.com>
......@@ -122,7 +122,7 @@ module ML = struct
(* TODO add return type? *)
| Dexn of ident * ty option
let create_expr e_node e_ity e_effect =
let mk_expr e_node e_ity e_effect =
{ e_node = e_node; e_ity = e_ity; e_effect = e_effect }
(* TODO add here some smart constructors for ML expressions *)
......@@ -155,8 +155,20 @@ module Translate = struct
let vsty vs =
vs.vs_name, type_ vs.vs_ty
let type_args = (* point-free *)
List.map (fun x -> x.tv_name)
(** programs *)
(* individual types *)
let rec ity t =
match t.ity_node with
| Ityvar ({tv_name = tv}, _) ->
ML.Tvar tv
| Ityapp ({its_ts = ts}, itl, _) ->
ML.Tapp (ts.ts_name, List.map ity itl)
| _ -> (* TODO *) assert false
let pv_name pv = pv.pv_vs.vs_name
let pvty pv =
......@@ -172,11 +184,39 @@ module Translate = struct
match e.e_node with
| Evar pvs ->
let pv_id = pv_name pvs in
ML.create_expr (ML.Eident pv_id) e.e_ity e.e_effect
ML.mk_expr (ML.Eident pv_id) e.e_ity e.e_effect
| Elet (LDvar (pvs, e1), e2) ->
let ml_let = ML.ml_let (pv_name pvs) (expr e1) (expr e2) in
ML.create_expr ml_let e.e_ity e.e_effect
| _ -> assert false (* TODO *)
ML.mk_expr ml_let e.e_ity e.e_effect
| _ -> (* TODO *) assert false
let its_args ts = ts.its_ts.ts_args
let itd_name td = td.itd_its.its_ts.ts_name
let ddata_constructs = (* point-free *)
List.map (fun ({rs_cty = rsc} as rs) ->
rs.rs_name, List.map (fun {pv_vs = pv} -> type_ pv.vs_ty) rsc.cty_args)
(** Question pour Jean-Christophe et Andreï :
est-ce que vous pouriez m'expliquer le champ itd_fields,
utilisé dans une déclaration de type ? *)
(* type declarations/definitions *)
let tdef itd =
let s = itd.itd_its in
let id = itd_name itd in
let args = its_args s in
begin match s.its_def, itd.itd_constructors with
| None, [] ->
(* let args = its_args s in *)
ML.Dtype [id, type_args args, ML.Dabstract]
| None, cl ->
(* let args = its_args s in *)
ML.Dtype [id, type_args args, ML.Ddata (ddata_constructs cl)]
| Some t, _ ->
ML.Dtype [id, type_args args, ML.Dalias (ity t)]
(* | _ -> (\* TODO *\) assert false *)
end
(* program declarations *)
let pdecl pd =
......@@ -198,6 +238,8 @@ module Translate = struct
[]
| PDpure ->
[]
| PDtype itl ->
List.map tdef itl
| _ -> (* TODO *) assert false
(* unit module declarations *)
......
......@@ -16,7 +16,6 @@ open Format
open Pmodule
open Theory
open Ident
open Printer
open Pp
module Print = struct
......@@ -50,41 +49,42 @@ module Print = struct
let print_tv fmt tv =
fprintf fmt "'%s" (id_unique aprinter tv)
(** Types *)
let protect_on b s =
if b then "(" ^^ s ^^ ")" else s
let star fmt () = fprintf fmt " *@ "
let rec print_ty fmt = function
let rec print_ty ?(paren=false) fmt = function
| Tvar id ->
print_tv fmt id
| Ttuple [] ->
fprintf fmt "unit"
| Ttuple tl ->
fprintf fmt "%a" (print_list star print_ty) tl
fprintf fmt (protect_on paren "%a") (print_list star (print_ty ~paren:false)) tl
| Tapp (ts, []) ->
print_ident fmt ts
| Tapp (ts, [ty]) ->
fprintf fmt "%a@ %a" print_ty ty print_ident ts
fprintf fmt (protect_on paren "%a@ %a")
(print_ty ~paren:true) ty print_ident ts
| Tapp (ts, tl) ->
fprintf fmt "(%a)@ %a"
(print_list comma print_ty) tl
fprintf fmt (protect_on paren "(%a)@ %a")
(print_list comma (print_ty ~paren:false)) tl
print_ident ts
let print_vsty fmt (v, ty) =
fprintf fmt "%a:@ %a" print_ident v print_ty ty
fprintf fmt "%a:@ %a" print_ident v (print_ty ~paren:false) ty
let print_tv_arg = print_tv
let print_tv_args fmt = function
| [] -> ()
| [tv] -> fprintf fmt "%a@ " print_tv_arg tv
| tvl -> fprintf fmt "(%a)@ " (print_list comma print_tv_arg) tvl
let print_vs_arg fmt vs =
fprintf fmt "@[(%a)@]" print_vsty vs
let rec print_ty fmt = function
| Tvar id ->
print_tv fmt id
| Ttuple [] ->
fprintf fmt "unit"
| Ttuple tl ->
fprintf fmt "%a" (print_list star print_ty) tl
| Tapp (ts, []) ->
print_ident fmt ts
| _ -> assert false (* TODO *)
let print_path =
print_list dot pp_print_string (* point-free *)
......@@ -106,11 +106,39 @@ module Print = struct
print_ident id
print_expr e1
print_expr e2
| _ -> assert false (* TODO *)
| _ -> (* TODO *) assert false
and print_expr fmt e =
print_enode fmt e.e_node
let print_type_decl fmt (id, args, tydef) =
let print_constr fmt (id, constrs) =
match constrs with
| [] ->
fprintf fmt "@[<hov 4>| %a@]"
print_ident id (* FIXME: first letter must be uppercase
-> print_uident *)
| l ->
fprintf fmt "@[<hov 4>| %a of %a@]"
print_ident id (* FIXME: print_uident *)
(print_list star (print_ty ~paren:false)) l
in
let print_def fmt = function
| Dabstract ->
()
| Ddata csl ->
fprintf fmt " =@\n%a" (print_list newline print_constr) csl
| Dalias ty ->
fprintf fmt " =@ %a" (print_ty ~paren:false) ty
| _ -> (* TODO *) assert false
in
fprintf fmt "@[<hov 2>%s %a%a%a@]"
(if true then "type" else "and") (* FIXME: mutual recursive types *)
print_tv_args args
print_ident id (* FIXME: first letter must be lowercase
-> print_lident *)
print_def tydef
let print_decl fmt = function
| Dlet (isrec, [id, vl, e]) ->
fprintf fmt "@[<hov 2>%s %a@ %a =@ %a@]"
......@@ -119,7 +147,10 @@ module Print = struct
(print_list space print_vs_arg) vl
print_expr e;
fprintf fmt "@\n@\n"
| _ -> assert false (* TODO *)
| Dtype dl ->
print_list newline print_type_decl fmt dl;
fprintf fmt "@\n@\n"
| _ -> (* TODO *) assert false
end
......
......@@ -13,6 +13,16 @@ module M
= let y = x in
y
type t 'a 'b 'c 'd
type list 'a = Nil | Cons 'a (list 'a)
type btree 'a = E | N (btree 'a) 'a (btree 'a)
type ntree 'a = Empty | Node 'a (list 'a)
type list_int = list int
end
(*
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment