Commit 8c0a08c4 authored by Pietro Abate's avatar Pietro Abate

Add syntax for parametric types

- type t 'a = ('a,'a)
- type t ('a,'b) = ('a,'b)

Fix Typer.pp_env printer for types
Minor code refactring
parent 95a432f0
......@@ -370,8 +370,8 @@ let rec collect_funs accu = function
| rest -> (List.rev accu,rest)
let rec collect_types accu = function
| { descr = Ast.TypeDecl ((loc,x),t) } :: rest ->
collect_types ((loc,x,t) :: accu) rest
| { descr = Ast.TypeDecl (x,pl,t) } :: rest ->
collect_types ((x,pl,t) :: accu) rest
| rest -> (accu,rest)
let rec phrases ~run ~show ~directive =
......@@ -380,7 +380,7 @@ let rec phrases ~run ~show ~directive =
| { descr = Ast.FunDecl _ } :: _ ->
let (funs,rest) = collect_funs [] phs in
loop (let_funs ~run ~show accu funs) rest
| { descr = Ast.TypeDecl (_,_) } :: _ ->
| { descr = Ast.TypeDecl (_,_,_) } :: _ ->
let (typs,rest) = collect_types [] phs in
loop (type_defs accu typs) rest
| { descr = Ast.SchemaDecl (name, uri); loc = loc } :: rest ->
......
......@@ -5,11 +5,14 @@ open Ident
type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ]
(* located ident *)
type lident = (Cduce_loc.loc * U.t)
type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of (Cduce_loc.loc * U.t) * ppat
| TypeDecl of (lident * U.t list * ppat)
| SchemaDecl of U.t * string
| LetDecl of ppat * pexpr
| FunDecl of pexpr
......@@ -86,17 +89,9 @@ and pexpr =
and label = U.t
and abstr = {
fun_name : (Cduce_loc.loc * U.t) option;
fun_name : lident option;
fun_iface : (ppat * ppat) list;
fun_body : branches
(* add deco : (sigma) symbolic representation of set type substitutions *)
(* plus a flag that is true if interesection of the free varbialbes of S that are not intruduced
* by the lambda astractions are domain of sigma.
* if oldvar(S) ^ dom(sigma) = empty then s < t else s[eval(sigma, env)] < t
* (biginter_{sigma_i \in eval} s (sigma_i) ) < t
*
* see Evaluation, section 5.3 Article part 1
* *)
}
and branches = (ppat * pexpr) list
......@@ -108,7 +103,7 @@ and ppat' =
| PatVar of U.t list
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (Cduce_loc.loc * U.t * ppat) list
| Recurs of ppat * (lident * U.t list * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
| And of ppat * ppat
......@@ -131,7 +126,7 @@ and regexp =
| Alt of regexp * regexp
| Star of regexp
| WeakStar of regexp
| SeqCapture of Cduce_loc.loc * U.t * regexp
| SeqCapture of lident * regexp
let pat_true = mknoloc (Internal Builtin_defs.true_type)
......
......@@ -144,7 +144,12 @@ EXTEND Gram
[ mk _loc (LetDecl (p,e)) ]
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
[ mk _loc (EvalStatement (exp _loc (let_in e1 p e2))) ]
| "type"; x = located_ident; "="; t = pat -> [ mk _loc (TypeDecl (x,t)) ]
| "type"; x = located_ident; pl =
[ p = PTYPE; "=" -> [ident p]
| "("; p = PTYPE; ","; pl = LIST1 [ x = PTYPE -> (ident x) ] SEP ","; ")"; "=" ->
(ident p)::pl
| "=" -> []
]; t = pat -> [ mk _loc (TypeDecl (x,pl,t)) ]
| "using"; name = IDENT; "="; cu = [ x = IDENT -> x | x = STRING -> x ] ->
[ mk _loc (Using (U.mk name, U.mk cu)) ]
| "open"; ids = LIST1 ident_or_keyword SEP "." ->
......@@ -306,7 +311,7 @@ EXTEND Gram
let tag = mk _loc (Internal (Types.atom Atoms.any)) in
let att = mk _loc (Internal Types.Record.any) in
let any = mk _loc (Internal Types.any) in
let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
let re = Star(Alt(SeqCapture((noloc,id_dummy),Elem p), Elem any)) in
let ct = mk _loc (Regexp re) in
let p = mk _loc (XmlT (tag, multi_prod _loc [att;ct])) in
exp _loc (Transform (e,[p, Var id_dummy]))
......@@ -338,7 +343,7 @@ EXTEND Gram
let tag = mknoloc (Internal (Types.atom Atoms.any)) in
let att = mknoloc (Internal Types.Record.any) in
let any = mknoloc (Internal Types.any) in
let re = (SeqCapture(noloc,y,Star(Elem(any)))) in
let re = (SeqCapture((noloc,y),Star(Elem(any)))) in
let ct = mknoloc (Regexp re) in
let children = mknoloc (XmlT (tag, multi_prod _loc [att;ct])) in
let capt = mknoloc (And (mknoloc (And (mknoloc (PatVar [id_dummy]),p)),children)) in
......@@ -476,7 +481,7 @@ EXTEND Gram
":"; tres = pat ;
"="; body = expr ->
`Compact (targ1,args,others,tres,body)
] ->
] ->
match res with
| `Classic (p2,a,b) -> (p1,p2)::a,b
| `Compact (targ1,args,others,tres,body) ->
......@@ -497,7 +502,8 @@ EXTEND Gram
others (tres,body) in
let (targ,arg) = mkfun ((p1,targ1) :: args) in
[(targ,tres)],[(arg,body)]
] ];
]
];
fun_decl: [
......@@ -531,7 +537,7 @@ EXTEND Gram
| Elem x, Elem y -> Elem (mk _loc (And (x,y)))
| _ -> error _loc "Conjunction not allowed in regular expression"
]
| [ a = IDENT; "::"; x = regexp -> SeqCapture (lop _loc,ident a,x) ]
| [ a = IDENT; "::"; x = regexp -> SeqCapture ((lop _loc,ident a),x) ]
| [ x = regexp; "*" -> Star x
| x = regexp; "*?" -> WeakStar x
| x = regexp; "+" -> Seq (x, Star x)
......@@ -595,15 +601,15 @@ EXTEND Gram
pat: [
[ x = pat; "where";
b = LIST1 [ (la,a) = located_ident; "="; y = pat -> (la,a,y) ] SEP "and" ->
b = LIST1 [ x = located_ident; "="; y = pat -> (x,[],y) ] SEP "and" ->
mk _loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk _loc (Arrow (x,y))
| x = pat; "@"; y = pat -> mk _loc (Concat (x,y))
| x = pat; "+"; y = pat -> mk _loc (Merge (x,y)) ]
| "no_arrow" [ x = pat; "|"; y = pat -> mk _loc (Or (x,y)) ]
| "simple" [ x = pat; "&"; y = pat -> mk _loc (And (x,y))
| x = pat; "\\"; y = pat -> mk _loc (Diff (x,y)) ]
| "var_typ" [ x = PTYPE ->
| x = pat; "\\"; y = pat -> mk _loc (Diff (x,y)) ]
| "var" [ x = PTYPE ->
mk _loc (Internal (Types.var (Var.mk (ident_aux x)))) ]
|
[ "{"; r = record_spec; "}" -> r
......@@ -653,9 +659,9 @@ EXTEND Gram
mk _loc (Regexp r)
| "<"; t =
[ x = tag_type -> x
| "("; t = pat; ")" -> t ];
a = attrib_spec; ">"; c = pat ->
mk _loc (XmlT (t, multi_prod _loc [a;c]))
| "("; t = pat; ")" -> t ];
a = attrib_spec; ">"; c = pat ->
mk _loc (XmlT (t, multi_prod _loc [a;c]))
| s = STRING ->
let s =
List.map
......@@ -673,12 +679,15 @@ EXTEND Gram
or_else : [ [ OPT [ "else"; y = pat -> y ] ] ];
opt_field_pat: [ [ OPT [ "=";
o = [ "?" -> true | -> false];
x = pat; y = or_else -> (o,x,y) ] ] ];
opt_field_pat: [
[ OPT [ "=";
o = [ "?" -> true | -> false];
x = pat; y = or_else -> (o,x,y) ]
]
];
record_spec:
[ [ r = LIST0 [ l = ident_or_keyword; f = opt_field_pat; OPT ";" ->
record_spec: [
[ r = LIST0 [ l = ident_or_keyword; f = opt_field_pat; OPT ";" ->
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar [ident l]), None)
......@@ -688,14 +697,14 @@ EXTEND Gram
(label l, (x,y))
]; op = [ ".." -> true | -> false ] ->
mk _loc (Record (op,r))
] ];
]
];
char:
[
[ c = CHAR -> Chars.V.mk_int (parse_char _loc c)
| c = STRING2 -> Chars.V.mk_int (parse_char _loc c) ]
char: [
[ c = CHAR -> Chars.V.mk_int (parse_char _loc c)
| c = STRING2 -> Chars.V.mk_int (parse_char _loc c) ]
];
];
attrib_spec: [
......
......@@ -171,7 +171,7 @@ let load_schema schema_name uri =
let schema_name = schema_name ^ "." in
let log_schema_component kind name cd_type =
if not (Schema_builtin.is name) then begin
Types.Print.register_global schema_name name cd_type;
Types.Print.register_global (schema_name,name) cd_type;
(* Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind
Ns.QName.print name; *)
......
......@@ -32,7 +32,7 @@ let env =
List.fold_left
(fun accu (n,t) ->
let n = (Ns.empty, Ident.U.mk n) in
Types.Print.register_global "" n t;
Types.Print.register_global ("",n) t;
Typer.enter_type (Ident.ident n) t accu
)
Typer.empty_env
......
This diff is collapsed.
......@@ -329,9 +329,9 @@ val cond_partition: t -> (t * t) list -> t list
The result is a partition of the first argument which is precise enough
to answer all the questions. *)
module Print :
sig
val register_global : string -> Ns.QName.t -> t -> unit
module Print : sig
type gname = string * Ns.QName.t
val register_global : gname -> t -> unit
val pp_const : Format.formatter -> const -> unit
val pp_type: Format.formatter -> t -> unit
val pp_node: Format.formatter -> Node.t -> unit
......@@ -344,8 +344,7 @@ sig
val printf : t -> unit
end
module Service :
sig
module Service : sig
val to_service_params: t -> service_params
val to_string: service_params -> string
end
......
......@@ -58,7 +58,7 @@ type t = {
let pp_env ppf env =
let pp_item ppf (s,t) = match t with
|Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
|Type t -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_type t
|Type t -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
|_ -> ()
in
let t = [
......@@ -185,9 +185,10 @@ let iter_values env f =
| _ -> ()) env.ids
let register_types cu env =
Env.iter (fun x t -> match t with
| Type t -> Types.Print.register_global cu (Ident.value x) t
| _ -> ()) env.ids
Env.iter (fun x -> function
| Type t -> Types.Print.register_global (cu,(Ident.value x)) t
| _ -> ()
) env.ids
let rec const env loc = function
| LocatedExpr (loc,e) -> const env loc e
......@@ -365,7 +366,7 @@ module IType = struct
| Alt (p1,p2) -> mk_alt (derecurs_regexp env p1) (derecurs_regexp env p2)
| Star p -> mk_star (derecurs_regexp env p)
| WeakStar p -> mk_weakstar (derecurs_regexp env p)
| SeqCapture (loc,x,p) -> mk_seqcapt (ident env.penv_tenv loc x) (derecurs_regexp env p)
| SeqCapture ((loc,x),p) -> mk_seqcapt (ident env.penv_tenv loc x) (derecurs_regexp env p)
and derecurs_var env loc ids =
match ids with
......@@ -381,17 +382,16 @@ module IType = struct
and derecurs_def env b =
let seen = ref IdSet.empty in
let b =
List.map
(fun (loc,v,p) ->
List.map (fun ((loc,v),_,p) ->
let v = ident env.penv_tenv loc v in
if IdSet.mem !seen v then
raise_loc_generic loc
("Multiple definitions for the type identifer " ^
(Ident.to_string v));
seen := IdSet.add v !seen;
(v,p,delayed loc))
b in
(v,p,delayed loc)
) b
in
let n = List.fold_left (fun env (v,p,s) -> Env.add v s env) env.penv_derec b in
let env = { env with penv_derec = n } in
List.iter (fun (v,p,s) -> link s (derecurs env p)) b;
......@@ -424,14 +424,15 @@ module IType = struct
with Patterns.Error s -> raise_loc_generic loc s
in
let b =
List.map2
(fun (loc,v,p) (v',_,d) ->
let t = aux loc d in
if (loc <> noloc) && (Types.is_empty t) then
warning loc
("This definition yields an empty type for " ^ (U.to_string v));
(v',t)) b b' in
List.iter (fun (v,t) -> Types.Print.register_global "" v t) b;
List.map2 (fun ((loc,v),_,p) (v',_,d) ->
let t = aux loc d in
if (loc <> noloc) && (Types.is_empty t) then
warning loc
("This definition yields an empty type for " ^ (U.to_string v));
(v',t)
) b b'
in
List.iter (fun (v,t) -> Types.Print.register_global ("",v) t) b;
enter_types b env
let type_defs env b =
......
......@@ -38,7 +38,8 @@ val type_keep_ns : t -> bool -> t
val type_expr: t -> Ast.pexpr -> Typed.texpr * Types.descr
val type_defs: t -> (Cduce_loc.loc * U.t * Ast.ppat) list -> t
(* val type_defs: t -> (Cduce_loc.loc * U.t * Ast.ppat) list -> t *)
val type_defs: t -> (Ast.lident * U.t list * Ast.ppat) list -> t
val type_let_decl: t -> Ast.ppat -> Ast.pexpr ->
t * Typed.let_decl * (id * Types.t) list
......
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