src/HOL/Tools/inductive_codegen.ML
author berghofe
Mon Dec 10 15:40:55 2001 +0100 (2001-12-10)
changeset 12453 806502073957
parent 11539 0f17da240450
child 12557 bb2e4689347e
permissions -rw-r--r--
- Changed type of invoke_codegen
- Added combinators for sequences
berghofe@12453
     1
(*  Title:      HOL/inductive_codegen.ML
berghofe@11537
     2
    ID:         $Id$
wenzelm@11539
     3
    Author:     Stefan Berghofer, TU Muenchen
wenzelm@11539
     4
    License:    GPL (GNU GENERAL PUBLIC LICENSE)
berghofe@11537
     5
wenzelm@11539
     6
Code generator for inductive predicates.
berghofe@11537
     7
*)
berghofe@11537
     8
berghofe@11537
     9
signature INDUCTIVE_CODEGEN =
berghofe@11537
    10
sig
berghofe@11537
    11
  val setup : (theory -> theory) list
berghofe@11537
    12
end;
berghofe@11537
    13
berghofe@11537
    14
structure InductiveCodegen : INDUCTIVE_CODEGEN =
berghofe@11537
    15
struct
berghofe@11537
    16
berghofe@11537
    17
open Codegen;
berghofe@11537
    18
berghofe@11537
    19
exception Modes of (string * int list list) list * (string * int list list) list;
berghofe@11537
    20
berghofe@11537
    21
datatype indprem = Prem of string * term list * term list
berghofe@11537
    22
                 | Sidecond of term;
berghofe@11537
    23
berghofe@11537
    24
fun prod_factors p (Const ("Pair", _) $ t $ u) =
berghofe@11537
    25
      p :: prod_factors (1::p) t @ prod_factors (2::p) u
berghofe@11537
    26
  | prod_factors p _ = [];
berghofe@11537
    27
berghofe@11537
    28
fun split_prod p ps t = if p mem ps then (case t of
berghofe@11537
    29
       Const ("Pair", _) $ t $ u =>
berghofe@11537
    30
         split_prod (1::p) ps t @ split_prod (2::p) ps u
berghofe@11537
    31
     | _ => error "Inconsistent use of products") else [t];
berghofe@11537
    32
berghofe@11537
    33
fun string_of_factors p ps = if p mem ps then
berghofe@11537
    34
    "(" ^ string_of_factors (1::p) ps ^ ", " ^ string_of_factors (2::p) ps ^ ")"
berghofe@11537
    35
  else "_";
berghofe@11537
    36
berghofe@11537
    37
(**** check if a term contains only constructor functions ****)
berghofe@11537
    38
berghofe@11537
    39
fun is_constrt thy =
berghofe@11537
    40
  let
