diff --git a/.depend b/.depend
index 4513260..c25f78b 100644
--- a/.depend
+++ b/.depend
@@ -186,6 +186,54 @@ typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \
     typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/datarepr.cmi
 typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
+typing/debug_core.cmo : typing/types.cmi typing/typemod.cmi \
+    typing/typedtree.cmi typing/printtyp.cmi parsing/pprintast.cmi \
+    typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/env.cmi \
+    parsing/asttypes.cmi parsing/ast_helper.cmi typing/debug_core.cmi
+typing/debug_core.cmx : typing/types.cmx typing/typemod.cmx \
+    typing/typedtree.cmx typing/printtyp.cmx parsing/pprintast.cmx \
+    typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
+    parsing/longident.cmx parsing/location.cmx typing/env.cmx \
+    parsing/asttypes.cmi parsing/ast_helper.cmx typing/debug_core.cmi
+typing/debug_core.cmi : typing/types.cmi parsing/parsetree.cmi \
+    parsing/location.cmi typing/env.cmi parsing/asttypes.cmi
+typing/debug_main.cmo : utils/warnings.cmi typing/typetexp.cmi \
+    typing/typemod.cmi typing/typedtree.cmi typing/typedecl.cmi \
+    typing/typecore.cmi parsing/syntaxerr.cmi typing/printtyp.cmi \
+    parsing/pprintast.cmi parsing/parsetree.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/env.cmi typing/debug_slice.cmi \
+    typing/debug_message.cmo typing/debug_core.cmi typing/ctype.cmi \
+    typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+    typing/debug_main.cmi
+typing/debug_main.cmx : utils/warnings.cmx typing/typetexp.cmx \
+    typing/typemod.cmx typing/typedtree.cmx typing/typedecl.cmx \
+    typing/typecore.cmx parsing/syntaxerr.cmx typing/printtyp.cmx \
+    parsing/pprintast.cmx parsing/parsetree.cmi parsing/longident.cmx \
+    parsing/location.cmx typing/env.cmx typing/debug_slice.cmx \
+    typing/debug_message.cmx typing/debug_core.cmx typing/ctype.cmx \
+    typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+    typing/debug_main.cmi
+typing/debug_main.cmi : parsing/parsetree.cmi typing/env.cmi
+typing/debug_message.cmo : typing/types.cmi parsing/syntaxerr.cmi \
+    typing/printtyp.cmi parsing/pprintast.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi typing/debug_core.cmi
+typing/debug_message.cmx : typing/types.cmx parsing/syntaxerr.cmx \
+    typing/printtyp.cmx parsing/pprintast.cmx typing/path.cmx \
+    parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \
+    typing/ident.cmx typing/debug_core.cmx
+typing/debug_slice.cmo : utils/warnings.cmi typing/typemod.cmi \
+    typing/typedtree.cmi parsing/pprintast.cmi parsing/parsetree.cmi \
+    bytecomp/meta.cmi parsing/location.cmi typing/env.cmi \
+    typing/debug_core.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+    typing/debug_slice.cmi
+typing/debug_slice.cmx : utils/warnings.cmx typing/typemod.cmx \
+    typing/typedtree.cmx parsing/pprintast.cmx parsing/parsetree.cmi \
+    bytecomp/meta.cmx parsing/location.cmx typing/env.cmx \
+    typing/debug_core.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+    typing/debug_slice.cmi
+typing/debug_slice.cmi : parsing/parsetree.cmi typing/env.cmi
 typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
     typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -1960,8 +2008,9 @@ driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
     bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \
     driver/pparse.cmi utils/misc.cmi bytecomp/lambda.cmi \
     typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \
-    driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
-    bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi
+    typing/debug_main.cmi typing/debug_core.cmi driver/compmisc.cmi \
+    driver/compenv.cmi utils/clflags.cmi bytecomp/bytegen.cmi \
+    parsing/builtin_attributes.cmi driver/compile.cmi
 driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
     typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
     utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
@@ -1969,8 +2018,9 @@ driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
     bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \
     driver/pparse.cmx utils/misc.cmx bytecomp/lambda.cmx \
     typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \
-    driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
-    bytecomp/bytegen.cmx parsing/builtin_attributes.cmx driver/compile.cmi
+    typing/debug_main.cmx typing/debug_core.cmx driver/compmisc.cmx \
+    driver/compenv.cmx utils/clflags.cmx bytecomp/bytegen.cmx \
+    parsing/builtin_attributes.cmx driver/compile.cmi
 driver/compile.cmi :
 driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -2155,8 +2205,9 @@ toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \
     typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \
     parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \
     typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \
-    bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
-    utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
+    bytecomp/emitcode.cmi bytecomp/dll.cmi typing/debug_main.cmi \
+    typing/debug_core.cmi utils/consistbl.cmi utils/config.cmi \
+    driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
     bytecomp/bytegen.cmi typing/btype.cmi parsing/asttypes.cmi \
     parsing/ast_helper.cmi toplevel/toploop.cmi
 toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \
@@ -2169,8 +2220,9 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \
     typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \
     parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
     typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \
-    bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
-    utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
+    bytecomp/emitcode.cmx bytecomp/dll.cmx typing/debug_main.cmx \
+    typing/debug_core.cmx utils/consistbl.cmx utils/config.cmx \
+    driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
     bytecomp/bytegen.cmx typing/btype.cmx parsing/asttypes.cmi \
     parsing/ast_helper.cmx toplevel/toploop.cmi
 toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
diff --git a/.gitignore b/.gitignore
index 332ecb8..2a1172a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -27,8 +27,6 @@
 *.annot
 *.exe
 *.exe.manifest
-.depend
-.depend.nt
 .DS_Store
 *.out
 *.out.dSYM
@@ -171,7 +169,6 @@
 /ocamldoc/test
 
 /otherlibs/dynlink/extract_crc
-/otherlibs/systhreads/thread.ml
 /otherlibs/threads/marshal.mli
 /otherlibs/threads/pervasives.mli
 /otherlibs/threads/unix.mli
diff --git a/Makefile.shared b/Makefile.shared
index 5ffccb4..3651295 100644
--- a/Makefile.shared
+++ b/Makefile.shared
@@ -71,7 +71,8 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
   typing/stypes.cmo typing/typedecl.cmo typing/typecore.cmo \
   typing/typeclass.cmo \
-  typing/typemod.cmo
+  typing/typemod.cmo typing/debug_core.cmo typing/debug_message.cmo \
+  typing/debug_slice.cmo typing/debug_main.cmo
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
   bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
diff --git a/driver/compile.ml b/driver/compile.ml
index 0d7325d..ebe3035 100644
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -54,6 +54,11 @@ let interface ppf sourcefile outputprefix =
       initial_env sg ;
   end
 
+(* for type debugger *)
+
+(* input structure to be compiled *)
+let structure = ref []
+
 (* Compile a .ml file *)
 
 let print_if ppf flag printer arg =
@@ -69,7 +74,9 @@ let implementation ppf sourcefile outputprefix =
   let env = Compmisc.initial_env() in
   try
     let (typedtree, coercion) =
-      Pparse.parse_implementation ~tool_name ppf sourcefile
+      let str = Pparse.parse_implementation ~tool_name ppf sourcefile in
+      structure := str;
+      str (* Pparse.parse_implementation ~tool_name ppf sourcefile *)
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
       ++ print_if ppf Clflags.dump_source Pprintast.structure
       ++ Timings.(time (Typing sourcefile))
@@ -110,4 +117,10 @@ let implementation ppf sourcefile outputprefix =
     end
   with x ->
     Stypes.dump (Some (outputprefix ^ ".annot"));
-    raise x
+    if Debug_main.handle_simple_errors ppf x !structure Compmisc.initial_env
+    then exit 2
+    else begin (* launch type debugger *)
+      Debug_main.launch (Debug_core.hole_str :: !structure) Compmisc.initial_env;
+      exit 2
+      (* raise x *)
+    end
diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index 8518438..7242c18 100755
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -593,5 +593,6 @@ let default_iterator =
          | PSig x -> this.signature this x
          | PTyp x -> this.typ this x
          | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g
+         | _ -> assert false
       );
   }
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index ec409be..22ef8ee 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -629,6 +629,7 @@ let default_mapper =
          | PSig x -> PSig (this.signature this x)
          | PTyp x -> PTyp (this.typ this x)
          | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)
+         | Size x -> Size x (* 深さを持つ *)
       );
   }
 
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 1b642b2..52584fd 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -23,6 +23,19 @@ open Parsetree
 open Ast_helper
 open Docstrings
 
+let language_level = Syntaxerr.language_level
+(*
+let language_level = try
+  let lang = Sys.getenv "OCAML_LANGUAGE_LEVEL" in
+  match lang with
+    "1" -> 1
+  | "2" -> 2
+  | "3" -> 3
+  | "4" -> 4
+  | _ -> 4
+  with Not_found -> 4
+*)
+
 let mktyp d = Typ.mk ~loc:(symbol_rloc()) d
 let mkpat d = Pat.mk ~loc:(symbol_rloc()) d
 let mkexp d = Exp.mk ~loc:(symbol_rloc()) d
@@ -459,6 +472,13 @@ let package_type_of_module_type pmty =
       err pmty.pmty_loc
         "only module type identifier and 'with type' constraints are supported"
 
+let expert_exp str =
+  raise (Syntaxerr.Error (Syntaxerr.Expert_exp
+          (str, language_level, symbol_rloc ())))
+
+let infixop0 str loc =
+  raise (Syntaxerr.Error (Syntaxerr.InfixOP0
+          (str, language_level, loc)))
 
 %}
 
@@ -1305,10 +1325,16 @@ and_class_type_declaration:
 
 seq_expr:
   | expr        %prec below_SEMI  { $1 }
-  | expr SEMI                     { reloc_exp $1 }
-  | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
+  | expr SEMI                     { if language_level < 3
+                                    then expert_exp "sequence"
+                                    else reloc_exp $1 }
+  | expr SEMI seq_expr            { if language_level < 3
+                                    then expert_exp "sequence"
+                                    else mkexp(Pexp_sequence($1, $3)) }
   | expr SEMI PERCENT attr_id seq_expr
-      { let seq = mkexp(Pexp_sequence ($1, $5)) in
+      { if language_level < 3
+        then expert_exp "sequence" else
+        let seq = mkexp(Pexp_sequence ($1, $5)) in
         let payload = PStr [mkstrexp seq []] in
         mkexp (Pexp_extension ($4, payload)) }
 ;
@@ -1388,18 +1414,30 @@ expr:
   | IF ext_attributes seq_expr THEN expr ELSE expr
       { mkexp_attrs(Pexp_ifthenelse($3, $5, Some $7)) $2 }
   | IF ext_attributes seq_expr THEN expr
-      { mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 }
+      { if language_level < 3
+        then expert_exp "if"
+        else mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 }
   | WHILE ext_attributes seq_expr DO seq_expr DONE
-      { mkexp_attrs (Pexp_while($3, $5)) $2 }
+      { if language_level < 4
+        then expert_exp "while"
+        else mkexp_attrs (Pexp_while($3, $5)) $2 }
   | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO
     seq_expr DONE
-      { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 }
+      { if language_level < 4
+        then expert_exp "for"
+        else mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 }
   | expr COLONCOLON expr
       { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
   | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
       { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
   | expr INFIXOP0 expr
-      { mkinfix $1 $2 $3 }
+      { if language_level < 4
+        then begin match $2 with
+               "==" -> infixop0 "=" (rhs_loc 2)
+             | "!=" -> infixop0 "<>" (rhs_loc 2)
+             | _ -> mkinfix $1 $2 $3
+             end
+        else mkinfix $1 $2 $3 }
   | expr INFIXOP1 expr
       { mkinfix $1 $2 $3 }
   | expr INFIXOP2 expr
@@ -1437,7 +1475,9 @@ expr:
   | expr AMPERAMPER expr
       { mkinfix $1 "&&" $3 }
   | expr COLONEQUAL expr
-      { mkinfix $1 ":=" $3 }
+      { if language_level < 3
+        then expert_exp "assign"
+        else mkinfix $1 ":=" $3 }
   | subtractive expr %prec prec_unary_minus
       { mkuminus $1 $2 }
   | additive expr %prec prec_unary_plus
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d61b339..216e2b8 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -61,6 +61,7 @@ and payload =
   | PSig of signature (* : SIG *)
   | PTyp of core_type  (* : T *)
   | PPat of pattern * expression option  (* ? P  or  ? P when E *)
+  | Size of int
 
 (** {2 Core language} *)
 
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index f9e5152..3f77e6e 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -1063,6 +1063,7 @@ and payload ctxt f = function
   | PPat (x, Some e) ->
       pp f "?"; pattern ctxt f x;
       pp f " when "; expression ctxt f e
+  | Size x -> print_int x
 
 (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
 and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 673defb..de2a543 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -419,7 +419,7 @@ and payload i ppf = function
     pattern i ppf x;
     line i ppf "<when>\n";
     expression (i + 1) ppf g
-
+  | Size x -> print_int x
 
 and type_kind i ppf x =
   match x with
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index 0bb55ab..bfdc306 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -13,6 +13,31 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(* language levels *)
+
+type language_t = English | Japanese
+
+let language = try
+  let lang = Sys.getenv "LANG" in
+  if String.sub lang 0 (min 5 (String.length lang)) = "ja_JP"
+  then Japanese
+  else English
+with Not_found -> English
+
+let language_level = try
+  let lang = Sys.getenv "OCAML_LANGUAGE_LEVEL" in
+  match lang with
+    "1" -> 1
+  | "2" -> 2
+  | "3" -> 3
+  | "4" -> 4
+  | _ -> 4
+  with Not_found -> 4
+
+let errorf ?(loc = Location.none) en ja = match language with
+    English -> Location.errorf ~loc en
+  | Japanese -> Location.errorf ~loc ja
+
 (* Auxiliary type for reporting syntax errors *)
 
 type error =
@@ -21,6 +46,8 @@ type error =
   | Not_expecting of Location.t * string
   | Applicative_path of Location.t
   | Variable_in_scope of Location.t * string
+  | Expert_exp of string * int * Location.t
+  | InfixOP0 of string * int * Location.t
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
   | Invalid_package_type of Location.t * string
@@ -54,6 +81,41 @@ let prepare_error = function
         "In this scoped type, variable '%s \
          is reserved for the local type %s."
          var var
+  (* language levels *)
+  | Expert_exp (str, level, loc) ->
+      begin match str with
+        "if" ->
+          errorf ~loc
+            "L%dError1: did you forget the else part?"
+            "L%dError1: else 部分を忘れていませんか？"
+            level
+      | "for" ->
+          errorf ~loc
+            "L%dError2: for not allowed at this language level"
+            "L%dError2: この言語レベルでは for 文を使うことはできません"
+            level
+      | "while" ->
+          errorf ~loc
+            "L%dError3: while not allowed at this language level"
+            "L%dError3: この言語レベルでは while 文を使うことはできません"
+            level
+      | "sequence" ->
+          errorf ~loc
+            "L%dError4: sequential execution not allowed at this language level"
+            "L%dError4: この言語レベルでは逐次実行文を使うことはできません"
+            level
+      | "assign" ->
+          errorf ~loc
+            "L%dError5: assignments not allowed at this language level"
+            "L%dError5: この言語レベルでは代入文を使うことはできません"
+            level
+      | _ -> Location.error ~loc ("Unsupported Expert_exp error: " ^ str)
+      end
+  | InfixOP0 (str, level, loc) ->
+      errorf ~loc
+        "L%dError6: use %s."
+        "L%dError6: %s を使いましょう"
+        level str
   | Other loc ->
       Location.errorf ~loc "Syntax error"
   | Ill_formed_ast (loc, s) ->
@@ -76,6 +138,8 @@ let location_of_error = function
   | Unclosed(l,_,_,_)
   | Applicative_path l
   | Variable_in_scope(l,_)
+  | Expert_exp (_, _, l)
+  | InfixOP0 (_, _, l)
   | Other l
   | Not_expecting (l, _)
   | Ill_formed_ast (l, _)
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 319eb57..996dcfb 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -13,6 +13,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(* language levels *)
+
+type language_t = English | Japanese
+val language : language_t
+val language_level : int
+
 (** Auxiliary type for reporting syntax errors *)
 
 open Format
@@ -23,6 +29,8 @@ type error =
   | Not_expecting of Location.t * string
   | Applicative_path of Location.t
   | Variable_in_scope of Location.t * string
+  | Expert_exp of string * int * Location.t
+  | InfixOP0 of string * int * Location.t
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
   | Invalid_package_type of Location.t * string
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index e832fde..4a141b7 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -241,6 +241,26 @@ let add_directive name dir_fun dir_info =
   Hashtbl.add directive_table name dir_fun;
   Hashtbl.add directive_info_table name dir_info
 
+(* for type debugger *)
+
+(* structures input so far in the reverse order *)
+let rev_structures = ref []
+
+(* the last input phrase *)
+let last_phrase = ref (Ptop_def [])
+
+let structure_of_phrase phr = match phr with
+    Ptop_dir (str, _) -> (print_string str; assert false)
+  | Ptop_def (str) -> str
+
+let rec rev_flatten structures acc = match structures with
+    [] -> acc
+  | structure :: rest -> rev_flatten rest (structure @ acc)
+
+(* cons_structure : structure -> structure list -> structure *)
+let cons_structure structure rev_structures =
+  rev_flatten (structure :: rev_structures) []
+
 (* Execute a toplevel phrase *)
 
 let execute_phrase print_outcome ppf phr =
@@ -291,6 +311,7 @@ let execute_phrase print_outcome ppf phr =
               Ophr_exception (exn, outv)
         in
         !print_out_phrase ppf out_phr;
+        rev_structures := sstr :: !rev_structures;
         if Printexc.backtrace_status ()
         then begin
           match !backtrace with
@@ -350,7 +371,15 @@ let execute_phrase print_outcome ppf phr =
   try execute_phrase print_outcome ppf phr
   with exn ->
     Warnings.reset_fatal ();
-    raise exn
+    let last_str = structure_of_phrase !last_phrase in
+    let structure = cons_structure last_str !rev_structures in
+    if Debug_main.handle_simple_errors ppf exn structure Compmisc.initial_env
+    then false
+    else begin (* launch type debugger *)
+      Debug_main.launch (Debug_core.hole_str :: structure) Compmisc.initial_env;
+      false
+    end
+    (* raise exn *)
 
 (* Read and execute commands from a file, or from stdin if [name] is "". *)
 
@@ -395,6 +424,7 @@ let use_file ppf wrap_mod name =
           List.iter
             (fun ph ->
               let ph = preprocess_phrase ppf ph in
+              last_phrase := ph;
               if not (execute_phrase !use_print_results ppf ph) then raise Exit)
             (if wrap_mod then
                parse_mod_use_file name lb
@@ -534,6 +564,7 @@ let loop ppf =
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
       let phr = preprocess_phrase ppf phr  in
+      last_phrase := phr;
       Env.reset_cache_toplevel ();
       ignore(execute_phrase true ppf phr)
     with
diff --git a/typing/debug_core.ml b/typing/debug_core.ml
new file mode 100755
index 0000000..91d58d2
--- /dev/null
+++ b/typing/debug_core.ml
@@ -0,0 +1,2977 @@
+open Asttypes
+module Ast = Ast_helper
+
+open Types
+open Typedtree
+open Parsetree
+
+(* コンテキストの定義 *)
+type expr_context =
+  Empty
+| Lambda of pattern * expr_context
+| Let of rec_flag * value_binding list * expr_context
+type 'a context_t =
+  ('a * expr_context) * Env.t * (structure_item * Env.t) list
+
+(* ---------------------------------------------------------- *)
+
+(* ppf *)
+let ppf = Format.std_formatter
+
+let print_node_count =
+  false (* ノード数をカウントするときには true にする *)
+(* true にすると型デバッグはできなくなる *)
+    
+let print_asked_expr =
+  false (* カウントされた質問を表示するときには true にする *)
+(* スライス表示用変数 (debug_slice.ml) *)
+    
+let print_slice =
+  not print_node_count && (* ノード数カウント中はスライスを表示しない *)
+  false (* スライス結果を表示するときに true にする *)
+  
+(* OCaml のエラーメッセージ Errors.report_error 制御用変数
+   (toplevel/toploop.ml, driver/compile.ml) *)
+  
+let print_ocaml_error =
+  not print_node_count && (* ノード数カウント中は表示しない *)
+  true  (* OCaml のエラーメッセージを消すときに false にする *)
+  
+(* スライスをするかどうかを制御する変数
+   (debug_slice.ml, debug_main.ml) *)     
+let on_exp_slice =
+  print_node_count || (* ノード数カウント中はスライスを行う *)
+  true (* スライスをしないときには false を代入する *)
+  
+let on_pat_slice =
+  ref false (* パターンのスライスをしないときには false を代入する *)
+
+let on_file_output =
+  false (* 各種情報をログに出力する時には true にする *)
+
+(* ---------------------------------------------------------- *)
+(* デバッガ、スライサ共通の定義 *)
+open Ast
+
+module Attr = struct
+
+  (* ここから、ocamldoc/odoc_print.mli とほぼ同じ内容 *)
+  let (type_fmt, flush_type_fmt) =
+    let buf = Buffer.create 512 in
+    let fmt = Format.formatter_of_buffer buf in
+    let flush () =
+      Format.pp_print_flush fmt ();
+      let s = Buffer.contents buf in
+      Buffer.reset buf ;
+      s
+    in
+    (fmt, flush)
+  let string_of_type_expr t =
+    Printtyp.mark_loops t;
+    Printtyp.type_scheme_max ~b_reset_names: false type_fmt t;
+    flush_type_fmt ()
+  (* ここまで、ocamldoc/odoc_print.mli とほぼ同じ内容 *)
+
+  (* 式の attribute *)
+  (* of_expr : expression -> attribute *)
+  let of_expr ({pexp_loc = loc} as e) =
+    (mkloc "exp" loc, PStr [Str.eval ~loc e])
+
+  (* サイズの attribute *)
+  (* of_size : int -> attribute *)
+  let of_size n =
+    (mknoloc "size", PPat (Pat.constant (Const.int n), None))
+
+  (* 型の attribute *)
+  (* of_type : string -> Types.type_expr -> attribute *)
+  let of_type st te =
+    let open Lexing in
+    let lex = from_string (string_of_type_expr te) in
+    let open Parse in
+    (mknoloc st, PTyp (core_type lex))
+
+  let to_size ({txt}, payload) = match payload with
+      PPat ({ppat_desc = Ppat_constant (Pconst_integer (n, None))}, None)
+         when txt = "size" -> int_of_string n
+    | _ -> failwith "Attr: mismatch"
+
+end
+
+(* ホール *)
+module Hole = struct
+  (* □の種類 *)
+  (* Exp : 式の□ *)
+  (* Pat : パターンの□ *)
+  (* Hole : 抽象化の必要がない *)
+  type t = Exp of attribute
+         | Pat of attribute
+         | Hole
+  (* □を求める関数 *)
+  (* Abst.hole' : ?exp:expression -> ?pat:pattern -> unit -> Abst.t *)
+  let rec hole' ?(exp = dummy_assertfalse ()) ?(pat = dummy_any ()) () =
+    match (exp, pat) with
+    | ({pexp_loc = loc; pexp_attributes = []}, _) when
+           exp <> dummy_assertfalse ~loc () && pat = dummy_any () ->
+       Exp ({txt = "exp"; loc}, PPat (pat, Some (exp))) (* 式の□ *)
+    | (_, {ppat_loc = loc; ppat_attributes = []}) when
+           exp = dummy_assertfalse () && pat <> dummy_any ~loc () ->
+       Pat ({txt = "pat"; loc}, PPat (pat, None)) (* パターンの□ *)
+    | _ -> Hole (* 既に抽象化されている *)
+
+  (* 式の抽象化 *)
+  (* Abst.expression : expression -> expression *)
+  and expression exp = match hole' ~exp () with
+    | Exp attr -> Exp.attr (dummy_assertfalse ~loc:exp.pexp_loc ()) attr
+    | _ -> exp
+
+  (* パターンの抽象化 *)
+  (* Abst.pattern : pattern -> pattern *)
+  and pattern pat = match hole' ~pat () with
+    | Pat attr -> Pat.attr (dummy_any ~loc:pat.ppat_loc ()) attr
+    | _ -> pat
+
+  (* ダミーの作成 *)
+  (* dummy_any : ~loc:loc -> unit -> pattern *)
+  (* その他 : ~loc:loc -> unit -> expression *)
+  and dummy_any ?(loc = Location.none) () =
+    Pat.any ~loc ()
+  and dummy_false ?(loc = Location.none) () =
+    Exp.construct ~loc (mknoloc (Longident.Lident "false")) None
+  (* and dummy_true ?(loc = Location.none) () =
+    Exp.construct ~loc (mknoloc (Longident.Lident "true")) None *)
+  and dummy_assertfalse ?(loc = Location.none) () =
+    Exp.assert_ ~loc (dummy_false ())
+  and dummy_int0 ?(loc = Location.none) () =
+    Exp.constant ~loc (Const.int 0)
+  and dummy_fun ?(loc = Location.none) () =
+    Exp.fun_ ~loc Nolabel None (dummy_any ()) (dummy_assertfalse ())
+
+  (* 変数として□を呼び出す用：lidになっている *)
+  let skeleton = mknoloc (Longident.parse "□")
+
+  (* □ を定義する structure_item *)
+  let item =
+    (* let □ = assert false *)
+    let p = Pat.var (mknoloc "□") in
+    let e = dummy_assertfalse () in
+    let vs = [Vb.mk p e] in
+    Str.value Nonrecursive vs
+
+  let of_exp'' loc attrs =
+    Exp.ident ~loc ~attrs skeleton
+
+  let rec of_exp' attrs e = match attrs with
+    | [] ->
+       let attrs = (Attr.of_expr e) :: attrs in
+       of_exp'' e.pexp_loc attrs
+    | ({txt; loc}, payload) :: rest ->
+       if txt = "exp" then
+         e
+       else if txt = "dummy" then
+         of_exp'' e.pexp_loc (({txt = "exp"; loc}, payload) :: rest)
+       else
+         of_exp' rest e
+
+  let of_exp e =
+    of_exp' e.pexp_attributes e
+
+  let of_pat ({ppat_loc = loc; ppat_attributes = attrs} as p) =
+    if List.exists (fun ({txt = name}, _) -> name = "pat") attrs then p
+    else
+      let attrs = (mkloc "pat" loc, PPat (p, None)) :: attrs in
+      Pat.any ~loc ~attrs ()
+
+
+  (* スケルトンのチェック *)
+  let check_loc expr slice = expr.pexp_loc = slice.pexp_loc
+  let check_skeleton expr = check_loc (Exp.ident skeleton) expr
+
+  (* 式の抽象化 *)
+  (* to_exp : expression -> expression *)
+  let rec to_exp exp = match exp.pexp_attributes with
+      [] -> raise Not_found
+    | ({txt = "exp"}, PStr [{pstr_desc = Pstr_eval (exp', _)}]) :: _ -> exp'
+    | _ :: rest -> to_exp {exp with pexp_attributes = rest}
+
+  (* 位置情報のない□ *)
+  let exp = Exp.ident skeleton
+
+end
+
+let rec get_type_name typ = match typ.desc with
+  | Tconstr (path, _, _) ->
+     (* 定義名とモジュール名のリストを返す *)
+     let lst =
+       (Longident.flatten (Longident.parse (Path.name path))) in
+     List.fold_left (
+         fun (type_name, mod_names) s ->
+         (s, if type_name = "" then mod_names
+             else type_name :: mod_names)
+       ) ("", []) lst
+  | Tsubst (t) -> get_type_name t
+  | Tlink (t) -> get_type_name t
+  | _ -> assert false
+
+let rec get_type_decl (type_name, mod_names) prefix = match prefix with
+    [] -> failwith "this type was not find."
+  | ({pstr_desc = d}, _) :: rest ->
+     match d with
+     | Pstr_module ({pmb_name = {txt = name};
+                     pmb_expr = {pmod_desc =
+                                   Pmod_structure (mod_str)}}) ->
+        (* モジュールの定義 *)
+        (* name が mod_names にある場合は mod_str も再帰に含める *)
+        get_type_decl
+          (type_name, mod_names)
+          (if List.exists (
+                  fun mod_name -> mod_name = name) mod_names
+           then List.fold_left (
+                    fun rest' s -> (s, Env.empty) :: rest'
+                  ) rest mod_str else rest)
+     | Pstr_type (_, tds) ->
+        (* 型の定義 *)
+        (* 名前が一致した場合に type_declaration を返す *)
+        begin
+          try
+            let td =
+              List.find (fun {ptype_name = {txt = name}} ->
+                          name = type_name) tds in
+            if print_slice then
+              Format.fprintf ppf "@[  find type_declaration. @]@.";
+            td
+          with _ -> get_type_decl (type_name, mod_names) rest
+        end
+     | _ -> get_type_decl (type_name, mod_names) rest
+
+(* decode_labels : type_expr -> prefix -> label_declaration list *)
+let decode_labels typ prefix =
+  match get_type_decl (get_type_name typ) prefix with
+  | {ptype_kind = Ptype_record (lds)} -> lds
+  | _ -> failwith "This type is not record."
+
+(* 矢印の分離 *)
+(* split_arrow : type_expr -> (type_expr * type_expr) option *)
+let rec split_arrow typ = match typ.desc with
+    Tarrow (_, t1, t2, _) -> Some (t1, t2)
+  | Tlink (typ') -> split_arrow typ'
+  | _ -> None
+
+(* タプルの分離 *)
+(* decode_tuple : type_expr -> type_expr option *)
+let rec decode_tuple typ = match typ.desc with
+    Ttuple (typs) -> Some (typs)
+  | Tlink (typ') -> decode_tuple typ'
+  | _ -> None
+
+(* pattern_variables : pattern -> string list *)
+(* collect all the pattern variables in a pattern *)
+let rec pattern_variables pat = match pat.ppat_desc with
+    Ppat_any -> []
+  | Ppat_var ({txt = st}) -> [st]
+  | Ppat_alias (p, {txt = st}) -> st :: pattern_variables p
+  | Ppat_constant (_) -> []
+  | Ppat_interval (_, _) -> []
+  | Ppat_tuple (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_construct (_, None) -> []
+  | Ppat_construct (_, Some (p)) -> pattern_variables p
+  | Ppat_variant (_, None) -> []
+  | Ppat_variant (_, Some (p)) -> pattern_variables p
+  | Ppat_record (lps, _) ->
+      List.flatten (List.map (fun (_, p) -> pattern_variables p) lps)
+  | Ppat_array (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_or (p1, p2) -> pattern_variables p1 @ pattern_variables p2
+  | Ppat_constraint (p, _) -> pattern_variables p
+  | Ppat_type (_) -> []
+  | Ppat_lazy (p) -> pattern_variables p
+  | Ppat_unpack ({txt = st}) -> [st]
+  | Ppat_exception (p) -> pattern_variables p
+  | Ppat_extension (_) -> []
+  | Ppat_open (_, p) -> pattern_variables p
+
+let rec plug_expr expr cxt = match cxt with
+  | Empty -> expr
+  | Lambda (pat, c) ->
+     (* パターン変数を全て集め *)
+     let vars = pattern_variables pat in
+     (* 変数名から変数の expression を作る *)
+     let varexp x = Exp.ident (mknoloc (Longident.Lident x)) in
+     (* expr と組にして body に入れる。これでパターン変数の型を知る *)
+     (* ダミーの 0 を入れるのは、tuple 長が 2 以上でないとエラーになるため *)
+     let body = Exp.tuple (expr :: Hole.dummy_int0 () :: List.map varexp vars) in
+     let exp = Exp.fun_ Nolabel None pat body in
+     plug_expr exp c
+  | Let (flg, bindings, c) ->
+     let exp = Exp.let_ flg bindings expr in
+     plug_expr exp c
+
+(* plug_str : (expression * expr_context) -> structure *)
+let plug_str (expr, cxt) = [Str.eval (plug_expr expr cxt)]
+
+(* collect_one : (string context_t * type_expr) context_t -> string list ->
+                 type_expr -> yes_no_list * type_expr *)
+let collect_one ((vartyps, cxt'), env, prefix) vars typ =
+  match decode_tuple typ with
+      Some (exp_typ :: _ :: typs) -> (* _ は dummy_int0 の型 *)
+        (List.map2 (fun v t -> (((v, cxt'), env, prefix), t)) vars typs
+         @ vartyps,
+         exp_typ)
+    | Some ([_]) | Some ([]) | None ->
+        Format.fprintf ppf "type:@.%a@." Printtyp.type_expr typ;
+        failwith "TypeDebugger: Error in collect_one"
+
+(* collect : expression context_t -> type_expr -> yes_no_list * type_expr *)
+let rec collect ((expr, cxt), env, prefix) t = match cxt with
+    Empty -> ([], t)
+  | Let (_, _, cxt') -> collect ((expr, cxt'), env, prefix) t
+  | Lambda (pat, cxt') ->
+      (* There and back again [Danvy&Goldberg ICFP'02] *)
+      let (vartyps, t') = collect ((expr, cxt'), env, prefix) t in
+      let vars = pattern_variables pat in
+      match split_arrow t' with
+          Some ((*t1*)_, t2) ->
+            collect_one ((vartyps, cxt'), env, prefix) vars t2
+        | None -> (* Can't happen *)
+            failwith "TypeDebugger: Error in collect"
+
+(* judge : expression context_t -> yes_no_list * type_expr *)
+let judge ((expr, cxt), env, prefix) =
+  let structure = plug_str (expr, cxt) in
+  let (structure', _, _) = Typemod.type_structure env structure Location.none in
+  match structure'.str_items with
+    {str_desc = Tstr_eval ({ exp_type = typ }, _)} :: [] ->
+      collect ((expr, cxt), env, prefix) typ
+  | _ -> failwith "TypeDebugger: Error in judge"
+
+
+(* map 関数の集合 *)
+module Map = struct
+
+  type 'a map2 = (pattern -> expression -> expression)
+                 -> (pattern -> expression -> pattern)
+                 -> 'a -> 'a
+  type 'a map1 = (expression -> expression) -> (pattern -> pattern)
+                 -> 'a -> 'a
+
+  let x1to2 x2 fe fp x = x2 (fun _ e -> fe e) (fun p _ -> fp p) x
+
+  (* 2引数 *)
+  let v2 fe2 fp2 ({pvb_pat = p; pvb_expr = e} as v) =
+    {v with pvb_pat = fp2 p e; pvb_expr = fe2 p e}
+  let c2 fe2 fp2 ({pc_lhs = p; pc_rhs = e} as c) =
+    {c with pc_lhs = fp2 p e; pc_rhs = fe2 p e}
+
+  (* 1引数 *)
+  let v1 fe fp v = x1to2 v2 fe fp v
+  let c1 fe fp c = x1to2 c2 fe fp c
+  let e1 fe _ e = fe e
+  let p1 _ fp p = fp p
+  let le fe _ (l, e) = (l, fe e)
+  let lp _ fp (l, p) = (l, fp p)
+  let id = fun x -> x
+
+  (* 差し替え *)
+  let set_exp x1 x e = x1 (fun _ -> e) id x
+  let set_pat x1 x p = x1 id (fun _ -> p) x
+
+  (* 式の抜き出し *)
+  let e_in_v v = v.pvb_expr
+  let e_in_c c = c.pc_rhs
+
+end
+
+
+let skeleton' = Ast.Exp.ident Hole.skeleton
+
+let hole_str = Hole.item
+let hole_of_exp exp = Hole.of_exp exp
+let hole_of_pat pat = Hole.of_pat pat
+
+module Desc = struct
+
+  (* desc 生成関数の型 *)
+  type 'a make_exp_desc =
+    'a list -> expression -> expression_desc
+  type make_exp_desc2 =
+    expression -> expression -> expression option -> expression_desc
+
+  type 'b make_pat_desc = 'b list -> pattern -> pattern_desc
+  
+  (* open Abst *)
+  let wildcard = Ast.Pat.any ()
+
+  (* pattern : pattern_desc -> pattern -> pattern *)
+  let pattern ppat_desc pat = {pat with ppat_desc}
+  
+  (* expression : expression_desc -> expression -> expression *)
+  let expression pexp_desc expr = {expr with pexp_desc}
+
+  (* to_pat :
+      ('a list -> pattern -> pattern_desc)
+     -> 'a list -> pattern -> pattern -> pattern *)
+  let to_pat fd ys p pat = pattern (fd ys p) pat
+
+  (* to_exp :
+      ('a list -> expression -> expression_desc)
+    -> 'a list -> expression -> expression -> expression *)
+  let to_exp fd xs e expr = expression (fd xs e) expr
+  let to_exp2 fd e1 e2 eop expr = expression (fd e1 e2 eop) expr
+
+  
+  (* ppat_desc の生成 *)
+  let p_alias str _ p = Ppat_alias (p, str)
+  let p_tuple ps _ = Ppat_tuple (ps)
+  let p_construct lid ps p =
+    if ps = [] then Ppat_construct (lid, Some p)
+    else if p = wildcard then Ppat_construct (lid, None)
+    else Ppat_construct (lid, Some (to_pat p_tuple ps p p))
+  let p_variant l _ p = Ppat_variant (l, Some p)
+  let p_record flg lps _ = Ppat_record (lps, flg)
+  let p_array ps _ = Ppat_array (ps)
+  let p_or p1 p2 = Ppat_or (p1, p2)
+  let p_constraint ct _ p = Ppat_constraint (p, ct)
+  
+  (* pexp_desc の生成 *)
+  let e_let flg vs e = Pexp_let (flg, vs, e)
+  let e_function cs _ = Pexp_function (cs) (*
+  let e_fun l eop p e = Pexp_fun (l, eop, p, e)
+  let e_apply les e = Pexp_apply (e, les) *)
+  let e_match cs e = Pexp_match (e, cs)
+  let e_try cs e = Pexp_try (e, cs)
+  let e_tuple es _ = Pexp_tuple (es)
+  let e_construct lid es e =
+    if es = [] then Pexp_construct (lid, Some e)
+    else if e = skeleton' then Pexp_construct (lid, None)
+    else Pexp_construct (lid, Some (to_exp e_tuple es e e))
+  (*  let e_variant l _ e = Pexp_variant (l, Some e) *)
+  (* let e_record les e =
+    if e = skeleton' then Pexp_record (les, None)
+    else Pexp_record (les, Some e)
+  let e_field lid _ e = Pexp_field (e, lid)
+  let e_setfield lid e1 e2 = Pexp_setfield (e1, lid, e2)
+  let e_array es _ = Pexp_array (es)
+  let e_constraint ct _ e = Pexp_constraint (e, ct)
+  let e_ifthenelse e1 e2 eop = Pexp_ifthenelse (e1, e2, eop)
+  let e_sequence e1 e2 = Pexp_sequence (e1, e2)
+  *)
+  (* こっちを使う *)
+  let enop e = if Hole.check_skeleton e then None else Some e
+  let deop eop = match eop with None -> skeleton' | Some e -> e
+
+  (* make_exp_desc *)
+  let pexp_let flg vs e = Pexp_let (flg, vs, e)
+  let pexp_function cs _ = Pexp_function (cs)
+  let pexp_fun l eop p _ e = Pexp_fun (l, eop, p, e)
+  let pexp_apply les e = Pexp_apply (e, les)
+  let pexp_match cs e = Pexp_match (e, cs)
+  let pexp_try cs e = Pexp_try (e, cs)
+  let pexp_tuple es _ = Pexp_tuple (es)
+  let pexp_construct lid _ e = Pexp_construct (lid, enop e)
+  let pexp_variant l _ e = Pexp_variant (l, enop e)
+  let pexp_record les e = Pexp_record (les, enop e)
+  let pexp_field lid _ e = Pexp_field (e, lid)
+  let pexp_array es _ = Pexp_array (es)
+  let pexp_constraint ct _ e = Pexp_constraint (e, ct)
+  let pexp_assert _ e = Pexp_assert (e)
+  (* make_exp_desc2 *)
+  let pexp_setfield lid e1 e2 _ = Pexp_setfield (e1, lid, e2)
+  let pexp_ifthenelse e1 e2 eop = Pexp_ifthenelse (e1, e2, eop)
+  let pexp_sequence e1 e2 _ = Pexp_sequence (e1, e2)
+
+  let flat f prefix env cxt x = f ((x, cxt), env, prefix)
+
+  module type Typ =
+    sig
+      type t
+      val internal : t -> t -> bool
+      val leaf : t -> bool
+      val comp : ?mode:bool -> t -> t -> int
+      val map : (t -> t) -> t -> t
+      val map_all : (t -> t) -> t -> t
+      val fold : ('a -> t -> 'a) -> 'a -> t -> 'a
+      val fold_all : ('a -> t -> 'a) -> 'a -> t -> 'a
+      val replace : t -> t -> t
+    end
+
+  let internal root node =
+    let open Location in
+    match (root, node) with
+      ({loc_start = root_s; loc_end = root_e},
+       {loc_start = node_s; loc_end = node_e}) ->
+        root_s <= node_s && node_e <= root_e
+
+  (* pattern *)
+  module Pat = struct
+    type t = pattern
+    let internal p0 p1 = internal p0.ppat_loc p1.ppat_loc
+
+    let node b {ppat_desc} = match ppat_desc with
+      | Ppat_any | Ppat_var _ | Ppat_constant _ -> b (* leaf : yes *)
+      | Ppat_construct (_, None) | Ppat_variant (_, None) -> b (* leaf : yes *)
+      | _ -> not b (* leaf : no *)
+
+    let leaf e = node true e
+
+    let comp ?(mode = false) p1 p2 =
+      (* true : 位置情報の比較 *)
+      (* 1 : e1 のほうが後 *)
+      (* 0 : 内包 *)
+      (* -1 : e2 のほうが後 *)
+      if mode then
+        let open Location in
+        if p2.ppat_loc.loc_end < p1.ppat_loc.loc_start then 1
+        else if p1.ppat_loc.loc_end < p2.ppat_loc.loc_start then -1
+        else 0
+      else
+        (* false : e1 と e2 の一致度 *)
+        (* 1 : 完全一致 *)
+        (* 0 : 部分一致 *)
+        (* -1 : 不一致 *)
+        if p1 = p2 then 1
+        else if p1.ppat_loc = p2.ppat_loc then 0
+        else -1
+
+    let check_loc patt slice = patt.ppat_loc = slice.ppat_loc
+    let check patt = check_loc wildcard patt
+
+    let enop p = if check p then None else Some p
+    let deop pop = match pop with None -> wildcard | Some p -> p
+
+    let map f patt =
+
+      let f1 map1 fd xs p =
+        {patt with
+          ppat_desc =
+            fd (List.map (map1 f Map.id) xs)
+               (if check p then p else f p)}
+
+      and f2 fd p1 p2 pop =
+        {patt with
+          ppat_desc =
+            fd (f p1) (f p2)
+               (if pop = None then None else enop (f (deop pop)))} in
+
+      if leaf patt then patt
+      else
+        match patt.ppat_desc with
+        | Ppat_alias (p, str) ->
+           f1 Map.p1 (p_alias str) [] p
+        | Ppat_tuple (ps) ->
+           f1 Map.p1 p_tuple ps wildcard
+        | Ppat_construct (lid, Some p) ->
+           f1 Map.p1 (p_construct lid) [] p
+        | Ppat_variant (l, Some p) ->
+           f1 Map.p1 (p_variant l) [] p
+        | Ppat_record (ls, flg) ->
+           f1 Map.lp (p_record flg) ls wildcard
+        | Ppat_array (ps) ->
+           f1 Map.p1 p_array ps wildcard
+        | Ppat_or (p1, p2) ->
+           f2 (fun p1 p2 _ -> p_or p1 p2) p1 p2 None
+        | Ppat_constraint (p, ct) ->
+           f1 Map.p1 (p_constraint ct) [] p
+        | _ -> failwith "not supported."
+
+    let rec map_all f patt =
+      if leaf patt then f patt
+      else f (map (map_all f) patt)
+
+    let fold f init patt =
+      let f0 p =
+        if check p then init else f init p in
+      let f1 p_in_x xs p = 
+        List.fold_left f (f0 p) (List.map p_in_x xs)
+      and f2 p1 p2 pop = f (f (f0 (deop pop)) p2) p1 in
+
+      match patt.ppat_desc with
+      | Ppat_alias (p, _) -> f0 p
+      | Ppat_tuple (ps) -> f1 Map.id ps wildcard
+      | Ppat_construct (_, Some p) -> f0 p
+      | Ppat_variant (_, Some p) -> f0 p
+      | Ppat_record (ls, _) -> f1 snd ls wildcard
+      | Ppat_array (ps) -> f1 Map.id ps wildcard
+      | Ppat_or (p1, p2) -> f2 p1 p2 None
+      | Ppat_constraint (p, _) -> f0 p
+      | _ -> init
+
+    let rec fold_all f init patt =
+      if leaf patt then f init patt
+      else f (fold (fold_all f) init patt) patt
+
+    let replace patt p =
+      if patt.ppat_loc = p.ppat_loc then patt else p
+
+    let find' name pat = match pat.ppat_desc with
+        Ppat_var {txt} -> txt = name
+      | Ppat_alias (_, {txt}) -> txt = name
+      | Ppat_unpack {txt} -> txt = name
+      | _ -> false
+
+    let rec find name pat =
+      if find' name pat then pat
+      else if leaf pat then wildcard
+      else
+        fold (
+          fun pat' p ->
+            if pat' = wildcard then
+              find name p
+            else
+              pat'
+        ) wildcard pat
+
+    let complete ((pat, cxt), env, prefix) =
+      if print_slice then
+        Format.fprintf ppf "@[Pat.complete : %a@]@."
+             Pprintast.pattern pat;
+
+      match pat.ppat_desc with
+      | Ppat_record (lps, flg) ->
+          (* レコード *)
+          (* 足りないフィールドを補う *)
+          (* あるいは、型の情報を記録 *)
+          let (pat, lps') =
+            try
+(*
+type 'a context_t =
+  ('a * expr_context) * Env.t * (structure_item * Env.t) list
+*)
+              let dummy_record =
+                Exp.record
+                  (List.map (fun (l, _) -> (l, skeleton')) lps) (Some skeleton') in
+
+              if print_slice then
+                Format.fprintf ppf "@[dummy_record : %a@]@."
+                  Pprintast.expression dummy_record;
+
+              let (_, exp_typ) = judge ((dummy_record, cxt), env, prefix) in
+
+              if print_slice then
+                Format.fprintf ppf "@[  make dummy labels: type %a @]@."
+                  Printtyp.type_expr exp_typ;
+
+              let dummy_lps =
+                List.map (
+                  fun {pld_name = {txt = t; loc = l}} ->
+                    ({txt = Longident.parse t; loc = l}, wildcard)
+                ) (decode_labels exp_typ prefix) in
+
+
+              (Ast_helper.Pat.attr pat (Attr.of_type "type" exp_typ),
+              List.fold_left (
+                fun lst (ln, pn) ->
+                  List.map (
+                    fun (lm, pm) ->
+                      if Longident.last lm.txt = Longident.last ln.txt
+                      then (ln, pn) else (lm, pm)) lst
+              ) dummy_lps lps)
+            with
+              _ -> (pat, lps) in
+
+          pattern (p_record flg lps' wildcard) pat
+
+    | _ -> pat (* その他はそのまま *)
+
+  end
+
+  (* expression *)
+  module Exp = struct
+    type t = expression
+    let internal e0 e1 = internal e0.pexp_loc e1.pexp_loc
+
+    let node b {pexp_desc} = match pexp_desc with
+      | Pexp_ident _ | Pexp_constant _ -> b (* leaf : yes *)
+      | Pexp_construct (_, None) | Pexp_variant (_, None) -> b (* leaf : yes *)
+      | _ -> not b (* leaf : no *)
+
+    let leaf e = node true e
+
+    let comp ?(mode = false) e1 e2 =
+      if mode then
+        (* true : 位置情報の比較 *)
+        (* 1 : e1 のほうが後 *)
+        (* 0 : 内包 *)
+        (* -1 : e2 のほうが後 *)
+        let open Location in
+        if e2.pexp_loc.loc_end < e1.pexp_loc.loc_start then 1
+        else if e1.pexp_loc.loc_end < e2.pexp_loc.loc_start then -1
+        else 0
+      else
+        (* false : e1 と e2 の一致度 *)
+        (* 1 : 完全一致 *)
+        (* 0 : 部分一致 *)
+        (* -1 : 不一致 *)
+        if e1 = e2 then 1
+        else if e1.pexp_loc = e2.pexp_loc then 0
+        else -1
+
+    let map f expr =
+
+      let f1 map1 fd xs e =
+        {expr with
+          pexp_desc =
+            fd (List.map (map1 f Map.id) xs)
+               (if Hole.check_skeleton e then e else f e)}
+
+      and f2 fd e1 e2 eop =
+        {expr with
+          pexp_desc =
+            fd (f e1) (f e2)
+               (if eop = None then None else enop (f (deop eop)))} in
+
+      if leaf expr then expr
+      else
+        match expr.pexp_desc with
+        | Pexp_let (flg, vs, e) ->
+           f1 Map.v1 (pexp_let flg) vs e
+        | Pexp_function (cs) ->
+           f1 Map.c1 pexp_function cs skeleton'
+        | Pexp_fun (l, eop, p, e) ->
+           f1 Map.e1 (pexp_fun l eop p) [] e
+        | Pexp_apply (e, les) ->
+           f1 Map.le pexp_apply les e
+        | Pexp_match (e, cs) ->
+           f1 Map.c1 pexp_match cs e
+        | Pexp_try (e, cs) ->
+           f1 Map.c1 pexp_try cs e
+        | Pexp_tuple (es) ->
+            f1 Map.e1 pexp_tuple es skeleton'
+        | Pexp_construct (lid, Some e) ->
+           f1 Map.e1 (pexp_construct lid) [] e
+        | Pexp_variant (l, Some e) ->
+           f1 Map.e1 (pexp_variant l) [] e
+        | Pexp_record (ls, eop) ->
+           f1 Map.le pexp_record ls (deop eop)
+        | Pexp_field (e, lid) ->
+           f1 Map.e1 (pexp_field lid) [] e
+        | Pexp_setfield (e1, lid, e2) ->
+           f2 (pexp_setfield lid) e1 e2 None
+        | Pexp_array (es) ->
+           f1 Map.e1 pexp_array es skeleton'
+        | Pexp_ifthenelse (e1, e2, eop) ->
+           f2 pexp_ifthenelse e1 e2 eop
+        | Pexp_sequence (e1, e2) ->
+           f2 pexp_sequence e1 e2 None
+        | Pexp_constraint (e, ct) ->
+           f1 Map.e1 (pexp_constraint ct) [] e
+        | Pexp_assert (e) ->
+           f1 Map.e1 pexp_assert [] e
+        | Pexp_send _ -> failwith "#use"
+        | _ -> failwith "not supported."
+
+    let rec map_all f expr =
+      if leaf expr then f expr
+      else f (map (map_all f) expr)
+
+    let fold f init expr =
+      let f0 e =
+        if Hole.check_skeleton e then init else f init e in
+      let f1 e_in_x xs e = 
+        List.fold_left f (f0 e) (List.map e_in_x xs)
+      and f2 e1 e2 eop = f (f (f0 (deop eop)) e2) e1 in
+
+      match expr.pexp_desc with
+      | Pexp_let (_, vs, e) -> f1 Map.e_in_v vs e
+      | Pexp_function (cs) -> f1 Map.e_in_c cs skeleton'
+      | Pexp_fun (_, _, _, e) -> f0 e
+      | Pexp_apply (e, ls) -> f1 snd ls e
+      | Pexp_match (e, cs) -> f1 Map.e_in_c cs e
+      | Pexp_try (e, cs) -> f1 Map.e_in_c cs e
+      | Pexp_tuple (es) -> f1 Map.id es skeleton'
+      | Pexp_construct (_, Some e) -> f0 e
+      | Pexp_variant (_, Some e) -> f0 e
+      | Pexp_record (ls, eop) ->
+         f1 snd ls (deop eop)
+      | Pexp_field (e, _) -> f0 e
+      | Pexp_setfield (e1, _, e2) -> f2 e1 e2 None
+      | Pexp_array (es) -> f1 Map.id es skeleton'
+      | Pexp_ifthenelse (e1, e2, eop) -> f2 e1 e2 eop
+      | Pexp_sequence (e1, e2) -> f2 e1 e2 None
+      | Pexp_constraint (e, _) -> f0 e
+      | Pexp_assert (e) -> f0 e
+      | _ -> init
+
+    let rec fold_all f init expr =
+      if leaf expr then f init expr
+      else f (fold (fold_all f) init expr) expr
+
+    let replace e expr =
+      if e.pexp_loc = expr.pexp_loc then e else expr
+
+    let restore les expr = match expr.pexp_desc with
+      | Pexp_tuple _ ->
+          {expr with pexp_desc = Pexp_tuple (List.map snd les)}
+      | Pexp_array _ ->
+          {expr with pexp_desc = Pexp_array (List.map snd les)}
+      | Pexp_construct (lid, Some e) ->
+          let e' = match les with
+              (_, e_) :: [] -> e_
+            | _ ->
+                {e with pexp_desc = Pexp_tuple (List.map snd les)} in
+          {expr with pexp_desc = Pexp_construct (lid, Some e')}
+      | Pexp_ifthenelse _ ->
+          let (e_if, e_then, e_else) = match les with
+            | (_, e_if') :: (_, e_then') :: (_, e_else') :: [] ->
+                (e_if', e_then', Some e_else')
+            | (_, e_if') :: (_, e_then') :: [] ->
+                (e_if', e_then', None)
+            | _ -> raise Not_found in
+          {expr with pexp_desc = Pexp_ifthenelse (e_if, e_then, e_else)}
+      | _ -> raise Not_found
+
+    let rec value_bindings ((vs, cxt), env, prefix) = match vs with
+      | [] -> []
+      | vn :: rest ->
+          (* let v1 fe fp v *)
+          let vn' =
+            Map.v1 Map.id
+              (flat Pat.complete prefix env cxt) vn in
+          let vn' =
+            try
+              let (_, tp) = judge ((
+                  Ast_helper.Exp.let_ Nonrecursive
+                    [{vn' with pvb_pat = Ast_helper.Pat.var (mknoloc "◆")}]
+                    (Ast_helper.Exp.ident
+                       {txt = (Longident.parse "◆"); loc = Location.none}
+                       ), cxt), env, prefix) in
+              if print_slice then
+                Format.fprintf ppf "@[Vb.complete : %a@]@."
+                  Printtyp.type_expr tp;
+              {vn' with pvb_pat = {vn'.pvb_pat with ppat_attributes = [Attr.of_type "vb" tp]}}
+            with
+              _ -> vn' in
+
+          (* vn のみで定義した関数がエラーになるかどうかをチェック *)
+          let rest' = value_bindings ((rest, cxt), env, prefix) in
+          try
+            ignore (
+              Typemod.type_structure
+                env [Ast_helper.Str.value Recursive [vn']] Location.none);
+            (* エラーにならない *)
+            vn' :: rest'
+          with
+          | _ ->
+              (* エラーになる *)
+              rest' @ [vn']
+
+    let cases ((cs, cxt), env, prefix) =
+
+      (* case の pattern に型を与える *)
+      List.map (
+        Map.c1 Map.id
+          (flat Pat.complete prefix env cxt)
+      ) cs
+
+    let complete ((expr, cxt), env, prefix) =
+      if print_slice then
+        Format.fprintf ppf "@[Exp.complete : %a@]@."
+             Pprintast.expression expr;
+      let flat' f x =
+        f ((x, cxt), env, prefix) in
+      let pat' p =
+        flat' Pat.complete p in
+      let set fd fx ?(e = Hole.exp) xs =
+        to_exp fd (fx xs) e expr in
+
+      match expr.pexp_desc with
+      | Pexp_fun (l, eop, p, e) ->
+          let desc = pexp_fun l eop (pat' p) [] e in
+          expression desc expr
+
+      | Pexp_let (flg, vs, e) ->
+          (* let文 *)
+          set (e_let flg) (flat' (value_bindings)) ~e vs
+
+      | Pexp_function cs ->
+          (* function | P1 -> E1 | ... *)
+          (* csに含まれるパターン全てに対して同じように処理する *)
+          set e_function (flat' cases) cs
+
+      | Pexp_match (e, cs) ->
+          (* match E0 with P1 -> E1 | ... *)
+          (* csに含まれるパターン全てに対して同じように処理する *)
+          set e_match (flat' cases) ~e cs
+
+      | Pexp_try (e, cs) ->
+          (* try E0 with P1 -> E1 | ... *)
+          (* csに含まれるパターン全てに対して同じように処理する *)
+          set e_try (flat' cases) ~e cs
+
+      | Pexp_construct (lid, Some (e)) ->
+          set (e_construct lid) Map.id ~e []
+
+      | _ -> expr
+
+    let origin e = match List.find (
+        fun ({txt}, _) -> txt = "dummy"
+      ) e.pexp_attributes with
+    | (_, PStr ({pstr_desc = Pstr_eval (slice, _)} :: _)) -> slice
+    | _ -> raise Not_found
+
+    let rec clear expr = match expr.pexp_desc with
+      | Pexp_apply (e, les) ->
+          let expr' =
+            try
+              restore les (origin e)
+            with _ -> expr in
+          clear' expr'
+      | _ -> clear' expr
+
+    and clear' expr = {(map clear expr) with pexp_attributes = []}
+
+  end
+
+  module Str = struct
+    let clear' item = match item.pstr_desc with
+      | Pstr_eval (slice, attr) ->
+          {item with
+           pstr_desc =
+             Pstr_eval
+               (Exp.clear slice, attr)}
+      | Pstr_value (flg, vs) ->
+          {item with
+           pstr_desc =
+             Pstr_value
+               (flg, List.map (
+                   fun v ->
+                     {v with
+                      pvb_expr = Exp.clear v.pvb_expr}) vs)}
+      | _ -> item
+    let clear structure = List.map clear' structure
+
+    let output name structure =
+      let file = open_out name in
+      output_string file
+        (Pprintast.string_of_structure structure);
+      close_out file
+
+  end
+
+  module Vb = struct
+    let complete = Exp.value_bindings
+  end
+(*
+  let restore = Exp.restore
+  let origin = Exp.origin
+*)
+end
+
+module Size = struct
+
+  module type Typ =
+    sig
+      type t
+      val get : t -> int
+      val set : t -> t
+      val reset : int -> t -> t
+      val comp : ?e':t -> t -> int
+    end
+
+  module Exp = struct
+    type t = expression
+
+    let get' n {pexp_attributes = attrs} =
+      List.fold_left (
+          fun n attr ->
+          try
+            let m = Attr.to_size attr in
+            m + n
+          with
+            _ -> n
+        ) n attrs
+
+    (* get : expression -> int *)
+    (* expr の size を取得 *)
+    let get expr = get' 0 expr
+
+    let set' ?(sel = false) n ({pexp_attributes = attrs} as expr) =
+      let attrs' =
+        List.map (
+            fun attr ->
+            try
+              let m = Attr.to_size attr in
+              Attr.of_size (abs m |> if sel then (-) n else (+) n)
+            with
+              _ -> attr
+          ) attrs in
+      if attrs = attrs' then
+        Ast.Exp.attr expr (Attr.of_size n)
+      else
+        {expr with pexp_attributes = attrs'}
+
+    (* Size.Exp.set と f を同時に処理する *)
+    let rec set_and f expr =
+      if Desc.Exp.leaf expr then
+        set' 1 expr
+      else
+        let expr' = Desc.Exp.map (set_and f) (f expr) in
+        let n = Desc.Exp.fold get' 1 expr' in
+        set' n expr'
+
+    let rec set expr =
+      if Desc.Exp.leaf expr then
+        set' 1 expr
+      else
+        let expr' = Desc.Exp.map set expr in
+        let n = Desc.Exp.fold get' 1 expr' in
+        set' n expr'
+
+    let reset n expr =
+      {expr with
+        pexp_attributes =
+          List.map (
+              fun attr ->
+              try
+                let _ = Attr.to_size attr in
+                Attr.of_size n
+              with
+                _ -> attr
+            ) expr.pexp_attributes}
+
+    let comp ?(e' = skeleton') e =
+      let n' = if e' = skeleton' then 1 else get e' and n = get e in
+      compare n' n
+
+  end
+
+
+  (*  let set_size = true *)
+  let set_resize = true
+
+  (* size を求める関数 *)
+  let get' n (*_, payload*) attr =
+    try
+      let m = Attr.to_size attr in
+      m + n
+    with
+      _ -> n
+
+  (* get int ->  expression -> int *)
+  let get n {pexp_attributes = attrs} =
+    List.fold_left get' n attrs
+
+
+  (* 比較関数 *)
+  (* comp1 : e の size と 1 を比較 *)
+  let comp1 e = compare (get 0 e) 1
+(*
+  (* is1 : sizeが1でtrue *)
+  let is1 e = comp1 e = 0
+
+  (* fltr1 : size が2以上 *)
+  let fltr1 e = 1 = comp1 e
+*)
+  (* fltr0 : sizeが1以上でtrue *)
+  let fltr0 e = 0 <= comp1 e
+
+  (* comp2 : e1 と e2 の、m までの距離を比較 *)
+  let comp2 m e1 e2 =
+    if comp1 e1 < 0 then 1
+    else if comp1 e2 < 0 then -1
+    else
+      let get_dist e = abs (m - get 0 e) in
+      compare (get_dist e1) (get_dist e2)
+
+  let get_one e = get 0 e
+(*
+  (* ある式のサイズをセットする *)
+  let set' ?(sel = false) n ({pexp_attributes = attrs} as expr) =
+    let attrs' =
+      List.map (
+          fun attr ->
+          try
+            let m = Attr.to_size attr in
+            Attr.of_size (abs m |> if sel then (-) n else (+) n)
+          with
+            _ -> attr
+        ) attrs in
+    if attrs = attrs' then
+      (* 追加 *)
+      (* 【旧バージョン】 *)
+      (* Exp.attr expr (mknoloc "size", Size n) *)
+      (* 【新バージョン】 *)
+      Ast.Exp.attr expr (Attr.of_size n)
+    else
+      (* 上書き *)
+      {expr with pexp_attributes = attrs'}
+
+  (* size を set する *)
+  let rec set expr =
+    if Desc.Exp.leaf expr then
+      (* 子ノードなし *)
+      set' 1 expr
+    else
+      (* 子ノードあり *)
+      let expr' = Desc.Exp.map set expr in
+      let n = Desc.Exp.fold get 1 expr' in
+      set' n expr'
+      *)
+  (* reset' : expr の size を n にする *)
+  let reset' n expr =
+    {expr with
+      pexp_attributes =
+        List.map (
+            fun attr ->
+            try
+              let _ = Attr.to_size attr in
+              Attr.of_size n
+            with
+              _ -> attr
+          ) expr.pexp_attributes}
+
+  let reset expr = reset' 0 expr
+      (*
+  let reset1 x expr =
+    reset' (get (x 0 1) expr) expr
+
+  let rec resize expr =
+
+    if Desc.Exp.leaf expr then expr
+
+    else
+      (* 未確定の子ノード *)
+      let children =
+        Desc.Exp.fold
+          (fun es e -> if fltr0 e then e :: es else es) [] expr in
+      match children with
+        [] -> reset expr
+      | first :: rest ->
+         let map f = Desc.Exp.map f expr in
+         let (n, expr') =
+           if rest = [] then
+             let e' = resize first in
+             (get_one e', map (fun e -> if first = e then e' else e))
+           else
+             let expr'' =
+               map (fun e -> if List.mem e children then resize e else e) in
+             (Desc.Exp.fold get 1 expr'', expr'') in
+         reset' n expr'
+
+  (* 確定させる *)
+  let terminated expr = set' ~sel:true 0 expr
+
+  (* terminated check *)
+  (* すべての式が terminated であれば true *)
+  let check' init expr = init && not (fltr0 expr)
+  let check expr = Desc.Exp.fold_all check' true expr
+*)
+  (* 子ノード *)
+  let children expr =
+    (* expr の半分に近いノードから昇順にソート *)
+    let children' =
+      Desc.Exp.fold (
+          fun acc exp ->
+          acc @ if fltr0 exp then [exp] else []) [] expr in
+    let comp' = comp2 ((get 2 expr) / 2) in
+
+    (* ソート *)
+    List.sort comp' children'
+
+  (*  let term_hole e = terminated (hole_of_exp e) *)
+  let reset_hole e = reset (hole_of_exp e)
+
+(*
+  let get_childNoResize expr =
+
+    (* 式exprのサイズ *)
+    let n = get_one expr in
+
+    if n = 1 then
+      (expr, Map.id, term_hole)
+
+    else
+
+    (* 比較関数 *)
+    let comp_child exp' exp =
+      if fltr0 exp && comp2 (n / 2) exp' exp >= 0 then exp else exp' in
+
+    let expr_cxt_one e' =
+      Desc.Exp.map_all (
+          fun e ->
+          if e = e' then term_hole e
+          else if Hole.check_loc e e' then e'
+          else e
+        ) expr in
+
+
+    let rec get_childNoResize' expr_cxt_expect expr' =
+      let child = Desc.Exp.fold comp_child expr' expr' in
+      if child = expr' then
+        (expr', expr_cxt_expect, expr_cxt_one)
+      else
+        let expr_cxt_expect' e' =
+          expr_cxt_expect (
+              Desc.Exp.map (
+                  fun e ->
+                  if Hole.check_loc e e'
+                  then e'
+                  else if fltr0 e then term_hole e
+                  else e) expr') in
+        get_childNoResize' expr_cxt_expect' child in
+
+    get_childNoResize' Map.id expr
+
+  let reset_hole e = reset (hole_of_exp e)
+
+  let get_childWithResize expr =
+
+    let n = get_one expr in
+
+    if Desc.Exp.leaf expr then
+      (* 子ノードなし *)
+      (expr, reset_hole, reset_hole)
+
+    else
+      let comp_child exp' exp =
+        if 0 <= comp2 (n / 2) exp' exp && fltr0 exp then exp else exp' in
+      let rec get_childWithResize' expr_cxt_expect expr' =
+        let child = Desc.Exp.fold comp_child expr' expr' in
+        if child = expr' then
+          let expr_cxt_one e' =
+            let slice =
+              Desc.Exp.map_all (
+                  fun e ->
+                  if e = e' then reset_hole e
+                  else if Hole.check_loc e e' then e' else e
+                ) expr in
+            resize slice in
+          (expr', expr_cxt_one, expr_cxt_expect)
+        else
+          let expr_cxt_expect' e' =
+            let n = get_one e' in
+            let slice = match expr'.pexp_desc with
+              | Pexp_apply (e, les) when Hole.check_loc e e' && n = 1 ->
+                 let les' =
+                   List.map (
+                       fun (ln, en) ->
+                       (ln, if fltr0 en then reset_hole e else e)
+                     ) les in
+                 {expr' with pexp_desc = Pexp_apply (e', les')} |> reset
+              | _ ->
+                 Desc.Exp.map (
+                     fun e ->
+                      if Hole.check_loc e e' then e'
+                      else if fltr0 e then reset_hole e
+                      else e
+                   ) expr' |> reset' n in
+            expr_cxt_expect slice in
+
+          get_childWithResize' expr_cxt_expect' child in
+
+      get_childWithResize' Map.id expr
+
+  let expect expr' e' =
+    Desc.Exp.map (
+        fun e ->
+        if Hole.check_loc e e' then e'
+        else if fltr0 e then reset_hole e
+        else e) expr'
+
+  let getChild _ getChild' expr_cxt_expect expr =
+
+    if Desc.Exp.leaf expr then
+      (expr, reset, reset_hole)
+
+    else
+      (* 探索とresize を同時に行う *)
+      let expr_cxt_one e =
+        let open Location in
+        let rec expr_cxt_one' e' =
+          (* 式のサイズ *)
+          let n = ref 1 in
+          let expr' =
+            Desc.Exp.map (
+                fun e'' ->
+                if e = e'' then reset_hole e''
+                else
+                  let expr'' =
+                    if e.pexp_loc = e''.pexp_loc then e
+                    else if
+                      e.pexp_loc.loc_end < e''.pexp_loc.loc_start
+                      || e''.pexp_loc.loc_end < e.pexp_loc.loc_start then e''
+                    else
+                      expr_cxt_one' e'' in
+                  n := get !n expr''; expr''
+              ) e' in
+          if !n = 1 then n := 0;
+          reset' !n expr' in
+        expr_cxt_one' expr in
+
+      getChild' expr_cxt_expect expr_cxt_one expr
+*)
+  let rec getChildSet' fltr3 fltr2 fltr' (expr', abst') =
+
+    let return () =
+      (expr', fun sel expr_cxt e -> expr_cxt (abst' sel e)) in
+
+    if fltr' expr' then
+      return ()
+    else
+      let comp e' e =
+        if fltr3 expr' e' e then
+          if fltr0 e then e else e'
+        else
+          if fltr2 e' e then e else e' in
+      let child = Desc.Exp.fold comp expr' expr' in
+      if child = expr' then
+        return ()
+      else
+        match expr'.pexp_desc with
+
+        | Pexp_construct (lid, Some ({pexp_desc = Pexp_tuple es} as en)) ->
+           let child'' = List.fold_left comp skeleton' es in
+           if child'' = skeleton' then
+             return ()
+           else
+             let abst sel e =
+               let m = ref 1 in
+               let set' e' = m := get !m e'; e' in
+
+               let expr'' =
+                 let sr sel' e' = if sel' then set' e' else reset_hole e' in
+                 let en' =
+                   Desc.Exp.map (
+                       fun e' ->
+                       match Desc.Exp.comp e e' with
+                       | 0 -> set' e
+                       | 1 -> sr sel e'
+                       | _ ->
+                          if Desc.Exp.comp ~mode:true e e' = 0 then set' e'
+                          else sr (not sel) e'
+                     ) en in
+
+                 if !m = 1 then m := 0;
+                 {expr' with
+                   pexp_desc =
+                     Pexp_construct (lid, Some (reset' !m en'))} in
+               if 0 < !m then m := !m + 1;
+               abst' sel (reset' !m expr'') in
+             getChildSet' fltr3 fltr2 fltr' (child'', abst)
+ 
+        | _ ->
+           (* construct の場合分けを追加する *)
+           let abst sel e =
+             let m = ref 1 in
+             let set' e' = m := get !m e'; e' in
+             let sr sel' e' = if sel' then set' e' else reset_hole e' in
+             let expr'' =
+               Desc.Exp.map (
+                   fun e' ->
+                   match Desc.Exp.comp e e' with
+                   | 1 -> sr sel e'
+                   | 0 -> set' e
+                   | _ ->
+                      if Desc.Exp.comp ~mode:true e e' = 0 then set' e'
+                      else sr (not sel) e'
+                 ) expr' in
+             if !m = 1 then m := 0;
+             abst' sel (reset' !m expr'') in
+           getChildSet' fltr3 fltr2 fltr' (child, abst)
+
+  let getChildSet expr =
+
+    let n = get_one expr / 2 in
+    let fltr3 expr' e' _ = expr' = e'
+    and fltr2 e' e = get_one e' < get_one e
+    and fltr' expr' = get_one expr' < n in
+    getChildSet' fltr3 fltr2 fltr' (expr, fun _ e -> e)
+
+  let getChildSet2 expr =
+    let n = get_one expr / 2 in
+    let fltr3 _ e' e = 0 <= comp2 n e' e
+    and fltr2 _ _ = false
+    and fltr' _ = false in
+    getChildSet' fltr3 fltr2 fltr' (expr, fun _ e -> e)
+(*
+  (* resize あり *)
+  let getChild2 expr =
+
+    let n = get_one expr in
+    let comp_child exp' exp =
+      if 0 <= comp2 (n / 2) exp' exp && fltr0 exp then exp else exp' in
+
+    let rec getChild' expr_cxt_expect expr_cxt_one expr' =
+      
+      let child = Desc.Exp.fold comp_child expr' expr' in
+
+      if child = expr' then
+        (expr', expr_cxt_expect, expr_cxt_one)
+
+      else
+        match expr'.pexp_desc with
+
+        | Pexp_construct (lid, Some {pexp_desc = Pexp_tuple es}) ->
+
+           let child' =
+             List.fold_left comp_child (reset child) es in
+           if child' = reset child then
+             (expr', expr_cxt_expect, expr_cxt_one)
+
+           else
+             let expr_cxt_expect' e' =
+               {expr' with
+                 pexp_desc =
+                   Pexp_construct (lid, Some (expect child e'))
+               } |> expr_cxt_expect |> reset' (get_one e') in
+             getChild' expr_cxt_expect' expr_cxt_one child'
+
+        | _ ->
+           let expr_cxt_expect' e' =
+             expect expr' e' |> expr_cxt_expect |> reset' (get_one e') in
+           getChild' expr_cxt_expect' expr_cxt_one child in
+
+    getChild true getChild' resize expr
+
+  let getChild3 expr =
+
+    let n = get_one expr in
+
+    let rec resize expr =
+
+      if Desc.Exp.leaf expr || get 0 expr = 0 then expr
+
+      else if fltr0 expr then
+        let expr' = Desc.Exp.map resize expr in
+        reset' (Desc.Exp.fold get 1 expr') expr'
+
+      else
+        let children =
+          Desc.Exp.fold (
+              fun acc e ->
+              if hole_of_exp e = e then acc else e :: acc
+            ) [] expr in
+
+        match expr.pexp_desc with
+
+        | Pexp_apply (e, les) when children = [] ->
+
+           reset_hole
+             {expr with
+               pexp_desc =
+                 Pexp_apply
+                   (Hole.to_exp e,
+                    List.map (
+                        fun (l', e') -> (l', Hole.to_exp e')
+                      ) les)}
+
+         | _ ->
+            reset expr in
+
+    let expect' expr_cxt_expect expr' e' =
+      expect expr' e' |> expr_cxt_expect in
+
+    let comp_child exp' exp =
+      if 0 <= comp2 (n / 2) exp' exp && fltr0 exp then exp else exp'
+
+    and expr_cxt_one e' =
+      let slice =
+        Desc.Exp.map_all (
+            fun e ->
+            if e = e' then reset_hole e
+            else if Hole.check_loc e e' then e' else e
+          ) expr in
+      resize slice in
+
+    let rec getChild' expr_cxt_expect expr' =
+
+      let child = Desc.Exp.fold comp_child expr' expr' in
+
+      if child = expr' then
+        (expr', expr_cxt_expect, expr_cxt_one)
+
+      else
+        match expr'.pexp_desc with
+
+        | Pexp_fun _ when (
+          match child.pexp_desc with
+          | Pexp_fun _ -> true
+          | _ -> false) ->
+           (* fun文 *)
+           (child, expect' expr_cxt_expect expr', expr_cxt_one)
+
+        | Pexp_let (_, vs, _) when (
+          match child.pexp_desc with
+          | Pexp_fun _ -> List.exists (fun {pvb_expr} -> pvb_expr = child) vs
+          | _ -> false) ->
+           (* let文 *)
+           (child, expect' expr_cxt_expect expr', expr_cxt_one)
+
+        | Pexp_construct (lid, Some {pexp_desc = Pexp_tuple es}) ->
+           (* construct *)
+
+           let child' =
+             List.fold_left comp_child child es in
+           if child' = child then
+             (expr', expr_cxt_expect, expr_cxt_one)
+           else
+             let expr_cxt_expect' e' =
+               {expr' with
+                 pexp_desc =
+                   Pexp_construct (lid, Some (expect child e'))
+               } |> expr_cxt_expect in
+             getChild' expr_cxt_expect' child'
+
+        | _ ->
+           getChild' (expect' expr_cxt_expect expr') child in
+
+    getChild' resize expr
+
+
+  (* get_child : expression -> expression * (expression -> expression) *)
+  (* 式 expr のサイズ n の半分に最も近い子ノードを探す *)
+  let get_child =
+    if set_resize then get_childWithResize else get_childNoResize
+
+
+  (* size を与える関数 *)
+  (* set_one : ?n:int -> expression -> expression *)
+  let set_one ?(n = 1) slice =
+    if set_size then
+      (* Exp.attr slice (mknoloc "size", Size n) *)
+      let open Ast in
+      Exp.attr slice (mknoloc "size", PPat (Pat.constant (Const.int n), None))
+    else slice
+
+  (* set_all : ('a list -> 'a list -> expression ->
+                 ('a list -> expression -> expression_desc) -> expression)
+                -> ('a list -> expression -> expression_desc)
+                -> ('a -> expression) -> 'a list -> expression
+                -> expression *)
+  let set_all fp fd fx acc s_all =
+    if set_size then
+      let n = List.fold_left
+                (fun n x -> get n (fx x))
+                (get 1 s_all) acc in
+      set_one ~n (fp acc [] s_all fd)
+    else (fp acc [] s_all fd)
+
+  let compare_size m e1 e2 =
+    compare (abs (m - get 0 e1)) (abs (m - get 0 e2))
+
+  (* 親ノードのサイズを取得して、子ノードの式を半分に近い順に並び替える *)
+  let node_sort expr =
+
+    let m = (get 2 expr) / 2 in (* 親のサイズの半分 *)
+    let sort_size es = List.stable_sort (compare_size m) es in
+
+    match expr.pexp_desc with
+    | Pexp_ident _ | Pexp_constant _ -> sort_size [expr]
+
+    | Pexp_let (_, vs, e) ->
+       sort_size (e :: List.map (fun v -> v.pvb_expr) vs)
+    | Pexp_function (cs) ->
+       sort_size (List.map (fun c -> c.pc_rhs) cs)
+    | Pexp_fun (_, eop, _, e) ->
+       sort_size (match eop with None -> [e] | Some e' ->[e; e'])
+    | Pexp_apply (e, les) ->
+       sort_size (e :: List.map snd les)
+    | Pexp_match (e, cs) ->
+       sort_size (e :: List.map (fun c -> c.pc_rhs) cs)
+    | Pexp_try (e, cs) ->
+       sort_size (e :: List.map (fun c -> c.pc_rhs) cs)
+    | Pexp_tuple (es) -> sort_size es
+    | Pexp_construct (_, Some {pexp_desc = Pexp_tuple es}) -> sort_size es
+    | Pexp_construct (_, Some e) -> [e]
+    | Pexp_variant (_, Some e) -> [e]
+    | Pexp_record (les, eop) ->
+       sort_size ((List.map snd les)
+                  @ match eop with None -> [] | Some e -> [e])
+    | Pexp_field (e, _) -> [e]
+    | Pexp_setfield (e1, _, e2) -> sort_size [e1; e2]
+    | Pexp_array (es) -> sort_size es
+    | Pexp_ifthenelse (e1, e2, eop) ->
+       sort_size (e1 :: e2
+                  :: match eop with None -> [] | Some e3 -> [e3])
+    | Pexp_sequence (e1, e2) -> sort_size [e1; e2]
+    | Pexp_constraint (e, _) -> [e]
+    | Pexp_send (e, _) -> [e] 
+    | _ -> []
+*)
+end
+
+(*
+module Abst = struct
+  (* 抽象化 *)
+  module type Typ =
+    sig
+      type t
+      val hole : t -> t
+    end
+
+  module Exp = struct
+    type t = expression
+    let hole = Hole.of_exp
+  end
+
+(*
+
+  let rec slice_of_exp' expr =
+    let open Location in
+    let (filename', start_line', start_char') =
+      get_pos_info expr.pexp_loc.loc_start
+    and (_, end_line', end_char') =
+      get_pos_info expr.pexp_loc.loc_end  in
+
+    Format.fprintf ppf "@[(%s, %d, %d, %d, %d) <- %a@]@."
+      filename' start_line' start_char' end_line' end_char'
+      Pprintast.expression expr;
+
+    (* 該当する情報を探す *)
+    let {ghost = ghost'} =
+      List.find (fun {start_line; start_char;
+                      end_line; end_char;
+                      filename; ghost} ->
+          start_line = start_line'
+          && start_char = start_char'
+          && end_line = end_line'
+          && end_char = end_char'
+          && filename = filename'
+          && expr.pexp_loc.loc_ghost = (ghost mod 2 = 1)) !log.slice in
+    
+    match expr.pexp_desc with
+    | Pexp_construct (lid, Some ({pexp_desc = Pexp_tuple es} as e))
+         when e.pexp_loc.loc_ghost ->
+       
+       if 1 < ghost' then
+         let les =
+           Format.fprintf ppf "@[make dummy : %a@]@."
+             Pprintast.expression expr;
+           List.map (fun e -> (Nolabel, slice_of_exp e)) es in
+         {expr with
+           pexp_desc =
+             Pexp_apply (hole_of_exp expr, les)}
+       else
+         let e' =
+           Format.fprintf ppf "@[slice : %a@]@."
+             Pprintast.expression expr;
+           {e with pexp_desc =
+                     Pexp_tuple (List.map slice_of_exp es)} in
+         {expr with
+           pexp_desc =
+             Pexp_construct (lid, Some e')}
+         
+    | _ ->
+       Format.fprintf ppf "@[slice : %a@]@."
+         Pprintast.expression expr;
+       (* そのまま *)
+       Desc.Exp.map slice_of_exp expr
+
+  and slice_of_exp expr =
+    try
+      slice_of_exp' expr
+    with
+      Not_found ->
+      Format.fprintf ppf "@[hole : %a@]@."
+        Pprintast.expression expr;
+      hole_of_exp expr
+
+*)
+
+  let hole_of_x map1 x = map1 hole_of_exp Map.id x
+
+  (* set_one : slice -> slice list *)
+  (* 部分的に抽象化 *)
+  let set_one exp =
+
+    let sn n en sel = if sel = n then hole_of_exp en else en in
+
+    (* リストが構文中にない場合 *)
+    (* e が □ でなければ exp の desc を置き換えた要素を abst に追加 *)
+    let set_some e ?(abst = []) desc =
+      
+      if e = hole_of_exp e then abst
+      else abst @ [Desc.expression desc exp] in
+
+    (* リストが構文中にある場合 *)
+    (* 再帰で要素をひとつひとつ抽象化 *)
+    let set_one' ?(es = []) ?(e = skeleton') map1 fd xs =
+     
+      let to_exp fd e xs = Desc.to_exp fd xs e exp in
+      let fde acc = List.map (to_exp fd e) (List.rev acc) in
+      let dummy_apply es =
+        Desc.e_apply (List.map (fun e -> (Nolabel, e)) es) skeleton' in
+      let rec set_some' acc forward backword = match backword with
+       | [] -> fde acc
+       | tar :: backword' ->
+          (* チェック済 *)
+          let forward' = forward @ [tar] in
+          (* tar を□で置き換えることを試みる *)
+          let dummy = hole_of_x map1  tar in
+          let acc' =
+            if tar = dummy then acc
+            else (forward @ (dummy :: backword')) :: acc in
+          set_some' acc' forward' backword' in
+
+      set_some
+        e ~abst:(set_some' [] [] xs)
+        (if es = [] then fd xs (hole_of_exp e) else dummy_apply es) in
+    
+    (* abst_one のメイン部分 *)
+    match exp.pexp_desc with
+
+    | Pexp_let (flg, vs, e) ->
+       (* let 文 *)
+       (* let x = S1 in S2 => [let x = □ in S2; let x = S1 in □] *)
+       set_one' ~e Map.v1 (Desc.e_let flg) vs
+
+    | Pexp_apply (e, les) ->
+       (* 関数適用 *)
+       (* @ S1 .. Sn => [=@ S1..Sn; @ □..Sn; ...; @ S1..□]  *)
+       set_one' ~e Map.le Desc.e_apply les
+
+    | Pexp_function (cs) ->
+       (* function *)
+       (* function P1 -> S1 | ... | Pn -> Sn =>
+       [function P1 -> □ | ... ; function ... | Pn -> □] *)
+       set_one' Map.c1 Desc.e_function cs
+
+    | Pexp_fun (l, eop, p, e) ->
+       (* fun *)
+       (* λx.S => λx.□ *)
+      set_one' ~e Map.e1 (fun _ e -> Desc.e_fun l eop p e) []
+
+    | Pexp_match (e, cs) ->
+       (* match 文 *)
+       (* パターンする式と結果のみを対象にしている *)
+       (* match S0 with P1 -> S1 | ... | Pn -> Sn =>
+       [match □ with ...; ... with P1 -> □ | ...; ... with ... | Pn -> □] *)
+       set_one' ~e Map.c1 Desc.e_match cs
+                
+    | Pexp_try (e, cs) ->
+       (* try 文 *)
+       (* パターンする式と結果のみを対象にしている *)
+       (* try S0 with P1 -> S1 | ... | Pn -> Sn =>
+       [try □ with ...; ... with P1 -> □ | ...; ... with ... | Pn -> □] *)
+       set_one' ~e Map.c1 Desc.e_try cs
+                
+    | Pexp_tuple (es) ->
+       (* tuple *)
+       (* (S1, ... Sn) => [(□, ... Sn); ... ; (S1, ..., □); @= S1 ,..., Sn] *)
+       set_one' ~es Map.e1 Desc.e_tuple es
+                
+    | Pexp_construct (lid, Some (e)) ->
+       (* コンストラクタ *)
+       (* 引数が単数か複数かで分岐 *)
+       let es = match e.pexp_desc with
+           Pexp_tuple es -> es
+         | _ -> [] in
+       set_one' ~es ~e Map.e1 (Desc.e_construct lid) es
+                
+    | Pexp_record (les, eop) ->
+       (* record *)
+       (* 各フィールドを対象にしている *)
+       set_one'
+         ~e:(match eop with None -> skeleton' | Some e -> e)
+         Map.le Desc.e_record les
+         
+    | Pexp_field (e, lid) ->
+       set_one' ~e Map.e1 (Desc.e_field lid) []
+
+    | Pexp_setfield (e1, lid, e2) ->
+       let fd sel = Desc.e_setfield lid (sn 1 e1 sel) (sn 2 e2 sel) in
+       set_some ~abst:(set_some e1 (fd 1)) e2 (fd 2)
+
+    | Pexp_array (es) ->
+       (* array *)
+       set_one' ~es Map.e1 Desc.e_array es
+                
+    | Pexp_ifthenelse (e1, e2, eop) ->
+       (* ifthenelse *)
+       (* [if □ then e2 else e3;
+          if e1 then □ else e3;
+          if e1 then e2 else □] *)
+      let e3 = match eop with
+          Some e -> e | None -> skeleton' in
+      let fd sel = Desc.e_ifthenelse
+                     (sn 1 e1 sel) (sn 2 e2 sel)
+                     (if eop <> None && sel = 3
+                      then Some (hole_of_exp e3) else eop) in
+      set_some
+        ~abst:(set_some ~abst:(set_some e1 (fd 1)) e2 (fd 2)) e3 (fd 3)
+
+   | Pexp_sequence (e1, e2) ->
+      let fd sel = Desc.e_sequence (sn 1 e1 sel) (sn 2 e2 sel) in
+      set_some ~abst:(set_some e1 (fd 1)) e2 (fd 2)
+
+   | Pexp_constraint (e, c) ->
+      (* constraint *)
+      (* [(□ : c)] *)
+      set_one' ~e Map.e1 (Desc.e_constraint c) []
+
+   | _ -> if exp = hole_of_exp exp then [] else [hole_of_exp exp]
+
+  (* 部分式を全て抽象化 *)
+  let set_all exp =
+
+    let set_all' ?(e = skeleton') map1 fd xs =
+      Desc.to_exp fd (List.map (hole_of_x map1) xs) (hole_of_exp e) exp in
+    let set_all'' desc = Desc.expression desc exp in 
+
+    match exp.pexp_desc with
+
+    | Pexp_let (flg, vs, e) ->
+       set_all' ~e Map.v1 (Desc.e_let flg) vs
+
+    | Pexp_apply (e, les) ->
+       set_all' ~e Map.le Desc.e_apply les
+
+    | Pexp_function (cs) ->
+       set_all' Map.c1 Desc.e_function cs
+
+    | Pexp_fun (l, eop, p, e) ->
+       set_all'' (Desc.e_fun l eop p (hole_of_exp e))
+
+    | Pexp_match (e, cs) ->
+       set_all' ~e Map.c1 Desc.e_match cs
+
+    | Pexp_try (e, cs) ->
+       set_all' ~e Map.c1 Desc.e_try cs
+
+    | Pexp_tuple (es) ->
+       set_all' Map.e1 Desc.e_tuple es
+
+    | Pexp_construct (lid, Some e) ->
+       let es = match e.pexp_desc with
+           Pexp_tuple es -> es | _ -> [] in
+       set_all' ~e Map.e1 (Desc.e_construct lid) es
+
+    | Pexp_record (les, eop) ->
+       set_all' ~e:(match eop with None -> skeleton' | Some e -> e)
+                Map.le Desc.e_record les
+
+    | Pexp_field (e, lid) ->
+       set_all' ~e Map.e1 (Desc.e_field lid) []
+
+    | Pexp_array (es) ->
+       set_all' Map.e1 Desc.e_array es
+
+    | Pexp_ifthenelse (e1, e2, eop) ->
+       set_all'' (
+           Desc.e_ifthenelse (hole_of_exp e1)
+                             (hole_of_exp e2)
+                             (match eop with Some e3 -> Some (hole_of_exp e3)
+                                           | None -> None))
+
+    | Pexp_sequence (e1, e2) ->
+       set_all'' (
+           Desc.e_sequence (hole_of_exp e1)
+                           (hole_of_exp e2))
+
+    | Pexp_constraint (e, ct) ->
+       set_all' ~e Map.e1 (Desc.e_constraint ct) []
+
+    | d -> set_all'' d
+
+  (* Abst.one, Abst.all *)
+
+  let one expr =
+    (* 既に確定している場合は抽象化しない *)
+    if Size.fltr0 expr then Size.terminated (hole_of_exp expr) else expr
+
+  let all expr = Size.terminated (Desc.Exp.map one expr)
+
+  let set slice expr =
+    if Hole.check_loc slice expr then slice else expr
+
+  let get' sel slice expr =
+
+    if Hole.check_loc slice expr = sel then
+      (* sel = true : loc = true *)
+      (* sel = false : loc = false *)
+      (* expr を抽象化 *)
+      one expr
+    else
+      set slice expr
+
+  (* Abst.get *)
+  let get expr sel slice =
+    (if Hole.check_skeleton slice then
+       if sel then Size.terminated else all
+     else
+       Desc.Exp.map (
+           (if Size.comp1 slice < 0 then set else get' sel)
+             slice)) expr
+
+
+  let exp e =
+    if Size.fltr0 e then
+      (hole_of_exp e)
+      |> (if Size.set_resize then Size.reset else Size.terminated)
+    else e;
+
+end
+*)
+
+(* デバッグ用 *)
+module Meta = struct
+  (* 型デバッガが訪れるノード数カウント用の変数 (debug_main.ml) *)
+  open Ast
+  let visible = false
+
+  let clean' name expr =
+    {expr with
+      pexp_attributes =
+        if name = "all" then [] (* 全部消す *)
+        else
+          List.filter (
+              fun ({txt = name'}, _) ->
+              name <> name'
+            ) expr.pexp_attributes}
+
+  let clean name expr =
+    Desc.Exp.map_all (clean' name) expr
+
+
+  let rec attribute ppf (kind, attrs) = match attrs with
+      [] -> ()
+    | ({txt = s}, PPat ({ppat_desc = Ppat_constant (Pconst_integer (n, None))}, None)) :: _ when s = kind ->
+       (* 【新バージョン】 *)
+       Format.fprintf ppf "(size : %s)" n
+
+    | ({txt = s}, PStr [{pstr_desc = Pstr_eval (e, _)}]) :: _ when s = kind ->
+       (* 式のホール □ *)
+       if visible then Format.fprintf ppf "【%a】" Pprintast.expression e
+       else Format.fprintf ppf "□"
+    | ({txt = s}, PPat (p, _)) :: _ when s = kind ->
+       (* パターンのホール ■ *)
+       if visible then Format.fprintf ppf "【%a】" Pprintast.pattern p
+       else Format.fprintf ppf "■"
+    | ({txt = s}, Size n) :: _ when s = kind ->
+       (* サイズ *)
+       Format.fprintf ppf "(size : %d)" n
+    | _ :: rest-> attribute ppf (kind, rest)
+
+  (* 表示 *)
+  (* expression -> unit *)
+  and expression ppf ({pexp_desc = d; pexp_attributes = attrs} as exp) =
+    match d with
+    | Pexp_let (flg, vs, e) -> pexp_let ppf (flg, vs, Some (e))
+    | Pexp_fun (_, _, p, e) -> pexp_fun ppf (p, e)
+    | Pexp_apply (e, les) -> pexp_apply ppf (e, les)
+    | Pexp_match (e, cs) -> pexp_match ppf (e, cs)
+    | Pexp_try (e, cs) -> pexp_try ppf (e, cs)
+    | Pexp_tuple es -> pexp_tuple ppf es
+    | Pexp_construct (lid, Some (e)) -> pexp_construct ppf (lid, e)
+    | Pexp_record (les, _) -> pexp_record ppf les
+    | Pexp_array (es) -> pexp_array ppf es
+    | Pexp_ifthenelse (e1, e2, eop) -> pexp_ifthenelse ppf (e1, e2, eop)
+    | Pexp_sequence (e1, e2) -> pexp_sequence ppf (e1, e2)
+    | _ -> if exp = hole_of_exp exp then attribute ppf ("exp", attrs)
+           else Pprintast.expression ppf (Exp.mk d)
+
+  and value_binding ppf {pvb_pat = pn; pvb_expr = en} = match en.pexp_desc with
+    | Pexp_fun (_, _, p, e) ->
+       Format.fprintf ppf "%a %a"
+                      pattern pn
+                      value_binding (Vb.mk p e)
+    | _ ->
+       Format.fprintf ppf "%a = %a"
+                      pattern pn
+                      expression en
+
+
+  and cases ppf cs =
+    let case ppf {pc_lhs = pn; pc_guard = gn; pc_rhs = en} = match gn with
+      | None ->
+         Format.fprintf ppf "| %a -> %a"
+                        pattern pn
+                        expression en
+      | Some (e) ->
+         Format.fprintf ppf "| %a when %a -> %a"
+                        pattern pn
+                        expression e
+                        expression en in
+    List.iter (fun c -> Format.fprintf ppf "%a" case c) cs
+
+  and field_and_exp ppf (l, e) =
+    Format.fprintf ppf "%s = %a; "
+                   (Longident.last l.txt)
+                   expression e
+
+  and es_tl ppf (s, tl) =
+    List.iter (
+        fun en ->
+        Format.fprintf ppf "%s %a" s
+                       expression en) tl
+
+  and pexp_let ppf (flg, vs, eop) = match vs with
+      [] -> assert false
+    | first :: rest ->
+       let vb_hd ppf hd =
+         Format.fprintf ppf (if flg = Recursive
+                             then "let rec %a"
+                             else "let %a") value_binding hd in
+       let vb_tl ppf tl =
+         List.iter (
+             fun vn ->
+             Format.fprintf ppf " and %a" value_binding vn) tl in
+       match eop with
+       | None ->
+          Format.fprintf ppf "%a %a"
+                         vb_hd first
+                         vb_tl rest
+       | Some (e) ->
+          Format.fprintf ppf "%a %a in %a"
+                         vb_hd first
+                         vb_tl rest
+                         expression e
+
+  and pexp_fun ppf (p, e) =
+    Format.fprintf ppf "(fun %a -> %a)"
+                   pattern p
+                   expression e
+
+  and pexp_apply ppf (e, les) =
+    let args ppf les =
+      List.iter (fun (_, e) -> Format.fprintf ppf " %a" expression e) les in
+    Format.fprintf ppf "(%a%a)"
+                   expression e
+                   args les
+
+  and pexp_match ppf (e, cs) =
+    Format.fprintf ppf "match %a with %a"
+                   expression e
+                   cases cs
+
+  and pexp_try ppf (e, cs) =
+    Format.fprintf ppf "try %a with %a"
+                   expression e
+                   cases cs
+
+  and pexp_tuple ppf es = match es with
+      [] -> assert false
+    | first :: rest ->
+       Format.fprintf ppf "(%a%a)"
+                      expression first
+                      es_tl (",", rest)
+
+  and pexp_construct ppf (lid, e) = (* 要素ありのみ *)
+    Format.fprintf ppf "(%s %a)"
+                   (Longident.last lid.txt)
+                   expression e
+
+  and pexp_record ppf les =
+    Format.fprintf ppf "{%a}"
+                   (fun ppf les ->
+                     List.iter (field_and_exp ppf) les) les
+
+  and pexp_array ppf es = match es with
+      [] -> Format.fprintf ppf "[||]"
+    | first :: rest ->
+       Format.fprintf ppf "[|%a%a|]"
+                      expression first
+                      es_tl (";", rest)
+
+  and pexp_ifthenelse ppf (e1, e2, eop) = match eop with
+    | None ->
+       Format.fprintf ppf "@if %a then %a"
+                      expression e1
+                      expression e2
+    | Some (e3) ->
+       Format.fprintf ppf "if %a then %a else %a"
+                      expression e1
+                      expression e2
+                      expression e3
+
+  and pexp_sequence ppf (e1, e2) =
+    Format.fprintf ppf "(%a; %a)"
+                   expression e1
+                   expression e2
+    
+
+  and pattern ppf ({ppat_desc = d; ppat_attributes = attrs} as pat) =
+    match d with
+    | Ppat_tuple ps -> ppat_tuple ppf ps
+    | Ppat_construct (lid, Some (p)) -> ppat_construct ppf (lid, p)
+    | Ppat_record (lps, _) -> ppat_record ppf lps
+    | _ -> if pat = hole_of_pat pat then attribute ppf ("pat", attrs)
+           else Pprintast.pattern ppf pat
+
+  and ppat_tuple ppf ps = match ps with
+      [] -> assert false
+    | first :: rest ->
+       Format.fprintf
+         ppf "(%a%a)"
+         pattern first
+         (fun ppf ps ->
+           List.iter (Format.fprintf ppf ", %a" pattern) ps) rest
+
+  and ppat_construct ppf (lid, p) = (* 要素ありのみ *)
+    Format.fprintf ppf "(%s %a)"
+                   (Longident.last lid.txt)
+                   pattern p
+
+  and ppat_record ppf lps =
+    Format.fprintf ppf "{%a}"
+                   (fun ppf lps ->
+                     List.iter (field_and_pat ppf) lps) lps
+
+  and field_and_pat ppf (l, p) =
+    Format.fprintf ppf "%s = %a; "
+                   (Longident.last l.txt) pattern p
+
+  let rec structure ppf str = match str with
+    | [] -> ()
+    | ({pstr_desc = d} as first) :: rest ->
+       (* first の表示 *)
+       if first <> hole_str then
+         match d with
+         | Pstr_eval (e, _) ->
+            Format.fprintf ppf "@[%a@]@." expression e
+         | Pstr_value (flg, vs) ->
+            Format.fprintf ppf "@[%a@]@." pexp_let (flg, vs, None)
+         | _ ->
+            Format.fprintf ppf "@[%a@]@." Pprintast.structure [first]
+       else Format.fprintf ppf "@[(The mark '□' is a hole expression.)@]@.";
+       (* rest について再帰 *)
+       Format.fprintf ppf "@[%a@]@." structure rest
+
+  (* デバッグ用 expression の print *)
+  let print_deb_exp ppf exp =
+    Format.fprintf ppf "%a %a"
+                   expression exp
+                   attribute ("size", exp.pexp_attributes)
+  let print_deb_strs ppf strs = Format.fprintf ppf "%a"structure strs
+
+end
+
+(* 抽象：変数 *)
+let skeleton = Hole.dummy_assertfalse ()
+let wildcard = Hole.dummy_any ()
+let dummy_int0 = Hole.dummy_int0 ()
+let dummy_fun = Hole.dummy_fun ()
+(* 抽象化：関数 *)
+let dummy_assertfalse exp = Hole.expression exp
+let dummy_any pat = Hole.pattern pat
+
+(* デバッグ用：変数 *)
+(* スライスの切り替え *)
+let on_slice = on_exp_slice
+let on_pat_slice = on_pat_slice
+(* デバッグ用：関数 *)
+let print_deb_exp ppf exp = Meta.print_deb_exp ppf exp
+let print_deb_strs ppf strs = Meta.print_deb_strs ppf strs
+
+(* ---------------------------------------------------------- *)
+(* 構文の生成 *)
+
+(* 元の構文の desc を置き換える *)
+let desc_to_exp = Desc.expression
+let desc_to_pat = Desc.pattern
+
+(* ---------------------------------------------------------- *)
+
+
+(*
+module Library =
+  struct
+
+    module Locations = struct
+      module type Typ =
+        sig
+          type s
+          val internal : s -> s -> bool
+          val pos_start : s -> string * (int * int)
+          val pos_end : s -> string * (int * int)
+          val pos_ghost : s -> bool
+          val pos_all : s -> (string * ((int * int) * (int * int))) * bool
+        end
+
+      open Location
+
+      let internal to_loc root node =
+        let {loc_start = root_s; loc_end = root_e} = to_loc root
+        and {loc_start = node_s; loc_end = node_e} = to_loc node in
+
+        root_s <= node_s && node_e <= root_e
+
+      let pos_start to_loc a =
+        let loc = to_loc a in
+        let (filename, line, char) =
+          get_pos_info loc.loc_start in
+        (filename, (line, char))
+
+      let pos_end to_loc a =
+        let loc = to_loc a in
+        let (filename, line, char) =
+          get_pos_info loc.loc_end in
+        (filename, (line, char))
+
+      let pos_ghost to_loc a =
+        let loc = to_loc a in
+        loc.loc_ghost
+
+      let pos_all to_loc a =
+        let (filename, s_pair) = pos_start to_loc a
+        and (filename', e_pair) = pos_end to_loc a in
+
+        (* ファイル名は同じになる *)
+        assert (filename = filename');
+        ((filename, (s_pair, e_pair)), pos_ghost to_loc a)
+
+    end
+
+    module type Abst_t =
+      sig
+        type t
+        val skeleton : t
+        val terminate : t -> t
+
+        val of_desc : t -> t
+        val of_attr : t -> t
+        val to_loc : t -> Location.t
+      end
+
+    module type Modules =
+      sig
+        include Locations.Typ
+
+        val print : bool -> Format.formatter -> s -> unit
+
+        module Desc : Desc.Typ with type t = s
+
+
+        module Hole : sig
+          include Abst_t with type t = s
+          val root : s -> s
+          val node : s -> s
+        end
+
+      end
+
+    type 'a abst_t = (module Abst_t with type t = 'a)
+    type 'a desc_t = (module Desc.Typ with type t = 'a)
+
+    let make (type a) print (abst : a abst_t) (desc : a desc_t) =
+      let (module A) = abst in
+      let (module D) = desc in
+
+      (module
+         struct
+           type s = a
+
+           let print = print
+           let internal root node =
+             Locations.internal A.to_loc root node
+           let pos_start a = Locations.pos_start A.to_loc a
+           let pos_end a = Locations.pos_end A.to_loc a
+           let pos_ghost a = Locations.pos_ghost A.to_loc a
+           let pos_all a = Locations.pos_all A.to_loc a
+
+           module Desc = D
+           module Hole = struct
+             include A
+             let root e = of_desc e
+             let node e = of_attr (D.map of_desc e)
+           end
+         end : Modules with type s = a)
+
+    let expression =
+      make
+        (fun debug ->
+          if debug then
+            print_deb_exp
+          else
+            Pprintast.expression)
+        (module
+           struct
+             type t = expression
+             let skeleton = skeleton
+             let terminate e =
+               let attr =
+                 ({txt = "term"; loc = e.pexp_loc}, PPat (wildcard, None)) in
+               Exp.attr e attr
+
+             let of_desc e = hole_of_exp e
+             let of_attr e = {e with pexp_attributes = []}
+             let to_loc e = e.pexp_loc
+           end)
+        (module Desc.Exp)
+
+  end
+*)
+module Data = struct
+
+  let is_toplevel = Array.length Sys.argv < 2
+
+  let log_path =
+    try
+      Sys.getenv "DEBUGGER_LOG_PATH"
+    with
+      Not_found -> "."
+  let express_mode =
+    try
+      int_of_string (Sys.getenv "DEBUGGER_EXPRESS_MODE")
+    with
+      _ -> -1
+
+  let makeOpenOut path =
+    open_out_gen [Open_append; Open_creat] 420 path
+
+  module Loc = struct
+    open Location
+
+    type t = {filename : string;
+              s_line : int; s_char : int;
+              e_line : int; e_char : int; }
+
+    let to_filename name =
+      try
+        assert (name <> "//toplevel//" && log_path <> ".");
+        let ld_len = String.length log_path + 1 in
+        let fn_len = String.length name in
+
+        Format.sprintf "%s"
+          (String.sub name ld_len (fn_len - ld_len))
+      with
+        _ -> name
+
+    let of_location loc =
+      let (filename, s_line, s_char) = get_pos_info loc.loc_start
+      and (filename', e_line, e_char) = get_pos_info loc.loc_end in
+      assert (filename = filename');
+      {filename; s_line; s_char; e_line; e_char}
+
+    let flat_string loc =
+      (* filename,
+         loc_start.line, loc_start.char,
+         loc_end.start, loc_end.char *)
+      let (filename, s_line, s_char) = get_pos_info loc.loc_start
+      and (filename', e_line, e_char) = get_pos_info loc.loc_end in
+      assert (filename = filename');
+
+      Format.sprintf "%s,%d,%d,%d,%d"
+        (to_filename filename) s_line s_char e_line e_char
+
+    let dual_string loc1 loc2 =
+      let str1 = of_location loc1 and str2 = of_location loc2 in
+      assert (str1.filename = str2.filename);
+      Format.sprintf "%s,%s"
+        (flat_string loc1) (flat_string loc2)
+
+    let is_ghost loc = loc.loc_ghost
+
+    let printJSON ppf loc =
+      let open Location in
+      let (s_file, s_line, s_char) =
+        get_pos_info loc.loc_start
+      and (e_file, e_line, e_char) =
+        get_pos_info loc.loc_end in
+      Format.fprintf ppf
+        "{\"s\": {\"file\":\"%s\", \"line\":%d, \"char\":%d},\"e\": {\"file\":\"%s\", \"line\":%d, \"char\":%d}}"
+        (to_filename s_file) s_line s_char
+        (to_filename e_file) e_line e_char
+
+    let read line =
+
+      let n = String.index_from line 0 ',' in
+
+      let filename =
+        match String.sub line 0 n with
+        filename' -> 
+          assert (filename' <> "//toplevel//");
+          log_path ^ "/" ^ filename' in
+
+      let line = String.sub line (n + 1) (String.length line - n - 1) in
+
+      let n = String.index_from line 0 ',' in
+      let s_line = String.sub line 0 n |> int_of_string in
+
+      let line = String.sub line (n + 1) (String.length line - n - 1) in
+
+      let n = String.index_from line 0 ',' in
+      let s_char = String.sub line 0 n |> int_of_string in
+
+      let line = String.sub line (n + 1) (String.length line - n - 1) in
+
+      let n = String.index_from line 0 ',' in
+      let e_line = String.sub line 0 n |> int_of_string in
+
+      let line = String.sub line (n + 1) (String.length line - n - 1) in
+
+      let n = String.index_from line 0 ',' in
+      let e_char = String.sub line 0 n |> int_of_string in
+
+      {filename; s_line; s_char; e_line; e_char; },
+      (String.sub line (n + 1) (String.length line - n - 1))
+
+  end
+
+  type opt =
+    | Buffer of (string option * bool) list
+    | Slice of int
+
+  module Buffer = struct
+    let path = log_path ^ "/buffer.csv"
+
+    (* 読み込み *)
+    let read' loc (scope, ans) list = match list with
+      | (loc', Buffer ((scope', ans') :: rest')) :: rest
+        when loc = loc' (* 同じ式が対象 *) ->
+          (loc, Buffer ((scope, ans) :: (scope', ans') :: rest')) :: rest
+      | _ ->
+          (loc, Buffer [(scope, ans)]) :: list
+
+    let rec read file list =
+      try
+        let line = input_line file in
+
+        if print_slice then
+          Format.fprintf ppf "@[Buffer read : %s@]@." line;
+
+        let (loc, line) = Loc.read line in
+
+        let n = String.index_from line 0 ',' in
+        let ans = String.sub line 0 n = "y" in
+        let scope =
+          let name =
+            String.sub line (n + 1) (String.length line - n - 1) in
+          if name = "" then None else Some name in
+        read file (read' loc (scope, ans) list)
+      with End_of_file -> close_in file; list
+         | _ -> read file list
+
+    (* 書き込み *)
+    let write scope expr ans =
+     if on_file_output then begin
+      let line = Loc.flat_string expr.pexp_loc in
+      let file = makeOpenOut path in
+      (* 回答、スコープ、位置情報 *)
+      if Array.length Sys.argv = 8 then
+        Format.fprintf ppf "{\"location\":%a, \"scope\":%s}"
+          Loc.printJSON expr.pexp_loc (if scope = "" then "null" else ("\"" ^ scope ^ "\""));
+
+      if ans = "y" || ans = "n" then
+        output_string file
+          (Format.sprintf "%s,%s,%s\n"
+             line ans scope);
+      close_out file
+     end
+
+    let rec set'' name cxt = match cxt with
+      | Lambda (p, cxt') ->
+         let p' = Desc.Pat.find name p in
+         if p' = wildcard then set'' name cxt' else p'
+      | Let (_, vs, cxt') ->
+          let p' =
+            List.fold_left (
+              fun p'' {pvb_pat} ->
+                if p'' = wildcard then
+                  Desc.Pat.find name pvb_pat
+                else
+                  p''
+              ) wildcard vs in
+          if p' = wildcard then set'' name cxt' else p'
+      | _ -> wildcard
+
+    let set' cxt expr (scope, ans) =
+      let pat = match scope with
+          None -> wildcard
+        | Some name ->
+           if print_slice then
+             Format.fprintf ppf "@[scope: %s@]@." name;
+           set'' name cxt in
+      ({txt = if ans then "yes" else "no"; loc = expr.pexp_loc},
+       PPat (pat, None))
+
+    let set cxt asks expr =
+      let cxt' =
+        match expr.pexp_desc with
+        | Pexp_fun (_, _, p, _) ->
+           if print_slice then
+             Format.fprintf ppf "@[lambda.%a@]@." Pprintast.pattern p;
+           Lambda (p, cxt)
+        | Pexp_let (flg, vs, _) ->
+           if print_slice then
+             Format.fprintf ppf "@[let%a@]@."
+               (fun ppf ->
+                 List.iter (fun vb ->
+                   Format.fprintf ppf ".%a"
+                     Pprintast.pattern vb.pvb_pat)) vs;
+           Let (flg, vs, cxt)
+        | _ -> cxt in
+      ({expr with pexp_attributes = List.map (set' cxt' expr) asks}, cxt')
+(*
+    open Location
+    let printJSON ppf loc =
+      let (s_file, s_line, s_char) =
+        get_pos_info loc.loc_start
+      and (e_file, e_line, e_char) =
+        get_pos_info loc.loc_end in
+      Format.fprintf ppf
+        "{\"s\": {\"file\":\"%s\", \"line\":%d, \"char\":%d},\"e\": {\"file\":\"%s\", \"line\":%d, \"char\":%d}}"
+        s_file s_line s_char e_file e_line e_char
+
+    let json ppf loc =
+      Format.fprintf ppf
+        "\"location\": %a"
+        printJSON loc
+*)
+  end
+  module Slice = struct
+
+    (* ファイルのパス *)
+    let path = log_path ^ "/slice.csv"
+
+    module Exp = struct
+
+      let slices = ref []
+      let lines = ref []
+
+      (* 読み込み *)
+      let rec read file list =
+        try
+          let line = input_line file in
+
+          let (loc, opt') = Loc.read line in
+
+          read file ((loc, Slice (int_of_string opt')) :: list)
+        with
+          End_of_file -> close_in file; list
+        | _ -> read file list
+
+      let outputs () =
+        let file = makeOpenOut path in
+        List.iter (output_string file) !lines
+
+      let rec set' expr es =
+        {expr with
+         pexp_desc =
+           Pexp_apply (hole_of_exp expr,
+                       List.map (fun e -> (Nolabel, e)) es)}
+
+      and set expr = match expr.pexp_desc with
+          Pexp_construct (_, Some {pexp_desc = Pexp_tuple es}) ->
+            set' expr es
+        | _ -> expr
+
+      let write' expr n =
+        (* 書き込み *)
+        if print_slice then
+          Format.fprintf ppf "@[write from: %a@]@." print_deb_exp expr;
+
+        let line =
+          Format.sprintf "%s,%d\n"
+            (Loc.flat_string expr.pexp_loc) n in
+
+        if print_slice then
+          Format.fprintf ppf "@[write to: %s@]@." line;
+
+        lines := !lines @ [line]
+
+      (* expr の位置情報を出力 *)
+      let write expr =
+        let ghost = Loc.is_ghost expr.pexp_loc in
+
+        match expr.pexp_desc with
+        | Pexp_apply (e, _) ->
+
+            if e = skeleton' then
+              (* nested apply *)
+              List.iter (
+                fun ({txt}, payload) ->
+                  match payload with
+                    PStr structure when txt = "app" ->
+                      List.iter (
+                        fun item ->
+                          match item.pstr_desc with
+                            Pstr_eval (expr', _) ->
+                              if ghost then
+                                write' expr' 3
+                              else
+                                write' expr' 2
+                          | _ -> ()
+                      ) structure
+                  | _ -> ()
+              ) expr.pexp_attributes
+            else if ghost && expr.pexp_loc = e.pexp_loc then
+              (* dummy apply and ghost *)
+              write' expr 3
+            else if expr.pexp_loc = e.pexp_loc then
+              (* dummy apply *)
+              write' expr 2
+            else if ghost then
+              (* ghost *)
+              write' expr 1
+            else
+              (* others *)
+              write' expr 0
+
+        | _ ->
+            if ghost then
+              (* ghost *)
+              write' expr 1
+            else
+              (* others *)
+              write' expr 0
+
+      let clean ?(output = false) expr =
+        let cnt' = ref 0 in
+        let expr' =
+          Desc.Exp.map_all (
+            fun e ->
+              let e' = {e with pexp_attributes = []} in
+              if hole_of_exp e <> e then
+                (* hole 以外を追加 *)
+                if output then
+                  write e
+                else if output then
+                  cnt' := 1 + !cnt';
+              e'
+          ) expr in
+
+        (* 重複がなかった場合のみ追加 *)
+        if not (List.exists (fun (_, e) -> e = expr') !slices) then
+          slices := (!cnt', expr') :: !slices;
+        expr'
+
+    end
+
+  end
+
+  (* スライスを作るかどうか *)
+  let check_make_slice () =
+    (not (Sys.file_exists Slice.path))
+    && (not (Sys.file_exists Buffer.path))
+
+
+  (* 型推論の情報 *)
+  module Infer = struct
+    let path = log_path ^ "/infer.txt"
+
+    let root = ref Location.none
+    let cntItem = ref 0
+    let cntExpr = ref 0
+
+    (* 初期状態 *)
+    let init name =
+      if on_file_output && print_slice && check_make_slice () then
+        let file = makeOpenOut path in
+        output_string file
+          (Format.sprintf "(* %s slicer *)\n" name);
+        close_out file
+
+    (* root の位置情報を記録 *)
+    let read loc = root := loc
+
+    (* 外部ファイルへの書き込み *)
+    let write structure expr b =
+      if structure = [] && b then
+        let slice = Slice.Exp.clean ~output:(
+            check_make_slice ()
+          ) expr in
+        begin
+          if on_file_output && print_slice && check_make_slice () then
+            let file = makeOpenOut path in
+            Format.fprintf ppf "@[return: %a @]@."
+              print_deb_exp expr;
+            (* expression の出力 *)
+            output_string file
+              (Format.sprintf "\n(* infer %d.%d: end *)\n"
+                 !cntItem !cntExpr);
+            output_string file
+              (Format.sprintf "(* %s *)\n"
+                 (Pprintast.string_of_expression slice));
+            close_out file
+        end
+      else if structure = [] &&
+              (on_file_output && print_slice && check_make_slice ()) then
+        begin
+          let file = makeOpenOut path in
+          Format.fprintf ppf "@[origin: %a @]@."
+            print_deb_exp expr;
+          output_string file
+            (Format.sprintf "\n(* infer %d.%d: begin *)\n"
+               !cntItem !cntExpr);
+          output_string file
+            (Format.sprintf "(* %s *)\n"
+               (expr |> Pprintast.string_of_expression));
+        end
+      else if on_file_output && print_slice && check_make_slice () then
+        (* structure の出力 *)
+        begin
+          let file = makeOpenOut path in
+          match !Slice.Exp.slices with
+            [] -> ()
+          | (first, _) :: _ ->
+              Format.fprintf ppf "    @[%s(%d): %a @]@."
+                (if b then "welltyped" else "illtyped")
+                first
+                print_deb_exp expr;
+              let item =
+                List.find (
+                  fun item -> Desc.internal item.pstr_loc expr.pexp_loc
+                ) structure in
+              output_string file
+                (Format.sprintf "\n(* infer %d.%d: %s (%d) *)\n"
+                   !cntItem !cntExpr
+                   (if b then "welltyped" else "illtyped")
+                   first);
+              output_string file
+                (Format.sprintf "(* %s *)\n"
+                   (Slice.Exp.clean expr |> Pprintast.string_of_expression));
+              output_string file
+                (Format.sprintf "%s\n"
+                   ([item] |> Pprintast.string_of_structure))
+        end;
+
+      if structure = [] && b then
+        (cntExpr := 0; cntItem := !cntItem + 1)
+      else
+        cntExpr := !cntExpr + 1
+
+  end
+
+  (* 式の生成 *)
+  let rec init''' expr = match expr.pexp_desc with
+    | Pexp_apply (e, (_, {pexp_desc = Pexp_apply (e', les')}) :: les)
+      when e.pexp_desc = skeleton'.pexp_desc
+        && e'.pexp_desc = skeleton'.pexp_desc ->
+        if print_slice then
+          Format.fprintf ppf "@[nested : %a@]@."
+            print_deb_exp expr;
+        let les'' =
+          List.fold_left (
+            fun acc (l_, e_) ->
+              if e_ = hole_of_exp e_ then
+                acc
+              else
+                (acc @ [(l_, e_)])
+          ) [] (les' @ les) in
+        {expr with pexp_desc = Pexp_apply (skeleton', les'')}
+
+    | _ -> expr
+
+  and init'' kind cxt list opt expr =
+
+    let f c e = Desc.Exp.map (init' kind c list) e in
+
+    match opt with
+      Buffer asks ->
+        (* buffer の設定 *)
+        (* 複数ある可能性も考慮 *)
+        if print_slice then
+          Format.fprintf ppf "@[Buffer : %a@]@."
+            Pprintast.expression expr;
+        let (expr', cxt') = Buffer.set cxt asks expr in
+        init' kind cxt' (
+            List.filter (
+                fun (loc', opt') ->
+                loc' <> Loc.of_location expr.pexp_loc
+                || opt <> opt'
+              ) list) expr'
+    | Slice ghost ->
+        match expr.pexp_desc with
+        | Pexp_fun (_, _, p, _) ->
+            let cxt' = Lambda (p, cxt) in
+            f cxt' expr
+
+        | Pexp_let (flg, vs, e0) ->
+            let cxt' = Let (flg, vs, cxt) in
+            Desc.Exp.map (
+              fun e ->
+                if e = e0 then
+                  f cxt' e
+                else
+                  f cxt e
+            ) expr
+
+        | Pexp_tuple es
+          when 1 < ghost ->
+            if print_slice then
+              Format.fprintf ppf "@[Tuple : %a@]@."
+                Pprintast.expression expr;
+
+            let les =
+              List.fold_left (
+                fun acc e ->
+                  let e' = init' kind cxt list e in
+                  if e'.pexp_desc = skeleton'.pexp_desc then
+                    (* 抽象化されたので残さない *)
+                    acc
+                  else
+                    (acc @ [Nolabel, e'])
+              ) [] es in
+
+            init'''
+              {expr with
+               pexp_desc =
+                 Pexp_apply (skeleton', les)}
+
+        | Pexp_construct (_, Some {pexp_desc = Pexp_tuple es})
+          when 1 < ghost ->
+            if print_slice then
+              Format.fprintf ppf "@[Construct : %a@]@."
+                Pprintast.expression expr;
+
+            let les =
+              List.fold_left (
+                fun acc e ->
+                  let e' = init' kind cxt list e in
+                  if e'.pexp_desc = skeleton'.pexp_desc then
+                    (* 抽象化されたので残さない *)
+                    acc
+                  else
+                    (acc @ [Nolabel, e'])
+              ) [] es in
+
+            init'''
+              {expr with
+               pexp_desc =
+                 Pexp_apply (skeleton', les)}
+
+          | Pexp_construct (lid, Some ({pexp_desc = Pexp_tuple _} as e)) ->
+              (* コンストラクタ : タプル内の要素のみを処理 *)
+              {expr with
+               pexp_desc =
+                 Pexp_construct (lid, Some (f cxt (Slice.Exp.set e)))}
+
+          | Pexp_apply (_, les) when 1 < ghost ->
+              (* 関数適用 : 入れ子の判定に進む *)
+              if print_slice then
+                Format.fprintf ppf "@[Apply : %a@]@."
+                  Pprintast.expression expr;
+
+              let les' =
+                List.fold_left (
+                  fun acc (l, e) ->
+                    let e' = init' kind cxt list e in
+                    if e'.pexp_desc = skeleton'.pexp_desc then
+                      (* 抽象化されたので残さない *)
+                      acc
+                    else
+                      (acc @ [l, e'])
+                ) [] les in
+
+              init'''
+                {expr with
+                 pexp_desc =
+                   Pexp_apply (skeleton', les')}
+
+          | _ ->
+              (* その他 *)
+              if print_slice then
+                Format.fprintf ppf "@[Slice : %a@]@."
+                  Pprintast.expression expr;
+              if ghost < 2 then
+                f cxt (Slice.Exp.set expr)
+              else
+                init''' expr
+
+  and init' kind cxt list expr =
+    try
+      let (_, opt) =
+        List.find (
+            fun (loc, _) ->
+            loc = Loc.of_location expr.pexp_loc
+        ) list in
+      init'' kind cxt list opt expr
+    with
+      Not_found ->
+        if kind then
+          begin
+            if print_slice then
+              Format.fprintf ppf "@[hole : %a@]@."
+                print_deb_exp expr;
+            hole_of_exp expr
+          end
+        else if Desc.Exp.leaf expr then
+          expr
+        else
+          Desc.Exp.map (init' kind cxt list) expr
+
+  let init ((expr, cxt), env, prefix) =
+
+    if check_make_slice () || is_toplevel then
+      Size.Exp.set_and
+        (fun e -> Desc.Exp.complete ((e, cxt), env, prefix)) expr
+
+    else
+      let expr =
+        if Sys.file_exists Slice.path then
+          let file = open_in Slice.path in
+          init' true Empty (Slice.Exp.read file []) expr
+        else
+          expr in
+      let expr =
+        if Sys.file_exists Buffer.path then
+          let file = open_in Buffer.path in
+          init' false Empty (Buffer.read file []) expr
+        else
+          expr in
+      expr
+
+  let typed'' expr tp time =
+    let loc = !Infer.root in
+    if on_file_output && loc <> Location.none && check_make_slice () then
+      let file =
+        makeOpenOut (log_path ^ "/data.csv") in
+      let line =
+        Format.sprintf "%s,%f,%d\n"
+          (Loc.dual_string !Infer.root expr.pexp_loc)
+          time tp in
+      output_string file line;
+      close_out file
+
+  let typed' env structure expr =
+    (* 型推論と所要時間の計測 *)
+    let time0 = Sys.time () in
+    let tp =
+      try
+
+        let _ =
+          Typemod.type_structure env structure Location.none in
+        true
+      with _ -> false in
+    let time1 = Sys.time () in
+
+    if print_slice then
+      Infer.write structure expr tp
+    else
+      begin
+        Infer.read expr.pexp_loc;
+        typed'' expr (if tp then 1 else 0) (time1 -. time0);
+      end;
+    (* 戻り値は bool *)
+    tp
+
+  let typed env item_cxt expr_cxt expr =
+    try
+      let structure =
+        List.map (
+          fun item ->
+            if not (Desc.internal item.pstr_loc expr.pexp_loc) then
+              item
+            else
+              match item.pstr_desc with
+              | Pstr_eval (e, attrs) ->
+                  if Desc.internal
+                      e.pexp_loc expr.pexp_loc then
+                    {item with pstr_desc = Pstr_eval (Slice.Exp.clean e, attrs)}
+                  else
+                    item
+
+              | Pstr_value (flg, vs) ->
+                  {item with
+                   pstr_desc =
+                     Pstr_value (flg, List.map (
+                         fun vb ->
+                           if Desc.internal
+                               vb.pvb_expr.pexp_loc expr.pexp_loc then
+                             {vb with pvb_expr = Slice.Exp.clean vb.pvb_expr}
+                           else
+                             vb
+                       ) vs)}
+              | _ -> item
+        ) (item_cxt expr_cxt expr) in
+      (* 型推論 *)
+      typed' env structure expr
+    with _ ->
+      true (* 省略 *)
+
+  (* 終了処理: ファイルの出力 *)
+  let finally expr time =
+    Infer.read expr.pexp_loc;
+    if check_make_slice () then
+      typed'' expr (-1) time;
+    expr
+
+end
diff --git a/typing/debug_core.mli b/typing/debug_core.mli
new file mode 100755
index 0000000..f8b61dd
--- /dev/null
+++ b/typing/debug_core.mli
@@ -0,0 +1,453 @@
+open Asttypes
+open Types
+
+open Parsetree
+
+(* ppf *)
+val ppf : Format.formatter
+
+(* コンテキストの定義 *)
+type expr_context =
+  | Empty
+  | Lambda of pattern * expr_context
+  | Let of rec_flag * value_binding list * expr_context
+type 'a context_t =
+  ('a * expr_context) * Env.t * (structure_item * Env.t) list
+
+
+module Map : sig
+
+  type 'a map2 = (pattern -> expression -> expression)
+                 -> (pattern -> expression -> pattern)
+                 -> 'a -> 'a
+  type 'a map1 = (expression -> expression) -> (pattern -> pattern)
+                 -> 'a -> 'a
+
+  (* 与える関数が2引数 *)
+  val v2 : value_binding map2
+  val c2 : case map2
+
+  (* 与える関数が1引数 *)
+  val v1 : value_binding map1
+  val c1 : case map1
+  val e1 : expression map1
+  val p1 : pattern map1
+  val le : ('a * expression) map1
+  val lp : ('a * pattern) map1
+
+  (* exp / pat を差し替える *)
+  val set_exp : 'a map1 -> 'a -> expression -> 'a
+  val set_pat : 'a map1 -> 'a -> pattern -> 'a
+
+end
+
+module Hole : sig
+  val item : structure_item
+  val to_exp : expression -> expression
+  val exp : expression
+end
+
+(* module Desc *)
+module Desc : sig
+
+  (* 生成関数の型 *)
+  type 'a make_exp_desc =
+    'a list -> expression -> expression_desc
+  type make_exp_desc2 =
+    expression -> expression -> expression option -> expression_desc
+
+  type 'b make_pat_desc = 'b list -> pattern -> pattern_desc
+
+  (* 生成関数を使って exp / pat の desc を差し替える *)
+  val to_exp :
+    'a make_exp_desc
+    -> 'a list -> expression -> expression
+    -> expression
+  val to_exp2 :
+    make_exp_desc2
+    -> expression -> expression -> expression option -> expression
+    -> expression
+
+  val to_pat : 'b make_pat_desc -> 'b list
+               -> pattern -> pattern -> pattern
+
+  (* pexp_desc の生成 *)
+  (*
+  val e_let : rec_flag -> value_binding make_exp_desc
+  val e_function : case make_exp_desc
+  val e_fun : arg_label -> expression option
+              -> pattern -> expression -> expression_desc
+  val e_apply : (arg_label * expression) make_exp_desc
+  val e_match : case make_exp_desc
+  val e_try : case make_exp_desc
+  val e_tuple : expression make_exp_desc
+  val e_construct : Longident.t loc -> expression make_exp_desc
+  val e_variant : label -> expression make_exp_desc
+  val e_record : (Longident.t loc * expression) make_exp_desc
+  val e_field : Longident.t loc -> expression make_exp_desc
+  val e_setfield : Longident.t loc
+                   -> expression -> expression -> expression_desc
+  val e_array : expression make_exp_desc
+  val e_constraint : core_type -> expression make_exp_desc
+  val e_ifthenelse : expression -> expression
+                     -> expression option -> expression_desc
+  val e_sequence : expression -> expression -> expression_desc
+  *)
+
+  module type Typ =
+    sig
+      type t
+      val internal : t -> t -> bool
+      val leaf : t -> bool
+      val comp : ?mode:bool -> t -> t -> int
+      val map : (t -> t) -> t -> t
+      val map_all : (t -> t) -> t -> t
+      val fold : ('a -> t -> 'a) -> 'a -> t -> 'a
+      val fold_all : ('a -> t -> 'a) -> 'a -> t -> 'a
+      val replace : t -> t -> t
+    end
+
+  module Exp : Typ with type t = expression
+  module Pat : sig
+    include Typ with type t = pattern
+    val find : string -> t -> t
+  end
+  module Vb :
+  sig
+    val complete : (value_binding list) context_t -> (value_binding list)
+  end
+
+  module Str :
+  sig
+    val clear : structure -> structure
+    val output : string -> structure -> unit
+  end
+(*
+  (* ppat_desc の生成 *)
+  val p_alias : string loc -> pattern make_pat_desc
+  val p_tuple : pattern make_pat_desc
+  val p_construct : Longident.t loc -> pattern make_pat_desc
+  val p_variant : label -> pattern make_pat_desc
+  val p_record : closed_flag -> (Longident.t loc * pattern) make_pat_desc
+  val p_array : pattern make_pat_desc
+  val p_or : pattern -> pattern -> pattern_desc
+  val p_constraint : core_type -> pattern make_pat_desc
+
+  val restore : (arg_label * expression) list -> expression -> expression
+  val origin : expression -> expression
+*)
+end
+
+(* module Size  *)
+module Size : sig
+
+  val set_resize : bool
+
+  module type Typ =
+    sig
+      type t
+      val get : t -> int
+      val set : t -> t
+      val reset : int -> t -> t
+      val comp : ?e':t -> t -> int
+    end
+
+  module Exp : Typ with type t = expression
+
+(*
+  val get : int ->  expression -> int
+  val set : expression -> expression
+
+  val reset : expression -> expression
+  val reset1 : (int -> int -> int) -> expression -> expression
+
+  val resize : expression -> expression
+
+  val terminated : expression -> expression
+
+  val is1 : expression -> bool
+
+  val fltr1 : expression -> bool
+  val fltr0 : expression -> bool
+*)
+  val children : expression -> expression list
+(*
+  val get_child :
+    expression ->
+    expression * (expression -> expression) * (expression -> expression)
+
+  val getChild2 :
+    expression ->
+    expression * (expression -> expression) * (expression -> expression)
+  val getChild3 :
+    expression ->
+    expression * (expression -> expression) * (expression -> expression)
+*)
+  val getChildSet :
+    expression -> expression * (bool -> (expression -> expression) -> expression -> expression)
+  val getChildSet2 :
+    expression -> expression * (bool -> (expression -> expression) -> expression -> expression)
+(*
+  val check : expression -> bool
+
+  val get_one : expression -> int
+  val set_one : ?n:int -> expression -> expression
+  val set_all :
+    ('a list -> 'a list -> expression -> 'a Desc.make_exp_desc -> expression)
+    ->'a Desc.make_exp_desc -> ('a -> expression) -> 'a list -> expression
+    -> expression
+
+
+
+  val node_sort : expression -> expression list
+
+*)
+end
+
+(* module Abst *)
+(*
+module Abst : sig
+  module type Typ =
+    sig
+      type t
+      val hole : t -> t
+    end
+
+  module Exp : Typ with type t = expression
+
+  val set_one : expression -> expression list
+  val set_all : expression -> expression
+
+  val get : expression -> bool -> expression -> expression
+
+  val exp : expression -> expression
+
+end
+*)
+
+module Meta : sig
+
+  val clean : string -> expression -> expression
+
+end
+
+
+(* 型デバッガが訪れるノード数カウント用の変数 (debug_main.ml) *)
+
+val print_node_count : bool
+val print_asked_expr : bool
+
+(* スライス表示用変数 (debug_slice.ml) *)
+
+val print_slice : bool
+
+(* OCaml のエラーメッセージ Errors.report_error 制御用変数
+   (toplevel/toploop.ml, driver/compile.ml) *)
+
+val print_ocaml_error : bool
+
+(* スライスをするかどうかを制御する変数
+   (debug_slice.ml, debug_main.ml) *)
+
+val on_slice : bool
+val on_pat_slice : bool ref
+
+(* 各種情報をログに出力するかを制御する変数
+   (debug_core.ml, debug_slice.ml) *)
+val on_file_output : bool
+
+(* 表示用関数 *)
+val print_deb_exp : Format.formatter -> expression -> unit
+val print_deb_strs : Format.formatter -> structure -> unit
+
+(* 抽象化した構文
+   (debug_slice.ml, debug_main.ml) *)
+val dummy_int0 : expression
+val skeleton : expression
+val wildcard : pattern
+val dummy_fun : expression
+val dummy_assertfalse : expression -> expression
+val dummy_any : pattern -> pattern
+
+(* desc の置換を行う関数 *)
+val desc_to_exp : expression_desc -> expression -> expression
+val desc_to_pat : pattern_desc -> pattern -> pattern
+
+(* type_expr を扱う関数 *)
+val decode_labels : type_expr -> (structure_item * Env.t) list -> label_declaration list
+val split_arrow : type_expr -> (type_expr * type_expr) option
+
+val decode_tuple : type_expr -> type_expr list option
+
+(* デバッガの処理を行う関数
+   (debug_slice.ml, debug_main.ml) *)
+val pattern_variables : pattern -> string list
+val plug_expr : expression -> expr_context -> expression
+val plug_str : (expression * expr_context) -> structure
+
+val judge : expression context_t -> (string context_t * type_expr) list * type_expr 
+
+
+val skeleton' : expression
+val hole_str : structure_item
+
+val hole_of_exp : expression -> expression
+val hole_of_pat : pattern -> pattern
+
+module Data : sig
+  val log_path : string
+  val express_mode : int
+  (* DEBUGGER_EXPRESS_MODE
+     98 : スライスの出力
+     99 : コンパイラのエラーメッセージ出力
+     100 : デバッガと対話
+
+     終了番号
+     ~99 : DEBUGGER_EXPRESS_MODEによる停止
+     100 : デバッガの質問内容を出力
+     101~ : デバッガのエラーメッセージ出力（予定）
+  *)
+
+  module Loc : sig
+    val printJSON : Format.formatter -> Location.t -> unit
+  end
+
+  module Buffer : sig
+    val write : string -> expression -> string -> unit
+  end
+
+  module Slice : sig
+    module Exp :
+    sig
+      val write : expression -> unit
+      val outputs : unit -> unit
+    end
+  end
+
+  module Infer : sig
+    val init : string -> unit
+    val read : Location.t -> unit
+    val write : structure -> expression -> bool -> unit
+  end
+
+  val init : expression context_t -> expression
+
+  val typed : Env.t ->
+    ((expression -> expression) -> expression -> structure)
+    -> (expression -> expression) -> expression -> bool
+
+  val finally : expression -> float -> expression
+
+end
+
+(*
+module Library :
+sig
+
+  module type Abst_t =
+    sig
+      type t
+      val skeleton : t
+      val terminate : t -> t
+      val of_desc : t -> t
+      val of_attr : t -> t
+      val to_loc : t -> Location.t
+    end
+
+  module type Modules =
+    sig
+      type s
+      val internal : s -> s -> bool
+      val pos_start : s -> string * (int * int)
+      val pos_end : s -> string * (int * int)
+      val pos_ghost : s -> bool
+      val pos_all : s -> (string * ((int * int) * (int * int))) * bool
+
+      val print : bool -> Format.formatter -> s -> unit
+
+      module Desc : Desc.Typ with type t = s
+      module Hole : sig
+        include Abst_t with type t = s
+        val root : s -> s
+        val node : s -> s
+      end
+    end
+
+  val expression : (module Modules with type s = expression)
+end
+
+(*
+module Node :
+sig
+  type loc_t = {
+    line : int;
+    char : int;
+  }
+  type pos_t = {
+    filename : string;
+    s : loc_t;
+    e : loc_t;
+  }
+  type slice_t = {
+    pos : pos_t;
+    ghost : int;
+  }
+  type buffer_t = {
+    scope : string option;
+    typ : bool * pos_t;
+  }
+  type infer_t = {
+    section : (float * bool option) list;
+    total : float;
+    root : expression;
+  }
+
+  type t = {
+    userID : string option; (* ユーザID。node の実行に必要 *)
+    date : string option; (* 日時 *)
+    slice : slice_t list; (* 既存のスライス情報 *)
+    buffer : buffer_t list; (* ユーザの回答 *)
+    infer : infer_t list; (* 型推論の記録 *)
+  }
+
+  module Null :
+  sig
+    val loc : loc_t
+    val pos : pos_t
+    val slice : slice_t
+  end
+
+  (* flg の設定 *)
+  module Input :
+  sig
+    val err : exn -> unit
+    val node : expression -> int * int * type_expr option -> unit
+    val ask : ?scope:string -> expression -> type_expr -> unit
+    val expr : expression * type_expr -> unit
+    val result : int -> expression context_t -> unit
+  end
+
+  module Output :
+  sig
+    val f : unit -> unit
+    val buffer : buffer_t -> unit
+    val slicer : expression -> t -> int * (expression * expression) list -> unit
+  end
+
+  module Check :
+  sig
+    val slice : t -> bool
+    val json : unit -> bool (* node.js 用の出力の有無 *)
+  end
+
+  val init : unit -> t ref
+  val typed : t ref -> Env.t -> structure -> bool
+
+  val yes : expression -> attribute
+  val no : expression -> attribute
+
+  val of_exp : t -> expression -> expression
+end
+
+*)
+*)
diff --git a/typing/debug_main.ml b/typing/debug_main.ml
new file mode 100644
index 0000000..ab8e599
--- /dev/null
+++ b/typing/debug_main.ml
@@ -0,0 +1,3056 @@
+open Asttypes
+open Ast_helper
+
+open Typedtree
+
+open Location
+open Parsetree
+
+open Debug_core
+open Debug_message
+
+let auto = false
+
+let skeleton = skeleton'
+
+type debugger_state_t =
+  | Null
+  | Evaluate of Location.error
+  | Interactive of Location.t * string option
+
+let debugger_state = ref Null
+
+let setCompileError exn = match error_of_exn exn with
+  | None -> true
+  | Some t -> debugger_state := Evaluate t; false
+let getCompileError () = match !debugger_state with
+  | Evaluate error -> error
+  | _ -> failwith "not set compile error"
+
+(* skeleton : expression *)
+(* dummy_assertfalse : expression -> expression *)
+
+(* ppf : Format.formatter *)
+let ppf = Format.std_formatter
+
+(* language_level : int *)
+let language_level = Syntaxerr.language_level
+
+(* debug : int *)
+let debug = try
+  int_of_string (Sys.getenv "TRACE_DEBUGGER")
+with _ -> 0
+(* 0 : no trace *)
+(* 1 : overall progress *)
+(* 2 : illtyped *)
+(* 4 : recursive env *)
+(* 8 : make message illtyped *)
+
+exception DebuggerQuit
+
+(* ブラウザ実行時は、逐次停止させる *)
+(*
+exception DebuggerPaused of string option * string * int * int * int * int * int
+ *)
+
+
+(* find_funtype_args : type_expr list -> int -> (int * type_expr) list *)
+(* int は 何番目の引数かを記憶 *)
+let rec find_funtype_args lst n = match lst with
+    [] -> []
+  | typ :: rest ->
+      begin match split_arrow typ with
+          None -> find_funtype_args rest (n + 1)
+        | Some (_, _) -> (n, typ) :: find_funtype_args rest (n + 1)
+      end
+
+(********** pat_appears **********)
+
+(* pattern_variables : pattern -> string list *)
+(* collect all the pattern variables in a pattern *)
+(*
+let rec pattern_variables pat = match pat.ppat_desc with
+    Ppat_any -> []
+  | Ppat_var ({txt = st}) -> [st]
+  | Ppat_alias (p, {txt = st}) -> st :: pattern_variables p
+  | Ppat_constant (_) -> []
+  | Ppat_interval (_, _) -> []
+  | Ppat_tuple (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_construct (_, None) -> []
+  | Ppat_construct (_, Some (p)) -> pattern_variables p
+  | Ppat_variant (_, None) -> []
+  | Ppat_variant (_, Some (p)) -> pattern_variables p
+  | Ppat_record (lps, _) ->
+      List.flatten (List.map (fun (_, p) -> pattern_variables p) lps)
+  | Ppat_array (ps) -> List.flatten (List.map pattern_variables ps)
+  | Ppat_or (p1, p2) -> pattern_variables p1 @ pattern_variables p2
+  | Ppat_constraint (p, _) -> pattern_variables p
+  | Ppat_type (_) -> []
+  | Ppat_lazy (p) -> pattern_variables p
+  | Ppat_unpack ({txt = st}) -> [st]
+  | Ppat_exception (p) -> pattern_variables p
+  | Ppat_extension (_) -> []
+  | Ppat_open (_, p) -> pattern_variables p
+ *)
+
+(* pat_appears : string -> pattern -> bool *)
+let pat_appears st pat = List.mem st (pattern_variables pat)
+
+(********** expr_context **********)
+(*
+type expr_context =
+    Empty
+  | Lambda of pattern * expr_context
+    (* TODO: incorporate labeled arguments, currently ignored *)
+  | Let of rec_flag * value_binding list * expr_context
+ *)
+
+(* type of prefix: reversed list of structure and environment *)
+(* type str_context = (structure_item * Env.t) list *)
+
+(* type of contexts *)
+(* type 'a context_t = ('a * expr_context) * Env.t * str_context *)
+
+(* expression context_t 型の値 ((exp, cxt), env, lst) の意味は以下 *)
+(* env は (exp, cxt) を実行する際の環境 *)
+(* lst は (structure, env) の逆順のリストで env は structure 実行前の環境 *)
+
+(********** plug **********)
+(*
+(* plug_expr : expression -> expr_context -> expression *)
+let rec plug_expr expr cxt = match cxt with
+  | Empty -> expr
+  | Lambda (pat, c) ->
+      (* パターン変数を全て集め *)
+      let vars = pattern_variables pat in
+      (* 変数名から変数の expression を作る *)
+      let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in
+      (* expr と組にして body に入れる。これでパターン変数の型を知る *)
+      (* ダミーの 0 を入れるのは、tuple 長が 2 以上でないとエラーになるため *)
+      let body = Exp.mk (Pexp_tuple
+                          (expr :: dummy_int0 :: List.map varexp vars)) in
+      let exp = Exp.mk (Pexp_fun (Nolabel, None, pat, body)) in
+      plug_expr exp c
+  | Let (flag, bindings, c) ->
+      plug_expr { pexp_desc        = Pexp_let (flag, bindings, expr);
+                  pexp_loc         = Location.none;
+                  pexp_attributes  = [] }
+                c
+
+(* plug_str : expression * expr_context -> structure *)
+let plug_str (expr, cxt) =
+  [{ pstr_desc = Pstr_eval (plug_expr expr cxt, []);
+     pstr_loc  = Location.none }]
+ *)
+
+(********** is_well_typed **********)
+
+(* is_well_typed_structure : structure -> Env.t -> bool *)
+(* Error = Location * Env * error になったので引数に env を加えた *)
+let is_well_typed_structure structure env =
+  try
+    ignore (Typemod.type_structure env structure Location.none);
+    (* Format.fprintf ppf "@[:welltyped@]@."; *)
+    true
+  with Typecore.Error (_, _, Typecore.Expr_type_clash (_))
+     | Typecore.Error (_, _, Typecore.Pattern_type_clash (_))
+     | _ (* Unbound value *)
+     ->
+       (* Format.fprintf ppf "@[:illtyped@]@."; *)
+       false
+
+(* is_well_typed_expr : expression context_t -> bool *)
+let is_well_typed_expr ((expr, cxt), env, _) =
+  is_well_typed_structure (plug_str (expr, cxt)) env
+
+(********** get **********)
+
+(* get_var_from_prefix : string -> str_context -> expression context_t list *)
+(* returns [] if not found; otherwise [((e, cxt), env, prefix)] *)
+let rec get_var_from_prefix st prefix = match prefix with
+    [] -> [] (* This happens when no binding is found, such as for '+' *)
+  | ({ pstr_desc = Pstr_value (flg, bindings) }, env) :: rest ->
+      (* let 文のみ考慮 *)
+      let rec loop bindings' = match bindings' with
+          [] -> get_var_from_prefix st rest
+        | {pvb_pat = p; pvb_expr = e} :: rest' ->
+            if pat_appears st p then
+              if flg = Recursive
+              then (* 定義された全ての変数が見えている *)
+                let cxt' = List.fold_right
+                             (fun {pvb_pat = pat} c -> Lambda (pat, c))
+                             bindings Empty in
+                [((e, cxt'), env, prefix)]
+              else [((e, Empty), env, rest)]
+            else loop rest'
+      in loop bindings
+  | _ :: rest ->
+      get_var_from_prefix st rest
+
+(* get_var_from_context : string context_t -> expression context_t list *)
+(* returns [] if not found; otherwise [((e, cxt), env, prefix)] *)
+let rec get_var_from_context ((st, cxt), env, prefix) = match cxt with
+    Empty -> get_var_from_prefix st prefix
+  | Lambda (p, cxt') -> (* もし p に現れていたら、その変数の定義はない *)
+      if pat_appears st p then []
+      else get_var_from_context ((st, cxt'), env, prefix)
+  | Let (flg, bindings, cxt') ->
+      let rec loop bindings' = match bindings' with
+          [] -> get_var_from_context ((st, cxt'), env, prefix)
+        | {pvb_pat = p; pvb_expr = e} :: rest ->
+            if pat_appears st p then
+              if flg = Recursive
+              then (* 定義された全ての変数が見えている *)
+                let cxt'' = List.fold_right
+                              (fun {pvb_pat = pat} c -> Lambda (pat, c))
+                              bindings cxt in
+                [((e, cxt''), env, prefix)]
+              else [((e, cxt'), env, prefix)]
+            else loop rest
+      in loop bindings
+
+(* structure_to_prefix : structure -> Env.t -> str_context ->
+                         Env.t * str_context *)
+let rec structure_to_prefix structure env prefix = match structure with
+    [] -> (env, prefix)
+  | s :: rest ->
+      let (_, _, env') = Typemod.type_structure env [s] Location.none in
+      structure_to_prefix rest env' ((s, env) :: prefix)
+
+(* get_module_from_prefix : string -> Env.t -> str_context ->
+                            (Env.t * str_context) option *)
+let rec get_module_from_prefix st env prefix = match prefix with
+    [] -> None (* This happens when no binding is found, such as for 'List' *)
+  | ({ pstr_desc = Pstr_module ({pmb_name = {txt = st'};
+                                 pmb_expr = {pmod_desc = Pmod_structure
+                                                           (structure)}}) },
+     env) :: rest ->
+      (* module A = struct ... end 文のみ考慮 *)
+      if st = st'
+      then Some (structure_to_prefix structure env prefix)
+      else get_module_from_prefix st env rest
+  | _ :: rest -> (* 他は無視。しかし recmodule は必要っぽい *)
+      get_module_from_prefix st env rest
+
+(* get_module : Longident.t context_t -> (Env.t * str_context) option *)
+let rec get_module ((longident, cxt), env, prefix) = match longident with
+    Longident.Lident (st) ->
+      get_module_from_prefix st env prefix
+  | Longident.Ldot (longident, st) ->
+      begin match get_module ((longident, cxt), env, prefix) with
+          None -> None
+        | Some (env', prefix') -> get_module_from_prefix st env' prefix'
+      end
+  | Longident.Lapply (_, _) ->
+      failwith "TypeDebugger: Longident.Lapply in get_module"
+
+(* get : Longident.t context_t -> expression context_t list *)
+let get ((longident, cxt), env, prefix) = match longident with
+    Longident.Lident (st) ->
+      get_var_from_context ((st, cxt), env, prefix)
+  | Longident.Ldot (longident, st) ->
+      begin match get_module ((longident, cxt), env, prefix) with
+          None -> []
+        | Some (_, prefix') -> get_var_from_prefix st prefix'
+      end
+  | Longident.Lapply (_, _) ->
+      failwith "TypeDebugger: Longident.Lapply in get"
+
+(********** pattern **********)
+
+(* wrap_exp : expression_desc -> pattern -> expression *)
+let wrap_exp desc {ppat_desc = _; ppat_loc = l; ppat_attributes = a} =
+  {pexp_desc = desc; pexp_loc = l; pexp_attributes = a}
+
+(* pat_to_exp : pattern -> expression *)
+let rec pat_to_exp pat = match pat.ppat_desc with
+  | Ppat_any ->
+      (* _ *)
+      skeleton
+  | Ppat_var ({txt = st; loc = loc'}) ->
+      (* Ppat_var of string loc *)
+      (* x *)
+      wrap_exp (Pexp_ident ({txt = Longident.Lident(st); loc = loc'})) pat
+  | Ppat_constant (c) ->
+      (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
+      wrap_exp (Pexp_constant (c)) pat
+  | Ppat_tuple (ps) ->
+      (* Ppat_tuple of pattern list *)
+      (* (P1, ..., Pn) Invariant: n >= 2 *)
+      wrap_exp (Pexp_tuple (List.map pat_to_exp ps)) pat
+  | Ppat_construct (lid, p) ->
+      (* Ppat_construct of Longident.t loc * pattern option *)
+      (* C                None
+         C P              Some P
+         C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn]) *)
+      wrap_exp (Pexp_construct (lid, match p with
+                                         None -> None
+                                       | Some p' -> Some (pat_to_exp p')))
+               pat
+  | Ppat_record (lps, _) ->
+      (* Ppat_record of (Longident.t loc * pattern) list * closed_flag *)
+      (* { l1=P1; ...; ln=Pn }     (flag = Closed)
+         { l1=P1; ...; ln=Pn; _}   (flag = Open)
+         Invariant: n > 0 *)
+      (* パターンにフィールドが全部、書かれていないとエラーになる *)
+      (* 要対処 *)
+
+      wrap_exp (Pexp_record (List.map (fun (l, p) -> (l, pat_to_exp p)) lps,
+                             None))
+               pat
+  | Ppat_constraint (p, ct) ->
+      (* (P : T) *)
+      wrap_exp (Pexp_constraint (pat_to_exp p, ct)) pat
+  | _ -> skeleton
+
+(* wrap_pat : pattern_desc -> pattern -> pattern *)
+let wrap_pat desc {ppat_desc = _; ppat_loc = l; ppat_attributes = a} =
+  {ppat_desc = desc; ppat_loc = l; ppat_attributes = a}
+
+(* cons_unconstrained_pat : pattern -> expr_context -> expr_context *)
+(* pat を（型制約のない）変数の列のパターンに変換して cxt の上に積む *)
+let cons_unconstrained_pat pat cxt = match pattern_variables pat with
+  | [] -> cxt
+  | first :: [] ->
+      Lambda (wrap_pat (Ppat_var ({txt = first; loc = Location.none})) pat,
+              cxt)
+  | lst ->
+      let lst' = List.map (fun s -> wrap_pat (Ppat_var ({txt = s;
+                                                         loc = Location.none}))
+                                             pat)
+                          lst in
+      Lambda (wrap_pat (Ppat_tuple lst') pat, cxt)
+
+(* extract_pattern : expression -> pattern list *)
+let extract_pattern exp = match exp.pexp_desc with
+    Parsetree.Pexp_let (_, bindings, _) ->
+      List.map (fun {pvb_pat = pat} -> pat) bindings
+  | Parsetree.Pexp_function (cases) ->
+      List.map (fun {pc_lhs = pat} -> pat) cases
+  | Parsetree.Pexp_fun (_, _, pat, _) -> [pat]
+  | Parsetree.Pexp_match (_, cases) ->
+      List.map (fun {pc_lhs = pat} -> pat) cases
+  | Parsetree.Pexp_try (_, cases) ->
+      List.map (fun {pc_lhs = pat} -> pat) cases
+(*| Parsetree.Pexp_for (_, exp1, exp2, _, exp3) -> [] *)
+(*| Parsetree.Pexp_letmodule (_, _, exp) -> [] *)
+  | _ -> []
+
+(* decompose_pattern : pattern -> pattern list *)
+let decompose_pattern pat = match pat.ppat_desc with
+    Ppat_any -> []
+  | Ppat_var (_) -> []
+  | Ppat_alias (p, _) -> [p]
+  | Ppat_constant (_) -> []
+  | Ppat_interval (_, _) -> []
+  | Ppat_tuple (ps) -> ps
+  | Ppat_construct (_, None) -> []
+  | Ppat_construct (_, Some (p)) -> [p]
+  | Ppat_variant (_, None) -> []
+  | Ppat_variant (_, Some (p)) -> [p]
+  | Ppat_record (lps, _) -> List.map (fun (_, p) -> p) lps
+  | Ppat_array (ps) -> ps
+  | Ppat_or (p1, p2) -> [p1; p2]
+  | Ppat_constraint (p, _) -> [p]
+  | Ppat_type (_) -> []
+  | Ppat_lazy (p) -> [p]
+  | Ppat_unpack (_) -> []
+  | Ppat_exception (p) -> [p]
+  | Ppat_extension (_) -> []
+  | Ppat_open (_, p) -> [p]
+
+(********** decompose **********)
+
+(* two phases of decompose *)
+type decompose_phase_t =
+    Illtyped (* decompose する式には型がつかない *)
+  | Typed    (* decompose する式に型はついている *)
+
+(* decompose_case : case context_t -> expression context_t list *)
+let decompose_case ((case, cxt), env, prefix) = match case with
+  | {pc_lhs = pat; pc_guard = None; pc_rhs = exp} ->
+      let cxt' = cons_unconstrained_pat pat cxt in
+      [((exp, cxt'), env, prefix); ((pat_to_exp pat, cxt'), env, prefix)]
+  | {pc_lhs = pat; pc_guard = Some (g); pc_rhs = exp} ->
+      let cxt' = cons_unconstrained_pat pat cxt in
+      [((g, cxt), env, prefix);
+       ((pat_to_exp pat, cxt'), env, prefix);
+       ((exp, cxt'), env, prefix)]
+
+(* decompose_expr : expression context_t -> decompose_phase_t ->
+                    expression context_t list *)
+let decompose_expr ((exp, cxt), env, prefix) phase =
+  match exp.pexp_desc with
+     Parsetree.Pexp_ident ({txt = longident}) ->
+       begin match phase with
+           Illtyped -> []
+         | Typed -> get ((longident, cxt), env, prefix)
+       end
+   | Parsetree.Pexp_constant (_) -> []
+   | Parsetree.Pexp_let (rec_flg, bindings, exp) ->
+       (* let 文で定義された変数を含めたコンテキストを cxt' とする *)
+       let cxt' = List.fold_right (fun {pvb_pat = pat} c ->
+                                    cons_unconstrained_pat pat c)
+                                  bindings cxt in
+       begin match phase with
+(* ------------------------------------------------------------------------ *)
+(*
+  Illtyped ->
+    if rec_flg = Recursive
+    (* let rec ではパターンは書けないためパターンについては考慮不要 *)
+    then let bindings' = List.map (fun binding ->
+                                    {binding with pvb_expr = skeleton})
+                                  bindings in
+         List.fold_right
+           (fun {pvb_expr = exp} lst -> ((exp, cxt'), env, prefix) :: lst)
+           bindings [((exp, Let (rec_flg, bindings', cxt)), env, prefix)]
+(*       List.map (fun {pvb_expr = exp} -> ((exp, cxt'), env, prefix)) bindings
+         @ [((exp, Let (rec_flg, bindings', cxt)), env, prefix)] *)
+    (* let ではパターンを考慮 *)
+    (* （まだ考慮できていない） *)
+    else List.fold_right
+           (fun {pvb_pat = pat; pvb_expr = exp} lst ->
+             ((pat_to_exp pat, cxt), env, prefix) ::
+             ((exp, cxt), env, prefix) :: lst)
+           bindings [((exp, cxt'), env, prefix)]
+(*       List.map (fun {pvb_expr = exp} -> ((exp, cxt), env, prefix)) bindings
+         @ [((exp, cxt'), env, prefix)] *)
+| Typed -> [((exp, Let (rec_flg, bindings, cxt)), env, prefix)] (* cxt'? *)
+         (* exp 中から束縛された値が見える *)
+ *)
+(* ------------------------------------------------------------------------ *)
+  Illtyped ->
+    (* let 文で定義された変数を含めたコンテキストを cxt' とする *)
+(*    let cxt' = List.fold_right (fun {pvb_pat = pat} c -> Lambda (pat, c))
+                               bindings cxt in *)
+    if rec_flg = Recursive
+    then let bindings' = List.map (fun binding ->
+                                    {binding with pvb_expr = dummy_fun})
+                                  bindings in
+         List.map (fun {pvb_expr = exp} -> ((exp, cxt'), env, prefix)) bindings
+         @ [((exp, Let (rec_flg, bindings', cxt)), env, prefix)]
+    else let bindings' = List.map (fun binding ->
+                                    {binding with pvb_expr = skeleton})
+                                  bindings in
+         List.map (fun {pvb_expr = exp} -> ((exp, cxt), env, prefix)) bindings
+         @ [((exp, Let (rec_flg, bindings', cxt)), env, prefix)]
+(*
+| Typed_fv ->
+       (* let 文で定義された変数を含めたコンテキストを cxt' とする *)
+       let cxt' = List.fold_right (fun (pat, _) c -> expand_lambda pat c)
+                                  bindings cxt in
+       (if rec_flg = Recursive
+        then List.map (fun (_, exp) -> ((exp, cxt'), env, prefix)) bindings
+             (* 再帰関数なら、cxt' を使う *)
+        else List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) bindings)
+       @ [((exp, Let (rec_flg, bindings, cxt)), env, prefix)]
+         (* exp 中から束縛された値が見える *)
+*)
+| Typed -> [((exp, Let (rec_flg, bindings, cxt)), env, prefix)]
+         (* exp 中から束縛された値が見える *)
+(* ------------------------------------------------------------------------ *)
+       end
+   | Parsetree.Pexp_function (cases) ->
+       List.flatten (List.map
+                      (fun case -> decompose_case ((case, cxt), env, prefix))
+                      cases)
+   | Parsetree.Pexp_fun (_, None, pat, exp) ->
+       let cxt' = cons_unconstrained_pat pat cxt in
+       let exp' = pat_to_exp pat in
+        ((exp', cxt'), env, prefix) :: [((exp, cxt'), env, prefix)]
+   | Parsetree.Pexp_fun (_, Some (exp1), pat, exp) ->
+      let cxt' = cons_unconstrained_pat pat cxt in
+      ((exp1, cxt), env, prefix) :: (
+        (pat_to_exp pat, cxt'), env, prefix) :: [((exp, cxt'), env, prefix)]
+   | Parsetree.Pexp_apply (exp, lexps) ->
+       ((exp, cxt), env, prefix) ::
+       List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_match (exp, cases) ->
+       ((exp, cxt), env, prefix) ::
+       List.flatten (List.map
+                      (fun case -> decompose_case ((case, cxt), env, prefix))
+                      cases)
+   | Parsetree.Pexp_try (exp, cases) ->
+       ((exp, cxt), env, prefix) ::
+       List.flatten (List.map
+                      (fun case -> decompose_case ((case, cxt), env, prefix))
+                      cases)
+   | Parsetree.Pexp_tuple (exps) ->
+       List.map (fun exp -> ((exp, cxt), env, prefix)) exps
+   | Parsetree.Pexp_construct (_, None) -> []
+   | Parsetree.Pexp_construct (_, Some ({pexp_desc = Pexp_tuple (exps)})) ->
+       (* :: など infix の構成子だと組をハイライトできないため *)
+       List.map (fun exp -> ((exp, cxt), env, prefix)) exps
+   | Parsetree.Pexp_construct (_, Some (exp)) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_variant (_, None) -> []
+   | Parsetree.Pexp_variant (_, Some (exp)) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_record (lexps, None) ->
+       List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_record (lexps, Some (exp)) ->
+       ((exp, cxt), env, prefix) ::
+       List.map (fun (_, exp) -> ((exp, cxt), env, prefix)) lexps
+   | Parsetree.Pexp_field (exp, _) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_setfield (exp1, _, exp2) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_array (exps) ->
+       List.map (fun exp -> ((exp, cxt), env, prefix)) exps
+   | Parsetree.Pexp_ifthenelse (exp1, exp2, None) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_ifthenelse (exp1, exp2, Some (exp3)) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix);
+        ((exp3, cxt), env, prefix)]
+   | Parsetree.Pexp_sequence (exp1, exp2) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_while (exp1, exp2) ->
+       [((exp1, cxt), env, prefix); ((exp2, cxt), env, prefix)]
+   | Parsetree.Pexp_constraint (exp, _)
+       when exp = hole_of_exp exp ->
+       []
+   | Parsetree.Pexp_constraint (exp1, typ) ->
+       let exp' = { exp with
+                    pexp_desc = Pexp_constraint (hole_of_exp exp, typ) }
+       in [((exp', cxt), env, prefix);
+           ((exp1, cxt), env, prefix)]
+   | Parsetree.Pexp_send (exp, _) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_setinstvar (_, exp) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_assert (exp) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_lazy (exp) ->
+       [((exp, cxt), env, prefix)]
+   | Parsetree.Pexp_open (_, _, exp) ->
+       [((exp, cxt), env, prefix)]
+   | _ ->
+       Format.fprintf ppf
+         "default case of decompose:@ %a@." Pprintast.expression exp;
+       []
+
+(********** obtain type and environment of expr **********)
+
+(* type of elements of yes/no list *)
+(* type yes_no_list = (string context_t * type_expr) list *)
+(* yes_no_list という名前を使っているが、ここでは環境として使っている *)
+
+(* collect_one : (string context_t * type_expr) list context_t -> string list ->
+                 type_expr -> yes_no_list * type_expr *)
+let collect_one ((vartyps, cxt'), env, prefix) vars typ =
+  match decode_tuple typ with
+      Some (exp_typ :: _ :: typs) -> (* _ は dummy_int0 の型 *)
+        (List.map2 (fun v t -> (((v, cxt'), env, prefix), t)) vars typs
+         @ vartyps,
+         exp_typ)
+    | Some ([_]) | Some ([]) | None ->
+        Format.fprintf ppf "type:@.%a@." Printtyp.type_expr typ;
+        failwith "TypeDebugger: Error in collect_one"
+
+(* collect : expression context_t -> type_expr -> yes_no_list * type_expr *)
+let rec collect ((expr, cxt), env, prefix) t = match cxt with
+    Empty -> ([], t)
+  | Lambda (pat, cxt') ->
+      (* There and back again [Danvy&Goldberg ICFP'02] *)
+      let (vartyps, t') = collect ((expr, cxt'), env, prefix) t in
+      let vars = pattern_variables pat in
+      begin match split_arrow t' with
+          Some (_, t2) ->
+            collect_one ((vartyps, cxt'), env, prefix) vars t2
+        | None -> (* Can't happen *)
+            failwith "TypeDebugger: Error in collect"
+      end
+  | Let (_, _, cxt') -> collect ((expr, cxt'), env, prefix) t
+
+(* judge : expression context_t -> yes_no_list * type_expr *)
+let judge ((expr, cxt), env, prefix) =
+  let structure = plug_str (expr, cxt) in
+  let (structure', _, _) = Typemod.type_structure env structure Location.none in
+  match structure'.str_items with
+    {str_desc = Tstr_eval ({ exp_type = typ }, _)} :: [] ->
+      collect ((expr, cxt), env, prefix) typ
+  | _ -> failwith "TypeDebugger: Error in judge"
+
+(********** check whether the question was already answered **********)
+
+(* trace_answer : bool *)
+(* change this variable to true to show the answer trace *)
+let trace_answer = false
+
+(* answered_yes : string context_t -> type_expr -> yes_no_list -> Env.t ->
+                  bool *)
+let answered_yes (((st, _), _, _) as key) typ yes env = try
+  let t = List.assoc key yes in
+  let b = Ctype.moregeneral env false typ t in
+  if trace_answer then Format.fprintf ppf "answered_yes %s = %b@\n" st b;
+  b
+with Not_found -> false
+
+(* answered_no : string context_t -> type_expr -> yes_no_list -> Env.t ->
+                 bool *)
+let answered_no (((st, _), _, _) as key) typ no env = try
+  let t = List.assoc key no in
+  let b = Ctype.moregeneral env false t typ in
+  if trace_answer then Format.fprintf ppf "answered_no %s = %b@\n" st b;
+  b
+with Not_found -> false
+
+(********** the source of the type error identified; make messages **********)
+
+(* iter4 : ('a -> 'b -> 'c -> 'd -> unit) ->
+           'a list -> 'b list -> 'c list -> 'd list -> unit *)
+let rec iter4 f lst1 lst2 lst3 lst4 = match (lst1, lst2, lst3, lst4) with
+    ([], [], [], []) -> ()
+  | (f1 :: r1, f2 :: r2, f3 :: r3, f4 :: r4) ->
+      f f1 f2 f3 f4;
+      iter4 f r1 r2 r3 r4
+  | (_, _, _, _) ->
+      failwith "TypeDebugger: Error in iter4"
+
+(* make_message_pattern : pattern context_t -> unit *)
+let make_message_pattern ((pat, _), _, _) =
+  print_loc pat.ppat_loc;
+  print_identified ();
+  print_pattern ()
+
+(* make_message_recursive1 : value_binding context_t -> unit *)
+(* 長さが１の場合を特別扱い（長さ 1 の tuple が許されないため） *)
+let make_message_recursive1 ((binding, cxt), env, prefix) =
+  (* パターンを集めてくる *)
+  let pat = binding.pvb_pat in
+  (* その中の変数 *)
+  let vars = pattern_variables pat in
+  begin match vars with
+      [] -> (* Can't happen *)
+        failwith "TypeDebugger: Error in make_message_recursive1a"
+    | [var] ->
+        (* 変数名から変数の expression を作る関数 *)
+        let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in
+        (* body を定義される変数にした再帰しない let 文 *)
+        let exp1 = Exp.mk (Pexp_let (Nonrecursive, [binding], varexp var)) in
+        (* それを単相の vars 用の fun 文で囲む *)
+        (* bindings = let rec f = e in ... なら *)
+        (* exp2 = fun f -> let f = e in f *)
+        (* fun f が used_typ を与え in f が inferred_typ を与える *)
+        let exp2 = Exp.mk (Pexp_fun (Nolabel, None, pat, exp1)) in
+        if debug land 4 = 4 then Format.fprintf ppf "exp2:@.%a@."
+                                   Pprintast.expression exp2;
+        (* その型を求める *)
+        let (_, typ) = judge ((exp2, cxt), env, prefix) in
+        begin match split_arrow typ with
+            None -> (* Can't happen *)
+              failwith "TypeDebugger: Error in make_message_recursive1b"
+          | Some (used_typ, inferred_typ) ->
+              print_loc binding.pvb_expr.pexp_loc;
+              print_identified ();
+              print_recursive inferred_typ var used_typ
+              (*
+              以下の場合分けは不要。then のケースは occur check に
+              引っかかったことを示す。let rec f x = f とか。
+              if Ctype.moregeneral env false used_typ inferred_typ
+              then print_recursive inferred_typ var used_typ
+              else print_recursive inferred_typ var used_typ
+              *)
+        end
+    | _ :: _ -> (* let rec で定義されるものが変数ではなくパターン *)
+        failwith "TypeDebugger: non-variable let rec not supported1."
+  end
+
+(* make_message_recursive_many : value_binding list context_t -> unit *)
+let make_message_recursive_many ((bindings, cxt), env, prefix) =
+  (* パターンを集めてくる *)
+  let pats = List.map (fun {pvb_pat = pat} -> pat) bindings in
+  (* その中の変数たち *)
+  let varss = List.map pattern_variables pats in
+  if List.exists (fun vars -> List.length vars <> 1) varss
+  then (* let rec で定義されるものが変数ではなくパターン *)
+    failwith "TypeDebugger: non-variable let rec not supported."
+  else
+    (* 定義される変数全て *)
+    let vars = List.flatten varss in
+    (* 変数名から変数の expression を作る関数 *)
+    let varexp x = Exp.mk (Pexp_ident (mknoloc (Longident.Lident x))) in
+    (* body を定義される変数の組にした再帰しない let 文 *)
+    let body = Exp.mk (Pexp_tuple (List.map varexp vars)) in
+    let exp1 = Exp.mk (Pexp_let (Nonrecursive, bindings, body)) in
+    (* それを単相の vars 用の fun 文で囲む *)
+    (* bindings = let rec f1 = e1 and f2 = e2 in ... なら *)
+    (* exp2 = fun (f1, f2) -> let f1 = e1 and f2 = e2 in (f1, f2) *)
+    let pat2 = Pat.mk (Ppat_tuple pats) in
+    let exp2 = Exp.mk (Pexp_fun (Nolabel, None, pat2, exp1)) in
+    (* その型を求める *)
+    let (_, typ) = judge ((exp2, cxt), env, prefix) in
+    begin match split_arrow typ with
+        None -> (* Can't happen *)
+          failwith "TypeDebugger: Error in make_message_recursive_many"
+      | Some (used_typ, inferred_typ) ->
+          begin match (decode_tuple used_typ, decode_tuple inferred_typ) with
+              (Some (used_typs), Some (inferred_typs)) ->
+                print_identified ();
+                iter4 (fun utyp ityp var binding ->
+                         if Ctype.moregeneral env false utyp ityp
+                         then ()
+                         else begin
+                           print_loc binding.pvb_expr.pexp_loc;
+                           print_recursive ityp var utyp
+                         end)
+                      used_typs inferred_typs vars bindings
+            | (_, _) ->
+                failwith "TypeDebugger: Error in make_message_recursive_many2"
+          end
+    end
+
+(* make_message_recursive : value_binding list context_t -> unit *)
+(* recursive なパターン pats = exps が型エラーの原因 *)
+(* 関数の定義と再帰呼び出し時の型がずれている *)
+let make_message_recursive ((bindings, cxt), env, prefix) = match bindings with
+    [] -> (* Can't happen *)
+      failwith "TypeDebugger: Error in make_message_recursive"
+  | [binding] ->
+      make_message_recursive1 ((binding, cxt), env, prefix)
+  | _ :: _ ->
+      make_message_recursive_many ((bindings, cxt), env, prefix)
+
+(* make_message_bindings : value_binding list context_t -> unit *)
+(* パターン pats = exps が型エラーの原因 *)
+(* binding は recursive ではない *)
+let make_message_bindings ((bindings, cxt), env, prefix) =
+  let rec loop bindings = match bindings with
+      [] -> failwith "TypeDebugger: Error in make_message_bindings"
+    | {pvb_pat = pat; pvb_expr = exp} as binding :: rest ->
+        let exp0 = { pexp_desc       = Pexp_let (Nonrecursive, [binding],
+                                                skeleton);
+                     pexp_loc        = Location.none;
+                     pexp_attributes = [] } in
+        if is_well_typed_expr ((exp0, cxt), env, prefix)
+        then loop rest
+        else begin match pat with
+            { ppat_desc = Ppat_constant (_) } -> (* constant のとき *)
+              print_loc pat.ppat_loc;
+              print_identified ();
+              print_patexps2 ()
+          | _ -> (* それ以外のパターン *)
+              let (_, typ) = judge ((exp, cxt), env, prefix) in
+              print_loc exp.pexp_loc;
+              print_identified ();
+              print_patexps typ
+        end
+  in loop bindings
+
+(* とりあえず型チェック *)
+let make_message_case ((case, cxt), env, prefix) =
+  (* case の式を歩く関数 *)
+  let rec walk_in_case exp progs = match progs with
+    | [] ->
+       let (lhs, rhs) = (case.pc_lhs, case.pc_rhs) in
+       if exp = skeleton then
+         let progs' =
+           decompose_expr ((case.pc_rhs, cxt), env, prefix) Illtyped in
+         walk_in_case skeleton progs'
+       else
+         (* 変数を特定 *)
+         let loc =
+           let (lloc, rloc) = (lhs.ppat_loc, rhs.pexp_loc) in
+           {loc_start = lloc.loc_start;
+            loc_end = rloc.loc_end;
+            loc_ghost = rloc.loc_ghost;} in
+         (lhs, loc, exp)
+    | ((expr', _), env', _) :: rest ->
+       try
+         ignore(Typecore.type_expression env' expr');
+         walk_in_case exp rest
+       with
+       | _ ->
+          (* expr' がエラーになる式だった *)
+          let rest' =
+            decompose_expr ((expr', cxt), env, prefix) Illtyped in
+          walk_in_case expr' rest' in
+  (* 実行結果 *)
+  let (_, loc, exp) = walk_in_case skeleton [] in
+  print_loc loc;
+  print_identified ();
+  print_illtyped_case exp
+
+(* bool_typ : core_type *)
+let bool_typ = Typ.mk (Ptyp_constr (mknoloc (Longident.Lident "bool"), []))
+                          
+(* unit_typ : core_type *)
+let unit_typ = Typ.mk (Ptyp_constr (mknoloc (Longident.Lident "unit"), []))
+
+(* is_bool_expr : expression context_t -> bool *)
+let is_bool_expr ((exp, cxt), env, prefix) =
+  (* exp with bool annotation *)
+  let exp' = { exp with pexp_desc = Pexp_constraint (exp, bool_typ) } in
+  is_well_typed_expr ((exp', cxt), env, prefix)
+
+(* is_unit_expr : expression context_t -> bool *)
+let is_unit_expr ((exp, cxt), env, prefix) =
+  (* exp with unit annotation *)
+  let exp' = { exp with pexp_desc = Pexp_constraint (exp, unit_typ) } in
+  is_well_typed_expr ((exp', cxt), env, prefix)
+(*
+(* make_message_illtyped : expression context_t -> unit *)
+let make_message_illtyped ((expr, cxt), env, prefix) (* yes no *) =
+  match expr.pexp_desc with
+    Parsetree.Pexp_ident (_) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_var_undefined ()
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, None) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else if not (is_unit_expr ((exp2, cxt), env, prefix)) then
+        (* then 部分が unit 型でない *)
+        let (_, typ2) = judge ((exp2, cxt), env, prefix) in begin
+          print_loc exp2.pexp_loc;
+          print_identified ();
+          print_illtyped_if_then typ2
+        end
+      else begin (* both are well_typed; conflicts in environment *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_if_fv ()
+      end
+
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, Some (exp3)) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else (* [exp2; exp3] を同じリストに入れる *)
+        let mtloc = mknoloc (Longident.Lident "[]") in
+        let mt = Exp.mk (Pexp_construct (mtloc, None)) in
+        let consloc = mknoloc (Longident.Lident "::") in
+        let cons e1 e2 =
+          let e = Exp.mk (Pexp_tuple [e1; e2]) in
+          Exp.mk (Pexp_construct (consloc, Some e)) in
+        let exp' = cons exp2 (cons exp3 mt) in
+        if not (is_well_typed_expr ((exp', cxt), env, prefix)) then
+          (* then 部分と else 部分が同じ型でない *)
+          (* または then 部分と else 部分で環境の衝突が起きた *)
+          let (_, typ2) = judge ((exp2, cxt), env, prefix) in
+          let (_, typ3) = judge ((exp3, cxt), env, prefix) in begin
+            print_loc expr.pexp_loc;
+            print_identified ();
+            print_illtyped_if_then_else typ2 typ3
+          end
+        else begin (* if 文全体で環境の衝突が起きている *)
+          print_loc expr.pexp_loc;
+          print_identified ();
+          print_illtyped_if_fv ()
+        end
+
+  | Parsetree.Pexp_apply (exp, lexps) ->
+      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in (* 関数の型 *)
+      let typs = List.map (fun (_, e) -> snd (judge ((e, cxt), env, prefix)))
+                          lexps in (* 引数の型 *)
+      let exps = List.map (fun (_, e) -> e) lexps in
+      if split_arrow exp_typ = None then begin
+        (* 関数部分が関数型になっていない *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_apply_not_function exp_typ
+      end else
+        (* 型エラーを起こすことなく渡せる引数列と
+         * 型エラーを起こす最初の引数のペアを返す *)
+        let rec well_typed_args wargs lexps = match lexps with
+            [] ->
+              failwith "TypeDebugger: Error: apply in make_message_illtyped."
+          | first :: rest ->
+              let wargs' = wargs @ [first] in
+              let exp' = Exp.mk (Pexp_apply (exp, wargs')) in
+              if is_well_typed_expr ((exp', cxt), env, prefix)
+              then well_typed_args wargs' rest
+              else (wargs, first) in
+        let (wargs, (_, arg)) = well_typed_args [] lexps in
+        (* 何番目の引数が型エラーを引き起こすか *)
+        let n = List.length wargs + 1 in
+        (* 型エラーになる直前までの型 *)
+        let typ = if n = 1 then exp_typ
+                  else let wexp = Exp.mk (Pexp_apply (exp, wargs)) in
+                       snd (judge ((wexp, cxt), env, prefix)) in
+                       (* wargs = [] だと judge が syntax error を起こす *)
+        begin match split_arrow typ with
+            None -> (* typ が関数型でなかった：引数が多かった場合 *)
+              print_loc expr.pexp_loc;
+              print_identified ();
+              print_illtyped_too_much_args n exp_typ typs exp
+          | Some (t1, _) -> (* n 番目の引数が型エラー *)
+              print_loc expr.pexp_loc;
+              print_identified ();
+              if language_level < 2
+              then (* language_level < 2 では関数引数は不可 *)
+                let (_, n_typ) = judge ((arg, cxt), env, prefix) in
+                (* 型エラーの原因となっている引数の型 *)
+                let funtypes = find_funtype_args typs 1 in
+                (* 関数型になっている引数 *)
+                begin match funtypes with
+                    [] -> (* 関数型になっている引数なし *)
+                      print_illtyped_apply_beginning2 n exp exp_typ n_typ
+                  | _ -> (* 関数型になっている引数あり *)
+                      print_illtyped_apply_beginning n exp exp_typ typs funtypes
+                end
+              (* language_level >= 2 は関数引数可 *)
+              else
+                print_illtyped_apply_funname n exp_typ exps typs t1 exp
+        end
+
+  | Parsetree.Pexp_function (_) ->
+      print_illtyped_function ()
+
+  | Parsetree.Pexp_fun (_, _, _, _) ->
+      print_illtyped_function ()
+
+  | Parsetree.Pexp_match (exp, cases) ->
+  (* Pexp_match の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat; } ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g; } ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_match の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> (* 最初の case が型エラー。exp と case が合わない*)
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match1:@.%a@."
+                      Pprintast.expression case';
+                  (* 最初のパターンの型 *)
+                  let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                  begin match split_arrow pat_typ with
+                    Some (t1, _) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      print_loc expr.pexp_loc;
+                      print_identified ();
+                      print_illtyped_match_exp exp_typ t1;
+                      false
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                  end
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (ok1, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_match_left notok1 ok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+              | [] -> (* case がひとつ目からだめ *)
+                 (* exp と case で環境が conflict している *)
+                 (* print_loc expr.pexp_loc; *)
+                 (* print_identified (); *)
+                 (* print_illtyped_other (); (* メッセージを変えるべき *) *)
+                 (* false *)
+                 let progs = decompose_expr ((case.pc_rhs, cxt), env, prefix) Typed in
+                 List.iter (fun ((exp, _), _, _) -> Pprintast.expression ppf exp) progs;
+                 let loc = (case.pc_rhs).pexp_loc in
+                 print_loc loc;
+                 print_identified ();
+                 print_illtyped_case_env case.pc_rhs;
+                 false
+              | _ :: _ -> (* case の右辺の式、あるいは環境の衝突が原因 *)
+                  let wcases' = Exp.mk (Pexp_match (exp, wcases)) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match6:@.%a@."
+                      Pprintast.expression wcases';
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_match (exp, [case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match7:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  begin try
+                    let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right notok_typ ok_typ;
+                    false
+                  with _ -> (* 型エラーが起きた。環境が衝突している *)
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right2 ();
+                    false
+                  end
+              end in
+
+  (* Pexp_match のメイン -------------------------------------------------- *)
+      if patterns_ok exp [] pattern_only_cases
+      && guards_all_bool pattern_and_guard_cases
+      && guards_ok_with_exp exp [] pattern_and_guard_cases
+      && cases_ok exp [] cases
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+(*
+      (* exp は単独では型はついている。match 文全体では型はつかない *)
+      if debug land 8 = 8 then
+        Format.fprintf ppf "message illtyped match1:@.%a@."
+          Pprintast.expression exp;
+*)
+
+  | Parsetree.Pexp_try (exp, cases) ->
+  (* Pexp_try の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat} ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g} ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_try の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (skeleton, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> true
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (_, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_try_left notok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+                [] | [_] | _ -> (* case がひとつ目からだめ *)
+                let case' = Exp.mk (Pexp_function ([case])) in
+                if debug land 8 = 8 then
+                  Format.fprintf ppf "message illtyped match1:@.%a@."
+                                 Pprintast.expression case';
+                (* 最初のパターンの型 *)
+                let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                begin match split_arrow pat_typ with
+                    Some (_, t2) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      let case_loc = (case.pc_rhs).pexp_loc in
+                      print_loc case_loc;
+                      print_identified ();
+                      (* 環境の衝突かどうかを確認 *)
+                      (try
+                          (Ctype.unify env exp_typ t2;
+                           print_illtyped_try_env ();
+                           false)
+                        with
+                          _ -> print_illtyped_try_right exp_typ t2;
+                      (* try文の式と矢印の右側の型が合わない *)
+                      false)
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                end
+              end in
+
+  (* Pexp_try のメイン -------------------------------------------------- *)
+      let exn_case =
+        [{ pc_lhs = { ppat_desc = Ppat_construct
+                                    ({txt = Longident.Lident ("Not_found");
+                                      loc = Location.none},
+                                     None);
+                      ppat_loc = Location.none;
+                      ppat_attributes = [] };
+           pc_guard = None;
+           pc_rhs = skeleton }] in
+      if (patterns_ok exp exn_case pattern_only_cases)
+      && (guards_all_bool pattern_and_guard_cases)
+      && (guards_ok_with_exp exp [] pattern_and_guard_cases)
+      && (cases_ok exp [] cases)
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+
+  | Parsetree.Pexp_construct ({txt = lid}, e) ->
+      (* 引数の情報 *)
+      let args =
+        List.map (fun (e, t) ->
+                   if e = dummy_assertfalse e then None else Some (e, t))
+          (match e with
+            | Some (exp) ->
+               let typ = snd (judge ((exp, cxt), env, prefix)) in
+               begin
+                 (* 引数の数をチェック *)
+                 match (decode_tuple typ) with
+                 | Some (typs) ->
+                    let exps = match exp.pexp_desc with
+                      | Pexp_tuple (es) -> es
+                      | _ -> assert false in
+                    List.combine exps typs
+                 | None -> [(exp, typ)]
+               end
+            | None -> []) in
+
+      (* extract core type list from constructor arguments *)
+      (* extract_core_types : constructor_arguments -> core_type list *)
+      let extract_core_types carg = match carg with
+        | Pcstr_tuple (cts) -> cts
+        | Pcstr_record (_) -> assert false (* not supported yet *)
+      in
+
+      (* prefix の分解 *)
+      (* prefix -> (string * kind) list *)
+      let rec get_construct prefix = match prefix with
+        | [] -> []
+        | (first, _) :: rest ->
+            begin match first.pstr_desc with
+            | Pstr_type (_, tds) ->
+                (* 型の情報 *)
+                (* type_declaration list -> (string * type_kind) list *)
+                (List.map (fun {ptype_name = n; ptype_kind = k} ->
+                            (n.txt, get_type_value k)) tds) @
+                (get_construct rest)
+            | Pstr_exception ({pext_name = n; pext_kind = k}) ->
+                (* 例外の情報 *)
+                (n.txt, get_ext_value n.txt k) :: (get_construct rest)
+            | Pstr_module ({pmb_name = n; pmb_expr = e}) ->
+                (* モジュール名と中の式 *)
+                begin match e.pmod_desc with
+                  | Pmod_structure (strs) ->
+                    let pre_mod = get_construct
+                                    (List.map (fun x -> (x, Env.empty)) strs) in
+                    let a = List.map (fun (nk, kind) ->
+                                       (n.txt ^ "." ^ nk,
+                                        List.map (fun (nc, cts) ->
+                                                   (n.txt ^ "." ^ nc, cts))
+                                                 kind))
+                                     pre_mod in
+                    a @ (get_construct rest)
+                  | _ -> get_construct rest
+                end
+            | _ -> get_construct rest
+            end
+
+      (* kind の分解 *)
+      (* type_kind -> (string, core_type list) list *)
+      and get_type_value kind = match kind with
+        | Ptype_variant (cds) ->
+          List.map (fun {pcd_name = n; pcd_args = a} ->
+                     (n.txt, extract_core_types a)) cds
+        | _ -> []
+      (* extension_constructor_kind -> (string, core_type list) list *)
+      and get_ext_value name kind = match kind with
+        | Pext_decl (cts, None) ->
+          (* 引数を取る場合をとりあえず *)
+          [(name, extract_core_types cts)]
+        | _ -> [] in
+
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_constructor lid (get_construct prefix) args
+
+  | Parsetree.Pexp_record (lst, None) -> (* illtyped *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+(*
+      (* typs : エラーが出た箇所でのフィールドの型 *)
+      let typs = List.map (fun ({txt = t}, e) -> (snd (judge ((e, cxt), env, prefix))), t) lst in
+      (* exps : エラーが出た箇所での式 *)
+      let exps = List.map (fun (_, e) -> e) lst in
+ *)
+      (* 上記フィールドの名称を取得 *)
+
+      (* ダミーの型 *)
+      let dummy_exp =
+        { pexp_desc = Parsetree.Pexp_record
+                        (List.map (fun (lid, _) -> (lid, skeleton)) lst, None);
+          pexp_loc = Location.none;
+          pexp_attributes = [] } in
+      let dummy_t = snd (judge ((dummy_exp, cxt), env, prefix)) in
+
+      (* prefixからフィールドの中身を取り出す *)
+      let rec dummy_string d = match d with
+        | {desc = Tconstr (p, _, _)} -> Path.name p
+        | {desc = Tsubst (expr)} -> dummy_string expr
+        | {desc = Tlink (expr)} -> dummy_string expr (* #useで呼び出した場合 *)
+        | _ -> Format.fprintf ppf "%a@." Printtyp.type_expr d;  assert false in
+      let rec get_params tlst = match tlst with
+        | [] -> raise Not_found
+        | {ptype_name = {txt = t}; ptype_kind = Ptype_record llst} :: rest ->
+           if t = dummy_string dummy_t then llst else get_params rest
+        | _ :: rest -> get_params rest in
+      let rec search_rec p = match p with
+          [] -> assert false
+        | ({pstr_desc = Pstr_type (_, tlst)}, _) :: rest ->
+           begin
+             try get_params tlst with
+             Not_found -> search_rec rest
+           end
+        | _ :: rest -> search_rec rest in
+      (* 各フィールドの情報 *)
+      let fields =
+        List.map2 (fun ({txt = f}, e) ft ->
+                   ((f, ft), (e, snd (judge ((e, cxt), env, prefix)))))
+                  lst (search_rec prefix) in
+      print_illtyped_record dummy_t fields
+
+  | Parsetree.Pexp_constraint (exp, t) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      let (_, typ1) = judge ((exp, cxt), env, prefix) in
+      let exp' = { pexp_desc = Parsetree.Pexp_constraint (skeleton, t);
+                   pexp_loc = Location.none;
+                   pexp_attributes = [] } in
+      let (_, typ2) = judge ((exp', cxt), env, prefix) in
+      print_illtyped_constraint typ1 typ2
+
+  | Parsetree.Pexp_array (es) ->
+      (* array に関するエラー *)
+      let typs =
+        List.map (fun exp -> snd (judge ((exp, cxt), env, prefix)))
+                 (List.filter (fun e -> e <> dummy_assertfalse e) es) in
+      let (typ1, typ2) = (List.nth typs 0, List.nth typs 1) in
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_array typ1 typ2
+  | Parsetree.Pexp_let (flg, vs, _) ->
+      (* 再起関数の rec を忘れた場合 *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+      if flg = Nonrecursive
+      then match vs with
+        | [] -> ()
+        | first :: rest -> print_illtyped_let first rest
+      else if List.length vs > 1
+      then print_illtyped_let_rec_many vs
+      else print_illtyped_let_rec1 (List.hd vs)
+  | _ -> (* illtyped *)
+       print_loc expr.pexp_loc;
+       print_identified ();
+       Format.fprintf ppf "default case of make_message_illtyped@.";
+       print_illtyped_other ()
+
+(* make_message_welltyped : expression context_t -> yes_no_list -> unit *)
+let make_message_welltyped ((expr, cxt), env, prefix) no =
+  (* 型エラーの原因と特定された式の型 *)
+  let (vartyps, t) = judge ((expr, cxt), env, prefix) in
+  let vartyps' = List.filter (fun (key, typ) -> answered_no key typ no env)
+                             vartyps in
+  print_loc expr.pexp_loc;
+  print_identified ();
+  match vartyps' with
+      [] -> (* 自由変数は意図通り *)
+        print_welltyped_expr t
+    | (((st, _), _, _), typ) :: [] -> (* 自由変数が意図通りでない *)
+        print_welltyped_env1 st typ
+    | (((st, _), _, _), typ) :: rest ->
+        print_welltyped_env_many st typ rest
+ *)
+
+(********** ask questions **********)
+
+(* ノード数カウント用の関数には全て node_count_ がついている *)
+
+(* node_count_ask_env :
+             (string context_t * type_expr) list -> Env.t ->
+             yes_no_list -> yes_no_list ->
+             int * yes_no_list * yes_no_list *)
+let rec node_count_ask_env vartyps env yes no = match vartyps with
+    [] -> (0, yes, no)
+  | (((st, _), _, _) as key, typ) :: rest ->
+      if Ctype.moregeneral env false typ (Btype.newgenvar ())
+      || answered_yes key typ yes env
+      then node_count_ask_env rest env yes no
+      else if answered_no key typ no env
+      then (0, yes, no)
+      else begin
+        (* 1 回聞き（yes を仮定してさらに）先を聞きにいく *)
+        if print_asked_expr then begin
+          Format.fprintf ppf "ask_env: %s@." st
+        end;
+        let (num, yes', no') =
+          node_count_ask_env rest env ((key, typ) :: yes) no in
+        (num + 1, yes', no')
+      end
+
+(* ask_env : expression -> (string context_t * type_expr) list -> Env.t ->
+             yes_no_list -> yes_no_list ->
+             bool * yes_no_list * yes_no_list *)
+(*
+let rec ask_env expr vartyps env yes no = match vartyps with
+    [] -> (true, yes, no)
+  | (((st, _), _, _) as key, typ) :: rest ->
+      if Ctype.moregeneral env false typ (Btype.newgenvar ())
+      || answered_yes key typ yes env
+      then ask_env expr rest env yes no
+      else if answered_no key typ no env
+      then (false, yes, no)
+      else (print_loc expr.pexp_loc;
+            print_ask_env st typ;
+            print_prompt ();
+            let input = read_line () in
+            Format.fprintf ppf "@.";
+            match input with
+                "y" | "y;;" -> ask_env expr rest env ((key, typ) :: yes) no
+              | "n" | "n;;"  -> (false, yes, (key, typ) :: no)
+              | _ -> raise DebuggerQuit)
+ *)
+let answer_and_write ?(scope = "") expr (b, yes, no) =  
+  Data.Buffer.write scope expr (if b then "y" else "n");
+  (b, yes, no)
+
+let answer_and_set ?(scope = "") expr ans = match !debugger_state with
+  | Evaluate _ ->
+      (* ユーザの回答を反映させていない *)
+      Data.Buffer.write scope expr (if ans then "y" else "n");
+      debugger_state := Interactive (expr.pexp_loc, None);
+      ans
+  | _ -> raise Not_found (* 例外Not_foundを発生させる *)
+
+let answer ?(scope = "null") expr typ =
+  (* 次の質問を出力 *)
+  Format.fprintf ppf
+    "{\"location\": %a,@,\
+     \"type\": \"%a\", \"scope\": %s}@."
+    Data.Loc.printJSON expr.pexp_loc
+    Printtyp.type_expr typ scope;
+  exit 100
+
+let rec ask_env expr vartyps env yes no = match vartyps with
+    [] -> (true, yes, no)
+  | (((st, _), _, _) as key, typ) :: rest ->
+      if Ctype.moregeneral env false typ (Btype.newgenvar ())
+      || answered_yes key typ yes env then
+        ask_env expr rest env yes no
+      else if answered_no key typ no env then
+        (false, yes, no)
+      else
+        try
+          (* buffer に回答があるかどうかを探す *)
+          let ({txt}, _) =
+            List.find (
+              fun (_, payload) ->
+                match payload with
+                  PPat (p, _) -> Desc.Pat.find st p <> wildcard
+                | _ -> false
+            ) expr.pexp_attributes in
+          if txt = "yes" then
+            ask_env expr rest env ((key, typ) :: yes) no
+          else
+            (false, yes, (key, typ) :: no)
+        with
+          Not_found ->
+            (* なかった *)
+            if Data.express_mode < 0 then
+              begin
+                print_loc expr.pexp_loc;
+                print_ask_env st typ;
+                print_prompt ();
+                let input = read_line () in
+                Format.fprintf ppf "@.";
+                match input with
+                | "y" | "y;;" ->
+                    let (_, yes', _) =
+                      answer_and_write
+                        ~scope:st expr (true, ((key, typ) :: yes), no) in
+                    ask_env expr rest env yes' no
+                | "n" | "n;;" ->
+                    answer_and_write
+                      ~scope:st expr (false, yes, (key, typ) :: no)
+                | _ -> raise DebuggerQuit
+              end
+            else
+              try
+                let ans = bool_of_string
+                    (Sys.getenv "DEBUGGER_USER_ANSWER") in
+                let (yes', no') =
+                  if ans then
+                    (((key, typ) :: yes), no)
+                  else
+                    (yes, (key, typ) :: no) in
+                (answer_and_set ~scope:st expr ans, yes', no')
+              with
+                Not_found ->
+                  answer ~scope:("\"" ^ st ^ "\"") expr typ
+
+              (* ask_expr_helper : expression -> type_expr -> Env.t ->
+                 yes_no_list -> yes_no_list ->
+   bool * yes_no_list * yes_no_list *)
+
+
+(*    
+let ask_expr_helper expr t env yes no =
+  if Ctype.moregeneral env false t (Btype.newgenvar ())
+  then (true, yes, no)
+  else
+    begin
+      if auto then (
+        print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+        Format.fprintf ppf "@.";
+        (true, yes, no)
+      ) else (
+        print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+        let input = read_line () in
+        Format.fprintf ppf "@.";
+        match input with
+        | "y" | "y;;" -> (true, yes, no)
+        | "n" | "n;;" -> (false, yes, no)
+        | _ -> raise DebuggerQuit (* 終わらせないようにしたい *)
+      ) end
+ *)
+
+(*
+let ask_expr_helper expr t env yes no =
+  if Ctype.moregeneral env false t (Btype.newgenvar ())
+  then (true, yes, no)
+  else if auto then (
+    print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+    Format.fprintf ppf "@.";
+    (true, yes, no)
+  ) else (
+    print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+    let input = read_line () in
+    Format.fprintf ppf "@.";
+    match input with
+    | "y" | "y;;" ->
+        (* buffer.csv への記録 *)
+        Data.Buffer.write "" expr "y";
+        if Sys.file_exists "slice.csv" then
+          (* raise (DebuggerPaused (None, fn, sl, sc, el, ec, 1)) *)
+          raise (DebuggerPaused ((t, ""), expr, true))
+        else
+          (true, yes, no)
+    | "n" | "n;;" ->
+        (* buffer.csv への記録 *)
+        Data.Buffer.write "" expr "n";
+        if Sys.file_exists "slice.csv" then             
+          raise (DebuggerPaused ((t, ""), expr, false))
+        else
+          (false, yes, no)
+    | _ -> raise DebuggerQuit (* 終わらせないようにしたい *)
+  )
+
+let rec ask_expr_helper' attrs yes no = match attrs with
+    [] -> raise Not_found
+  | ({txt}, PPat (p, _)) :: _ when p = wildcard ->
+      if txt = "yes" then
+        (true, yes, no)
+      else
+        (false, yes, no)
+  | _ :: rest ->
+      ask_expr_helper' rest yes no
+
+(* ask_expr : expression context_t -> type_expr -> Env.t ->
+              yes_no_list -> yes_no_list -> bool * yes_no_list * yes_no_list *)
+let ask_expr ((expr, _), _, _) t env yes no =
+  try
+    ask_expr_helper' expr.pexp_attributes yes no
+  with Not_found ->
+    ask_expr_helper expr t env yes no
+
+(*
+  ask_expr_helper expr t env yes no
+ *)
+
+*)
+
+let ask_expr_helper expr t env yes no =
+  if Ctype.moregeneral env false t (Btype.newgenvar ()) then
+    (true, yes, no)
+  else if auto then
+    begin
+      print_loc expr.pexp_loc;
+      print_ask_expr t;
+      print_prompt ();
+      Format.fprintf ppf "@.";
+      (true, yes, no)
+    end
+  else if Data.express_mode < 0 then
+    begin
+      print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+      let input = read_line () in
+      Format.fprintf ppf "@.";
+      match input with
+      | "y" | "y;;" ->
+          answer_and_write expr (true, yes, no)
+      | "n" | "n;;" ->
+          answer_and_write expr (false, yes, no)
+      | _ -> raise DebuggerQuit (* 終わらせないようにしたい *)
+    end
+  else
+    try
+      let ans = bool_of_string (Sys.getenv "DEBUGGER_USER_ANSWER") in
+      (answer_and_set expr ans, yes, no)
+    with
+      Not_found -> answer expr t
+
+(*    
+    begin
+      try
+        if Array.length Sys.argv = 7 then
+          raise DebuggerQuit
+        else
+          match Sys.argv.(7) with
+          | "y" -> (ask_expr_helper' expr true, yes, no)
+          | "n" -> (ask_expr_helper' expr false, yes, no)
+          | _ -> (* Debug_core.Node.Input.ask expr t; *)
+              Data.Buffer.write "" expr "q";
+              exit 100
+      with
+        Invalid_argument _ ->
+
+      if auto then (
+        print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+        Format.fprintf ppf "@.";
+        (true, yes, no)
+      ) else (
+        print_loc expr.pexp_loc; print_ask_expr t; print_prompt ();
+        let input = read_line () in
+        Format.fprintf ppf "@.";
+        match input with
+        | "y" | "y;;" ->
+            answer_and_write "" expr (true, yes, no)
+        | "n" | "n;;" ->
+            answer_and_write "" expr (false, yes, no)
+        | _ -> raise DebuggerQuit (* 終わらせないようにしたい *)
+      ) end
+*)
+
+(* ask_expr : expression context_t -> type_expr -> Env.t ->
+              yes_no_list -> yes_no_list -> bool * yes_no_list * yes_no_list *)
+let ask_expr ((expr, _), _, _) t env yes no =
+  try
+    let ({txt}, _) =
+      List.find (
+          fun ({txt}, _) ->
+            txt = "yes" || txt = "no"
+        ) expr.pexp_attributes in
+    (txt = "yes", yes, no)
+  with
+    Not_found -> ask_expr_helper expr t env yes no
+
+
+(********** check whether expr has intended type **********)
+
+(* node_count_has_intended_type :
+     expression context_t -> yes_no_list -> yes_no_list ->
+     int * yes_no_list * yes_no_list *)
+let node_count_has_intended_type ((expr, cxt), env, prefix) yes no =
+  let (vartyps, typ) = judge ((expr, cxt), env, prefix) in
+  (* 以下は全部 yes と答えた場合のノード数を返す *)
+  let (num, yes', no') = node_count_ask_env vartyps env yes no in
+  (* 以下は ask_expr_helper に沿って書いてある *)
+  (* 全部 yes だと expr 自身も聞くので 1 を加えようとする *)
+  if Ctype.moregeneral env false typ (Btype.newgenvar ())
+  (* しかし型が 'a なら聞く必要がないので加えない *)
+  then (num, yes', no')
+  (* そうでなければ 1 加える *)
+  else begin
+    if print_asked_expr then begin
+      Format.fprintf ppf "has_intended_type:@.";
+      print_deb_exp ppf expr
+    end;
+    (num + 1, yes', no')
+    end
+
+
+(* 返す yes', no' は全部 yes と答えた場合の返答 *)
+(* has_intended_type : expression context_t -> yes_no_list -> yes_no_list ->
+                       bool * yes_no_list * yes_no_list *)
+let has_intended_type ((expr, cxt), env, prefix) yes no =
+  let (vartyps, typ) = judge ((expr, cxt), env, prefix) in
+  let (b, yes', no') = ask_env expr vartyps env yes no in
+  if b
+  then ask_expr ((expr, cxt), env, prefix) typ env yes' no'
+  else (false, yes', no')
+
+(********** find the source of the type error **********)
+
+(* node_count_walk_right_typed :
+        expression context_t list -> yes_no_list -> yes_no_list -> int -> int *)
+let rec node_count_walk_right_typed progs yes no acc =
+  if acc >= 1000 then acc else match progs with
+    [] -> acc
+  | ((expr', _), _, _) :: rest
+      when expr' = hole_of_exp expr' ->
+      (* □ の中は数えないで次に行く *)
+      node_count_walk_right_typed rest yes no acc
+  | ((expr', cxt'), env', prefix') :: rest ->
+      (* このノードの質問の回数 *)
+      let (n1, yes', no') =
+        node_count_has_intended_type ((expr', cxt'), env', prefix')  yes no in
+      (* 以下の yes', no' は全て yes と答えてきた場合のもの *)
+      let n2 =
+        node_count_walk_right_typed rest yes' no' (acc + n1) in
+      (* no と答えた場合は、どこで no と答えたかわからないので困る *)
+      (* 以下は古い yes, no を使っている *)
+      (* つまり、no と答えた際の答えは再利用していないことになる *)
+      node_count_walk_up_typed ((expr', cxt'), env', prefix') yes no n2
+      (*
+      num (* このノードの質問の回数 *)
+      (* 以下の yes', no' は全て yes と答えてきた場合のもの *)
+      + node_count_walk_right_typed rest yes' no'
+      (* no と答えた場合は、どこで no と答えたかわからないので困る *)
+      (* 以下は古い yes, no を使っている *)
+      (* つまり、no と答えた際の答えは再利用していないことになる *)
+      + node_count_walk_up_typed ((expr', cxt'), env', prefix') yes no
+      *)
+
+(* node_count_walk_up_typed :
+        expression context_t -> yes_no_list -> yes_no_list -> int -> int *)
+and node_count_walk_up_typed ((expr, cxt), env, prefix) yes no acc =
+  (* ((expr, cxt), env, prefix) は well-typed *)
+  if acc >= 1000 then acc else
+  let progs = decompose_expr ((expr, cxt), env, prefix) Typed in
+  node_count_walk_right_typed progs yes no acc
+
+(* make_message_welltyped : expression context_t -> yes_no_list -> unit *)
+let make_message_welltyped ((expr, cxt), env, prefix) no =
+  (* 型エラーの原因と特定された式の型 *)
+  let (vartyps, t) = judge ((expr, cxt), env, prefix) in
+  let vartyps' = List.filter (fun (key, typ) -> answered_no key typ no env)
+                             vartyps in
+  print_loc expr.pexp_loc;
+  print_identified ();
+  match vartyps' with
+      [] -> (* 自由変数は意図通り *)
+        print_welltyped_expr t
+    | (((st, _), _, _), typ) :: [] -> (* 自由変数が意図通りでない *)
+        print_welltyped_env1 st typ
+    | (((st, _), _, _), typ) :: rest ->
+        print_welltyped_env_many st typ rest
+
+(* walk_right_typed :
+        expression context_t list -> yes_no_list -> yes_no_list ->
+        expression context_t option * yes_no_list * yes_no_list *)
+let rec walk_right_typed progs yes no = match progs with
+    [] -> (* All the premises are as intended. *)
+          (* The current expr is the source of the type error. *)
+      (None, yes, no)
+  | ((expr', cxt'), env', prefix') :: rest ->
+     if auto then
+       Format.fprintf ppf "ノード：@.%a@."
+                      Pprintast.expression expr';
+      let (intended, yes', no') =
+        has_intended_type ((expr', cxt'), env', prefix')  yes no in
+      if intended
+      then walk_right_typed rest yes' no'
+      else (Some ((expr', cxt'), env', prefix'), yes', no')
+
+(* walk_up_typed : expression context_t -> yes_no_list -> yes_no_list -> unit *)
+let rec walk_up_typed ((expr, cxt), env, prefix) yes no =
+  (* ((expr, cxt), env, prefix) は well-typed *)
+  let progs = decompose_expr ((expr, cxt), env, prefix) Typed in
+  let (c, yes', no') = walk_right_typed progs yes no in
+  begin match c with
+      None ->
+        (* 部分式の型は意図通り *)
+        make_message_welltyped ((expr, cxt), env, prefix) no'
+    | Some ((expr', cxt'), env', prefix') ->
+        (* 部分式の型が意図に合わない *)
+        walk_up_typed ((expr', cxt'), env', prefix') yes' no'
+  end
+
+(********** find the smallest illtyped pattern **********)
+
+(* walk_right_illtyped_pattern : pattern list context_t -> pattern option *)
+let rec walk_right_illtyped_pattern ((pats, cxt), env, prefix) =
+  match pats with
+    [] -> None
+  | pat :: rest ->
+      let exp = Exp.mk (Pexp_fun (Nolabel, None, pat, skeleton)) in
+      if is_well_typed_expr ((exp, cxt), env, prefix)
+      then walk_right_illtyped_pattern ((rest, cxt), env, prefix)
+      else Some (pat)
+
+(* walk_up_illtyped_pattern : pattern context_t -> unit *)
+let rec walk_up_illtyped_pattern ((pat, cxt), env, prefix) =
+  let pats = decompose_pattern pat in
+  match walk_right_illtyped_pattern ((pats, cxt), env, prefix) with
+    None -> (* 部分パターンは型がつく *) (* pat が型エラーの原因 *)
+      make_message_pattern ((pat, cxt), env, prefix)
+  | Some (pat) ->
+      walk_up_illtyped_pattern ((pat, cxt), env, prefix)
+
+(********** find the smallest illtyped expression **********)
+
+(* walk_right_illtyped :
+        expression context_t list -> yes_no_list -> yes_no_list ->
+        expression context_t option * yes_no_list * yes_no_list *)
+let rec walk_right_illtyped progs yes no = match progs with
+    [] -> (* all the decomposed programs are well typed *)
+      (None, yes, no)
+  | ((expr', cxt'), env', prefix') :: rest ->
+      if debug land 2 = 2 then Format.fprintf ppf "walk right illtyped:@.%a@."
+                                Pprintast.expression expr';
+      if is_well_typed_expr ((expr', cxt'), env', prefix')
+      then walk_right_illtyped rest yes no
+      else (Some ((expr', cxt'), env', prefix'), yes, no)
+
+(* walk_up_illtyped : expression context_t -> yes_no_list -> yes_no_list ->
+                      unit *)
+let rec walk_up_illtyped ((expr, cxt), env, prefix) yes no =
+  let pats = extract_pattern expr in
+  (* pattern に型がつくかを最初にチェック *)
+  match walk_right_illtyped_pattern ((pats, cxt), env, prefix) with
+    Some (pat) -> (* pat is illtyped *)
+      walk_up_illtyped_pattern ((pat, cxt), env, prefix)
+  | None -> (* patterns are all welltyped *)
+      let progs = decompose_expr ((expr, cxt), env, prefix) Illtyped in
+      let (c, yes', no') = walk_right_illtyped progs yes no in
+      begin match c with
+        None ->
+          if debug land 1 = 1 then
+            Format.fprintf ppf "illtyped expression:@.%a@."
+              Pprintast.expression expr;
+          (* expr は illtyped だけど、子は全て welltyped になる *)          
+          start_typed ((expr, cxt), env, prefix) yes' no'
+      | Some ((expr', cxt'), env', prefix') ->
+          walk_up_illtyped ((expr', cxt'), env', prefix') yes' no'
+      end
+
+(* start_typed : expression context_t -> yes_no_list -> yes_no_list -> unit *)
+and start_typed ((expr, cxt), env, prefix) yes no =
+  (* ((expr, cxt), env, prefix) 自身は ill-typed *)
+  (* decompose 結果は well-typed *)
+  match expr.pexp_desc with
+      Pexp_let (rec_flg, bindings, exp) ->
+        let exp0 = Exp.mk (Pexp_let (rec_flg, bindings, skeleton)) in
+        if is_well_typed_expr ((exp0, cxt), env, prefix) then
+          (* bindings に型がついたので、in 以下に進む *)
+          walk_up_illtyped
+            ((exp, Let (rec_flg, bindings, cxt)), env, prefix) yes no
+        else if rec_flg = Recursive then begin (* bindings 中の再帰が原因 *)
+          if debug land 1 = 1 then
+            Format.fprintf ppf "make message recursive:@.%a@."
+              Pprintast.expression expr;
+          make_message_recursive ((bindings, cxt), env, prefix)
+        end else (* パターン pats = exps が型エラーの原因 *)
+          make_message_bindings ((bindings, cxt), env, prefix)
+    | _ when print_node_count -> (* ノード数カウントの場合 *)
+        (* ノード数を数えて、ノード数を表示して終了 *)
+        let num =
+          node_count_walk_up_typed ((expr, cxt), env, prefix) yes no 0 in
+        (* Format.fprintf ppf "Number of visited nodes = %d@." num *)
+        Format.fprintf ppf ", %d" num
+    | _ -> (* let 文以外の式 *)
+(*
+        (* walk_up_typed をノード数を数えるように変更済み *)
+        (* それを呼び出して、ノード数を表示して終了 *)
+        let num = walk_up_typed ((expr, cxt), env, prefix) yes no in
+        Format.fprintf ppf "Number of visited nodes = %d@." num
+ *)
+       if auto then
+       Format.fprintf ppf "頂点のノード：@.%a@."
+                      Pprintast.expression expr;
+(*       let progs =  ((expr, cxt), env, prefix) in *)
+       let progs = decompose_expr ((expr, cxt), env, prefix) Typed in
+       let (c, yes', no') = walk_right_typed progs yes no in
+        begin match c with
+            None ->
+              (* 部分式の型は意図通り *)
+              if debug land 1 = 1 then
+                Format.fprintf ppf "make message illtyped:@.%a@."
+                  Pprintast.expression expr;
+              make_message_illtyped ((expr, cxt), env, prefix) (* yes' no' *)
+          | Some ((expr', cxt'), env', prefix') ->
+              (* 部分式の型が意図に合わない *)
+              if debug land 1 = 1 then Format.fprintf ppf "typed started:@.%a@."
+                  Pprintast.expression expr';
+              walk_up_typed ((expr', cxt'), env', prefix') yes' no'
+        end
+
+(* make_message_illtyped : expression context_t -> unit *)
+and make_message_illtyped ((expr, cxt), env, prefix) (* yes no *) =
+  let expr =
+    Desc.Exp.map_all (fun e -> {e with pexp_attributes = []}) expr in
+
+  match expr.pexp_desc with
+    Parsetree.Pexp_ident (_) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_var_undefined ()
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, None) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else if not (is_unit_expr ((exp2, cxt), env, prefix)) then
+        (* then 部分が unit 型でない *)
+        let (_, typ2) = judge ((exp2, cxt), env, prefix) in begin
+          print_loc exp2.pexp_loc;
+          print_identified ();
+          print_illtyped_if_then typ2
+        end
+      else begin (* both are well_typed; conflicts in environment *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_if_fv ()
+      end
+
+  | Parsetree.Pexp_ifthenelse (exp1, exp2, Some (exp3)) ->
+      if not (is_bool_expr ((exp1, cxt), env, prefix)) then
+        (* predicate 部分が bool 型でない *)
+        let (_, typ1) = judge ((exp1, cxt), env, prefix) in begin
+          print_loc exp1.pexp_loc;
+          print_identified ();
+          print_illtyped_if_predicate typ1
+        end
+      else (* [exp2; exp3] を同じリストに入れる *)
+        let mtloc = mknoloc (Longident.Lident "[]") in
+        let mt = Exp.mk (Pexp_construct (mtloc, None)) in
+        let consloc = mknoloc (Longident.Lident "::") in
+        let cons e1 e2 =
+          let e = Exp.mk (Pexp_tuple [e1; e2]) in
+          Exp.mk (Pexp_construct (consloc, Some e)) in
+        let exp' = cons exp2 (cons exp3 mt) in
+        if not (is_well_typed_expr ((exp', cxt), env, prefix)) then
+          (* then 部分と else 部分が同じ型でない *)
+          (* または then 部分と else 部分で環境の衝突が起きた *)
+          let (_, typ2) = judge ((exp2, cxt), env, prefix) in
+          let (_, typ3) = judge ((exp3, cxt), env, prefix) in begin
+            print_loc expr.pexp_loc;
+            print_identified ();
+            print_illtyped_if_then_else typ2 typ3
+          end
+        else begin (* if 文全体で環境の衝突が起きている *)
+          print_loc expr.pexp_loc;
+          print_identified ();
+          print_illtyped_if_fv ()
+        end
+
+  | Parsetree.Pexp_apply (exp, lexps) ->
+      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in (* 関数の型 *)
+      let typs = List.map (fun (_, e) -> snd (judge ((e, cxt), env, prefix)))
+                          lexps in (* 引数の型 *)
+      let exps = List.map (fun (_, e) -> e) lexps in
+      if split_arrow exp_typ = None then begin
+        (* 関数部分が関数型になっていない *)
+        print_loc expr.pexp_loc;
+        print_identified ();
+        print_illtyped_apply_not_function exp_typ
+      end else
+        (* 型エラーを起こすことなく渡せる引数列と
+         * 型エラーを起こす最初の引数のペアを返す *)
+        let rec well_typed_args wargs lexps = match lexps with
+            [] ->
+              Format.fprintf ppf "check %a@."
+                Pprintast.expression expr;
+              failwith "TypeDebugger: Error: apply in make_message_illtyped."
+          | first :: rest ->
+              let wargs' = wargs @ [first] in
+              let exp' = Exp.mk (Pexp_apply (exp, wargs')) in
+              if is_well_typed_expr ((exp', cxt), env, prefix)
+              then well_typed_args wargs' rest
+              else (wargs, first) in
+(*        let (wargs, (_, arg)) = well_typed_args [] lexps in *)
+        let (wargs, _) = well_typed_args [] lexps in
+        (* 何番目の引数が型エラーを引き起こすか *)
+        let n = List.length wargs + 1 in
+        (* 型エラーになる直前までの型 *)
+        let typ = if n = 1 then exp_typ
+                  else let wexp = Exp.mk (Pexp_apply (exp, wargs)) in
+                       snd (judge ((wexp, cxt), env, prefix)) in
+                       (* wargs = [] だと judge が syntax error を起こす *)
+        begin match split_arrow typ with
+            None -> (* typ が関数型でなかった：引数が多かった場合 *)
+              print_loc expr.pexp_loc;
+              print_identified ();
+              print_illtyped_too_much_args n exp_typ typs exp
+          | Some (t1, _) -> (* n 番目の引数が型エラー *)
+              if Data.express_mode < 0 then
+                begin
+                  print_loc expr.pexp_loc;
+                  print_identified ()
+                end;
+
+              if language_level < 2 then
+                (* language_level < 2 では関数引数は不可 *)
+                (* let (_, n_typ) = judge ((arg, cxt), env, prefix) in *)
+                (* 型エラーの原因となっている引数の型 *)
+                let funtypes = find_funtype_args typs 1 in
+                (* 関数型になっている引数 *)
+                begin
+                  match funtypes with
+                  | [] -> (* 関数型になっている引数なし *)
+                      (*print_illtyped_apply_beginning2 n exp exp_typ n_typ*)
+                      print_illtyped_apply_beginning2 n exp_typ exps typs t1 exp
+                  | _ -> (* 関数型になっている引数あり *)
+                      print_illtyped_apply_beginning n exp exp_typ typs funtypes
+                end
+                (* language_level >= 2 は関数引数可 *)
+              else if Data.express_mode < 0 then
+                (* 17 *)
+                print_illtyped_apply_funname n exp_typ exps typs t1 exp
+              else
+                Format.fprintf ppf
+                  "{\"location\": %a, \"No.\": 17}@."
+                  Data.Loc.printJSON expr.pexp_loc
+
+        end
+
+  | Parsetree.Pexp_function (_) ->
+      print_illtyped_function ()
+
+  | Parsetree.Pexp_fun (_, _, p, e) ->
+     let case = {pc_lhs = p; pc_guard = None; pc_rhs = e} in
+     make_message_case ((case, cxt), env, prefix)
+
+  | Parsetree.Pexp_match (exp, cases) ->
+  (* Pexp_match の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat; } ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g; } ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_match の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> (* 最初の case が型エラー。exp と case が合わない*)
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match1:@.%a@."
+                      Pprintast.expression case';
+                  (* 最初のパターンの型 *)
+                  let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                  begin match split_arrow pat_typ with
+                    Some (t1, _) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      print_loc expr.pexp_loc;
+                      print_identified ();
+                      print_illtyped_match_exp exp_typ t1;
+                      false
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                  end
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (ok1, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_match_left notok1 ok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_match (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+              | [] -> (* case がひとつ目からだめ *)
+                 (* exp と case で環境が conflict している *)
+                 (* print_loc expr.pexp_loc; *)
+                 (* print_identified (); *)
+                 (* print_illtyped_other (); (* メッセージを変えるべき *) *)
+                 (* false *)
+                 make_message_case ((case, cxt), env, prefix);
+                 false
+              | _ :: _ -> (* case の右辺の式、あるいは環境の衝突が原因 *)
+                  let wcases' = Exp.mk (Pexp_match (exp, wcases)) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match6:@.%a@."
+                      Pprintast.expression wcases';
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_match (exp, [case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match7:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  begin try
+                    let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right notok_typ ok_typ;
+                    false
+                  with _ -> (* 型エラーが起きた。環境が衝突している *)
+                    print_loc case.pc_rhs.pexp_loc;
+                    print_identified ();
+                    print_illtyped_match_right2 ();
+                    false
+                  end
+              end in
+
+  (* Pexp_match のメイン -------------------------------------------------- *)
+      if patterns_ok exp [] pattern_only_cases
+      && guards_all_bool pattern_and_guard_cases
+      && guards_ok_with_exp exp [] pattern_and_guard_cases
+      && cases_ok exp [] cases
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+(*
+      (* exp は単独では型はついている。match 文全体では型はつかない *)
+      if debug land 8 = 8 then
+        Format.fprintf ppf "message illtyped match1:@.%a@."
+          Pprintast.expression exp;
+*)
+
+  | Parsetree.Pexp_try (exp, cases) ->
+  (* Pexp_try の補助変数 ------------------------------------------------ *)
+      (* body と guard を無効にした cases *)
+      let pattern_only_cases =
+        List.map (fun {pc_lhs = pat} ->
+                    {pc_lhs = pat; pc_guard = None; pc_rhs = skeleton})
+                 cases in
+      (* body のみを無効にした cases *)
+      let pattern_and_guard_cases =
+        List.map (fun {pc_lhs = pat; pc_guard = g} ->
+                    {pc_lhs = pat; pc_guard = g; pc_rhs = skeleton})
+                 cases in
+
+  (* Pexp_try の補助関数 ------------------------------------------------ *)
+      (* pattern の型が合っているかを調べる *)
+      (* pattern をひとつずつ加えて、型がつかなくなるところを探す *)
+      let rec patterns_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (skeleton, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then patterns_ok exp wcases' rest
+            else begin match wcases with
+                [] -> true
+              | _ :: _ -> (* case 同士で型エラー *)
+                  let wcases' = Exp.mk (Pexp_function (wcases)) in
+                  (* 型が合っている case の型 *)
+                  let (_, ok_typ) = judge ((wcases', cxt), env, prefix) in
+                  let case' = Exp.mk (Pexp_function ([case])) in
+                  if debug land 8 = 8 then
+                    Format.fprintf ppf "message illtyped match3:@.%a@."
+                      Pprintast.expression case';
+                  (* 型が合わない case の型 *)
+                  let (_, notok_typ) = judge ((case', cxt), env, prefix) in
+                  begin match (split_arrow ok_typ, split_arrow notok_typ) with
+                    (Some (_, _), Some (notok1, _)) ->
+                      print_loc case.pc_lhs.ppat_loc;
+                      print_identified ();
+                      print_illtyped_try_left notok1;
+                      false
+                  | (_, _) -> (* Can't happen *)
+                      failwith "TypeDebugger: match4 in make_message_illtyped."
+                  end
+            end in
+      (* guard が全て bool かどうかを調べる *)
+      let guards_all_bool cases =
+        List.for_all
+          (function {pc_guard = None} -> true
+            | {pc_guard = Some (g)} ->
+                if is_bool_expr ((g, cxt), env, prefix)
+                then true
+                else begin
+                  let (_, g_typ) = judge ((g, cxt), env, prefix) in
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard g_typ;
+                  false
+                end)
+          cases in
+      (* guard と exp で環境が衝突していないかを調べる *)
+      let rec guards_ok_with_exp exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then guards_ok_with_exp exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match case with
+                {pc_guard = None} -> (* Can't happen *)
+                  failwith "TypeDebugger: match5 in make_message_illtyped."
+              | {pc_guard = Some (g)} ->
+                  print_loc g.pexp_loc;
+                  print_identified ();
+                  print_guard_env ();
+                  false
+              end in
+      (* cases に型がつくかを順に調べる *)
+      (* 各ケースの型を独立に求め、その型が皆同じかを調べたい *)
+      (* すると、以後は、環境の衝突のみを考えれば良くなる *)
+      let rec cases_ok exp wcases cases = match cases with
+          [] -> true (* すべての case を入れて型がついた *)
+        | case :: rest ->
+            let wcases' = wcases @ [case] in
+            let exp' = Exp.mk (Pexp_try (exp, wcases')) in
+            if is_well_typed_expr ((exp', cxt), env, prefix)
+            then cases_ok exp wcases' rest
+            else (* case に入っている guard で環境の衝突 *)
+              begin match wcases with
+                [] | [_] | _ -> (* case がひとつ目からだめ *)
+                let case' = Exp.mk (Pexp_function ([case])) in
+                if debug land 8 = 8 then
+                  Format.fprintf ppf "message illtyped match1:@.%a@."
+                                 Pprintast.expression case';
+                (* 最初のパターンの型 *)
+                let (_, pat_typ) = judge ((case', cxt), env, prefix) in
+                begin match split_arrow pat_typ with
+                    Some (_, t2) ->
+                      (* exp の型 *)
+                      let (_, exp_typ) = judge ((exp, cxt), env, prefix) in
+                      let case_loc = (case.pc_rhs).pexp_loc in
+                      print_loc case_loc;
+                      print_identified ();
+                      (* 環境の衝突かどうかを確認 *)
+                      (try
+                          (Ctype.unify env exp_typ t2;
+                           print_illtyped_try_env ();
+                           false)
+                        with
+                          _ -> print_illtyped_try_right exp_typ t2;
+                      (* try文の式と矢印の右側の型が合わない *)
+                      false)
+                  | None -> (* Can't happen *)
+                      failwith "TypeDebugger: match2 in make_message_illtyped."
+                end
+              end in
+
+  (* Pexp_try のメイン -------------------------------------------------- *)
+      let exn_case =
+        [{ pc_lhs = { ppat_desc = Ppat_construct
+                                    ({txt = Longident.Lident ("Not_found");
+                                      loc = Location.none},
+                                     None);
+                      ppat_loc = Location.none;
+                      ppat_attributes = [] };
+           pc_guard = None;
+           pc_rhs = skeleton }] in
+      if (patterns_ok exp exn_case pattern_only_cases)
+      && (guards_all_bool pattern_and_guard_cases)
+      && (guards_ok_with_exp exp [] pattern_and_guard_cases)
+      && (cases_ok exp [] cases)
+      then failwith "TypeDebugger: match is welltyped in make_message_illtyped."
+      else () (* error already reported in one of the predicates *)
+
+  | Parsetree.Pexp_construct ({txt = lid}, e) ->
+      (* 引数の情報 *)
+      let args =
+        List.map (fun (e, t) ->
+                   if e = hole_of_exp e then None else Some (e, t))
+          (match e with
+            | Some (exp) ->
+               let typ = snd (judge ((exp, cxt), env, prefix)) in
+               begin
+                 (* 引数の数をチェック *)
+                 match (decode_tuple typ) with
+                 | Some (typs) ->
+                    let exps = match exp.pexp_desc with
+                      | Pexp_tuple (es) -> es
+                      | _ -> assert false in
+                    List.combine exps typs
+                 | None -> [(exp, typ)]
+               end
+            | None -> []) in
+
+      (* extract core type list from constructor arguments *)
+      (* extract_core_types : constructor_arguments -> core_type list *)
+      let extract_core_types carg = match carg with
+        | Pcstr_tuple (cts) -> cts
+        | Pcstr_record (_) -> assert false (* not supported yet *)
+      in
+
+      (* prefix の分解 *)
+      (* prefix -> (string * kind) list *)
+      let rec get_construct prefix = match prefix with
+        | [] -> []
+        | (first, _) :: rest ->
+            begin match first.pstr_desc with
+            | Pstr_type (_, tds) ->
+                (* 型の情報 *)
+                (* type_declaration list -> (string * type_kind) list *)
+                (List.map (fun {ptype_name = n; ptype_kind = k} ->
+                            (n.txt, get_type_value k)) tds) @
+                (get_construct rest)
+            | Pstr_exception ({pext_name = n; pext_kind = k}) ->
+                (* 例外の情報 *)
+                (n.txt, get_ext_value n.txt k) :: (get_construct rest)
+            | Pstr_module ({pmb_name = n; pmb_expr = e}) ->
+                (* モジュール名と中の式 *)
+                begin match e.pmod_desc with
+                  | Pmod_structure (strs) ->
+                    let pre_mod = get_construct
+                                    (List.map (fun x -> (x, Env.empty)) strs) in
+                    let a = List.map (fun (nk, kind) ->
+                                       (n.txt ^ "." ^ nk,
+                                        List.map (fun (nc, cts) ->
+                                                   (n.txt ^ "." ^ nc, cts))
+                                                 kind))
+                                     pre_mod in
+                    a @ (get_construct rest)
+                  | _ -> get_construct rest
+                end
+            | _ -> get_construct rest
+            end
+
+      (* kind の分解 *)
+      (* type_kind -> (string, core_type list) list *)
+      and get_type_value kind = match kind with
+        | Ptype_variant (cds) ->
+          List.map (fun {pcd_name = n; pcd_args = a} ->
+                     (n.txt, extract_core_types a)) cds
+        | _ -> []
+      (* extension_constructor_kind -> (string, core_type list) list *)
+      and get_ext_value name kind = match kind with
+        | Pext_decl (cts, None) ->
+          (* 引数を取る場合をとりあえず *)
+          [(name, extract_core_types cts)]
+        | _ -> [] in
+
+(*
+      Debug_core.Node.Input.result 25 ((expr, cxt), env, prefix);
+      Debug_core.Node.Output.f ();
+*)
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_constructor lid (get_construct prefix) args
+
+  | Parsetree.Pexp_record (lst, None) -> (* illtyped *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+
+(*
+      (* typs : エラーが出た箇所でのフィールドの型 *)
+      let typs = List.map (fun ({txt = t}, e) -> (snd (judge ((e, cxt), env, prefix))), t) lst in
+      (* exps : エラーが出た箇所での式 *)
+      let exps = List.map (fun (_, e) -> e) lst in
+ *)
+      (* 上記フィールドの名称を取得 *)
+
+      (* ダミーの型 *)
+      let dummy_exp =
+        { pexp_desc = Parsetree.Pexp_record
+                        (List.map (fun (lid, _) -> (lid, skeleton)) lst, None);
+          pexp_loc = Location.none;
+          pexp_attributes = [] } in
+
+      let dummy_t = snd (judge ((dummy_exp, cxt), env, prefix)) in
+
+      (* prefixからフィールドの中身を取り出す *)
+(*
+      let rec dummy_string d = match d with
+        | {desc = Tconstr (p, _, _)} -> Path.name p
+        | {desc = Tsubst (expr)} -> dummy_string expr
+        | {desc = Tlink (expr)} -> dummy_string expr (* #useで呼び出した場合 *)
+        | _ -> Format.fprintf ppf "%a@." Printtyp.type_expr d;  assert false in
+      let rec get_params tlst = match tlst with
+        | [] -> raise Not_found
+        | {ptype_name = {txt = t}; ptype_kind = Ptype_record llst} :: rest ->
+           if t = dummy_string dummy_t then llst else get_params rest
+        | _ :: rest -> get_params rest in
+      let rec search_rec p = match p with
+          [] -> assert false
+        | ({pstr_desc = Pstr_type (_, tlst)}, _) :: rest ->
+           begin
+             try get_params tlst with
+             Not_found -> search_rec rest
+           end
+        | _ :: rest -> search_rec rest in
+ *)
+      (* 各フィールドの情報 *)
+      let fields =
+        List.map2 (fun ({txt = f}, e) ft ->
+                   ((f, ft), (e, snd (judge ((e, cxt), env, prefix)))))
+          lst (decode_labels dummy_t prefix) in
+      print_illtyped_record dummy_t fields
+
+  | Parsetree.Pexp_constraint (exp, t) ->
+      print_loc expr.pexp_loc;
+      print_identified ();
+      let (_, typ1) = judge ((exp, cxt), env, prefix) in
+      let exp' = { pexp_desc = Parsetree.Pexp_constraint (skeleton, t);
+                   pexp_loc = Location.none;
+                   pexp_attributes = [] } in
+      let (_, typ2) = judge ((exp', cxt), env, prefix) in
+      print_illtyped_constraint typ1 typ2
+
+  | Parsetree.Pexp_array (es) ->
+      (* array に関するエラー *)
+      let typs =
+        List.map (fun exp -> snd (judge ((exp, cxt), env, prefix)))
+                 (List.filter (fun e -> e <> hole_of_exp e) es) in
+      let (typ1, typ2) = (List.nth typs 0, List.nth typs 1) in
+      print_loc expr.pexp_loc;
+      print_identified ();
+      print_illtyped_array typ1 typ2
+  | Parsetree.Pexp_let (flg, vs, _) ->
+      (* 再起関数の rec を忘れた場合 *)
+      print_loc expr.pexp_loc;
+      print_identified ();
+      if flg = Nonrecursive
+      then match vs with
+        | [] -> ()
+        | first :: rest -> print_illtyped_let first rest
+      else if List.length vs > 1
+      then print_illtyped_let_rec_many vs
+      else print_illtyped_let_rec1 (List.hd vs)
+  | _ -> (* illtyped *)
+       print_loc expr.pexp_loc;
+       print_identified ();
+       Format.fprintf ppf "default case of make_message_illtyped@.";
+       print_illtyped_other ()
+
+(********** find the smallest illtyped structure **********)
+
+(* expr_of_structure : structure_item -> expression * expr_context *)
+let expr_of_structure structure_item = match structure_item with
+  | { pstr_desc = Pstr_eval (expr, _) } ->
+      (expr, Empty)
+  | { pstr_desc = Pstr_value (flg, bindings); pstr_loc = loc } ->
+      (* in なしの let 文 *)
+      ({ pexp_desc       = Pexp_let (flg, bindings, skeleton);
+         pexp_loc        = loc;
+         pexp_attributes = [] }, Empty)
+  | _ -> failwith "TypeDebugger: Error: this structure not supported."
+
+(* illtyped_expr : structure -> Env.t -> str_context -> expression context_t *)
+(* structure has to be ill-typed. *)
+let rec illtyped_expr structure env lst = match structure with
+    [] -> failwith "TypeDebugger: Error: structure is well typed."
+  | s :: rest ->
+      begin try
+        let (_, _, env') = Typemod.type_structure env [s] Location.none in
+        illtyped_expr rest env' ((s, env) :: lst)
+      with Typecore.Error (_, _, Typecore.Expr_type_clash (_))
+         | Typecore.Error (_, _, Typecore.Pattern_type_clash (_))
+         | _ (* Unbound value *)
+         -> (match s with 
+               { pstr_desc = Pstr_module ({pmb_expr = {pmod_desc =  Pmod_structure(structure)}})} -> illtyped_expr structure env lst
+             | _ -> (expr_of_structure s, env, lst))
+      end
+
+(********** main entry point **********)
+
+(* check_let_rec1 : value_binding -> Env.t -> value_binding list * int *)
+let check_let_rec1 vb env =
+  try
+    ignore(Typemod.type_structure env [{ pstr_desc = Pstr_value (Recursive, [vb]); pstr_loc  = Location.none }] Location.none);
+    (* エラーにならなければ単独再帰の rec つけ忘れ *)
+    if print_slice
+    then Format.fprintf ppf "@[This error is let_rec1.@]@.";
+    ([vb], 1)
+  with
+  | _ -> ([], 0)
+(* check_let_rec_many :
+     value_binding list -> Env.t -> value_binding list * int *)
+and check_let_rec_many vs_f env =
+  try
+    ignore(Typemod.type_structure env [{ pstr_desc = Pstr_value (Recursive, vs_f); pstr_loc  = Location.none }] Location.none);
+    (* 相互再帰の rec つけ忘れ *)
+    if print_slice
+    then Format.fprintf ppf "@[This error is let_rec_many.@]@.";
+    (vs_f, 2)
+  with
+  | _ -> ([], 0)
+(* check_let :
+     value_binding -> value_binding list -> Env.t -> value_binding list * int *)
+and check_let vb vs_b env =
+  try
+    ignore(Typemod.type_structure env [{ pstr_desc = Pstr_eval ({pexp_desc = Pexp_let (Nonrecursive, vs_b, {pexp_desc = Pexp_let (Nonrecursive, [vb], skeleton); pexp_loc = Location.none; pexp_attributes = []; }); pexp_loc = Location.none; pexp_attributes = []; }, []); pstr_loc  = Location.none }] Location.none);
+    (* and じゃなくて in で書くべき場面 *)
+    if print_slice
+    then Format.fprintf ppf "@[This error is let.@]@.";
+    (vb :: vs_b, 3)
+  with
+  | _ -> ([], 0)
+
+(* unbound_vb : value_binding list ->
+                value_binding list -> Env.t -> value_binding list * int *)
+let rec unbound_vb vs_f vs_b env = match vs_f with
+  (* エラーの原因になっている value binding を返す *)
+  | [] -> ([], 0)
+  | first :: rest ->
+     try
+       (* first の式部分がエラーになるかどうか *)
+       ignore(Typemod.type_structure env [{ pstr_desc = Pstr_eval (first.pvb_expr, []); pstr_loc  = Location.none }] Location.none);
+       (* エラーにならなければ次に進む *)
+       unbound_vb rest (first :: vs_b) env
+     with
+     | _ ->
+        (* let文のエラーをチェック *)
+        let (vs, num) =
+          check_let_rec1 first env in
+        let (vs, num) =
+          if num > 0 then (vs, num) else check_let_rec_many vs_f env in
+        let (vs, num) =
+          if num > 0 then (vs, num) else check_let first vs_b env in
+        (* 結果 *)
+        (vs, num)
+(* search : expression -> Env.t -> expression *)
+and search exp env = match exp.pexp_desc with
+  (* rec のつけ忘れがあれば該当する構文を返す *)
+  (* なければ □ を返す *)
+  | Pexp_let (flg, vs, e) ->
+     let exp' = search e env in
+     let (vs', num) =
+       if flg = Recursive then ([], 0) else unbound_vb vs [] env in
+     (* 結果を元に返す式を決める *)
+     if num > 0
+     then
+       let flg' =
+         if num = 3 then Nonrecursive else Recursive in
+       let d =
+         Pexp_let (flg', vs', e) in
+       {pexp_desc = d;
+        pexp_loc = exp.pexp_loc;
+        pexp_attributes = exp.pexp_attributes; }
+     else if exp' = hole_of_exp exp'
+     then hole_of_exp exp
+     else exp'
+  | Pexp_ifthenelse (e1, e2, e') ->
+     let es = e1 :: e2 :: match e' with None -> [] | Some e3 -> [e3] in
+     search' skeleton es env
+  | Pexp_match (e, cs) ->
+     search' (search e env) (List.map (fun {pc_rhs = e} -> e) cs) env
+  | Pexp_try (e, cs) ->
+     search' (search e env) (List.map (fun {pc_rhs = e} -> e) cs) env
+  | Pexp_apply (e, les) ->
+     search' (search e env) (List.map (fun (_, e) -> e) les) env
+  | Pexp_function (cs) ->
+     search' skeleton (List.map (fun {pc_rhs = e} -> e) cs) env
+  | Pexp_record (les, _) ->
+     search' skeleton (List.map (fun (_, e) -> e) les) env
+  | Pexp_tuple (es) -> search' skeleton es env
+  | Pexp_array (es) -> search' skeleton es env
+  | Pexp_construct (_, Some e) -> search e env
+  | Pexp_fun (_, None, _, e) -> search e env
+  | Pexp_constraint (e, _) -> search e env
+  | _ -> hole_of_exp exp
+(* search' : expression -> expression list -> Env.t -> expression *)
+and search' dummy lst env =
+  List.fold_left (
+      fun e' fst ->
+      if e' = hole_of_exp e' then search fst env else e'
+    ) dummy lst
+
+(*
+let get_type_expr ((expr, cxt), env, prefix) =
+  try
+    (* expr(fun文)の型を求める *)
+    let (_, typ) = judge ((expr, cxt), env, prefix) in
+    begin
+      match split_arrow typ with
+      | Some (t, _) -> Some (t)
+      | None -> Some (typ)
+    end
+  with _ -> None
+
+(* レコードの補完 *)
+(* complete_pat_record : expression context_t
+   -> (Longident.t loc * pattern) list -> pattern_desc *)
+let complete_pat_record ((expr, cxt), env, prefix) (lps, flg) =
+  match get_type_expr ((expr, cxt), env, prefix) with
+  | None -> Ppat_any
+  | Some (dummy_t) ->
+     (* レコードのパターンの置き換えを行う *)
+     (* 各フィールドのダミーを作る *)
+     let dummy_lps =
+       List.map (
+           fun {pld_name = {txt = t; loc = l}} ->
+           ({txt = Longident.parse t; loc = l}, Debug_core.wildcard)
+         ) (decode_labels dummy_t prefix) in
+     (* lps の要素を順に dummy_lps に当てはめていく *)
+     let lps' =
+       List.fold_left (
+           (* lst : 置き換えの対象 *)
+           (* (ln, pn) : パターン中の一要素 *)
+           fun lst (ln, pn) ->
+           List.map (
+               fun (lm, pm) ->
+               if Longident.last lm.txt = Longident.last ln.txt
+               then (ln, pn) else (lm, pm)) lst
+         ) dummy_lps lps in
+     (* record の desc を返す *)
+     Ppat_record (lps', flg)
+
+let dummy_fun pat =
+  Debug_core.desc_to_exp (Pexp_fun (Nolabel, None, pat, skeleton)) skeleton
+
+let complete_pat ((expr, cxt), env, prefix) pat =
+  match pat.ppat_desc with
+  | Ppat_record (lps, flg) ->
+     (* レコード *)
+     (* 足りないフィールドを補う *)
+     Debug_core.desc_to_pat (complete_pat_record ((expr, cxt), env, prefix) (lps, flg)) pat
+  | _ -> pat
+
+(* パターンの補完を行う関数 *)
+let rec complete ((expr, cxt), env, prefix) =  match expr.pexp_desc with
+  | Pexp_fun (l, eop, pat, exp) ->
+     (* fun P -> E *)
+     (* Pの型をチェックする *)
+     let exp' = complete ((exp, cxt), env, prefix) in
+     let pat' = complete_pat ((exp, cxt), env, prefix) pat in
+
+(*
+     let pat' = match pat.ppat_desc with
+       | Ppat_record (lps, flg) ->
+          (* E を □ に置き換える *)
+          let d = Pexp_fun (Nolabel, None, pat, skeleton) in
+          let dummy_e = Debug_core.desc_to_exp d expr in
+          (* Pのフィールドを補完する *)
+          Debug_core.desc_to_pat (complete_pat_record ((dummy_e, cxt), env, prefix) (lps, flg)) pat
+       | _ -> pat in
+ *)
+     let d' = Pexp_fun (l, eop, pat', exp') in
+     Debug_core.desc_to_exp d' expr
+(*     Debug_core.compare_expr (Debug_core.desc_to_exp d') expr *)
+  | Pexp_apply (e0, les) ->
+     (* E0 E1 E2 ... *)
+     let e0' = complete ((e0, cxt), env, prefix) in
+     let les' =
+       List.map (
+           fun (l, en) -> (l, complete ((en, cxt), env, prefix))) les in
+     let d' = Pexp_apply (e0', les') in
+(*     Debug_core.compare_expr (Debug_core.desc_to_exp d') expr *)
+     Debug_core.desc_to_exp d' expr
+  | Pexp_match (e, cs) ->
+     (* match E0 with P1 -> E1 | ... *)
+     (* csに含まれるパターン全てに対して同じように処理する *)
+     let cs' =
+       List.map (
+           fun ({pc_lhs = pat; pc_guard = g; pc_rhs = exp}) ->
+           let exp' = dummy_fun pat in
+           let pat' = complete_pat ((exp', cxt), env, prefix) pat in
+           {pc_lhs = pat'; pc_guard = g; pc_rhs = exp}
+         ) cs in
+     let d' = Pexp_match (e, cs') in
+     Debug_core.desc_to_exp d' expr
+(*
+     Debug_core.compare_expr (Debug_core.desc_to_exp d') expr
+ *)
+  | _ -> expr
+*)
+
+(* algo : structure -> Env.t -> unit *)
+(* structure contains all the program to be compiled *)
+(* toplevel_env is always the clean initial environment *)
+let algo structure toplevel_env =
+(*
+  if Debug_core.print_slice
+  then (
+    Format.fprintf ppf "@[algo: \n @.%a@.@]@." Pprintast.structure structure
+  );
+ *)
+  Warnings.parse_options false "-A";
+  if not print_node_count && false (* exists mode *) then print_initial_message ();
+(*
+  match phr with
+    Ptop_dir (_, _) ->
+      failwith "TypeDebugger: Error: Ptop_dir is passed to algo."
+  | Ptop_def (structure) ->
+*)
+  (* obtain the smallest illtyped structure *)
+
+  let ((expr, cxt), env, prefix) =
+    illtyped_expr structure toplevel_env [] in
+  if debug land 1 = 1 then Format.fprintf ppf "starting structure:@.%a@." Pprintast.structure structure;
+  if debug land 1 = 1 then Format.fprintf ppf "illtyped structure:@.%a@." Pprintast.expression expr;
+(*
+  if false (* !Debug_core.error_kind = "Typetexp" *)
+  then
+    (* let 文のエラー判定 *)
+    let expr' = search expr env in
+    if expr' = dummy_assertfalse expr'
+    then make_message_illtyped ((expr, cxt), env, prefix) (* [] [] *)
+    else make_message_illtyped ((expr', cxt), env, prefix) (* [] [] *)
+  else
+ *)
+  (* 通常のデバッグ *)
+  try
+    (* デバッガ起動 *)
+    (* 簡単なエラーでなければ、パターンの補完を行う *)
+    (*
+    if print_slice
+    then Format.fprintf ppf 
+                        "@[~algo~\
+                         @.  %a @]@." Pprintast.expression expr;
+     *)
+
+    walk_up_illtyped ((expr, cxt), env, prefix) [] [];
+
+    Warnings.parse_options false Warnings.defaults_w
+  with
+  | DebuggerQuit ->
+     Warnings.parse_options false Warnings.defaults_w
+
+  | Syntaxerr.Error (Syntaxerr.Unclosed _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Expecting _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Not_expecting _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Applicative_path _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Variable_in_scope _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Expert_exp _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.InfixOP0 _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Other _) -> assert false
+  | Syntaxerr.Error (Syntaxerr.Ill_formed_ast _) -> assert false
+  | err ->
+      Warnings.parse_options false Warnings.defaults_w;
+      raise err
+
+(* illtyped_structure_prefix : structure -> Env.t -> structure * structure *)
+(* structure has to be ill-typed. *)
+(* toplevel_env is always the clean initial environment *)
+(* returns (str, rev_str) where rev_str is well typed but str is ill typed *)
+let illtyped_structure_prefix structure toplevel_env =
+  let ((expr, cxt), _, prefix) = illtyped_expr structure toplevel_env [] in
+  (plug_str (expr, cxt), List.map fst prefix)
+
+(* handle_simple_errors : Format.formatter -> exn ->
+                          structure -> (unit -> Env.t) -> bool *)
+(* 簡単なエラーはここで処理して true を返す *)
+(* 処理しなかった場合は false を返す *)
+
+(*
+let finished = ref (true)
+*)
+
+let handler loc error f =
+  try
+    f loc error;
+    true
+  with
+    Failure msg -> msg <> "Typecore"
+
+(* typecore のエラー *)
+let typecore loc error = match error with
+  | Typecore.Wrong_name (_, typ, kind, _, name, _) ->
+      (* レコードもしくはコンストラクタに属していない引数がある *)
+      print_loc loc;
+      Debug_message.print_wrong_name kind typ name
+  | Typecore.Label_missing (labels) ->
+      (* フィールド不足 *)
+      print_loc loc;
+      Debug_message.print_label_missing labels
+  | Typecore.Label_multiply_defined (name) ->
+      (* 同一レコード内のフィールド多重定義 *)
+      print_loc loc;
+      Debug_message.print_label_mul name
+  | Typecore.Undefined_method (_, "use", _) ->
+      (* #useが文の途中にある *)
+      print_loc loc;
+      Debug_message.print_no_method_use ()
+  | Typecore.Orpat_vars (_) ->
+      (* 変数を含む複数のパターンが同じ式に至る *)
+      print_loc loc;
+      Debug_message.print_orpad_vars ()
+  | Typecore.Multiply_bound_variable (s) ->
+      (* ひとつのパターンマッチに同じ変数が複数回現れている *)
+      print_loc loc;
+      Debug_message.print_multiply_bound_variable s
+  | _ -> failwith "Typecore"
+
+(* typedecl のエラー *)
+and typedecl loc error = match error with
+  | Typedecl.Duplicate_constructor s ->
+      (* 二重定義・コンストラクタ *)
+      print_loc loc;
+      Debug_message.print_identified ();
+      Debug_message.print_duplicate_name "constructor" s
+  | Typedecl.Duplicate_label s ->
+      (* 二重定義・レコード *)
+      print_loc loc;
+      Debug_message.print_identified ();
+      Debug_message.print_duplicate_name "record" s
+  | _ -> failwith "Typedecl"
+
+(* typetexp のエラー *)
+and typetexp loc error = match error with
+  | Typetexp.Unbound_constructor (lid) ->
+      (* 未定義：コンストラクタ *)
+      print_loc loc;
+      Debug_message.print_identified ();
+      Debug_message.print_unbound_name "construct" lid
+  | Typetexp.Unbound_label (lid) ->
+      (* 未定義：フィールド *)
+      print_loc loc;
+      Debug_message.print_identified ();
+      Debug_message.print_unbound_name "record" lid
+  | Typetexp.Unbound_module (lid) ->
+      (* 未定義：モジュール *)
+      print_loc loc;
+      Debug_message.print_identified ();
+      Debug_message.print_unbound_name "module" lid
+  | _ -> failwith "Typetexp"
+
+let handle_simple_errors ppf x structure init_env =
+
+  if Data.express_mode < 0 && print_ocaml_error then
+    Location.report_exception ppf x;
+
+  match x with
+  | Typetexp.Error (loc, _, Typetexp.Unbound_value (_)) ->
+      (* 未定義：変数 *)
+      let ((expr, cxt), env, prefix) =
+        illtyped_expr structure (init_env ()) [] in
+      let expr' = search expr env in
+      if expr' = hole_of_exp expr' then
+        false
+      else
+        handler loc expr'
+          (fun l e ->
+             print_loc l;
+             make_message_illtyped ((e, cxt), env, prefix))
+  | Typecore.Error (loc, _, error) when handler loc error typecore -> true
+  | Typedecl.Error (loc, error) when handler loc error typedecl -> true
+  | Typetexp.Error (loc, _, error) when handler loc error typetexp -> true
+  | _ -> setCompileError x
+
+(*
+let handle_simple_errors ppf x structure init_env =
+
+  if Data.express_mode < 0 && print_ocaml_error then
+    Location.report_exception ppf x;
+
+  (* typecore のエラー *)
+  let typecore error =
+    (* Debug_core.error_kind := "Typecore"; *))
+
+    match error with
+    | Typecore.Wrong_name (_, typ, kind, _, name, _) ->
+        (* レコードもしくはコンストラクタに属していない引数がある *)
+        Location.report_exception ppf x;
+        Debug_message.print_identified ();
+        Debug_message.print_wrong_name kind typ name
+    | Typecore.Label_missing (labels) ->
+        (* フィールド不足 *)
+        Location.report_exception ppf x;
+        Debug_message.print_identified ();
+        Debug_message.print_label_missing labels
+    | Typecore.Label_multiply_defined (name) ->
+        (* 同一レコード内のフィールド多重定義 *)
+        Location.report_exception ppf x;
+        Debug_message.print_identified ();
+        Debug_message.print_label_mul name
+    | Typecore.Undefined_method (_, "use", _) ->
+        (* #useが文の途中にある *)
+        Location.report_exception ppf x;
+        Debug_message.print_identified ();
+        Debug_message.print_no_method_use ()
+    | Typecore.Orpat_vars (_) ->
+        (* 変数を含む複数のパターンが同じ式に至る *)
+        Location.report_exception ppf x;
+        Debug_message.print_identified ();
+        Debug_message.print_orpad_vars ()
+    | Typecore.Multiply_bound_variable (s) ->
+        (* ひとつのパターンマッチに同じ変数が複数回現れている *)
+        Location.report_exception ppf x;
+        Debug_message.print_identified ();
+        Debug_message.print_multiply_bound_variable s
+    | _ -> finished := false; (* type debugger will be launched later *)
+        handle := Core (x) (* typecore のエラー *)
+
+  (* typedecl のエラー *)
+  and typedecl error =
+    (* Debug_core.error_kind := "Typedecl"; *)
+
+    match error with
+    | Typedecl.Duplicate_constructor s ->
+        (* 二重定義・コンストラクタ *)
+        Debug_message.print_identified ();
+        Debug_message.print_duplicate_name "constructor" s
+    | Typedecl.Duplicate_label s ->
+        (* 二重定義・レコード *)
+        Debug_message.print_identified ();
+        Debug_message.print_duplicate_name "record" s
+    | _ -> Location.report_exception ppf x;
+        handle := Decl error
+
+  (* typetexp のエラー *)
+  and typetexp error =
+    (* Debug_core.error_kind := "Typetexp"; *)
+
+    match error with
+    | Typetexp.Unbound_value (_) ->
+        (* 未定義：変数 *)
+        let ((expr, cxt), env, prefix) =
+          illtyped_expr structure (init_env ()) [] in
+        let expr' = search expr env in
+        if expr' = hole_of_exp expr'
+        then (* make_message_illtyped ((expr, cxt), env, prefix) *)
+          (finished := false; handle := Texp error)
+        else make_message_illtyped ((expr', cxt), env, prefix) (* [] [] *)
+
+    | Typetexp.Unbound_constructor (lid) ->
+        (* 未定義：コンストラクタ *)
+        Debug_message.print_identified ();
+        Debug_message.print_unbound_name "construct" lid
+
+    | Typetexp.Unbound_label (lid) ->
+        (* 未定義：フィールド *)
+        Debug_message.print_identified ();
+        Debug_message.print_unbound_name "record" lid
+
+    | Typetexp.Unbound_module (lid) ->
+       (* 未定義：モジュール *)
+       Debug_message.print_identified ();
+       Debug_message.print_unbound_name "module" lid
+
+    | _ -> Location.report_exception ppf x
+  in
+
+  begin
+    match x with
+      | Typecore.Error (_, _, error) -> typecore error
+      | Typedecl.Error (_, error) -> typedecl error
+      | Typetexp.Error (_, _, error) -> typetexp error
+      | _ -> Location.report_exception ppf x
+  end;
+  !finished
+*)
+
+(* launch : structure -> (unit -> Env.t) -> unit *)
+let launch strs initial_env =
+  (* structure *)
+  if print_node_count then begin
+      let (last_str, rev_str) =
+        illtyped_structure_prefix ([hole_str]@strs) (initial_env ()) in
+      let strs = List.rev_append rev_str last_str in
+
+      (* スライス前のノード数も数える *)
+      algo strs (initial_env ());
+      (* パターン以外のスライス後のノード数も数える *)
+      on_pat_slice := false;
+      let slice = Debug_slice.get_slice_top strs (initial_env ()) in
+
+      let strs = List.rev_append rev_str slice in
+      algo strs (initial_env ());
+      on_pat_slice := true
+    end;
+  (* スライスの有無を切り替える *)
+
+  let strs = 
+    if on_slice then
+      (* スライスを求める *)
+      Debug_slice.get_slice_top strs (initial_env ())
+    else
+      strs in
+
+  if print_slice then
+    Format.fprintf ppf
+      "structure : %a@."
+      Pprintast.structure strs;
+
+  let {msg; loc} = getCompileError () in
+
+  if Data.express_mode = 99 then
+    let message =
+      String.split_on_char '\n' msg (* 改行コードの除去 *)
+      |> List.map (String.split_on_char ' ') (* 空白の除去 *)
+      |> List.concat
+      |> List.filter (fun word -> word <> "") (* 空文字列の除去 *)
+      |> String.concat " " (* 改行をのぞいて復元 *) in
+    (* コンパイラのメッセージをJSON形式で表示 *)
+    Format.fprintf ppf
+      "{\"location\": %a, \"message\": \"%s\"}@."
+      Data.Loc.printJSON loc message;
+    exit 99
+
+  else if Data.express_mode = 98 then
+    let structure =
+      List.filter (fun item -> item <> Hole.item) strs in
+    (* スライス結果を表示する *)
+    Pprintast.structure ppf structure;
+    exit 98
+
+  else
+    (* その他 *)
+    algo strs (initial_env ())
diff --git a/typing/debug_main.mli b/typing/debug_main.mli
new file mode 100644
index 0000000..fb5a3d5
--- /dev/null
+++ b/typing/debug_main.mli
@@ -0,0 +1,5 @@
+open Parsetree
+
+val handle_simple_errors : Format.formatter -> exn ->
+                           structure -> (unit -> Env.t) -> bool
+val launch : structure -> (unit -> Env.t) -> unit
diff --git a/typing/debug_message.ml b/typing/debug_message.ml
new file mode 100644
index 0000000..68a9433
--- /dev/null
+++ b/typing/debug_message.ml
@@ -0,0 +1,1080 @@
+open Format
+open Printtyp
+open Parsetree
+open Syntaxerr (* for language_t, language *)
+
+let ppf = std_formatter
+
+let nth n = match n with
+    1 -> "1st"
+  | 2 -> "2nd"
+  | 3 -> "3rd"
+  | _ -> string_of_int n ^ "th"
+
+let print_loc loc =
+  Location.print ppf loc
+
+let rec string_of_longident t = match t with
+    Longident.Lident (l) -> l
+  | Longident.Ldot (t, l) -> (string_of_longident t) ^ "." ^ l
+  | _ -> assert false;;
+
+let print_initial_message () =
+  match language with
+| English -> fprintf ppf
+    "@[The above type error was raised.  Type debugger started.@]@.@."
+| Japanese -> fprintf ppf
+    "@[上記の型エラーが起こりました。デバッガを起動します。@]@.@."
+
+let print_prompt () =
+  fprintf ppf "@[(y/n/q) > @]@?"
+
+let print_ask_env st typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[In this scope, do you intend '%s' to be of type:@ %a ?@]@."
+    st Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[ハイライトされた部分のスコープで %s を@ %a@ 型だと意図していますか？@]@."
+    st Printtyp.type_expr typ
+
+let print_ask_expr typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Do you intend this expression to be of type:@ %a ?@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[ハイライトされた部分の型を@ %a@ だと意図していますか？@]@."
+    Printtyp.type_expr typ
+
+let print_identified () =
+  match language with
+| English -> fprintf ppf
+    "@[The source of the type error is highlighted.@]@."
+| Japanese -> fprintf ppf
+    "@[ハイライトされた部分に特定されました。@]@."
+
+let check_duplicate typ1 typ2 =
+  (* type_expr を Ident.t list にする *)
+  (* idents_of_typexp : type_expr -> Ident.t list *)
+  let rec idents_of_typexp {Types.desc = desc} =
+    match desc with
+      Types.Tconstr (path, tyl, _) ->
+       let rec get_id p = match p with
+           Path.Pident (id) -> [id] (* path の情報がある *)
+         | Path.Pdot (p, _, _) -> get_id p
+         | Path.Papply (p1, p2) -> (get_id p1) @ (get_id p2) in
+       List.fold_left (fun il ty -> il @ idents_of_typexp ty) (get_id path) tyl
+    | Types.Tlink (ty) -> idents_of_typexp ty
+    | Types.Tsubst (ty) -> idents_of_typexp ty
+    | Types.Tarrow (_, ty1, ty2, _) ->
+       (idents_of_typexp ty1) @ (idents_of_typexp ty2)
+    | Types.Ttuple (tyl) ->
+       List.fold_left (fun il ty -> il @ idents_of_typexp ty) [] tyl
+    | Types.Tvar _ | Types.Tobject _
+    | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tunivar _
+    | Types.Tpoly _ | Types.Tpackage _ -> [] in
+  let is_duplicate i1 i2 =
+    (* equal = true,  same = true  : 同一の型 *)
+    (* equal = true,  same = false : 同じ名前だが別の型 *)
+    (* equal = false, same = false : 全く異なる型 *)
+    if (Ident.equal i1 i2) <> (Ident.same i1 i2) then
+      fprintf ppf "@[（%s が二重に定義されています。）@]@." (Ident.name i1) in
+  let print_duplicate typ1 typ2 =
+    let idl1 = idents_of_typexp typ1 in
+    let idl2 = idents_of_typexp typ2 in
+    try List.iter2 is_duplicate idl1 idl2 with
+      Invalid_argument _ -> () in
+  print_duplicate typ1 typ2
+
+(*** print error massage ***)
+(*
+
+特定される構文ごとに分類
+・式
+<Pexp_ifthenelse>
+  Error12 -- Error15
+<Pexp_apply>
+  Error17 -- Error19, Error27 -- Error28
+<Pexp_function><Pexp_fun>
+  Error20
+<Pexp_match>
+  Error21 -- Error24, Error33
+<Pexp_try>
+  Error53 -- Error55
+<Pexp_construct>
+  Error25, Error56, print_duplicate_name (共通)
+<Pexp_record>
+  Error34 -- Error35, Error51 -- Error52, Error56, print_duplicate_name (共通)
+
+<Pexp_constraint>
+  Error36
+
+<Pexp_array>
+  Error38
+・パターン変数
+Error30
+Error39
+Error40
+
+  print_recursive as
+  Error1  : 再帰関数の定義と呼び出しで型が合わない
+  print_patexps as
+  Error2  : パターンと式の型が合わない
+  (print_patexps2 as Error3)
+  print_welltyped_expr as
+  Error4  : 式の型がプログラマの意図と異なる
+  print_welltyped_env1 as
+  Error5  : 環境の変数のうち一つが別の型として使われている
+  print_welltyped_env_many as
+  Error6  : 環境の変数のうち複数が別の型として使われている
+  (print_welltyped_if_bool as Error7)
+  (print_welltyped_if_unit as Error8)
+  (print_welltyped_if_then_else as Error9)
+  (print_welltyped_match_pattern as Error10)
+  (print_welltyped_match_expression as Error11)
+  print_illtyped_if_predicate as
+  Error12 : 条件部分が bool 型でない
+  print_illtyped_if_then as
+  Error13 : else 部分がない
+  print_illtyped_if_fv as
+  Error14 : if 文の中で同じ変数が別の型として扱われている
+  print_illtyped_if_then_else as
+  Error15 : then 部分と else 部分で型が異なる
+  (print_illtyped_apply as Error16)
+  print_illtyped_apply_funname as
+  Error17 : 関数呼び出しの引数の型が合わない
+  (print_illtyped_apply_beginning as Error18)
+  (print_illtyped_apply_beginning2 as Error19)
+  print_illtyped_function as
+  Error20 : function 文の型エラー
+  print_illtyped_match_exp as
+  Error21 : パターンと match する式の型が異なる
+  print_illtyped_match_left as
+  Error22 : match 文のパターンに複数の型が混在している
+  print_illtyped_match_right as
+  Error23 : match 文の結果に複数の型が混在している
+  (print_illtyped_match_fv as Error24)
+  print_illtyped_constructor as
+  Error25 : コンストラクタのエラー
+  print_illtyped_other as
+  Error26 : デフォルトケース
+  print_illtyped_too_much_args as
+  Error27 : 関数に渡す引数が多い
+  print_illtyped_apply_not_function as
+  Error28 : 関数部分が関数でない
+  print_illtyped_var_undefined as
+  Error29 : 変数が未定義、もしくはstructure_item における区切りがない
+  print_pattern as
+  Error30 : パターンのエラー
+  print_guard as
+  Error32 : ガードのエラー
+  (print_guard_env as Error33)
+  print_illtyped_match_right2 as
+  Error33 : match 文の中で同じ変数が別の型として扱われている
+  print_illtyped_record as
+  Error34 : レコード内の要素の型が定義と異なる
+  print_label_mul as
+  Error35 : レコード内であるフィールドが複数回現れている
+  print_illtyped_constraint as
+  Error36 : (expr : core_type) の左右で型が一致しない
+  print_no_method_use as
+  Error37 : #use の前に区切りがない
+  print_illtyped_array as
+  Error38 : 配列のエラー
+
+  Error41 : let文のエラー(nonrec)
+  Error42 : let文のエラー(rec 1)
+  Error43 : let文のエラー(rec many)
+
+  print_label_mismatch as
+  Error51 : 複数のレコードに定義されたフィールドが混在している
+  print_label_missing as
+  Error52 : 使われていないフィールドがある
+  print_illtyped_try_right as
+  Error53 : try 文の結果に複数の型が混在している
+  print_illtyped_try_left as
+  Error54 : try 文のパターンに複数の型が混在している
+  print_illtyped_try_env as
+  Error55 : try 文の中で同じ変数が別の型として扱われている
+  print_wrong_name as
+  Error56 : 未定義のコンストラクタ/フィールドが存在する
+
+↓並べ替えるなら↓
+・デフォルトケース
+・未定義
+・welltyped のやつ
+・関数適用
+・fun文、function文
+・if文
+・パターンマッチ
+・try文
+・パターン
+・ガード
+・再帰
+・コンストラクタ
+・コンストラクタ/レコード共通
+・レコード
+・#use、constraint、配列
+
+
+*)
+
+let print_recursive typ st typ' =
+  Printtyp.reset_and_mark_loops typ;
+  Printtyp.reset_and_mark_loops typ';
+  match language with
+| English -> fprintf ppf
+    "@[Error1 : The function %s has type@ %a,\
+     @ but '%s' is used at type@ %a in this recursive call.@]@."
+    st Printtyp.type_expr typ st Printtyp.type_expr typ'
+| Japanese -> fprintf ppf
+    "@[Error1 : 関数 %s は@ %a@ 型ですが、@,\
+     再帰呼び出しで %s を %a@ 型として使っています。@,\
+     （再帰呼び出し時の引数の数や型は合っていますか？）@]@."
+    st Printtyp.type_expr typ st Printtyp.type_expr typ'
+
+let print_patexps typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error2 : This expression has type:@ %a,\
+     @ but it conflicts with the type of the pattern.@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error2 : この式は@ %a@ 型で、@,\
+     期待されるパターンの型と合いません。@]@."
+    Printtyp.type_expr typ
+
+let print_patexps2 () =
+ (* Printtyp.reset_and_mark_loops pattyp;*)
+  match language with
+| English -> fprintf ppf
+    "@[Error3 : This expression has constant type,@,\
+     but it conflicts with the type of the pattern.@]@."
+| Japanese -> fprintf ppf
+    "@[Error3 : この式は定数になっていますが、@,\
+     let 文で束縛する式は変数もしくはパターンでなければなりません。@]@."
+
+let print_welltyped_expr typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error4 : This expression has type@ %a.@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error4 : この式の型は@ %a@ 型です。@]@."
+    Printtyp.type_expr typ
+
+let print_welltyped_env1 st typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error5 : The variable '%s' is used as an expression of type:@ %a.@]@."
+    st Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error5 : 変数 %s は@ %a@ 型として使われています。@]@."
+    st Printtyp.type_expr typ
+
+let print_welltyped_env_many st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "@[Error6 : Following variables are used as expressions of types:@]@."
+| Japanese -> fprintf ppf
+    "@[Error6 : 次の変数は示される型として使われています。@]@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_if_bool st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error7 : Expressions at the following variables need the following types.\
+     @. The predicate of a conditional expression needs to have type bool.@."
+| Japanese -> fprintf ppf
+    "Error7 : 次の変数が示される型になっています。@,\
+     if 文の条件部は bool 型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_if_unit st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error8 : Expressions at the following variables need the following types.\
+     @. Since the conditional expression does not have else branch,@,\
+     then branch needs to have type unit.@. (or you might forgot else branch)@."
+| Japanese -> fprintf ppf
+    "Error8 : 次の変数が示される型になっています。@,\
+     else 部分がないため if 文の then 部分は unit 型でなければなりません。@,\
+     （もしくは else 部分を忘れていませんか？）@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_if_then_else st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error9 : Expressions at the following variables need the following types.\
+     @. Then branch and else branch of a conditional expression need to be \
+     the same type.@."
+| Japanese -> fprintf ppf
+    "Error9 : 次の変数が示される型になっています。@,\
+     if 文の then 部分と else 部分は同じ型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+(* TODO : English messages *)
+let print_welltyped_match_pattern st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error10 : Expressions at the following variables need the following types:\
+     @."
+| Japanese -> fprintf ppf
+    "Error10 : 次の変数が示される型になっています。@,\
+     match 文の矢印の左側は同じ型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_welltyped_match_expression st typ rest =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "Error11 : Expressions at the following variables need the following types:\
+     @."
+| Japanese -> fprintf ppf
+    "Error11 : 次の変数が示される型になっています。@,\
+     match 文の矢印の右側は同じ型でなければなりません。@."
+  end;
+  fprintf ppf "  @[%s : %a" st Printtyp.type_expr typ;
+  List.iter (fun (((st, _), _, _), typ) ->
+              (* Printtyp.reset_and_mark_loops typ; *)
+              fprintf ppf ",@ %s : %a" st Printtyp.type_expr typ)
+            rest;
+  fprintf ppf "@]@."
+
+let print_illtyped_var_undefined () =
+  match language with
+| English -> fprintf ppf
+    "@[Error29 : This variable is undefined.@]@."
+| Japanese -> fprintf ppf
+    "@[Error29 : この変数は未定義です。@]@."
+
+let print_illtyped_if_predicate typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error12 : The type of the predicate part is:@ %a,@,\
+     but it has to be bool.]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error12 : 条件部分の型は@ %a@ ですが bool 型でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+
+let print_illtyped_if_then typ =
+  Printtyp.reset_and_mark_loops typ;
+  begin match language with
+| English -> fprintf ppf
+    "@[Error13 : The type of the then branch is:@ %a,@,\
+     but it has to be unit.]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error13 : then 部分が@ %a @ 型になっていますが@ \
+     else 部分がないため unit 型でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+  end;
+  begin match language with
+| English -> fprintf ppf
+    "@[(Or, you forgot the else branch perhaps?)@]@."
+| Japanese -> fprintf ppf
+    "@[（もしくは else 部分を書き忘れていませんか？）@]@."
+  end
+
+let print_illtyped_if_fv () =
+  match language with
+| English -> fprintf ppf
+    "@[Error14 : Some variables are used at different types.@]@."
+| Japanese -> fprintf ppf
+    "@[Error14 : 同じ変数が別の場所で別の型として使われています。@]@."
+
+let print_illtyped_if_then_else typ2 typ3 =
+  Printtyp.reset_and_mark_loops typ2;
+  Printtyp.reset_and_mark_loops typ3;
+  begin match language with
+| English -> fprintf ppf
+    "@[Error15 : The types of the then and else branches are:@ %a@ and@ %a,@,\
+     but they have to be the same.@,\
+     (Or, some variables are used at different types.)@]@."
+    Printtyp.type_expr typ2 Printtyp.type_expr typ3
+| Japanese -> fprintf ppf
+    "@[Error15 : then 部分が@ %a@ 型で else 部分が@ %a@ 型になっていますが、@,\
+     これらは同じ型でなくてはなりません。@,\
+     （または同じ変数が別の場所で別の型として使われています。）@]@."
+    Printtyp.type_expr typ2 Printtyp.type_expr typ3
+  end;
+  check_duplicate typ2 typ3
+
+let rec print_illtyped_apply_args typs n = match typs with
+    [] -> ()
+  | typ :: rest ->
+      begin match language with
+      | English -> fprintf ppf
+          " @[<2>%s argument :@ %a@]@." (nth n) Printtyp.type_expr typ
+      | Japanese -> fprintf ppf
+          " @[<2>%d 番目の引数の型：@,%a@]@." n Printtyp.type_expr typ
+      end;
+      print_illtyped_apply_args rest (n + 1)
+
+(* 関数名なし *)
+let print_illtyped_apply n exp_typ typs well_typ =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error16 : The type conflict occurs at the %s argument.@,\
+       The types of function and arguments, required type of %s argument are:@]"
+      (nth n) (nth n);
+    fprintf ppf
+      "@[Function :@ %a@]@."
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[Required type of %s argument :@ %a@.@]"
+      (nth n) Printtyp.type_expr well_typ
+| Japanese ->
+    fprintf ppf
+      "@[Error16 : この関数呼び出しの %d 番目の引数で型が合いません。@,\
+       関数、引数、%d 番目の引数に要求される型は以下の通りです。@]@."
+      n n;
+    fprintf ppf
+      "@[関数部分：@,%a@]@."
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[%d 番目の引数に要求される型：@,%a@.@]"
+      n Printtyp.type_expr well_typ
+
+(* 関数名あり *)
+let print_illtyped_apply_funname n exp_typ exps typs well_typ name =
+  if 7 <= Array.length Sys.argv then
+    fprintf ppf
+      "@[Function %a :@ %a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error17 : The type conflict occurs at the %s argument.@,\
+       The types of function and %s argument, required type of %s argument are:@]"
+      (nth n) (nth n) (nth n);
+    fprintf ppf
+      "@[Function %a :@ %a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    fprintf ppf
+      " @[<2>%s argument :@ %a@]@."
+      (nth n) Printtyp.type_expr (List.nth typs (n - 1));
+    fprintf ppf
+      " @[Required type of %s argument :@ %a@.@]"
+      (nth n) Printtyp.type_expr well_typ
+| Japanese -> fprintf ppf
+    "@[Error17 : この関数呼び出しの %d 番目の引数で型が合いません。@,\
+     関数、%d 番目の引数、%d 番目の引数に要求される型は以下の通りです。@]@." n n n;
+    fprintf ppf
+      "@[関数部分 %a：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    fprintf ppf
+      " @[<2>%d 番目の引数 %a：@,%a@]@."
+      n Pprintast.expression (List.nth exps (n - 1)) Printtyp.type_expr (List.nth typs (n - 1));
+    fprintf ppf
+      " @[%d 番目の引数に要求される型：@,%a@.@]"
+      n Printtyp.type_expr well_typ;
+    check_duplicate (List.nth typs (n - 1)) well_typ
+
+(*
+let print_illtyped_apply_funname n exp_typ typs well_typ name =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error17 : The type conflict occurs at the %s argument.@,\
+       The types of function and arguments, required type of %s argument are:@]"
+      (nth n) (nth n);
+    fprintf ppf
+      "@[Function %a :@ %a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[Required type of %s argument :@ %a@.@]"
+      (nth n) Printtyp.type_expr well_typ
+| Japanese -> fprintf ppf
+    "@[Error17 : この関数呼び出しの %d 番目の引数で型が合いません。@,\
+     関数、引数、%d 番目の引数に要求される型は以下の通りです。@]@." n n;
+    fprintf ppf
+      "@[関数部分 %a：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      " @[%d 番目の引数に要求される型：@,%a@.@]"
+      n Printtyp.type_expr well_typ;
+    check_duplicate (List.nth typs (n - 1)) well_typ
+    *)
+
+let rec print_funtypes n funtypes =
+  match language with
+| English ->
+    begin match funtypes with
+        [] -> fprintf ppf
+          "@[(some arguments might be missing.)@]@."
+      | (m, typ) :: rest ->
+          fprintf ppf
+            " @[Type of %s argument :@ %a@]@."
+            (nth m) Printtyp.type_expr typ;
+          print_funtypes n rest
+    end
+| Japanese ->
+    begin match funtypes with
+        [] -> fprintf ppf
+          "@[これらに引数を渡すのを忘れていませんか？@]@."
+      | (m, typ) :: rest ->
+          fprintf ppf
+            " @[%d 番目の引数の型：@,%a@]@."
+            m Printtyp.type_expr typ;
+          print_funtypes n rest
+    end
+
+let print_illtyped_apply_beginning n name exp_typ typs funtype_args =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error18 : The type conflict occurs at the %s argument.@]@."
+      (nth n);
+    fprintf ppf
+      "@[Function %a :@ %a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf
+      "@[The following arguments have function type.@]@.";
+    print_funtypes n funtype_args
+| Japanese ->
+    fprintf ppf
+      "@[Error18 : この関数呼び出しの %d 番目の引数で型が合いません。@]@."
+      n;
+    fprintf ppf
+      "@[関数部分 %a の型：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1;
+    fprintf ppf "@[以下の引数が関数型になっています。@]@.";
+    print_funtypes n funtype_args
+
+(* 関数型になっている引数がないとき *)
+let print_illtyped_apply_beginning2 =
+  print_illtyped_apply_funname
+(*
+let print_illtyped_apply_beginning2 n name exp_typ n_typ =
+  match language with
+| English ->
+    fprintf ppf
+      "@[Error19 : The type conflict occurs at the %s argument.@]@."
+      (nth n);
+| Japanese ->
+    fprintf ppf
+      "@[Error19 : この関数呼び出しの %d 番目の引数で型が合いません。@]@."
+      n;
+    fprintf ppf
+      "@[関数部分 %a の型：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    fprintf ppf
+      " @[%d 番目の引数の型：@,%a@.@]@."
+      n Printtyp.type_expr n_typ
+ *)
+
+let print_illtyped_function () =
+  match language with
+  | English ->
+      fprintf ppf
+        "@[Error20 : The pattern forces some variable an unintended type.@]@."
+  | Japanese ->
+      fprintf ppf
+        "@[Error20 : パターンによって変数の型が意図しないものに\
+         強制されています。@]@."
+
+let print_illtyped_match () =
+  match language with
+| English -> fprintf ppf
+    "@[Somewhere in this match expression is wrong.@]@."
+| Japanese -> fprintf ppf
+    "@[この match 文のどこかがおかしいです。@]@."
+
+let print_illtyped_match_exp typ1 typ2 =
+  match language with
+  | English ->
+      fprintf ppf
+        "@[Error21 : Somewhere in this match expression is wrong.@]@." (* 英語 *)
+| Japanese ->
+    fprintf ppf
+      "@[Error21 : match する式が@ %a@ 型でパターンが@ %a@ 型になっていますが、\
+       @,これらは同じ型でなくてはなりません。@]@."
+      Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+    check_duplicate typ1 typ2
+
+let print_illtyped_match_left typ1 typ2 =
+  match language with
+| English -> fprintf ppf
+    "@[Error22 : Somewhere in this match expression is wrong.@]@." (* 英語 *)
+| Japanese -> fprintf ppf
+    "@[Error22 : ハイライト部分が@ %a@ 型でそれ以前までの矢印の左側が\
+     @ %a@ 型になっていますが、@,これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+              check_duplicate typ1 typ2
+
+let print_illtyped_match_right typ1 typ2 =
+  match language with
+| English -> fprintf ppf
+    "@[Error23 : The type of this expression is:@ %a,@,\
+     but the type of the preceeding clause is:@ %a.@,\
+     They must be the same type.@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2
+| Japanese -> fprintf ppf
+    "@[Error23 : ハイライト部分が@ %a@ 型でそれ以前までの矢印の右側が\
+     @ %a@ 型になっていますが、@,これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+              check_duplicate typ1 typ2
+
+let print_illtyped_match_right2 () =
+  match language with
+| English -> fprintf ppf
+    "@[Error33 : Some variables in this expression is used at different type@ \
+     at different place.@]@."
+| Japanese -> fprintf ppf
+    "@[Error33 : ハイライト部分の変数が\
+     別の場所で別の型として使われています。@]@."
+
+let print_illtyped_match_fv () =
+  match language with
+| English -> fprintf ppf
+    "@[Error24 : Some variables are used at different types.@]@."
+| Japanese -> fprintf ppf
+    "@[Error24 : 同じ変数が別の場所で別の型として使われています。@]@."
+
+let rec print_type lid plst args =
+    match plst with
+    | [] ->
+       begin
+         if Longident.last lid = "::"
+         then
+           begin
+             match args with
+             | [Some (e1, t1); Some (e2, t2)] -> print_list_clash e1 t1 e2 t2
+             | [_; Some (_, typ)] -> print_list_mismatch typ
+             | _ -> ()
+           end
+         else
+           begin
+             print_constructor_name "'a option" lid;
+             if Longident.last lid = "Some"
+             then print_no_args "Some"
+             else print_arity_mismatch (List.length args) 0
+           end
+       end
+    | (name, vs) :: rest ->
+       try
+         print_args lid (name, vs) args
+       with
+         Not_found -> print_type lid rest args
+
+and print_args lid (name, vlst) args =
+  match vlst with
+  | [] -> raise Not_found
+  | (value, cts) :: rest ->
+     let a_sum = List.length args and c_sum = List.length cts in
+     let rec num t = match t with
+         [] -> 0
+       | first :: rest ->
+          if first = None
+          then num rest
+          else a_sum - (List.length rest) in
+     let n = num args in
+     if value <> string_of_longident lid
+     then
+       (* コンストラクタ名が一致しない場合は次へ進む *)
+       print_args lid (name, rest) args
+     else
+       begin
+         (* 該当するコンストラクタ名を表示 *)
+         print_constructor_name name lid;
+         if a_sum = 0
+         then
+           (* 引数が見つからない *)
+           print_no_args (string_of_longident lid)
+         else
+           begin
+             if a_sum = c_sum
+             then
+               (* 引数の数が同じ *)
+               let (en, tn) = match (List.nth args (n - 1)) with
+                 | Some (e, t) -> (e, t)
+                 | _ -> assert false in
+               begin
+                 print_arg_type_clash n (en, tn) (List.nth cts (n - 1));
+                 print_constuctor_type lid cts
+               end
+             else
+               (* 引数の数が異なる *)
+               print_arity_mismatch a_sum c_sum
+           end
+       end
+
+and print_list_clash e1 t1 e2 t2 =
+
+
+  fprintf ppf
+          "@[ハイライト部分のリストで、先頭の要素と末尾のリストの型が合いません。@ \
+           先頭の要素、末尾のリストは以下の通りです。@]@.";
+  fprintf ppf
+          " @[　先頭の要素 %a：@,%a @]@."
+          Pprintast.expression e1 Printtyp.type_expr t1;
+  fprintf ppf
+          " @[末尾のリスト %a：@,%a @]@."
+          Pprintast.expression e2 Printtyp.type_expr t2
+
+and print_list_mismatch typ =
+  fprintf ppf
+          "@[ハイライト部分の末尾が %a 型になっていますが、@ \
+           :: の右側はリストでなければなりません。@]@."
+          Printtyp.type_expr typ
+and print_constructor_name tname lid =
+  match lid with
+  | Longident.Ldot (t, l) ->
+     fprintf ppf
+             "@[ハイライトされた部分では、モジュール %s の中に定義された %s 型のコンストラクタ %s の、" (string_of_longident t) tname l
+  | _ ->
+     fprintf ppf
+             "@[%s 型のコンストラクタ %s の" tname (string_of_longident lid)
+
+and print_arg_type_clash n (e, t) c =
+  (* 引数の数が同じ *)
+  fprintf ppf
+          "%d 番目の引数で型が合いません。@ \
+           %d 番目の引数、%d 番目の引数に要求される型、コンストラクタの定義は以下の通りです。@]@."
+          n n n;
+  fprintf ppf
+          " @[<2>%d 番目の引数 %a：@,%a@]@."
+          n Pprintast.expression e Printtyp.type_expr t;
+  fprintf ppf
+          " @[<2>%d 番目の引数に要求される型：@,%a@.@]"
+          n Pprintast.core_type c;
+and print_constuctor_type lid cts =
+      fprintf ppf
+      " @[コンストラクタの定義：@,%s " (string_of_longident lid);
+     let rec print_core ct = match ct with
+         [] -> ()
+       | [first] ->
+          (* 引数が一つしかない場合 *)
+          fprintf ppf "%a" Pprintast.core_type first
+       | first :: rest ->
+          fprintf ppf "%a * " Pprintast.core_type first;
+          print_core rest in
+     if cts <> []
+     then (fprintf ppf "of ";  print_core cts);
+     fprintf ppf "@]@."
+
+and print_arity_mismatch n m =
+  (* 引数の数が異なる *)
+  fprintf ppf
+          "引数の数が違います。@ \
+           ハイライトされた部分では %d 個になっていますが、定義では %d 個です。@]@." n m
+and print_no_args l =
+  (* 引数が見つからない *)
+  fprintf ppf
+          "引数が見つかりません。@ \
+           （もしくは、 (%s ...) のようにかっこをつけましょう。）@]@." l
+
+let print_illtyped_constructor lid plst args =
+  match language with
+| English -> fprintf ppf
+    "@[Error25 : The constructor is given a wrong type of argument(s).@]@."
+| Japanese ->
+   fprintf ppf
+    "@[Error25 : コンストラクタの引数の型が合っていません。@]@.";
+   print_type lid plst args
+
+let print_illtyped_other () =
+  match language with
+| English -> fprintf ppf
+    "@[Error26 : This expression is ill-typed.@]@."
+| Japanese -> fprintf ppf
+    "@[Error26 : この部分に型がつきません。@]@."
+
+let print_illtyped_too_much_args n exp_typ typs name =
+  match language with
+| English ->
+    fprintf ppf
+      "@[The type conflict occurs at the %s argument.@]@."
+      (nth n)
+| Japanese ->
+    fprintf ppf
+      "@[Error27 : この関数呼び出しで渡されている引数が多いようです。@,\
+       関数と引数の型は以下の通りです。@]@.";
+    fprintf ppf
+      "@[関数部分 %a：@,%a@]@."
+      Pprintast.expression name
+      Printtyp.type_expr exp_typ;
+    print_illtyped_apply_args typs 1
+
+let print_illtyped_apply_not_function exp =
+  match language with
+| English -> fprintf ppf
+    "@[Error28 : This is not a function@]@.";
+| Japanese ->
+    fprintf ppf
+      "@[Error28 : ハイライトされた部分が関数呼び出しになっているのに、@,\
+       関数部分が@ %a@ 型になっています。@]@."
+       Printtyp.type_expr exp
+
+(* Error29 is already defined above *)
+
+let print_pattern () =
+  match language with
+| English -> fprintf ppf
+    "@[Error30 : This pattern is ill-formed.@]@."
+| Japanese -> fprintf ppf
+    "@[Error30 : ハイライトされたパターンに型がつきません@]@."
+
+let print_guard typ =
+  Printtyp.reset_and_mark_loops typ;
+  match language with
+| English -> fprintf ppf
+    "@[Error31 : The type of this expression is:@ %a,@,\
+     but it has to be bool.@]@."
+    Printtyp.type_expr typ
+| Japanese -> fprintf ppf
+    "@[Error31 : ハイライトされた部分の型は@ %a@ ですが@ \
+     bool 型でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+
+let print_guard_env () =
+  match language with
+| English -> fprintf ppf
+    "@[Error32 : A variable in this expression is used at different type@ \
+     at different place.@]@."
+| Japanese -> fprintf ppf
+    "@[Error32 : この式の中の変数が、別のところで別の型で使われています。@]@."
+
+(* Error33 is already defined above *)
+
+let print_illtyped_record typ fields =
+  (* 式が □ でないフィールドの情報だけを取る *)
+  List.iter (
+    fun ((f, ft), (e, et)) ->
+      if e.pexp_desc <> Debug_core.skeleton'.pexp_desc then
+        begin
+          fprintf ppf
+                  "@[Error34 : レコード %a のフィールド %s の型が合っていません。@ \
+                   ハイライト部分、定義上の型は以下の通りです。@]@."
+                  type_expr typ (Longident.last f);
+          fprintf ppf
+                  "@[ハイライト部分：@,(%a : %a)@]@."
+                  Pprintast.expression e type_expr et;
+          fprintf ppf
+                  "    @[定義上の型：@,%a@.@]"
+                  Pprintast.core_type ft.pld_type
+        end
+    ) fields
+
+let print_label_mul fname =
+  match language with
+| English -> fprintf ppf
+    "@[Error35 : The record field label %s@ is defined several times.@]@." fname
+| Japanese -> fprintf ppf
+    "@[Error35 : ハイライトされた部分で、レコードのフィールド %s が複数回使われています。@ \
+     (レコードのフィールド名はすべて異なる必要があります。)@]@." fname
+
+let print_illtyped_constraint typ1 typ2 =
+  Format.fprintf ppf
+    "@[Error36 : ハイライトされた部分で、: の左側の式は %a 型ですが、@ \
+     : の右側の型は %a 型です。これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+  check_duplicate typ1 typ2
+
+let print_no_method_use () =
+  Format.fprintf ppf
+    "@[Error37 : #use はファイルの先頭に書きましょう。@]@."
+
+let print_illtyped_array typ1 typ2 =
+  Format.fprintf ppf
+                 "@[Error38 : ハイライトされた部分は %a 型の配列ですが、@ \
+                  %a 型の要素が含まれています。 @ \
+                  配列の各要素の型は、すべて同じである必要があります。@]@."
+                 Printtyp.type_expr typ1 Printtyp.type_expr typ2;
+  check_duplicate typ1 typ2
+
+let print_orpad_vars () =
+  fprintf ppf
+          "@[Error39 : 変数を含むパターンは、| で矢印の左側にまとめることができません。@,\
+           すべてのパターンに式をつけるか、パターンに変数を含まないようにしましょう。@]@."
+
+let print_multiply_bound_variable s =
+  fprintf ppf
+          "@[Error40 : ハイライトされた部分で、パターン変数 %s が多重に定義されています。@,\
+           (ひとつのパターンの中に定義する変数の名前はすべて異なる必要があります。)@]@." s
+
+(* let文のエラー *)
+let print_illtyped_let_rec1 v =
+  fprintf ppf
+          "@[Error41 : ハイライト部分の関数定義 %a に再帰があります。@,\
+           let の後に rec を書きましょう。@]@."
+          Pprintast.pattern v.pvb_pat
+
+let print_illtyped_let_rec_many vs =
+  fprintf ppf
+          "@[Error42 : ハイライト部分の関数定義 ";
+  List.iter (fun v' -> fprintf ppf "%a " Pprintast.pattern v'.pvb_pat) vs;
+  fprintf ppf "@,\
+           に相互再帰があります。let の後に rec を書きましょう。@]@."
+
+let print_illtyped_let v vs =
+  fprintf ppf
+          "@[Error43 : ハイライト部分の関数定義 %a の中で、@,\
+           and で同時に定義された他の関数 "
+          Pprintast.pattern v.pvb_pat;
+  List.iter (fun v' -> fprintf ppf "%a " Pprintast.pattern v'.pvb_pat) vs;
+  fprintf ppf
+          "@,\
+           が1つ以上呼び出されています。in や ;; を使って各定義を独立させましょう。@]@."
+
+let print_illtyped_case exp =
+  fprintf ppf
+          "@[Error44 : ハイライト部分のパターン変数 %a が @,\
+           式中で異なる型として使われています。@]@." Pprintast.expression exp
+
+let print_label_mismatch env lid trace =
+  match language with
+| English -> report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "@[Error51 : The record field %a@ belongs to the type"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "but is mixed here with fields of type");
+             fprintf ppf "@]@."
+| Japanese -> report_unification_error ppf env trace
+        (function ppf ->
+           fprintf ppf "@[Error51 : フィールド %a@ が属する型は"
+                   longident lid)
+        (function ppf ->
+           fprintf ppf "ですが、それを含む全体のレコード型は");
+              fprintf ppf " です。@]@."
+
+let print_label_missing labels =
+  match language with
+| English ->
+   let print_labels ppf =
+     List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
+   fprintf ppf "@[<hov>Some record fields are undefined:%a@]"
+           print_labels labels
+| Japanese ->
+   let print_labels ppf =
+     List.iter (fun lbl -> fprintf ppf " %s" (Ident.name lbl)) in
+   fprintf ppf "@[Error52 : ハイライトされた部分で、レコードのフィールド%a が足りません。@]@." print_labels labels
+
+let print_illtyped_try_right typ1 typ2 =
+  begin match language with
+| English -> fprintf ppf
+    "@[Error53 : Somewhere in this try expression is wrong.@]@." (* 英語 *)
+| Japanese -> fprintf ppf
+    "@[Error53 : try する式が@ %a@ 型で矢印の右側が@ %a@ 型になっていますが、\
+     @,これらは同じ型でなくてはなりません。@]@."
+    Printtyp.type_expr typ1 Printtyp.type_expr typ2
+  end;
+  check_duplicate typ1 typ2
+
+let print_illtyped_try_left typ =
+  match language with
+| English -> fprintf ppf
+    "@[Error54 : Somewhere in this try expression is wrong.@]@." (* 英語 *)
+| Japanese -> fprintf ppf
+    "@[Error54 : try 文のパターンが @ %a@ 型になっていますが、\
+     @,これは例外でなくてはなりません。@]@."
+    Printtyp.type_expr typ
+
+let print_illtyped_try_env () =
+  match language with
+| English -> fprintf ppf
+    "@[Error55 : Some variables in this expression is used at different type@ \
+     at different place.@]@."
+| Japanese -> fprintf ppf
+    "@[Error55 : ハイライト部分の変数が\
+     別の場所で別の型として使われています。@]@."
+
+
+let print_wrong_name kind typ name =
+  match language with
+  | English ->
+     fprintf ppf
+	     "@[Error56 : The %s %s does not belong to type %a.@]@."
+	     (if kind = "record" then "field" else kind) name Printtyp.type_expr typ
+  | Japanese ->
+     fprintf ppf
+	     "@[Error56 : %s %s は %a の中で定義されていません。@]@."
+	     (if kind = "record" then "フィールド" else "コンストラクタ") name Printtyp.type_expr typ
+
+let print_unbound_name kind lid =
+
+  let var_name = Longident.last lid in (* 変数名 *)
+  let mod_names = (* モジュールの名前リスト *)
+    List.filter (fun v -> v <> var_name)
+                (List.rev (Longident.flatten lid)) in
+
+  fprintf ppf
+          "@[Error57 : %s という名前の%sは、%s定義されていません。@]@."
+          var_name
+          (if kind = "record"
+           then "フィールドを持つレコード"
+           else if kind = "module"
+           then "モジュール"
+           else "コンストラクタ")
+          (if mod_names = [] then ""
+           else "モジュール" ^ List.hd mod_names ^ "の中で")
+
+let print_duplicate_name kind name =
+  match language with
+  | English ->
+     fprintf ppf "@[Two constructors are named %s@]@." name
+  | Japanese ->
+     let kind' = (if kind = "record" then "フィールド" else "コンストラクタ") in
+     fprintf ppf "@[Error58 : %s %s が複数あります。@,\
+                  定義する%sの名前は、すべて異なる必要があります。@]@." kind' name kind'
diff --git a/typing/debug_slice.ml b/typing/debug_slice.ml
new file mode 100644
index 0000000..abd15e5
--- /dev/null
+++ b/typing/debug_slice.ml
@@ -0,0 +1,972 @@
+(* open Misc *)
+(* open Path *)
+open Asttypes
+open Ast_helper
+
+(* open Types *)
+open Typedtree
+(* open Ctype *)
+(* open Format *)
+
+open Parsetree
+open Debug_core
+
+type structure_cxt = (structure_item * Env.t) list -> structure -> structure
+
+(* go *)
+(* 'a context_t を引数に持つ関数を、最後に 'a 型で受け取る形にする。 *)
+(* かっこを減らせる, 'a 型の引数で再帰する関数に渡すときに便利。 *)
+let go f prefix env cxt x = f ((x, cxt), env, prefix)
+
+(* id : 'a -> 'a *)
+let id = fun x -> x
+
+(* ここから *)
+module type Go =
+  sig
+    type t
+    val go : unit -> t
+  end
+
+module type InitTop =
+  sig
+    type t = structure
+    val name : string
+    val context : ((structure_item * structure) * structure_cxt) context_t
+  end
+
+module type InitSlice =
+  sig
+    type t
+    (*    val f : t -> structure *)
+    val slice : t
+    val cxt : expr_context
+    val typed_set : ((t -> t) -> t -> structure) * Env.t (* item_cxt *)
+  end
+
+module type Init =
+  sig
+    type t
+    val env : Env.t
+  end
+
+module type Slicer =
+  sig
+    type t
+    val get : (t * (t -> t)) * ((t -> t) -> t -> structure) -> expr_context ->t
+  end
+
+module type MakeSlicer =
+sig
+  (* init を渡すと slice型 の Slicer が生成されるファンクタ *)
+  (* string でスライサの種類を指定する *)
+  type slice
+  module type Init = Init with type t = slice
+    module type Slicer = Slicer with type t = slice
+    module type Make = functor (I : Init) -> Slicer
+    val get : (module InitSlice with type t = slice) -> string -> slice
+  end
+
+module Generate = struct
+
+    (* context_t の生成 *)
+    let rec context' structure env prefix = match structure with
+        [] -> failwith "TypeDebugger: Error: structure is well typed."
+      | s :: rest ->
+         try
+           let (_, _, env') =
+             Typemod.type_structure env [s] Location.none in
+           context' rest env' ((s, env) :: prefix)
+         with _ ->
+           ((((s, []), fun _ x -> x), Empty), env, prefix)
+
+    (* init の生成 *)
+    let init (type s) env =
+      (module
+         struct
+           type t = s
+           let env = env
+         end : Init with type t = s)
+
+    let initTop name structure env =
+      (* Data.Infer.init name; *)
+      (module
+         struct
+           type t = structure
+           let name = name
+           let context = context' structure env []
+         end : InitTop)
+
+    let initSlice (type s) skeleton ((((f, slice), str_cxt), cxt), env, prefix) = 
+        let item_cxt' prefix str slice_cxt slice' =
+          str_cxt prefix (str @ f (slice_cxt slice')) in
+
+        (module
+           struct
+             type t = s
+             let f = f
+             let slice = slice
+             let cxt = cxt
+             let typed_set = match prefix with
+                 [] -> (item_cxt' prefix [], env)
+               | (s', env') :: prefix' ->
+                  try
+                    ignore (
+                        Typemod.type_structure env (f skeleton) Location.none);
+                    (* □に置き換えて welltyped: *)
+                    (item_cxt' prefix [], env)
+                  with _ ->
+                    (* □に置き換えて illtyped: *)
+                    (item_cxt' prefix' [s'], env')
+           end : InitSlice with type t = s)
+
+    (* スライスを求める *)
+    let slice (type s) slice item_cxt cxt (module S : Slicer with type t = s) =
+      S.get ((slice, id), item_cxt) cxt
+
+    (* Slicer モジュールを返す *)
+    let slicer (type s) name skeleton context
+               (module M : MakeSlicer with type slice = s) =
+      (module
+         struct
+           type t = s
+           let go () =
+             let slice =
+               M.get (initSlice skeleton context) name in             
+             slice
+         end : Go with type t = s)
+
+    let f (type s) (module F : Go with type t = s) = F.go ()
+
+  end
+
+module ExprSlicer :
+sig
+  open Parsetree
+  val search : string -> bool
+  val top : string ->
+    (((expression -> structure) * expression) *
+     ((structure_item * Env.t) list -> structure_item list -> structure))
+      context_t -> expression
+end = struct
+  
+  module Make =
+  struct
+    type slice = expression
+    module type Slicer = Slicer with type t = expression
+    module type Init = Init with type t = expression
+    module type Make = functor (I : Init) -> Slicer
+
+    let print = print_deb_exp
+    let term e = Size.Exp.reset 0 e
+    let hole e = term (hole_of_exp e)
+    let make_slicer (module M : Make) (module I : Init) = (module M (I) : Slicer)
+
+    module Slicer0 (I : Init) = struct
+      include I
+
+      let wrap_expr expr_cxt' expr_cxt expr =
+        expr_cxt' (expr_cxt expr)
+      let wrap_item item_cxt expr_cxt' expr_cxt expr =
+        item_cxt (wrap_expr expr_cxt' expr_cxt) expr
+
+      let dummy_apply expr es =
+        if List.exists (fun e -> e = hole e) es then []
+        else
+          [{expr with
+            pexp_desc =
+              Pexp_apply (hole expr, List.map (fun e -> (Nolabel, e)) es)}]
+
+      let abst sel e' e = match Desc.Exp.comp e' e with
+          1 -> if sel then e else hole e
+        | 0 -> e'
+        | _ -> if sel then hole e else e
+                                     
+      let make_expr expr e' =
+        Desc.Exp.map (abst false e') expr
+                         
+      let selected_expr expr expr_cxt' e' =
+        if Desc.Exp.comp e' expr < 0 then expr_cxt' e' else e'
+                                                                      
+      (* dummy apply *)
+      let getChildren'' expr = match expr.pexp_desc with
+        | Pexp_tuple es ->
+            dummy_apply expr es
+        | Pexp_array es ->
+            dummy_apply expr es
+        | Pexp_construct (_, Some {pexp_desc = Pexp_tuple es}) ->
+            dummy_apply expr es
+        | _ -> []
+  
+      (* □以外の子ノード全て *)
+      let getChildren' expr = match expr.pexp_desc with
+        | Pexp_construct (_, Some {pexp_desc = Pexp_tuple es}) ->
+            List.filter (fun e -> e <> hole e) es
+        | _ ->
+            Desc.Exp.fold (
+              fun acc e ->
+                if Size.Exp.comp e < 1 then e :: acc else acc
+            ) [] expr
+              
+      let getChildren expr = getChildren'' expr @ getChildren' expr
+            
+      let rec search (slices, expr_cxt, item_cxt, f) cxt = match slices with
+        | [] -> f ()
+        | first :: rest ->
+            if print_slice then
+              Format.fprintf ppf "@[  search: %a @]@."
+                print first;
+
+            if Data.typed env item_cxt expr_cxt first then
+              (* welltyped *)
+              search (rest, expr_cxt, item_cxt, f) cxt
+            else
+              (* illtyped *)
+              get ((expr_cxt first, id), item_cxt) cxt
+                
+      and get ((expr, expr_cxt), item_cxt) cxt =
+        
+        if print_slice then
+          Format.fprintf ppf "@[  get: %a @]@."
+            print expr;
+        
+        let children = getChildren expr in
+        
+        match expr.pexp_desc with
+        
+        | Pexp_construct (lid, Some ({pexp_desc = Pexp_tuple es} as expr')) ->
+            
+            (* Construct *)
+            let fold es' e' =
+              {expr with
+               pexp_desc =
+                 Pexp_construct (
+                   lid,
+                   Some {expr' with
+                         pexp_desc =
+                           Pexp_tuple (List.map (abst false e') es')})} in
+            let f () =
+              let slice =
+                let fold' es' e' = fold es' (term e') in
+                let es' =
+                  Desc.Exp.fold (
+                    fun es' e ->
+                      let slice =
+                        get' ((e, id), wrap_item item_cxt (fold' es')) cxt in
+                      List.map (
+                        fun e ->
+                          if Desc.Exp.comp slice e < 0 then e else slice) es'
+                  ) es expr' in
+                fold' es' Hole.exp in
+              wrap_expr expr_cxt term slice in
+            
+            (* search *)
+            search (
+              children,
+              wrap_expr expr_cxt (selected_expr expr (fold es)),
+              item_cxt, f) cxt
+              
+        | _ ->
+            
+            let f () =
+              let slice =
+                let item_cxt' = wrap_item item_cxt expr_cxt in
+                Desc.Exp.fold (
+                  fun expr' e ->
+                    let expr_cxt'' = make_expr expr' in
+                    let item_cxt'' = wrap_item item_cxt' expr_cxt'' in          
+                    get' ((e, id), item_cxt'') cxt |> expr_cxt''
+                ) expr expr in
+              wrap_expr expr_cxt term slice in
+            
+            (* search *)
+            search (
+              children,
+              wrap_expr expr_cxt (selected_expr expr (make_expr expr)),
+              item_cxt, f) cxt
+              
+      (* get' *)
+      and get' ((expr, expr_cxt), item_cxt) cxt =
+        if Desc.Exp.leaf expr then wrap_expr expr_cxt term expr
+        else get ((expr, expr_cxt), item_cxt) cxt
+
+    end
+
+
+
+    module SelectiveSlicer (S : sig val selector : bool end) (I : Init) = struct
+      include I
+
+      let rec search (child, sel, expr_cxt, slice_cxt) item_cxt cxt =
+
+        if print_slice then
+          Format.fprintf ppf "@[  search / abst %s: %a @]@."
+            (if sel then "expect" else "one")
+            print child;
+        
+        let sel' =
+          Data.typed env item_cxt (slice_cxt sel expr_cxt) child in
+        if sel' && sel then
+          (* welltyped : abst expect *)
+          search (child, false, expr_cxt, slice_cxt) item_cxt cxt
+            
+        else
+          let g pair = get (pair, item_cxt) cxt in
+          if sel' && Size.Exp.comp child = 0 then
+            (* welltyped : is1 *)
+            g (slice_cxt false expr_cxt (term child), id)
+              
+          else if sel' || sel then
+            (* welltyped : greater1 *)
+            (* illtyped : abst expect *)
+            g (child, slice_cxt sel expr_cxt)
+              
+          else
+            (* illtyped : abst one *)
+            g (slice_cxt sel id child , expr_cxt)
+              
+      and get ((expr, expr_cxt), item_cxt) cxt =
+
+        if print_slice then
+          Format.fprintf ppf "@[  get: %a @]@."
+            print expr;
+        
+        if Size.Exp.comp expr < 0 then
+          let (expr', slice_cxt) =
+            if S.selector then
+              Size.getChildSet expr
+            else
+              Size.getChildSet2 expr in
+          search (expr',
+                  slice_cxt true id expr' <> expr, expr_cxt,
+                  slice_cxt) item_cxt cxt
+        else
+          get' ((expr, expr_cxt), item_cxt) cxt
+
+      and get' ((expr, expr_cxt), item_cxt) cxt =
+        let slice = expr_cxt expr in
+        if Size.Exp.comp slice < 0 then
+          get ((slice, id), item_cxt) cxt
+        else
+          slice
+    end
+
+    module Slicer3 (I : Init) = struct
+      include I
+          
+      let rec resize expr =
+        if Desc.Exp.leaf expr then expr (* そのまま *)
+        else
+          let n_sum = ref 0 in
+          let expr' =
+            Desc.Exp.map (
+              fun e ->
+                let e' = resize e in
+                let n' = Size.Exp.get e' in
+                n_sum := !n_sum + n';
+                e'
+            ) expr in
+          if !n_sum = 0 then
+            (* expr も 0 になる *)
+            term expr'
+          else
+            Size.Exp.reset (!n_sum + 1) expr'
+              
+      let rec make_expr_cxt0 expr piv =
+        match (expr.pexp_desc, piv.pexp_desc) with
+        | (Pexp_apply (e, (_, e0) :: les0),
+           Pexp_apply (e1, les1)) when
+            e.pexp_desc = Hole.exp.pexp_desc
+            && e0.pexp_loc = piv.pexp_loc
+            && e1.pexp_desc = Hole.exp.pexp_desc->
+            
+            let attrs =
+              List.fold_left (
+                fun attrs' (str, payload) ->                            
+                  match (attrs', payload) with
+                    ((str', PStr structure) :: rest, PStr structure')
+                    when str.txt = "app" && str'.txt = "app" ->
+                      (* mergeする *)
+                      let payload = PStr (structure @ structure') in
+                      (str', payload) :: rest
+                  | _ ->
+                      attrs'
+              ) piv.pexp_attributes expr.pexp_attributes in
+            
+            {expr with pexp_desc = Pexp_apply (e, les0 @ les1);
+                       pexp_attributes = attrs}
+        | _ ->
+            if print_slice then
+              Format.fprintf ppf "@[  make0(expr): %a @]@."
+                print_deb_exp expr;
+
+            if piv.pexp_loc = expr.pexp_loc then
+              piv
+            else
+              Desc.Exp.map (
+                fun e ->
+                  if Desc.Exp.internal e piv then
+                    make_expr_cxt0 e piv
+                  else
+                    e
+              ) expr
+                
+      let rec make_expr_cxt1 piv expr =
+        if piv = expr then
+          hole piv
+        else if piv.pexp_loc = expr.pexp_loc then
+          piv
+        else
+          Desc.Exp.map (
+            fun e ->
+              if Desc.Exp.internal e piv then
+                make_expr_cxt1 piv e
+              else
+                e
+          ) expr
+            
+      let dummy_apply expr es =
+        {expr with
+         pexp_desc =
+           Pexp_apply
+             (hole expr, List.map (fun e -> (Nolabel, e)) es)}
+        
+      
+      let rec make_expr_cxt2 piv expr =
+        if piv.pexp_loc = expr.pexp_loc then
+          piv
+        else
+          match expr.pexp_desc with
+          | Pexp_construct (_, Some {pexp_desc = Pexp_tuple es}) ->
+              make_dummy_apply_cxt es piv expr
+          | Pexp_tuple es ->
+              make_dummy_apply_cxt es piv expr
+          | Pexp_array es ->
+              make_dummy_apply_cxt es piv expr
+          | Pexp_record (les, eop) ->
+              let es' = match eop with
+                  None ->
+                    List.map (
+                      fun (_, e) -> make_expr_cxt2' piv e
+                    ) les
+                | Some e' ->
+                    List.map
+                      (make_expr_cxt2' piv)
+                      (e' :: List.map snd les) in
+              dummy_apply expr es'
+          | Pexp_ifthenelse (e1, e2, eop) ->
+              let es = e1 :: e2 ::
+                       match eop with None -> [] | Some e' -> [e'] in
+              let es' = List.map (make_expr_cxt2' piv) es in
+              dummy_apply expr es'
+                
+          | Pexp_apply (e, les)
+            when 0 < Size.Exp.get e
+              && not (Desc.Exp.internal e piv) ->
+              let expr' =
+                make_skeleton_apply_cxt ([], (Nolabel, e) :: les) piv expr in
+              if print_slice then
+                Format.fprintf ppf "@[  skeleton apply: %a @]@."
+                  print_deb_exp expr';
+              
+              make_expr_cxt2' piv {expr' with pexp_loc = expr.pexp_loc}
+                
+          | Pexp_apply (e, (_, {pexp_loc;
+                                pexp_attributes;
+                                pexp_desc =
+                                  Pexp_apply (e', (l0, e0) :: les0)}) :: les1)
+            when
+              (* 入れ子になっているが、pivは関数適用ではない *)
+              Desc.Exp.internal {skeleton' with pexp_loc = pexp_loc} piv && pexp_loc <> piv.pexp_loc
+              (* hole あるいは抽象化される式 *)
+              && (e.pexp_desc = Hole.exp.pexp_desc
+                  || (0 < Size.Exp.get e
+                      && not (Desc.Exp.internal e piv)))
+              && (e'.pexp_desc = Hole.exp.pexp_desc
+                  || (0 < Size.Exp.get e'
+                      && not (Desc.Exp.internal e' piv))) ->
+              
+              let expr' =
+                let les =
+                  List.filter (
+                    fun (_, e_) ->
+                      (* 抽象化できない式 or 既に抽象化された式を除外 *)
+                      e_.pexp_desc <> Hole.exp.pexp_desc
+                      && 0 = Size.Exp.get e_
+                  ) (les0 @ les1) in
+                
+                let attrs =
+                  List.fold_left (
+                    fun attrs' (str, payload) ->                            
+                      match (attrs', payload) with
+                        ((str', PStr structure) :: rest, PStr structure')
+                        when str.txt = "app" && str'.txt = "app" ->
+                          (* mergeする *)
+                          let payload = PStr (structure @ structure') in
+                          (str', payload) :: rest
+                      | _ ->
+                          attrs'
+                  ) pexp_attributes expr.pexp_attributes in
+                Desc.Exp.map
+                  (make_expr_cxt2' piv)
+                  {expr
+                   with pexp_desc = Pexp_apply (Hole.exp, (l0, e0) :: les);
+                        pexp_attributes = attrs} in
+              
+              if print_slice then
+                Format.fprintf ppf "@[  nested apply: %a @]@."
+                  print_deb_exp expr';
+
+              make_expr_cxt2' piv expr'
+                
+          | _ ->
+              (* その他 *)
+              Desc.Exp.map (make_expr_cxt2' piv) expr
+                
+      and make_expr_cxt2' piv expr =
+        if Desc.Exp.internal expr piv then
+          (* 部分木の一部：再帰 *)
+          make_expr_cxt2 piv expr
+        else if Size.Exp.get expr = 0 then
+          (* 確定 *)
+          expr
+        else
+          (* 抽象化 *)
+          hole expr
+            
+      (* dummy apply の生成 *)
+      and make_dummy_apply_cxt es piv expr =
+        let expr' =
+          make_skeleton_apply_cxt
+            ([], List.map (fun e -> (Nolabel, e)) es) piv expr in
+        if print_slice then
+          Format.fprintf ppf "@[  dummy apply: %a @]@."
+            print_deb_exp expr';
+        make_expr_cxt2 piv expr'
+
+      and make_skeleton_apply_cxt (acc, les) piv expr = match les with
+        | [] ->
+            (* 元の関数適用 *)
+            let payload =
+              ({txt = "app"; loc = expr.pexp_loc},
+               PStr [Str.eval (Desc.Exp.map_all (
+                   fun e -> {e with pexp_attributes = []}
+                 ) expr)]) in
+            {expr with
+             pexp_desc =
+               Pexp_apply (hole expr, acc);
+             pexp_attributes =
+               payload :: expr.pexp_attributes}
+            
+        | (l, e) :: rest ->
+            let acc' =
+              let e' = make_expr_cxt2' piv e in
+              if e' = hole_of_exp e then
+                (* 抽象化される *)
+                acc
+              else
+                (* 抽象化されない *)
+                acc @ [(l, e')] in
+            make_skeleton_apply_cxt (acc', rest) piv expr
+              
+      let make_slice_cxt' slice expr = match slice.pexp_desc with
+          Pexp_construct (_, Some {pexp_desc = Pexp_tuple es})
+          when Desc.Exp.fold (
+              fun b e ->
+                if e <> slice && 0 = Size.Exp.get e then
+                  b
+                else if b then
+                  e = slice
+                else
+                  b
+            ) true expr ->
+            let slice' =
+              let es' =
+                List.filter (
+                  fun {pexp_desc} -> pexp_desc <> Hole.exp.pexp_desc
+                ) es in
+              dummy_apply slice es' in
+            
+            let expr' =
+              Desc.Exp.map (
+                fun e' ->
+                  if e' = slice then
+                    slice'
+                  else
+                    e'
+              ) expr in
+            
+            if print_slice then
+              Format.fprintf ppf "@[  skip expected : %a@]@."
+                print_deb_exp expr';
+            expr'
+        | _ ->
+            make_expr_cxt2 slice expr
+              
+      let make_slice_cxt expr sel f slice =
+        f (resize (
+            if sel then
+              make_expr_cxt1 slice expr
+            else
+              make_slice_cxt' slice expr))
+          
+      let rec search f (child, sel, expr_cxt, slice_cxt) item_cxt cxt =
+
+        let sel' =
+          (* 呼び出し時に時間を記録 *)
+          Data.typed env item_cxt (slice_cxt sel expr_cxt) child in
+        
+        if print_slice then
+          Format.fprintf ppf "@[  search / abst %s is %s @]@."
+            (if sel then "one" else "expect")
+            (if sel' then "welltyped" else "illtyped");
+
+        let expr' = slice_cxt sel expr_cxt child in
+        if sel' && sel && 0 = Size.Exp.get expr' then
+          f ()
+        else if sel' && sel then
+          search f (child, false, expr_cxt, slice_cxt) item_cxt cxt
+        else
+          let g pair = get (pair, item_cxt) cxt in
+          if sel then
+            (* illtyped : abst one *)
+            begin
+              if print_slice then
+                Format.fprintf ppf "@[illtyped one : %a@]@."
+                  print_deb_exp expr';
+              g (resize (slice_cxt sel id child), expr_cxt)
+            end
+          else if sel' = sel then
+            (* illtyped : abst expected *)
+            begin
+              if print_slice then
+                Format.fprintf ppf "@[illtyped expected : %a@]@."
+                  print_deb_exp expr';
+              g (child, make_expr_cxt0 expr')
+            end
+          else
+            f ()
+              
+      and pick m expr =
+        if Desc.Exp.leaf expr then
+          (* leaf の場合は、そのまま返す *)
+          expr
+        else
+          Desc.Exp.fold (
+            fun piv node ->
+              if Size.Exp.get node < 1 then
+                (* node が確定している *)
+                piv                        
+              else
+                let n' = Size.Exp.get piv in
+                let m1 = abs (m - Size.Exp.get node) and m2 = abs (m - n') in
+                match compare m1 m2 with
+                  1 -> piv (* piv の方が適切 *)
+                | 0 when
+                    Desc.Exp.fold (
+                      fun b e ->
+                        if b && e <> node then true
+                        else if b && e = hole_of_exp e then true
+                        else false (* node が piv の子ノード *)
+                    ) true piv ->
+                    piv
+                | _ ->
+                    match expr.pexp_desc with
+                    | Pexp_construct (_, Some ({pexp_desc = Pexp_tuple (e :: es)} as e0))
+                      when e0 = node ->
+                        let p = pick m e in
+                        List.fold_left (
+                          fun p' e' ->
+                            if Size.Exp.get p' = 0 then
+                              e'
+                            else if hole_of_exp e' = e' then
+                              p'
+                            else
+                              let p'' = pick m e' in
+                              if 0 < compare m1 (abs (m - Size.Exp.get p'')) then
+                                p''
+                              else
+                                p'
+                        ) p es
+                    | _ ->
+                        if print_slice then
+                          Format.fprintf ppf "@[pick (node) : %a@]@."
+                            print_deb_exp node;
+                        pick m node
+          ) expr expr
+            
+      and get ((expr, expr_cxt), item_cxt) cxt =
+        
+        if Size.Exp.get expr = 0 || Desc.Exp.leaf expr then
+          get' ((expr, expr_cxt), item_cxt) cxt
+        else
+          let piv =                  
+            let m = (1 + Size.Exp.get expr) / 2 in
+            pick m expr in
+          
+          let f () =
+            
+            let terminate () =
+              if print_slice then
+                Format.fprintf ppf "@[welltyped terminated : %a@]@."
+                  print_deb_exp piv;
+              resize (make_expr_cxt0 expr (term piv)) in
+            if Size.Exp.get piv = 1 then
+              (* piv is size 1 : terminated *)
+              get ((terminate (), expr_cxt), item_cxt) cxt
+            else
+              let child_cxt expr_cxt' expr' =
+                make_slice_cxt expr true expr_cxt (expr_cxt' expr') in
+              let item_cxt' expr_cxt' expr' =
+                item_cxt (child_cxt expr_cxt') expr' in
+              begin
+                if print_slice then
+                  Format.fprintf ppf "@[welltyped sub-slice : %a@]@."
+                    print_deb_exp piv;
+                let piv' =
+                  get ((piv, id), item_cxt') cxt in
+                get ((child_cxt id piv', expr_cxt), item_cxt) cxt
+              end in
+          
+          begin
+            if print_slice then
+              begin
+                Format.fprintf ppf "@[  get: %a @]@."
+                  print expr;
+                Format.fprintf ppf "@[  pivot: %a @]@."
+                  print piv;
+              end
+            else
+              Data.Infer.read expr.pexp_loc;
+            
+            search f (piv, true, expr_cxt, make_slice_cxt expr) item_cxt cxt
+          end
+          
+      and get' ((expr, expr_cxt), item_cxt) cxt =
+        let slice = resize (expr_cxt expr) in
+        if print_slice then
+          Format.fprintf ppf "@[  get': %a @]@."
+            print (expr_cxt expr);
+        
+        (* size が 0 になった時点で終了 *)
+        if Size.Exp.get slice = 0 then
+          slice
+        else
+          get ((slice, id), item_cxt) cxt
+            
+    end
+
+    (* list *)
+    (* スライサーリスト *)
+    let list : (string * (module Make)) list =
+      ["original", (module Slicer0);
+       "resize1", (module SelectiveSlicer (struct let selector = true end));
+       "resize2", (module SelectiveSlicer (struct let selector = false end));
+       "resize3", (module Slicer3)]
+      
+    (* search *)
+    (* スライサーを探す *)
+    let search name = List.exists (fun (name', _) -> name = name') list
+        
+    (* get_one *)
+    (* 1種類のスライサを起動 *)
+    let get_one (module S : InitSlice with type t = expression) (name, make) =
+      let open S in
+      if print_slice then
+        Format.fprintf ppf "@[[%s slicer] @]@." name;
+
+      (* スライスを求める *)
+      if not (Data.typed (snd typed_set) (fst typed_set) hole slice) then
+        hole slice (* expr が不要 *)
+      else if Desc.Exp.leaf slice then
+        term slice (* expr が必要かつ leaf *)
+      else
+        Generate.init (snd typed_set) (* その他 *)
+        |> make_slicer make
+        |> Generate.slice slice (fst typed_set) cxt
+
+    (* get_all *)
+    (* 全ての複数のスライサを起動 *)
+    let get_all init = List.map (get_one init) list
+        
+    (* get *)
+    (* 外部から呼び出される。スライスを求める関数。 *)
+    let get init name =
+      try
+        get_one init (name, List.assoc name list)
+      with
+        Not_found -> List.hd (get_all init)
+                       
+  end
+
+  let search = Make.search
+                 
+  (* top *)
+  (* 外部から呼び出される。スライサの入口 *)
+  let top name ((((expr_cxt, expr), structure_cxt), cxt), env, prefix) =
+    
+    (* 初期状態の生成 *)
+    let expr =
+      Data.init ((expr, cxt), env, prefix) in
+
+    Data.Infer.write [] expr false;
+    let time0 = Sys.time () in
+    let slice =
+      Generate.f (
+        Generate.slicer name Hole.exp
+          ((((expr_cxt, expr), structure_cxt), cxt), env, prefix)
+          (module Make : MakeSlicer with type slice = expression)) in
+    let time1 = Sys.time () in
+    Data.Infer.write [] slice true;
+
+    (* スライスの出力をしていない場合、データを記録する *)
+    if print_slice then
+      slice
+    else
+      Data.finally slice (time1 -. time0)
+end
+
+(* 共通部分 *)
+module Top (I : InitTop) =
+  struct
+    type t = structure
+
+    (* search *)
+    (* structure のスライスを1行ずつ求める。 *)
+    let rec search (str_cxt, prefix, slice_str) cxt = match prefix with
+        [] -> str_cxt [] slice_str
+      | (next_str, env) :: rest ->
+         go get rest env cxt ((next_str, slice_str), str_cxt)
+
+    (* get *)
+    (* 着目している行のスライスを求める。 *)
+    and get ((((item, slice_str), str_cxt), cxt), env, prefix) =
+      match item with
+        {pstr_desc = d; pstr_loc = loc} ->
+          (* item をスライシングして、slice_str を更新する。 *)
+          let slice_str' = match d with
+            | Pstr_eval (expr, _) ->
+                (* eval *)
+                (* expr;; *)
+                let eval_cxt e = (Str.eval ~loc e) :: slice_str in
+                go eval prefix env cxt
+                  (str_cxt, eval_cxt, expr)
+            | Pstr_value (flg, vs) when item <> hole_str ->
+                (* value *)
+                (* let (flg) P0=E0 and ... Pn=En *)
+                let value_cxt vs = (Str.value ~loc flg vs) :: slice_str in
+                go value prefix env cxt
+                  (str_cxt, value_cxt, go Desc.Vb.complete prefix env cxt vs)
+
+            | Pstr_module ({pmb_loc; pmb_name = name;
+                            pmb_expr = {pmod_loc;
+                                        pmod_attributes = [];
+                                        pmod_desc =
+                                          Pmod_structure (mod_str)}}) ->
+                (* module *)
+                (* module MODULENAME = struct ... end *)
+                let me_cxt str =
+                  Mod.structure
+                    ~loc:pmod_loc
+                    ~attrs:[mkloc "mod" loc, PStr mod_str;
+                            mknoloc "size", Size (List.length mod_str)] str in
+                let mb_cxt str =
+                  Mb.mk ~loc:pmb_loc name (me_cxt str) in
+                let mod_cxt str =
+                  (Str.module_ ~loc (mb_cxt str)) :: slice_str in
+                go module_
+                  [] env cxt
+                  (mod_str,
+                   fun prefix' structure' ->
+                     mod_cxt (
+                       List.fold_left (
+                         fun str (s', _) ->
+                           s' :: str) structure' prefix'))
+            | _ ->
+                (* その他は特に何もしない *)
+                item :: slice_str in
+          
+          (* search に移動 *)
+          search (str_cxt, prefix, slice_str') cxt
+
+    (* Eval : (structure_cxt * (expression -> structure) * expression) context_t
+     -> structure *)
+    (* eval のスライシング *)
+    and eval (((str_cxt, eval_cxt, expr), cxt), env, prefix) =
+      let slice =
+        go get' prefix env cxt ((eval_cxt, expr), str_cxt) in
+
+      if print_slice then
+        Format.fprintf ppf "@[get_slice_eval: %a @]@."
+                       print_deb_strs (eval_cxt slice);
+      eval_cxt slice
+
+    (* value *)
+    (* value のスライシング *)
+    and value (((str_cxt, value_cxt, vs), cxt), env, prefix) = match vs with
+        [] -> value_cxt []
+      | vn :: rest ->
+         (* vn のスライスを求める *)
+         let value_cxt' e vs' = value_cxt ((Map.set_exp Map.v1 vn e) :: vs') in
+         let vb_cxt e = value_cxt' e rest in
+         let slice =
+           go get' prefix env cxt ((vb_cxt, vn.pvb_expr), str_cxt) in
+         if print_slice then
+           Format.fprintf ppf "@[get_slice_value: %a @]@."
+                          Pprintast.structure (value_cxt' (Meta.clean "all" slice) []);
+         go value prefix env cxt (str_cxt, value_cxt' slice, rest)
+
+    (* module *)
+    (* (structure_cxt * (structure -> structure) * structure) context_t
+     -> structure *)
+    (* module のスライシング *)
+    and module_ (((structure, structure_cxt), cxt), env, prefix) =
+      match structure with
+        [] -> search (structure_cxt, prefix, []) cxt
+      | s :: rest ->
+         try
+           (* rest のみ無視したモジュールで型がつくかどうかチェックする *)
+           ignore (
+               Typemod.type_structure
+                 env [List.hd (structure_cxt prefix [s])] Location.none);
+           (* prefix に積んで再帰 *)
+           go module_ ((s, env) :: prefix) env cxt (rest, structure_cxt)
+         with _ ->
+           (* モジュールの中で型エラー *)
+           go get prefix env cxt ((s, []), structure_cxt)
+
+    (* get' *)
+    (* Expression_slicing に行く *)
+    (* ひとつ前の行の環境があれば使う。なければ現在の環境を使う。 *)
+    and get' context = ExprSlicer.top I.name context
+
+    (* ここから呼び出す *)
+    let go () =
+      let structure = get I.context in
+      if Debug_core.on_file_output then Data.Slice.Exp.outputs ();
+
+      if ExprSlicer.search I.name then
+        (* アルゴリズムの指定があればそのまま返す *)
+        structure
+      else
+        (* それ以外ではデバッガの起動は不要 *)
+        failwith "Slicer: debug mode"
+
+  end
+(* ここまで：デバッグ用のスライス書き込み *)
+
+(* スライスのトップ *)
+let get_slice_top structure env =
+  Warnings.parse_options false "-A";
+
+  let (module I : InitTop) =
+    (* アルゴリズムの種類を環境変数で指定 *)
+    try
+      let name = Sys.getenv "DEBUGGER_SELECTED_SLICER" in
+      Generate.initTop name structure env
+    with
+    (* なければデフォルトの設定 *)
+      Not_found -> Generate.initTop "resize3" structure env in
+
+  (* スライサの処理に進む *)
+  Generate.f (module Top (I) : Go with type t = structure)
diff --git a/typing/debug_slice.mli b/typing/debug_slice.mli
new file mode 100644
index 0000000..a2ccfd9
--- /dev/null
+++ b/typing/debug_slice.mli
@@ -0,0 +1,3 @@
+open Parsetree
+
+val get_slice_top : structure -> Env.t -> structure
