Commit f1235de1 authored by Pietro Abate's avatar Pietro Abate

New syntax for parametric types

now we can write types as
type t( 'a) = <a>'a

and patterns can contain type instantiations
let f = fun (t('a) -> [ t('a)* ]) x -> [ x ];;
let id = fun (t(Int) -> [ t(Int)* ]) x -> [ x ];;

Note: parametric types must be written as "IDENT(" without space.
parent 49d173b7
open Cduce_loc
open Ident
exception InconsistentCrc of U.t
exception InvalidObject of string
exception CannotOpen of string
......@@ -23,13 +22,11 @@ type t = {
mutable exts: Value.t array;
mutable depends: (U.t * string) list;
mutable status: [ `Evaluating | `Unevaluated | `Evaluated ];
}
let digest c = match c.digest with None -> assert false | Some x -> x
module Tbl = Hashtbl.Make(U)
let tbl = Tbl.create 64
......@@ -117,7 +114,6 @@ let set_hash c =
Compunit.set_hash c.descr (succ max_rank) h
(* This invalidates all hash tables on types ! *)
let compile_save verbose name src out =
protect_op "Save compilation unit";
......
......@@ -12,7 +12,6 @@ let () = Grammar.error_verbose := true
let tloc (i,j) = (i,j)
let nopos = (-1,-1)
let mk loc x = Cduce_loc.mk_located (tloc loc) x
exception Error of string
......@@ -59,7 +58,6 @@ let rec tuple = function
let tuple_queue =
List.fold_right (fun x q -> Pair (x, q))
let char = mknoloc (Internal (Types.char Chars.any))
let string_regexp = Star (Elem char)
......@@ -71,7 +69,6 @@ let seq_of_string s =
in
aux (Encodings.Utf8.start_index s) (Encodings.Utf8.end_index s)
let parse_char loc s =
match seq_of_string s with
| [ c ] -> c
......@@ -109,7 +106,6 @@ let is_capture =
| _ -> raise Stream.Failure
)
let if_then_else cond e1 e2 =
Match (cond, [(mk (0,0) (Cst (Atom (ident "true")))),e1;
(mk (0,0) (Cst (Atom (ident "false")))),e2])
......@@ -144,11 +140,10 @@ 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; 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)) ]
| "type"; x = PTYPE; pargs = LIST1 [ x = PVAR -> ident x ] SEP ","; ")"; "="; t = pat ->
[ mk _loc (TypeDecl ((lop _loc,ident x),pargs,t)) ]
| "type"; x = located_ident; "="; t = pat ->
[ mk _loc (TypeDecl (x,[],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 "." ->
......@@ -435,7 +430,6 @@ EXTEND Gram
`Path ids ]
];
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
......@@ -576,8 +570,7 @@ EXTEND Gram
Seq (Elem (mknoloc (Internal (Types.char c))), accu))
(seq_of_string s)
Epsilon ]
| [ e = pat LEVEL "simple" -> Elem e
]
| [ e = pat LEVEL "simple" -> Elem e ]
];
schema_ref: [
......@@ -597,7 +590,7 @@ EXTEND Gram
| "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" [ x = PTYPE ->
| "var" [ x = PVAR ->
mk _loc (Internal (Types.var (Var.mk (ident_aux x)))) ]
|
[ "{"; r = record_spec; "}" -> r
......@@ -612,10 +605,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 ".";
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))
| id = PTYPE; pargs = LIST1 pat SEP ","; ")" ->
mk _loc (PatVar ([ident id],pargs))
| ids = LIST1 ident_or_keyword SEP "." ->
mk _loc (PatVar (List.map ident ids,[]))
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
......@@ -636,8 +629,7 @@ EXTEND Gram
| "`"; c = tag_type -> c
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
q = [ ";"; q = pat -> Some q
| -> None ];
q = [ ";"; q = pat -> Some q | -> None ];
"]" ->
let r = match q with
| Some q ->
......
......@@ -51,6 +51,7 @@ type token =
| CHAR of string
| STRING of string
| STRING2 of string
| PVAR of string
| PTYPE of string
| EOI
......@@ -71,6 +72,7 @@ module Token = struct
| STRING s -> sf "STRING \"%s\"" s
| STRING2 s -> sf "STRING \'%s\'" s
(* here it's not %S since the string is already escaped *)
| PVAR s -> sf "PVAR \'%S\'" s
| PTYPE s -> sf "PTYPE \'%S\'" s
| ANY_IN_NS s -> sf "ANY_IN_NS %S" s
| EOI -> sf "EOI"
......@@ -84,7 +86,7 @@ module Token = struct
let extract_string =
function
| KEYWORD s | IDENT s | INT s | CHAR s | STRING s | STRING2 s | PTYPE s |
| PTYPE s | KEYWORD s | IDENT s | INT s | CHAR s | STRING s | STRING2 s | PVAR s |
ANY_IN_NS s -> s
| tok ->
invalid_arg ("Cannot extract a string from this token: "^
......@@ -178,7 +180,6 @@ let parse_char lexbuf base i =
done;
!r
let regexp ncname_char =
xml_letter | xml_digit | [ '-' '_' ] | xml_combining_char | xml_extender | "\\."
let regexp ncname = ( xml_letter ncname_char* ) | ('_' ncname_char+)
......@@ -203,6 +204,9 @@ let return_loc i j tok = (tok, (i,j))
let rec token = lexer
| xml_blank+ -> token lexbuf
| qname "(" ->
let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 1) in
return lexbuf (PTYPE s)
| qname ->
let s = L.utf8_lexeme lexbuf in
return lexbuf (IDENT s)
......@@ -214,7 +218,7 @@ let rec token = lexer
| '-'? ['0'-'9']+ ->
return lexbuf (INT (L.utf8_lexeme lexbuf))
| [ "<>=.,:;+-*/@&{}()|?`!$" ]
| "{["| "]}" | "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
| "->" | "::" | ";;" | "--" | "//" | "/@" | ":=" | "\\" | "++"
| "<=" | ">=" | "<<" | ">>" | "||" | "&&" | "**" | "_"
| ".."
| ["?+*"] "?" | "#" ->
......@@ -239,7 +243,7 @@ let rec token = lexer
| "'" ncname ->
let s = L.utf8_lexeme lexbuf in
let s = String.sub s 1 (String.length s - 1) in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "(*" ->
in_comment := true;
comment (L.lexeme_start lexbuf) lexbuf;
......@@ -257,6 +261,9 @@ let rec token = lexer
and token2 = lexer
| xml_blank+ -> token2 lexbuf
| qname "(" ->
let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 1) in
return lexbuf (PTYPE s)
| qname ->
let s = L.utf8_lexeme lexbuf in
return lexbuf (IDENT s)
......@@ -300,11 +307,11 @@ and token2 = lexer
(try String.index s '\t' with _ -> len))
(try String.index s ')' with _ -> len) in
let s = String.sub s 0 idend in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "'" ncname ->
let s = L.utf8_lexeme lexbuf in
let s = String.sub s 1 (String.length s - 1) in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "(*" ->
in_comment := true;
comment (L.lexeme_start lexbuf) lexbuf;
......@@ -322,6 +329,9 @@ and token2 = lexer
and token2toplevel = lexer
| xml_blank+ -> token2toplevel lexbuf
| qname "(" ->
let s = L.utf8_sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 1) in
return lexbuf (PTYPE s)
| qname ->
let s = L.utf8_lexeme lexbuf in
return lexbuf (IDENT s)
......@@ -365,11 +375,11 @@ and token2toplevel = lexer
(try String.index s '\t' with _ -> len))
(try String.index s ')' with _ -> len) in
let s = String.sub s 0 idend in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "'" ncname ->
let s = L.utf8_lexeme lexbuf in
let s = String.sub s 1 (String.length s - 1) in
return lexbuf (PTYPE s)
return lexbuf (PVAR s)
| "(*" ->
in_comment := true;
comment (L.lexeme_start lexbuf) lexbuf;
......
......@@ -8,6 +8,7 @@ type token =
| CHAR of string
| STRING of string
| STRING2 of string
| PVAR of string
| PTYPE of string
| EOI
......
......@@ -60,8 +60,8 @@ let pp_env ppf env =
|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,al) ->
Format.fprintf ppf "type %s %a = %a" s
(Utils.pp_list ~delim:("{[","]}") Var.pp) (Array.to_list 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
......
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