42 cons'' : ((string * mixfix * (bool*string*typ) list) list) list) sg = |
42 cons'' : ((string * mixfix * (bool*string*typ) list) list) list) sg = |
43 let |
43 let |
44 val defaultS = Sign.defaultS sg; |
44 val defaultS = Sign.defaultS sg; |
45 val test_dupl_typs = (case duplicates (map fst dtnvs) of |
45 val test_dupl_typs = (case duplicates (map fst dtnvs) of |
46 [] => false | dups => error ("Duplicate types: " ^ commas_quote dups)); |
46 [] => false | dups => error ("Duplicate types: " ^ commas_quote dups)); |
47 val test_dupl_cons = (case duplicates (map first (flat cons'')) of |
47 val test_dupl_cons = (case duplicates (map first (List.concat cons'')) of |
48 [] => false | dups => error ("Duplicate constructors: " |
48 [] => false | dups => error ("Duplicate constructors: " |
49 ^ commas_quote dups)); |
49 ^ commas_quote dups)); |
50 val test_dupl_sels = (case duplicates |
50 val test_dupl_sels = (case duplicates |
51 (map second (flat (map third (flat cons'')))) of |
51 (map second (List.concat (map third (List.concat cons'')))) of |
52 [] => false | dups => error("Duplicate selectors: "^commas_quote dups)); |
52 [] => false | dups => error("Duplicate selectors: "^commas_quote dups)); |
53 val test_dupl_tvars = exists(fn s=>case duplicates(map(fst o rep_TFree)s)of |
53 val test_dupl_tvars = exists(fn s=>case duplicates(map(fst o rep_TFree)s)of |
54 [] => false | dups => error("Duplicate type arguments: " |
54 [] => false | dups => error("Duplicate type arguments: " |
55 ^commas_quote dups)) (map snd dtnvs); |
55 ^commas_quote dups)) (map snd dtnvs); |
56 (* test for free type variables, illegal sort constraints on rhs, |
56 (* test for free type variables, illegal sort constraints on rhs, |
108 val sg'' = sign_of thy''; |
108 val sg'' = sign_of thy''; |
109 val cons''=map (map (upd_third (map (upd_third (str2typ sg''))))) cons'''; |
109 val cons''=map (map (upd_third (map (upd_third (str2typ sg''))))) cons'''; |
110 val eqs' = check_and_sort_domain (dtnvs,cons'') sg''; |
110 val eqs' = check_and_sort_domain (dtnvs,cons'') sg''; |
111 val thy' = thy'' |> Domain_Syntax.add_syntax (comp_dnam,eqs'); |
111 val thy' = thy'' |> Domain_Syntax.add_syntax (comp_dnam,eqs'); |
112 val dts = map (Type o fst) eqs'; |
112 val dts = map (Type o fst) eqs'; |
113 fun strip ss = drop (find_index_eq "'" ss +1, ss); |
113 fun strip ss = Library.drop (find_index_eq "'" ss +1, ss); |
114 fun typid (Type (id,_)) = |
114 fun typid (Type (id,_)) = |
115 let val c = hd (Symbol.explode (Sign.base_name id)) |
115 let val c = hd (Symbol.explode (Sign.base_name id)) |
116 in if Symbol.is_letter c then c else "t" end |
116 in if Symbol.is_letter c then c else "t" end |
117 | typid (TFree (id,_) ) = hd (strip (tl (Symbol.explode id))) |
117 | typid (TFree (id,_) ) = hd (strip (tl (Symbol.explode id))) |
118 | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id)); |
118 | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id)); |
129 Domain_Theorems.theorems (eq,eqs) thy0) (thy,eqs)) |
129 Domain_Theorems.theorems (eq,eqs) thy0) (thy,eqs)) |
130 |>>> Domain_Theorems.comp_theorems (comp_dnam, eqs); |
130 |>>> Domain_Theorems.comp_theorems (comp_dnam, eqs); |
131 in |
131 in |
132 theorems_thy |
132 theorems_thy |
133 |> Theory.add_path (Sign.base_name comp_dnam) |
133 |> Theory.add_path (Sign.base_name comp_dnam) |
134 |> (#1 o (PureThy.add_thmss [(("rews", flat rewss @ take_rews), [])])) |
134 |> (#1 o (PureThy.add_thmss [(("rews", List.concat rewss @ take_rews), [])])) |
135 |> Theory.parent_path |
135 |> Theory.parent_path |
136 end; |
136 end; |
137 |
137 |
138 |
138 |
139 |
139 |