16 val rebuild: theory -> T -> T |
16 val rebuild: theory -> T -> T |
17 val add_syntax: theory -> (bool * (string * typ * mixfix)) list -> T -> T |
17 val add_syntax: theory -> (bool * (string * typ * mixfix)) list -> T -> T |
18 val extern_term: (string -> xstring) -> theory -> T -> term -> term |
18 val extern_term: (string -> xstring) -> theory -> T -> term -> term |
19 end; |
19 end; |
20 |
20 |
21 structure LocalSyntax (* : LOCAL_SYNTAX *) = |
21 structure LocalSyntax: LOCAL_SYNTAX = |
22 struct |
22 struct |
23 |
23 |
24 (* datatype T *) |
24 (* datatype T *) |
25 |
25 |
26 datatype T = Syntax of |
26 datatype T = Syntax of |
27 {thy_syntax: Syntax.syntax, |
27 {thy_syntax: Syntax.syntax, |
28 local_syntax: Syntax.syntax, |
28 local_syntax: Syntax.syntax, |
29 mixfixes: (string * typ * mixfix) list * (string * typ * mixfix) list, |
29 mixfixes: (((string * bool) * string list list) * (string * typ * mixfix)) list, |
30 idents: string list * string list * string list}; |
30 idents: string list * string list * string list}; |
31 |
31 |
32 fun make_syntax (thy_syntax, local_syntax, mixfixes, idents) = |
32 fun make_syntax (thy_syntax, local_syntax, mixfixes, idents) = |
33 Syntax {thy_syntax = thy_syntax, local_syntax = local_syntax, |
33 Syntax {thy_syntax = thy_syntax, local_syntax = local_syntax, |
34 mixfixes = mixfixes, idents = idents}; |
34 mixfixes = mixfixes, idents = idents}; |
44 val structs_of = #1 o idents_of; |
44 val structs_of = #1 o idents_of; |
45 |
45 |
46 |
46 |
47 (* build syntax *) |
47 (* build syntax *) |
48 |
48 |
49 fun build_syntax thy (mixfixes as (mxs, mxs_output), idents as (structs, _, _)) = |
49 fun build_syntax thy (mixfixes, idents as (structs, _, _)) = |
50 let |
50 let |
51 val thy_syntax = Sign.syn_of thy; |
51 val thy_syntax = Sign.syn_of thy; |
52 val is_logtype = Sign.is_logtype thy; |
52 val is_logtype = Sign.is_logtype thy; |
53 val (atrs, trs, trs', atrs') = Syntax.struct_trfuns structs; |
53 val (atrs, trs, trs', atrs') = Syntax.struct_trfuns structs; |
54 val local_syntax = thy_syntax |
54 val local_syntax = thy_syntax |
55 |> Syntax.extend_trfuns |
55 |> Syntax.extend_trfuns |
56 (map Syntax.mk_trfun atrs, map Syntax.mk_trfun trs, |
56 (map Syntax.mk_trfun atrs, map Syntax.mk_trfun trs, |
57 map Syntax.mk_trfun trs', map Syntax.mk_trfun atrs') |
57 map Syntax.mk_trfun trs', map Syntax.mk_trfun atrs') |
58 |> Syntax.extend_const_gram is_logtype ("", false) mxs_output |
58 |> Syntax.extend_const_gram is_logtype ("", false) |
59 |> Syntax.extend_const_gram is_logtype ("", true) mxs; |
59 (map (fn (((x, _), _), (c, T, _)) => (c, T, Syntax.literal x)) mixfixes) |
|
60 |> Syntax.extend_const_gram is_logtype ("", true) (map snd mixfixes) |
60 in make_syntax (thy_syntax, local_syntax, mixfixes, idents) end |
61 in make_syntax (thy_syntax, local_syntax, mixfixes, idents) end |
61 |
62 |
62 fun init thy = build_syntax thy (([], []), ([], [], [])); |
63 fun init thy = build_syntax thy ([], ([], [], [])); |
63 |
64 |
64 fun rebuild thy (syntax as Syntax {mixfixes, idents, ...}) = |
65 fun rebuild thy (syntax as Syntax {mixfixes, idents, ...}) = |
65 if is_consistent thy syntax then syntax |
66 if is_consistent thy syntax then syntax |
66 else build_syntax thy (mixfixes, idents); |
67 else build_syntax thy (mixfixes, idents); |
67 |
68 |
68 |
69 |
69 (* mixfix declarations *) |
70 (* mixfix declarations *) |
70 |
71 |
71 local |
72 local |
72 |
73 |
73 fun mixfix_conflict (mx1, (_, _, mx2)) = Syntax.mixfix_conflict (mx1, mx2); |
74 fun mixfix_nosyn (_, (_, _, mx)) = mx = NoSyn; |
74 fun mixfix_proper (_, _, mx) = mx <> NoSyn andalso mx <> Structure; |
75 fun mixfix_struct (_, (_, _, mx)) = mx = Structure; |
75 |
76 |
76 fun mixfix_output (c, T, _) = |
77 fun mixfix_conflict (content1: string list list, ((_, content2), _)) = |
77 let val c' = unprefix Syntax.fixedN c handle Fail _ => unprefix Syntax.constN c |
78 exists (fn x => exists (fn y => x = y) content2) content1; |
78 in (c, T, Syntax.literal c') end; |
79 |
|
80 fun add_mixfix (fixed, (x, T, mx)) = |
|
81 let |
|
82 val content = Syntax.mixfix_content mx; |
|
83 val c = if fixed then Syntax.fixedN ^ x else Syntax.constN ^ x; |
|
84 in remove mixfix_conflict content #> cons (((x, fixed), content), (c, T, mx)) end; |
|
85 |
|
86 fun prep_struct (fixed, (c, _, Structure)) = |
|
87 if fixed then SOME c |
|
88 else error ("Bad mixfix declaration for const: " ^ quote c) |
|
89 | prep_struct _ = NONE; |
79 |
90 |
80 in |
91 in |
81 |
92 |
82 fun add_syntax thy decls (Syntax {mixfixes = (mxs, _), idents = (structs, _, _), ...}) = |
93 fun add_syntax thy raw_decls (syntax as (Syntax {mixfixes, idents = (structs, _, _), ...})) = |
83 let |
94 (case filter_out mixfix_nosyn raw_decls of |
84 fun add_mx (fixed, (c, T, mx)) = |
95 [] => syntax |
85 remove mixfix_conflict mx #> |
96 | decls => |
86 cons (if fixed then Syntax.fixedN ^ c else Syntax.constN ^ c, T, mx); |
97 let |
87 val mxs' = mxs |> fold add_mx (filter (mixfix_proper o snd) decls); |
98 val mixfixes' = mixfixes |> fold add_mixfix (filter_out mixfix_struct decls); |
88 |
99 val fixes' = fold (fn (((x, true), _), _) => cons x | _ => I) mixfixes' []; |
89 val fixes' = List.mapPartial (try (unprefix Syntax.fixedN) o #1) mxs'; |
100 val consts' = fold (fn (((x, false), _), _) => cons x | _ => I) mixfixes' []; |
90 val consts' = List.mapPartial (try (unprefix Syntax.constN) o #1) mxs'; |
101 val structs' = structs @ List.mapPartial prep_struct decls; |
91 |
102 in build_syntax thy (mixfixes', (structs', fixes', consts')) end); |
92 fun prep_struct (fixed, (c, _, Structure)) = |
|
93 if fixed then SOME c |
|
94 else error ("Bad mixfix declaration for const: " ^ quote c) |
|
95 | prep_struct _ = NONE; |
|
96 val structs' = structs @ List.mapPartial prep_struct decls; |
|
97 in build_syntax thy ((mxs', map mixfix_output mxs'), (structs', fixes', consts')) end; |
|
98 |
103 |
99 end; |
104 end; |
100 |
105 |
101 |
106 |
102 (* extern_term *) |
107 (* extern_term *) |