src/HOLCF/domain/extender.ML
changeset 15570 8d8c70b41bab
parent 15531 08c8dad8e399
child 15601 2de79f493856
equal deleted inserted replaced
15569:1b3115d1a8df 15570:8d8c70b41bab
    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