remove gratuitous semicolons from ML code
authorhuffman
Tue Nov 30 14:21:57 2010 -0800 (2010-11-30)
changeset 408324352ca878c41
parent 40831 10aeee1d5b71
child 40833 4f130bd9e17e
remove gratuitous semicolons from ML code
src/HOL/HOLCF/Tools/Domain/domain.ML
src/HOL/HOLCF/Tools/Domain/domain_axioms.ML
src/HOL/HOLCF/Tools/Domain/domain_constructors.ML
src/HOL/HOLCF/Tools/Domain/domain_induction.ML
src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML
src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML
src/HOL/HOLCF/Tools/cont_consts.ML
src/HOL/HOLCF/Tools/cont_proc.ML
src/HOL/HOLCF/Tools/cpodef.ML
src/HOL/HOLCF/Tools/domaindef.ML
src/HOL/HOLCF/Tools/fixrec.ML
src/HOL/HOLCF/Tools/holcf_library.ML
     1.1 --- a/src/HOL/HOLCF/Tools/Domain/domain.ML	Tue Nov 30 14:01:49 2010 -0800
     1.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain.ML	Tue Nov 30 14:21:57 2010 -0800
     1.3 @@ -26,26 +26,26 @@
     1.4        ((string * sort) list * binding * mixfix *
     1.5         (binding * (bool * binding option * typ) list * mixfix) list) list
     1.6        -> theory -> theory
     1.7 -end;
     1.8 +end
     1.9  
    1.10  structure Domain :> DOMAIN =
    1.11  struct
    1.12  
    1.13 -open HOLCF_Library;
    1.14 +open HOLCF_Library
    1.15  
    1.16 -fun first  (x,_,_) = x;
    1.17 -fun second (_,x,_) = x;
    1.18 -fun third  (_,_,x) = x;
    1.19 +fun first  (x,_,_) = x
    1.20 +fun second (_,x,_) = x
    1.21 +fun third  (_,_,x) = x
    1.22  
    1.23  (* ----- calls for building new thy and thms -------------------------------- *)
    1.24  
    1.25  type info =
    1.26 -     Domain_Take_Proofs.iso_info list * Domain_Take_Proofs.take_induct_info;
    1.27 +     Domain_Take_Proofs.iso_info list * Domain_Take_Proofs.take_induct_info
    1.28  
    1.29  fun add_arity ((b, sorts, mx), sort) thy : theory =
    1.30    thy
    1.31    |> Sign.add_types [(b, length sorts, mx)]
    1.32 -  |> AxClass.axiomatize_arity (Sign.full_name thy b, sorts, sort);
    1.33 +  |> AxClass.axiomatize_arity (Sign.full_name thy b, sorts, sort)
    1.34  
    1.35  fun gen_add_domain
    1.36      (prep_sort : theory -> 'a -> sort)
    1.37 @@ -58,52 +58,52 @@
    1.38    let
    1.39      val dtnvs : (binding * typ list * mixfix) list =
    1.40        let
    1.41 -        fun prep_tvar (a, s) = TFree (a, prep_sort thy s);
    1.42 +        fun prep_tvar (a, s) = TFree (a, prep_sort thy s)
    1.43        in
    1.44          map (fn (vs, dbind, mx, _) =>
    1.45                  (dbind, map prep_tvar vs, mx)) raw_specs
    1.46 -      end;
    1.47 +      end
    1.48  
    1.49      fun thy_arity (dbind, tvars, mx) =
    1.50 -      ((dbind, map (snd o dest_TFree) tvars, mx), arg_sort false);
    1.51 +      ((dbind, map (snd o dest_TFree) tvars, mx), arg_sort false)
    1.52  
    1.53      (* this theory is used just for parsing and error checking *)
    1.54      val tmp_thy = thy
    1.55        |> Theory.copy
    1.56 -      |> fold (add_arity o thy_arity) dtnvs;
    1.57 +      |> fold (add_arity o thy_arity) dtnvs
    1.58  
    1.59      val dbinds : binding list =
    1.60 -        map (fn (_,dbind,_,_) => dbind) raw_specs;
    1.61 +        map (fn (_,dbind,_,_) => dbind) raw_specs
    1.62      val raw_rhss :
    1.63          (binding * (bool * binding option * 'b) list * mixfix) list list =
    1.64 -        map (fn (_,_,_,cons) => cons) raw_specs;
    1.65 +        map (fn (_,_,_,cons) => cons) raw_specs
    1.66      val dtnvs' : (string * typ list) list =
    1.67 -        map (fn (dbind, vs, mx) => (Sign.full_name thy dbind, vs)) dtnvs;
    1.68 +        map (fn (dbind, vs, mx) => (Sign.full_name thy dbind, vs)) dtnvs
    1.69  
    1.70 -    val all_cons = map (Binding.name_of o first) (flat raw_rhss);
    1.71 +    val all_cons = map (Binding.name_of o first) (flat raw_rhss)
    1.72      val test_dupl_cons =
    1.73        case duplicates (op =) all_cons of 
    1.74          [] => false | dups => error ("Duplicate constructors: " 
    1.75 -                                      ^ commas_quote dups);
    1.76 +                                      ^ commas_quote dups)
    1.77      val all_sels =
    1.78 -      (map Binding.name_of o map_filter second o maps second) (flat raw_rhss);
    1.79 +      (map Binding.name_of o map_filter second o maps second) (flat raw_rhss)
    1.80      val test_dupl_sels =
    1.81        case duplicates (op =) all_sels of
    1.82 -        [] => false | dups => error("Duplicate selectors: "^commas_quote dups);
    1.83 +        [] => false | dups => error("Duplicate selectors: "^commas_quote dups)
    1.84  
    1.85      fun test_dupl_tvars s =
    1.86        case duplicates (op =) (map(fst o dest_TFree)s) of
    1.87          [] => false | dups => error("Duplicate type arguments: " 
    1.88 -                                    ^commas_quote dups);
    1.89 -    val test_dupl_tvars' = exists test_dupl_tvars (map snd dtnvs');
    1.90 +                                    ^commas_quote dups)
    1.91 +    val test_dupl_tvars' = exists test_dupl_tvars (map snd dtnvs')
    1.92  
    1.93      val sorts : (string * sort) list =
    1.94 -      let val all_sorts = map (map dest_TFree o snd) dtnvs';
    1.95 +      let val all_sorts = map (map dest_TFree o snd) dtnvs'
    1.96        in
    1.97          case distinct (eq_set (op =)) all_sorts of
    1.98            [sorts] => sorts
    1.99          | _ => error "Mutually recursive domains must have same type parameters"
   1.100 -      end;
   1.101 +      end
   1.102  
   1.103      (* a lazy argument may have an unpointed type *)
   1.104      (* unless the argument has a selector function *)
   1.105 @@ -113,19 +113,19 @@
   1.106          else error ("Constructor argument type is not of sort " ^
   1.107                      Syntax.string_of_sort_global tmp_thy sort ^ ": " ^
   1.108                      Syntax.string_of_typ_global tmp_thy T)
   1.109 -      end;
   1.110 +      end
   1.111  
   1.112      (* test for free type variables, illegal sort constraints on rhs,
   1.113 -       non-pcpo-types and invalid use of recursive type;
   1.114 +       non-pcpo-types and invalid use of recursive type
   1.115         replace sorts in type variables on rhs *)
   1.116 -    val rec_tab = Domain_Take_Proofs.get_rec_tab thy;
   1.117 +    val rec_tab = Domain_Take_Proofs.get_rec_tab thy
   1.118      fun check_rec rec_ok (T as TFree (v,_))  =
   1.119          if AList.defined (op =) sorts v then T
   1.120          else error ("Free type variable " ^ quote v ^ " on rhs.")
   1.121        | check_rec rec_ok (T as Type (s, Ts)) =
   1.122          (case AList.lookup (op =) dtnvs' s of
   1.123            NONE =>
   1.124 -            let val rec_ok' = rec_ok andalso Symtab.defined rec_tab s;
   1.125 +            let val rec_ok' = rec_ok andalso Symtab.defined rec_tab s
   1.126              in Type (s, map (check_rec rec_ok') Ts) end
   1.127          | SOME typevars =>
   1.128            if typevars <> Ts
   1.129 @@ -135,114 +135,114 @@
   1.130            else if rec_ok then T
   1.131            else error ("Illegal indirect recursion of type " ^ 
   1.132                        quote (Syntax.string_of_typ_global tmp_thy T)))
   1.133 -      | check_rec rec_ok (TVar _) = error "extender:check_rec";
   1.134 +      | check_rec rec_ok (TVar _) = error "extender:check_rec"
   1.135  
   1.136      fun prep_arg (lazy, sel, raw_T) =
   1.137        let
   1.138 -        val T = prep_typ tmp_thy sorts raw_T;
   1.139 -        val _ = check_rec true T;
   1.140 -        val _ = check_pcpo (lazy, sel, T);
   1.141 -      in (lazy, sel, T) end;
   1.142 -    fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
   1.143 -    fun prep_rhs cons = map prep_con cons;
   1.144 +        val T = prep_typ tmp_thy sorts raw_T
   1.145 +        val _ = check_rec true T
   1.146 +        val _ = check_pcpo (lazy, sel, T)
   1.147 +      in (lazy, sel, T) end
   1.148 +    fun prep_con (b, args, mx) = (b, map prep_arg args, mx)
   1.149 +    fun prep_rhs cons = map prep_con cons
   1.150      val rhss : (binding * (bool * binding option * typ) list * mixfix) list list =
   1.151 -        map prep_rhs raw_rhss;
   1.152 +        map prep_rhs raw_rhss
   1.153  
   1.154 -    fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_upT T else T;
   1.155 +    fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_upT T else T
   1.156      fun mk_con_typ (bind, args, mx) =
   1.157 -        if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
   1.158 -    fun mk_rhs_typ cons = foldr1 mk_ssumT (map mk_con_typ cons);
   1.159 +        if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args)
   1.160 +    fun mk_rhs_typ cons = foldr1 mk_ssumT (map mk_con_typ cons)
   1.161  
   1.162 -    val absTs : typ list = map Type dtnvs';
   1.163 -    val repTs : typ list = map mk_rhs_typ rhss;
   1.164 +    val absTs : typ list = map Type dtnvs'
   1.165 +    val repTs : typ list = map mk_rhs_typ rhss
   1.166  
   1.167      val iso_spec : (binding * mixfix * (typ * typ)) list =
   1.168          map (fn ((dbind, _, mx), eq) => (dbind, mx, eq))
   1.169 -          (dtnvs ~~ (absTs ~~ repTs));
   1.170 +          (dtnvs ~~ (absTs ~~ repTs))
   1.171  
   1.172 -    val ((iso_infos, take_info), thy) = add_isos iso_spec thy;
   1.173 +    val ((iso_infos, take_info), thy) = add_isos iso_spec thy
   1.174  
   1.175      val (constr_infos, thy) =
   1.176          thy
   1.177            |> fold_map (fn ((dbind, cons), info) =>
   1.178                  Domain_Constructors.add_domain_constructors dbind cons info)
   1.179 -             (dbinds ~~ rhss ~~ iso_infos);
   1.180 +             (dbinds ~~ rhss ~~ iso_infos)
   1.181  
   1.182      val (take_rews, thy) =
   1.183          Domain_Induction.comp_theorems
   1.184 -          dbinds take_info constr_infos thy;
   1.185 +          dbinds take_info constr_infos thy
   1.186    in
   1.187      thy
   1.188 -  end;
   1.189 +  end
   1.190  
   1.191  fun define_isos (spec : (binding * mixfix * (typ * typ)) list) =
   1.192    let
   1.193      fun prep (dbind, mx, (lhsT, rhsT)) =
   1.194 -      let val (dname, vs) = dest_Type lhsT;
   1.195 -      in (map (fst o dest_TFree) vs, dbind, mx, rhsT, NONE) end;
   1.196 +      let val (dname, vs) = dest_Type lhsT
   1.197 +      in (map (fst o dest_TFree) vs, dbind, mx, rhsT, NONE) end
   1.198    in
   1.199      Domain_Isomorphism.domain_isomorphism (map prep spec)
   1.200 -  end;
   1.201 +  end
   1.202  
   1.203 -fun pcpo_arg lazy = if lazy then @{sort cpo} else @{sort pcpo};
   1.204 -fun rep_arg lazy = if lazy then @{sort predomain} else @{sort "domain"};
   1.205 +fun pcpo_arg lazy = if lazy then @{sort cpo} else @{sort pcpo}
   1.206 +fun rep_arg lazy = if lazy then @{sort predomain} else @{sort "domain"}
   1.207  
   1.208  fun read_sort thy (SOME s) = Syntax.read_sort_global thy s
   1.209 -  | read_sort thy NONE = Sign.defaultS thy;
   1.210 +  | read_sort thy NONE = Sign.defaultS thy
   1.211  
   1.212  (* Adapted from src/HOL/Tools/Datatype/datatype_data.ML *)
   1.213  fun read_typ thy sorts str =
   1.214    let
   1.215      val ctxt = ProofContext.init_global thy
   1.216 -      |> fold (Variable.declare_typ o TFree) sorts;
   1.217 -  in Syntax.read_typ ctxt str end;
   1.218 +      |> fold (Variable.declare_typ o TFree) sorts
   1.219 +  in Syntax.read_typ ctxt str end
   1.220  
   1.221  fun cert_typ sign sorts raw_T =
   1.222    let
   1.223      val T = Type.no_tvars (Sign.certify_typ sign raw_T)
   1.224 -      handle TYPE (msg, _, _) => error msg;
   1.225 -    val sorts' = Term.add_tfreesT T sorts;
   1.226 +      handle TYPE (msg, _, _) => error msg
   1.227 +    val sorts' = Term.add_tfreesT T sorts
   1.228      val _ =
   1.229        case duplicates (op =) (map fst sorts') of
   1.230          [] => ()
   1.231        | dups => error ("Inconsistent sort constraints for " ^ commas dups)
   1.232 -  in T end;
   1.233 +  in T end
   1.234  
   1.235  val add_domain =
   1.236 -    gen_add_domain (K I) cert_typ Domain_Axioms.add_axioms pcpo_arg;
   1.237 +    gen_add_domain (K I) cert_typ Domain_Axioms.add_axioms pcpo_arg
   1.238  
   1.239  val add_new_domain =
   1.240 -    gen_add_domain (K I) cert_typ define_isos rep_arg;
   1.241 +    gen_add_domain (K I) cert_typ define_isos rep_arg
   1.242  
   1.243  val add_domain_cmd =
   1.244 -    gen_add_domain read_sort read_typ Domain_Axioms.add_axioms pcpo_arg;
   1.245 +    gen_add_domain read_sort read_typ Domain_Axioms.add_axioms pcpo_arg
   1.246  
   1.247  val add_new_domain_cmd =
   1.248 -    gen_add_domain read_sort read_typ define_isos rep_arg;
   1.249 +    gen_add_domain read_sort read_typ define_isos rep_arg
   1.250  
   1.251  
   1.252  (** outer syntax **)
   1.253  
   1.254 -val _ = Keyword.keyword "lazy";
   1.255 -val _ = Keyword.keyword "unsafe";
   1.256 +val _ = Keyword.keyword "lazy"
   1.257 +val _ = Keyword.keyword "unsafe"
   1.258  
   1.259  val dest_decl : (bool * binding option * string) parser =
   1.260    Parse.$$$ "(" |-- Scan.optional (Parse.$$$ "lazy" >> K true) false --
   1.261      (Parse.binding >> SOME) -- (Parse.$$$ "::" |-- Parse.typ)  --| Parse.$$$ ")" >> Parse.triple1
   1.262      || Parse.$$$ "(" |-- Parse.$$$ "lazy" |-- Parse.typ --| Parse.$$$ ")"
   1.263      >> (fn t => (true,NONE,t))
   1.264 -    || Parse.typ >> (fn t => (false,NONE,t));
   1.265 +    || Parse.typ >> (fn t => (false,NONE,t))
   1.266  
   1.267  val cons_decl =
   1.268 -  Parse.binding -- Scan.repeat dest_decl -- Parse.opt_mixfix;
   1.269 +  Parse.binding -- Scan.repeat dest_decl -- Parse.opt_mixfix
   1.270  
   1.271  val domain_decl =
   1.272    (Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix) --
   1.273 -    (Parse.$$$ "=" |-- Parse.enum1 "|" cons_decl);
   1.274 +    (Parse.$$$ "=" |-- Parse.enum1 "|" cons_decl)
   1.275  
   1.276  val domains_decl =
   1.277    Scan.optional (Parse.$$$ "(" |-- (Parse.$$$ "unsafe" >> K true) --| Parse.$$$ ")") false --
   1.278 -    Parse.and_list1 domain_decl;
   1.279 +    Parse.and_list1 domain_decl
   1.280  
   1.281  fun mk_domain
   1.282      (unsafe : bool,
   1.283 @@ -252,15 +252,15 @@
   1.284      val specs : ((string * string option) list * binding * mixfix *
   1.285                   (binding * (bool * binding option * string) list * mixfix) list) list =
   1.286          map (fn (((vs, t), mx), cons) =>
   1.287 -                (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms;
   1.288 +                (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms
   1.289    in
   1.290      if unsafe
   1.291      then add_domain_cmd specs
   1.292      else add_new_domain_cmd specs
   1.293 -  end;
   1.294 +  end
   1.295  
   1.296  val _ =
   1.297    Outer_Syntax.command "domain" "define recursive domains (HOLCF)"
   1.298 -    Keyword.thy_decl (domains_decl >> (Toplevel.theory o mk_domain));
   1.299 +    Keyword.thy_decl (domains_decl >> (Toplevel.theory o mk_domain))
   1.300  
   1.301 -end;
   1.302 +end
     2.1 --- a/src/HOL/HOLCF/Tools/Domain/domain_axioms.ML	Tue Nov 30 14:01:49 2010 -0800
     2.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_axioms.ML	Tue Nov 30 14:21:57 2010 -0800
     2.3 @@ -18,44 +18,44 @@
     2.4        (binding * mixfix * (typ * typ)) list -> theory ->
     2.5        (Domain_Take_Proofs.iso_info list
     2.6         * Domain_Take_Proofs.take_induct_info) * theory
     2.7 -end;
     2.8 +end
     2.9  
    2.10  
    2.11  structure Domain_Axioms : DOMAIN_AXIOMS =
    2.12  struct
    2.13  
    2.14 -open HOLCF_Library;
    2.15 +open HOLCF_Library
    2.16  
    2.17 -infixr 6 ->>;
    2.18 -infix -->>;
    2.19 -infix 9 `;
    2.20 +infixr 6 ->>
    2.21 +infix -->>
    2.22 +infix 9 `
    2.23  
    2.24  fun axiomatize_isomorphism
    2.25      (dbind : binding, (lhsT, rhsT))
    2.26      (thy : theory)
    2.27      : Domain_Take_Proofs.iso_info * theory =
    2.28    let
    2.29 -    val abs_bind = Binding.suffix_name "_abs" dbind;
    2.30 -    val rep_bind = Binding.suffix_name "_rep" dbind;
    2.31 +    val abs_bind = Binding.suffix_name "_abs" dbind
    2.32 +    val rep_bind = Binding.suffix_name "_rep" dbind
    2.33  
    2.34      val (abs_const, thy) =
    2.35 -        Sign.declare_const ((abs_bind, rhsT ->> lhsT), NoSyn) thy;
    2.36 +        Sign.declare_const ((abs_bind, rhsT ->> lhsT), NoSyn) thy
    2.37      val (rep_const, thy) =
    2.38 -        Sign.declare_const ((rep_bind, lhsT ->> rhsT), NoSyn) thy;
    2.39 +        Sign.declare_const ((rep_bind, lhsT ->> rhsT), NoSyn) thy
    2.40  
    2.41 -    val x = Free ("x", lhsT);
    2.42 -    val y = Free ("y", rhsT);
    2.43 +    val x = Free ("x", lhsT)
    2.44 +    val y = Free ("y", rhsT)
    2.45  
    2.46      val abs_iso_eqn =
    2.47 -        Logic.all y (mk_trp (mk_eq (rep_const ` (abs_const ` y), y)));
    2.48 +        Logic.all y (mk_trp (mk_eq (rep_const ` (abs_const ` y), y)))
    2.49      val rep_iso_eqn =
    2.50 -        Logic.all x (mk_trp (mk_eq (abs_const ` (rep_const ` x), x)));
    2.51 +        Logic.all x (mk_trp (mk_eq (abs_const ` (rep_const ` x), x)))
    2.52  
    2.53 -    val abs_iso_bind = Binding.qualified true "abs_iso" dbind;
    2.54 -    val rep_iso_bind = Binding.qualified true "rep_iso" dbind;
    2.55 +    val abs_iso_bind = Binding.qualified true "abs_iso" dbind
    2.56 +    val rep_iso_bind = Binding.qualified true "rep_iso" dbind
    2.57  
    2.58 -    val (abs_iso_thm, thy) = Specification.axiom ((abs_iso_bind, []), abs_iso_eqn) thy;
    2.59 -    val (rep_iso_thm, thy) = Specification.axiom ((rep_iso_bind, []), rep_iso_eqn) thy;
    2.60 +    val (abs_iso_thm, thy) = Specification.axiom ((abs_iso_bind, []), abs_iso_eqn) thy
    2.61 +    val (rep_iso_thm, thy) = Specification.axiom ((rep_iso_bind, []), rep_iso_eqn) thy
    2.62  
    2.63      val result =
    2.64          {
    2.65 @@ -65,74 +65,74 @@
    2.66            rep_const = rep_const,
    2.67            abs_inverse = Drule.export_without_context abs_iso_thm,
    2.68            rep_inverse = Drule.export_without_context rep_iso_thm
    2.69 -        };
    2.70 +        }
    2.71    in
    2.72      (result, thy)
    2.73 -  end;
    2.74 +  end
    2.75  
    2.76  fun axiomatize_lub_take
    2.77      (dbind : binding, take_const : term)
    2.78      (thy : theory)
    2.79      : thm * theory =
    2.80    let
    2.81 -    val i = Free ("i", natT);
    2.82 -    val T = (fst o dest_cfunT o range_type o fastype_of) take_const;
    2.83 +    val i = Free ("i", natT)
    2.84 +    val T = (fst o dest_cfunT o range_type o fastype_of) take_const
    2.85  
    2.86      val lub_take_eqn =
    2.87 -        mk_trp (mk_eq (mk_lub (lambda i (take_const $ i)), mk_ID T));
    2.88 +        mk_trp (mk_eq (mk_lub (lambda i (take_const $ i)), mk_ID T))
    2.89  
    2.90 -    val lub_take_bind = Binding.qualified true "lub_take" dbind;
    2.91 +    val lub_take_bind = Binding.qualified true "lub_take" dbind
    2.92  
    2.93 -    val (lub_take_thm, thy) = Specification.axiom ((lub_take_bind, []), lub_take_eqn) thy;
    2.94 +    val (lub_take_thm, thy) = Specification.axiom ((lub_take_bind, []), lub_take_eqn) thy
    2.95    in
    2.96      (lub_take_thm, thy)
    2.97 -  end;
    2.98 +  end
    2.99  
   2.100  fun add_axioms
   2.101      (dom_eqns : (binding * mixfix * (typ * typ)) list)
   2.102      (thy : theory) =
   2.103    let
   2.104  
   2.105 -    val dbinds = map #1 dom_eqns;
   2.106 +    val dbinds = map #1 dom_eqns
   2.107  
   2.108      (* declare new types *)
   2.109      fun thy_type (dbind, mx, (lhsT, _)) =
   2.110 -        (dbind, (length o snd o dest_Type) lhsT, mx);
   2.111 -    val thy = Sign.add_types (map thy_type dom_eqns) thy;
   2.112 +        (dbind, (length o snd o dest_Type) lhsT, mx)
   2.113 +    val thy = Sign.add_types (map thy_type dom_eqns) thy
   2.114  
   2.115      (* axiomatize type constructor arities *)
   2.116      fun thy_arity (_, _, (lhsT, _)) =
   2.117 -        let val (dname, tvars) = dest_Type lhsT;
   2.118 -        in (dname, map (snd o dest_TFree) tvars, @{sort pcpo}) end;
   2.119 -    val thy = fold (AxClass.axiomatize_arity o thy_arity) dom_eqns thy;
   2.120 +        let val (dname, tvars) = dest_Type lhsT
   2.121 +        in (dname, map (snd o dest_TFree) tvars, @{sort pcpo}) end
   2.122 +    val thy = fold (AxClass.axiomatize_arity o thy_arity) dom_eqns thy
   2.123  
   2.124      (* declare and axiomatize abs/rep *)
   2.125      val (iso_infos, thy) =
   2.126          fold_map axiomatize_isomorphism
   2.127 -          (map (fn (dbind, _, eqn) => (dbind, eqn)) dom_eqns) thy;
   2.128 +          (map (fn (dbind, _, eqn) => (dbind, eqn)) dom_eqns) thy
   2.129  
   2.130      (* define take functions *)
   2.131      val (take_info, thy) =
   2.132          Domain_Take_Proofs.define_take_functions
   2.133 -          (dbinds ~~ iso_infos) thy;
   2.134 +          (dbinds ~~ iso_infos) thy
   2.135  
   2.136      (* declare lub_take axioms *)
   2.137      val (lub_take_thms, thy) =
   2.138          fold_map axiomatize_lub_take
   2.139 -          (dbinds ~~ #take_consts take_info) thy;
   2.140 +          (dbinds ~~ #take_consts take_info) thy
   2.141  
   2.142      (* prove additional take theorems *)
   2.143      val (take_info2, thy) =
   2.144          Domain_Take_Proofs.add_lub_take_theorems
   2.145 -          (dbinds ~~ iso_infos) take_info lub_take_thms thy;
   2.146 +          (dbinds ~~ iso_infos) take_info lub_take_thms thy
   2.147  
   2.148      (* define map functions *)
   2.149      val (map_info, thy) =
   2.150          Domain_Isomorphism.define_map_functions
   2.151 -          (dbinds ~~ iso_infos) thy;
   2.152 +          (dbinds ~~ iso_infos) thy
   2.153  
   2.154    in
   2.155      ((iso_infos, take_info2), thy)
   2.156 -  end;
   2.157 +  end
   2.158  
   2.159 -end; (* struct *)
   2.160 +end (* struct *)
     3.1 --- a/src/HOL/HOLCF/Tools/Domain/domain_constructors.ML	Tue Nov 30 14:01:49 2010 -0800
     3.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_constructors.ML	Tue Nov 30 14:21:57 2010 -0800
     3.3 @@ -30,18 +30,18 @@
     3.4        -> (binding * (bool * binding option * typ) list * mixfix) list
     3.5        -> Domain_Take_Proofs.iso_info
     3.6        -> theory
     3.7 -      -> constr_info * theory;
     3.8 -end;
     3.9 +      -> constr_info * theory
    3.10 +end
    3.11  
    3.12  
    3.13  structure Domain_Constructors :> DOMAIN_CONSTRUCTORS =
    3.14  struct
    3.15  
    3.16 -open HOLCF_Library;
    3.17 +open HOLCF_Library
    3.18  
    3.19 -infixr 6 ->>;
    3.20 -infix -->>;
    3.21 -infix 9 `;
    3.22 +infixr 6 ->>
    3.23 +infix -->>
    3.24 +infix 9 `
    3.25  
    3.26  type constr_info =
    3.27    {
    3.28 @@ -64,32 +64,32 @@
    3.29  
    3.30  (************************** miscellaneous functions ***************************)
    3.31  
    3.32 -val simple_ss = HOL_basic_ss addsimps simp_thms;
    3.33 +val simple_ss = HOL_basic_ss addsimps simp_thms
    3.34  
    3.35  val beta_rules =
    3.36    @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
    3.37 -  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
    3.38 +  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair}
    3.39  
    3.40 -val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
    3.41 +val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules)
    3.42  
    3.43  fun define_consts
    3.44      (specs : (binding * term * mixfix) list)
    3.45      (thy : theory)
    3.46      : (term list * thm list) * theory =
    3.47    let
    3.48 -    fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
    3.49 -    val decls = map mk_decl specs;
    3.50 -    val thy = Cont_Consts.add_consts decls thy;
    3.51 -    fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
    3.52 -    val consts = map mk_const decls;
    3.53 +    fun mk_decl (b, t, mx) = (b, fastype_of t, mx)
    3.54 +    val decls = map mk_decl specs
    3.55 +    val thy = Cont_Consts.add_consts decls thy
    3.56 +    fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T)
    3.57 +    val consts = map mk_const decls
    3.58      fun mk_def c (b, t, mx) =
    3.59 -      (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
    3.60 -    val defs = map2 mk_def consts specs;
    3.61 +      (Binding.suffix_name "_def" b, Logic.mk_equals (c, t))
    3.62 +    val defs = map2 mk_def consts specs
    3.63      val (def_thms, thy) =
    3.64 -      Global_Theory.add_defs false (map Thm.no_attributes defs) thy;
    3.65 +      Global_Theory.add_defs false (map Thm.no_attributes defs) thy
    3.66    in
    3.67      ((consts, def_thms), thy)
    3.68 -  end;
    3.69 +  end
    3.70  
    3.71  fun prove
    3.72      (thy : theory)
    3.73 @@ -103,45 +103,45 @@
    3.74        EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
    3.75    in
    3.76      Goal.prove_global thy [] [] goal tac
    3.77 -  end;
    3.78 +  end
    3.79  
    3.80  fun get_vars_avoiding
    3.81      (taken : string list)
    3.82      (args : (bool * typ) list)
    3.83      : (term list * term list) =
    3.84    let
    3.85 -    val Ts = map snd args;
    3.86 -    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
    3.87 -    val vs = map Free (ns ~~ Ts);
    3.88 -    val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
    3.89 +    val Ts = map snd args
    3.90 +    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts)
    3.91 +    val vs = map Free (ns ~~ Ts)
    3.92 +    val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs))
    3.93    in
    3.94      (vs, nonlazy)
    3.95 -  end;
    3.96 +  end
    3.97  
    3.98 -fun get_vars args = get_vars_avoiding [] args;
    3.99 +fun get_vars args = get_vars_avoiding [] args
   3.100  
   3.101  (************** generating beta reduction rules from definitions **************)
   3.102  
   3.103  local
   3.104    fun arglist (Const _ $ Abs (s, T, t)) =
   3.105        let
   3.106 -        val arg = Free (s, T);
   3.107 -        val (args, body) = arglist (subst_bound (arg, t));
   3.108 +        val arg = Free (s, T)
   3.109 +        val (args, body) = arglist (subst_bound (arg, t))
   3.110        in (arg :: args, body) end
   3.111 -    | arglist t = ([], t);
   3.112 +    | arglist t = ([], t)
   3.113  in
   3.114    fun beta_of_def thy def_thm =
   3.115        let
   3.116 -        val (con, lam) = Logic.dest_equals (concl_of def_thm);
   3.117 -        val (args, rhs) = arglist lam;
   3.118 -        val lhs = list_ccomb (con, args);
   3.119 -        val goal = mk_equals (lhs, rhs);
   3.120 -        val cs = ContProc.cont_thms lam;
   3.121 -        val betas = map (fn c => mk_meta_eq (c RS @{thm beta_cfun})) cs;
   3.122 +        val (con, lam) = Logic.dest_equals (concl_of def_thm)
   3.123 +        val (args, rhs) = arglist lam
   3.124 +        val lhs = list_ccomb (con, args)
   3.125 +        val goal = mk_equals (lhs, rhs)
   3.126 +        val cs = ContProc.cont_thms lam
   3.127 +        val betas = map (fn c => mk_meta_eq (c RS @{thm beta_cfun})) cs
   3.128        in
   3.129          prove thy (def_thm::betas) goal (K [rtac reflexive_thm 1])
   3.130 -      end;
   3.131 -end;
   3.132 +      end
   3.133 +end
   3.134  
   3.135  (******************************************************************************)
   3.136  (************* definitions and theorems for constructor functions *************)
   3.137 @@ -156,213 +156,213 @@
   3.138    let
   3.139  
   3.140      (* get theorems about rep and abs *)
   3.141 -    val abs_strict = iso_locale RS @{thm iso.abs_strict};
   3.142 +    val abs_strict = iso_locale RS @{thm iso.abs_strict}
   3.143  
   3.144      (* get types of type isomorphism *)
   3.145 -    val (rhsT, lhsT) = dest_cfunT (fastype_of abs_const);
   3.146 +    val (rhsT, lhsT) = dest_cfunT (fastype_of abs_const)
   3.147  
   3.148      fun vars_of args =
   3.149        let
   3.150 -        val Ts = map snd args;
   3.151 -        val ns = Datatype_Prop.make_tnames Ts;
   3.152 +        val Ts = map snd args
   3.153 +        val ns = Datatype_Prop.make_tnames Ts
   3.154        in
   3.155          map Free (ns ~~ Ts)
   3.156 -      end;
   3.157 +      end
   3.158  
   3.159      (* define constructor functions *)
   3.160      val ((con_consts, con_defs), thy) =
   3.161        let
   3.162 -        fun one_arg (lazy, T) var = if lazy then mk_up var else var;
   3.163 -        fun one_con (_,args,_) = mk_stuple (map2 one_arg args (vars_of args));
   3.164 -        fun mk_abs t = abs_const ` t;
   3.165 -        val rhss = map mk_abs (mk_sinjects (map one_con spec));
   3.166 +        fun one_arg (lazy, T) var = if lazy then mk_up var else var
   3.167 +        fun one_con (_,args,_) = mk_stuple (map2 one_arg args (vars_of args))
   3.168 +        fun mk_abs t = abs_const ` t
   3.169 +        val rhss = map mk_abs (mk_sinjects (map one_con spec))
   3.170          fun mk_def (bind, args, mx) rhs =
   3.171 -          (bind, big_lambdas (vars_of args) rhs, mx);
   3.172 +          (bind, big_lambdas (vars_of args) rhs, mx)
   3.173        in
   3.174          define_consts (map2 mk_def spec rhss) thy
   3.175 -      end;
   3.176 +      end
   3.177  
   3.178      (* prove beta reduction rules for constructors *)
   3.179 -    val con_betas = map (beta_of_def thy) con_defs;
   3.180 +    val con_betas = map (beta_of_def thy) con_defs
   3.181  
   3.182      (* replace bindings with terms in constructor spec *)
   3.183      val spec' : (term * (bool * typ) list) list =
   3.184 -      let fun one_con con (b, args, mx) = (con, args);
   3.185 -      in map2 one_con con_consts spec end;
   3.186 +      let fun one_con con (b, args, mx) = (con, args)
   3.187 +      in map2 one_con con_consts spec end
   3.188  
   3.189      (* prove exhaustiveness of constructors *)
   3.190      local
   3.191        fun arg2typ n (true,  T) = (n+1, mk_upT (TVar (("'a", n), @{sort cpo})))
   3.192 -        | arg2typ n (false, T) = (n+1, TVar (("'a", n), @{sort pcpo}));
   3.193 +        | arg2typ n (false, T) = (n+1, TVar (("'a", n), @{sort pcpo}))
   3.194        fun args2typ n [] = (n, oneT)
   3.195          | args2typ n [arg] = arg2typ n arg
   3.196          | args2typ n (arg::args) =
   3.197            let
   3.198 -            val (n1, t1) = arg2typ n arg;
   3.199 +            val (n1, t1) = arg2typ n arg
   3.200              val (n2, t2) = args2typ n1 args
   3.201 -          in (n2, mk_sprodT (t1, t2)) end;
   3.202 +          in (n2, mk_sprodT (t1, t2)) end
   3.203        fun cons2typ n [] = (n, oneT)
   3.204          | cons2typ n [con] = args2typ n (snd con)
   3.205          | cons2typ n (con::cons) =
   3.206            let
   3.207 -            val (n1, t1) = args2typ n (snd con);
   3.208 +            val (n1, t1) = args2typ n (snd con)
   3.209              val (n2, t2) = cons2typ n1 cons
   3.210 -          in (n2, mk_ssumT (t1, t2)) end;
   3.211 -      val ct = ctyp_of thy (snd (cons2typ 1 spec'));
   3.212 -      val thm1 = instantiate' [SOME ct] [] @{thm exh_start};
   3.213 -      val thm2 = rewrite_rule (map mk_meta_eq @{thms ex_bottom_iffs}) thm1;
   3.214 -      val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2;
   3.215 +          in (n2, mk_ssumT (t1, t2)) end
   3.216 +      val ct = ctyp_of thy (snd (cons2typ 1 spec'))
   3.217 +      val thm1 = instantiate' [SOME ct] [] @{thm exh_start}
   3.218 +      val thm2 = rewrite_rule (map mk_meta_eq @{thms ex_bottom_iffs}) thm1
   3.219 +      val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2
   3.220  
   3.221 -      val y = Free ("y", lhsT);
   3.222 +      val y = Free ("y", lhsT)
   3.223        fun one_con (con, args) =
   3.224          let
   3.225 -          val (vs, nonlazy) = get_vars_avoiding ["y"] args;
   3.226 -          val eqn = mk_eq (y, list_ccomb (con, vs));
   3.227 -          val conj = foldr1 mk_conj (eqn :: map mk_defined nonlazy);
   3.228 -        in Library.foldr mk_ex (vs, conj) end;
   3.229 -      val goal = mk_trp (foldr1 mk_disj (mk_undef y :: map one_con spec'));
   3.230 +          val (vs, nonlazy) = get_vars_avoiding ["y"] args
   3.231 +          val eqn = mk_eq (y, list_ccomb (con, vs))
   3.232 +          val conj = foldr1 mk_conj (eqn :: map mk_defined nonlazy)
   3.233 +        in Library.foldr mk_ex (vs, conj) end
   3.234 +      val goal = mk_trp (foldr1 mk_disj (mk_undef y :: map one_con spec'))
   3.235        (* first rules replace "y = UU \/ P" with "rep$y = UU \/ P" *)
   3.236        val tacs = [
   3.237            rtac (iso_locale RS @{thm iso.casedist_rule}) 1,
   3.238            rewrite_goals_tac [mk_meta_eq (iso_locale RS @{thm iso.iso_swap})],
   3.239 -          rtac thm3 1];
   3.240 +          rtac thm3 1]
   3.241      in
   3.242 -      val nchotomy = prove thy con_betas goal (K tacs);
   3.243 +      val nchotomy = prove thy con_betas goal (K tacs)
   3.244        val exhaust =
   3.245            (nchotomy RS @{thm exh_casedist0})
   3.246            |> rewrite_rule @{thms exh_casedists}
   3.247 -          |> Drule.zero_var_indexes;
   3.248 -    end;
   3.249 +          |> Drule.zero_var_indexes
   3.250 +    end
   3.251  
   3.252      (* prove compactness rules for constructors *)
   3.253      val compacts =
   3.254        let
   3.255          val rules = @{thms compact_sinl compact_sinr compact_spair
   3.256 -                           compact_up compact_ONE};
   3.257 +                           compact_up compact_ONE}
   3.258          val tacs =
   3.259            [rtac (iso_locale RS @{thm iso.compact_abs}) 1,
   3.260 -           REPEAT (resolve_tac rules 1 ORELSE atac 1)];
   3.261 +           REPEAT (resolve_tac rules 1 ORELSE atac 1)]
   3.262          fun con_compact (con, args) =
   3.263            let
   3.264 -            val vs = vars_of args;
   3.265 -            val con_app = list_ccomb (con, vs);
   3.266 -            val concl = mk_trp (mk_compact con_app);
   3.267 -            val assms = map (mk_trp o mk_compact) vs;
   3.268 -            val goal = Logic.list_implies (assms, concl);
   3.269 +            val vs = vars_of args
   3.270 +            val con_app = list_ccomb (con, vs)
   3.271 +            val concl = mk_trp (mk_compact con_app)
   3.272 +            val assms = map (mk_trp o mk_compact) vs
   3.273 +            val goal = Logic.list_implies (assms, concl)
   3.274            in
   3.275              prove thy con_betas goal (K tacs)
   3.276 -          end;
   3.277 +          end
   3.278        in
   3.279          map con_compact spec'
   3.280 -      end;
   3.281 +      end
   3.282  
   3.283      (* prove strictness rules for constructors *)
   3.284      local
   3.285        fun con_strict (con, args) = 
   3.286          let
   3.287 -          val rules = abs_strict :: @{thms con_strict_rules};
   3.288 -          val (vs, nonlazy) = get_vars args;
   3.289 +          val rules = abs_strict :: @{thms con_strict_rules}
   3.290 +          val (vs, nonlazy) = get_vars args
   3.291            fun one_strict v' =
   3.292              let
   3.293 -              val UU = mk_bottom (fastype_of v');
   3.294 -              val vs' = map (fn v => if v = v' then UU else v) vs;
   3.295 -              val goal = mk_trp (mk_undef (list_ccomb (con, vs')));
   3.296 -              val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
   3.297 -            in prove thy con_betas goal (K tacs) end;
   3.298 -        in map one_strict nonlazy end;
   3.299 +              val UU = mk_bottom (fastype_of v')
   3.300 +              val vs' = map (fn v => if v = v' then UU else v) vs
   3.301 +              val goal = mk_trp (mk_undef (list_ccomb (con, vs')))
   3.302 +              val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1]
   3.303 +            in prove thy con_betas goal (K tacs) end
   3.304 +        in map one_strict nonlazy end
   3.305  
   3.306        fun con_defin (con, args) =
   3.307          let
   3.308            fun iff_disj (t, []) = HOLogic.mk_not t
   3.309 -            | iff_disj (t, ts) = mk_eq (t, foldr1 HOLogic.mk_disj ts);
   3.310 -          val (vs, nonlazy) = get_vars args;
   3.311 -          val lhs = mk_undef (list_ccomb (con, vs));
   3.312 -          val rhss = map mk_undef nonlazy;
   3.313 -          val goal = mk_trp (iff_disj (lhs, rhss));
   3.314 -          val rule1 = iso_locale RS @{thm iso.abs_bottom_iff};
   3.315 -          val rules = rule1 :: @{thms con_bottom_iff_rules};
   3.316 -          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
   3.317 -        in prove thy con_betas goal (K tacs) end;
   3.318 +            | iff_disj (t, ts) = mk_eq (t, foldr1 HOLogic.mk_disj ts)
   3.319 +          val (vs, nonlazy) = get_vars args
   3.320 +          val lhs = mk_undef (list_ccomb (con, vs))
   3.321 +          val rhss = map mk_undef nonlazy
   3.322 +          val goal = mk_trp (iff_disj (lhs, rhss))
   3.323 +          val rule1 = iso_locale RS @{thm iso.abs_bottom_iff}
   3.324 +          val rules = rule1 :: @{thms con_bottom_iff_rules}
   3.325 +          val tacs = [simp_tac (HOL_ss addsimps rules) 1]
   3.326 +        in prove thy con_betas goal (K tacs) end
   3.327      in
   3.328 -      val con_stricts = maps con_strict spec';
   3.329 -      val con_defins = map con_defin spec';
   3.330 -      val con_rews = con_stricts @ con_defins;
   3.331 -    end;
   3.332 +      val con_stricts = maps con_strict spec'
   3.333 +      val con_defins = map con_defin spec'
   3.334 +      val con_rews = con_stricts @ con_defins
   3.335 +    end
   3.336  
   3.337      (* prove injectiveness of constructors *)
   3.338      local
   3.339        fun pgterm rel (con, args) =
   3.340          let
   3.341            fun prime (Free (n, T)) = Free (n^"'", T)
   3.342 -            | prime t             = t;
   3.343 -          val (xs, nonlazy) = get_vars args;
   3.344 -          val ys = map prime xs;
   3.345 -          val lhs = rel (list_ccomb (con, xs), list_ccomb (con, ys));
   3.346 -          val rhs = foldr1 mk_conj (ListPair.map rel (xs, ys));
   3.347 -          val concl = mk_trp (mk_eq (lhs, rhs));
   3.348 -          val zs = case args of [_] => [] | _ => nonlazy;
   3.349 -          val assms = map (mk_trp o mk_defined) zs;
   3.350 -          val goal = Logic.list_implies (assms, concl);
   3.351 -        in prove thy con_betas goal end;
   3.352 -      val cons' = filter (fn (_, args) => not (null args)) spec';
   3.353 +            | prime t             = t
   3.354 +          val (xs, nonlazy) = get_vars args
   3.355 +          val ys = map prime xs
   3.356 +          val lhs = rel (list_ccomb (con, xs), list_ccomb (con, ys))
   3.357 +          val rhs = foldr1 mk_conj (ListPair.map rel (xs, ys))
   3.358 +          val concl = mk_trp (mk_eq (lhs, rhs))
   3.359 +          val zs = case args of [_] => [] | _ => nonlazy
   3.360 +          val assms = map (mk_trp o mk_defined) zs
   3.361 +          val goal = Logic.list_implies (assms, concl)
   3.362 +        in prove thy con_betas goal end
   3.363 +      val cons' = filter (fn (_, args) => not (null args)) spec'
   3.364      in
   3.365        val inverts =
   3.366          let
   3.367 -          val abs_below = iso_locale RS @{thm iso.abs_below};
   3.368 -          val rules1 = abs_below :: @{thms sinl_below sinr_below spair_below up_below};
   3.369 +          val abs_below = iso_locale RS @{thm iso.abs_below}
   3.370 +          val rules1 = abs_below :: @{thms sinl_below sinr_below spair_below up_below}
   3.371            val rules2 = @{thms up_defined spair_defined ONE_defined}
   3.372 -          val rules = rules1 @ rules2;
   3.373 -          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
   3.374 -        in map (fn c => pgterm mk_below c (K tacs)) cons' end;
   3.375 +          val rules = rules1 @ rules2
   3.376 +          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1]
   3.377 +        in map (fn c => pgterm mk_below c (K tacs)) cons' end
   3.378        val injects =
   3.379          let
   3.380 -          val abs_eq = iso_locale RS @{thm iso.abs_eq};
   3.381 -          val rules1 = abs_eq :: @{thms sinl_eq sinr_eq spair_eq up_eq};
   3.382 +          val abs_eq = iso_locale RS @{thm iso.abs_eq}
   3.383 +          val rules1 = abs_eq :: @{thms sinl_eq sinr_eq spair_eq up_eq}
   3.384            val rules2 = @{thms up_defined spair_defined ONE_defined}
   3.385 -          val rules = rules1 @ rules2;
   3.386 -          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
   3.387 -        in map (fn c => pgterm mk_eq c (K tacs)) cons' end;
   3.388 -    end;
   3.389 +          val rules = rules1 @ rules2
   3.390 +          val tacs = [asm_simp_tac (simple_ss addsimps rules) 1]
   3.391 +        in map (fn c => pgterm mk_eq c (K tacs)) cons' end
   3.392 +    end
   3.393  
   3.394      (* prove distinctness of constructors *)
   3.395      local
   3.396        fun map_dist (f : 'a -> 'a -> 'b) (xs : 'a list) : 'b list =
   3.397 -        flat (map_index (fn (i, x) => map (f x) (nth_drop i xs)) xs);
   3.398 +        flat (map_index (fn (i, x) => map (f x) (nth_drop i xs)) xs)
   3.399        fun prime (Free (n, T)) = Free (n^"'", T)
   3.400 -        | prime t             = t;
   3.401 +        | prime t             = t
   3.402        fun iff_disj (t, []) = mk_not t
   3.403 -        | iff_disj (t, ts) = mk_eq (t, foldr1 mk_disj ts);
   3.404 +        | iff_disj (t, ts) = mk_eq (t, foldr1 mk_disj ts)
   3.405        fun iff_disj2 (t, [], us) = mk_not t
   3.406          | iff_disj2 (t, ts, []) = mk_not t
   3.407          | iff_disj2 (t, ts, us) =
   3.408 -          mk_eq (t, mk_conj (foldr1 mk_disj ts, foldr1 mk_disj us));
   3.409 +          mk_eq (t, mk_conj (foldr1 mk_disj ts, foldr1 mk_disj us))
   3.410        fun dist_le (con1, args1) (con2, args2) =
   3.411          let
   3.412 -          val (vs1, zs1) = get_vars args1;
   3.413 -          val (vs2, zs2) = get_vars args2 |> pairself (map prime);
   3.414 -          val lhs = mk_below (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
   3.415 -          val rhss = map mk_undef zs1;
   3.416 -          val goal = mk_trp (iff_disj (lhs, rhss));
   3.417 -          val rule1 = iso_locale RS @{thm iso.abs_below};
   3.418 -          val rules = rule1 :: @{thms con_below_iff_rules};
   3.419 -          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
   3.420 -        in prove thy con_betas goal (K tacs) end;
   3.421 +          val (vs1, zs1) = get_vars args1
   3.422 +          val (vs2, zs2) = get_vars args2 |> pairself (map prime)
   3.423 +          val lhs = mk_below (list_ccomb (con1, vs1), list_ccomb (con2, vs2))
   3.424 +          val rhss = map mk_undef zs1
   3.425 +          val goal = mk_trp (iff_disj (lhs, rhss))
   3.426 +          val rule1 = iso_locale RS @{thm iso.abs_below}
   3.427 +          val rules = rule1 :: @{thms con_below_iff_rules}
   3.428 +          val tacs = [simp_tac (HOL_ss addsimps rules) 1]
   3.429 +        in prove thy con_betas goal (K tacs) end
   3.430        fun dist_eq (con1, args1) (con2, args2) =
   3.431          let
   3.432 -          val (vs1, zs1) = get_vars args1;
   3.433 -          val (vs2, zs2) = get_vars args2 |> pairself (map prime);
   3.434 -          val lhs = mk_eq (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
   3.435 -          val rhss1 = map mk_undef zs1;
   3.436 -          val rhss2 = map mk_undef zs2;
   3.437 -          val goal = mk_trp (iff_disj2 (lhs, rhss1, rhss2));
   3.438 -          val rule1 = iso_locale RS @{thm iso.abs_eq};
   3.439 -          val rules = rule1 :: @{thms con_eq_iff_rules};
   3.440 -          val tacs = [simp_tac (HOL_ss addsimps rules) 1];
   3.441 -        in prove thy con_betas goal (K tacs) end;
   3.442 +          val (vs1, zs1) = get_vars args1
   3.443 +          val (vs2, zs2) = get_vars args2 |> pairself (map prime)
   3.444 +          val lhs = mk_eq (list_ccomb (con1, vs1), list_ccomb (con2, vs2))
   3.445 +          val rhss1 = map mk_undef zs1
   3.446 +          val rhss2 = map mk_undef zs2
   3.447 +          val goal = mk_trp (iff_disj2 (lhs, rhss1, rhss2))
   3.448 +          val rule1 = iso_locale RS @{thm iso.abs_eq}
   3.449 +          val rules = rule1 :: @{thms con_eq_iff_rules}
   3.450 +          val tacs = [simp_tac (HOL_ss addsimps rules) 1]
   3.451 +        in prove thy con_betas goal (K tacs) end
   3.452      in
   3.453 -      val dist_les = map_dist dist_le spec';
   3.454 -      val dist_eqs = map_dist dist_eq spec';
   3.455 -    end;
   3.456 +      val dist_les = map_dist dist_le spec'
   3.457 +      val dist_eqs = map_dist dist_eq spec'
   3.458 +    end
   3.459  
   3.460      val result =
   3.461        {
   3.462 @@ -376,10 +376,10 @@
   3.463          injects = injects,
   3.464          dist_les = dist_les,
   3.465          dist_eqs = dist_eqs
   3.466 -      };
   3.467 +      }
   3.468    in
   3.469      (result, thy)
   3.470 -  end;
   3.471 +  end
   3.472  
   3.473  (******************************************************************************)
   3.474  (**************** definition and theorems for case combinator *****************)
   3.475 @@ -398,121 +398,121 @@
   3.476    let
   3.477  
   3.478      (* prove rep/abs rules *)
   3.479 -    val rep_strict = iso_locale RS @{thm iso.rep_strict};
   3.480 -    val abs_inverse = iso_locale RS @{thm iso.abs_iso};
   3.481 +    val rep_strict = iso_locale RS @{thm iso.rep_strict}
   3.482 +    val abs_inverse = iso_locale RS @{thm iso.abs_iso}
   3.483  
   3.484      (* calculate function arguments of case combinator *)
   3.485 -    val tns = map fst (Term.add_tfreesT lhsT []);
   3.486 -    val resultT = TFree (Name.variant tns "'t", @{sort pcpo});
   3.487 -    fun fTs T = map (fn (_, args) => map snd args -->> T) spec;
   3.488 -    val fns = Datatype_Prop.indexify_names (map (K "f") spec);
   3.489 -    val fs = map Free (fns ~~ fTs resultT);
   3.490 -    fun caseT T = fTs T -->> (lhsT ->> T);
   3.491 +    val tns = map fst (Term.add_tfreesT lhsT [])
   3.492 +    val resultT = TFree (Name.variant tns "'t", @{sort pcpo})
   3.493 +    fun fTs T = map (fn (_, args) => map snd args -->> T) spec
   3.494 +    val fns = Datatype_Prop.indexify_names (map (K "f") spec)
   3.495 +    val fs = map Free (fns ~~ fTs resultT)
   3.496 +    fun caseT T = fTs T -->> (lhsT ->> T)
   3.497  
   3.498      (* definition of case combinator *)
   3.499      local
   3.500 -      val case_bind = Binding.suffix_name "_case" dbind;
   3.501 +      val case_bind = Binding.suffix_name "_case" dbind
   3.502        fun lambda_arg (lazy, v) t =
   3.503 -          (if lazy then mk_fup else I) (big_lambda v t);
   3.504 +          (if lazy then mk_fup else I) (big_lambda v t)
   3.505        fun lambda_args []      t = mk_one_case t
   3.506          | lambda_args (x::[]) t = lambda_arg x t
   3.507 -        | lambda_args (x::xs) t = mk_ssplit (lambda_arg x (lambda_args xs t));
   3.508 +        | lambda_args (x::xs) t = mk_ssplit (lambda_arg x (lambda_args xs t))
   3.509        fun one_con f (_, args) =
   3.510          let
   3.511 -          val Ts = map snd args;
   3.512 -          val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts);
   3.513 -          val vs = map Free (ns ~~ Ts);
   3.514 +          val Ts = map snd args
   3.515 +          val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts)
   3.516 +          val vs = map Free (ns ~~ Ts)
   3.517          in
   3.518            lambda_args (map fst args ~~ vs) (list_ccomb (f, vs))
   3.519 -        end;
   3.520 +        end
   3.521        fun mk_sscases [t] = mk_strictify t
   3.522 -        | mk_sscases ts = foldr1 mk_sscase ts;
   3.523 -      val body = mk_sscases (map2 one_con fs spec);
   3.524 -      val rhs = big_lambdas fs (mk_cfcomp (body, rep_const));
   3.525 +        | mk_sscases ts = foldr1 mk_sscase ts
   3.526 +      val body = mk_sscases (map2 one_con fs spec)
   3.527 +      val rhs = big_lambdas fs (mk_cfcomp (body, rep_const))
   3.528        val ((case_consts, case_defs), thy) =
   3.529 -          define_consts [(case_bind, rhs, NoSyn)] thy;
   3.530 -      val case_name = Sign.full_name thy case_bind;
   3.531 +          define_consts [(case_bind, rhs, NoSyn)] thy
   3.532 +      val case_name = Sign.full_name thy case_bind
   3.533      in
   3.534 -      val case_def = hd case_defs;
   3.535 -      fun case_const T = Const (case_name, caseT T);
   3.536 -      val case_app = list_ccomb (case_const resultT, fs);
   3.537 -      val thy = thy;
   3.538 -    end;
   3.539 +      val case_def = hd case_defs
   3.540 +      fun case_const T = Const (case_name, caseT T)
   3.541 +      val case_app = list_ccomb (case_const resultT, fs)
   3.542 +      val thy = thy
   3.543 +    end
   3.544  
   3.545      (* define syntax for case combinator *)
   3.546      (* TODO: re-implement case syntax using a parse translation *)
   3.547      local
   3.548        open Syntax
   3.549 -      fun syntax c = Syntax.mark_const (fst (dest_Const c));
   3.550 -      fun xconst c = Long_Name.base_name (fst (dest_Const c));
   3.551 +      fun syntax c = Syntax.mark_const (fst (dest_Const c))
   3.552 +      fun xconst c = Long_Name.base_name (fst (dest_Const c))
   3.553        fun c_ast authentic con =
   3.554 -          Constant (if authentic then syntax con else xconst con);
   3.555 -      fun showint n = string_of_int (n+1);
   3.556 -      fun expvar n = Variable ("e" ^ showint n);
   3.557 -      fun argvar n (m, _) = Variable ("a" ^ showint n ^ "_" ^ showint m);
   3.558 -      fun argvars n args = map_index (argvar n) args;
   3.559 -      fun app s (l, r) = mk_appl (Constant s) [l, r];
   3.560 -      val cabs = app "_cabs";
   3.561 -      val capp = app @{const_syntax Rep_cfun};
   3.562 +          Constant (if authentic then syntax con else xconst con)
   3.563 +      fun showint n = string_of_int (n+1)
   3.564 +      fun expvar n = Variable ("e" ^ showint n)
   3.565 +      fun argvar n (m, _) = Variable ("a" ^ showint n ^ "_" ^ showint m)
   3.566 +      fun argvars n args = map_index (argvar n) args
   3.567 +      fun app s (l, r) = mk_appl (Constant s) [l, r]
   3.568 +      val cabs = app "_cabs"
   3.569 +      val capp = app @{const_syntax Rep_cfun}
   3.570        val capps = Library.foldl capp
   3.571        fun con1 authentic n (con,args) =
   3.572 -          Library.foldl capp (c_ast authentic con, argvars n args);
   3.573 +          Library.foldl capp (c_ast authentic con, argvars n args)
   3.574        fun case1 authentic (n, c) =
   3.575 -          app "_case1" (con1 authentic n c, expvar n);
   3.576 -      fun arg1 (n, (con,args)) = List.foldr cabs (expvar n) (argvars n args);
   3.577 +          app "_case1" (con1 authentic n c, expvar n)
   3.578 +      fun arg1 (n, (con,args)) = List.foldr cabs (expvar n) (argvars n args)
   3.579        fun when1 n (m, c) =
   3.580 -          if n = m then arg1 (n, c) else (Constant @{const_syntax UU});
   3.581 -      val case_constant = Constant (syntax (case_const dummyT));
   3.582 +          if n = m then arg1 (n, c) else (Constant @{const_syntax UU})
   3.583 +      val case_constant = Constant (syntax (case_const dummyT))
   3.584        fun case_trans authentic =
   3.585            ParsePrintRule
   3.586              (app "_case_syntax"
   3.587                (Variable "x",
   3.588                 foldr1 (app "_case2") (map_index (case1 authentic) spec)),
   3.589 -             capp (capps (case_constant, map_index arg1 spec), Variable "x"));
   3.590 +             capp (capps (case_constant, map_index arg1 spec), Variable "x"))
   3.591        fun one_abscon_trans authentic (n, c) =
   3.592            ParsePrintRule
   3.593              (cabs (con1 authentic n c, expvar n),
   3.594 -             capps (case_constant, map_index (when1 n) spec));
   3.595 +             capps (case_constant, map_index (when1 n) spec))
   3.596        fun abscon_trans authentic =
   3.597 -          map_index (one_abscon_trans authentic) spec;
   3.598 +          map_index (one_abscon_trans authentic) spec
   3.599        val trans_rules : ast Syntax.trrule list =
   3.600            case_trans false :: case_trans true ::
   3.601 -          abscon_trans false @ abscon_trans true;
   3.602 +          abscon_trans false @ abscon_trans true
   3.603      in
   3.604 -      val thy = Sign.add_trrules_i trans_rules thy;
   3.605 -    end;
   3.606 +      val thy = Sign.add_trrules_i trans_rules thy
   3.607 +    end
   3.608  
   3.609      (* prove beta reduction rule for case combinator *)
   3.610 -    val case_beta = beta_of_def thy case_def;
   3.611 +    val case_beta = beta_of_def thy case_def
   3.612  
   3.613      (* prove strictness of case combinator *)
   3.614      val case_strict =
   3.615        let
   3.616 -        val defs = case_beta :: map mk_meta_eq [rep_strict, @{thm cfcomp2}];
   3.617 -        val goal = mk_trp (mk_strict case_app);
   3.618 -        val rules = @{thms sscase1 ssplit1 strictify1 one_case1};
   3.619 -        val tacs = [resolve_tac rules 1];
   3.620 -      in prove thy defs goal (K tacs) end;
   3.621 +        val defs = case_beta :: map mk_meta_eq [rep_strict, @{thm cfcomp2}]
   3.622 +        val goal = mk_trp (mk_strict case_app)
   3.623 +        val rules = @{thms sscase1 ssplit1 strictify1 one_case1}
   3.624 +        val tacs = [resolve_tac rules 1]
   3.625 +      in prove thy defs goal (K tacs) end
   3.626          
   3.627      (* prove rewrites for case combinator *)
   3.628      local
   3.629        fun one_case (con, args) f =
   3.630          let
   3.631 -          val (vs, nonlazy) = get_vars args;
   3.632 -          val assms = map (mk_trp o mk_defined) nonlazy;
   3.633 -          val lhs = case_app ` list_ccomb (con, vs);
   3.634 -          val rhs = list_ccomb (f, vs);
   3.635 -          val concl = mk_trp (mk_eq (lhs, rhs));
   3.636 -          val goal = Logic.list_implies (assms, concl);
   3.637 -          val defs = case_beta :: con_betas;
   3.638 -          val rules1 = @{thms strictify2 sscase2 sscase3 ssplit2 fup2 ID1};
   3.639 -          val rules2 = @{thms con_bottom_iff_rules};
   3.640 -          val rules3 = @{thms cfcomp2 one_case2};
   3.641 -          val rules = abs_inverse :: rules1 @ rules2 @ rules3;
   3.642 -          val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
   3.643 -        in prove thy defs goal (K tacs) end;
   3.644 +          val (vs, nonlazy) = get_vars args
   3.645 +          val assms = map (mk_trp o mk_defined) nonlazy
   3.646 +          val lhs = case_app ` list_ccomb (con, vs)
   3.647 +          val rhs = list_ccomb (f, vs)
   3.648 +          val concl = mk_trp (mk_eq (lhs, rhs))
   3.649 +          val goal = Logic.list_implies (assms, concl)
   3.650 +          val defs = case_beta :: con_betas
   3.651 +          val rules1 = @{thms strictify2 sscase2 sscase3 ssplit2 fup2 ID1}
   3.652 +          val rules2 = @{thms con_bottom_iff_rules}
   3.653 +          val rules3 = @{thms cfcomp2 one_case2}
   3.654 +          val rules = abs_inverse :: rules1 @ rules2 @ rules3
   3.655 +          val tacs = [asm_simp_tac (beta_ss addsimps rules) 1]
   3.656 +        in prove thy defs goal (K tacs) end
   3.657      in
   3.658 -      val case_apps = map2 one_case spec fs;
   3.659 +      val case_apps = map2 one_case spec fs
   3.660      end
   3.661  
   3.662    in
   3.663 @@ -537,26 +537,26 @@
   3.664      (* define selector functions *)
   3.665      val ((sel_consts, sel_defs), thy) =
   3.666        let
   3.667 -        fun rangeT s = snd (dest_cfunT (fastype_of s));
   3.668 -        fun mk_outl s = mk_cfcomp (from_sinl (dest_ssumT (rangeT s)), s);
   3.669 -        fun mk_outr s = mk_cfcomp (from_sinr (dest_ssumT (rangeT s)), s);
   3.670 -        fun mk_sfst s = mk_cfcomp (sfst_const (dest_sprodT (rangeT s)), s);
   3.671 -        fun mk_ssnd s = mk_cfcomp (ssnd_const (dest_sprodT (rangeT s)), s);
   3.672 -        fun mk_down s = mk_cfcomp (from_up (dest_upT (rangeT s)), s);
   3.673 +        fun rangeT s = snd (dest_cfunT (fastype_of s))
   3.674 +        fun mk_outl s = mk_cfcomp (from_sinl (dest_ssumT (rangeT s)), s)
   3.675 +        fun mk_outr s = mk_cfcomp (from_sinr (dest_ssumT (rangeT s)), s)
   3.676 +        fun mk_sfst s = mk_cfcomp (sfst_const (dest_sprodT (rangeT s)), s)
   3.677 +        fun mk_ssnd s = mk_cfcomp (ssnd_const (dest_sprodT (rangeT s)), s)
   3.678 +        fun mk_down s = mk_cfcomp (from_up (dest_upT (rangeT s)), s)
   3.679  
   3.680          fun sels_of_arg s (lazy, NONE,   T) = []
   3.681            | sels_of_arg s (lazy, SOME b, T) =
   3.682 -            [(b, if lazy then mk_down s else s, NoSyn)];
   3.683 +            [(b, if lazy then mk_down s else s, NoSyn)]
   3.684          fun sels_of_args s [] = []
   3.685            | sels_of_args s (v :: []) = sels_of_arg s v
   3.686            | sels_of_args s (v :: vs) =
   3.687 -            sels_of_arg (mk_sfst s) v @ sels_of_args (mk_ssnd s) vs;
   3.688 +            sels_of_arg (mk_sfst s) v @ sels_of_args (mk_ssnd s) vs
   3.689          fun sels_of_cons s [] = []
   3.690            | sels_of_cons s ((con, args) :: []) = sels_of_args s args
   3.691            | sels_of_cons s ((con, args) :: cs) =
   3.692 -            sels_of_args (mk_outl s) args @ sels_of_cons (mk_outr s) cs;
   3.693 +            sels_of_args (mk_outl s) args @ sels_of_cons (mk_outr s) cs
   3.694          val sel_eqns : (binding * term * mixfix) list =
   3.695 -            sels_of_cons rep_const spec;
   3.696 +            sels_of_cons rep_const spec
   3.697        in
   3.698          define_consts sel_eqns thy
   3.699        end
   3.700 @@ -566,21 +566,21 @@
   3.701        let
   3.702          fun prep_arg (lazy, NONE, T) sels = ((lazy, NONE, T), sels)
   3.703            | prep_arg (lazy, SOME _, T) sels =
   3.704 -            ((lazy, SOME (hd sels), T), tl sels);
   3.705 +            ((lazy, SOME (hd sels), T), tl sels)
   3.706          fun prep_con (con, args) sels =
   3.707 -            apfst (pair con) (fold_map prep_arg args sels);
   3.708 +            apfst (pair con) (fold_map prep_arg args sels)
   3.709        in
   3.710          fst (fold_map prep_con spec sel_consts)
   3.711 -      end;
   3.712 +      end
   3.713  
   3.714      (* prove selector strictness rules *)
   3.715      val sel_stricts : thm list =
   3.716        let
   3.717 -        val rules = rep_strict :: @{thms sel_strict_rules};
   3.718 -        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
   3.719 +        val rules = rep_strict :: @{thms sel_strict_rules}
   3.720 +        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1]
   3.721          fun sel_strict sel =
   3.722            let
   3.723 -            val goal = mk_trp (mk_strict sel);
   3.724 +            val goal = mk_trp (mk_strict sel)
   3.725            in
   3.726              prove thy sel_defs goal (K tacs)
   3.727            end
   3.728 @@ -591,37 +591,37 @@
   3.729      (* prove selector application rules *)
   3.730      val sel_apps : thm list =
   3.731        let
   3.732 -        val defs = con_betas @ sel_defs;
   3.733 -        val rules = abs_inv :: @{thms sel_app_rules};
   3.734 -        val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
   3.735 +        val defs = con_betas @ sel_defs
   3.736 +        val rules = abs_inv :: @{thms sel_app_rules}
   3.737 +        val tacs = [asm_simp_tac (simple_ss addsimps rules) 1]
   3.738          fun sel_apps_of (i, (con, args: (bool * term option * typ) list)) =
   3.739            let
   3.740 -            val Ts : typ list = map #3 args;
   3.741 -            val ns : string list = Datatype_Prop.make_tnames Ts;
   3.742 -            val vs : term list = map Free (ns ~~ Ts);
   3.743 -            val con_app : term = list_ccomb (con, vs);
   3.744 -            val vs' : (bool * term) list = map #1 args ~~ vs;
   3.745 +            val Ts : typ list = map #3 args
   3.746 +            val ns : string list = Datatype_Prop.make_tnames Ts
   3.747 +            val vs : term list = map Free (ns ~~ Ts)
   3.748 +            val con_app : term = list_ccomb (con, vs)
   3.749 +            val vs' : (bool * term) list = map #1 args ~~ vs
   3.750              fun one_same (n, sel, T) =
   3.751                let
   3.752 -                val xs = map snd (filter_out fst (nth_drop n vs'));
   3.753 -                val assms = map (mk_trp o mk_defined) xs;
   3.754 -                val concl = mk_trp (mk_eq (sel ` con_app, nth vs n));
   3.755 -                val goal = Logic.list_implies (assms, concl);
   3.756 +                val xs = map snd (filter_out fst (nth_drop n vs'))
   3.757 +                val assms = map (mk_trp o mk_defined) xs
   3.758 +                val concl = mk_trp (mk_eq (sel ` con_app, nth vs n))
   3.759 +                val goal = Logic.list_implies (assms, concl)
   3.760                in
   3.761                  prove thy defs goal (K tacs)
   3.762 -              end;
   3.763 +              end
   3.764              fun one_diff (n, sel, T) =
   3.765                let
   3.766 -                val goal = mk_trp (mk_eq (sel ` con_app, mk_bottom T));
   3.767 +                val goal = mk_trp (mk_eq (sel ` con_app, mk_bottom T))
   3.768                in
   3.769                  prove thy defs goal (K tacs)
   3.770 -              end;
   3.771 +              end
   3.772              fun one_con (j, (_, args')) : thm list =
   3.773                let
   3.774                  fun prep (i, (lazy, NONE, T)) = NONE
   3.775 -                  | prep (i, (lazy, SOME sel, T)) = SOME (i, sel, T);
   3.776 +                  | prep (i, (lazy, SOME sel, T)) = SOME (i, sel, T)
   3.777                  val sels : (int * term * typ) list =
   3.778 -                  map_filter prep (map_index I args');
   3.779 +                  map_filter prep (map_index I args')
   3.780                in
   3.781                  if i = j
   3.782                  then map one_same sels
   3.783 @@ -637,25 +637,25 @@
   3.784    (* prove selector definedness rules *)
   3.785      val sel_defins : thm list =
   3.786        let
   3.787 -        val rules = rep_bottom_iff :: @{thms sel_bottom_iff_rules};
   3.788 -        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
   3.789 +        val rules = rep_bottom_iff :: @{thms sel_bottom_iff_rules}
   3.790 +        val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1]
   3.791          fun sel_defin sel =
   3.792            let
   3.793 -            val (T, U) = dest_cfunT (fastype_of sel);
   3.794 -            val x = Free ("x", T);
   3.795 -            val lhs = mk_eq (sel ` x, mk_bottom U);
   3.796 -            val rhs = mk_eq (x, mk_bottom T);
   3.797 -            val goal = mk_trp (mk_eq (lhs, rhs));
   3.798 +            val (T, U) = dest_cfunT (fastype_of sel)
   3.799 +            val x = Free ("x", T)
   3.800 +            val lhs = mk_eq (sel ` x, mk_bottom U)
   3.801 +            val rhs = mk_eq (x, mk_bottom T)
   3.802 +            val goal = mk_trp (mk_eq (lhs, rhs))
   3.803            in
   3.804              prove thy sel_defs goal (K tacs)
   3.805            end
   3.806          fun one_arg (false, SOME sel, T) = SOME (sel_defin sel)
   3.807 -          | one_arg _                    = NONE;
   3.808 +          | one_arg _                    = NONE
   3.809        in
   3.810          case spec2 of
   3.811            [(con, args)] => map_filter one_arg args
   3.812          | _             => []
   3.813 -      end;
   3.814 +      end
   3.815  
   3.816    in
   3.817      (sel_stricts @ sel_defins @ sel_apps, thy)
   3.818 @@ -677,81 +677,81 @@
   3.819  
   3.820      fun vars_of args =
   3.821        let
   3.822 -        val Ts = map snd args;
   3.823 -        val ns = Datatype_Prop.make_tnames Ts;
   3.824 +        val Ts = map snd args
   3.825 +        val ns = Datatype_Prop.make_tnames Ts
   3.826        in
   3.827          map Free (ns ~~ Ts)
   3.828 -      end;
   3.829 +      end
   3.830  
   3.831      (* define discriminator functions *)
   3.832      local
   3.833        fun dis_fun i (j, (con, args)) =
   3.834          let
   3.835 -          val (vs, nonlazy) = get_vars args;
   3.836 -          val tr = if i = j then @{term TT} else @{term FF};
   3.837 +          val (vs, nonlazy) = get_vars args
   3.838 +          val tr = if i = j then @{term TT} else @{term FF}
   3.839          in
   3.840            big_lambdas vs tr
   3.841 -        end;
   3.842 +        end
   3.843        fun dis_eqn (i, bind) : binding * term * mixfix =
   3.844          let
   3.845 -          val dis_bind = Binding.prefix_name "is_" bind;
   3.846 -          val rhs = list_ccomb (case_const trT, map_index (dis_fun i) spec);
   3.847 +          val dis_bind = Binding.prefix_name "is_" bind
   3.848 +          val rhs = list_ccomb (case_const trT, map_index (dis_fun i) spec)
   3.849          in
   3.850            (dis_bind, rhs, NoSyn)
   3.851 -        end;
   3.852 +        end
   3.853      in
   3.854        val ((dis_consts, dis_defs), thy) =
   3.855            define_consts (map_index dis_eqn bindings) thy
   3.856 -    end;
   3.857 +    end
   3.858  
   3.859      (* prove discriminator strictness rules *)
   3.860      local
   3.861        fun dis_strict dis =
   3.862 -        let val goal = mk_trp (mk_strict dis);
   3.863 -        in prove thy dis_defs goal (K [rtac (hd case_rews) 1]) end;
   3.864 +        let val goal = mk_trp (mk_strict dis)
   3.865 +        in prove thy dis_defs goal (K [rtac (hd case_rews) 1]) end
   3.866      in
   3.867 -      val dis_stricts = map dis_strict dis_consts;
   3.868 -    end;
   3.869 +      val dis_stricts = map dis_strict dis_consts
   3.870 +    end
   3.871  
   3.872      (* prove discriminator/constructor rules *)
   3.873      local
   3.874        fun dis_app (i, dis) (j, (con, args)) =
   3.875          let
   3.876 -          val (vs, nonlazy) = get_vars args;
   3.877 -          val lhs = dis ` list_ccomb (con, vs);
   3.878 -          val rhs = if i = j then @{term TT} else @{term FF};
   3.879 -          val assms = map (mk_trp o mk_defined) nonlazy;
   3.880 -          val concl = mk_trp (mk_eq (lhs, rhs));
   3.881 -          val goal = Logic.list_implies (assms, concl);
   3.882 -          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
   3.883 -        in prove thy dis_defs goal (K tacs) end;
   3.884 +          val (vs, nonlazy) = get_vars args
   3.885 +          val lhs = dis ` list_ccomb (con, vs)
   3.886 +          val rhs = if i = j then @{term TT} else @{term FF}
   3.887 +          val assms = map (mk_trp o mk_defined) nonlazy
   3.888 +          val concl = mk_trp (mk_eq (lhs, rhs))
   3.889 +          val goal = Logic.list_implies (assms, concl)
   3.890 +          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1]
   3.891 +        in prove thy dis_defs goal (K tacs) end
   3.892        fun one_dis (i, dis) =
   3.893 -          map_index (dis_app (i, dis)) spec;
   3.894 +          map_index (dis_app (i, dis)) spec
   3.895      in
   3.896 -      val dis_apps = flat (map_index one_dis dis_consts);
   3.897 -    end;
   3.898 +      val dis_apps = flat (map_index one_dis dis_consts)
   3.899 +    end
   3.900  
   3.901      (* prove discriminator definedness rules *)
   3.902      local
   3.903        fun dis_defin dis =
   3.904          let
   3.905 -          val x = Free ("x", lhsT);
   3.906 -          val simps = dis_apps @ @{thms dist_eq_tr};
   3.907 +          val x = Free ("x", lhsT)
   3.908 +          val simps = dis_apps @ @{thms dist_eq_tr}
   3.909            val tacs =
   3.910              [rtac @{thm iffI} 1,
   3.911               asm_simp_tac (HOL_basic_ss addsimps dis_stricts) 2,
   3.912               rtac exhaust 1, atac 1,
   3.913               DETERM_UNTIL_SOLVED (CHANGED
   3.914 -               (asm_full_simp_tac (simple_ss addsimps simps) 1))];
   3.915 -          val goal = mk_trp (mk_eq (mk_undef (dis ` x), mk_undef x));
   3.916 -        in prove thy [] goal (K tacs) end;
   3.917 +               (asm_full_simp_tac (simple_ss addsimps simps) 1))]
   3.918 +          val goal = mk_trp (mk_eq (mk_undef (dis ` x), mk_undef x))
   3.919 +        in prove thy [] goal (K tacs) end
   3.920      in
   3.921 -      val dis_defins = map dis_defin dis_consts;
   3.922 -    end;
   3.923 +      val dis_defins = map dis_defin dis_consts
   3.924 +    end
   3.925  
   3.926    in
   3.927      (dis_stricts @ dis_defins @ dis_apps, thy)
   3.928 -  end;
   3.929 +  end
   3.930  
   3.931  (******************************************************************************)
   3.932  (*************** definitions and theorems for match combinators ***************)
   3.933 @@ -770,80 +770,80 @@
   3.934      (* get a fresh type variable for the result type *)
   3.935      val resultT : typ =
   3.936        let
   3.937 -        val ts : string list = map fst (Term.add_tfreesT lhsT []);
   3.938 -        val t : string = Name.variant ts "'t";
   3.939 -      in TFree (t, @{sort pcpo}) end;
   3.940 +        val ts : string list = map fst (Term.add_tfreesT lhsT [])
   3.941 +        val t : string = Name.variant ts "'t"
   3.942 +      in TFree (t, @{sort pcpo}) end
   3.943  
   3.944      (* define match combinators *)
   3.945      local
   3.946 -      val x = Free ("x", lhsT);
   3.947 -      fun k args = Free ("k", map snd args -->> mk_matchT resultT);
   3.948 -      val fail = mk_fail resultT;
   3.949 +      val x = Free ("x", lhsT)
   3.950 +      fun k args = Free ("k", map snd args -->> mk_matchT resultT)
   3.951 +      val fail = mk_fail resultT
   3.952        fun mat_fun i (j, (con, args)) =
   3.953          let
   3.954 -          val (vs, nonlazy) = get_vars_avoiding ["x","k"] args;
   3.955 +          val (vs, nonlazy) = get_vars_avoiding ["x","k"] args
   3.956          in
   3.957            if i = j then k args else big_lambdas vs fail
   3.958 -        end;
   3.959 +        end
   3.960        fun mat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
   3.961          let
   3.962 -          val mat_bind = Binding.prefix_name "match_" bind;
   3.963 +          val mat_bind = Binding.prefix_name "match_" bind
   3.964            val funs = map_index (mat_fun i) spec
   3.965 -          val body = list_ccomb (case_const (mk_matchT resultT), funs);
   3.966 -          val rhs = big_lambda x (big_lambda (k args) (body ` x));
   3.967 +          val body = list_ccomb (case_const (mk_matchT resultT), funs)
   3.968 +          val rhs = big_lambda x (big_lambda (k args) (body ` x))
   3.969          in
   3.970            (mat_bind, rhs, NoSyn)
   3.971 -        end;
   3.972 +        end
   3.973      in
   3.974        val ((match_consts, match_defs), thy) =
   3.975            define_consts (map_index mat_eqn (bindings ~~ spec)) thy
   3.976 -    end;
   3.977 +    end
   3.978  
   3.979      (* register match combinators with fixrec package *)
   3.980      local
   3.981 -      val con_names = map (fst o dest_Const o fst) spec;
   3.982 -      val mat_names = map (fst o dest_Const) match_consts;
   3.983 +      val con_names = map (fst o dest_Const o fst) spec
   3.984 +      val mat_names = map (fst o dest_Const) match_consts
   3.985      in
   3.986 -      val thy = Fixrec.add_matchers (con_names ~~ mat_names) thy;
   3.987 -    end;
   3.988 +      val thy = Fixrec.add_matchers (con_names ~~ mat_names) thy
   3.989 +    end
   3.990  
   3.991      (* prove strictness of match combinators *)
   3.992      local
   3.993        fun match_strict mat =
   3.994          let
   3.995 -          val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
   3.996 -          val k = Free ("k", U);
   3.997 -          val goal = mk_trp (mk_eq (mat ` mk_bottom T ` k, mk_bottom V));
   3.998 -          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
   3.999 -        in prove thy match_defs goal (K tacs) end;
  3.1000 +          val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat))
  3.1001 +          val k = Free ("k", U)
  3.1002 +          val goal = mk_trp (mk_eq (mat ` mk_bottom T ` k, mk_bottom V))
  3.1003 +          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1]
  3.1004 +        in prove thy match_defs goal (K tacs) end
  3.1005      in
  3.1006 -      val match_stricts = map match_strict match_consts;
  3.1007 -    end;
  3.1008 +      val match_stricts = map match_strict match_consts
  3.1009 +    end
  3.1010  
  3.1011      (* prove match/constructor rules *)
  3.1012      local
  3.1013 -      val fail = mk_fail resultT;
  3.1014 +      val fail = mk_fail resultT
  3.1015        fun match_app (i, mat) (j, (con, args)) =
  3.1016          let
  3.1017 -          val (vs, nonlazy) = get_vars_avoiding ["k"] args;
  3.1018 -          val (_, (kT, _)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
  3.1019 -          val k = Free ("k", kT);
  3.1020 -          val lhs = mat ` list_ccomb (con, vs) ` k;
  3.1021 -          val rhs = if i = j then list_ccomb (k, vs) else fail;
  3.1022 -          val assms = map (mk_trp o mk_defined) nonlazy;
  3.1023 -          val concl = mk_trp (mk_eq (lhs, rhs));
  3.1024 -          val goal = Logic.list_implies (assms, concl);
  3.1025 -          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
  3.1026 -        in prove thy match_defs goal (K tacs) end;
  3.1027 +          val (vs, nonlazy) = get_vars_avoiding ["k"] args
  3.1028 +          val (_, (kT, _)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat))
  3.1029 +          val k = Free ("k", kT)
  3.1030 +          val lhs = mat ` list_ccomb (con, vs) ` k
  3.1031 +          val rhs = if i = j then list_ccomb (k, vs) else fail
  3.1032 +          val assms = map (mk_trp o mk_defined) nonlazy
  3.1033 +          val concl = mk_trp (mk_eq (lhs, rhs))
  3.1034 +          val goal = Logic.list_implies (assms, concl)
  3.1035 +          val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1]
  3.1036 +        in prove thy match_defs goal (K tacs) end
  3.1037        fun one_match (i, mat) =
  3.1038 -          map_index (match_app (i, mat)) spec;
  3.1039 +          map_index (match_app (i, mat)) spec
  3.1040      in
  3.1041 -      val match_apps = flat (map_index one_match match_consts);
  3.1042 -    end;
  3.1043 +      val match_apps = flat (map_index one_match match_consts)
  3.1044 +    end
  3.1045  
  3.1046    in
  3.1047      (match_stricts @ match_apps, thy)
  3.1048 -  end;
  3.1049 +  end
  3.1050  
  3.1051  (******************************************************************************)
  3.1052  (******************************* main function ********************************)
  3.1053 @@ -855,46 +855,46 @@
  3.1054      (iso_info : Domain_Take_Proofs.iso_info)
  3.1055      (thy : theory) =
  3.1056    let
  3.1057 -    val dname = Binding.name_of dbind;
  3.1058 -    val _ = writeln ("Proving isomorphism properties of domain "^dname^" ...");
  3.1059 +    val dname = Binding.name_of dbind
  3.1060 +    val _ = writeln ("Proving isomorphism properties of domain "^dname^" ...")
  3.1061  
  3.1062 -    val bindings = map #1 spec;
  3.1063 +    val bindings = map #1 spec
  3.1064  
  3.1065      (* retrieve facts about rep/abs *)
  3.1066 -    val lhsT = #absT iso_info;
  3.1067 -    val {rep_const, abs_const, ...} = iso_info;
  3.1068 -    val abs_iso_thm = #abs_inverse iso_info;
  3.1069 -    val rep_iso_thm = #rep_inverse iso_info;
  3.1070 -    val iso_locale = @{thm iso.intro} OF [abs_iso_thm, rep_iso_thm];
  3.1071 -    val rep_strict = iso_locale RS @{thm iso.rep_strict};
  3.1072 -    val abs_strict = iso_locale RS @{thm iso.abs_strict};
  3.1073 -    val rep_bottom_iff = iso_locale RS @{thm iso.rep_bottom_iff};
  3.1074 -    val abs_bottom_iff = iso_locale RS @{thm iso.abs_bottom_iff};
  3.1075 -    val iso_rews = [abs_iso_thm, rep_iso_thm, abs_strict, rep_strict];
  3.1076 +    val lhsT = #absT iso_info
  3.1077 +    val {rep_const, abs_const, ...} = iso_info
  3.1078 +    val abs_iso_thm = #abs_inverse iso_info
  3.1079 +    val rep_iso_thm = #rep_inverse iso_info
  3.1080 +    val iso_locale = @{thm iso.intro} OF [abs_iso_thm, rep_iso_thm]
  3.1081 +    val rep_strict = iso_locale RS @{thm iso.rep_strict}
  3.1082 +    val abs_strict = iso_locale RS @{thm iso.abs_strict}
  3.1083 +    val rep_bottom_iff = iso_locale RS @{thm iso.rep_bottom_iff}
  3.1084 +    val abs_bottom_iff = iso_locale RS @{thm iso.abs_bottom_iff}
  3.1085 +    val iso_rews = [abs_iso_thm, rep_iso_thm, abs_strict, rep_strict]
  3.1086  
  3.1087      (* qualify constants and theorems with domain name *)
  3.1088 -    val thy = Sign.add_path dname thy;
  3.1089 +    val thy = Sign.add_path dname thy
  3.1090  
  3.1091      (* define constructor functions *)
  3.1092      val (con_result, thy) =
  3.1093        let
  3.1094 -        fun prep_arg (lazy, sel, T) = (lazy, T);
  3.1095 -        fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
  3.1096 -        val con_spec = map prep_con spec;
  3.1097 +        fun prep_arg (lazy, sel, T) = (lazy, T)
  3.1098 +        fun prep_con (b, args, mx) = (b, map prep_arg args, mx)
  3.1099 +        val con_spec = map prep_con spec
  3.1100        in
  3.1101          add_constructors con_spec abs_const iso_locale thy
  3.1102 -      end;
  3.1103 +      end
  3.1104      val {con_consts, con_betas, nchotomy, exhaust, compacts, con_rews,
  3.1105 -          inverts, injects, dist_les, dist_eqs} = con_result;
  3.1106 +          inverts, injects, dist_les, dist_eqs} = con_result
  3.1107  
  3.1108      (* prepare constructor spec *)
  3.1109      val con_specs : (term * (bool * typ) list) list =
  3.1110        let
  3.1111 -        fun prep_arg (lazy, sel, T) = (lazy, T);
  3.1112 -        fun prep_con c (b, args, mx) = (c, map prep_arg args);
  3.1113 +        fun prep_arg (lazy, sel, T) = (lazy, T)
  3.1114 +        fun prep_con c (b, args, mx) = (c, map prep_arg args)
  3.1115        in
  3.1116          map2 prep_con con_consts spec
  3.1117 -      end;
  3.1118 +      end
  3.1119  
  3.1120      (* define case combinator *)
  3.1121      val ((case_const : typ -> term, cases : thm list), thy) =
  3.1122 @@ -905,34 +905,34 @@
  3.1123      val (sel_thms : thm list, thy : theory) =
  3.1124        let
  3.1125          val sel_spec : (term * (bool * binding option * typ) list) list =
  3.1126 -          map2 (fn con => fn (b, args, mx) => (con, args)) con_consts spec;
  3.1127 +          map2 (fn con => fn (b, args, mx) => (con, args)) con_consts spec
  3.1128        in
  3.1129          add_selectors sel_spec rep_const
  3.1130            abs_iso_thm rep_strict rep_bottom_iff con_betas thy
  3.1131 -      end;
  3.1132 +      end
  3.1133  
  3.1134      (* define and prove theorems for discriminator functions *)
  3.1135      val (dis_thms : thm list, thy : theory) =
  3.1136          add_discriminators bindings con_specs lhsT
  3.1137 -          exhaust case_const cases thy;
  3.1138 +          exhaust case_const cases thy
  3.1139  
  3.1140      (* define and prove theorems for match combinators *)
  3.1141      val (match_thms : thm list, thy : theory) =
  3.1142          add_match_combinators bindings con_specs lhsT
  3.1143 -          exhaust case_const cases thy;
  3.1144 +          exhaust case_const cases thy
  3.1145  
  3.1146      (* restore original signature path *)
  3.1147 -    val thy = Sign.parent_path thy;
  3.1148 +    val thy = Sign.parent_path thy
  3.1149  
  3.1150      (* bind theorem names in global theory *)
  3.1151      val (_, thy) =
  3.1152        let
  3.1153 -        fun qualified name = Binding.qualified true name dbind;
  3.1154 -        val names = "bottom" :: map (fn (b,_,_) => Binding.name_of b) spec;
  3.1155 -        val dname = fst (dest_Type lhsT);
  3.1156 -        val simp = Simplifier.simp_add;
  3.1157 -        val case_names = Rule_Cases.case_names names;
  3.1158 -        val cases_type = Induct.cases_type dname;
  3.1159 +        fun qualified name = Binding.qualified true name dbind
  3.1160 +        val names = "bottom" :: map (fn (b,_,_) => Binding.name_of b) spec
  3.1161 +        val dname = fst (dest_Type lhsT)
  3.1162 +        val simp = Simplifier.simp_add
  3.1163 +        val case_names = Rule_Cases.case_names names
  3.1164 +        val cases_type = Induct.cases_type dname
  3.1165        in
  3.1166          Global_Theory.add_thmss [
  3.1167            ((qualified "iso_rews"  , iso_rews    ), [simp]),
  3.1168 @@ -948,7 +948,7 @@
  3.1169            ((qualified "inverts"   , inverts     ), [simp]),
  3.1170            ((qualified "injects"   , injects     ), [simp]),
  3.1171            ((qualified "match_rews", match_thms  ), [simp])] thy
  3.1172 -      end;
  3.1173 +      end
  3.1174  
  3.1175      val result =
  3.1176        {
  3.1177 @@ -967,9 +967,9 @@
  3.1178          sel_rews = sel_thms,
  3.1179          dis_rews = dis_thms,
  3.1180          match_rews = match_thms
  3.1181 -      };
  3.1182 +      }
  3.1183    in
  3.1184      (result, thy)
  3.1185 -  end;
  3.1186 +  end
  3.1187  
  3.1188 -end;
  3.1189 +end
     4.1 --- a/src/HOL/HOLCF/Tools/Domain/domain_induction.ML	Tue Nov 30 14:01:49 2010 -0800
     4.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_induction.ML	Tue Nov 30 14:21:57 2010 -0800
     4.3 @@ -13,20 +13,20 @@
     4.4        Domain_Constructors.constr_info list ->
     4.5        theory -> thm list * theory
     4.6  
     4.7 -  val quiet_mode: bool Unsynchronized.ref;
     4.8 -  val trace_domain: bool Unsynchronized.ref;
     4.9 -end;
    4.10 +  val quiet_mode: bool Unsynchronized.ref
    4.11 +  val trace_domain: bool Unsynchronized.ref
    4.12 +end
    4.13  
    4.14  structure Domain_Induction :> DOMAIN_INDUCTION =
    4.15  struct
    4.16  
    4.17 -val quiet_mode = Unsynchronized.ref false;
    4.18 -val trace_domain = Unsynchronized.ref false;
    4.19 +val quiet_mode = Unsynchronized.ref false
    4.20 +val trace_domain = Unsynchronized.ref false
    4.21  
    4.22 -fun message s = if !quiet_mode then () else writeln s;
    4.23 -fun trace s = if !trace_domain then tracing s else ();
    4.24 +fun message s = if !quiet_mode then () else writeln s
    4.25 +fun trace s = if !trace_domain then tracing s else ()
    4.26  
    4.27 -open HOLCF_Library;
    4.28 +open HOLCF_Library
    4.29  
    4.30  (******************************************************************************)
    4.31  (***************************** proofs about take ******************************)
    4.32 @@ -38,60 +38,60 @@
    4.33      (constr_infos : Domain_Constructors.constr_info list)
    4.34      (thy : theory) : thm list list * theory =
    4.35  let
    4.36 -  val {take_consts, take_Suc_thms, deflation_take_thms, ...} = take_info;
    4.37 -  val deflation_thms = Domain_Take_Proofs.get_deflation_thms thy;
    4.38 +  val {take_consts, take_Suc_thms, deflation_take_thms, ...} = take_info
    4.39 +  val deflation_thms = Domain_Take_Proofs.get_deflation_thms thy
    4.40  
    4.41 -  val n = Free ("n", @{typ nat});
    4.42 -  val n' = @{const Suc} $ n;
    4.43 +  val n = Free ("n", @{typ nat})
    4.44 +  val n' = @{const Suc} $ n
    4.45  
    4.46    local
    4.47 -    val newTs = map (#absT o #iso_info) constr_infos;
    4.48 -    val subs = newTs ~~ map (fn t => t $ n) take_consts;
    4.49 +    val newTs = map (#absT o #iso_info) constr_infos
    4.50 +    val subs = newTs ~~ map (fn t => t $ n) take_consts
    4.51      fun is_ID (Const (c, _)) = (c = @{const_name ID})
    4.52 -      | is_ID _              = false;
    4.53 +      | is_ID _              = false
    4.54    in
    4.55      fun map_of_arg thy v T =
    4.56 -      let val m = Domain_Take_Proofs.map_of_typ thy subs T;
    4.57 -      in if is_ID m then v else mk_capply (m, v) end;
    4.58 +      let val m = Domain_Take_Proofs.map_of_typ thy subs T
    4.59 +      in if is_ID m then v else mk_capply (m, v) end
    4.60    end
    4.61  
    4.62    fun prove_take_apps
    4.63        ((dbind, take_const), constr_info) thy =
    4.64      let
    4.65 -      val {iso_info, con_specs, con_betas, ...} = constr_info;
    4.66 -      val {abs_inverse, ...} = iso_info;
    4.67 +      val {iso_info, con_specs, con_betas, ...} = constr_info
    4.68 +      val {abs_inverse, ...} = iso_info
    4.69        fun prove_take_app (con_const, args) =
    4.70          let
    4.71 -          val Ts = map snd args;
    4.72 -          val ns = Name.variant_list ["n"] (Datatype_Prop.make_tnames Ts);
    4.73 -          val vs = map Free (ns ~~ Ts);
    4.74 -          val lhs = mk_capply (take_const $ n', list_ccomb (con_const, vs));
    4.75 -          val rhs = list_ccomb (con_const, map2 (map_of_arg thy) vs Ts);
    4.76 -          val goal = mk_trp (mk_eq (lhs, rhs));
    4.77 +          val Ts = map snd args
    4.78 +          val ns = Name.variant_list ["n"] (Datatype_Prop.make_tnames Ts)
    4.79 +          val vs = map Free (ns ~~ Ts)
    4.80 +          val lhs = mk_capply (take_const $ n', list_ccomb (con_const, vs))
    4.81 +          val rhs = list_ccomb (con_const, map2 (map_of_arg thy) vs Ts)
    4.82 +          val goal = mk_trp (mk_eq (lhs, rhs))
    4.83            val rules =
    4.84                [abs_inverse] @ con_betas @ @{thms take_con_rules}
    4.85 -              @ take_Suc_thms @ deflation_thms @ deflation_take_thms;
    4.86 -          val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
    4.87 +              @ take_Suc_thms @ deflation_thms @ deflation_take_thms
    4.88 +          val tac = simp_tac (HOL_basic_ss addsimps rules) 1
    4.89          in
    4.90            Goal.prove_global thy [] [] goal (K tac)
    4.91 -        end;
    4.92 -      val take_apps = map prove_take_app con_specs;
    4.93 +        end
    4.94 +      val take_apps = map prove_take_app con_specs
    4.95      in
    4.96        yield_singleton Global_Theory.add_thmss
    4.97          ((Binding.qualified true "take_rews" dbind, take_apps),
    4.98          [Simplifier.simp_add]) thy
    4.99 -    end;
   4.100 +    end
   4.101  in
   4.102    fold_map prove_take_apps
   4.103      (dbinds ~~ take_consts ~~ constr_infos) thy
   4.104 -end;
   4.105 +end
   4.106  
   4.107  (******************************************************************************)
   4.108  (****************************** induction rules *******************************)
   4.109  (******************************************************************************)
   4.110  
   4.111  val case_UU_allI =
   4.112 -    @{lemma "(!!x. x ~= UU ==> P x) ==> P UU ==> ALL x. P x" by metis};
   4.113 +    @{lemma "(!!x. x ~= UU ==> P x) ==> P UU ==> ALL x. P x" by metis}
   4.114  
   4.115  fun prove_induction
   4.116      (comp_dbind : binding)
   4.117 @@ -100,135 +100,135 @@
   4.118      (take_rews : thm list)
   4.119      (thy : theory) =
   4.120  let
   4.121 -  val comp_dname = Binding.name_of comp_dbind;
   4.122 +  val comp_dname = Binding.name_of comp_dbind
   4.123  
   4.124 -  val iso_infos = map #iso_info constr_infos;
   4.125 -  val exhausts = map #exhaust constr_infos;
   4.126 -  val con_rews = maps #con_rews constr_infos;
   4.127 -  val {take_consts, take_induct_thms, ...} = take_info;
   4.128 +  val iso_infos = map #iso_info constr_infos
   4.129 +  val exhausts = map #exhaust constr_infos
   4.130 +  val con_rews = maps #con_rews constr_infos
   4.131 +  val {take_consts, take_induct_thms, ...} = take_info
   4.132  
   4.133 -  val newTs = map #absT iso_infos;
   4.134 -  val P_names = Datatype_Prop.indexify_names (map (K "P") newTs);
   4.135 -  val x_names = Datatype_Prop.indexify_names (map (K "x") newTs);
   4.136 -  val P_types = map (fn T => T --> HOLogic.boolT) newTs;
   4.137 -  val Ps = map Free (P_names ~~ P_types);
   4.138 -  val xs = map Free (x_names ~~ newTs);
   4.139 -  val n = Free ("n", HOLogic.natT);
   4.140 +  val newTs = map #absT iso_infos
   4.141 +  val P_names = Datatype_Prop.indexify_names (map (K "P") newTs)
   4.142 +  val x_names = Datatype_Prop.indexify_names (map (K "x") newTs)
   4.143 +  val P_types = map (fn T => T --> HOLogic.boolT) newTs
   4.144 +  val Ps = map Free (P_names ~~ P_types)
   4.145 +  val xs = map Free (x_names ~~ newTs)
   4.146 +  val n = Free ("n", HOLogic.natT)
   4.147  
   4.148    fun con_assm defined p (con, args) =
   4.149      let
   4.150 -      val Ts = map snd args;
   4.151 -      val ns = Name.variant_list P_names (Datatype_Prop.make_tnames Ts);
   4.152 -      val vs = map Free (ns ~~ Ts);
   4.153 -      val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
   4.154 +      val Ts = map snd args
   4.155 +      val ns = Name.variant_list P_names (Datatype_Prop.make_tnames Ts)
   4.156 +      val vs = map Free (ns ~~ Ts)
   4.157 +      val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs))
   4.158        fun ind_hyp (v, T) t =
   4.159            case AList.lookup (op =) (newTs ~~ Ps) T of NONE => t
   4.160 -          | SOME p' => Logic.mk_implies (mk_trp (p' $ v), t);
   4.161 -      val t1 = mk_trp (p $ list_ccomb (con, vs));
   4.162 -      val t2 = fold_rev ind_hyp (vs ~~ Ts) t1;
   4.163 -      val t3 = Logic.list_implies (map (mk_trp o mk_defined) nonlazy, t2);
   4.164 -    in fold_rev Logic.all vs (if defined then t3 else t2) end;
   4.165 +          | SOME p' => Logic.mk_implies (mk_trp (p' $ v), t)
   4.166 +      val t1 = mk_trp (p $ list_ccomb (con, vs))
   4.167 +      val t2 = fold_rev ind_hyp (vs ~~ Ts) t1
   4.168 +      val t3 = Logic.list_implies (map (mk_trp o mk_defined) nonlazy, t2)
   4.169 +    in fold_rev Logic.all vs (if defined then t3 else t2) end
   4.170    fun eq_assms ((p, T), cons) =
   4.171 -      mk_trp (p $ HOLCF_Library.mk_bottom T) :: map (con_assm true p) cons;
   4.172 -  val assms = maps eq_assms (Ps ~~ newTs ~~ map #con_specs constr_infos);
   4.173 +      mk_trp (p $ HOLCF_Library.mk_bottom T) :: map (con_assm true p) cons
   4.174 +  val assms = maps eq_assms (Ps ~~ newTs ~~ map #con_specs constr_infos)
   4.175  
   4.176 -  val take_ss = HOL_ss addsimps (@{thm Rep_cfun_strict1} :: take_rews);
   4.177 +  val take_ss = HOL_ss addsimps (@{thm Rep_cfun_strict1} :: take_rews)
   4.178    fun quant_tac ctxt i = EVERY
   4.179 -    (map (fn name => res_inst_tac ctxt [(("x", 0), name)] spec i) x_names);
   4.180 +    (map (fn name => res_inst_tac ctxt [(("x", 0), name)] spec i) x_names)
   4.181  
   4.182    (* FIXME: move this message to domain_take_proofs.ML *)
   4.183 -  val is_finite = #is_finite take_info;
   4.184 +  val is_finite = #is_finite take_info
   4.185    val _ = if is_finite
   4.186            then message ("Proving finiteness rule for domain "^comp_dname^" ...")
   4.187 -          else ();
   4.188 +          else ()
   4.189  
   4.190 -  val _ = trace " Proving finite_ind...";
   4.191 +  val _ = trace " Proving finite_ind..."
   4.192    val finite_ind =
   4.193      let
   4.194        val concls =
   4.195            map (fn ((P, t), x) => P $ mk_capply (t $ n, x))
   4.196 -              (Ps ~~ take_consts ~~ xs);
   4.197 -      val goal = mk_trp (foldr1 mk_conj concls);
   4.198 +              (Ps ~~ take_consts ~~ xs)
   4.199 +      val goal = mk_trp (foldr1 mk_conj concls)
   4.200  
   4.201        fun tacf {prems, context} =
   4.202          let
   4.203            (* Prove stronger prems, without definedness side conditions *)
   4.204            fun con_thm p (con, args) =
   4.205              let
   4.206 -              val subgoal = con_assm false p (con, args);
   4.207 -              val rules = prems @ con_rews @ simp_thms;
   4.208 -              val simplify = asm_simp_tac (HOL_basic_ss addsimps rules);
   4.209 +              val subgoal = con_assm false p (con, args)
   4.210 +              val rules = prems @ con_rews @ simp_thms
   4.211 +              val simplify = asm_simp_tac (HOL_basic_ss addsimps rules)
   4.212                fun arg_tac (lazy, _) =
   4.213 -                  rtac (if lazy then allI else case_UU_allI) 1;
   4.214 +                  rtac (if lazy then allI else case_UU_allI) 1
   4.215                val tacs =
   4.216                    rewrite_goals_tac @{thms atomize_all atomize_imp} ::
   4.217                    map arg_tac args @
   4.218 -                  [REPEAT (rtac impI 1), ALLGOALS simplify];
   4.219 +                  [REPEAT (rtac impI 1), ALLGOALS simplify]
   4.220              in
   4.221                Goal.prove context [] [] subgoal (K (EVERY tacs))
   4.222 -            end;
   4.223 -          fun eq_thms (p, cons) = map (con_thm p) cons;
   4.224 -          val conss = map #con_specs constr_infos;
   4.225 -          val prems' = maps eq_thms (Ps ~~ conss);
   4.226 +            end
   4.227 +          fun eq_thms (p, cons) = map (con_thm p) cons
   4.228 +          val conss = map #con_specs constr_infos
   4.229 +          val prems' = maps eq_thms (Ps ~~ conss)
   4.230  
   4.231            val tacs1 = [
   4.232              quant_tac context 1,
   4.233              simp_tac HOL_ss 1,
   4.234              InductTacs.induct_tac context [[SOME "n"]] 1,
   4.235              simp_tac (take_ss addsimps prems) 1,
   4.236 -            TRY (safe_tac HOL_cs)];
   4.237 +            TRY (safe_tac HOL_cs)]
   4.238            fun con_tac _ = 
   4.239              asm_simp_tac take_ss 1 THEN
   4.240 -            (resolve_tac prems' THEN_ALL_NEW etac spec) 1;
   4.241 +            (resolve_tac prems' THEN_ALL_NEW etac spec) 1
   4.242            fun cases_tacs (cons, exhaust) =
   4.243              res_inst_tac context [(("y", 0), "x")] exhaust 1 ::
   4.244              asm_simp_tac (take_ss addsimps prems) 1 ::
   4.245 -            map con_tac cons;
   4.246 +            map con_tac cons
   4.247            val tacs = tacs1 @ maps cases_tacs (conss ~~ exhausts)
   4.248          in
   4.249            EVERY (map DETERM tacs)
   4.250 -        end;
   4.251 -    in Goal.prove_global thy [] assms goal tacf end;
   4.252 +        end
   4.253 +    in Goal.prove_global thy [] assms goal tacf end
   4.254  
   4.255 -  val _ = trace " Proving ind...";
   4.256 +  val _ = trace " Proving ind..."
   4.257    val ind =
   4.258      let
   4.259 -      val concls = map (op $) (Ps ~~ xs);
   4.260 -      val goal = mk_trp (foldr1 mk_conj concls);
   4.261 -      val adms = if is_finite then [] else map (mk_trp o mk_adm) Ps;
   4.262 +      val concls = map (op $) (Ps ~~ xs)
   4.263 +      val goal = mk_trp (foldr1 mk_conj concls)
   4.264 +      val adms = if is_finite then [] else map (mk_trp o mk_adm) Ps
   4.265        fun tacf {prems, context} =
   4.266          let
   4.267            fun finite_tac (take_induct, fin_ind) =
   4.268                rtac take_induct 1 THEN
   4.269                (if is_finite then all_tac else resolve_tac prems 1) THEN
   4.270 -              (rtac fin_ind THEN_ALL_NEW solve_tac prems) 1;
   4.271 -          val fin_inds = Project_Rule.projections context finite_ind;
   4.272 +              (rtac fin_ind THEN_ALL_NEW solve_tac prems) 1
   4.273 +          val fin_inds = Project_Rule.projections context finite_ind
   4.274          in
   4.275            TRY (safe_tac HOL_cs) THEN
   4.276            EVERY (map finite_tac (take_induct_thms ~~ fin_inds))
   4.277 -        end;
   4.278 +        end
   4.279      in Goal.prove_global thy [] (adms @ assms) goal tacf end
   4.280  
   4.281    (* case names for induction rules *)
   4.282 -  val dnames = map (fst o dest_Type) newTs;
   4.283 +  val dnames = map (fst o dest_Type) newTs
   4.284    val case_ns =
   4.285      let
   4.286        val adms =
   4.287            if is_finite then [] else
   4.288            if length dnames = 1 then ["adm"] else
   4.289 -          map (fn s => "adm_" ^ Long_Name.base_name s) dnames;
   4.290 +          map (fn s => "adm_" ^ Long_Name.base_name s) dnames
   4.291        val bottoms =
   4.292            if length dnames = 1 then ["bottom"] else
   4.293 -          map (fn s => "bottom_" ^ Long_Name.base_name s) dnames;
   4.294 +          map (fn s => "bottom_" ^ Long_Name.base_name s) dnames
   4.295        fun one_eq bot constr_info =
   4.296 -        let fun name_of (c, args) = Long_Name.base_name (fst (dest_Const c));
   4.297 -        in bot :: map name_of (#con_specs constr_info) end;
   4.298 -    in adms @ flat (map2 one_eq bottoms constr_infos) end;
   4.299 +        let fun name_of (c, args) = Long_Name.base_name (fst (dest_Const c))
   4.300 +        in bot :: map name_of (#con_specs constr_info) end
   4.301 +    in adms @ flat (map2 one_eq bottoms constr_infos) end
   4.302  
   4.303 -  val inducts = Project_Rule.projections (ProofContext.init_global thy) ind;
   4.304 +  val inducts = Project_Rule.projections (ProofContext.init_global thy) ind
   4.305    fun ind_rule (dname, rule) =
   4.306        ((Binding.empty, rule),
   4.307 -       [Rule_Cases.case_names case_ns, Induct.induct_type dname]);
   4.308 +       [Rule_Cases.case_names case_ns, Induct.induct_type dname])
   4.309  
   4.310  in
   4.311    thy
   4.312 @@ -236,7 +236,7 @@
   4.313       ((Binding.qualified true "finite_induct" comp_dbind, finite_ind), []),
   4.314       ((Binding.qualified true "induct"        comp_dbind, ind       ), [])]
   4.315    |> (snd o Global_Theory.add_thms (map ind_rule (dnames ~~ inducts)))
   4.316 -end; (* prove_induction *)
   4.317 +end (* prove_induction *)
   4.318  
   4.319  (******************************************************************************)
   4.320  (************************ bisimulation and coinduction ************************)
   4.321 @@ -249,83 +249,83 @@
   4.322      (take_rews : thm list list)
   4.323      (thy : theory) : theory =
   4.324  let
   4.325 -  val iso_infos = map #iso_info constr_infos;
   4.326 -  val newTs = map #absT iso_infos;
   4.327 +  val iso_infos = map #iso_info constr_infos
   4.328 +  val newTs = map #absT iso_infos
   4.329  
   4.330 -  val {take_consts, take_0_thms, take_lemma_thms, ...} = take_info;
   4.331 +  val {take_consts, take_0_thms, take_lemma_thms, ...} = take_info
   4.332  
   4.333 -  val R_names = Datatype_Prop.indexify_names (map (K "R") newTs);
   4.334 -  val R_types = map (fn T => T --> T --> boolT) newTs;
   4.335 -  val Rs = map Free (R_names ~~ R_types);
   4.336 -  val n = Free ("n", natT);
   4.337 -  val reserved = "x" :: "y" :: R_names;
   4.338 +  val R_names = Datatype_Prop.indexify_names (map (K "R") newTs)
   4.339 +  val R_types = map (fn T => T --> T --> boolT) newTs
   4.340 +  val Rs = map Free (R_names ~~ R_types)
   4.341 +  val n = Free ("n", natT)
   4.342 +  val reserved = "x" :: "y" :: R_names
   4.343  
   4.344    (* declare bisimulation predicate *)
   4.345 -  val bisim_bind = Binding.suffix_name "_bisim" comp_dbind;
   4.346 -  val bisim_type = R_types ---> boolT;
   4.347 +  val bisim_bind = Binding.suffix_name "_bisim" comp_dbind
   4.348 +  val bisim_type = R_types ---> boolT
   4.349    val (bisim_const, thy) =
   4.350 -      Sign.declare_const ((bisim_bind, bisim_type), NoSyn) thy;
   4.351 +      Sign.declare_const ((bisim_bind, bisim_type), NoSyn) thy
   4.352  
   4.353    (* define bisimulation predicate *)
   4.354    local
   4.355      fun one_con T (con, args) =
   4.356        let
   4.357 -        val Ts = map snd args;
   4.358 -        val ns1 = Name.variant_list reserved (Datatype_Prop.make_tnames Ts);
   4.359 -        val ns2 = map (fn n => n^"'") ns1;
   4.360 -        val vs1 = map Free (ns1 ~~ Ts);
   4.361 -        val vs2 = map Free (ns2 ~~ Ts);
   4.362 -        val eq1 = mk_eq (Free ("x", T), list_ccomb (con, vs1));
   4.363 -        val eq2 = mk_eq (Free ("y", T), list_ccomb (con, vs2));
   4.364 +        val Ts = map snd args
   4.365 +        val ns1 = Name.variant_list reserved (Datatype_Prop.make_tnames Ts)
   4.366 +        val ns2 = map (fn n => n^"'") ns1
   4.367 +        val vs1 = map Free (ns1 ~~ Ts)
   4.368 +        val vs2 = map Free (ns2 ~~ Ts)
   4.369 +        val eq1 = mk_eq (Free ("x", T), list_ccomb (con, vs1))
   4.370 +        val eq2 = mk_eq (Free ("y", T), list_ccomb (con, vs2))
   4.371          fun rel ((v1, v2), T) =
   4.372              case AList.lookup (op =) (newTs ~~ Rs) T of
   4.373 -              NONE => mk_eq (v1, v2) | SOME r => r $ v1 $ v2;
   4.374 -        val eqs = foldr1 mk_conj (map rel (vs1 ~~ vs2 ~~ Ts) @ [eq1, eq2]);
   4.375 +              NONE => mk_eq (v1, v2) | SOME r => r $ v1 $ v2
   4.376 +        val eqs = foldr1 mk_conj (map rel (vs1 ~~ vs2 ~~ Ts) @ [eq1, eq2])
   4.377        in
   4.378          Library.foldr mk_ex (vs1 @ vs2, eqs)
   4.379 -      end;
   4.380 +      end
   4.381      fun one_eq ((T, R), cons) =
   4.382        let
   4.383 -        val x = Free ("x", T);
   4.384 -        val y = Free ("y", T);
   4.385 -        val disj1 = mk_conj (mk_eq (x, mk_bottom T), mk_eq (y, mk_bottom T));
   4.386 -        val disjs = disj1 :: map (one_con T) cons;
   4.387 +        val x = Free ("x", T)
   4.388 +        val y = Free ("y", T)
   4.389 +        val disj1 = mk_conj (mk_eq (x, mk_bottom T), mk_eq (y, mk_bottom T))
   4.390 +        val disjs = disj1 :: map (one_con T) cons
   4.391        in
   4.392          mk_all (x, mk_all (y, mk_imp (R $ x $ y, foldr1 mk_disj disjs)))
   4.393 -      end;
   4.394 -    val conjs = map one_eq (newTs ~~ Rs ~~ map #con_specs constr_infos);
   4.395 -    val bisim_rhs = lambdas Rs (Library.foldr1 mk_conj conjs);
   4.396 -    val bisim_eqn = Logic.mk_equals (bisim_const, bisim_rhs);
   4.397 +      end
   4.398 +    val conjs = map one_eq (newTs ~~ Rs ~~ map #con_specs constr_infos)
   4.399 +    val bisim_rhs = lambdas Rs (Library.foldr1 mk_conj conjs)
   4.400 +    val bisim_eqn = Logic.mk_equals (bisim_const, bisim_rhs)
   4.401    in
   4.402      val (bisim_def_thm, thy) = thy |>
   4.403          yield_singleton (Global_Theory.add_defs false)
   4.404 -         ((Binding.qualified true "bisim_def" comp_dbind, bisim_eqn), []);
   4.405 +         ((Binding.qualified true "bisim_def" comp_dbind, bisim_eqn), [])
   4.406    end (* local *)
   4.407  
   4.408    (* prove coinduction lemma *)
   4.409    val coind_lemma =
   4.410      let
   4.411 -      val assm = mk_trp (list_comb (bisim_const, Rs));
   4.412 +      val assm = mk_trp (list_comb (bisim_const, Rs))
   4.413        fun one ((T, R), take_const) =
   4.414          let
   4.415 -          val x = Free ("x", T);
   4.416 -          val y = Free ("y", T);
   4.417 -          val lhs = mk_capply (take_const $ n, x);
   4.418 -          val rhs = mk_capply (take_const $ n, y);
   4.419 +          val x = Free ("x", T)
   4.420 +          val y = Free ("y", T)
   4.421 +          val lhs = mk_capply (take_const $ n, x)
   4.422 +          val rhs = mk_capply (take_const $ n, y)
   4.423          in
   4.424            mk_all (x, mk_all (y, mk_imp (R $ x $ y, mk_eq (lhs, rhs))))
   4.425 -        end;
   4.426 +        end
   4.427        val goal =
   4.428 -          mk_trp (foldr1 mk_conj (map one (newTs ~~ Rs ~~ take_consts)));
   4.429 -      val rules = @{thm Rep_cfun_strict1} :: take_0_thms;
   4.430 +          mk_trp (foldr1 mk_conj (map one (newTs ~~ Rs ~~ take_consts)))
   4.431 +      val rules = @{thm Rep_cfun_strict1} :: take_0_thms
   4.432        fun tacf {prems, context} =
   4.433          let
   4.434 -          val prem' = rewrite_rule [bisim_def_thm] (hd prems);
   4.435 -          val prems' = Project_Rule.projections context prem';
   4.436 -          val dests = map (fn th => th RS spec RS spec RS mp) prems';
   4.437 +          val prem' = rewrite_rule [bisim_def_thm] (hd prems)
   4.438 +          val prems' = Project_Rule.projections context prem'
   4.439 +          val dests = map (fn th => th RS spec RS spec RS mp) prems'
   4.440            fun one_tac (dest, rews) =
   4.441                dtac dest 1 THEN safe_tac HOL_cs THEN
   4.442 -              ALLGOALS (asm_simp_tac (HOL_basic_ss addsimps rews));
   4.443 +              ALLGOALS (asm_simp_tac (HOL_basic_ss addsimps rews))
   4.444          in
   4.445            rtac @{thm nat.induct} 1 THEN
   4.446            simp_tac (HOL_ss addsimps rules) 1 THEN
   4.447 @@ -334,33 +334,33 @@
   4.448          end
   4.449      in
   4.450        Goal.prove_global thy [] [assm] goal tacf
   4.451 -    end;
   4.452 +    end
   4.453  
   4.454    (* prove individual coinduction rules *)
   4.455    fun prove_coind ((T, R), take_lemma) =
   4.456      let
   4.457 -      val x = Free ("x", T);
   4.458 -      val y = Free ("y", T);
   4.459 -      val assm1 = mk_trp (list_comb (bisim_const, Rs));
   4.460 -      val assm2 = mk_trp (R $ x $ y);
   4.461 -      val goal = mk_trp (mk_eq (x, y));
   4.462 +      val x = Free ("x", T)
   4.463 +      val y = Free ("y", T)
   4.464 +      val assm1 = mk_trp (list_comb (bisim_const, Rs))
   4.465 +      val assm2 = mk_trp (R $ x $ y)
   4.466 +      val goal = mk_trp (mk_eq (x, y))
   4.467        fun tacf {prems, context} =
   4.468          let
   4.469 -          val rule = hd prems RS coind_lemma;
   4.470 +          val rule = hd prems RS coind_lemma
   4.471          in
   4.472            rtac take_lemma 1 THEN
   4.473            asm_simp_tac (HOL_basic_ss addsimps (rule :: prems)) 1
   4.474 -        end;
   4.475 +        end
   4.476      in
   4.477        Goal.prove_global thy [] [assm1, assm2] goal tacf
   4.478 -    end;
   4.479 -  val coinds = map prove_coind (newTs ~~ Rs ~~ take_lemma_thms);
   4.480 -  val coind_binds = map (Binding.qualified true "coinduct") dbinds;
   4.481 +    end
   4.482 +  val coinds = map prove_coind (newTs ~~ Rs ~~ take_lemma_thms)
   4.483 +  val coind_binds = map (Binding.qualified true "coinduct") dbinds
   4.484  
   4.485  in
   4.486    thy |> snd o Global_Theory.add_thms
   4.487      (map Thm.no_attributes (coind_binds ~~ coinds))
   4.488 -end; (* let *)
   4.489 +end (* let *)
   4.490  
   4.491  (******************************************************************************)
   4.492  (******************************* main function ********************************)
   4.493 @@ -373,67 +373,67 @@
   4.494      (thy : theory) =
   4.495  let
   4.496  
   4.497 -val comp_dname = space_implode "_" (map Binding.name_of dbinds);
   4.498 -val comp_dbind = Binding.name comp_dname;
   4.499 +val comp_dname = space_implode "_" (map Binding.name_of dbinds)
   4.500 +val comp_dbind = Binding.name comp_dname
   4.501  
   4.502  (* Test for emptiness *)
   4.503  (* FIXME: reimplement emptiness test
   4.504  local
   4.505 -  open Domain_Library;
   4.506 -  val dnames = map (fst o fst) eqs;
   4.507 -  val conss = map snd eqs;
   4.508 +  open Domain_Library
   4.509 +  val dnames = map (fst o fst) eqs
   4.510 +  val conss = map snd eqs
   4.511    fun rec_to ns lazy_rec (n,cons) = forall (exists (fn arg => 
   4.512          is_rec arg andalso not (member (op =) ns (rec_of arg)) andalso
   4.513          ((rec_of arg =  n andalso not (lazy_rec orelse is_lazy arg)) orelse 
   4.514            rec_of arg <> n andalso rec_to (rec_of arg::ns) 
   4.515              (lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
   4.516 -        ) o snd) cons;
   4.517 +        ) o snd) cons
   4.518    fun warn (n,cons) =
   4.519      if rec_to [] false (n,cons)
   4.520 -    then (warning ("domain "^List.nth(dnames,n)^" is empty!"); true)
   4.521 -    else false;
   4.522 +    then (warning ("domain "^List.nth(dnames,n)^" is empty!") true)
   4.523 +    else false
   4.524  in
   4.525 -  val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs;
   4.526 -  val is_emptys = map warn n__eqs;
   4.527 -end;
   4.528 +  val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs
   4.529 +  val is_emptys = map warn n__eqs
   4.530 +end
   4.531  *)
   4.532  
   4.533  (* Test for indirect recursion *)
   4.534  local
   4.535 -  val newTs = map (#absT o #iso_info) constr_infos;
   4.536 +  val newTs = map (#absT o #iso_info) constr_infos
   4.537    fun indirect_typ (Type (_, Ts)) =
   4.538        exists (fn T => member (op =) newTs T orelse indirect_typ T) Ts
   4.539 -    | indirect_typ _ = false;
   4.540 -  fun indirect_arg (_, T) = indirect_typ T;
   4.541 -  fun indirect_con (_, args) = exists indirect_arg args;
   4.542 -  fun indirect_eq cons = exists indirect_con cons;
   4.543 +    | indirect_typ _ = false
   4.544 +  fun indirect_arg (_, T) = indirect_typ T
   4.545 +  fun indirect_con (_, args) = exists indirect_arg args
   4.546 +  fun indirect_eq cons = exists indirect_con cons
   4.547  in
   4.548 -  val is_indirect = exists indirect_eq (map #con_specs constr_infos);
   4.549 +  val is_indirect = exists indirect_eq (map #con_specs constr_infos)
   4.550    val _ =
   4.551        if is_indirect
   4.552        then message "Indirect recursion detected, skipping proofs of (co)induction rules"
   4.553 -      else message ("Proving induction properties of domain "^comp_dname^" ...");
   4.554 -end;
   4.555 +      else message ("Proving induction properties of domain "^comp_dname^" ...")
   4.556 +end
   4.557  
   4.558  (* theorems about take *)
   4.559  
   4.560  val (take_rewss, thy) =
   4.561 -    take_theorems dbinds take_info constr_infos thy;
   4.562 +    take_theorems dbinds take_info constr_infos thy
   4.563  
   4.564 -val {take_lemma_thms, take_0_thms, take_strict_thms, ...} = take_info;
   4.565 +val {take_lemma_thms, take_0_thms, take_strict_thms, ...} = take_info
   4.566  
   4.567 -val take_rews = take_0_thms @ take_strict_thms @ flat take_rewss;
   4.568 +val take_rews = take_0_thms @ take_strict_thms @ flat take_rewss
   4.569  
   4.570  (* prove induction rules, unless definition is indirect recursive *)
   4.571  val thy =
   4.572      if is_indirect then thy else
   4.573 -    prove_induction comp_dbind constr_infos take_info take_rews thy;
   4.574 +    prove_induction comp_dbind constr_infos take_info take_rews thy
   4.575  
   4.576  val thy =
   4.577      if is_indirect then thy else
   4.578 -    prove_coinduction (comp_dbind, dbinds) constr_infos take_info take_rewss thy;
   4.579 +    prove_coinduction (comp_dbind, dbinds) constr_infos take_info take_rewss thy
   4.580  
   4.581  in
   4.582    (take_rews, thy)
   4.583 -end; (* let *)
   4.584 -end; (* struct *)
   4.585 +end (* let *)
   4.586 +end (* struct *)
     5.1 --- a/src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML	Tue Nov 30 14:01:49 2010 -0800
     5.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_isomorphism.ML	Tue Nov 30 14:21:57 2010 -0800
     5.3 @@ -29,20 +29,20 @@
     5.4        -> theory -> theory
     5.5  
     5.6    val setup : theory -> theory
     5.7 -end;
     5.8 +end
     5.9  
    5.10  structure Domain_Isomorphism : DOMAIN_ISOMORPHISM =
    5.11  struct
    5.12  
    5.13  val beta_rules =
    5.14    @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
    5.15 -  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair cont2cont_prod_case'};
    5.16 +  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair cont2cont_prod_case'}
    5.17  
    5.18 -val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
    5.19 +val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules)
    5.20  
    5.21 -val beta_tac = simp_tac beta_ss;
    5.22 +val beta_tac = simp_tac beta_ss
    5.23  
    5.24 -fun is_cpo thy T = Sign.of_sort thy (T, @{sort cpo});
    5.25 +fun is_cpo thy T = Sign.of_sort thy (T, @{sort cpo})
    5.26  
    5.27  (******************************************************************************)
    5.28  (******************************** theory data *********************************)
    5.29 @@ -58,7 +58,7 @@
    5.30  (
    5.31    val name = "domain_isodefl"
    5.32    val description = "theorems like isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)"
    5.33 -);
    5.34 +)
    5.35  
    5.36  val setup = RepData.setup #> IsodeflData.setup
    5.37  
    5.38 @@ -67,51 +67,51 @@
    5.39  (************************** building types and terms **************************)
    5.40  (******************************************************************************)
    5.41  
    5.42 -open HOLCF_Library;
    5.43 +open HOLCF_Library
    5.44  
    5.45 -infixr 6 ->>;
    5.46 -infixr -->>;
    5.47 +infixr 6 ->>
    5.48 +infixr -->>
    5.49  
    5.50 -val udomT = @{typ udom};
    5.51 -val deflT = @{typ "defl"};
    5.52 +val udomT = @{typ udom}
    5.53 +val deflT = @{typ "defl"}
    5.54  
    5.55  fun mk_DEFL T =
    5.56 -  Const (@{const_name defl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
    5.57 +  Const (@{const_name defl}, Term.itselfT T --> deflT) $ Logic.mk_type T
    5.58  
    5.59  fun dest_DEFL (Const (@{const_name defl}, _) $ t) = Logic.dest_type t
    5.60 -  | dest_DEFL t = raise TERM ("dest_DEFL", [t]);
    5.61 +  | dest_DEFL t = raise TERM ("dest_DEFL", [t])
    5.62  
    5.63  fun mk_LIFTDEFL T =
    5.64 -  Const (@{const_name liftdefl}, Term.itselfT T --> deflT) $ Logic.mk_type T;
    5.65 +  Const (@{const_name liftdefl}, Term.itselfT T --> deflT) $ Logic.mk_type T
    5.66  
    5.67  fun dest_LIFTDEFL (Const (@{const_name liftdefl}, _) $ t) = Logic.dest_type t
    5.68 -  | dest_LIFTDEFL t = raise TERM ("dest_LIFTDEFL", [t]);
    5.69 +  | dest_LIFTDEFL t = raise TERM ("dest_LIFTDEFL", [t])
    5.70  
    5.71 -fun mk_u_defl t = mk_capply (@{const "u_defl"}, t);
    5.72 +fun mk_u_defl t = mk_capply (@{const "u_defl"}, t)
    5.73  
    5.74  fun mk_u_map t =
    5.75    let
    5.76 -    val (T, U) = dest_cfunT (fastype_of t);
    5.77 -    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
    5.78 -    val u_map_const = Const (@{const_name u_map}, u_map_type);
    5.79 +    val (T, U) = dest_cfunT (fastype_of t)
    5.80 +    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U)
    5.81 +    val u_map_const = Const (@{const_name u_map}, u_map_type)
    5.82    in
    5.83      mk_capply (u_map_const, t)
    5.84 -  end;
    5.85 +  end
    5.86  
    5.87 -fun emb_const T = Const (@{const_name emb}, T ->> udomT);
    5.88 -fun prj_const T = Const (@{const_name prj}, udomT ->> T);
    5.89 -fun coerce_const (T, U) = mk_cfcomp (prj_const U, emb_const T);
    5.90 +fun emb_const T = Const (@{const_name emb}, T ->> udomT)
    5.91 +fun prj_const T = Const (@{const_name prj}, udomT ->> T)
    5.92 +fun coerce_const (T, U) = mk_cfcomp (prj_const U, emb_const T)
    5.93  
    5.94  fun isodefl_const T =
    5.95 -  Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
    5.96 +  Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT)
    5.97  
    5.98  fun mk_deflation t =
    5.99 -  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
   5.100 +  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t
   5.101  
   5.102  (* splits a cterm into the right and lefthand sides of equality *)
   5.103 -fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
   5.104 +fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t)
   5.105  
   5.106 -fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
   5.107 +fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u))
   5.108  
   5.109  (******************************************************************************)
   5.110  (****************************** isomorphism info ******************************)
   5.111 @@ -119,9 +119,9 @@
   5.112  
   5.113  fun deflation_abs_rep (info : Domain_Take_Proofs.iso_info) : thm =
   5.114    let
   5.115 -    val abs_iso = #abs_inverse info;
   5.116 -    val rep_iso = #rep_inverse info;
   5.117 -    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
   5.118 +    val abs_iso = #abs_inverse info
   5.119 +    val rep_iso = #rep_inverse info
   5.120 +    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso]
   5.121    in
   5.122      Drule.zero_var_indexes thm
   5.123    end
   5.124 @@ -132,19 +132,19 @@
   5.125  
   5.126  fun mk_projs []      t = []
   5.127    | mk_projs (x::[]) t = [(x, t)]
   5.128 -  | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
   5.129 +  | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t)
   5.130  
   5.131  fun add_fixdefs
   5.132      (spec : (binding * term) list)
   5.133      (thy : theory) : (thm list * thm list) * theory =
   5.134    let
   5.135 -    val binds = map fst spec;
   5.136 -    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
   5.137 -    val functional = lambda_tuple lhss (mk_tuple rhss);
   5.138 -    val fixpoint = mk_fix (mk_cabs functional);
   5.139 +    val binds = map fst spec
   5.140 +    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec)
   5.141 +    val functional = lambda_tuple lhss (mk_tuple rhss)
   5.142 +    val fixpoint = mk_fix (mk_cabs functional)
   5.143  
   5.144      (* project components of fixpoint *)
   5.145 -    val projs = mk_projs lhss fixpoint;
   5.146 +    val projs = mk_projs lhss fixpoint
   5.147  
   5.148      (* convert parameters to lambda abstractions *)
   5.149      fun mk_eqn (lhs, rhs) =
   5.150 @@ -154,48 +154,48 @@
   5.151          | f $ Const (@{const_name TYPE}, T) =>
   5.152              mk_eqn (f, Abs ("t", T, rhs))
   5.153          | Const _ => Logic.mk_equals (lhs, rhs)
   5.154 -        | _ => raise TERM ("lhs not of correct form", [lhs, rhs]);
   5.155 -    val eqns = map mk_eqn projs;
   5.156 +        | _ => raise TERM ("lhs not of correct form", [lhs, rhs])
   5.157 +    val eqns = map mk_eqn projs
   5.158  
   5.159      (* register constant definitions *)
   5.160      val (fixdef_thms, thy) =
   5.161        (Global_Theory.add_defs false o map Thm.no_attributes)
   5.162 -        (map (Binding.suffix_name "_def") binds ~~ eqns) thy;
   5.163 +        (map (Binding.suffix_name "_def") binds ~~ eqns) thy
   5.164  
   5.165      (* prove applied version of definitions *)
   5.166      fun prove_proj (lhs, rhs) =
   5.167        let
   5.168 -        val tac = rewrite_goals_tac fixdef_thms THEN beta_tac 1;
   5.169 -        val goal = Logic.mk_equals (lhs, rhs);
   5.170 -      in Goal.prove_global thy [] [] goal (K tac) end;
   5.171 -    val proj_thms = map prove_proj projs;
   5.172 +        val tac = rewrite_goals_tac fixdef_thms THEN beta_tac 1
   5.173 +        val goal = Logic.mk_equals (lhs, rhs)
   5.174 +      in Goal.prove_global thy [] [] goal (K tac) end
   5.175 +    val proj_thms = map prove_proj projs
   5.176  
   5.177      (* mk_tuple lhss == fixpoint *)
   5.178 -    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
   5.179 -    val tuple_fixdef_thm = foldr1 pair_equalI proj_thms;
   5.180 +    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2]
   5.181 +    val tuple_fixdef_thm = foldr1 pair_equalI proj_thms
   5.182  
   5.183      val cont_thm =
   5.184        Goal.prove_global thy [] [] (mk_trp (mk_cont functional))
   5.185 -        (K (beta_tac 1));
   5.186 +        (K (beta_tac 1))
   5.187      val tuple_unfold_thm =
   5.188        (@{thm def_cont_fix_eq} OF [tuple_fixdef_thm, cont_thm])
   5.189 -      |> Local_Defs.unfold (ProofContext.init_global thy) @{thms split_conv};
   5.190 +      |> Local_Defs.unfold (ProofContext.init_global thy) @{thms split_conv}
   5.191  
   5.192      fun mk_unfold_thms [] thm = []
   5.193        | mk_unfold_thms (n::[]) thm = [(n, thm)]
   5.194        | mk_unfold_thms (n::ns) thm = let
   5.195 -          val thmL = thm RS @{thm Pair_eqD1};
   5.196 -          val thmR = thm RS @{thm Pair_eqD2};
   5.197 -        in (n, thmL) :: mk_unfold_thms ns thmR end;
   5.198 -    val unfold_binds = map (Binding.suffix_name "_unfold") binds;
   5.199 +          val thmL = thm RS @{thm Pair_eqD1}
   5.200 +          val thmR = thm RS @{thm Pair_eqD2}
   5.201 +        in (n, thmL) :: mk_unfold_thms ns thmR end
   5.202 +    val unfold_binds = map (Binding.suffix_name "_unfold") binds
   5.203  
   5.204      (* register unfold theorems *)
   5.205      val (unfold_thms, thy) =
   5.206        (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
   5.207 -        (mk_unfold_thms unfold_binds tuple_unfold_thm) thy;
   5.208 +        (mk_unfold_thms unfold_binds tuple_unfold_thm) thy
   5.209    in
   5.210      ((proj_thms, unfold_thms), thy)
   5.211 -  end;
   5.212 +  end
   5.213  
   5.214  
   5.215  (******************************************************************************)
   5.216 @@ -208,20 +208,20 @@
   5.217      (tab2 : (typ * term) list)
   5.218      (T : typ) : term =
   5.219    let
   5.220 -    val defl_simps = RepData.get (ProofContext.init_global thy);
   5.221 -    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) defl_simps;
   5.222 -    val rules' = map (apfst mk_DEFL) tab1 @ map (apfst mk_LIFTDEFL) tab2;
   5.223 +    val defl_simps = RepData.get (ProofContext.init_global thy)
   5.224 +    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) defl_simps
   5.225 +    val rules' = map (apfst mk_DEFL) tab1 @ map (apfst mk_LIFTDEFL) tab2
   5.226      fun proc1 t =
   5.227        (case dest_DEFL t of
   5.228          TFree (a, _) => SOME (Free ("d" ^ Library.unprefix "'" a, deflT))
   5.229 -      | _ => NONE) handle TERM _ => NONE;
   5.230 +      | _ => NONE) handle TERM _ => NONE
   5.231      fun proc2 t =
   5.232        (case dest_LIFTDEFL t of
   5.233          TFree (a, _) => SOME (Free ("p" ^ Library.unprefix "'" a, deflT))
   5.234 -      | _ => NONE) handle TERM _ => NONE;
   5.235 +      | _ => NONE) handle TERM _ => NONE
   5.236    in
   5.237      Pattern.rewrite_term thy (rules @ rules') [proc1, proc2] (mk_DEFL T)
   5.238 -  end;
   5.239 +  end
   5.240  
   5.241  (******************************************************************************)
   5.242  (********************* declaring definitions and theorems *********************)
   5.243 @@ -232,18 +232,18 @@
   5.244      (thy : theory)
   5.245      : (term * thm) * theory =
   5.246    let
   5.247 -    val typ = Term.fastype_of rhs;
   5.248 -    val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy;
   5.249 -    val eqn = Logic.mk_equals (const, rhs);
   5.250 -    val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn);
   5.251 -    val (def_thm, thy) = yield_singleton (Global_Theory.add_defs false) def thy;
   5.252 +    val typ = Term.fastype_of rhs
   5.253 +    val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy
   5.254 +    val eqn = Logic.mk_equals (const, rhs)
   5.255 +    val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn)
   5.256 +    val (def_thm, thy) = yield_singleton (Global_Theory.add_defs false) def thy
   5.257    in
   5.258      ((const, def_thm), thy)
   5.259 -  end;
   5.260 +  end
   5.261  
   5.262  fun add_qualified_thm name (dbind, thm) =
   5.263      yield_singleton Global_Theory.add_thms
   5.264 -      ((Binding.qualified true name dbind, thm), []);
   5.265 +      ((Binding.qualified true name dbind, thm), [])
   5.266  
   5.267  (******************************************************************************)
   5.268  (*************************** defining map functions ***************************)
   5.269 @@ -255,77 +255,77 @@
   5.270    let
   5.271  
   5.272      (* retrieve components of spec *)
   5.273 -    val dbinds = map fst spec;
   5.274 -    val iso_infos = map snd spec;
   5.275 -    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
   5.276 -    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
   5.277 +    val dbinds = map fst spec
   5.278 +    val iso_infos = map snd spec
   5.279 +    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos
   5.280 +    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos
   5.281  
   5.282      fun mapT (T as Type (_, Ts)) =
   5.283          (map (fn T => T ->> T) (filter (is_cpo thy) Ts)) -->> (T ->> T)
   5.284 -      | mapT T = T ->> T;
   5.285 +      | mapT T = T ->> T
   5.286  
   5.287      (* declare map functions *)
   5.288      fun declare_map_const (tbind, (lhsT, rhsT)) thy =
   5.289        let
   5.290 -        val map_type = mapT lhsT;
   5.291 -        val map_bind = Binding.suffix_name "_map" tbind;
   5.292 +        val map_type = mapT lhsT
   5.293 +        val map_bind = Binding.suffix_name "_map" tbind
   5.294        in
   5.295          Sign.declare_const ((map_bind, map_type), NoSyn) thy
   5.296 -      end;
   5.297 +      end
   5.298      val (map_consts, thy) = thy |>
   5.299 -      fold_map declare_map_const (dbinds ~~ dom_eqns);
   5.300 +      fold_map declare_map_const (dbinds ~~ dom_eqns)
   5.301  
   5.302      (* defining equations for map functions *)
   5.303      local
   5.304 -      fun unprime a = Library.unprefix "'" a;
   5.305 -      fun mapvar T = Free (unprime (fst (dest_TFree T)), T ->> T);
   5.306 +      fun unprime a = Library.unprefix "'" a
   5.307 +      fun mapvar T = Free (unprime (fst (dest_TFree T)), T ->> T)
   5.308        fun map_lhs (map_const, lhsT) =
   5.309 -          (lhsT, list_ccomb (map_const, map mapvar (filter (is_cpo thy) (snd (dest_Type lhsT)))));
   5.310 -      val tab1 = map map_lhs (map_consts ~~ map fst dom_eqns);
   5.311 -      val Ts = (snd o dest_Type o fst o hd) dom_eqns;
   5.312 -      val tab = (Ts ~~ map mapvar Ts) @ tab1;
   5.313 +          (lhsT, list_ccomb (map_const, map mapvar (filter (is_cpo thy) (snd (dest_Type lhsT)))))
   5.314 +      val tab1 = map map_lhs (map_consts ~~ map fst dom_eqns)
   5.315 +      val Ts = (snd o dest_Type o fst o hd) dom_eqns
   5.316 +      val tab = (Ts ~~ map mapvar Ts) @ tab1
   5.317        fun mk_map_spec (((rep_const, abs_const), map_const), (lhsT, rhsT)) =
   5.318          let
   5.319 -          val lhs = Domain_Take_Proofs.map_of_typ thy tab lhsT;
   5.320 -          val body = Domain_Take_Proofs.map_of_typ thy tab rhsT;
   5.321 -          val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
   5.322 -        in mk_eqs (lhs, rhs) end;
   5.323 +          val lhs = Domain_Take_Proofs.map_of_typ thy tab lhsT
   5.324 +          val body = Domain_Take_Proofs.map_of_typ thy tab rhsT
   5.325 +          val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const))
   5.326 +        in mk_eqs (lhs, rhs) end
   5.327      in
   5.328        val map_specs =
   5.329 -          map mk_map_spec (rep_abs_consts ~~ map_consts ~~ dom_eqns);
   5.330 -    end;
   5.331 +          map mk_map_spec (rep_abs_consts ~~ map_consts ~~ dom_eqns)
   5.332 +    end
   5.333  
   5.334      (* register recursive definition of map functions *)
   5.335 -    val map_binds = map (Binding.suffix_name "_map") dbinds;
   5.336 +    val map_binds = map (Binding.suffix_name "_map") dbinds
   5.337      val ((map_apply_thms, map_unfold_thms), thy) =
   5.338 -      add_fixdefs (map_binds ~~ map_specs) thy;
   5.339 +      add_fixdefs (map_binds ~~ map_specs) thy
   5.340  
   5.341      (* prove deflation theorems for map functions *)
   5.342 -    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
   5.343 +    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos
   5.344      val deflation_map_thm =
   5.345        let
   5.346 -        fun unprime a = Library.unprefix "'" a;
   5.347 -        fun mk_f T = Free (unprime (fst (dest_TFree T)), T ->> T);
   5.348 -        fun mk_assm T = mk_trp (mk_deflation (mk_f T));
   5.349 +        fun unprime a = Library.unprefix "'" a
   5.350 +        fun mk_f T = Free (unprime (fst (dest_TFree T)), T ->> T)
   5.351 +        fun mk_assm T = mk_trp (mk_deflation (mk_f T))
   5.352          fun mk_goal (map_const, (lhsT, rhsT)) =
   5.353            let
   5.354 -            val (_, Ts) = dest_Type lhsT;
   5.355 -            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
   5.356 -          in mk_deflation map_term end;
   5.357 -        val assms = (map mk_assm o filter (is_cpo thy) o snd o dest_Type o fst o hd) dom_eqns;
   5.358 -        val goals = map mk_goal (map_consts ~~ dom_eqns);
   5.359 -        val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
   5.360 +            val (_, Ts) = dest_Type lhsT
   5.361 +            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts))
   5.362 +          in mk_deflation map_term end
   5.363 +        val assms = (map mk_assm o filter (is_cpo thy) o snd o dest_Type o fst o hd) dom_eqns
   5.364 +        val goals = map mk_goal (map_consts ~~ dom_eqns)
   5.365 +        val goal = mk_trp (foldr1 HOLogic.mk_conj goals)
   5.366          val start_thms =
   5.367 -          @{thm split_def} :: map_apply_thms;
   5.368 +          @{thm split_def} :: map_apply_thms
   5.369          val adm_rules =
   5.370            @{thms adm_conj adm_subst [OF _ adm_deflation]
   5.371 -                 cont2cont_fst cont2cont_snd cont_id};
   5.372 +                 cont2cont_fst cont2cont_snd cont_id}
   5.373          val bottom_rules =
   5.374 -          @{thms fst_strict snd_strict deflation_UU simp_thms};
   5.375 +          @{thms fst_strict snd_strict deflation_UU simp_thms}
   5.376          val deflation_rules =
   5.377            @{thms conjI deflation_ID}
   5.378            @ deflation_abs_rep_thms
   5.379 -          @ Domain_Take_Proofs.get_deflation_thms thy;
   5.380 +          @ Domain_Take_Proofs.get_deflation_thms thy
   5.381        in
   5.382          Goal.prove_global thy [] assms goal (fn {prems, ...} =>
   5.383           EVERY
   5.384 @@ -337,34 +337,34 @@
   5.385             simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
   5.386             REPEAT (etac @{thm conjE} 1),
   5.387             REPEAT (resolve_tac (deflation_rules @ prems) 1 ORELSE atac 1)])
   5.388 -      end;
   5.389 +      end
   5.390      fun conjuncts [] thm = []
   5.391        | conjuncts (n::[]) thm = [(n, thm)]
   5.392        | conjuncts (n::ns) thm = let
   5.393 -          val thmL = thm RS @{thm conjunct1};
   5.394 -          val thmR = thm RS @{thm conjunct2};
   5.395 -        in (n, thmL):: conjuncts ns thmR end;
   5.396 +          val thmL = thm RS @{thm conjunct1}
   5.397 +          val thmR = thm RS @{thm conjunct2}
   5.398 +        in (n, thmL):: conjuncts ns thmR end
   5.399      val deflation_map_binds = dbinds |>
   5.400 -        map (Binding.prefix_name "deflation_" o Binding.suffix_name "_map");
   5.401 +        map (Binding.prefix_name "deflation_" o Binding.suffix_name "_map")
   5.402      val (deflation_map_thms, thy) = thy |>
   5.403        (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
   5.404 -        (conjuncts deflation_map_binds deflation_map_thm);
   5.405 +        (conjuncts deflation_map_binds deflation_map_thm)
   5.406  
   5.407      (* register indirect recursion in theory data *)
   5.408      local
   5.409        fun register_map (dname, args) =
   5.410 -        Domain_Take_Proofs.add_rec_type (dname, args);
   5.411 -      val dnames = map (fst o dest_Type o fst) dom_eqns;
   5.412 -      val map_names = map (fst o dest_Const) map_consts;
   5.413 -      fun args (T, _) = case T of Type (_, Ts) => map (is_cpo thy) Ts | _ => [];
   5.414 -      val argss = map args dom_eqns;
   5.415 +        Domain_Take_Proofs.add_rec_type (dname, args)
   5.416 +      val dnames = map (fst o dest_Type o fst) dom_eqns
   5.417 +      val map_names = map (fst o dest_Const) map_consts
   5.418 +      fun args (T, _) = case T of Type (_, Ts) => map (is_cpo thy) Ts | _ => []
   5.419 +      val argss = map args dom_eqns
   5.420      in
   5.421        val thy =
   5.422 -          fold register_map (dnames ~~ argss) thy;
   5.423 -    end;
   5.424 +          fold register_map (dnames ~~ argss) thy
   5.425 +    end
   5.426  
   5.427      (* register deflation theorems *)
   5.428 -    val thy = fold Domain_Take_Proofs.add_deflation_thm deflation_map_thms thy;
   5.429 +    val thy = fold Domain_Take_Proofs.add_deflation_thm deflation_map_thms thy
   5.430  
   5.431      val result =
   5.432        {
   5.433 @@ -375,7 +375,7 @@
   5.434        }
   5.435    in
   5.436      (result, thy)
   5.437 -  end;
   5.438 +  end
   5.439  
   5.440  (******************************************************************************)
   5.441  (******************************* main function ********************************)
   5.442 @@ -384,20 +384,20 @@
   5.443  fun read_typ thy str sorts =
   5.444    let
   5.445      val ctxt = ProofContext.init_global thy
   5.446 -      |> fold (Variable.declare_typ o TFree) sorts;
   5.447 -    val T = Syntax.read_typ ctxt str;
   5.448 -  in (T, Term.add_tfreesT T sorts) end;
   5.449 +      |> fold (Variable.declare_typ o TFree) sorts
   5.450 +    val T = Syntax.read_typ ctxt str
   5.451 +  in (T, Term.add_tfreesT T sorts) end
   5.452  
   5.453  fun cert_typ sign raw_T sorts =
   5.454    let
   5.455      val T = Type.no_tvars (Sign.certify_typ sign raw_T)
   5.456 -      handle TYPE (msg, _, _) => error msg;
   5.457 -    val sorts' = Term.add_tfreesT T sorts;
   5.458 +      handle TYPE (msg, _, _) => error msg
   5.459 +    val sorts' = Term.add_tfreesT T sorts
   5.460      val _ =
   5.461        case duplicates (op =) (map fst sorts') of
   5.462          [] => ()
   5.463        | dups => error ("Inconsistent sort constraints for " ^ commas dups)
   5.464 -  in (T, sorts') end;
   5.465 +  in (T, sorts') end
   5.466  
   5.467  fun gen_domain_isomorphism
   5.468      (prep_typ: theory -> 'a -> (string * sort) list -> typ * (string * sort) list)
   5.469 @@ -406,49 +406,49 @@
   5.470      : (Domain_Take_Proofs.iso_info list
   5.471         * Domain_Take_Proofs.take_induct_info) * theory =
   5.472    let
   5.473 -    val _ = Theory.requires thy "Domain" "domain isomorphisms";
   5.474 +    val _ = Theory.requires thy "Domain" "domain isomorphisms"
   5.475  
   5.476      (* this theory is used just for parsing *)
   5.477      val tmp_thy = thy |>
   5.478        Theory.copy |>
   5.479        Sign.add_types (map (fn (tvs, tbind, mx, _, morphs) =>
   5.480 -        (tbind, length tvs, mx)) doms_raw);
   5.481 +        (tbind, length tvs, mx)) doms_raw)
   5.482  
   5.483      fun prep_dom thy (vs, t, mx, typ_raw, morphs) sorts =
   5.484        let val (typ, sorts') = prep_typ thy typ_raw sorts
   5.485 -      in ((vs, t, mx, typ, morphs), sorts') end;
   5.486 +      in ((vs, t, mx, typ, morphs), sorts') end
   5.487  
   5.488      val (doms : (string list * binding * mixfix * typ * (binding * binding) option) list,
   5.489           sorts : (string * sort) list) =
   5.490 -      fold_map (prep_dom tmp_thy) doms_raw [];
   5.491 +      fold_map (prep_dom tmp_thy) doms_raw []
   5.492  
   5.493      (* lookup function for sorts of type variables *)
   5.494 -    fun the_sort v = the (AList.lookup (op =) sorts v);
   5.495 +    fun the_sort v = the (AList.lookup (op =) sorts v)
   5.496  
   5.497      (* declare arities in temporary theory *)
   5.498      val tmp_thy =
   5.499        let
   5.500          fun arity (vs, tbind, mx, _, _) =
   5.501 -          (Sign.full_name thy tbind, map the_sort vs, @{sort "domain"});
   5.502 +          (Sign.full_name thy tbind, map the_sort vs, @{sort "domain"})
   5.503        in
   5.504          fold AxClass.axiomatize_arity (map arity doms) tmp_thy
   5.505 -      end;
   5.506 +      end
   5.507  
   5.508      (* check bifiniteness of right-hand sides *)
   5.509      fun check_rhs (vs, tbind, mx, rhs, morphs) =
   5.510        if Sign.of_sort tmp_thy (rhs, @{sort "domain"}) then ()
   5.511        else error ("Type not of sort domain: " ^
   5.512 -        quote (Syntax.string_of_typ_global tmp_thy rhs));
   5.513 -    val _ = map check_rhs doms;
   5.514 +        quote (Syntax.string_of_typ_global tmp_thy rhs))
   5.515 +    val _ = map check_rhs doms
   5.516  
   5.517      (* domain equations *)
   5.518      fun mk_dom_eqn (vs, tbind, mx, rhs, morphs) =
   5.519 -      let fun arg v = TFree (v, the_sort v);
   5.520 -      in (Type (Sign.full_name tmp_thy tbind, map arg vs), rhs) end;
   5.521 -    val dom_eqns = map mk_dom_eqn doms;
   5.522 +      let fun arg v = TFree (v, the_sort v)
   5.523 +      in (Type (Sign.full_name tmp_thy tbind, map arg vs), rhs) end
   5.524 +    val dom_eqns = map mk_dom_eqn doms
   5.525  
   5.526      (* check for valid type parameters *)
   5.527 -    val (tyvars, _, _, _, _) = hd doms;
   5.528 +    val (tyvars, _, _, _, _) = hd doms
   5.529      val new_doms = map (fn (tvs, tname, mx, _, _) =>
   5.530        let val full_tname = Sign.full_name tmp_thy tname
   5.531        in
   5.532 @@ -458,133 +458,133 @@
   5.533              else error ("Mutually recursive domains must have same type parameters")
   5.534          | dups => error ("Duplicate parameter(s) for domain " ^ quote (Binding.str_of tname) ^
   5.535              " : " ^ commas dups))
   5.536 -      end) doms;
   5.537 -    val dbinds = map (fn (_, dbind, _, _, _) => dbind) doms;
   5.538 -    val morphs = map (fn (_, _, _, _, morphs) => morphs) doms;
   5.539 +      end) doms
   5.540 +    val dbinds = map (fn (_, dbind, _, _, _) => dbind) doms
   5.541 +    val morphs = map (fn (_, _, _, _, morphs) => morphs) doms
   5.542  
   5.543      (* determine deflation combinator arguments *)
   5.544 -    val lhsTs : typ list = map fst dom_eqns;
   5.545 -    val defl_rec = Free ("t", mk_tupleT (map (K deflT) lhsTs));
   5.546 -    val defl_recs = mk_projs lhsTs defl_rec;
   5.547 -    val defl_recs' = map (apsnd mk_u_defl) defl_recs;
   5.548 +    val lhsTs : typ list = map fst dom_eqns
   5.549 +    val defl_rec = Free ("t", mk_tupleT (map (K deflT) lhsTs))
   5.550 +    val defl_recs = mk_projs lhsTs defl_rec
   5.551 +    val defl_recs' = map (apsnd mk_u_defl) defl_recs
   5.552      fun defl_body (_, _, _, rhsT, _) =
   5.553 -      defl_of_typ tmp_thy defl_recs defl_recs' rhsT;
   5.554 -    val functional = Term.lambda defl_rec (mk_tuple (map defl_body doms));
   5.555 +      defl_of_typ tmp_thy defl_recs defl_recs' rhsT
   5.556 +    val functional = Term.lambda defl_rec (mk_tuple (map defl_body doms))
   5.557  
   5.558 -    val tfrees = map fst (Term.add_tfrees functional []);
   5.559 -    val frees = map fst (Term.add_frees functional []);
   5.560 +    val tfrees = map fst (Term.add_tfrees functional [])
   5.561 +    val frees = map fst (Term.add_frees functional [])
   5.562      fun get_defl_flags (vs, _, _, _, _) =
   5.563        let
   5.564 -        fun argT v = TFree (v, the_sort v);
   5.565 -        fun mk_d v = "d" ^ Library.unprefix "'" v;
   5.566 -        fun mk_p v = "p" ^ Library.unprefix "'" v;
   5.567 -        val args = maps (fn v => [(mk_d v, mk_DEFL (argT v)), (mk_p v, mk_LIFTDEFL (argT v))]) vs;
   5.568 -        val typeTs = map argT (filter (member (op =) tfrees) vs);
   5.569 -        val defl_args = map snd (filter (member (op =) frees o fst) args);
   5.570 +        fun argT v = TFree (v, the_sort v)
   5.571 +        fun mk_d v = "d" ^ Library.unprefix "'" v
   5.572 +        fun mk_p v = "p" ^ Library.unprefix "'" v
   5.573 +        val args = maps (fn v => [(mk_d v, mk_DEFL (argT v)), (mk_p v, mk_LIFTDEFL (argT v))]) vs
   5.574 +        val typeTs = map argT (filter (member (op =) tfrees) vs)
   5.575 +        val defl_args = map snd (filter (member (op =) frees o fst) args)
   5.576        in
   5.577          (typeTs, defl_args)
   5.578 -      end;
   5.579 -    val defl_flagss = map get_defl_flags doms;
   5.580 +      end
   5.581 +    val defl_flagss = map get_defl_flags doms
   5.582  
   5.583      (* declare deflation combinator constants *)
   5.584      fun declare_defl_const ((typeTs, defl_args), (_, tbind, _, _, _)) thy =
   5.585        let
   5.586 -        val defl_bind = Binding.suffix_name "_defl" tbind;
   5.587 +        val defl_bind = Binding.suffix_name "_defl" tbind
   5.588          val defl_type =
   5.589 -          map Term.itselfT typeTs ---> map (K deflT) defl_args -->> deflT;
   5.590 +          map Term.itselfT typeTs ---> map (K deflT) defl_args -->> deflT
   5.591        in
   5.592          Sign.declare_const ((defl_bind, defl_type), NoSyn) thy
   5.593 -      end;
   5.594 +      end
   5.595      val (defl_consts, thy) =
   5.596 -      fold_map declare_defl_const (defl_flagss ~~ doms) thy;
   5.597 +      fold_map declare_defl_const (defl_flagss ~~ doms) thy
   5.598  
   5.599      (* defining equations for type combinators *)
   5.600      fun mk_defl_term (defl_const, (typeTs, defl_args)) =
   5.601        let
   5.602 -        val type_args = map Logic.mk_type typeTs;
   5.603 +        val type_args = map Logic.mk_type typeTs
   5.604        in
   5.605          list_ccomb (list_comb (defl_const, type_args), defl_args)
   5.606 -      end;
   5.607 -    val defl_terms = map mk_defl_term (defl_consts ~~ defl_flagss);
   5.608 -    val defl_tab = map fst dom_eqns ~~ defl_terms;
   5.609 -    val defl_tab' = map fst dom_eqns ~~ map mk_u_defl defl_terms;
   5.610 +      end
   5.611 +    val defl_terms = map mk_defl_term (defl_consts ~~ defl_flagss)
   5.612 +    val defl_tab = map fst dom_eqns ~~ defl_terms
   5.613 +    val defl_tab' = map fst dom_eqns ~~ map mk_u_defl defl_terms
   5.614      fun mk_defl_spec (lhsT, rhsT) =
   5.615        mk_eqs (defl_of_typ tmp_thy defl_tab defl_tab' lhsT,
   5.616 -              defl_of_typ tmp_thy defl_tab defl_tab' rhsT);
   5.617 -    val defl_specs = map mk_defl_spec dom_eqns;
   5.618 +              defl_of_typ tmp_thy defl_tab defl_tab' rhsT)
   5.619 +    val defl_specs = map mk_defl_spec dom_eqns
   5.620  
   5.621      (* register recursive definition of deflation combinators *)
   5.622 -    val defl_binds = map (Binding.suffix_name "_defl") dbinds;
   5.623 +    val defl_binds = map (Binding.suffix_name "_defl") dbinds
   5.624      val ((defl_apply_thms, defl_unfold_thms), thy) =
   5.625 -      add_fixdefs (defl_binds ~~ defl_specs) thy;
   5.626 +      add_fixdefs (defl_binds ~~ defl_specs) thy
   5.627  
   5.628      (* define types using deflation combinators *)
   5.629      fun make_repdef ((vs, tbind, mx, _, _), defl) thy =
   5.630        let
   5.631 -        val spec = (tbind, map (rpair dummyS) vs, mx);
   5.632 +        val spec = (tbind, map (rpair dummyS) vs, mx)
   5.633          val ((_, _, _, {DEFL, liftemb_def, liftprj_def, ...}), thy) =
   5.634 -          Domaindef.add_domaindef false NONE spec defl NONE thy;
   5.635 +          Domaindef.add_domaindef false NONE spec defl NONE thy
   5.636          (* declare domain_defl_simps rules *)
   5.637 -        val thy = Context.theory_map (RepData.add_thm DEFL) thy;
   5.638 +        val thy = Context.theory_map (RepData.add_thm DEFL) thy
   5.639        in
   5.640          (DEFL, thy)
   5.641 -      end;
   5.642 -    val (DEFL_thms, thy) = fold_map make_repdef (doms ~~ defl_terms) thy;
   5.643 +      end
   5.644 +    val (DEFL_thms, thy) = fold_map make_repdef (doms ~~ defl_terms) thy
   5.645  
   5.646      (* prove DEFL equations *)
   5.647      fun mk_DEFL_eq_thm (lhsT, rhsT) =
   5.648        let
   5.649 -        val goal = mk_eqs (mk_DEFL lhsT, mk_DEFL rhsT);
   5.650 -        val DEFL_simps = RepData.get (ProofContext.init_global thy);
   5.651 +        val goal = mk_eqs (mk_DEFL lhsT, mk_DEFL rhsT)
   5.652 +        val DEFL_simps = RepData.get (ProofContext.init_global thy)
   5.653          val tac =
   5.654            rewrite_goals_tac (map mk_meta_eq DEFL_simps)
   5.655 -          THEN TRY (resolve_tac defl_unfold_thms 1);
   5.656 +          THEN TRY (resolve_tac defl_unfold_thms 1)
   5.657        in
   5.658          Goal.prove_global thy [] [] goal (K tac)
   5.659 -      end;
   5.660 -    val DEFL_eq_thms = map mk_DEFL_eq_thm dom_eqns;
   5.661 +      end
   5.662 +    val DEFL_eq_thms = map mk_DEFL_eq_thm dom_eqns
   5.663  
   5.664      (* register DEFL equations *)
   5.665 -    val DEFL_eq_binds = map (Binding.prefix_name "DEFL_eq_") dbinds;
   5.666 +    val DEFL_eq_binds = map (Binding.prefix_name "DEFL_eq_") dbinds
   5.667      val (_, thy) = thy |>
   5.668        (Global_Theory.add_thms o map Thm.no_attributes)
   5.669 -        (DEFL_eq_binds ~~ DEFL_eq_thms);
   5.670 +        (DEFL_eq_binds ~~ DEFL_eq_thms)
   5.671  
   5.672      (* define rep/abs functions *)
   5.673      fun mk_rep_abs ((tbind, morphs), (lhsT, rhsT)) thy =
   5.674        let
   5.675 -        val rep_bind = Binding.suffix_name "_rep" tbind;
   5.676 -        val abs_bind = Binding.suffix_name "_abs" tbind;
   5.677 +        val rep_bind = Binding.suffix_name "_rep" tbind
   5.678 +        val abs_bind = Binding.suffix_name "_abs" tbind
   5.679          val ((rep_const, rep_def), thy) =
   5.680 -            define_const (rep_bind, coerce_const (lhsT, rhsT)) thy;
   5.681 +            define_const (rep_bind, coerce_const (lhsT, rhsT)) thy
   5.682          val ((abs_const, abs_def), thy) =
   5.683 -            define_const (abs_bind, coerce_const (rhsT, lhsT)) thy;
   5.684 +            define_const (abs_bind, coerce_const (rhsT, lhsT)) thy
   5.685        in
   5.686          (((rep_const, abs_const), (rep_def, abs_def)), thy)
   5.687 -      end;
   5.688 +      end
   5.689      val ((rep_abs_consts, rep_abs_defs), thy) = thy
   5.690        |> fold_map mk_rep_abs (dbinds ~~ morphs ~~ dom_eqns)
   5.691 -      |>> ListPair.unzip;
   5.692 +      |>> ListPair.unzip
   5.693  
   5.694      (* prove isomorphism and isodefl rules *)
   5.695      fun mk_iso_thms ((tbind, DEFL_eq), (rep_def, abs_def)) thy =
   5.696        let
   5.697          fun make thm =
   5.698 -            Drule.zero_var_indexes (thm OF [DEFL_eq, abs_def, rep_def]);
   5.699 -        val rep_iso_thm = make @{thm domain_rep_iso};
   5.700 -        val abs_iso_thm = make @{thm domain_abs_iso};
   5.701 -        val isodefl_thm = make @{thm isodefl_abs_rep};
   5.702 +            Drule.zero_var_indexes (thm OF [DEFL_eq, abs_def, rep_def])
   5.703 +        val rep_iso_thm = make @{thm domain_rep_iso}
   5.704 +        val abs_iso_thm = make @{thm domain_abs_iso}
   5.705 +        val isodefl_thm = make @{thm isodefl_abs_rep}
   5.706          val thy = thy
   5.707            |> snd o add_qualified_thm "rep_iso" (tbind, rep_iso_thm)
   5.708            |> snd o add_qualified_thm "abs_iso" (tbind, abs_iso_thm)
   5.709 -          |> snd o add_qualified_thm "isodefl_abs_rep" (tbind, isodefl_thm);
   5.710 +          |> snd o add_qualified_thm "isodefl_abs_rep" (tbind, isodefl_thm)
   5.711        in
   5.712          (((rep_iso_thm, abs_iso_thm), isodefl_thm), thy)
   5.713 -      end;
   5.714 +      end
   5.715      val ((iso_thms, isodefl_abs_rep_thms), thy) =
   5.716        thy
   5.717        |> fold_map mk_iso_thms (dbinds ~~ DEFL_eq_thms ~~ rep_abs_defs)
   5.718 -      |>> ListPair.unzip;
   5.719 +      |>> ListPair.unzip
   5.720  
   5.721      (* collect info about rep/abs *)
   5.722      val iso_infos : Domain_Take_Proofs.iso_info list =
   5.723 @@ -597,51 +597,51 @@
   5.724              abs_const = absC,
   5.725              rep_inverse = rep_iso,
   5.726              abs_inverse = abs_iso
   5.727 -          };
   5.728 +          }
   5.729        in
   5.730          map mk_info (dom_eqns ~~ rep_abs_consts ~~ iso_thms)
   5.731        end
   5.732  
   5.733      (* definitions and proofs related to map functions *)
   5.734      val (map_info, thy) =
   5.735 -        define_map_functions (dbinds ~~ iso_infos) thy;
   5.736 +        define_map_functions (dbinds ~~ iso_infos) thy
   5.737      val { map_consts, map_apply_thms, map_unfold_thms,
   5.738 -          deflation_map_thms } = map_info;
   5.739 +          deflation_map_thms } = map_info
   5.740  
   5.741      (* prove isodefl rules for map functions *)
   5.742      val isodefl_thm =
   5.743        let
   5.744 -        fun unprime a = Library.unprefix "'" a;
   5.745 -        fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT);
   5.746 -        fun mk_p T = Free ("p" ^ unprime (fst (dest_TFree T)), deflT);
   5.747 -        fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T);
   5.748 +        fun unprime a = Library.unprefix "'" a
   5.749 +        fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT)
   5.750 +        fun mk_p T = Free ("p" ^ unprime (fst (dest_TFree T)), deflT)
   5.751 +        fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T)
   5.752          fun mk_assm t =
   5.753            case try dest_LIFTDEFL t of
   5.754              SOME T => mk_trp (isodefl_const (mk_upT T) $ mk_u_map (mk_f T) $ mk_p T)
   5.755            | NONE =>
   5.756              let val T = dest_DEFL t
   5.757 -            in mk_trp (isodefl_const T $ mk_f T $ mk_d T) end;
   5.758 +            in mk_trp (isodefl_const T $ mk_f T $ mk_d T) end
   5.759          fun mk_goal (map_const, (T, rhsT)) =
   5.760            let
   5.761 -            val (_, Ts) = dest_Type T;
   5.762 -            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts));
   5.763 -            val defl_term = defl_of_typ thy (Ts ~~ map mk_d Ts) (Ts ~~ map mk_p Ts) T;
   5.764 -          in isodefl_const T $ map_term $ defl_term end;
   5.765 -        val assms = (map mk_assm o snd o hd) defl_flagss;
   5.766 -        val goals = map mk_goal (map_consts ~~ dom_eqns);
   5.767 -        val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
   5.768 +            val (_, Ts) = dest_Type T
   5.769 +            val map_term = list_ccomb (map_const, map mk_f (filter (is_cpo thy) Ts))
   5.770 +            val defl_term = defl_of_typ thy (Ts ~~ map mk_d Ts) (Ts ~~ map mk_p Ts) T
   5.771 +          in isodefl_const T $ map_term $ defl_term end
   5.772 +        val assms = (map mk_assm o snd o hd) defl_flagss
   5.773 +        val goals = map mk_goal (map_consts ~~ dom_eqns)
   5.774 +        val goal = mk_trp (foldr1 HOLogic.mk_conj goals)
   5.775          val start_thms =
   5.776 -          @{thm split_def} :: defl_apply_thms @ map_apply_thms;
   5.777 +          @{thm split_def} :: defl_apply_thms @ map_apply_thms
   5.778          val adm_rules =
   5.779 -          @{thms adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id};
   5.780 +          @{thms adm_conj adm_isodefl cont2cont_fst cont2cont_snd cont_id}
   5.781          val bottom_rules =
   5.782 -          @{thms fst_strict snd_strict isodefl_bottom simp_thms};
   5.783 -        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
   5.784 -        val map_ID_simps = map (fn th => th RS sym) map_ID_thms;
   5.785 +          @{thms fst_strict snd_strict isodefl_bottom simp_thms}
   5.786 +        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy
   5.787 +        val map_ID_simps = map (fn th => th RS sym) map_ID_thms
   5.788          val isodefl_rules =
   5.789            @{thms conjI isodefl_ID_DEFL isodefl_LIFTDEFL}
   5.790            @ isodefl_abs_rep_thms
   5.791 -          @ IsodeflData.get (ProofContext.init_global thy);
   5.792 +          @ IsodeflData.get (ProofContext.init_global thy)
   5.793        in
   5.794          Goal.prove_global thy [] assms goal (fn {prems, ...} =>
   5.795           EVERY
   5.796 @@ -656,69 +656,69 @@
   5.797             simp_tac (HOL_basic_ss addsimps map_ID_simps) 1,
   5.798             REPEAT (etac @{thm conjE} 1),
   5.799             REPEAT (resolve_tac (isodefl_rules @ prems) 1 ORELSE atac 1)])
   5.800 -      end;
   5.801 -    val isodefl_binds = map (Binding.prefix_name "isodefl_") dbinds;
   5.802 +      end
   5.803 +    val isodefl_binds = map (Binding.prefix_name "isodefl_") dbinds
   5.804      fun conjuncts [] thm = []
   5.805        | conjuncts (n::[]) thm = [(n, thm)]
   5.806        | conjuncts (n::ns) thm = let
   5.807 -          val thmL = thm RS @{thm conjunct1};
   5.808 -          val thmR = thm RS @{thm conjunct2};
   5.809 -        in (n, thmL):: conjuncts ns thmR end;
   5.810 +          val thmL = thm RS @{thm conjunct1}
   5.811 +          val thmR = thm RS @{thm conjunct2}
   5.812 +        in (n, thmL):: conjuncts ns thmR end
   5.813      val (isodefl_thms, thy) = thy |>
   5.814        (Global_Theory.add_thms o map (Thm.no_attributes o apsnd Drule.zero_var_indexes))
   5.815 -        (conjuncts isodefl_binds isodefl_thm);
   5.816 -    val thy = fold (Context.theory_map o IsodeflData.add_thm) isodefl_thms thy;
   5.817 +        (conjuncts isodefl_binds isodefl_thm)
   5.818 +    val thy = fold (Context.theory_map o IsodeflData.add_thm) isodefl_thms thy
   5.819  
   5.820      (* prove map_ID theorems *)
   5.821      fun prove_map_ID_thm
   5.822          (((map_const, (lhsT, _)), DEFL_thm), isodefl_thm) =
   5.823        let
   5.824 -        val Ts = snd (dest_Type lhsT);
   5.825 -        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
   5.826 -        val lhs = list_ccomb (map_const, map mk_ID (filter is_cpo Ts));
   5.827 -        val goal = mk_eqs (lhs, mk_ID lhsT);
   5.828 +        val Ts = snd (dest_Type lhsT)
   5.829 +        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo})
   5.830 +        val lhs = list_ccomb (map_const, map mk_ID (filter is_cpo Ts))
   5.831 +        val goal = mk_eqs (lhs, mk_ID lhsT)
   5.832          val tac = EVERY
   5.833            [rtac @{thm isodefl_DEFL_imp_ID} 1,
   5.834             stac DEFL_thm 1,
   5.835             rtac isodefl_thm 1,
   5.836 -           REPEAT (resolve_tac @{thms isodefl_ID_DEFL isodefl_LIFTDEFL} 1)];
   5.837 +           REPEAT (resolve_tac @{thms isodefl_ID_DEFL isodefl_LIFTDEFL} 1)]
   5.838        in
   5.839          Goal.prove_global thy [] [] goal (K tac)
   5.840 -      end;
   5.841 -    val map_ID_binds = map (Binding.suffix_name "_map_ID") dbinds;
   5.842 +      end
   5.843 +    val map_ID_binds = map (Binding.suffix_name "_map_ID") dbinds
   5.844      val map_ID_thms =
   5.845        map prove_map_ID_thm
   5.846 -        (map_consts ~~ dom_eqns ~~ DEFL_thms ~~ isodefl_thms);
   5.847 +        (map_consts ~~ dom_eqns ~~ DEFL_thms ~~ isodefl_thms)
   5.848      val (_, thy) = thy |>
   5.849        (Global_Theory.add_thms o map (rpair [Domain_Take_Proofs.map_ID_add]))
   5.850 -        (map_ID_binds ~~ map_ID_thms);
   5.851 +        (map_ID_binds ~~ map_ID_thms)
   5.852  
   5.853      (* definitions and proofs related to take functions *)
   5.854      val (take_info, thy) =
   5.855          Domain_Take_Proofs.define_take_functions
   5.856 -          (dbinds ~~ iso_infos) thy;
   5.857 +          (dbinds ~~ iso_infos) thy
   5.858      val { take_consts, chain_take_thms, take_0_thms, take_Suc_thms, ...} =
   5.859 -        take_info;
   5.860 +        take_info
   5.861  
   5.862      (* least-upper-bound lemma for take functions *)
   5.863      val lub_take_lemma =
   5.864        let
   5.865 -        val lhs = mk_tuple (map mk_lub take_consts);
   5.866 -        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo});
   5.867 +        val lhs = mk_tuple (map mk_lub take_consts)
   5.868 +        fun is_cpo T = Sign.of_sort thy (T, @{sort cpo})
   5.869          fun mk_map_ID (map_const, (lhsT, rhsT)) =
   5.870 -          list_ccomb (map_const, map mk_ID (filter is_cpo (snd (dest_Type lhsT))));
   5.871 -        val rhs = mk_tuple (map mk_map_ID (map_consts ~~ dom_eqns));
   5.872 -        val goal = mk_trp (mk_eq (lhs, rhs));
   5.873 -        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy;
   5.874 +          list_ccomb (map_const, map mk_ID (filter is_cpo (snd (dest_Type lhsT))))
   5.875 +        val rhs = mk_tuple (map mk_map_ID (map_consts ~~ dom_eqns))
   5.876 +        val goal = mk_trp (mk_eq (lhs, rhs))
   5.877 +        val map_ID_thms = Domain_Take_Proofs.get_map_ID_thms thy
   5.878          val start_rules =
   5.879              @{thms lub_Pair [symmetric] ch2ch_Pair} @ chain_take_thms
   5.880              @ @{thms pair_collapse split_def}
   5.881 -            @ map_apply_thms @ map_ID_thms;
   5.882 +            @ map_apply_thms @ map_ID_thms
   5.883          val rules0 =
   5.884 -            @{thms iterate_0 Pair_strict} @ take_0_thms;
   5.885 +            @{thms iterate_0 Pair_strict} @ take_0_thms
   5.886          val rules1 =
   5.887              @{thms iterate_Suc Pair_fst_snd_eq fst_conv snd_conv}
   5.888 -            @ take_Suc_thms;
   5.889 +            @ take_Suc_thms
   5.890          val tac =
   5.891              EVERY
   5.892              [simp_tac (HOL_basic_ss addsimps start_rules) 1,
   5.893 @@ -726,39 +726,39 @@
   5.894               rtac @{thm lub_eq} 1,
   5.895               rtac @{thm nat.induct} 1,
   5.896               simp_tac (HOL_basic_ss addsimps rules0) 1,
   5.897 -             asm_full_simp_tac (beta_ss addsimps rules1) 1];
   5.898 +             asm_full_simp_tac (beta_ss addsimps rules1) 1]
   5.899        in
   5.900          Goal.prove_global thy [] [] goal (K tac)
   5.901 -      end;
   5.902 +      end
   5.903  
   5.904      (* prove lub of take equals ID *)
   5.905      fun prove_lub_take (((dbind, take_const), map_ID_thm), (lhsT, rhsT)) thy =
   5.906        let
   5.907 -        val n = Free ("n", natT);
   5.908 -        val goal = mk_eqs (mk_lub (lambda n (take_const $ n)), mk_ID lhsT);
   5.909 +        val n = Free ("n", natT)
   5.910 +        val goal = mk_eqs (mk_lub (lambda n (take_const $ n)), mk_ID lhsT)
   5.911          val tac =
   5.912              EVERY
   5.913              [rtac @{thm trans} 1, rtac map_ID_thm 2,
   5.914               cut_facts_tac [lub_take_lemma] 1,
   5.915 -             REPEAT (etac @{thm Pair_inject} 1), atac 1];
   5.916 -        val lub_take_thm = Goal.prove_global thy [] [] goal (K tac);
   5.917 +             REPEAT (etac @{thm Pair_inject} 1), atac 1]
   5.918 +        val lub_take_thm = Goal.prove_global thy [] [] goal (K tac)
   5.919        in
   5.920          add_qualified_thm "lub_take" (dbind, lub_take_thm) thy
   5.921 -      end;
   5.922 +      end
   5.923      val (lub_take_thms, thy) =
   5.924          fold_map prove_lub_take
   5.925 -          (dbinds ~~ take_consts ~~ map_ID_thms ~~ dom_eqns) thy;
   5.926 +          (dbinds ~~ take_consts ~~ map_ID_thms ~~ dom_eqns) thy
   5.927  
   5.928      (* prove additional take theorems *)
   5.929      val (take_info2, thy) =
   5.930          Domain_Take_Proofs.add_lub_take_theorems
   5.931 -          (dbinds ~~ iso_infos) take_info lub_take_thms thy;
   5.932 +          (dbinds ~~ iso_infos) take_info lub_take_thms thy
   5.933    in
   5.934      ((iso_infos, take_info2), thy)
   5.935 -  end;
   5.936 +  end
   5.937  
   5.938 -val domain_isomorphism = gen_domain_isomorphism cert_typ;
   5.939 -val domain_isomorphism_cmd = snd oo gen_domain_isomorphism read_typ;
   5.940 +val domain_isomorphism = gen_domain_isomorphism cert_typ
   5.941 +val domain_isomorphism_cmd = snd oo gen_domain_isomorphism read_typ
   5.942  
   5.943  (******************************************************************************)
   5.944  (******************************** outer syntax ********************************)
   5.945 @@ -771,17 +771,17 @@
   5.946        parser =
   5.947    (Parse.type_args -- Parse.binding -- Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.typ) --
   5.948      Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding)))
   5.949 -    >> (fn ((((vs, t), mx), rhs), morphs) => (vs, t, mx, rhs, morphs));
   5.950 +    >> (fn ((((vs, t), mx), rhs), morphs) => (vs, t, mx, rhs, morphs))
   5.951  
   5.952 -val parse_domain_isos = Parse.and_list1 parse_domain_iso;
   5.953 +val parse_domain_isos = Parse.and_list1 parse_domain_iso
   5.954  
   5.955  in
   5.956  
   5.957  val _ =
   5.958    Outer_Syntax.command "domain_isomorphism" "define domain isomorphisms (HOLCF)"
   5.959      Keyword.thy_decl
   5.960 -    (parse_domain_isos >> (Toplevel.theory o domain_isomorphism_cmd));
   5.961 +    (parse_domain_isos >> (Toplevel.theory o domain_isomorphism_cmd))
   5.962  
   5.963 -end;
   5.964 +end
   5.965  
   5.966 -end;
   5.967 +end
     6.1 --- a/src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML	Tue Nov 30 14:01:49 2010 -0800
     6.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_take_proofs.ML	Tue Nov 30 14:21:57 2010 -0800
     6.3 @@ -62,7 +62,7 @@
     6.4    val map_ID_add : attribute
     6.5    val get_map_ID_thms : theory -> thm list
     6.6    val setup : theory -> theory
     6.7 -end;
     6.8 +end
     6.9  
    6.10  structure Domain_Take_Proofs : DOMAIN_TAKE_PROOFS =
    6.11  struct
    6.12 @@ -75,7 +75,7 @@
    6.13      rep_const : term,
    6.14      abs_inverse : thm,
    6.15      rep_inverse : thm
    6.16 -  };
    6.17 +  }
    6.18  
    6.19  type take_info =
    6.20    { take_consts : term list,
    6.21 @@ -87,7 +87,7 @@
    6.22      take_strict_thms : thm list,
    6.23      finite_consts : term list,
    6.24      finite_defs : thm list
    6.25 -  };
    6.26 +  }
    6.27  
    6.28  type take_induct_info =
    6.29    {
    6.30 @@ -105,15 +105,15 @@
    6.31      take_lemma_thms     : thm list,
    6.32      is_finite           : bool,
    6.33      take_induct_thms    : thm list
    6.34 -  };
    6.35 +  }
    6.36  
    6.37  val beta_rules =
    6.38    @{thms beta_cfun cont_id cont_const cont2cont_APP cont2cont_LAM'} @
    6.39 -  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair};
    6.40 +  @{thms cont2cont_fst cont2cont_snd cont2cont_Pair}
    6.41  
    6.42 -val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules);
    6.43 +val beta_ss = HOL_basic_ss addsimps (simp_thms @ beta_rules)
    6.44  
    6.45 -val beta_tac = simp_tac beta_ss;
    6.46 +val beta_tac = simp_tac beta_ss
    6.47  
    6.48  (******************************************************************************)
    6.49  (******************************** theory data *********************************)
    6.50 @@ -122,56 +122,56 @@
    6.51  structure Rec_Data = Theory_Data
    6.52  (
    6.53    (* list indicates which type arguments allow indirect recursion *)
    6.54 -  type T = (bool list) Symtab.table;
    6.55 -  val empty = Symtab.empty;
    6.56 -  val extend = I;
    6.57 -  fun merge data = Symtab.merge (K true) data;
    6.58 -);
    6.59 +  type T = (bool list) Symtab.table
    6.60 +  val empty = Symtab.empty
    6.61 +  val extend = I
    6.62 +  fun merge data = Symtab.merge (K true) data
    6.63 +)
    6.64  
    6.65  structure DeflMapData = Named_Thms
    6.66  (
    6.67    val name = "domain_deflation"
    6.68    val description = "theorems like deflation a ==> deflation (foo_map$a)"
    6.69 -);
    6.70 +)
    6.71  
    6.72  structure Map_Id_Data = Named_Thms
    6.73  (
    6.74    val name = "domain_map_ID"
    6.75    val description = "theorems like foo_map$ID = ID"
    6.76 -);
    6.77 +)
    6.78  
    6.79  fun add_rec_type (tname, bs) =
    6.80 -    Rec_Data.map (Symtab.insert (K true) (tname, bs));
    6.81 +    Rec_Data.map (Symtab.insert (K true) (tname, bs))
    6.82  
    6.83  fun add_deflation_thm thm =
    6.84 -    Context.theory_map (DeflMapData.add_thm thm);
    6.85 +    Context.theory_map (DeflMapData.add_thm thm)
    6.86  
    6.87 -val get_rec_tab = Rec_Data.get;
    6.88 -fun get_deflation_thms thy = DeflMapData.get (ProofContext.init_global thy);
    6.89 +val get_rec_tab = Rec_Data.get
    6.90 +fun get_deflation_thms thy = DeflMapData.get (ProofContext.init_global thy)
    6.91  
    6.92 -val map_ID_add = Map_Id_Data.add;
    6.93 -val get_map_ID_thms = Map_Id_Data.get o ProofContext.init_global;
    6.94 +val map_ID_add = Map_Id_Data.add
    6.95 +val get_map_ID_thms = Map_Id_Data.get o ProofContext.init_global
    6.96  
    6.97 -val setup = DeflMapData.setup #> Map_Id_Data.setup;
    6.98 +val setup = DeflMapData.setup #> Map_Id_Data.setup
    6.99  
   6.100  (******************************************************************************)
   6.101  (************************** building types and terms **************************)
   6.102  (******************************************************************************)
   6.103  
   6.104 -open HOLCF_Library;
   6.105 +open HOLCF_Library
   6.106  
   6.107 -infixr 6 ->>;
   6.108 -infix -->>;
   6.109 -infix 9 `;
   6.110 +infixr 6 ->>
   6.111 +infix -->>
   6.112 +infix 9 `
   6.113  
   6.114  fun mapT (T as Type (_, Ts)) =
   6.115      (map (fn T => T ->> T) Ts) -->> (T ->> T)
   6.116 -  | mapT T = T ->> T;
   6.117 +  | mapT T = T ->> T
   6.118  
   6.119  fun mk_deflation t =
   6.120 -  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
   6.121 +  Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t
   6.122  
   6.123 -fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
   6.124 +fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u))
   6.125  
   6.126  (******************************************************************************)
   6.127  (****************************** isomorphism info ******************************)
   6.128 @@ -179,9 +179,9 @@
   6.129  
   6.130  fun deflation_abs_rep (info : iso_info) : thm =
   6.131    let
   6.132 -    val abs_iso = #abs_inverse info;
   6.133 -    val rep_iso = #rep_inverse info;
   6.134 -    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
   6.135 +    val abs_iso = #abs_inverse info
   6.136 +    val rep_iso = #rep_inverse info
   6.137 +    val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso]
   6.138    in
   6.139      Drule.zero_var_indexes thm
   6.140    end
   6.141 @@ -192,14 +192,14 @@
   6.142  
   6.143  fun map_of_typ (thy : theory) (sub : (typ * term) list) (T : typ) : term =
   6.144    let
   6.145 -    val thms = get_map_ID_thms thy;
   6.146 -    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) thms;
   6.147 -    val rules' = map (apfst mk_ID) sub @ map swap rules;
   6.148 +    val thms = get_map_ID_thms thy
   6.149 +    val rules = map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) thms
   6.150 +    val rules' = map (apfst mk_ID) sub @ map swap rules
   6.151    in
   6.152      mk_ID T
   6.153      |> Pattern.rewrite_term thy rules' []
   6.154      |> Pattern.rewrite_term thy rules []
   6.155 -  end;
   6.156 +  end
   6.157  
   6.158  (******************************************************************************)
   6.159  (********************* declaring definitions and theorems *********************)
   6.160 @@ -207,15 +207,15 @@
   6.161  
   6.162  fun add_qualified_def name (dbind, eqn) =
   6.163      yield_singleton (Global_Theory.add_defs false)
   6.164 -     ((Binding.qualified true name dbind, eqn), []);
   6.165 +     ((Binding.qualified true name dbind, eqn), [])
   6.166  
   6.167  fun add_qualified_thm name (dbind, thm) =
   6.168      yield_singleton Global_Theory.add_thms
   6.169 -      ((Binding.qualified true name dbind, thm), []);
   6.170 +      ((Binding.qualified true name dbind, thm), [])
   6.171  
   6.172  fun add_qualified_simp_thm name (dbind, thm) =
   6.173      yield_singleton Global_Theory.add_thms
   6.174 -      ((Binding.qualified true name dbind, thm), [Simplifier.simp_add]);
   6.175 +      ((Binding.qualified true name dbind, thm), [Simplifier.simp_add])
   6.176  
   6.177  (******************************************************************************)
   6.178  (************************** defining take functions ***************************)
   6.179 @@ -227,119 +227,119 @@
   6.180    let
   6.181  
   6.182      (* retrieve components of spec *)
   6.183 -    val dbinds = map fst spec;
   6.184 -    val iso_infos = map snd spec;
   6.185 -    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
   6.186 -    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
   6.187 +    val dbinds = map fst spec
   6.188 +    val iso_infos = map snd spec
   6.189 +    val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos
   6.190 +    val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos
   6.191  
   6.192      fun mk_projs []      t = []
   6.193        | mk_projs (x::[]) t = [(x, t)]
   6.194 -      | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
   6.195 +      | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t)
   6.196  
   6.197      fun mk_cfcomp2 ((rep_const, abs_const), f) =
   6.198 -        mk_cfcomp (abs_const, mk_cfcomp (f, rep_const));
   6.199 +        mk_cfcomp (abs_const, mk_cfcomp (f, rep_const))
   6.200  
   6.201      (* define take functional *)
   6.202 -    val newTs : typ list = map fst dom_eqns;
   6.203 -    val copy_arg_type = mk_tupleT (map (fn T => T ->> T) newTs);
   6.204 -    val copy_arg = Free ("f", copy_arg_type);
   6.205 -    val copy_args = map snd (mk_projs dbinds copy_arg);
   6.206 +    val newTs : typ list = map fst dom_eqns
   6.207 +    val copy_arg_type = mk_tupleT (map (fn T => T ->> T) newTs)
   6.208 +    val copy_arg = Free ("f", copy_arg_type)
   6.209 +    val copy_args = map snd (mk_projs dbinds copy_arg)
   6.210      fun one_copy_rhs (rep_abs, (lhsT, rhsT)) =
   6.211        let
   6.212 -        val body = map_of_typ thy (newTs ~~ copy_args) rhsT;
   6.213 +        val body = map_of_typ thy (newTs ~~ copy_args) rhsT
   6.214        in
   6.215          mk_cfcomp2 (rep_abs, body)
   6.216 -      end;
   6.217 +      end
   6.218      val take_functional =
   6.219          big_lambda copy_arg
   6.220 -          (mk_tuple (map one_copy_rhs (rep_abs_consts ~~ dom_eqns)));
   6.221 +          (mk_tuple (map one_copy_rhs (rep_abs_consts ~~ dom_eqns)))
   6.222      val take_rhss =
   6.223        let
   6.224 -        val n = Free ("n", HOLogic.natT);
   6.225 -        val rhs = mk_iterate (n, take_functional);
   6.226 +        val n = Free ("n", HOLogic.natT)
   6.227 +        val rhs = mk_iterate (n, take_functional)
   6.228        in
   6.229          map (lambda n o snd) (mk_projs dbinds rhs)
   6.230 -      end;
   6.231 +      end
   6.232  
   6.233      (* define take constants *)
   6.234      fun define_take_const ((dbind, take_rhs), (lhsT, rhsT)) thy =
   6.235        let
   6.236 -        val take_type = HOLogic.natT --> lhsT ->> lhsT;
   6.237 -        val take_bind = Binding.suffix_name "_take" dbind;
   6.238 +        val take_type = HOLogic.natT --> lhsT ->> lhsT
   6.239 +        val take_bind = Binding.suffix_name "_take" dbind
   6.240          val (take_const, thy) =
   6.241 -          Sign.declare_const ((take_bind, take_type), NoSyn) thy;
   6.242 -        val take_eqn = Logic.mk_equals (take_const, take_rhs);
   6.243 +          Sign.declare_const ((take_bind, take_type), NoSyn) thy
   6.244 +        val take_eqn = Logic.mk_equals (take_const, take_rhs)
   6.245          val (take_def_thm, thy) =
   6.246 -            add_qualified_def "take_def" (dbind, take_eqn) thy;
   6.247 -      in ((take_const, take_def_thm), thy) end;
   6.248 +            add_qualified_def "take_def" (dbind, take_eqn) thy
   6.249 +      in ((take_const, take_def_thm), thy) end
   6.250      val ((take_consts, take_defs), thy) = thy
   6.251        |> fold_map define_take_const (dbinds ~~ take_rhss ~~ dom_eqns)
   6.252 -      |>> ListPair.unzip;
   6.253 +      |>> ListPair.unzip
   6.254  
   6.255      (* prove chain_take lemmas *)
   6.256      fun prove_chain_take (take_const, dbind) thy =
   6.257        let
   6.258 -        val goal = mk_trp (mk_chain take_const);
   6.259 -        val rules = take_defs @ @{thms chain_iterate ch2ch_fst ch2ch_snd};
   6.260 -        val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
   6.261 -        val thm = Goal.prove_global thy [] [] goal (K tac);
   6.262 +        val goal = mk_trp (mk_chain take_const)
   6.263 +        val rules = take_defs @ @{thms chain_iterate ch2ch_fst ch2ch_snd}
   6.264 +        val tac = simp_tac (HOL_basic_ss addsimps rules) 1
   6.265 +        val thm = Goal.prove_global thy [] [] goal (K tac)
   6.266        in
   6.267          add_qualified_simp_thm "chain_take" (dbind, thm) thy
   6.268 -      end;
   6.269 +      end
   6.270      val (chain_take_thms, thy) =
   6.271 -      fold_map prove_chain_take (take_consts ~~ dbinds) thy;
   6.272 +      fold_map prove_chain_take (take_consts ~~ dbinds) thy
   6.273  
   6.274      (* prove take_0 lemmas *)
   6.275      fun prove_take_0 ((take_const, dbind), (lhsT, rhsT)) thy =
   6.276        let
   6.277 -        val lhs = take_const $ @{term "0::nat"};
   6.278 -        val goal = mk_eqs (lhs, mk_bottom (lhsT ->> lhsT));
   6.279 -        val rules = take_defs @ @{thms iterate_0 fst_strict snd_strict};
   6.280 -        val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
   6.281 -        val take_0_thm = Goal.prove_global thy [] [] goal (K tac);
   6.282 +        val lhs = take_const $ @{term "0::nat"}
   6.283 +        val goal = mk_eqs (lhs, mk_bottom (lhsT ->> lhsT))
   6.284 +        val rules = take_defs @ @{thms iterate_0 fst_strict snd_strict}
   6.285 +        val tac = simp_tac (HOL_basic_ss addsimps rules) 1
   6.286 +        val take_0_thm = Goal.prove_global thy [] [] goal (K tac)
   6.287        in
   6.288          add_qualified_simp_thm "take_0" (dbind, take_0_thm) thy
   6.289 -      end;
   6.290 +      end
   6.291      val (take_0_thms, thy) =
   6.292 -      fold_map prove_take_0 (take_consts ~~ dbinds ~~ dom_eqns) thy;
   6.293 +      fold_map prove_take_0 (take_consts ~~ dbinds ~~ dom_eqns) thy
   6.294  
   6.295      (* prove take_Suc lemmas *)
   6.296 -    val n = Free ("n", natT);
   6.297 -    val take_is = map (fn t => t $ n) take_consts;
   6.298 +    val n = Free ("n", natT)
   6.299 +    val take_is = map (fn t => t $ n) take_consts
   6.300      fun prove_take_Suc
   6.301            (((take_const, rep_abs), dbind), (lhsT, rhsT)) thy =
   6.302        let
   6.303 -        val lhs = take_const $ (@{term Suc} $ n);
   6.304 -        val body = map_of_typ thy (newTs ~~ take_is) rhsT;
   6.305 -        val rhs = mk_cfcomp2 (rep_abs, body);
   6.306 -        val goal = mk_eqs (lhs, rhs);
   6.307 +        val lhs = take_const $ (@{term Suc} $ n)
   6.308 +        val body = map_of_typ thy (newTs ~~ take_is) rhsT
   6.309 +        val rhs = mk_cfcomp2 (rep_abs, body)
   6.310 +        val goal = mk_eqs (lhs, rhs)
   6.311          val simps = @{thms iterate_Suc fst_conv snd_conv}
   6.312 -        val rules = take_defs @ simps;
   6.313 -        val tac = simp_tac (beta_ss addsimps rules) 1;
   6.314 -        val take_Suc_thm = Goal.prove_global thy [] [] goal (K tac);
   6.315 +        val rules = take_defs @ simps
   6.316 +        val tac = simp_tac (beta_ss addsimps rules) 1
   6.317 +        val take_Suc_thm = Goal.prove_global thy [] [] goal (K tac)
   6.318        in
   6.319          add_qualified_thm "take_Suc" (dbind, take_Suc_thm) thy
   6.320 -      end;
   6.321 +      end
   6.322      val (take_Suc_thms, thy) =
   6.323        fold_map prove_take_Suc
   6.324 -        (take_consts ~~ rep_abs_consts ~~ dbinds ~~ dom_eqns) thy;
   6.325 +        (take_consts ~~ rep_abs_consts ~~ dbinds ~~ dom_eqns) thy
   6.326  
   6.327      (* prove deflation theorems for take functions *)
   6.328 -    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
   6.329 +    val deflation_abs_rep_thms = map deflation_abs_rep iso_infos
   6.330      val deflation_take_thm =
   6.331        let
   6.332 -        val n = Free ("n", natT);
   6.333 -        fun mk_goal take_const = mk_deflation (take_const $ n);
   6.334 -        val goal = mk_trp (foldr1 mk_conj (map mk_goal take_consts));
   6.335 +        val n = Free ("n", natT)
   6.336 +        fun mk_goal take_const = mk_deflation (take_const $ n)
   6.337 +        val goal = mk_trp (foldr1 mk_conj (map mk_goal take_consts))
   6.338          val adm_rules =
   6.339            @{thms adm_conj adm_subst [OF _ adm_deflation]
   6.340 -                 cont2cont_fst cont2cont_snd cont_id};
   6.341 +                 cont2cont_fst cont2cont_snd cont_id}
   6.342          val bottom_rules =
   6.343 -          take_0_thms @ @{thms deflation_UU simp_thms};
   6.344 +          take_0_thms @ @{thms deflation_UU simp_thms}
   6.345          val deflation_rules =
   6.346            @{thms conjI deflation_ID}
   6.347            @ deflation_abs_rep_thms
   6.348 -          @ get_deflation_thms thy;
   6.349 +          @ get_deflation_thms thy
   6.350        in
   6.351          Goal.prove_global thy [] [] goal (fn _ =>
   6.352           EVERY
   6.353 @@ -349,76 +349,76 @@
   6.354             REPEAT (etac @{thm conjE} 1
   6.355                     ORELSE resolve_tac deflation_rules 1
   6.356                     ORELSE atac 1)])
   6.357 -      end;
   6.358 +      end
   6.359      fun conjuncts [] thm = []
   6.360        | conjuncts (n::[]) thm = [(n, thm)]
   6.361        | conjuncts (n::ns) thm = let
   6.362 -          val thmL = thm RS @{thm conjunct1};
   6.363 -          val thmR = thm RS @{thm conjunct2};
   6.364 -        in (n, thmL):: conjuncts ns thmR end;
   6.365 +          val thmL = thm RS @{thm conjunct1}
   6.366 +          val thmR = thm RS @{thm conjunct2}
   6.367 +        in (n, thmL):: conjuncts ns thmR end
   6.368      val (deflation_take_thms, thy) =
   6.369        fold_map (add_qualified_thm "deflation_take")
   6.370          (map (apsnd Drule.zero_var_indexes)
   6.371 -          (conjuncts dbinds deflation_take_thm)) thy;
   6.372 +          (conjuncts dbinds deflation_take_thm)) thy
   6.373  
   6.374      (* prove strictness of take functions *)
   6.375      fun prove_take_strict (deflation_take, dbind) thy =
   6.376        let
   6.377          val take_strict_thm =
   6.378              Drule.zero_var_indexes
   6.379 -              (@{thm deflation_strict} OF [deflation_take]);
   6.380 +              (@{thm deflation_strict} OF [deflation_take])
   6.381        in
   6.382          add_qualified_simp_thm "take_strict" (dbind, take_strict_thm) thy
   6.383 -      end;
   6.384 +      end
   6.385      val (take_strict_thms, thy) =
   6.386        fold_map prove_take_strict
   6.387 -        (deflation_take_thms ~~ dbinds) thy;
   6.388 +        (deflation_take_thms ~~ dbinds) thy
   6.389  
   6.390      (* prove take/take rules *)
   6.391      fun prove_take_take ((chain_take, deflation_take), dbind) thy =
   6.392        let
   6.393          val take_take_thm =
   6.394              Drule.zero_var_indexes
   6.395 -              (@{thm deflation_chain_min} OF [chain_take, deflation_take]);
   6.396 +              (@{thm deflation_chain_min} OF [chain_take, deflation_take])
   6.397        in
   6.398          add_qualified_thm "take_take" (dbind, take_take_thm) thy
   6.399 -      end;
   6.400 +      end
   6.401      val (take_take_thms, thy) =
   6.402        fold_map prove_take_take
   6.403 -        (chain_take_thms ~~ deflation_take_thms ~~ dbinds) thy;
   6.404 +        (chain_take_thms ~~ deflation_take_thms ~~ dbinds) thy
   6.405  
   6.406      (* prove take_below rules *)
   6.407      fun prove_take_below (deflation_take, dbind) thy =
   6.408        let
   6.409          val take_below_thm =
   6.410              Drule.zero_var_indexes
   6.411 -              (@{thm deflation.below} OF [deflation_take]);
   6.412 +              (@{thm deflation.below} OF [deflation_take])
   6.413        in
   6.414          add_qualified_thm "take_below" (dbind, take_below_thm) thy
   6.415 -      end;
   6.416 +      end
   6.417      val (take_below_thms, thy) =
   6.418        fold_map prove_take_below
   6.419 -        (deflation_take_thms ~~ dbinds) thy;
   6.420 +        (deflation_take_thms ~~ dbinds) thy
   6.421  
   6.422      (* define finiteness predicates *)
   6.423      fun define_finite_const ((dbind, take_const), (lhsT, rhsT)) thy =
   6.424        let
   6.425 -        val finite_type = lhsT --> boolT;
   6.426 -        val finite_bind = Binding.suffix_name "_finite" dbind;
   6.427 +        val finite_type = lhsT --> boolT
   6.428 +        val finite_bind = Binding.suffix_name "_finite" dbind
   6.429          val (finite_const, thy) =
   6.430 -          Sign.declare_const ((finite_bind, finite_type), NoSyn) thy;
   6.431 -        val x = Free ("x", lhsT);
   6.432 -        val n = Free ("n", natT);
   6.433 +          Sign.declare_const ((finite_bind, finite_type), NoSyn) thy
   6.434 +        val x = Free ("x", lhsT)
   6.435 +        val n = Free ("n", natT)
   6.436          val finite_rhs =
   6.437            lambda x (HOLogic.exists_const natT $
   6.438 -            (lambda n (mk_eq (mk_capply (take_const $ n, x), x))));
   6.439 -        val finite_eqn = Logic.mk_equals (finite_const, finite_rhs);
   6.440 +            (lambda n (mk_eq (mk_capply (take_const $ n, x), x))))
   6.441 +        val finite_eqn = Logic.mk_equals (finite_const, finite_rhs)
   6.442          val (finite_def_thm, thy) =
   6.443 -            add_qualified_def "finite_def" (dbind, finite_eqn) thy;
   6.444 -      in ((finite_const, finite_def_thm), thy) end;
   6.445 +            add_qualified_def "finite_def" (dbind, finite_eqn) thy
   6.446 +      in ((finite_const, finite_def_thm), thy) end
   6.447      val ((finite_consts, finite_defs), thy) = thy
   6.448        |> fold_map define_finite_const (dbinds ~~ take_consts ~~ dom_eqns)
   6.449 -      |>> ListPair.unzip;
   6.450 +      |>> ListPair.unzip
   6.451  
   6.452      val result =
   6.453        {
   6.454 @@ -431,11 +431,11 @@
   6.455          take_strict_thms = take_strict_thms,
   6.456          finite_consts = finite_consts,
   6.457          finite_defs = finite_defs
   6.458 -      };
   6.459 +      }
   6.460  
   6.461    in
   6.462      (result, thy)
   6.463 -  end;
   6.464 +  end
   6.465  
   6.466  fun prove_finite_take_induct
   6.467      (spec : (binding * iso_info) list)
   6.468 @@ -443,72 +443,72 @@
   6.469      (lub_take_thms : thm list)
   6.470      (thy : theory) =
   6.471    let
   6.472 -    val dbinds = map fst spec;
   6.473 -    val iso_infos = map snd spec;
   6.474 -    val absTs = map #absT iso_infos;
   6.475 -    val {take_consts, ...} = take_info;
   6.476 -    val {chain_take_thms, take_0_thms, take_Suc_thms, ...} = take_info;
   6.477 -    val {finite_consts, finite_defs, ...} = take_info;
   6.478 +    val dbinds = map fst spec
   6.479 +    val iso_infos = map snd spec
   6.480 +    val absTs = map #absT iso_infos
   6.481 +    val {take_consts, ...} = take_info
   6.482 +    val {chain_take_thms, take_0_thms, take_Suc_thms, ...} = take_info
   6.483 +    val {finite_consts, finite_defs, ...} = take_info
   6.484  
   6.485      val decisive_lemma =
   6.486        let
   6.487          fun iso_locale (info : iso_info) =
   6.488 -            @{thm iso.intro} OF [#abs_inverse info, #rep_inverse info];
   6.489 -        val iso_locale_thms = map iso_locale iso_infos;
   6.490 +            @{thm iso.intro} OF [#abs_inverse info, #rep_inverse info]
   6.491 +        val iso_locale_thms = map iso_locale iso_infos
   6.492          val decisive_abs_rep_thms =
   6.493 -            map (fn x => @{thm decisive_abs_rep} OF [x]) iso_locale_thms;
   6.494 -        val n = Free ("n", @{typ nat});
   6.495 +            map (fn x => @{thm decisive_abs_rep} OF [x]) iso_locale_thms
   6.496 +        val n = Free ("n", @{typ nat})
   6.497          fun mk_decisive t =
   6.498 -            Const (@{const_name decisive}, fastype_of t --> boolT) $ t;
   6.499 -        fun f take_const = mk_decisive (take_const $ n);
   6.500 -        val goal = mk_trp (foldr1 mk_conj (map f take_consts));
   6.501 -        val rules0 = @{thm decisive_bottom} :: take_0_thms;
   6.502 +            Const (@{const_name decisive}, fastype_of t --> boolT) $ t
   6.503 +        fun f take_const = mk_decisive (take_const $ n)
   6.504 +        val goal = mk_trp (foldr1 mk_conj (map f take_consts))
   6.505 +        val rules0 = @{thm decisive_bottom} :: take_0_thms
   6.506          val rules1 =
   6.507              take_Suc_thms @ decisive_abs_rep_thms
   6.508 -            @ @{thms decisive_ID decisive_ssum_map decisive_sprod_map};
   6.509 +            @ @{thms decisive_ID decisive_ssum_map decisive_sprod_map}
   6.510          val tac = EVERY [
   6.511              rtac @{thm nat.induct} 1,
   6.512              simp_tac (HOL_ss addsimps rules0) 1,
   6.513 -            asm_simp_tac (HOL_ss addsimps rules1) 1];
   6.514 -      in Goal.prove_global thy [] [] goal (K tac) end;
   6.515 +            asm_simp_tac (HOL_ss addsimps rules1) 1]
   6.516 +      in Goal.prove_global thy [] [] goal (K tac) end
   6.517      fun conjuncts 1 thm = [thm]
   6.518        | conjuncts n thm = let
   6.519 -          val thmL = thm RS @{thm conjunct1};
   6.520 -          val thmR = thm RS @{thm conjunct2};
   6.521 -        in thmL :: conjuncts (n-1) thmR end;
   6.522 -    val decisive_thms = conjuncts (length spec) decisive_lemma;
   6.523 +          val thmL = thm RS @{thm conjunct1}
   6.524 +          val thmR = thm RS @{thm conjunct2}
   6.525 +        in thmL :: conjuncts (n-1) thmR end
   6.526 +    val decisive_thms = conjuncts (length spec) decisive_lemma
   6.527  
   6.528      fun prove_finite_thm (absT, finite_const) =
   6.529        let
   6.530 -        val goal = mk_trp (finite_const $ Free ("x", absT));
   6.531 +        val goal = mk_trp (finite_const $ Free ("x", absT))
   6.532          val tac =
   6.533              EVERY [
   6.534              rewrite_goals_tac finite_defs,
   6.535              rtac @{thm lub_ID_finite} 1,
   6.536              resolve_tac chain_take_thms 1,
   6.537              resolve_tac lub_take_thms 1,
   6.538 -            resolve_tac decisive_thms 1];
   6.539 +            resolve_tac decisive_thms 1]
   6.540        in
   6.541          Goal.prove_global thy [] [] goal (K tac)
   6.542 -      end;
   6.543 +      end
   6.544      val finite_thms =
   6.545 -        map prove_finite_thm (absTs ~~ finite_consts);
   6.546 +        map prove_finite_thm (absTs ~~ finite_consts)
   6.547  
   6.548      fun prove_take_induct ((ch_take, lub_take), decisive) =
   6.549          Drule.export_without_context
   6.550 -          (@{thm lub_ID_finite_take_induct} OF [ch_take, lub_take, decisive]);
   6.551 +          (@{thm lub_ID_finite_take_induct} OF [ch_take, lub_take, decisive])
   6.552      val take_induct_thms =
   6.553          map prove_take_induct
   6.554 -          (chain_take_thms ~~ lub_take_thms ~~ decisive_thms);
   6.555 +          (chain_take_thms ~~ lub_take_thms ~~ decisive_thms)
   6.556  
   6.557      val thy = thy
   6.558          |> fold (snd oo add_qualified_thm "finite")
   6.559              (dbinds ~~ finite_thms)
   6.560          |> fold (snd oo add_qualified_thm "take_induct")
   6.561 -            (dbinds ~~ take_induct_thms);
   6.562 +            (dbinds ~~ take_induct_thms)
   6.563    in
   6.564      ((finite_thms, take_induct_thms), thy)
   6.565 -  end;
   6.566 +  end
   6.567  
   6.568  fun add_lub_take_theorems
   6.569      (spec : (binding * iso_info) list)
   6.570 @@ -518,57 +518,57 @@
   6.571    let
   6.572  
   6.573      (* retrieve components of spec *)
   6.574 -    val dbinds = map fst spec;
   6.575 -    val iso_infos = map snd spec;
   6.576 -    val absTs = map #absT iso_infos;
   6.577 -    val repTs = map #repT iso_infos;
   6.578 -    val {take_consts, take_0_thms, take_Suc_thms, ...} = take_info;
   6.579 -    val {chain_take_thms, deflation_take_thms, ...} = take_info;
   6.580 +    val dbinds = map fst spec
   6.581 +    val iso_infos = map snd spec
   6.582 +    val absTs = map #absT iso_infos
   6.583 +    val repTs = map #repT iso_infos
   6.584 +    val {take_consts, take_0_thms, take_Suc_thms, ...} = take_info
   6.585 +    val {chain_take_thms, deflation_take_thms, ...} = take_info
   6.586  
   6.587      (* prove take lemmas *)
   6.588      fun prove_take_lemma ((chain_take, lub_take), dbind) thy =
   6.589        let
   6.590          val take_lemma =
   6.591              Drule.export_without_context
   6.592 -              (@{thm lub_ID_take_lemma} OF [chain_take, lub_take]);
   6.593 +              (@{thm lub_ID_take_lemma} OF [chain_take, lub_take])
   6.594        in
   6.595          add_qualified_thm "take_lemma" (dbind, take_lemma) thy
   6.596 -      end;
   6.597 +      end
   6.598      val (take_lemma_thms, thy) =
   6.599        fold_map prove_take_lemma
   6.600 -        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
   6.601 +        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy
   6.602  
   6.603      (* prove reach lemmas *)
   6.604      fun prove_reach_lemma ((chain_take, lub_take), dbind) thy =
   6.605        let
   6.606          val thm =
   6.607              Drule.zero_var_indexes
   6.608 -              (@{thm lub_ID_reach} OF [chain_take, lub_take]);
   6.609 +              (@{thm lub_ID_reach} OF [chain_take, lub_take])
   6.610        in
   6.611          add_qualified_thm "reach" (dbind, thm) thy
   6.612 -      end;
   6.613 +      end
   6.614      val (reach_thms, thy) =
   6.615        fold_map prove_reach_lemma
   6.616 -        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy;
   6.617 +        (chain_take_thms ~~ lub_take_thms ~~ dbinds) thy
   6.618  
   6.619      (* test for finiteness of domain definitions *)
   6.620      local
   6.621 -      val types = [@{type_name ssum}, @{type_name sprod}];
   6.622 +      val types = [@{type_name ssum}, @{type_name sprod}]
   6.623        fun finite d T = if member (op =) absTs T then d else finite' d T
   6.624        and finite' d (Type (c, Ts)) =
   6.625 -          let val d' = d andalso member (op =) types c;
   6.626 +          let val d' = d andalso member (op =) types c
   6.627            in forall (finite d') Ts end
   6.628 -        | finite' d _ = true;
   6.629 +        | finite' d _ = true
   6.630      in
   6.631 -      val is_finite = forall (finite true) repTs;
   6.632 -    end;
   6.633 +      val is_finite = forall (finite true) repTs
   6.634 +    end
   6.635  
   6.636      val ((finite_thms, take_induct_thms), thy) =
   6.637        if is_finite
   6.638        then
   6.639          let
   6.640            val ((finites, take_inducts), thy) =
   6.641 -              prove_finite_take_induct spec take_info lub_take_thms thy;
   6.642 +              prove_finite_take_induct spec take_info lub_take_thms thy
   6.643          in
   6.644            ((SOME finites, take_inducts), thy)
   6.645          end
   6.646 @@ -576,14 +576,14 @@
   6.647          let
   6.648            fun prove_take_induct (chain_take, lub_take) =
   6.649                Drule.zero_var_indexes
   6.650 -                (@{thm lub_ID_take_induct} OF [chain_take, lub_take]);
   6.651 +                (@{thm lub_ID_take_induct} OF [chain_take, lub_take])
   6.652            val take_inducts =
   6.653 -              map prove_take_induct (chain_take_thms ~~ lub_take_thms);
   6.654 +              map prove_take_induct (chain_take_thms ~~ lub_take_thms)
   6.655            val thy = fold (snd oo add_qualified_thm "take_induct")
   6.656 -                         (dbinds ~~ take_inducts) thy;
   6.657 +                         (dbinds ~~ take_inducts) thy
   6.658          in
   6.659            ((NONE, take_inducts), thy)
   6.660 -        end;
   6.661 +        end
   6.662  
   6.663      val result =
   6.664        {
   6.665 @@ -601,9 +601,9 @@
   6.666          take_lemma_thms     = take_lemma_thms,
   6.667          is_finite           = is_finite,
   6.668          take_induct_thms    = take_induct_thms
   6.669 -      };
   6.670 +      }
   6.671    in
   6.672      (result, thy)
   6.673 -  end;
   6.674 +  end
   6.675  
   6.676 -end;
   6.677 +end
     7.1 --- a/src/HOL/HOLCF/Tools/cont_consts.ML	Tue Nov 30 14:01:49 2010 -0800
     7.2 +++ b/src/HOL/HOLCF/Tools/cont_consts.ML	Tue Nov 30 14:21:57 2010 -0800
     7.3 @@ -9,7 +9,7 @@
     7.4  sig
     7.5    val add_consts: (binding * typ * mixfix) list -> theory -> theory
     7.6    val add_consts_cmd: (binding * string * mixfix) list -> theory -> theory
     7.7 -end;
     7.8 +end
     7.9  
    7.10  structure Cont_Consts: CONT_CONSTS =
    7.11  struct
    7.12 @@ -19,12 +19,12 @@
    7.13  
    7.14  fun change_arrow 0 T = T
    7.15    | change_arrow n (Type (_, [S, T])) = Type ("fun", [S, change_arrow (n - 1) T])
    7.16 -  | change_arrow _ T = raise TYPE ("cont_consts: change_arrow", [T], []);
    7.17 +  | change_arrow _ T = raise TYPE ("cont_consts: change_arrow", [T], [])
    7.18  
    7.19  fun trans_rules name2 name1 n mx =
    7.20    let
    7.21 -    val vnames = Name.invents Name.context "a" n;
    7.22 -    val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1);
    7.23 +    val vnames = Name.invents Name.context "a" n
    7.24 +    val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1)
    7.25    in
    7.26      [Syntax.ParsePrintRule
    7.27        (Syntax.mk_appl (Constant name2) (map Variable vnames),
    7.28 @@ -35,7 +35,7 @@
    7.29      | Infixl _ => [extra_parse_rule]
    7.30      | Infixr _ => [extra_parse_rule]
    7.31      | _ => [])
    7.32 -  end;
    7.33 +  end
    7.34  
    7.35  
    7.36  (* transforming infix/mixfix declarations of constants with type ...->...
    7.37 @@ -46,26 +46,26 @@
    7.38  *)
    7.39  fun transform thy (c, T, mx) =
    7.40    let
    7.41 -    fun syntax b = Syntax.mark_const (Sign.full_bname thy b);
    7.42 -    val c1 = Binding.name_of c;
    7.43 -    val c2 = c1 ^ "_cont_syntax";
    7.44 -    val n = Syntax.mixfix_args mx;
    7.45 +    fun syntax b = Syntax.mark_const (Sign.full_bname thy b)
    7.46 +    val c1 = Binding.name_of c
    7.47 +    val c2 = c1 ^ "_cont_syntax"
    7.48 +    val n = Syntax.mixfix_args mx
    7.49    in
    7.50      ((c, T, NoSyn),
    7.51        (Binding.name c2, change_arrow n T, mx),
    7.52        trans_rules (syntax c2) (syntax c1) n mx)
    7.53 -  end;
    7.54 +  end
    7.55  
    7.56  fun cfun_arity (Type (n, [_, T])) = if n = @{type_name cfun} then 1 + cfun_arity T else 0
    7.57 -  | cfun_arity _ = 0;
    7.58 +  | cfun_arity _ = 0
    7.59  
    7.60  fun is_contconst (_, _, NoSyn) = false
    7.61    | is_contconst (_, _, Binder _) = false    (* FIXME ? *)
    7.62    | is_contconst (c, T, mx) =
    7.63        let
    7.64          val n = Syntax.mixfix_args mx handle ERROR msg =>
    7.65 -          cat_error msg ("in mixfix annotation for " ^ quote (Binding.str_of c));
    7.66 -      in cfun_arity T >= n end;
    7.67 +          cat_error msg ("in mixfix annotation for " ^ quote (Binding.str_of c))
    7.68 +      in cfun_arity T >= n end
    7.69  
    7.70  
    7.71  (* add_consts *)
    7.72 @@ -74,20 +74,20 @@
    7.73  
    7.74  fun gen_add_consts prep_typ raw_decls thy =
    7.75    let
    7.76 -    val decls = map (fn (c, T, mx) => (c, prep_typ thy T, mx)) raw_decls;
    7.77 -    val (contconst_decls, normal_decls) = List.partition is_contconst decls;
    7.78 -    val transformed_decls = map (transform thy) contconst_decls;
    7.79 +    val decls = map (fn (c, T, mx) => (c, prep_typ thy T, mx)) raw_decls
    7.80 +    val (contconst_decls, normal_decls) = List.partition is_contconst decls
    7.81 +    val transformed_decls = map (transform thy) contconst_decls
    7.82    in
    7.83      thy
    7.84      |> Sign.add_consts_i (normal_decls @ map #1 transformed_decls @ map #2 transformed_decls)
    7.85      |> Sign.add_trrules_i (maps #3 transformed_decls)
    7.86 -  end;
    7.87 +  end
    7.88  
    7.89  in
    7.90  
    7.91 -val add_consts = gen_add_consts Sign.certify_typ;
    7.92 -val add_consts_cmd = gen_add_consts Syntax.read_typ_global;
    7.93 +val add_consts = gen_add_consts Sign.certify_typ
    7.94 +val add_consts_cmd = gen_add_consts Syntax.read_typ_global
    7.95  
    7.96 -end;
    7.97 +end
    7.98  
    7.99 -end;
   7.100 +end
     8.1 --- a/src/HOL/HOLCF/Tools/cont_proc.ML	Tue Nov 30 14:01:49 2010 -0800
     8.2 +++ b/src/HOL/HOLCF/Tools/cont_proc.ML	Tue Nov 30 14:21:57 2010 -0800
     8.3 @@ -10,21 +10,21 @@
     8.4    val cont_tac: int -> tactic
     8.5    val cont_proc: theory -> simproc
     8.6    val setup: theory -> theory
     8.7 -end;
     8.8 +end
     8.9  
    8.10  structure ContProc :> CONT_PROC =
    8.11  struct
    8.12  
    8.13  (** theory context references **)
    8.14  
    8.15 -val cont_K = @{thm cont_const};
    8.16 -val cont_I = @{thm cont_id};
    8.17 -val cont_A = @{thm cont2cont_APP};
    8.18 -val cont_L = @{thm cont2cont_LAM};
    8.19 -val cont_R = @{thm cont_Rep_cfun2};
    8.20 +val cont_K = @{thm cont_const}
    8.21 +val cont_I = @{thm cont_id}
    8.22 +val cont_A = @{thm cont2cont_APP}
    8.23 +val cont_L = @{thm cont2cont_LAM}
    8.24 +val cont_R = @{thm cont_Rep_cfun2}
    8.25  
    8.26  (* checks whether a term contains no dangling bound variables *)
    8.27 -fun is_closed_term t = not (Term.loose_bvar (t, 0));
    8.28 +fun is_closed_term t = not (Term.loose_bvar (t, 0))
    8.29  
    8.30  (* checks whether a term is written entirely in the LCF sublanguage *)
    8.31  fun is_lcf_term (Const (@{const_name Rep_cfun}, _) $ t $ u) =
    8.32 @@ -34,7 +34,7 @@
    8.33    | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ t) =
    8.34        is_lcf_term (Term.incr_boundvars 1 t $ Bound 0)
    8.35    | is_lcf_term (Bound _) = true
    8.36 -  | is_lcf_term t = is_closed_term t;
    8.37 +  | is_lcf_term t = is_closed_term t
    8.38  
    8.39  (*
    8.40    efficiently generates a cont thm for every LAM abstraction in a term,
    8.41 @@ -42,13 +42,13 @@
    8.42  *)
    8.43  local
    8.44    fun var 0 = [SOME cont_I]
    8.45 -    | var n = NONE :: var (n-1);
    8.46 +    | var n = NONE :: var (n-1)
    8.47  
    8.48    fun k NONE     = cont_K
    8.49 -    | k (SOME x) = x;
    8.50 +    | k (SOME x) = x
    8.51  
    8.52    fun ap NONE NONE = NONE
    8.53 -    | ap x    y    = SOME (k y RS (k x RS cont_A));
    8.54 +    | ap x    y    = SOME (k y RS (k x RS cont_A))
    8.55  
    8.56    fun zip []      []      = []
    8.57      | zip []      (y::ys) = (ap NONE y   ) :: zip [] ys
    8.58 @@ -60,36 +60,36 @@
    8.59      let
    8.60        (* should use "close_derivation" for thms that are used multiple times *)
    8.61        (* it seems to allow for sharing in explicit proof objects *)
    8.62 -      val x' = Thm.close_derivation (k x);
    8.63 -      val Lx = x' RS cont_L;
    8.64 -    in (map (fn y => SOME (k y RS Lx)) ys, x') end;
    8.65 +      val x' = Thm.close_derivation (k x)
    8.66 +      val Lx = x' RS cont_L
    8.67 +    in (map (fn y => SOME (k y RS Lx)) ys, x') end
    8.68  
    8.69    (* first list: cont thm for each dangling bound variable *)
    8.70    (* second list: cont thm for each LAM in t *)
    8.71    (* if b = false, only return cont thm for outermost LAMs *)
    8.72    fun cont_thms1 b (Const (@{const_name Rep_cfun}, _) $ f $ t) =
    8.73      let
    8.74 -      val (cs1,ls1) = cont_thms1 b f;
    8.75 -      val (cs2,ls2) = cont_thms1 b t;
    8.76 +      val (cs1,ls1) = cont_thms1 b f
    8.77 +      val (cs2,ls2) = cont_thms1 b t
    8.78      in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
    8.79      | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
    8.80      let
    8.81 -      val (cs, ls) = cont_thms1 b t;
    8.82 -      val (cs', l) = lam cs;
    8.83 +      val (cs, ls) = cont_thms1 b t
    8.84 +      val (cs', l) = lam cs
    8.85      in (cs', l::ls) end
    8.86      | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ t) =
    8.87      let
    8.88 -      val t' = Term.incr_boundvars 1 t $ Bound 0;
    8.89 -      val (cs, ls) = cont_thms1 b t';
    8.90 -      val (cs', l) = lam cs;
    8.91 +      val t' = Term.incr_boundvars 1 t $ Bound 0
    8.92 +      val (cs, ls) = cont_thms1 b t'
    8.93 +      val (cs', l) = lam cs
    8.94      in (cs', l::ls) end
    8.95      | cont_thms1 _ (Bound n) = (var n, [])
    8.96 -    | cont_thms1 _ _ = ([], []);
    8.97 +    | cont_thms1 _ _ = ([], [])
    8.98  in
    8.99    (* precondition: is_lcf_term t = true *)
   8.100 -  fun cont_thms t = snd (cont_thms1 false t);
   8.101 -  fun all_cont_thms t = snd (cont_thms1 true t);
   8.102 -end;
   8.103 +  fun cont_thms t = snd (cont_thms1 false t)
   8.104 +  fun all_cont_thms t = snd (cont_thms1 true t)
   8.105 +end
   8.106  
   8.107  (*
   8.108    Given the term "cont f", the procedure tries to construct the
   8.109 @@ -100,37 +100,37 @@
   8.110  
   8.111  val cont_tac =
   8.112    let
   8.113 -    val rules = [cont_K, cont_I, cont_R, cont_A, cont_L];
   8.114 +    val rules = [cont_K, cont_I, cont_R, cont_A, cont_L]
   8.115    
   8.116      fun new_cont_tac f' i =
   8.117        case all_cont_thms f' of
   8.118          [] => no_tac
   8.119 -      | (c::cs) => rtac c i;
   8.120 +      | (c::cs) => rtac c i
   8.121  
   8.122      fun cont_tac_of_term (Const (@{const_name cont}, _) $ f) =
   8.123        let
   8.124 -        val f' = Const (@{const_name Abs_cfun}, dummyT) $ f;
   8.125 +        val f' = Const (@{const_name Abs_cfun}, dummyT) $ f
   8.126        in
   8.127          if is_lcf_term f'
   8.128          then new_cont_tac f'
   8.129          else REPEAT_ALL_NEW (resolve_tac rules)
   8.130        end
   8.131 -      | cont_tac_of_term _ = K no_tac;
   8.132 +      | cont_tac_of_term _ = K no_tac
   8.133    in
   8.134      SUBGOAL (fn (t, i) =>
   8.135        cont_tac_of_term (HOLogic.dest_Trueprop t) i)
   8.136 -  end;
   8.137 +  end
   8.138  
   8.139  local
   8.140    fun solve_cont thy _ t =
   8.141      let
   8.142 -      val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
   8.143 +      val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI
   8.144      in Option.map fst (Seq.pull (cont_tac 1 tr)) end
   8.145  in
   8.146    fun cont_proc thy =
   8.147 -    Simplifier.simproc_global thy "cont_proc" ["cont f"] solve_cont;
   8.148 -end;
   8.149 +    Simplifier.simproc_global thy "cont_proc" ["cont f"] solve_cont
   8.150 +end
   8.151  
   8.152 -fun setup thy = Simplifier.map_simpset (fn ss => ss addsimprocs [cont_proc thy]) thy;
   8.153 +fun setup thy = Simplifier.map_simpset (fn ss => ss addsimprocs [cont_proc thy]) thy
   8.154  
   8.155 -end;
   8.156 +end
     9.1 --- a/src/HOL/HOLCF/Tools/cpodef.ML	Tue Nov 30 14:01:49 2010 -0800
     9.2 +++ b/src/HOL/HOLCF/Tools/cpodef.ML	Tue Nov 30 14:21:57 2010 -0800
     9.3 @@ -36,7 +36,7 @@
     9.4    val pcpodef_proof_cmd: (bool * binding)
     9.5      * (binding * (string * string option) list * mixfix) * string
     9.6      * (binding * binding) option -> theory -> Proof.state
     9.7 -end;
     9.8 +end
     9.9  
    9.10  structure Cpodef :> CPODEF =
    9.11  struct
    9.12 @@ -53,22 +53,22 @@
    9.13  
    9.14  (* building terms *)
    9.15  
    9.16 -fun adm_const T = Const (@{const_name adm}, (T --> HOLogic.boolT) --> HOLogic.boolT);
    9.17 -fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
    9.18 +fun adm_const T = Const (@{const_name adm}, (T --> HOLogic.boolT) --> HOLogic.boolT)
    9.19 +fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P)
    9.20  
    9.21 -fun below_const T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
    9.22 +fun below_const T = Const (@{const_name below}, T --> T --> HOLogic.boolT)
    9.23  
    9.24  (* manipulating theorems *)
    9.25  
    9.26  fun fold_adm_mem thm NONE = thm
    9.27    | fold_adm_mem thm (SOME set_def) =
    9.28      let val rule = @{lemma "A == B ==> adm (%x. x : B) ==> adm (%x. x : A)" by simp}
    9.29 -    in rule OF [set_def, thm] end;
    9.30 +    in rule OF [set_def, thm] end
    9.31  
    9.32  fun fold_UU_mem thm NONE = thm
    9.33    | fold_UU_mem thm (SOME set_def) =
    9.34      let val rule = @{lemma "A == B ==> UU : B ==> UU : A" by simp}
    9.35 -    in rule OF [set_def, thm] end;
    9.36 +    in rule OF [set_def, thm] end
    9.37  
    9.38  (* proving class instances *)
    9.39  
    9.40 @@ -83,20 +83,20 @@
    9.41        (thy: theory)
    9.42      =
    9.43    let
    9.44 -    val admissible' = fold_adm_mem admissible set_def;
    9.45 -    val cpo_thms = map (Thm.transfer thy) [type_definition, below_def, admissible'];
    9.46 -    val (full_tname, Ts) = dest_Type newT;
    9.47 -    val lhs_sorts = map (snd o dest_TFree) Ts;
    9.48 -    val tac = Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1;
    9.49 -    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo}) tac thy;
    9.50 +    val admissible' = fold_adm_mem admissible set_def
    9.51 +    val cpo_thms = map (Thm.transfer thy) [type_definition, below_def, admissible']
    9.52 +    val (full_tname, Ts) = dest_Type newT
    9.53 +    val lhs_sorts = map (snd o dest_TFree) Ts
    9.54 +    val tac = Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1
    9.55 +    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo}) tac thy
    9.56      (* transfer thms so that they will know about the new cpo instance *)
    9.57 -    val cpo_thms' = map (Thm.transfer thy) cpo_thms;
    9.58 -    fun make thm = Drule.zero_var_indexes (thm OF cpo_thms');
    9.59 -    val cont_Rep = make @{thm typedef_cont_Rep};
    9.60 -    val cont_Abs = make @{thm typedef_cont_Abs};
    9.61 -    val is_lub = make @{thm typedef_is_lub};
    9.62 -    val lub = make @{thm typedef_lub};
    9.63 -    val compact = make @{thm typedef_compact};
    9.64 +    val cpo_thms' = map (Thm.transfer thy) cpo_thms
    9.65 +    fun make thm = Drule.zero_var_indexes (thm OF cpo_thms')
    9.66 +    val cont_Rep = make @{thm typedef_cont_Rep}
    9.67 +    val cont_Abs = make @{thm typedef_cont_Abs}
    9.68 +    val is_lub = make @{thm typedef_is_lub}
    9.69 +    val lub = make @{thm typedef_lub}
    9.70 +    val compact = make @{thm typedef_compact}
    9.71      val (_, thy) =
    9.72        thy
    9.73        |> Sign.add_path (Binding.name_of name)
    9.74 @@ -107,13 +107,13 @@
    9.75            ((Binding.prefix_name "is_lub_"   name, is_lub     ), []),
    9.76            ((Binding.prefix_name "lub_"      name, lub        ), []),
    9.77            ((Binding.prefix_name "compact_"  name, compact    ), [])])
    9.78 -      ||> Sign.parent_path;
    9.79 +      ||> Sign.parent_path
    9.80      val cpo_info : cpo_info =
    9.81        { below_def = below_def, adm = admissible', cont_Rep = cont_Rep,
    9.82 -        cont_Abs = cont_Abs, is_lub = is_lub, lub = lub, compact = compact };
    9.83 +        cont_Abs = cont_Abs, is_lub = is_lub, lub = lub, compact = compact }
    9.84    in
    9.85      (cpo_info, thy)
    9.86 -  end;
    9.87 +  end
    9.88  
    9.89  fun prove_pcpo
    9.90        (name: binding)
    9.91 @@ -126,20 +126,20 @@
    9.92        (thy: theory)
    9.93      =
    9.94    let
    9.95 -    val UU_mem' = fold_UU_mem UU_mem set_def;
    9.96 -    val pcpo_thms = map (Thm.transfer thy) [type_definition, below_def, UU_mem'];
    9.97 -    val (full_tname, Ts) = dest_Type newT;
    9.98 -    val lhs_sorts = map (snd o dest_TFree) Ts;
    9.99 -    val tac = Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1;
   9.100 -    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo}) tac thy;
   9.101 -    val pcpo_thms' = map (Thm.transfer thy) pcpo_thms;
   9.102 -    fun make thm = Drule.zero_var_indexes (thm OF pcpo_thms');
   9.103 -    val Rep_strict = make @{thm typedef_Rep_strict};
   9.104 -    val Abs_strict = make @{thm typedef_Abs_strict};
   9.105 -    val Rep_bottom_iff = make @{thm typedef_Rep_bottom_iff};
   9.106 -    val Abs_bottom_iff = make @{thm typedef_Abs_bottom_iff};
   9.107 -    val Rep_defined = make @{thm typedef_Rep_defined};
   9.108 -    val Abs_defined = make @{thm typedef_Abs_defined};
   9.109 +    val UU_mem' = fold_UU_mem UU_mem set_def
   9.110 +    val pcpo_thms = map (Thm.transfer thy) [type_definition, below_def, UU_mem']
   9.111 +    val (full_tname, Ts) = dest_Type newT
   9.112 +    val lhs_sorts = map (snd o dest_TFree) Ts
   9.113 +    val tac = Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1
   9.114 +    val thy = AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo}) tac thy
   9.115 +    val pcpo_thms' = map (Thm.transfer thy) pcpo_thms
   9.116 +    fun make thm = Drule.zero_var_indexes (thm OF pcpo_thms')
   9.117 +    val Rep_strict = make @{thm typedef_Rep_strict}
   9.118 +    val Abs_strict = make @{thm typedef_Abs_strict}
   9.119 +    val Rep_bottom_iff = make @{thm typedef_Rep_bottom_iff}
   9.120 +    val Abs_bottom_iff = make @{thm typedef_Abs_bottom_iff}
   9.121 +    val Rep_defined = make @{thm typedef_Rep_defined}
   9.122 +    val Abs_defined = make @{thm typedef_Abs_defined}
   9.123      val (_, thy) =
   9.124        thy
   9.125        |> Sign.add_path (Binding.name_of name)
   9.126 @@ -150,70 +150,70 @@
   9.127            ((Binding.suffix_name "_bottom_iff" Abs_name, Abs_bottom_iff), []),
   9.128            ((Binding.suffix_name "_defined"    Rep_name, Rep_defined), []),
   9.129            ((Binding.suffix_name "_defined"    Abs_name, Abs_defined), [])])
   9.130 -      ||> Sign.parent_path;
   9.131 +      ||> Sign.parent_path
   9.132      val pcpo_info =
   9.133        { Rep_strict = Rep_strict, Abs_strict = Abs_strict,
   9.134          Rep_bottom_iff = Rep_bottom_iff, Abs_bottom_iff = Abs_bottom_iff,
   9.135 -        Rep_defined = Rep_defined, Abs_defined = Abs_defined };
   9.136 +        Rep_defined = Rep_defined, Abs_defined = Abs_defined }
   9.137    in
   9.138      (pcpo_info, thy)
   9.139 -  end;
   9.140 +  end
   9.141  
   9.142  (* prepare_cpodef *)
   9.143  
   9.144  fun declare_type_name a =
   9.145 -  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
   9.146 +  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)))
   9.147  
   9.148  fun prepare prep_term name (tname, raw_args, mx) raw_set opt_morphs thy =
   9.149    let
   9.150 -    val _ = Theory.requires thy "Cpodef" "cpodefs";
   9.151 +    val _ = Theory.requires thy "Cpodef" "cpodefs"
   9.152  
   9.153      (*rhs*)
   9.154      val tmp_ctxt =
   9.155        ProofContext.init_global thy
   9.156 -      |> fold (Variable.declare_typ o TFree) raw_args;
   9.157 -    val set = prep_term tmp_ctxt raw_set;
   9.158 -    val tmp_ctxt' = tmp_ctxt |> Variable.declare_term set;
   9.159 +      |> fold (Variable.declare_typ o TFree) raw_args
   9.160 +    val set = prep_term tmp_ctxt raw_set
   9.161 +    val tmp_ctxt' = tmp_ctxt |> Variable.declare_term set
   9.162  
   9.163 -    val setT = Term.fastype_of set;
   9.164 +    val setT = Term.fastype_of set
   9.165      val oldT = HOLogic.dest_setT setT handle TYPE _ =>
   9.166 -      error ("Not a set type: " ^ quote (Syntax.string_of_typ tmp_ctxt setT));
   9.167 +      error ("Not a set type: " ^ quote (Syntax.string_of_typ tmp_ctxt setT))
   9.168  
   9.169      (*lhs*)
   9.170 -    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt') raw_args;
   9.171 -    val full_tname = Sign.full_name thy tname;
   9.172 -    val newT = Type (full_tname, map TFree lhs_tfrees);
   9.173 +    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt') raw_args
   9.174 +    val full_tname = Sign.full_name thy tname
   9.175 +    val newT = Type (full_tname, map TFree lhs_tfrees)
   9.176  
   9.177      val morphs = opt_morphs
   9.178 -      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
   9.179 +      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name)
   9.180    in
   9.181      (newT, oldT, set, morphs)
   9.182    end
   9.183  
   9.184  fun add_podef def opt_name typ set opt_morphs tac thy =
   9.185    let
   9.186 -    val name = the_default (#1 typ) opt_name;
   9.187 +    val name = the_default (#1 typ) opt_name
   9.188      val ((full_tname, info as ({Rep_name, ...}, {type_definition, set_def, ...})), thy2) = thy
   9.189 -      |> Typedef.add_typedef_global def opt_name typ set opt_morphs tac;
   9.190 -    val oldT = #rep_type (#1 info);
   9.191 -    val newT = #abs_type (#1 info);
   9.192 -    val lhs_tfrees = map dest_TFree (snd (dest_Type newT));
   9.193 +      |> Typedef.add_typedef_global def opt_name typ set opt_morphs tac
   9.194 +    val oldT = #rep_type (#1 info)
   9.195 +    val newT = #abs_type (#1 info)
   9.196 +    val lhs_tfrees = map dest_TFree (snd (dest_Type newT))
   9.197  
   9.198 -    val RepC = Const (Rep_name, newT --> oldT);
   9.199 +    val RepC = Const (Rep_name, newT --> oldT)
   9.200      val below_eqn = Logic.mk_equals (below_const newT,
   9.201 -      Abs ("x", newT, Abs ("y", newT, below_const oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
   9.202 +      Abs ("x", newT, Abs ("y", newT, below_const oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))))
   9.203      val lthy3 = thy2
   9.204 -      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort po});
   9.205 +      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort po})
   9.206      val ((_, (_, below_ldef)), lthy4) = lthy3
   9.207        |> Specification.definition (NONE,
   9.208 -          ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_eqn));
   9.209 -    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy4);
   9.210 -    val below_def = singleton (ProofContext.export lthy4 ctxt_thy) below_ldef;
   9.211 +          ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_eqn))
   9.212 +    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy4)
   9.213 +    val below_def = singleton (ProofContext.export lthy4 ctxt_thy) below_ldef
   9.214      val thy5 = lthy4
   9.215        |> Class.prove_instantiation_instance
   9.216            (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, below_def]) 1))
   9.217 -      |> Local_Theory.exit_global;
   9.218 -  in ((info, below_def), thy5) end;
   9.219 +      |> Local_Theory.exit_global
   9.220 +  in ((info, below_def), thy5) end
   9.221  
   9.222  fun prepare_cpodef
   9.223        (prep_term: Proof.context -> 'a -> term)
   9.224 @@ -226,27 +226,27 @@
   9.225      : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info) * theory) =
   9.226    let
   9.227      val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
   9.228 -      prepare prep_term name typ raw_set opt_morphs thy;
   9.229 +      prepare prep_term name typ raw_set opt_morphs thy
   9.230  
   9.231      val goal_nonempty =
   9.232 -      HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
   9.233 +      HOLogic.mk_Trueprop (HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)))
   9.234      val goal_admissible =
   9.235 -      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
   9.236 +      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)))
   9.237  
   9.238      fun cpodef_result nonempty admissible thy =
   9.239        let
   9.240          val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
   9.241 -          |> add_podef def (SOME name) typ set opt_morphs (Tactic.rtac nonempty 1);
   9.242 +          |> add_podef def (SOME name) typ set opt_morphs (Tactic.rtac nonempty 1)
   9.243          val (cpo_info, thy3) = thy2
   9.244 -          |> prove_cpo name newT morphs type_definition set_def below_def admissible;
   9.245 +          |> prove_cpo name newT morphs type_definition set_def below_def admissible
   9.246        in
   9.247          ((info, cpo_info), thy3)
   9.248 -      end;
   9.249 +      end
   9.250    in
   9.251      (goal_nonempty, goal_admissible, cpodef_result)
   9.252    end
   9.253    handle ERROR msg =>
   9.254 -    cat_error msg ("The error(s) above occurred in cpodef " ^ quote (Binding.str_of name));
   9.255 +    cat_error msg ("The error(s) above occurred in cpodef " ^ quote (Binding.str_of name))
   9.256  
   9.257  fun prepare_pcpodef
   9.258        (prep_term: Proof.context -> 'a -> term)
   9.259 @@ -259,60 +259,60 @@
   9.260      : term * term * (thm -> thm -> theory -> (Typedef.info * cpo_info * pcpo_info) * theory) =
   9.261    let
   9.262      val (newT, oldT, set, morphs as (Rep_name, Abs_name)) =
   9.263 -      prepare prep_term name typ raw_set opt_morphs thy;
   9.264 +      prepare prep_term name typ raw_set opt_morphs thy
   9.265  
   9.266      val goal_UU_mem =
   9.267 -      HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name UU}, oldT), set));
   9.268 +      HOLogic.mk_Trueprop (HOLogic.mk_mem (Const (@{const_name UU}, oldT), set))
   9.269  
   9.270      val goal_admissible =
   9.271 -      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)));
   9.272 +      HOLogic.mk_Trueprop (mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), set)))
   9.273  
   9.274      fun pcpodef_result UU_mem admissible thy =
   9.275        let
   9.276 -        val tac = Tactic.rtac exI 1 THEN Tactic.rtac UU_mem 1;
   9.277 +        val tac = Tactic.rtac exI 1 THEN Tactic.rtac UU_mem 1
   9.278          val ((info as (_, {type_definition, set_def, ...}), below_def), thy2) = thy
   9.279 -          |> add_podef def (SOME name) typ set opt_morphs tac;
   9.280 +          |> add_podef def (SOME name) typ set opt_morphs tac
   9.281          val (cpo_info, thy3) = thy2
   9.282 -          |> prove_cpo name newT morphs type_definition set_def below_def admissible;
   9.283 +          |> prove_cpo name newT morphs type_definition set_def below_def admissible
   9.284          val (pcpo_info, thy4) = thy3
   9.285 -          |> prove_pcpo name newT morphs type_definition set_def below_def UU_mem;
   9.286 +          |> prove_pcpo name newT morphs type_definition set_def below_def UU_mem
   9.287        in
   9.288          ((info, cpo_info, pcpo_info), thy4)
   9.289 -      end;
   9.290 +      end
   9.291    in
   9.292      (goal_UU_mem, goal_admissible, pcpodef_result)
   9.293    end
   9.294    handle ERROR msg =>
   9.295 -    cat_error msg ("The error(s) above occurred in pcpodef " ^ quote (Binding.str_of name));
   9.296 +    cat_error msg ("The error(s) above occurred in pcpodef " ^ quote (Binding.str_of name))
   9.297  
   9.298  
   9.299  (* tactic interface *)
   9.300  
   9.301  fun add_cpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
   9.302    let
   9.303 -    val name = the_default (#1 typ) opt_name;
   9.304 +    val name = the_default (#1 typ) opt_name
   9.305      val (goal1, goal2, cpodef_result) =
   9.306 -      prepare_cpodef Syntax.check_term def name typ set opt_morphs thy;
   9.307 +      prepare_cpodef Syntax.check_term def name typ set opt_morphs thy
   9.308      val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
   9.309        handle ERROR msg => cat_error msg
   9.310 -        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
   9.311 +        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set))
   9.312      val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
   9.313        handle ERROR msg => cat_error msg
   9.314 -        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
   9.315 -  in cpodef_result thm1 thm2 thy end;
   9.316 +        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set))
   9.317 +  in cpodef_result thm1 thm2 thy end
   9.318  
   9.319  fun add_pcpodef def opt_name typ set opt_morphs (tac1, tac2) thy =
   9.320    let
   9.321 -    val name = the_default (#1 typ) opt_name;
   9.322 +    val name = the_default (#1 typ) opt_name
   9.323      val (goal1, goal2, pcpodef_result) =
   9.324 -      prepare_pcpodef Syntax.check_term def name typ set opt_morphs thy;
   9.325 +      prepare_pcpodef Syntax.check_term def name typ set opt_morphs thy
   9.326      val thm1 = Goal.prove_global thy [] [] goal1 (K tac1)
   9.327        handle ERROR msg => cat_error msg
   9.328 -        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set));
   9.329 +        ("Failed to prove non-emptiness of " ^ quote (Syntax.string_of_term_global thy set))
   9.330      val thm2 = Goal.prove_global thy [] [] goal2 (K tac2)
   9.331        handle ERROR msg => cat_error msg
   9.332 -        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set));
   9.333 -  in pcpodef_result thm1 thm2 thy end;
   9.334 +        ("Failed to prove admissibility of " ^ quote (Syntax.string_of_term_global thy set))
   9.335 +  in pcpodef_result thm1 thm2 thy end
   9.336  
   9.337  
   9.338  (* proof interface *)
   9.339 @@ -322,34 +322,34 @@
   9.340  fun gen_cpodef_proof prep_term prep_constraint
   9.341      ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
   9.342    let
   9.343 -    val ctxt = ProofContext.init_global thy;
   9.344 -    val args = map (apsnd (prep_constraint ctxt)) raw_args;
   9.345 +    val ctxt = ProofContext.init_global thy
   9.346 +    val args = map (apsnd (prep_constraint ctxt)) raw_args
   9.347      val (goal1, goal2, make_result) =
   9.348 -      prepare_cpodef prep_term def name (b, args, mx) set opt_morphs thy;
   9.349 +      prepare_cpodef prep_term def name (b, args, mx) set opt_morphs thy
   9.350      fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
   9.351 -      | after_qed _ = raise Fail "cpodef_proof";
   9.352 -  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
   9.353 +      | after_qed _ = raise Fail "cpodef_proof"
   9.354 +  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end
   9.355  
   9.356  fun gen_pcpodef_proof prep_term prep_constraint
   9.357      ((def, name), (b, raw_args, mx), set, opt_morphs) thy =
   9.358    let
   9.359 -    val ctxt = ProofContext.init_global thy;
   9.360 -    val args = map (apsnd (prep_constraint ctxt)) raw_args;
   9.361 +    val ctxt = ProofContext.init_global thy
   9.362 +    val args = map (apsnd (prep_constraint ctxt)) raw_args
   9.363      val (goal1, goal2, make_result) =
   9.364 -      prepare_pcpodef prep_term def name (b, args, mx) set opt_morphs thy;
   9.365 +      prepare_pcpodef prep_term def name (b, args, mx) set opt_morphs thy
   9.366      fun after_qed [[th1, th2]] = ProofContext.background_theory (snd o make_result th1 th2)
   9.367 -      | after_qed _ = raise Fail "pcpodef_proof";
   9.368 -  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end;
   9.369 +      | after_qed _ = raise Fail "pcpodef_proof"
   9.370 +  in Proof.theorem NONE after_qed [[(goal1, []), (goal2, [])]] ctxt end
   9.371  
   9.372  in
   9.373  
   9.374 -fun cpodef_proof x = gen_cpodef_proof Syntax.check_term (K I) x;
   9.375 -fun cpodef_proof_cmd x = gen_cpodef_proof Syntax.read_term Typedecl.read_constraint x;
   9.376 +fun cpodef_proof x = gen_cpodef_proof Syntax.check_term (K I) x
   9.377 +fun cpodef_proof_cmd x = gen_cpodef_proof Syntax.read_term Typedecl.read_constraint x
   9.378  
   9.379 -fun pcpodef_proof x = gen_pcpodef_proof Syntax.check_term (K I) x;
   9.380 -fun pcpodef_proof_cmd x = gen_pcpodef_proof Syntax.read_term Typedecl.read_constraint x;
   9.381 +fun pcpodef_proof x = gen_pcpodef_proof Syntax.check_term (K I) x
   9.382 +fun pcpodef_proof_cmd x = gen_pcpodef_proof Syntax.read_term Typedecl.read_constraint x
   9.383  
   9.384 -end;
   9.385 +end
   9.386  
   9.387  
   9.388  
   9.389 @@ -362,22 +362,22 @@
   9.390          --| Parse.$$$ ")") (true, NONE) --
   9.391      (Parse.type_args_constrained -- Parse.binding) -- Parse.opt_mixfix --
   9.392      (Parse.$$$ "=" |-- Parse.term) --
   9.393 -    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
   9.394 +    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding))
   9.395  
   9.396  fun mk_pcpodef_proof pcpo ((((((def, opt_name), (args, t)), mx), A), morphs)) =
   9.397    (if pcpo then pcpodef_proof_cmd else cpodef_proof_cmd)
   9.398 -    ((def, the_default t opt_name), (t, args, mx), A, morphs);
   9.399 +    ((def, the_default t opt_name), (t, args, mx), A, morphs)
   9.400  
   9.401  val _ =
   9.402    Outer_Syntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)"
   9.403    Keyword.thy_goal
   9.404      (typedef_proof_decl >>
   9.405 -      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)));
   9.406 +      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)))
   9.407  
   9.408  val _ =
   9.409    Outer_Syntax.command "cpodef" "HOLCF type definition (requires admissibility proof)"
   9.410    Keyword.thy_goal
   9.411      (typedef_proof_decl >>
   9.412 -      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)));
   9.413 +      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)))
   9.414  
   9.415 -end;
   9.416 +end
    10.1 --- a/src/HOL/HOLCF/Tools/domaindef.ML	Tue Nov 30 14:01:49 2010 -0800
    10.2 +++ b/src/HOL/HOLCF/Tools/domaindef.ML	Tue Nov 30 14:21:57 2010 -0800
    10.3 @@ -23,15 +23,15 @@
    10.4  
    10.5    val domaindef_cmd: (bool * binding) * (binding * (string * string option) list * mixfix) * string
    10.6      * (binding * binding) option -> theory -> theory
    10.7 -end;
    10.8 +end
    10.9  
   10.10  structure Domaindef :> DOMAINDEF =
   10.11  struct
   10.12  
   10.13 -open HOLCF_Library;
   10.14 +open HOLCF_Library
   10.15  
   10.16 -infixr 6 ->>;
   10.17 -infix -->>;
   10.18 +infixr 6 ->>
   10.19 +infix -->>
   10.20  
   10.21  (** type definitions **)
   10.22  
   10.23 @@ -44,39 +44,39 @@
   10.24      liftprj_def : thm,
   10.25      liftdefl_def : thm,
   10.26      DEFL : thm
   10.27 -  };
   10.28 +  }
   10.29  
   10.30  (* building types and terms *)
   10.31  
   10.32 -val udomT = @{typ udom};
   10.33 -val deflT = @{typ defl};
   10.34 -fun emb_const T = Const (@{const_name emb}, T ->> udomT);
   10.35 -fun prj_const T = Const (@{const_name prj}, udomT ->> T);
   10.36 -fun defl_const T = Const (@{const_name defl}, Term.itselfT T --> deflT);
   10.37 -fun liftemb_const T = Const (@{const_name liftemb}, mk_upT T ->> udomT);
   10.38 -fun liftprj_const T = Const (@{const_name liftprj}, udomT ->> mk_upT T);
   10.39 -fun liftdefl_const T = Const (@{const_name liftdefl}, Term.itselfT T --> deflT);
   10.40 +val udomT = @{typ udom}
   10.41 +val deflT = @{typ defl}
   10.42 +fun emb_const T = Const (@{const_name emb}, T ->> udomT)
   10.43 +fun prj_const T = Const (@{const_name prj}, udomT ->> T)
   10.44 +fun defl_const T = Const (@{const_name defl}, Term.itselfT T --> deflT)
   10.45 +fun liftemb_const T = Const (@{const_name liftemb}, mk_upT T ->> udomT)
   10.46 +fun liftprj_const T = Const (@{const_name liftprj}, udomT ->> mk_upT T)
   10.47 +fun liftdefl_const T = Const (@{const_name liftdefl}, Term.itselfT T --> deflT)
   10.48  
   10.49  fun mk_u_map t =
   10.50    let
   10.51 -    val (T, U) = dest_cfunT (fastype_of t);
   10.52 -    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U);
   10.53 -    val u_map_const = Const (@{const_name u_map}, u_map_type);
   10.54 +    val (T, U) = dest_cfunT (fastype_of t)
   10.55 +    val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U)
   10.56 +    val u_map_const = Const (@{const_name u_map}, u_map_type)
   10.57    in
   10.58      mk_capply (u_map_const, t)
   10.59 -  end;
   10.60 +  end
   10.61  
   10.62  fun mk_cast (t, x) =
   10.63    capply_const (udomT, udomT)
   10.64    $ (capply_const (deflT, udomT ->> udomT) $ @{const cast} $ t)
   10.65 -  $ x;
   10.66 +  $ x
   10.67  
   10.68  (* manipulating theorems *)
   10.69  
   10.70  (* proving class instances *)
   10.71  
   10.72  fun declare_type_name a =
   10.73 -  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
   10.74 +  Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)))
   10.75  
   10.76  fun gen_add_domaindef
   10.77        (prep_term: Proof.context -> 'a -> term)
   10.78 @@ -88,130 +88,130 @@
   10.79        (thy: theory)
   10.80      : (Typedef.info * Cpodef.cpo_info * Cpodef.pcpo_info * rep_info) * theory =
   10.81    let
   10.82 -    val _ = Theory.requires thy "Domain" "domaindefs";
   10.83 +    val _ = Theory.requires thy "Domain" "domaindefs"
   10.84  
   10.85      (*rhs*)
   10.86      val tmp_ctxt =
   10.87        ProofContext.init_global thy
   10.88 -      |> fold (Variable.declare_typ o TFree) raw_args;
   10.89 -    val defl = prep_term tmp_ctxt raw_defl;
   10.90 -    val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl;
   10.91 +      |> fold (Variable.declare_typ o TFree) raw_args
   10.92 +    val defl = prep_term tmp_ctxt raw_defl
   10.93 +    val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl
   10.94  
   10.95 -    val deflT = Term.fastype_of defl;
   10.96 +    val deflT = Term.fastype_of defl
   10.97      val _ = if deflT = @{typ "defl"} then ()
   10.98 -            else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT));
   10.99 +            else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT))
  10.100  
  10.101      (*lhs*)
  10.102 -    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt) raw_args;
  10.103 -    val lhs_sorts = map snd lhs_tfrees;
  10.104 -    val full_tname = Sign.full_name thy tname;
  10.105 -    val newT = Type (full_tname, map TFree lhs_tfrees);
  10.106 +    val lhs_tfrees = map (ProofContext.check_tfree tmp_ctxt) raw_args
  10.107 +    val lhs_sorts = map snd lhs_tfrees
  10.108 +    val full_tname = Sign.full_name thy tname
  10.109 +    val newT = Type (full_tname, map TFree lhs_tfrees)
  10.110  
  10.111      (*morphisms*)
  10.112      val morphs = opt_morphs
  10.113 -      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name);
  10.114 +      |> the_default (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name)
  10.115  
  10.116      (*set*)
  10.117 -    val set = @{const defl_set} $ defl;
  10.118 +    val set = @{const defl_set} $ defl
  10.119  
  10.120      (*pcpodef*)
  10.121 -    val tac1 = rtac @{thm defl_set_bottom} 1;
  10.122 -    val tac2 = rtac @{thm adm_defl_set} 1;
  10.123 +    val tac1 = rtac @{thm defl_set_bottom} 1
  10.124 +    val tac2 = rtac @{thm adm_defl_set} 1
  10.125      val ((info, cpo_info, pcpo_info), thy) = thy
  10.126 -      |> Cpodef.add_pcpodef def (SOME name) typ set (SOME morphs) (tac1, tac2);
  10.127 +      |> Cpodef.add_pcpodef def (SOME name) typ set (SOME morphs) (tac1, tac2)
  10.128  
  10.129      (*definitions*)
  10.130 -    val Rep_const = Const (#Rep_name (#1 info), newT --> udomT);
  10.131 -    val Abs_const = Const (#Abs_name (#1 info), udomT --> newT);
  10.132 -    val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const);
  10.133 +    val Rep_const = Const (#Rep_name (#1 info), newT --> udomT)
  10.134 +    val Abs_const = Const (#Abs_name (#1 info), udomT --> newT)
  10.135 +    val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const)
  10.136      val prj_eqn = Logic.mk_equals (prj_const newT, cabs_const (udomT, newT) $
  10.137 -      Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)));
  10.138 +      Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)))
  10.139      val defl_eqn = Logic.mk_equals (defl_const newT,
  10.140 -      Abs ("x", Term.itselfT newT, defl));
  10.141 +      Abs ("x", Term.itselfT newT, defl))
  10.142      val liftemb_eqn =
  10.143        Logic.mk_equals (liftemb_const newT,
  10.144 -      mk_cfcomp (@{term "udom_emb u_approx"}, mk_u_map (emb_const newT)));
  10.145 +      mk_cfcomp (@{term "udom_emb u_approx"}, mk_u_map (emb_const newT)))
  10.146      val liftprj_eqn =
  10.147        Logic.mk_equals (liftprj_const newT,
  10.148 -      mk_cfcomp (mk_u_map (prj_const newT), @{term "udom_prj u_approx"}));
  10.149 +      mk_cfcomp (mk_u_map (prj_const newT), @{term "udom_prj u_approx"}))
  10.150      val liftdefl_eqn =
  10.151        Logic.mk_equals (liftdefl_const newT,
  10.152          Abs ("t", Term.itselfT newT,
  10.153 -          mk_capply (@{const u_defl}, defl_const newT $ Logic.mk_type newT)));
  10.154 +          mk_capply (@{const u_defl}, defl_const newT $ Logic.mk_type newT)))
  10.155  
  10.156 -    val name_def = Binding.suffix_name "_def" name;
  10.157 -    val emb_bind = (Binding.prefix_name "emb_" name_def, []);
  10.158 -    val prj_bind = (Binding.prefix_name "prj_" name_def, []);
  10.159 -    val defl_bind = (Binding.prefix_name "defl_" name_def, []);
  10.160 -    val liftemb_bind = (Binding.prefix_name "liftemb_" name_def, []);
  10.161 -    val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, []);
  10.162 -    val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, []);
  10.163 +    val name_def = Binding.suffix_name "_def" name
  10.164 +    val emb_bind = (Binding.prefix_name "emb_" name_def, [])
  10.165 +    val prj_bind = (Binding.prefix_name "prj_" name_def, [])
  10.166 +    val defl_bind = (Binding.prefix_name "defl_" name_def, [])
  10.167 +    val liftemb_bind = (Binding.prefix_name "liftemb_" name_def, [])
  10.168 +    val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, [])
  10.169 +    val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, [])
  10.170  
  10.171      (*instantiate class rep*)
  10.172      val lthy = thy
  10.173 -      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort liftdomain});
  10.174 +      |> Class.instantiation ([full_tname], lhs_tfrees, @{sort liftdomain})
  10.175      val ((_, (_, emb_ldef)), lthy) =
  10.176 -        Specification.definition (NONE, (emb_bind, emb_eqn)) lthy;
  10.177 +        Specification.definition (NONE, (emb_bind, emb_eqn)) lthy
  10.178      val ((_, (_, prj_ldef)), lthy) =
  10.179 -        Specification.definition (NONE, (prj_bind, prj_eqn)) lthy;
  10.180 +        Specification.definition (NONE, (prj_bind, prj_eqn)) lthy
  10.181      val ((_, (_, defl_ldef)), lthy) =
  10.182 -        Specification.definition (NONE, (defl_bind, defl_eqn)) lthy;
  10.183 +        Specification.definition (NONE, (defl_bind, defl_eqn)) lthy
  10.184      val ((_, (_, liftemb_ldef)), lthy) =
  10.185 -        Specification.definition (NONE, (liftemb_bind, liftemb_eqn)) lthy;
  10.186 +        Specification.definition (NONE, (liftemb_bind, liftemb_eqn)) lthy
  10.187      val ((_, (_, liftprj_ldef)), lthy) =
  10.188 -        Specification.definition (NONE, (liftprj_bind, liftprj_eqn)) lthy;
  10.189 +        Specification.definition (NONE, (liftprj_bind, liftprj_eqn)) lthy
  10.190      val ((_, (_, liftdefl_ldef)), lthy) =
  10.191 -        Specification.definition (NONE, (liftdefl_bind, liftdefl_eqn)) lthy;
  10.192 -    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy);
  10.193 -    val emb_def = singleton (ProofContext.export lthy ctxt_thy) emb_ldef;
  10.194 -    val prj_def = singleton (ProofContext.export lthy ctxt_thy) prj_ldef;
  10.195 -    val defl_def = singleton (ProofContext.export lthy ctxt_thy) defl_ldef;
  10.196 -    val liftemb_def = singleton (ProofContext.export lthy ctxt_thy) liftemb_ldef;
  10.197 -    val liftprj_def = singleton (ProofContext.export lthy ctxt_thy) liftprj_ldef;
  10.198 -    val liftdefl_def = singleton (ProofContext.export lthy ctxt_thy) liftdefl_ldef;
  10.199 +        Specification.definition (NONE, (liftdefl_bind, liftdefl_eqn)) lthy
  10.200 +    val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy)
  10.201 +    val emb_def = singleton (ProofContext.export lthy ctxt_thy) emb_ldef
  10.202 +    val prj_def = singleton (ProofContext.export lthy ctxt_thy) prj_ldef
  10.203 +    val defl_def = singleton (ProofContext.export lthy ctxt_thy) defl_ldef
  10.204 +    val liftemb_def = singleton (ProofContext.export lthy ctxt_thy) liftemb_ldef
  10.205 +    val liftprj_def = singleton (ProofContext.export lthy ctxt_thy) liftprj_ldef
  10.206 +    val liftdefl_def = singleton (ProofContext.export lthy ctxt_thy) liftdefl_ldef
  10.207      val type_definition_thm =
  10.208        MetaSimplifier.rewrite_rule
  10.209          (the_list (#set_def (#2 info)))
  10.210 -        (#type_definition (#2 info));
  10.211 +        (#type_definition (#2 info))
  10.212      val typedef_thms =
  10.213        [type_definition_thm, #below_def cpo_info, emb_def, prj_def, defl_def,
  10.214 -      liftemb_def, liftprj_def, liftdefl_def];
  10.215 +      liftemb_def, liftprj_def, liftdefl_def]
  10.216      val thy = lthy
  10.217        |> Class.prove_instantiation_instance
  10.218            (K (Tactic.rtac (@{thm typedef_liftdomain_class} OF typedef_thms) 1))
  10.219 -      |> Local_Theory.exit_global;
  10.220 +      |> Local_Theory.exit_global
  10.221  
  10.222      (*other theorems*)
  10.223 -    val defl_thm' = Thm.transfer thy defl_def;
  10.224 +    val defl_thm' = Thm.transfer thy defl_def
  10.225      val (DEFL_thm, thy) = thy
  10.226        |> Sign.add_path (Binding.name_of name)
  10.227        |> Global_Theory.add_thm
  10.228           ((Binding.prefix_name "DEFL_" name,
  10.229            Drule.zero_var_indexes (@{thm typedef_DEFL} OF [defl_thm'])), [])
  10.230 -      ||> Sign.restore_naming thy;
  10.231 +      ||> Sign.restore_naming thy
  10.232  
  10.233      val rep_info =
  10.234        { emb_def = emb_def, prj_def = prj_def, defl_def = defl_def,
  10.235          liftemb_def = liftemb_def, liftprj_def = liftprj_def,
  10.236 -        liftdefl_def = liftdefl_def, DEFL = DEFL_thm };
  10.237 +        liftdefl_def = liftdefl_def, DEFL = DEFL_thm }
  10.238    in
  10.239      ((info, cpo_info, pcpo_info, rep_info), thy)
  10.240    end
  10.241    handle ERROR msg =>
  10.242 -    cat_error msg ("The error(s) above occurred in domaindef " ^ quote (Binding.str_of name));
  10.243 +    cat_error msg ("The error(s) above occurred in domaindef " ^ quote (Binding.str_of name))
  10.244  
  10.245  fun add_domaindef def opt_name typ defl opt_morphs thy =
  10.246    let
  10.247 -    val name = the_default (#1 typ) opt_name;
  10.248 +    val name = the_default (#1 typ) opt_name
  10.249    in
  10.250      gen_add_domaindef Syntax.check_term def name typ defl opt_morphs thy
  10.251 -  end;
  10.252 +  end
  10.253  
  10.254  fun domaindef_cmd ((def, name), (b, raw_args, mx), A, morphs) thy =
  10.255    let
  10.256 -    val ctxt = ProofContext.init_global thy;
  10.257 -    val args = map (apsnd (Typedecl.read_constraint ctxt)) raw_args;
  10.258 -  in snd (gen_add_domaindef Syntax.read_term def name (b, args, mx) A morphs thy) end;
  10.259 +    val ctxt = ProofContext.init_global thy
  10.260 +    val args = map (apsnd (Typedecl.read_constraint ctxt)) raw_args
  10.261 +  in snd (gen_add_domaindef Syntax.read_term def name (b, args, mx) A morphs thy) end
  10.262  
  10.263  
  10.264  (** outer syntax **)
  10.265 @@ -223,14 +223,14 @@
  10.266          --| Parse.$$$ ")") (true, NONE) --
  10.267      (Parse.type_args_constrained -- Parse.binding) --
  10.268      Parse.opt_mixfix -- (Parse.$$$ "=" |-- Parse.term) --
  10.269 -    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding));
  10.270 +    Scan.option (Parse.$$$ "morphisms" |-- Parse.!!! (Parse.binding -- Parse.binding))
  10.271  
  10.272  fun mk_domaindef ((((((def, opt_name), (args, t)), mx), A), morphs)) =
  10.273 -  domaindef_cmd ((def, the_default t opt_name), (t, args, mx), A, morphs);
  10.274 +  domaindef_cmd ((def, the_default t opt_name), (t, args, mx), A, morphs)
  10.275  
  10.276  val _ =
  10.277    Outer_Syntax.command "domaindef" "HOLCF definition of domains from deflations" Keyword.thy_decl
  10.278      (domaindef_decl >>
  10.279 -      (Toplevel.print oo (Toplevel.theory o mk_domaindef)));
  10.280 +      (Toplevel.print oo (Toplevel.theory o mk_domaindef)))
  10.281  
  10.282 -end;
  10.283 +end
    11.1 --- a/src/HOL/HOLCF/Tools/fixrec.ML	Tue Nov 30 14:01:49 2010 -0800
    11.2 +++ b/src/HOL/HOLCF/Tools/fixrec.ML	Tue Nov 30 14:21:57 2010 -0800
    11.3 @@ -13,23 +13,23 @@
    11.4    val add_matchers: (string * string) list -> theory -> theory
    11.5    val fixrec_simp_tac: Proof.context -> int -> tactic
    11.6    val setup: theory -> theory
    11.7 -end;
    11.8 +end
    11.9  
   11.10  structure Fixrec :> FIXREC =
   11.11  struct
   11.12  
   11.13 -open HOLCF_Library;
   11.14 +open HOLCF_Library
   11.15  
   11.16 -infixr 6 ->>;
   11.17 -infix -->>;
   11.18 -infix 9 `;
   11.19 +infixr 6 ->>
   11.20 +infix -->>
   11.21 +infix 9 `
   11.22  
   11.23 -val def_cont_fix_eq = @{thm def_cont_fix_eq};
   11.24 -val def_cont_fix_ind = @{thm def_cont_fix_ind};
   11.25 +val def_cont_fix_eq = @{thm def_cont_fix_eq}
   11.26 +val def_cont_fix_ind = @{thm def_cont_fix_ind}
   11.27  
   11.28 -fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
   11.29 +fun fixrec_err s = error ("fixrec definition error:\n" ^ s)
   11.30  fun fixrec_eq_err thy s eq =
   11.31 -  fixrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq));
   11.32 +  fixrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq))
   11.33  
   11.34  (*************************************************************************)
   11.35  (***************************** building types ****************************)
   11.36 @@ -39,19 +39,19 @@
   11.37  
   11.38  fun binder_cfun (Type(@{type_name cfun},[T, U])) = T :: binder_cfun U
   11.39    | binder_cfun (Type(@{type_name "fun"},[T, U])) = T :: binder_cfun U
   11.40 -  | binder_cfun _   =  [];
   11.41 +  | binder_cfun _   =  []
   11.42  
   11.43  fun body_cfun (Type(@{type_name cfun},[T, U])) = body_cfun U
   11.44    | body_cfun (Type(@{type_name "fun"},[T, U])) = body_cfun U
   11.45 -  | body_cfun T   =  T;
   11.46 +  | body_cfun T   =  T
   11.47  
   11.48  fun strip_cfun T : typ list * typ =
   11.49 -  (binder_cfun T, body_cfun T);
   11.50 +  (binder_cfun T, body_cfun T)
   11.51  
   11.52  in
   11.53  
   11.54  fun matcherT (T, U) =
   11.55 -  body_cfun T ->> (binder_cfun T -->> U) ->> U;
   11.56 +  body_cfun T ->> (binder_cfun T -->> U) ->> U
   11.57  
   11.58  end
   11.59  
   11.60 @@ -59,21 +59,21 @@
   11.61  (***************************** building terms ****************************)
   11.62  (*************************************************************************)
   11.63  
   11.64 -val mk_trp = HOLogic.mk_Trueprop;
   11.65 +val mk_trp = HOLogic.mk_Trueprop
   11.66  
   11.67  (* splits a cterm into the right and lefthand sides of equality *)
   11.68 -fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
   11.69 +fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t)
   11.70  
   11.71  (* similar to Thm.head_of, but for continuous application *)
   11.72  fun chead_of (Const(@{const_name Rep_cfun},_)$f$t) = chead_of f
   11.73 -  | chead_of u = u;
   11.74 +  | chead_of u = u
   11.75  
   11.76 -infix 0 ==;  val (op ==) = Logic.mk_equals;
   11.77 -infix 1 ===; val (op ===) = HOLogic.mk_eq;
   11.78 +infix 0 ==  val (op ==) = Logic.mk_equals
   11.79 +infix 1 === val (op ===) = HOLogic.mk_eq
   11.80  
   11.81  fun mk_mplus (t, u) =
   11.82    let val mT = Term.fastype_of t
   11.83 -  in Const(@{const_name Fixrec.mplus}, mT ->> mT ->> mT) ` t ` u end;
   11.84 +  in Const(@{const_name Fixrec.mplus}, mT ->> mT ->> mT) ` t ` u end
   11.85  
   11.86  fun mk_run t =
   11.87    let
   11.88 @@ -85,7 +85,7 @@
   11.89        Const(@{const_name Rep_cfun}, _) $
   11.90          Const(@{const_name Fixrec.succeed}, _) $ u => u
   11.91      | _ => run ` t
   11.92 -  end;
   11.93 +  end
   11.94  
   11.95  
   11.96  (*************************************************************************)
   11.97 @@ -94,26 +94,26 @@
   11.98  
   11.99  structure FixrecUnfoldData = Generic_Data
  11.100  (
  11.101 -  type T = thm Symtab.table;
  11.102 -  val empty = Symtab.empty;
  11.103 -  val extend = I;
  11.104 -  fun merge data : T = Symtab.merge (K true) data;
  11.105 -);
  11.106 +  type T = thm Symtab.table
  11.107 +  val empty = Symtab.empty
  11.108 +  val extend = I
  11.109 +  fun merge data : T = Symtab.merge (K true) data
  11.110 +)
  11.111  
  11.112  local
  11.113  
  11.114  fun name_of (Const (n, T)) = n
  11.115    | name_of (Free (n, T)) = n
  11.116 -  | name_of t = raise TERM ("Fixrec.add_unfold: lhs not a constant", [t]);
  11.117 +  | name_of t = raise TERM ("Fixrec.add_unfold: lhs not a constant", [t])
  11.118  
  11.119  val lhs_name =
  11.120 -  name_of o head_of o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of;
  11.121 +  name_of o head_of o fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of
  11.122  
  11.123  in
  11.124  
  11.125  val add_unfold : attribute =
  11.126    Thm.declaration_attribute
  11.127 -    (fn th => FixrecUnfoldData.map (Symtab.insert (K true) (lhs_name th, th)));
  11.128 +    (fn th => FixrecUnfoldData.map (Symtab.insert (K true) (lhs_name th, th)))
  11.129  
  11.130  end
  11.131  
  11.132 @@ -122,73 +122,73 @@
  11.133    (spec : (Attrib.binding * term) list)
  11.134    (lthy : local_theory) =
  11.135    let
  11.136 -    val thy = ProofContext.theory_of lthy;
  11.137 -    val names = map (Binding.name_of o fst o fst) fixes;
  11.138 -    val all_names = space_implode "_" names;
  11.139 -    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
  11.140 -    val functional = lambda_tuple lhss (mk_tuple rhss);
  11.141 -    val fixpoint = mk_fix (mk_cabs functional);
  11.142 +    val thy = ProofContext.theory_of lthy
  11.143 +    val names = map (Binding.name_of o fst o fst) fixes
  11.144 +    val all_names = space_implode "_" names
  11.145 +    val (lhss, rhss) = ListPair.unzip (map (dest_eqs o snd) spec)
  11.146 +    val functional = lambda_tuple lhss (mk_tuple rhss)
  11.147 +    val fixpoint = mk_fix (mk_cabs functional)
  11.148  
  11.149      val cont_thm =
  11.150        let
  11.151 -        val prop = mk_trp (mk_cont functional);
  11.152 +        val prop = mk_trp (mk_cont functional)
  11.153          fun err _ = error (
  11.154 -          "Continuity proof failed; please check that cont2cont rules\n" ^
  11.155 +          "Continuity proof failed please check that cont2cont rules\n" ^
  11.156            "or simp rules are configured for all non-HOLCF constants.\n" ^
  11.157            "The error occurred for the goal statement:\n" ^
  11.158 -          Syntax.string_of_term lthy prop);
  11.159 -        val rules = Cont2ContData.get lthy;
  11.160 -        val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules));
  11.161 -        val slow_tac = SOLVED' (simp_tac (simpset_of lthy));
  11.162 -        val tac = fast_tac 1 ORELSE slow_tac 1 ORELSE err;
  11.163 +          Syntax.string_of_term lthy prop)
  11.164 +        val rules = Cont2ContData.get lthy
  11.165 +        val fast_tac = SOLVED' (REPEAT_ALL_NEW (match_tac rules))
  11.166 +        val slow_tac = SOLVED' (simp_tac (simpset_of lthy))
  11.167 +        val tac = fast_tac 1 ORELSE slow_tac 1 ORELSE err
  11.168        in
  11.169          Goal.prove lthy [] [] prop (K tac)
  11.170 -      end;
  11.171 +      end
  11.172  
  11.173      fun one_def (l as Free(n,_)) r =
  11.174            let val b = Long_Name.base_name n
  11.175            in ((Binding.name (b^"_def"), []), r) end
  11.176 -      | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
  11.177 +      | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form"
  11.178      fun defs [] _ = []
  11.179        | defs (l::[]) r = [one_def l r]
  11.180 -      | defs (l::ls) r = one_def l (mk_fst r) :: defs ls (mk_snd r);
  11.181 -    val fixdefs = defs lhss fixpoint;
  11.182 +      | defs (l::ls) r = one_def l (mk_fst r) :: defs ls (mk_snd r)
  11.183 +    val fixdefs = defs lhss fixpoint
  11.184      val (fixdef_thms : (term * (string * thm)) list, lthy) = lthy
  11.185 -      |> fold_map Local_Theory.define (map (apfst fst) fixes ~~ fixdefs);
  11.186 -    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
  11.187 -    val tuple_fixdef_thm = foldr1 pair_equalI (map (snd o snd) fixdef_thms);
  11.188 -    val P = Var (("P", 0), map Term.fastype_of lhss ---> HOLogic.boolT);
  11.189 -    val predicate = lambda_tuple lhss (list_comb (P, lhss));
  11.190 +      |> fold_map Local_Theory.define (map (apfst fst) fixes ~~ fixdefs)
  11.191 +    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2]
  11.192 +    val tuple_fixdef_thm = foldr1 pair_equalI (map (snd o snd) fixdef_thms)
  11.193 +    val P = Var (("P", 0), map Term.fastype_of lhss ---> HOLogic.boolT)
  11.194 +    val predicate = lambda_tuple lhss (list_comb (P, lhss))
  11.195      val tuple_induct_thm = (def_cont_fix_ind OF [tuple_fixdef_thm, cont_thm])
  11.196        |> Drule.instantiate' [] [SOME (Thm.cterm_of thy predicate)]
  11.197 -      |> Local_Defs.unfold lthy @{thms split_paired_all split_conv split_strict};
  11.198 +      |> Local_Defs.unfold lthy @{thms split_paired_all split_conv split_strict}
  11.199      val tuple_unfold_thm = (def_cont_fix_eq OF [tuple_fixdef_thm, cont_thm])
  11.200 -      |> Local_Defs.unfold lthy @{thms split_conv};
  11.201 +      |> Local_Defs.unfold lthy @{thms split_conv}
  11.202      fun unfolds [] thm = []
  11.203        | unfolds (n::[]) thm = [(n, thm)]
  11.204        | unfolds (n::ns) thm = let
  11.205 -          val thmL = thm RS @{thm Pair_eqD1};
  11.206 -          val thmR = thm RS @{thm Pair_eqD2};
  11.207 -        in (n, thmL) :: unfolds ns thmR end;
  11.208 -    val unfold_thms = unfolds names tuple_unfold_thm;
  11.209 +          val thmL = thm RS @{thm Pair_eqD1}
  11.210 +          val thmR = thm RS @{thm Pair_eqD2}
  11.211 +        in (n, thmL) :: unfolds ns thmR end
  11.212 +    val unfold_thms = unfolds names tuple_unfold_thm
  11.213      val induct_note : Attrib.binding * Thm.thm list =
  11.214        let
  11.215 -        val thm_name = Binding.qualify true all_names (Binding.name "induct");
  11.216 +        val thm_name = Binding.qualify true all_names (Binding.name "induct")
  11.217        in
  11.218          ((thm_name, []), [tuple_induct_thm])
  11.219 -      end;
  11.220 +      end
  11.221      fun unfold_note (name, thm) : Attrib.binding * Thm.thm list =
  11.222        let
  11.223 -        val thm_name = Binding.qualify true name (Binding.name "unfold");
  11.224 -        val src = Attrib.internal (K add_unfold);
  11.225 +        val thm_name = Binding.qualify true name (Binding.name "unfold")
  11.226 +        val src = Attrib.internal (K add_unfold)
  11.227        in
  11.228          ((thm_name, [src]), [thm])
  11.229 -      end;
  11.230 +      end
  11.231      val (thmss, lthy) = lthy
  11.232 -      |> fold_map Local_Theory.note (induct_note :: map unfold_note unfold_thms);
  11.233 +      |> fold_map Local_Theory.note (induct_note :: map unfold_note unfold_thms)
  11.234    in
  11.235      (lthy, names, fixdef_thms, map snd unfold_thms)
  11.236 -  end;
  11.237 +  end
  11.238  
  11.239  (*************************************************************************)
  11.240  (*********** monadic notation and pattern matching compilation ***********)
  11.241 @@ -196,14 +196,14 @@
  11.242  
  11.243  structure FixrecMatchData = Theory_Data
  11.244  (
  11.245 -  type T = string Symtab.table;
  11.246 -  val empty = Symtab.empty;
  11.247 -  val extend = I;
  11.248 -  fun merge data = Symtab.merge (K true) data;
  11.249 -);
  11.250 +  type T = string Symtab.table
  11.251 +  val empty = Symtab.empty
  11.252 +  val extend = I
  11.253 +  fun merge data = Symtab.merge (K true) data
  11.254 +)
  11.255  
  11.256  (* associate match functions with pattern constants *)
  11.257 -fun add_matchers ms = FixrecMatchData.map (fold Symtab.update ms);
  11.258 +fun add_matchers ms = FixrecMatchData.map (fold Symtab.update ms)
  11.259  
  11.260  fun taken_names (t : term) : bstring list =
  11.261    let
  11.262 @@ -211,10 +211,10 @@
  11.263        | taken (Free(a,_) , bs) = insert (op =) a bs
  11.264        | taken (f $ u     , bs) = taken (f, taken (u, bs))
  11.265        | taken (Abs(a,_,t), bs) = taken (t, insert (op =) a bs)
  11.266 -      | taken (_         , bs) = bs;
  11.267 +      | taken (_         , bs) = bs
  11.268    in
  11.269      taken (t, [])
  11.270 -  end;
  11.271 +  end
  11.272  
  11.273  (* builds a monadic term for matching a pattern *)
  11.274  (* returns (rhs, free variable, used varnames) *)
  11.275 @@ -244,87 +244,87 @@
  11.276        | _ => raise TERM ("fixrec: invalid pattern ", [p])
  11.277    in
  11.278      comp_pat pat rhs taken
  11.279 -  end;
  11.280 +  end
  11.281  
  11.282  (* builds a monadic term for matching a function definition pattern *)
  11.283  (* returns (constant, (vars, matcher)) *)
  11.284  fun compile_lhs match_name pat rhs vs taken =
  11.285    case pat of
  11.286      Const(@{const_name Rep_cfun}, _) $ f $ x =>
  11.287 -      let val (rhs', v, taken') = compile_pat match_name x rhs taken;
  11.288 +      let val (rhs', v, taken') = compile_pat match_name x rhs taken
  11.289        in compile_lhs match_name f rhs' (v::vs) taken' end
  11.290    | Free(_,_) => (pat, (vs, rhs))
  11.291    | Const(_,_) => (pat, (vs, rhs))
  11.292    | _ => fixrec_err ("invalid function pattern: "
  11.293 -                    ^ ML_Syntax.print_term pat);
  11.294 +                    ^ ML_Syntax.print_term pat)
  11.295  
  11.296  fun strip_alls t =
  11.297 -  if Logic.is_all t then strip_alls (snd (Logic.dest_all t)) else t;
  11.298 +  if Logic.is_all t then strip_alls (snd (Logic.dest_all t)) else t
  11.299  
  11.300  fun compile_eq match_name eq =
  11.301    let
  11.302 -    val (lhs,rhs) = dest_eqs (Logic.strip_imp_concl (strip_alls eq));
  11.303 +    val (lhs,rhs) = dest_eqs (Logic.strip_imp_concl (strip_alls eq))
  11.304    in
  11.305      compile_lhs match_name lhs (mk_succeed rhs) [] (taken_names eq)
  11.306 -  end;
  11.307 +  end
  11.308  
  11.309  (* this is the pattern-matching compiler function *)
  11.310  fun compile_eqs match_name eqs =
  11.311    let
  11.312      val (consts, matchers) =
  11.313 -      ListPair.unzip (map (compile_eq match_name) eqs);
  11.314 +      ListPair.unzip (map (compile_eq match_name) eqs)
  11.315      val const =
  11.316          case distinct (op =) consts of
  11.317            [n] => n
  11.318 -        | _ => fixrec_err "all equations in block must define the same function";
  11.319 +        | _ => fixrec_err "all equations in block must define the same function"
  11.320      val vars =
  11.321          case distinct (op = o pairself length) (map fst matchers) of
  11.322            [vars] => vars
  11.323 -        | _ => fixrec_err "all equations in block must have the same arity";
  11.324 +        | _ => fixrec_err "all equations in block must have the same arity"
  11.325      (* rename so all matchers use same free variables *)
  11.326 -    fun rename (vs, t) = Term.subst_free (filter_out (op =) (vs ~~ vars)) t;
  11.327 -    val rhs = big_lambdas vars (mk_run (foldr1 mk_mplus (map rename matchers)));
  11.328 +    fun rename (vs, t) = Term.subst_free (filter_out (op =) (vs ~~ vars)) t
  11.329 +    val rhs = big_lambdas vars (mk_run (foldr1 mk_mplus (map rename matchers)))
  11.330    in
  11.331      mk_trp (const === rhs)
  11.332 -  end;
  11.333 +  end
  11.334  
  11.335  (*************************************************************************)
  11.336  (********************** Proving associated theorems **********************)
  11.337  (*************************************************************************)
  11.338  
  11.339 -fun eta_tac i = CONVERSION Thm.eta_conversion i;
  11.340 +fun eta_tac i = CONVERSION Thm.eta_conversion i
  11.341  
  11.342  fun fixrec_simp_tac ctxt =
  11.343    let
  11.344 -    val tab = FixrecUnfoldData.get (Context.Proof ctxt);
  11.345 -    val ss = Simplifier.simpset_of ctxt;
  11.346 +    val tab = FixrecUnfoldData.get (Context.Proof ctxt)
  11.347 +    val ss = Simplifier.simpset_of ctxt
  11.348      fun concl t =
  11.349        if Logic.is_all t then concl (snd (Logic.dest_all t))
  11.350 -      else HOLogic.dest_Trueprop (Logic.strip_imp_concl t);
  11.351 +      else HOLogic.dest_Trueprop (Logic.strip_imp_concl t)
  11.352      fun tac (t, i) =
  11.353        let
  11.354          val (c, T) =
  11.355 -            (dest_Const o head_of o chead_of o fst o HOLogic.dest_eq o concl) t;
  11.356 -        val unfold_thm = the (Symtab.lookup tab c);
  11.357 -        val rule = unfold_thm RS @{thm ssubst_lhs};
  11.358 +            (dest_Const o head_of o chead_of o fst o HOLogic.dest_eq o concl) t
  11.359 +        val unfold_thm = the (Symtab.lookup tab c)
  11.360 +        val rule = unfold_thm RS @{thm ssubst_lhs}
  11.361        in
  11.362          CHANGED (rtac rule i THEN eta_tac i THEN asm_simp_tac ss i)
  11.363        end
  11.364    in
  11.365      SUBGOAL (fn ti => the_default no_tac (try tac ti))
  11.366 -  end;
  11.367 +  end
  11.368  
  11.369  (* proves a block of pattern matching equations as theorems, using unfold *)
  11.370  fun make_simps ctxt (unfold_thm, eqns : (Attrib.binding * term) list) =
  11.371    let
  11.372 -    val ss = Simplifier.simpset_of ctxt;
  11.373 -    val rule = unfold_thm RS @{thm ssubst_lhs};
  11.374 -    val tac = rtac rule 1 THEN eta_tac 1 THEN asm_simp_tac ss 1;
  11.375 -    fun prove_term t = Goal.prove ctxt [] [] t (K tac);
  11.376 -    fun prove_eqn (bind, eqn_t) = (bind, prove_term eqn_t);
  11.377 +    val ss = Simplifier.simpset_of ctxt
  11.378 +    val rule = unfold_thm RS @{thm ssubst_lhs}
  11.379 +    val tac = rtac rule 1 THEN eta_tac 1 THEN asm_simp_tac ss 1
  11.380 +    fun prove_term t = Goal.prove ctxt [] [] t (K tac)
  11.381 +    fun prove_eqn (bind, eqn_t) = (bind, prove_term eqn_t)
  11.382    in
  11.383      map prove_eqn eqns
  11.384 -  end;
  11.385 +  end
  11.386  
  11.387  (*************************************************************************)
  11.388  (************************* Main fixrec function **************************)
  11.389 @@ -339,54 +339,54 @@
  11.390    (raw_spec' : (bool * (Attrib.binding * 'b)) list)
  11.391    (lthy : local_theory) =
  11.392    let
  11.393 -    val (skips, raw_spec) = ListPair.unzip raw_spec';
  11.394 +    val (skips, raw_spec) = ListPair.unzip raw_spec'
  11.395      val (fixes : ((binding * typ) * mixfix) list,
  11.396           spec : (Attrib.binding * term) list) =
  11.397 -          fst (prep_spec raw_fixes raw_spec lthy);
  11.398 +          fst (prep_spec raw_fixes raw_spec lthy)
  11.399      val chead_of_spec =
  11.400 -      chead_of o fst o dest_eqs o Logic.strip_imp_concl o strip_alls o snd;
  11.401 +      chead_of o fst o dest_eqs o Logic.strip_imp_concl o strip_alls o snd
  11.402      fun name_of (Free (n, _)) = n
  11.403 -      | name_of t = fixrec_err ("unknown term");
  11.404 -    val all_names = map (name_of o chead_of_spec) spec;
  11.405 -    val names = distinct (op =) all_names;
  11.406 +      | name_of t = fixrec_err ("unknown term")
  11.407 +    val all_names = map (name_of o chead_of_spec) spec
  11.408 +    val names = distinct (op =) all_names
  11.409      fun block_of_name n =
  11.410        map_filter
  11.411          (fn (m,eq) => if m = n then SOME eq else NONE)
  11.412 -        (all_names ~~ (spec ~~ skips));
  11.413 -    val blocks = map block_of_name names;
  11.414 +        (all_names ~~ (spec ~~ skips))
  11.415 +    val blocks = map block_of_name names
  11.416  
  11.417 -    val matcher_tab = FixrecMatchData.get (ProofContext.theory_of lthy);
  11.418 +    val matcher_tab = FixrecMatchData.get (ProofContext.theory_of lthy)
  11.419      fun match_name c =
  11.420        case Symtab.lookup matcher_tab c of SOME m => m
  11.421 -        | NONE => fixrec_err ("unknown pattern constructor: " ^ c);
  11.422 +        | NONE => fixrec_err ("unknown pattern constructor: " ^ c)
  11.423  
  11.424 -    val matches = map (compile_eqs match_name) (map (map (snd o fst)) blocks);
  11.425 -    val spec' = map (pair Attrib.empty_binding) matches;
  11.426 +    val matches = map (compile_eqs match_name) (map (map (snd o fst)) blocks)
  11.427 +    val spec' = map (pair Attrib.empty_binding) matches
  11.428      val (lthy, cnames, fixdef_thms, unfold_thms) =
  11.429 -      add_fixdefs fixes spec' lthy;
  11.430 +      add_fixdefs fixes spec' lthy
  11.431  
  11.432 -    val blocks' = map (map fst o filter_out snd) blocks;
  11.433 +    val blocks' = map (map fst o filter_out snd) blocks
  11.434      val simps : (Attrib.binding * thm) list list =
  11.435 -      map (make_simps lthy) (unfold_thms ~~ blocks');
  11.436 +      map (make_simps lthy) (unfold_thms ~~ blocks')
  11.437      fun mk_bind n : Attrib.binding =
  11.438       (Binding.qualify true n (Binding.name "simps"),
  11.439 -       [Attrib.internal (K Simplifier.simp_add)]);
  11.440 +       [Attrib.internal (K Simplifier.simp_add)])
  11.441      val simps1 : (Attrib.binding * thm list) list =
  11.442 -      map (fn (n,xs) => (mk_bind n, map snd xs)) (names ~~ simps);
  11.443 +      map (fn (n,xs) => (mk_bind n, map snd xs)) (names ~~ simps)
  11.444      val simps2 : (Attrib.binding * thm list) list =
  11.445 -      map (apsnd (fn thm => [thm])) (flat simps);
  11.446 +      map (apsnd (fn thm => [thm])) (flat simps)
  11.447      val (_, lthy) = lthy
  11.448 -      |> fold_map Local_Theory.note (simps1 @ simps2);
  11.449 +      |> fold_map Local_Theory.note (simps1 @ simps2)
  11.450    in
  11.451      lthy
  11.452 -  end;
  11.453 +  end
  11.454  
  11.455  in
  11.456  
  11.457 -val add_fixrec = gen_fixrec Specification.check_spec;
  11.458 -val add_fixrec_cmd = gen_fixrec Specification.read_spec;
  11.459 +val add_fixrec = gen_fixrec Specification.check_spec
  11.460 +val add_fixrec_cmd = gen_fixrec Specification.read_spec
  11.461  
  11.462 -end; (* local *)
  11.463 +end (* local *)
  11.464  
  11.465  
  11.466  (*************************************************************************)
  11.467 @@ -395,23 +395,23 @@
  11.468  
  11.469  val opt_thm_name' : (bool * Attrib.binding) parser =
  11.470    Parse.$$$ "(" -- Parse.$$$ "unchecked" -- Parse.$$$ ")" >> K (true, Attrib.empty_binding)
  11.471 -    || Parse_Spec.opt_thm_name ":" >> pair false;
  11.472 +    || Parse_Spec.opt_thm_name ":" >> pair false
  11.473  
  11.474  val spec' : (bool * (Attrib.binding * string)) parser =
  11.475 -  opt_thm_name' -- Parse.prop >> (fn ((a, b), c) => (a, (b, c)));
  11.476 +  opt_thm_name' -- Parse.prop >> (fn ((a, b), c) => (a, (b, c)))
  11.477  
  11.478  val alt_specs' : (bool * (Attrib.binding * string)) list parser =
  11.479 -  let val unexpected = Scan.ahead (Parse.name || Parse.$$$ "[" || Parse.$$$ "(");
  11.480 -  in Parse.enum1 "|" (spec' --| Scan.option (unexpected -- Parse.!!! (Parse.$$$ "|"))) end;
  11.481 +  let val unexpected = Scan.ahead (Parse.name || Parse.$$$ "[" || Parse.$$$ "(")
  11.482 +  in Parse.enum1 "|" (spec' --| Scan.option (unexpected -- Parse.!!! (Parse.$$$ "|"))) end
  11.483  
  11.484  val _ =
  11.485    Outer_Syntax.local_theory "fixrec" "define recursive functions (HOLCF)" Keyword.thy_decl
  11.486      (Parse.fixes -- (Parse.where_ |-- Parse.!!! alt_specs')
  11.487 -      >> (fn (fixes, specs) => add_fixrec_cmd fixes specs));
  11.488 +      >> (fn (fixes, specs) => add_fixrec_cmd fixes specs))
  11.489  
  11.490  val setup =
  11.491    Method.setup @{binding fixrec_simp}
  11.492      (Scan.succeed (SIMPLE_METHOD' o fixrec_simp_tac))
  11.493 -    "pattern prover for fixrec constants";
  11.494 +    "pattern prover for fixrec constants"
  11.495  
  11.496 -end;
  11.497 +end
    12.1 --- a/src/HOL/HOLCF/Tools/holcf_library.ML	Tue Nov 30 14:01:49 2010 -0800
    12.2 +++ b/src/HOL/HOLCF/Tools/holcf_library.ML	Tue Nov 30 14:21:57 2010 -0800
    12.3 @@ -7,79 +7,79 @@
    12.4  structure HOLCF_Library =
    12.5  struct
    12.6  
    12.7 -infixr 6 ->>;
    12.8 -infixr -->>;
    12.9 -infix 9 `;
   12.10 +infixr 6 ->>
   12.11 +infixr -->>
   12.12 +infix 9 `
   12.13  
   12.14  (*** Operations from Isabelle/HOL ***)
   12.15  
   12.16 -val boolT = HOLogic.boolT;
   12.17 -val natT = HOLogic.natT;
   12.18 +val boolT = HOLogic.boolT
   12.19 +val natT = HOLogic.natT
   12.20  
   12.21 -val mk_equals = Logic.mk_equals;
   12.22 -val mk_eq = HOLogic.mk_eq;
   12.23 -val mk_trp = HOLogic.mk_Trueprop;
   12.24 -val mk_fst = HOLogic.mk_fst;
   12.25 -val mk_snd = HOLogic.mk_snd;
   12.26 -val mk_not = HOLogic.mk_not;
   12.27 -val mk_conj = HOLogic.mk_conj;
   12.28 -val mk_disj = HOLogic.mk_disj;
   12.29 -val mk_imp = HOLogic.mk_imp;
   12.30 +val mk_equals = Logic.mk_equals
   12.31 +val mk_eq = HOLogic.mk_eq
   12.32 +val mk_trp = HOLogic.mk_Trueprop
   12.33 +val mk_fst = HOLogic.mk_fst
   12.34 +val mk_snd = HOLogic.mk_snd
   12.35 +val mk_not = HOLogic.mk_not
   12.36 +val mk_conj = HOLogic.mk_conj
   12.37 +val mk_disj = HOLogic.mk_disj
   12.38 +val mk_imp = HOLogic.mk_imp
   12.39  
   12.40 -fun mk_ex (x, t) = HOLogic.exists_const (fastype_of x) $ Term.lambda x t;
   12.41 -fun mk_all (x, t) = HOLogic.all_const (fastype_of x) $ Term.lambda x t;
   12.42 +fun mk_ex (x, t) = HOLogic.exists_const (fastype_of x) $ Term.lambda x t
   12.43 +fun mk_all (x, t) = HOLogic.all_const (fastype_of x) $ Term.lambda x t
   12.44  
   12.45  
   12.46  (*** Basic HOLCF concepts ***)
   12.47  
   12.48 -fun mk_bottom T = Const (@{const_name UU}, T);
   12.49 +fun mk_bottom T = Const (@{const_name UU}, T)
   12.50  
   12.51 -fun below_const T = Const (@{const_name below}, [T, T] ---> boolT);
   12.52 -fun mk_below (t, u) = below_const (fastype_of t) $ t $ u;
   12.53 +fun below_const T = Const (@{const_name below}, [T, T] ---> boolT)
   12.54 +fun mk_below (t, u) = below_const (fastype_of t) $ t $ u
   12.55  
   12.56 -fun mk_undef t = mk_eq (t, mk_bottom (fastype_of t));
   12.57 +fun mk_undef t = mk_eq (t, mk_bottom (fastype_of t))
   12.58  
   12.59 -fun mk_defined t = mk_not (mk_undef t);
   12.60 +fun mk_defined t = mk_not (mk_undef t)
   12.61  
   12.62  fun mk_adm t =
   12.63 -  Const (@{const_name adm}, fastype_of t --> boolT) $ t;
   12.64 +  Const (@{const_name adm}, fastype_of t --> boolT) $ t
   12.65  
   12.66  fun mk_compact t =
   12.67 -  Const (@{const_name compact}, fastype_of t --> boolT) $ t;
   12.68 +  Const (@{const_name compact}, fastype_of t --> boolT) $ t
   12.69  
   12.70  fun mk_cont t =
   12.71 -  Const (@{const_name cont}, fastype_of t --> boolT) $ t;
   12.72 +  Const (@{const_name cont}, fastype_of t --> boolT) $ t
   12.73  
   12.74  fun mk_chain t =
   12.75 -  Const (@{const_name chain}, Term.fastype_of t --> boolT) $ t;
   12.76 +  Const (@{const_name chain}, Term.fastype_of t --> boolT) $ t
   12.77  
   12.78  fun mk_lub t =
   12.79    let
   12.80 -    val T = Term.range_type (Term.fastype_of t);
   12.81 -    val lub_const = Const (@{const_name lub}, (T --> boolT) --> T);
   12.82 -    val UNIV_const = @{term "UNIV :: nat set"};
   12.83 -    val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT;
   12.84 -    val image_const = Const (@{const_name image}, image_type);
   12.85 +    val T = Term.range_type (Term.fastype_of t)
   12.86 +    val lub_const = Const (@{const_name lub}, (T --> boolT) --> T)
   12.87 +    val UNIV_const = @{term "UNIV :: nat set"}
   12.88 +    val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT
   12.89 +    val image_const = Const (@{const_name image}, image_type)
   12.90    in
   12.91      lub_const $ (image_const $ t $ UNIV_const)
   12.92 -  end;
   12.93 +  end
   12.94  
   12.95  
   12.96  (*** Continuous function space ***)
   12.97  
   12.98 -fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U]);
   12.99 +fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U])
  12.100  
  12.101 -val (op ->>) = mk_cfunT;
  12.102 -val (op -->>) = Library.foldr mk_cfunT;
  12.103 +val (op ->>) = mk_cfunT
  12.104 +val (op -->>) = Library.foldr mk_cfunT
  12.105  
  12.106  fun dest_cfunT (Type(@{type_name cfun}, [T, U])) = (T, U)
  12.107 -  | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
  12.108 +  | dest_cfunT T = raise TYPE ("dest_cfunT", [T], [])
  12.109  
  12.110  fun capply_const (S, T) =
  12.111 -  Const(@{const_name Rep_cfun}, (S ->> T) --> (S --> T));
  12.112 +  Const(@{const_name Rep_cfun}, (S ->> T) --> (S --> T))
  12.113  
  12.114  fun cabs_const (S, T) =
  12.115 -  Const(@{const_name Abs_cfun}, (S --> T) --> (S ->> T));
  12.116 +  Const(@{const_name Abs_cfun}, (S --> T) --> (S ->> T))
  12.117  
  12.118  fun mk_cabs t =
  12.119    let val T = fastype_of t
  12.120 @@ -87,48 +87,48 @@
  12.121  
  12.122  (* builds the expression (% v1 v2 .. vn. rhs) *)
  12.123  fun lambdas [] rhs = rhs
  12.124 -  | lambdas (v::vs) rhs = Term.lambda v (lambdas vs rhs);
  12.125 +  | lambdas (v::vs) rhs = Term.lambda v (lambdas vs rhs)
  12.126  
  12.127  (* builds the expression (LAM v. rhs) *)
  12.128  fun big_lambda v rhs =
  12.129 -  cabs_const (fastype_of v, fastype_of rhs) $ Term.lambda v rhs;
  12.130 +  cabs_const (fastype_of v, fastype_of rhs) $ Term.lambda v rhs
  12.131  
  12.132  (* builds the expression (LAM v1 v2 .. vn. rhs) *)
  12.133  fun big_lambdas [] rhs = rhs
  12.134 -  | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
  12.135 +  | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs)
  12.136  
  12.137  fun mk_capply (t, u) =
  12.138    let val (S, T) =
  12.139      case fastype_of t of
  12.140          Type(@{type_name cfun}, [S, T]) => (S, T)
  12.141 -      | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
  12.142 -  in capply_const (S, T) $ t $ u end;
  12.143 +      | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u])
  12.144 +  in capply_const (S, T) $ t $ u end
  12.145  
  12.146 -val (op `) = mk_capply;
  12.147 +val (op `) = mk_capply
  12.148  
  12.149 -val list_ccomb : term * term list -> term = Library.foldl mk_capply;
  12.150 +val list_ccomb : term * term list -> term = Library.foldl mk_capply
  12.151  
  12.152 -fun mk_ID T = Const (@{const_name ID}, T ->> T);
  12.153 +fun mk_ID T = Const (@{const_name ID}, T ->> T)
  12.154  
  12.155  fun cfcomp_const (T, U, V) =
  12.156 -  Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V));
  12.157 +  Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V))
  12.158  
  12.159  fun mk_cfcomp (f, g) =
  12.160    let
  12.161 -    val (U, V) = dest_cfunT (fastype_of f);
  12.162 -    val (T, U') = dest_cfunT (fastype_of g);
  12.163 +    val (U, V) = dest_cfunT (fastype_of f)
  12.164 +    val (T, U') = dest_cfunT (fastype_of g)
  12.165    in
  12.166      if U = U'
  12.167      then mk_capply (mk_capply (cfcomp_const (T, U, V), f), g)
  12.168      else raise TYPE ("mk_cfcomp", [U, U'], [f, g])
  12.169 -  end;
  12.170 +  end
  12.171  
  12.172 -fun strictify_const T = Const (@{const_name strictify}, T ->> T);
  12.173 -fun mk_strictify t = strictify_const (fastype_of t) ` t;
  12.174 +fun strictify_const T = Const (@{const_name strictify}, T ->> T)
  12.175 +fun mk_strictify t = strictify_const (fastype_of t) ` t
  12.176  
  12.177  fun mk_strict t =
  12.178 -  let val (T, U) = dest_cfunT (fastype_of t);
  12.179 -  in mk_eq (t ` mk_bottom T, mk_bottom U) end;
  12.180 +  let val (T, U) = dest_cfunT (fastype_of t)
  12.181 +  in mk_eq (t ` mk_bottom T, mk_bottom U) end
  12.182  
  12.183  
  12.184  (*** Product type ***)
  12.185 @@ -137,153 +137,153 @@
  12.186  
  12.187  fun mk_tupleT [] = HOLogic.unitT
  12.188    | mk_tupleT [T] = T
  12.189 -  | mk_tupleT (T :: Ts) = mk_prodT (T, mk_tupleT Ts);
  12.190 +  | mk_tupleT (T :: Ts) = mk_prodT (T, mk_tupleT Ts)
  12.191  
  12.192  (* builds the expression (v1,v2,..,vn) *)
  12.193  fun mk_tuple [] = HOLogic.unit
  12.194    | mk_tuple (t::[]) = t
  12.195 -  | mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
  12.196 +  | mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts)
  12.197  
  12.198  (* builds the expression (%(v1,v2,..,vn). rhs) *)
  12.199  fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
  12.200    | lambda_tuple (v::[]) rhs = Term.lambda v rhs
  12.201    | lambda_tuple (v::vs) rhs =
  12.202 -      HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
  12.203 +      HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs))
  12.204  
  12.205  
  12.206  (*** Lifted cpo type ***)
  12.207  
  12.208 -fun mk_upT T = Type(@{type_name "u"}, [T]);
  12.209 +fun mk_upT T = Type(@{type_name "u"}, [T])
  12.210  
  12.211  fun dest_upT (Type(@{type_name "u"}, [T])) = T
  12.212 -  | dest_upT T = raise TYPE ("dest_upT", [T], []);
  12.213 +  | dest_upT T = raise TYPE ("dest_upT", [T], [])
  12.214  
  12.215 -fun up_const T = Const(@{const_name up}, T ->> mk_upT T);
  12.216 +fun up_const T = Const(@{const_name up}, T ->> mk_upT T)
  12.217  
  12.218 -fun mk_up t = up_const (fastype_of t) ` t;
  12.219 +fun mk_up t = up_const (fastype_of t) ` t
  12.220  
  12.221  fun fup_const (T, U) =
  12.222 -  Const(@{const_name fup}, (T ->> U) ->> mk_upT T ->> U);
  12.223 +  Const(@{const_name fup}, (T ->> U) ->> mk_upT T ->> U)
  12.224  
  12.225 -fun mk_fup t = fup_const (dest_cfunT (fastype_of t)) ` t;
  12.226 +fun mk_fup t = fup_const (dest_cfunT (fastype_of t)) ` t
  12.227  
  12.228 -fun from_up T = fup_const (T, T) ` mk_ID T;
  12.229 +fun from_up T = fup_const (T, T) ` mk_ID T
  12.230  
  12.231  
  12.232  (*** Lifted unit type ***)
  12.233  
  12.234 -val oneT = @{typ "one"};
  12.235 +val oneT = @{typ "one"}
  12.236  
  12.237 -fun one_case_const T = Const (@{const_name one_case}, T ->> oneT ->> T);
  12.238 -fun mk_one_case t = one_case_const (fastype_of t) ` t;
  12.239 +fun one_case_const T = Const (@{const_name one_case}, T ->> oneT ->> T)
  12.240 +fun mk_one_case t = one_case_const (fastype_of t) ` t
  12.241  
  12.242  
  12.243  (*** Strict product type ***)
  12.244  
  12.245 -fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U]);
  12.246 +fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U])
  12.247  
  12.248  fun dest_sprodT (Type(@{type_name sprod}, [T, U])) = (T, U)
  12.249 -  | dest_sprodT T = raise TYPE ("dest_sprodT", [T], []);
  12.250 +  | dest_sprodT T = raise TYPE ("dest_sprodT", [T], [])
  12.251  
  12.252  fun spair_const (T, U) =
  12.253 -  Const(@{const_name spair}, T ->> U ->> mk_sprodT (T, U));
  12.254 +  Const(@{const_name spair}, T ->> U ->> mk_sprodT (T, U))
  12.255  
  12.256  (* builds the expression (:t, u:) *)
  12.257  fun mk_spair (t, u) =
  12.258 -  spair_const (fastype_of t, fastype_of u) ` t ` u;
  12.259 +  spair_const (fastype_of t, fastype_of u) ` t ` u
  12.260  
  12.261  (* builds the expression (:t1,t2,..,tn:) *)
  12.262  fun mk_stuple [] = @{term "ONE"}
  12.263    | mk_stuple (t::[]) = t
  12.264 -  | mk_stuple (t::ts) = mk_spair (t, mk_stuple ts);
  12.265 +  | mk_stuple (t::ts) = mk_spair (t, mk_stuple ts)
  12.266  
  12.267  fun sfst_const (T, U) =
  12.268 -  Const(@{const_name sfst}, mk_sprodT (T, U) ->> T);
  12.269 +  Const(@{const_name sfst}, mk_sprodT (T, U) ->> T)
  12.270  
  12.271  fun ssnd_const (T, U) =
  12.272 -  Const(@{const_name ssnd}, mk_sprodT (T, U) ->> U);
  12.273 +  Const(@{const_name ssnd}, mk_sprodT (T, U) ->> U)
  12.274  
  12.275  fun ssplit_const (T, U, V) =
  12.276 -  Const (@{const_name ssplit}, (T ->> U ->> V) ->> mk_sprodT (T, U) ->> V);
  12.277 +  Const (@{const_name ssplit}, (T ->> U ->> V) ->> mk_sprodT (T, U) ->> V)
  12.278  
  12.279  fun mk_ssplit t =
  12.280 -  let val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of t));
  12.281 -  in ssplit_const (T, U, V) ` t end;
  12.282 +  let val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of t))
  12.283 +  in ssplit_const (T, U, V) ` t end
  12.284  
  12.285  
  12.286  (*** Strict sum type ***)
  12.287  
  12.288 -fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U]);
  12.289 +fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U])
  12.290  
  12.291  fun dest_ssumT (Type(@{type_name ssum}, [T, U])) = (T, U)
  12.292 -  | dest_ssumT T = raise TYPE ("dest_ssumT", [T], []);
  12.293 +  | dest_ssumT T = raise TYPE ("dest_ssumT", [T], [])
  12.294  
  12.295 -fun sinl_const (T, U) = Const(@{const_name sinl}, T ->> mk_ssumT (T, U));
  12.296 -fun sinr_const (T, U) = Const(@{const_name sinr}, U ->> mk_ssumT (T, U));
  12.297 +fun sinl_const (T, U) = Const(@{const_name sinl}, T ->> mk_ssumT (T, U))
  12.298 +fun sinr_const (T, U) = Const(@{const_name sinr}, U ->> mk_ssumT (T, U))
  12.299  
  12.300  (* builds the list [sinl(t1), sinl(sinr(t2)), ... sinr(...sinr(tn))] *)
  12.301  fun mk_sinjects ts =
  12.302    let
  12.303 -    val Ts = map fastype_of ts;
  12.304 +    val Ts = map fastype_of ts
  12.305      fun combine (t, T) (us, U) =
  12.306        let
  12.307 -        val v = sinl_const (T, U) ` t;
  12.308 -        val vs = map (fn u => sinr_const (T, U) ` u) us;
  12.309 +        val v = sinl_const (T, U) ` t
  12.310 +        val vs = map (fn u => sinr_const (T, U) ` u) us
  12.311        in
  12.312          (v::vs, mk_ssumT (T, U))
  12.313        end
  12.314      fun inj [] = raise Fail "mk_sinjects: empty list"
  12.315        | inj ((t, T)::[]) = ([t], T)
  12.316 -      | inj ((t, T)::ts) = combine (t, T) (inj ts);
  12.317 +      | inj ((t, T)::ts) = combine (t, T) (inj ts)
  12.318    in
  12.319      fst (inj (ts ~~ Ts))
  12.320 -  end;
  12.321 +  end
  12.322  
  12.323  fun sscase_const (T, U, V) =
  12.324    Const(@{const_name sscase},
  12.325 -    (T ->> V) ->> (U ->> V) ->> mk_ssumT (T, U) ->> V);
  12.326 +    (T ->> V) ->> (U ->> V) ->> mk_ssumT (T, U) ->> V)
  12.327  
  12.328  fun mk_sscase (t, u) =
  12.329 -  let val (T, V) = dest_cfunT (fastype_of t);
  12.330 -      val (U, V) = dest_cfunT (fastype_of u);
  12.331 -  in sscase_const (T, U, V) ` t ` u end;
  12.332 +  let val (T, V) = dest_cfunT (fastype_of t)
  12.333 +      val (U, V) = dest_cfunT (fastype_of u)
  12.334 +  in sscase_const (T, U, V) ` t ` u end
  12.335  
  12.336  fun from_sinl (T, U) =
  12.337 -  sscase_const (T, U, T) ` mk_ID T ` mk_bottom (U ->> T);
  12.338 +  sscase_const (T, U, T) ` mk_ID T ` mk_bottom (U ->> T)
  12.339  
  12.340  fun from_sinr (T, U) =
  12.341 -  sscase_const (T, U, U) ` mk_bottom (T ->> U) ` mk_ID U;
  12.342 +  sscase_const (T, U, U) ` mk_bottom (T ->> U) ` mk_ID U
  12.343  
  12.344  
  12.345  (*** pattern match monad type ***)
  12.346  
  12.347 -fun mk_matchT T = Type (@{type_name "match"}, [T]);
  12.348 +fun mk_matchT T = Type (@{type_name "match"}, [T])
  12.349  
  12.350  fun dest_matchT (Type(@{type_name "match"}, [T])) = T
  12.351 -  | dest_matchT T = raise TYPE ("dest_matchT", [T], []);
  12.352 +  | dest_matchT T = raise TYPE ("dest_matchT", [T], [])
  12.353  
  12.354 -fun mk_fail T = Const (@{const_name "Fixrec.fail"}, mk_matchT T);
  12.355 +fun mk_fail T = Const (@{const_name "Fixrec.fail"}, mk_matchT T)
  12.356  
  12.357 -fun succeed_const T = Const (@{const_name "Fixrec.succeed"}, T ->> mk_matchT T);
  12.358 -fun mk_succeed t = succeed_const (fastype_of t) ` t;
  12.359 +fun succeed_const T = Const (@{const_name "Fixrec.succeed"}, T ->> mk_matchT T)
  12.360 +fun mk_succeed t = succeed_const (fastype_of t) ` t
  12.361  
  12.362  
  12.363  (*** lifted boolean type ***)
  12.364  
  12.365 -val trT = @{typ "tr"};
  12.366 +val trT = @{typ "tr"}
  12.367  
  12.368  
  12.369  (*** theory of fixed points ***)
  12.370  
  12.371  fun mk_fix t =
  12.372    let val (T, _) = dest_cfunT (fastype_of t)
  12.373 -  in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end;
  12.374 +  in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end
  12.375  
  12.376  fun iterate_const T =
  12.377 -  Const (@{const_name iterate}, natT --> (T ->> T) ->> (T ->> T));
  12.378 +  Const (@{const_name iterate}, natT --> (T ->> T) ->> (T ->> T))
  12.379  
  12.380  fun mk_iterate (n, f) =
  12.381 -  let val (T, _) = dest_cfunT (Term.fastype_of f);
  12.382 -  in (iterate_const T $ n) ` f ` mk_bottom T end;
  12.383 +  let val (T, _) = dest_cfunT (Term.fastype_of f)
  12.384 +  in (iterate_const T $ n) ` f ` mk_bottom T end
  12.385  
  12.386 -end;
  12.387 +end