berghofe@11537
    41
    val cnstrs = flat (flat (map
berghofe@11537
    42
      (map (fn (_, (_, _, cs)) => map (apsnd length) cs) o #descr o snd)
berghofe@11537
    43
      (Symtab.dest (DatatypePackage.get_datatypes thy))));
berghofe@11537
    44
    fun check t = (case strip_comb t of
berghofe@11537
    45
        (Var _, []) => true
berghofe@11537
    46
      | (Const (s, _), ts) => (case assoc (cnstrs, s) of
berghofe@11537
    47
            None => false
berghofe@11537
    48
          | Some i => length ts = i andalso forall check ts)
berghofe@11537
    49
      | _ => false)
berghofe@11537
    50
  in check end;
berghofe@11537
    51
berghofe@11537
    52
(**** check if a type is an equality type (i.e. doesn't contain fun) ****)
berghofe@11537
    53
berghofe@11537
    54
fun is_eqT (Type (s, Ts)) = s <> "fun" andalso forall is_eqT Ts
berghofe@11537
    55
  | is_eqT _ = true;
berghofe@11537
    56
berghofe@11537
    57
(**** mode inference ****)
berghofe@11537
    58
berghofe@11537
    59
val term_vs = map (fst o fst o dest_Var) o term_vars;
berghofe@11537
    60
val terms_vs = distinct o flat o (map term_vs);
berghofe@11537
    61
berghofe@11537
    62
(** collect all Vars in a term (with duplicates!) **)
berghofe@11537
    63
fun term_vTs t = map (apfst fst o dest_Var)
berghofe@11537
    64
  (filter is_Var (foldl_aterms (op :: o Library.swap) ([], t)));
berghofe@11537
    65
berghofe@11537
    66
fun known_args _ _ [] = []
berghofe@11537
    67
  | known_args vs i (t::ts) = if term_vs t subset vs then i::known_args vs (i+1) ts
berghofe@11537
    68
      else known_args vs (i+1) ts;
berghofe@11537
    69
berghofe@11537
    70
fun get_args _ _ [] = ([], [])
berghofe@11537
    71
  | get_args is i (x::xs) = (if i mem is then apfst else apsnd) (cons x)
berghofe@11537
    72
      (get_args is (i+1) xs);
berghofe@11537
    73
berghofe@11537
    74
fun merge xs [] = xs
berghofe@11537
    75
  | merge [] ys = ys
berghofe@11537
    76
  | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
berghofe@11537
    77
      else y::merge (x::xs) ys;
berghofe@11537
    78
berghofe@11537
    79
fun subsets i j = if i <= j then
berghofe@11537
    80
       let val is = subsets (i+1) j
berghofe@11537
    81
       in merge (map (fn ks => i::ks) is) is end
berghofe@11537
    82
     else [[]];
berghofe@11537
    83
berghofe@11537
    84
fun select_mode_prem thy modes vs ps =
berghofe@11537
    85
  find_first (is_some o snd) (ps ~~ map
berghofe@11537
    86
    (fn Prem (s, us, args) => find_first (fn is =>
berghofe@11537
    87
          let
berghofe@11537
    88
            val (_, out_ts) = get_args is 1 us;
berghofe@11537
    89
            val vTs = flat (map term_vTs out_ts);
berghofe@11537
    90
            val dupTs = map snd (duplicates vTs) @
berghofe@11537
    91
              mapfilter (curry assoc vTs) vs;
berghofe@11537
    92
          in
berghofe@11537
    93
            is subset known_args vs 1 us andalso
berghofe@11537
    94
            forall (is_constrt thy) (snd (get_args is 1 us)) andalso
berghofe@11537
    95
            terms_vs args subset vs andalso
berghofe@11537
    96
            forall is_eqT dupTs
berghofe@11537
    97
          end)
berghofe@11537
    98
            (the (assoc (modes, s)))
berghofe@11537
    99
      | Sidecond t => if term_vs t subset vs then Some [] else None) ps);
berghofe@11537
   100
berghofe@11537
   101
fun check_mode_clause thy arg_vs modes mode (ts, ps) =
berghofe@11537
   102
  let
berghofe@11537
   103
    fun check_mode_prems vs [] = Some vs
berghofe@11537
   104
      | check_mode_prems vs ps = (case select_mode_prem thy modes vs ps of
berghofe@11537
   105
          None => None
berghofe@11537
   106
        | Some (x, _) => check_mode_prems
berghofe@11537
   107
            (case x of Prem (_, us, _) => vs union terms_vs us | _ => vs)
berghofe@11537
   108
            (filter_out (equal x) ps));
berghofe@11537
   109
    val (in_ts', _) = get_args mode 1 ts;
berghofe@11537
   110
    val in_ts = filter (is_constrt thy) in_ts';
berghofe@11537
   111
    val in_vs = terms_vs in_ts;
berghofe@11537
   112
    val concl_vs = terms_vs ts
berghofe@11537
   113
  in
berghofe@11537
   114
    forall is_eqT (map snd (duplicates (flat (map term_vTs in_ts')))) andalso
berghofe@11537
   115
    (case check_mode_prems (arg_vs union in_vs) ps of
berghofe@11537
   116
       None => false
berghofe@11537
   117
     | Some vs => concl_vs subset vs)
berghofe@11537
   118
  end;
berghofe@11537
   119
berghofe@11537
   120
fun check_modes_pred thy arg_vs preds modes (p, ms) =
berghofe@11537
   121
  let val Some rs = assoc (preds, p)
berghofe@11537
   122
  in (p, filter (fn m => forall (check_mode_clause thy arg_vs modes m) rs) ms) end
berghofe@11537
   123
berghofe@11537
   124
fun fixp f x =
berghofe@11537
   125
  let val y = f x
berghofe@11537
   126
  in if x = y then x else fixp f y end;
berghofe@11537
   127
berghofe@11537
   128
fun infer_modes thy extra_modes arg_vs preds = fixp (fn modes =>
berghofe@11537
   129
  map (check_modes_pred thy arg_vs preds (modes @ extra_modes)) modes)
berghofe@11537
   130
    (map (fn (s, (ts, _)::_) => (s, subsets 1 (length ts))) preds);
berghofe@11537
   131
berghofe@11537
   132
(**** code generation ****)
berghofe@11537
   133
berghofe@11537
   134
fun mk_eq (x::xs) =
berghofe@11537
   135
  let fun mk_eqs _ [] = []
berghofe@11537
   136
        | mk_eqs a (b::cs) = Pretty.str (a ^ " = " ^ b) :: mk_eqs b cs
berghofe@11537
   137
  in mk_eqs x xs end;
berghofe@11537
   138
berghofe@11537
   139
fun mk_tuple xs = Pretty.block (Pretty.str "(" ::
berghofe@11537
   140
  flat (separate [Pretty.str ",", Pretty.brk 1] (map single xs)) @
berghofe@11537
   141
  [Pretty.str ")"]);
berghofe@11537
   142
berghofe@11537
   143
fun mk_v ((names, vs), s) = (case assoc (vs, s) of
berghofe@11537
   144
      None => ((names, (s, [s])::vs), s)
berghofe@11537
   145
    | Some xs => let val s' = variant names s in
berghofe@11537
   146
        ((s'::names, overwrite (vs, (s, s'::xs))), s') end);
berghofe@11537
   147
berghofe@11537
   148
fun distinct_v (nvs, Var ((s, 0), T)) =
berghofe@11537
   149
      apsnd (Var o rpair T o rpair 0) (mk_v (nvs, s))
berghofe@11537
   150
  | distinct_v (nvs, t $ u) =
berghofe@11537
   151
      let
berghofe@11537
   152
        val (nvs', t') = distinct_v (nvs, t);
berghofe@11537
   153
        val (nvs'', u') = distinct_v (nvs', u);
berghofe@11537
   154
      in (nvs'', t' $ u') end
berghofe@11537
   155
  | distinct_v x = x;
berghofe@11537
   156
berghofe@11537
   157
fun compile_match nvs eq_ps out_ps success_p fail_p =
berghofe@11537
   158
  let val eqs = flat (separate [Pretty.str " andalso", Pretty.brk 1]
berghofe@11537
   159
    (map single (flat (map (mk_eq o snd) nvs) @ eq_ps)));
berghofe@11537
   160
  in
berghofe@11537
   161
    Pretty.block
berghofe@11537
   162
     ([Pretty.str "(fn ", mk_tuple out_ps, Pretty.str " =>", Pretty.brk 1] @
berghofe@11537
   163
      (Pretty.block ((if eqs=[] then [] else Pretty.str "if " ::
berghofe@11537
   164
         [Pretty.block eqs, Pretty.brk 1, Pretty.str "then "]) @
berghofe@11537
   165
         (success_p ::
berghofe@11537
   166
          (if eqs=[] then [] else [Pretty.brk 1, Pretty.str "else ", fail_p]))) ::
berghofe@11537
   167
       [Pretty.brk 1, Pretty.str "| _ => ", fail_p, Pretty.str ")"]))
berghofe@11537
   168
  end;
berghofe@11537
   169
berghofe@11537
   170
fun modename thy s mode = space_implode "_"
berghofe@11537
   171
  (mk_const_id (sign_of thy) s :: map string_of_int mode);
berghofe@11537
   172
berghofe@11537
   173
fun compile_clause thy gr dep all_vs arg_vs modes mode (ts, ps) =
berghofe@11537
   174
  let
berghofe@11537
   175
    fun check_constrt ((names, eqs), t) =
berghofe@11537
   176
      if is_constrt thy t then ((names, eqs), t) else
berghofe@11537
   177
        let val s = variant names "x";
berghofe@11537
   178
        in ((s::names, (s, t)::eqs), Var ((s, 0), fastype_of t)) end;
berghofe@11537
   179
berghofe@11537
   180
    val (in_ts, out_ts) = get_args mode 1 ts;
berghofe@11537
   181
    val ((all_vs', eqs), in_ts') =
berghofe@11537
   182
      foldl_map check_constrt ((all_vs, []), in_ts);
berghofe@11537
   183
berghofe@11537
   184
    fun compile_prems out_ts' vs names gr [] =
berghofe@11537
   185
          let
berghofe@12453
   186
            val (gr2, out_ps) = foldl_map
berghofe@12453
   187
              (invoke_codegen thy dep false) (gr, out_ts);
berghofe@11537
   188
            val (gr3, eq_ps) = foldl_map (fn (gr, (s, t)) =>
berghofe@11537
   189
              apsnd (Pretty.block o cons (Pretty.str (s ^ " = ")) o single)
berghofe@12453
   190
                (invoke_codegen thy dep false (gr, t))) (gr2, eqs);
berghofe@11537
   191
            val (nvs, out_ts'') = foldl_map distinct_v
berghofe@11537
   192
              ((names, map (fn x => (x, [x])) vs), out_ts');
berghofe@12453
   193
            val (gr4, out_ps') = foldl_map
berghofe@12453
   194
              (invoke_codegen thy dep false) (gr3, out_ts'');
berghofe@11537
   195
          in
berghofe@11537
   196
            (gr4, compile_match (snd nvs) eq_ps out_ps'
berghofe@11537
   197
              (Pretty.block [Pretty.str "Seq.single", Pretty.brk 1, mk_tuple out_ps])
berghofe@11537
   198
              (Pretty.str "Seq.empty"))
berghofe@11537
   199
          end
berghofe@11537
   200
      | compile_prems out_ts vs names gr ps =
berghofe@11537
   201
          let
berghofe@11537
   202
            val vs' = distinct (flat (vs :: map term_vs out_ts));
berghofe@11537
   203
            val Some (p, Some mode') =
berghofe@11537
   204
              select_mode_prem thy modes (arg_vs union vs') ps;
berghofe@11537
   205
            val ps' = filter_out (equal p) ps;
berghofe@11537
   206
          in
berghofe@11537
   207
            (case p of
berghofe@11537
   208
               Prem (s, us, args) =>
berghofe@11537
   209
                 let
berghofe@11537
   210
                   val (in_ts, out_ts') = get_args mode' 1 us;
berghofe@12453
   211
                   val (gr1, in_ps) = foldl_map
berghofe@12453
   212
                     (invoke_codegen thy dep false) (gr, in_ts);
berghofe@12453
   213
                   val (gr2, arg_ps) = foldl_map
berghofe@12453
   214
                     (invoke_codegen thy dep true) (gr1, args);
berghofe@11537
   215
                   val (nvs, out_ts'') = foldl_map distinct_v
berghofe@11537
   216
                     ((names, map (fn x => (x, [x])) vs), out_ts);
berghofe@12453
   217
                   val (gr3, out_ps) = foldl_map
berghofe@12453
   218
                     (invoke_codegen thy dep false) (gr2, out_ts'')
berghofe@11537
   219
                   val (gr4, rest) = compile_prems out_ts' vs' (fst nvs) gr3 ps';
berghofe@11537
   220
                 in
berghofe@11537
   221
                   (gr4, compile_match (snd nvs) [] out_ps
berghofe@11537
   222
                      (Pretty.block (separate (Pretty.brk 1)
berghofe@11537
   223
                        (Pretty.str (modename thy s mode') :: arg_ps) @
berghofe@11537
   224
                         [Pretty.brk 1, mk_tuple in_ps,
berghofe@11537
   225
                          Pretty.str " :->", Pretty.brk 1, rest]))
berghofe@11537
   226
                      (Pretty.str "Seq.empty"))
berghofe@11537
   227
                 end
berghofe@11537
   228
             | Sidecond t =>
berghofe@11537
   229
                 let
berghofe@12453
   230
                   val (gr1, side_p) = invoke_codegen thy dep true (gr, t);
berghofe@11537
   231
                   val (nvs, out_ts') = foldl_map distinct_v
berghofe@11537
   232
                     ((names, map (fn x => (x, [x])) vs), out_ts);
berghofe@12453
   233
                   val (gr2, out_ps) = foldl_map
berghofe@12453
   234
                     (invoke_codegen thy dep false) (gr1, out_ts')
berghofe@11537
   235
                   val (gr3, rest) = compile_prems [] vs' (fst nvs) gr2 ps';
berghofe@11537
   236
                 in
berghofe@11537
   237
                   (gr3, compile_match (snd nvs) [] out_ps
berghofe@11537
   238
                      (Pretty.block [Pretty.str "?? ", side_p,
berghofe@11537
   239
                        Pretty.str " :->", Pretty.brk 1, rest])
berghofe@11537
   240
                      (Pretty.str "Seq.empty"))
berghofe@11537
   241
                 end)
berghofe@11537
   242
          end;
berghofe@11537
   243
berghofe@11537
   244
    val (gr', prem_p) = compile_prems in_ts' [] all_vs' gr ps;
berghofe@11537
   245
  in
berghofe@11537
   246
    (gr', Pretty.block [Pretty.str "Seq.single inp :->", Pretty.brk 1, prem_p])
berghofe@11537
   247
  end;
berghofe@11537
   248
berghofe@11537
   249
fun compile_pred thy gr dep prfx all_vs arg_vs modes s cls mode =
berghofe@11537
   250
  let val (gr', cl_ps) = foldl_map (fn (gr, cl) =>
berghofe@11537
   251
    compile_clause thy gr dep all_vs arg_vs modes mode cl) (gr, cls)
berghofe@11537
   252
  in
berghofe@11537
   253
    ((gr', "and "), Pretty.block
berghofe@11537
   254
      ([Pretty.block (separate (Pretty.brk 1)
berghofe@11537
   255
         (Pretty.str (prfx ^ modename thy s mode) :: map Pretty.str arg_vs) @
berghofe@11537
   256
         [Pretty.str " inp ="]),
berghofe@11537
   257
        Pretty.brk 1] @
berghofe@11537
   258
       flat (separate [Pretty.str " ++", Pretty.brk 1] (map single cl_ps))))
berghofe@11537
   259
  end;
berghofe@11537
   260
berghofe@11537
   261
fun compile_preds thy gr dep all_vs arg_vs modes preds =
berghofe@11537
   262
  let val ((gr', _), prs) = foldl_map (fn ((gr, prfx), (s, cls)) =>
berghofe@11537
   263
    foldl_map (fn ((gr', prfx'), mode) =>
berghofe@11537
   264
      compile_pred thy gr' dep prfx' all_vs arg_vs modes s cls mode)
berghofe@11537
   265
        ((gr, prfx), the (assoc (modes, s)))) ((gr, "fun "), preds)
berghofe@11537
   266
  in
berghofe@11537
   267
    (gr', space_implode "\n\n" (map Pretty.string_of (flat prs)) ^ ";\n\n")
berghofe@11537
   268
  end;
berghofe@11537
   269
berghofe@11537
   270
(**** processing of introduction rules ****)
berghofe@11537
   271
berghofe@11537
   272
val string_of_mode = enclose "[" "]" o commas o map string_of_int;
berghofe@11537
   273
berghofe@11537
   274
fun print_modes modes = message ("Inferred modes:\n" ^
berghofe@11537
   275
  space_implode "\n" (map (fn (s, ms) => s ^ ": " ^ commas (map
berghofe@11537
   276
    string_of_mode ms)) modes));
berghofe@11537
   277
berghofe@11537
   278
fun print_factors factors = message ("Factors:\n" ^
berghofe@11537
   279
  space_implode "\n" (map (fn (s, fs) => s ^ ": " ^ string_of_factors [] fs) factors));
berghofe@11537
   280
  
berghofe@11537
   281
fun get_modes (Some (Modes x), _) = x
berghofe@11537
   282
  | get_modes _ = ([], []);
berghofe@11537
   283
berghofe@11537
   284
fun mk_ind_def thy gr dep names intrs =
berghofe@11537
   285
  let val ids = map (mk_const_id (sign_of thy)) names
berghofe@11537
   286
  in Graph.add_edge (hd ids, dep) gr handle Graph.UNDEF _ =>
berghofe@11537
   287
    let
berghofe@11537
   288
      fun process_prem factors (gr, t' as _ $ (Const ("op :", _) $ t $ u)) =
berghofe@11537
   289
            (case strip_comb u of
berghofe@11537
   290
               (Const (name, _), args) =>
berghofe@11537
   291
                  (case InductivePackage.get_inductive thy name of
berghofe@11537
   292
                     None => (gr, Sidecond t')
berghofe@11537
   293
                   | Some ({names=names', ...}, {intrs=intrs', ...}) =>
berghofe@11537
   294
                       (if names = names' then gr
berghofe@11537
   295
                          else mk_ind_def thy gr (hd ids) names' intrs',
berghofe@11537
   296
                        Prem (name, split_prod []
berghofe@11537
   297
                          (the (assoc (factors, name))) t, args)))
berghofe@11537
   298
             | _ => (gr, Sidecond t'))
berghofe@11537
   299
        | process_prem factors (gr, _ $ (Const ("op =", _) $ t $ u)) =
berghofe@11537
   300
            (gr, Prem ("eq", [t, u], []))
berghofe@11537
   301
        | process_prem factors (gr, _ $ t) = (gr, Sidecond t);
berghofe@11537
   302
berghofe@11537
   303
      fun add_clause factors ((clauses, gr), intr) =
berghofe@11537
   304
        let
berghofe@11537
   305
          val _ $ (_ $ t $ u) = Logic.strip_imp_concl intr;
berghofe@11537
   306
          val (Const (name, _), args) = strip_comb u;
berghofe@11537
   307
          val (gr', prems) = foldl_map (process_prem factors)
berghofe@11537
   308
            (gr, Logic.strip_imp_prems intr);
berghofe@11537
   309
        in
berghofe@11537
   310
          (overwrite (clauses, (name, if_none (assoc (clauses, name)) [] @
berghofe@11537
   311
             [(split_prod [] (the (assoc (factors, name))) t, prems)])), gr')
berghofe@11537
   312
        end;
berghofe@11537
   313
berghofe@11537
   314
      fun add_prod_factors (fs, x as _ $ (Const ("op :", _) $ t $ u)) =
berghofe@11537
   315
            (case strip_comb u of
berghofe@11537
   316
               (Const (name, _), _) =>
berghofe@11537
   317
                 let val f = prod_factors [] t
berghofe@11537
   318
                 in overwrite (fs, (name, f inter if_none (assoc (fs, name)) f)) end
berghofe@11537
   319
             | _ => fs)
berghofe@11537
   320
        | add_prod_factors (fs, _) = fs;
berghofe@11537
   321
berghofe@11537
   322
      val intrs' = map (rename_term o #prop o rep_thm o standard) intrs;
berghofe@11537
   323
      val factors = foldl add_prod_factors ([], flat (map (fn t =>
berghofe@11537
   324
        Logic.strip_imp_concl t :: Logic.strip_imp_prems t) intrs'));
berghofe@11537
   325
      val (clauses, gr') = foldl (add_clause factors) (([], Graph.add_edge (hd ids, dep)
berghofe@11537
   326
        (Graph.new_node (hd ids, (None, "")) gr)), intrs');
berghofe@11537
   327
      val _ $ (_ $ _ $ u) = Logic.strip_imp_concl (hd intrs');
berghofe@11537
   328
      val (_, args) = strip_comb u;
berghofe@11537
   329
      val arg_vs = flat (map term_vs args);
berghofe@11537
   330
      val extra_modes = ("eq", [[1], [2], [1,2]]) :: (flat (map
berghofe@11537
   331
        (fst o get_modes o Graph.get_node gr') (Graph.all_preds gr' [hd ids])));
berghofe@11537
   332
      val modes = infer_modes thy extra_modes arg_vs clauses;
berghofe@11537
   333
      val _ = print_modes modes;
berghofe@11537
   334
      val _ = print_factors factors;
berghofe@11537
   335
      val (gr'', s) = compile_preds thy gr' (hd ids) (terms_vs intrs') arg_vs
berghofe@11537
   336
        (modes @ extra_modes) clauses;
berghofe@11537
   337
    in
berghofe@11537
   338
      (Graph.map_node (hd ids) (K (Some (Modes (modes, factors)), s)) gr'')
berghofe@11537
   339
    end      
berghofe@11537
   340
  end;
berghofe@11537
   341
berghofe@11537
   342
fun mk_ind_call thy gr dep t u is_query = (case strip_comb u of
berghofe@11537
   343
  (Const (s, _), args) => (case InductivePackage.get_inductive thy s of
berghofe@11537
   344
       None => None
berghofe@11537
   345
     | Some ({names, ...}, {intrs, ...}) =>
berghofe@11537
   346
         let
berghofe@11537
   347
          fun mk_mode (((ts, mode), i), Var _) = ((ts, mode), i+1)
berghofe@11537
   348
            | mk_mode (((ts, mode), i), Free _) = ((ts, mode), i+1)
berghofe@11537
   349
            | mk_mode (((ts, mode), i), t) = ((ts @ [t], mode @ [i]), i+1);
berghofe@11537
   350
berghofe@11537
   351
           val gr1 = mk_ind_def thy gr dep names intrs;
berghofe@11537
   352
           val (modes, factors) = pairself flat (ListPair.unzip
berghofe@11537
   353
             (map (get_modes o Graph.get_node gr1) (Graph.all_preds gr1 [dep])));
berghofe@11537
   354
           val ts = split_prod [] (the (assoc (factors, s))) t;
berghofe@11537
   355
           val (ts', mode) = if is_query then
berghofe@11537
   356
               fst (foldl mk_mode ((([], []), 1), ts))
berghofe@11537
   357
             else (ts, 1 upto length ts);
berghofe@11537
   358
           val _ = if mode mem the (assoc (modes, s)) then () else
berghofe@11537
   359
             error ("No such mode for " ^ s ^ ": " ^ string_of_mode mode);
berghofe@12453
   360
           val (gr2, in_ps) = foldl_map
berghofe@12453
   361
             (invoke_codegen thy dep false) (gr1, ts');
berghofe@12453
   362
           val (gr3, arg_ps) = foldl_map
berghofe@12453
   363
             (invoke_codegen thy dep true) (gr2, args);
berghofe@11537
   364
         in
berghofe@11537
   365
           Some (gr3, Pretty.block (separate (Pretty.brk 1)
berghofe@11537
   366
             (Pretty.str (modename thy s mode) :: arg_ps @ [mk_tuple in_ps])))
berghofe@11537
   367
         end)
berghofe@11537
   368
  | _ => None);
berghofe@11537
   369
berghofe@11537
   370
fun inductive_codegen thy gr dep brack (Const ("op :", _) $ t $ u) =
berghofe@11537
   371
      (case mk_ind_call thy gr dep t u false of
berghofe@11537
   372
         None => None
berghofe@11537
   373
       | Some (gr', call_p) => Some (gr', (if brack then parens else I)
berghofe@12453
   374
           (Pretty.block [Pretty.str "?! (", call_p, Pretty.str ")"])))
berghofe@11537
   375
  | inductive_codegen thy gr dep brack (Free ("query", _) $ (Const ("op :", _) $ t $ u)) =
berghofe@11537
   376
      mk_ind_call thy gr dep t u true
berghofe@11537
   377
  | inductive_codegen thy gr dep brack _ = None;
berghofe@11537
   378
berghofe@11537
   379
val setup = [add_codegen "inductive" inductive_codegen];
berghofe@11537
   380
berghofe@11537
   381
end;
berghofe@12453
   382
berghofe@12453
   383
berghofe@12453
   384
(**** combinators for code generated from inductive predicates ****)
berghofe@12453
   385
berghofe@12453
   386
infix 5 :->;
berghofe@12453
   387
infix 3 ++;
berghofe@12453
   388
berghofe@12453
   389
fun s :-> f = Seq.flat (Seq.map f s);
berghofe@12453
   390
berghofe@12453
   391
fun s1 ++ s2 = Seq.append (s1, s2);
berghofe@12453
   392
berghofe@12453
   393
fun ?? b = if b then Seq.single () else Seq.empty;
berghofe@12453
   394
berghofe@12453
   395
fun ?! s = is_some (Seq.pull s);    
berghofe@12453
   396
berghofe@12453
   397
fun eq_1 x = Seq.single x;
berghofe@12453
   398
berghofe@12453
   399
val eq_2 = eq_1;