Commit 0d3a9e60 authored by Pietro Abate's avatar Pietro Abate

Add parametric type to patterns

- change syntax to avoid conflicts ( tried "((", "[<", "<[", "(" )
   type t {[ 'a,'b ]} = (Int,[ 'b* ]) ;;
   let app (f : 'a -> t {[Int,Int]} )(a : 'a) : t = f a;;
parent 8c0a08c4
......@@ -100,7 +100,7 @@ and branches = (ppat * pexpr) list
and ppat = ppat' located
and ppat' =
| PatVar of U.t list
| PatVar of (U.t list * ppat list)
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (lident * U.t list * ppat) list
......@@ -128,7 +128,6 @@ and regexp =
| WeakStar of regexp
| SeqCapture of lident * regexp
let pat_true = mknoloc (Internal Builtin_defs.true_type)
let pat_false = mknoloc (Internal Builtin_defs.false_type)
let cst_true = Const (Types.Atom Builtin_defs.true_atom)
......
......@@ -144,12 +144,11 @@ 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; 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)) ]
| "type"; x = located_ident; pargs = OPT
[ "{["; pl = LIST0 [ x = PTYPE -> ident x ] SEP ","; "]}" -> pl ];
"="; t = pat ->
let pargs = match pargs with None -> [] | Some l -> l in
[ mk _loc (TypeDecl (x,pargs,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 "." ->
......@@ -285,26 +284,21 @@ EXTEND Gram
exp _loc (Ref (e,p))
| "not"; e = expr -> exp _loc (logical_not e)
]
|
[ e1 = expr; ":="; e2 = expr -> exp _loc (set_ref e1 e2)
]
|
[ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr ->
| [ e1 = expr; ":="; e2 = expr -> exp _loc (set_ref e1 e2) ]
| [ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr ->
let op = match op with
| "<<" -> "<"
| ">>" -> ">"
| s -> s in
| s -> s
in
apply_op2 _loc op e1 e2
]
|
[ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> apply_op2 _loc op e1 e2
| [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> apply_op2 _loc op e1 e2
| e1 = expr; ["||" | "or"]; e2 = expr -> exp _loc (logical_or e1 e2)
| e = expr; "\\"; l = ident_or_keyword ->
exp _loc (RemoveField (e, label l))
]
|
[ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 _loc op e1 e2
| [ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 _loc op e1 e2
| e1 = expr; "&&"; e2 = expr -> exp _loc (logical_and e1 e2)
| e = expr; op = "/"; p = pat LEVEL "simple" ->
(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
......@@ -313,16 +307,13 @@ EXTEND Gram
let any = mk _loc (Internal Types.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
let p = mk _loc (XmlT (tag, multi_prod _loc [att;ct])) in
exp _loc (Transform (e,[p, Var id_dummy]))
| e = expr; "/@"; a = ident_or_keyword ->
(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
let tag = mk _loc (Internal (Types.atom Atoms.any)) in
let any = mk _loc (Internal Types.any) in
let att = mk _loc (Record
(true, [(label a,
(mk _loc (PatVar [id_dummy]),
None))])) in
let att = mk _loc (Record (true, [(label a, (mk _loc (PatVar([id_dummy],[])), None))])) in
let p = mk _loc (XmlT (tag, multi_prod _loc [att;any])) in
let t = (p, Pair (Var id_dummy,cst_nil)) in
exp _loc (Transform (e,[t]))
......@@ -337,27 +328,27 @@ EXTEND Gram
let x = U.mk "x" in
let f = U.mk "f" in
let assign =
set_ref
(Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
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 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
let assign = seq assign ( (Apply(Var(f) , Var(y) ) ) ) in
let xt = Xtrans ((Var x),[capt,assign]) in
let rf = Ref (cst_nil, mknoloc (Regexp (Star(Elem p)))) in
let targ = mknoloc (Regexp(Star(Elem(any)))) in
let tres = targ in
let arg = mknoloc(PatVar [x]) in
let abst = {fun_name = Some (lop _loc,ident "f") ; fun_iface = [(targ, tres)] ;fun_body = [(arg,xt)] } in
let body =
let_in rf (mknoloc (PatVar [stk]))
(let_in ((Abstraction abst)) (mknoloc (PatVar[ident "f"]))
(let_in ((Apply(Var(f) , e) ) ) (mknoloc (Internal Types.any)) (get_ref (Var stk))))
set_ref
(Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
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 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
let assign = seq assign ((Apply(Var(f),Var(y)))) in
let xt = Xtrans ((Var x),[capt,assign]) in
let rf = Ref (cst_nil, mknoloc (Regexp (Star(Elem p)))) in
let targ = mknoloc (Regexp(Star(Elem(any)))) in
let tres = targ in
let arg = mknoloc(PatVar ([x],[])) in
let abst = {fun_name = Some (lop _loc,ident "f") ; fun_iface = [(targ, tres)] ;fun_body = [(arg,xt)] } in
let body =
let_in rf (mknoloc (PatVar ([stk],[])))
(let_in ((Abstraction abst)) (mknoloc (PatVar ([ident "f"],[])))
(let_in ((Apply(Var(f) , e) ) ) (mknoloc (Internal Types.any)) (get_ref (Var stk))))
in
exp _loc body
]
......@@ -367,9 +358,7 @@ EXTEND Gram
| e1 = SELF; e2 = expr -> exp _loc (Apply (e1,e2))
]
| "no_appl"
[ e = expr; "."; l = ident_or_keyword;
| "no_appl" [ e = expr; "."; l = ident_or_keyword;
tyargs = [ "with"; "{"; tyargs = LIST0 pat; "}" -> Some tyargs
| -> None ] ->
let e = Dot (e,label l) in
......@@ -450,7 +439,7 @@ EXTEND Gram
let_binding: [
[ "let"; is_fun_decl; OPT "fun"; (f,a,b) = fun_decl ->
let f = match f with Some x -> x | None -> assert false in
let p = mk _loc (PatVar [snd f]) in
let p = mk _loc (PatVar([snd f],[])) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
let e = exp _loc (Abstraction abst) in
(true,p,e)
......@@ -462,7 +451,7 @@ EXTEND Gram
];
fun_decl_after_lparen: [
(* need an hack to do this, because both productions would
(* need an hack to do this, because both productions would
match [ OPT IDENT; "("; pat ] .... *)
[ p1 = pat LEVEL "no_arrow";
res = [ "->"; p2 = pat;
......@@ -524,7 +513,6 @@ EXTEND Gram
[ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
];
regexp: [
[ x = regexp; "|"; y = regexp ->
match (x,y) with
......@@ -624,9 +612,10 @@ EXTEND Gram
mk _loc (Constant (ident a,c))
| "!"; a = IDENT ->
mk _loc (Internal (Types.abstract (Types.Abstracts.atom a)))
| ids = LIST1 ident_or_keyword SEP "." ->
let ids = List.map ident ids in
mk _loc (PatVar ids)
| ids = LIST1 ident_or_keyword SEP ".";
pargs = OPT [ "{["; pl = LIST0 [ x = pat -> x ] SEP ","; "]}" -> pl ] ->
let pargs = match pargs with None -> [] | Some l -> l in
mk _loc (PatVar (List.map ident ids,pargs))
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
......@@ -688,15 +677,15 @@ EXTEND Gram
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)
| Some z -> z
in
let x = if o then mk _loc (Optional x) else x in
(label l, (x,y))
]; op = [ ".." -> true | -> false ] ->
mk _loc (Record (op,r))
let (o,x,y) =
match f with
| None -> (false, mknoloc (PatVar([ident l],[])), None)
| Some z -> z
in
let x = if o then mk _loc (Optional x) else x in
(label l, (x,y))
]; op = [ ".." -> true | -> false ] ->
mk _loc (Record (op,r))
]
];
......@@ -714,20 +703,19 @@ EXTEND Gram
opt_field_expr: [ [ OPT [ "="; x = expr LEVEL "no_appl" -> x ] ] ];
expr_record_spec:
[ [ r = LIST0
[ l = ident_or_keyword;
x = opt_field_expr; OPT ";" ->
let x = match x with Some x -> x | None -> Var (ident l) in
(label l,x) ]
->
exp _loc (RecordLitt r)
] ];
expr_record_spec: [
[ r = LIST0 [ l = ident_or_keyword;
x = opt_field_expr; OPT ";" ->
let x = match x with Some x -> x | None -> Var (ident l) in
(label l,x) ] -> exp _loc (RecordLitt r)
]
];
expr_attrib_spec: [
[ e = expr_record_spec -> e
| "("; e = expr; ")" -> e
] ];
]
];
END
module Hook = struct
......
......@@ -214,7 +214,7 @@ let rec token = lexer
| '-'? ['0'-'9']+ ->
return lexbuf (INT (L.utf8_lexeme lexbuf))
| [ "<>=.,:;+-*/@&{}()|?`!$" ]
| "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
| "{["| "]}" | "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
| "<=" | ">=" | "<<" | ">>" | "||" | "&&" | "**" | "_"
| ".."
| ["?+*"] "?" | "#" ->
......
......@@ -37,7 +37,7 @@ type schema = {
type item =
(* These are really exported by CDuce units: *)
| Type of Types.t
| Type of (Types.t * Var.t array)
| Val of Types.t
| ECDuce of Compunit.t
| ESchema of schema
......@@ -58,7 +58,13 @@ 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_noname t
|Type (t,[||]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
|Type (t,[|a|]) ->
Format.fprintf ppf "type %s %a = %a" s Var.pp a Types.Print.pp_noname t
|Type (t,al) ->
Format.fprintf ppf "type %s %a = %a" s
(Utils.pp_list ~delim:("(",")") Var.pp) (Array.to_list al)
Types.Print.pp_noname t
|_ -> ()
in
let t = [
......@@ -141,10 +147,13 @@ let type_using env loc x cu =
with Not_found ->
error loc ("Cannot find external unit " ^ (U.to_string cu))
let enter_type id t env = enter_id id (Type t) env
let enter_type id t env = enter_id id (Type (t,[||])) env
let enter_types l env =
{ env with ids =
List.fold_left (fun accu (id,t) -> Env.add id (Type t) accu) env.ids l }
List.fold_left (fun accu (id,t,al) ->
Env.add id (Type (t,al)) accu
) env.ids l
}
let find_id env0 env loc head x =
let id = ident env0 loc x in
......@@ -186,7 +195,7 @@ let iter_values env f =
let register_types cu env =
Env.iter (fun x -> function
| Type t -> Types.Print.register_global (cu,(Ident.value x)) t
| Type (t,_) -> Types.Print.register_global (cu,(Ident.value x)) t
| _ -> ()
) env.ids
......@@ -217,10 +226,12 @@ let navig loc env0 (env,comp) id =
let env = !from_comp_unit cu in
let c =
try find_id env0 env loc false id
with Not_found -> error loc "Unbound identifier" in
with Not_found -> error loc "Unbound identifier"
in
let c = match c with
| Val t -> EVal (cu,ident env0 loc id,t)
| c -> c in
| c -> c
in
env,c
| EOCaml cu ->
let s = cu ^ "." ^ (U.get_str id) in
......@@ -262,7 +273,7 @@ let type_ns env loc p ns =
let find_global_type env loc ids =
match find_global env loc ids with
| Type t | ESchemaComponent (t,_) -> t
| Type (t,_) | ESchemaComponent (t,_) -> t
| _ -> error loc "This path does not refer to a type"
let find_global_schema_component env loc ids =
......@@ -272,7 +283,7 @@ let find_global_schema_component env loc ids =
let find_local_type env loc id =
match Env.find id env.ids with
| Type t -> t
| Type (t,_) -> t
| _ -> raise Not_found
let find_value id env =
......@@ -370,14 +381,16 @@ module IType = struct
and derecurs_var env loc ids =
match ids with
| [v] ->
| ([v],_) ->
let v = ident env.penv_tenv loc v in
(try Env.find v env.penv_derec
with Not_found ->
begin
try Env.find v env.penv_derec
with Not_found ->
try mk_type (find_local_type env.penv_tenv loc v)
with Not_found -> mk_capture v)
| ids ->
mk_type (find_global_type env.penv_tenv loc ids)
with Not_found -> mk_capture v
end
| (ids,_) ->
mk_type (find_global_type env.penv_tenv loc ids)
and derecurs_def env b =
let seen = ref IdSet.empty in
......@@ -424,15 +437,20 @@ module IType = struct
with Patterns.Error s -> raise_loc_generic loc s
in
let b =
List.map2 (fun ((loc,v),_,p) (v',_,d) ->
List.map2 (fun ((loc,v),pl,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)
let al =
let a = Array.make (List.length pl) (Var.mk "dummy")in
List.iteri (fun i v -> a.(i) <- Var.mk (Ident.U.to_string v)) pl;
a
in
(v',t,al)
) b b'
in
List.iter (fun (v,t) -> Types.Print.register_global ("",v) t) b;
List.iter (fun (v,t,_) -> Types.Print.register_global ("",v) t) b;
enter_types b env
let type_defs env b =
......
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