diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/byterun/sys.c seminalOcaml/byterun/sys.c
*** ocaml-3.08.4/byterun/sys.c 2004-05-18 01:50:22.000000000 -0700
--- seminalOcaml/byterun/sys.c 2009-01-19 09:36:42.121334405 -0800
***************
*** 245,250 ****
--- 245,260 ----
CAMLprim value caml_sys_time(value unit)
{
+ /* ADDED BSL 12/05/2005 to support higher resolution clocks */
+ #ifdef HAS_GETTIMEOFDAY
+ struct timeval tp;
+ if (gettimeofday(&tp, NULL) == -1) {
+ return caml_copy_double((double)clock() / CLOCKS_PER_SEC);
+ }
+ return caml_copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6);
+ #endif
+ /* END ADDED BSL */
+
#ifdef HAS_TIMES
#ifndef CLK_TCK
#ifdef HZ
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/camlp4/config/Makefile seminalOcaml/camlp4/config/Makefile
*** ocaml-3.08.4/camlp4/config/Makefile 1969-12-31 16:00:00.000000000 -0800
--- seminalOcaml/camlp4/config/Makefile 2009-01-19 09:36:58.121036308 -0800
***************
*** 0 ****
--- 1,60 ----
+ # $Id: Makefile.tpl,v 1.1.1.1 2005/12/09 03:02:40 blerner Exp $
+
+ # Change the value of PROFILING to prof for systematically building
+ # and installing profiled versions of Camlp4 libraries. Then, execute
+ # `make opt.opt', then `make install' in the OCaml toplevel directory
+ # (or in the camlp4 subdirectory).
+
+ # Default value is noprof
+
+ #PROFILING=prof
+ PROFILING=noprof
+
+ ###########################################################################
+
+ CAMLP4_COMM=OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/camlp4_comm.sh
+ OCAMLC=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlc.sh
+ OCAMLOPT=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlopt.sh
+ OCAMLCFLAGS=
+ MKDIR=mkdir -p
+
+ TEST_DIRECTORY=test `basename "$<"` = "$<" || { echo "You are not in the right directory"; exit 1; }
+
+ .SUFFIXES: .cmx .cmo .cmi .ml .mli .p.cmx
+
+ .mli.cmi:
+ @$(TEST_DIRECTORY)
+ @$(CAMLP4_COMM) $< -o $*.ppi
+ $(OCAMLC) $(OCAMLCFLAGS) -c -intf $*.ppi
+ rm -f $*.ppi
+
+ .ml.cmo:
+ @$(TEST_DIRECTORY)
+ @$(CAMLP4_COMM) $< -o $*.ppo
+ $(OCAMLC) $(OCAMLCFLAGS) -c -impl $*.ppo
+ rm -f $*.ppo
+
+ .ml.cmx:
+ @$(TEST_DIRECTORY)
+ @$(CAMLP4_COMM) $< -o $*.ppo
+ $(OCAMLOPT) $(OCAMLCFLAGS) -c -impl $*.ppo
+ rm -f $*.ppo
+
+ .ml.p.cmx:
+ @$(TEST_DIRECTORY)
+ @$(CAMLP4_COMM) $< -o $*.ppo
+ $(OCAMLOPT) $(OCAMLCFLAGS) -c -p -o $*.p.cmx -impl $*.ppo
+ rm -f $*.ppo
+
+ EXE=
+ O=o
+ A=a
+ OPT=
+ OTOP=../..
+ RANLIB=ranlib
+ RANLIBCMD=ranlib
+ OLIBDIR=$(OTOP)/boot
+ PREFIX=/projects/swlab8/blerner/projects/seminal/seminalOcaml
+ BINDIR=/projects/swlab8/blerner/projects/seminal/seminalOcaml/bin
+ LIBDIR=/projects/swlab8/blerner/projects/seminal/seminalOcaml/lib/ocaml
+ MANDIR=/projects/swlab8/blerner/projects/seminal/seminalOcaml/man
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/camlp4/config/Makefile.cnf seminalOcaml/camlp4/config/Makefile.cnf
*** ocaml-3.08.4/camlp4/config/Makefile.cnf 1969-12-31 16:00:00.000000000 -0800
--- seminalOcaml/camlp4/config/Makefile.cnf 2009-01-19 09:36:58.081037182 -0800
***************
*** 0 ****
--- 1,12 ----
+ EXE=
+ O=o
+ A=a
+ OPT=
+ OTOP=../..
+ RANLIB=ranlib
+ RANLIBCMD=ranlib
+ OLIBDIR=$(OTOP)/boot
+ PREFIX=/projects/swlab8/blerner/projects/seminal/seminalOcaml
+ BINDIR=/projects/swlab8/blerner/projects/seminal/seminalOcaml/bin
+ LIBDIR=/projects/swlab8/blerner/projects/seminal/seminalOcaml/lib/ocaml
+ MANDIR=/projects/swlab8/blerner/projects/seminal/seminalOcaml/man
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/config/Makefile seminalOcaml/config/Makefile
*** ocaml-3.08.4/config/Makefile 1969-12-31 16:00:00.000000000 -0800
--- seminalOcaml/config/Makefile 2009-01-19 09:37:42.980206989 -0800
***************
*** 0 ****
--- 1,50 ----
+ # generated by ./configure --prefix /projects/swlab8/blerner/projects/seminal/seminalOcaml
+ PREFIX=/projects/swlab8/blerner/projects/seminal/seminalOcaml
+ BINDIR=$(PREFIX)/bin
+ LIBDIR=$(PREFIX)/lib/ocaml
+ STUBLIBDIR=$(LIBDIR)/stublibs
+ MANDIR=$(PREFIX)/man
+ MANEXT=1
+ RANLIB=ranlib
+ RANLIBCMD=ranlib
+ SHARPBANGSCRIPTS=true
+ BNG_ARCH=ia32
+ BNG_ASM_LEVEL=2
+ PTHREAD_LINK=-lpthread
+ X11_INCLUDES=
+ X11_LINK=-lX11
+ DBM_INCLUDES=-I/usr/include/gdbm
+ DBM_LINK=-lgdbm
+ TK_DEFS= $(X11_INCLUDES)
+ TK_LINK= -ltk8.4 -ltcl8.4 -ldl $(X11_LINK)
+ BYTECC=gcc
+ BYTECCCOMPOPTS=-fno-defer-pop -Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+ BYTECCLINKOPTS= -Wl,-E
+ BYTECCLIBS= -lm -ldl -lcurses -lpthread
+ BYTECCRPATH=-Wl,-rpath,
+ EXE=
+ SUPPORTS_SHARED_LIBRARIES=true
+ SHAREDCCCOMPOPTS=-fPIC
+ MKSHAREDLIB=gcc -shared -o
+ MKSHAREDLIBRPATH=-Wl,-rpath,
+ ARCH=i386
+ MODEL=default
+ SYSTEM=linux_elf
+ NATIVECC=gcc
+ NATIVECCCOMPOPTS=-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+ NATIVECCPROFOPTS=-Wall -D_FILE_OFFSET_BITS=64 -D_REENTRANT
+ NATIVECCLINKOPTS=
+ NATIVECCRPATH=-Wl,-rpath,
+ NATIVECCLIBS= -lm -ldl
+ ASFLAGS=
+ ASPP=gcc
+ ASPPFLAGS=-c -DSYS_$(SYSTEM)
+ ASPPPROFFLAGS=-DPROFILING
+ PROFILING=prof
+ BINUTILS_OBJCOPY=/usr/bin/objcopy
+ BINUTILS_INSTALL_OBJCOPY=:
+ BINUTILS_NM=/usr/bin/nm
+ DYNLINKOPTS= -ldl
+ OTHERLIBRARIES=unix str num dynlink bigarray systhreads threads graph dbm labltk
+ DEBUGGER=ocamldebugger
+ CC_PROFILE=-pg
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/config/Makefile.msvc seminalOcaml/config/Makefile.msvc
*** ocaml-3.08.4/config/Makefile.msvc 2005-02-02 07:39:40.000000000 -0800
--- seminalOcaml/config/Makefile.msvc 2009-01-19 09:37:42.720212263 -0800
***************
*** 11,23 ****
# #
#########################################################################
! # $Id: Makefile.msvc,v 1.12.4.2 2005/02/02 15:39:40 xleroy Exp $
# Configuration for Windows, Visual C++ compiler
######### General configuration
! PREFIX=C:/ocamlms
### Where to install the binaries.
BINDIR=$(PREFIX)/bin
--- 11,23 ----
# #
#########################################################################
! # $Id: Makefile.msvc,v 1.2 2006/02/06 18:38:40 blerner Exp $
# Configuration for Windows, Visual C++ compiler
######### General configuration
! PREFIX=C:/docume~1/blerner/desktop/ocamlms
### Where to install the binaries.
BINDIR=$(PREFIX)/bin
***************
*** 45,51 ****
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
! BYTECC=cl /nologo
### Additional compile-time options for $(BYTECC). (For static linking.)
BYTECCCOMPOPTS=/Ox /MT
--- 45,52 ----
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
! VCDIR=/cygdrive/c/Program\ Files/Microsoft\ Visual\ Studio\ .NET\ 2003/Vc7/bin
! BYTECC=$(VCDIR)/cl /nologo
### Additional compile-time options for $(BYTECC). (For static linking.)
BYTECCCOMPOPTS=/Ox /MT
***************
*** 61,73 ****
NATIVECCLIBS=advapi32.lib
### How to invoke the C preprocessor
! CPP=cl /nologo /EP
### How to build a DLL
! MKDLL=link /nologo /dll /out:$(1) /implib:$(2) $(3)
### How to build a static library
! MKLIB=link /lib /nologo /debugtype:CV /out:$(1) $(2)
### Canonicalize the name of a system library
SYSLIB=$(1).lib
--- 62,74 ----
NATIVECCLIBS=advapi32.lib
### How to invoke the C preprocessor
! CPP=$(VCDIR)/cl /nologo /EP
### How to build a DLL
! MKDLL=$(VCDIR)/link /nologo /dll /out:$(1) /implib:$(2) $(3)
### How to build a static library
! MKLIB=$(VCDIR)/link /lib /nologo /debug /out:$(1) $(2)
### Canonicalize the name of a system library
SYSLIB=$(1).lib
***************
*** 96,102 ****
NATIVECCLINKOPTS=/MT
### Build partially-linked object file
! PARTIALLD=lib /nologo /debugtype:cv
PACKLD=ld -r --oformat pe-i386
### nm and objcopy are missing
--- 97,103 ----
NATIVECCLINKOPTS=/MT
### Build partially-linked object file
! PARTIALLD=lib /nologo /debug
PACKLD=ld -r --oformat pe-i386
### nm and objcopy are missing
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/config/m.h seminalOcaml/config/m.h
*** ocaml-3.08.4/config/m.h 1969-12-31 16:00:00.000000000 -0800
--- seminalOcaml/config/m.h 2009-01-19 09:37:42.820210266 -0800
***************
*** 0 ****
--- 1,11 ----
+ #undef ARCH_SIXTYFOUR
+ #define SIZEOF_INT 4
+ #define SIZEOF_LONG 4
+ #define SIZEOF_SHORT 2
+ #define ARCH_INT64_TYPE long long
+ #define ARCH_UINT64_TYPE unsigned long long
+ #define ARCH_INT64_PRINTF_FORMAT "ll"
+ #undef ARCH_BIG_ENDIAN
+ #undef ARCH_ALIGN_DOUBLE
+ #undef ARCH_ALIGN_INT64
+ #undef NONSTANDARD_DIV_MOD
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/config/s.h seminalOcaml/config/s.h
*** ocaml-3.08.4/config/s.h 1969-12-31 16:00:00.000000000 -0800
--- seminalOcaml/config/s.h 2009-01-19 09:37:42.888208829 -0800
***************
*** 0 ****
--- 1,45 ----
+ #define OCAML_OS_TYPE "Unix"
+ #define OCAML_STDLIB_DIR "/projects/swlab8/blerner/projects/seminal/seminalOcaml/lib/ocaml"
+ #define POSIX_SIGNALS
+ #define HAS_TIMES
+ #define HAS_TERMCAP
+ #define HAS_SOCKETS
+ #define HAS_SOCKLEN_T
+ #define HAS_INET_ATON
+ #define HAS_IPV6
+ #define HAS_UNISTD
+ #define HAS_OFF_T
+ #define HAS_DIRENT
+ #define HAS_REWINDDIR
+ #define HAS_LOCKF
+ #define HAS_MKFIFO
+ #define HAS_GETCWD
+ #define HAS_GETWD
+ #define HAS_GETPRIORITY
+ #define HAS_UTIME
+ #define HAS_UTIMES
+ #define HAS_DUP2
+ #define HAS_FCHMOD
+ #define HAS_TRUNCATE
+ #define HAS_SYS_SELECT_H
+ #define HAS_SELECT
+ #define HAS_SYMLINK
+ #define HAS_WAITPID
+ #define HAS_WAIT4
+ #define HAS_GETGROUPS
+ #define HAS_TERMIOS
+ #define HAS_ASYNC_IO
+ #define HAS_SETITIMER
+ #define HAS_GETHOSTNAME
+ #define HAS_UNAME
+ #define HAS_GETTIMEOFDAY
+ #define HAS_MKTIME
+ #define HAS_SETSID
+ #define HAS_PUTENV
+ #define HAS_LOCALE
+ #define SUPPORT_DYNAMIC_LINKING
+ #define HAS_MMAP
+ #define HAS_GETHOSTBYNAME_R 6
+ #define HAS_GETHOSTBYADDR_R 8
+ #define HAS_STACK_OVERFLOW_DETECTION
+ #define HAS_SIGWAIT
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/.depend seminalOcaml/.depend
*** ocaml-3.08.4/.depend 2005-02-22 06:33:34.000000000 -0800
--- seminalOcaml/.depend 2009-01-19 09:42:21.592965358 -0800
***************
*** 23,28 ****
--- 23,29 ----
parsing/parsetree.cmi: parsing/longident.cmi parsing/location.cmi \
parsing/asttypes.cmi
parsing/printast.cmi: parsing/parsetree.cmi
+ parsing/printcode.cmi: parsing/parsetree.cmi
parsing/syntaxerr.cmi: parsing/location.cmi
parsing/lexer.cmo: utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
parsing/location.cmi parsing/lexer.cmi
***************
*** 50,55 ****
--- 51,60 ----
parsing/location.cmi parsing/asttypes.cmi parsing/printast.cmi
parsing/printast.cmx: parsing/parsetree.cmi parsing/longident.cmx \
parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi
+ parsing/printcode.cmo: parsing/parsetree.cmi parsing/longident.cmi \
+ parsing/location.cmi parsing/asttypes.cmi parsing/printcode.cmi
+ parsing/printcode.cmx: parsing/parsetree.cmi parsing/longident.cmx \
+ parsing/location.cmx parsing/asttypes.cmi parsing/printcode.cmi
parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi
parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi
typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
***************
*** 430,437 ****
asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \
parsing/asttypes.cmi
asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi
- asmcomp/cmm.cmi: typing/ident.cmi
asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi
asmcomp/codegen.cmi: asmcomp/cmm.cmi
asmcomp/comballoc.cmi: asmcomp/mach.cmi
asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/clambda.cmi
--- 435,442 ----
asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \
parsing/asttypes.cmi
asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi
asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi
+ asmcomp/cmm.cmi: typing/ident.cmi
asmcomp/codegen.cmi: asmcomp/cmm.cmi
asmcomp/comballoc.cmi: asmcomp/mach.cmi
asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/clambda.cmi
***************
*** 445,452 ****
asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reg.cmi: asmcomp/cmm.cmi
- asmcomp/reload.cmi: asmcomp/mach.cmi
asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi: asmcomp/linearize.cmi
asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
--- 450,457 ----
asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
asmcomp/reg.cmi: asmcomp/cmm.cmi
asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
+ asmcomp/reload.cmi: asmcomp/mach.cmi
asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi
asmcomp/scheduling.cmi: asmcomp/linearize.cmi
asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
***************
*** 510,517 ****
utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/compilenv.cmx \
utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
asmcomp/closure.cmi
- asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
- asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmo \
--- 515,520 ----
***************
*** 522,527 ****
--- 525,532 ----
utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \
asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
asmcomp/cmmgen.cmi
+ asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
+ asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \
***************
*** 542,557 ****
utils/config.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \
utils/config.cmx asmcomp/clambda.cmx asmcomp/compilenv.cmi
asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \
asmcomp/emitaux.cmi utils/config.cmi asmcomp/compilenv.cmi \
! asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/emit.cmi
asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \
asmcomp/emitaux.cmx utils/config.cmx asmcomp/compilenv.cmx \
! asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/emit.cmi
! asmcomp/emitaux.cmo: asmcomp/emitaux.cmi
! asmcomp/emitaux.cmx: asmcomp/emitaux.cmi
asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/interf.cmi
asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
--- 547,562 ----
utils/config.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \
utils/config.cmx asmcomp/clambda.cmx asmcomp/compilenv.cmi
+ asmcomp/emitaux.cmo: asmcomp/emitaux.cmi
+ asmcomp/emitaux.cmx: asmcomp/emitaux.cmi
asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \
asmcomp/emitaux.cmi utils/config.cmi asmcomp/compilenv.cmi \
! asmcomp/cmm.cmi utils/clflags.cmo asmcomp/arch.cmo asmcomp/emit.cmi
asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \
asmcomp/emitaux.cmx utils/config.cmx asmcomp/compilenv.cmx \
! asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/interf.cmi
asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
***************
*** 586,617 ****
asmcomp/arch.cmx asmcomp/proc.cmi
asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
- asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi
- asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi
asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/schedgen.cmi
! asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.cmi \
! asmcomp/arch.cmo asmcomp/scheduling.cmi
! asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/mach.cmx \
! asmcomp/arch.cmx asmcomp/scheduling.cmi
asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/cmm.cmi \
asmcomp/arch.cmo asmcomp/selectgen.cmi
asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/cmm.cmx \
asmcomp/arch.cmx asmcomp/selectgen.cmi
! asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \
! asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi
! asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \
! asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selection.cmi
asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
--- 591,624 ----
asmcomp/arch.cmx asmcomp/proc.cmi
asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/reloadgen.cmi
+ asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+ asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi
+ asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
+ asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
asmcomp/schedgen.cmi
asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/schedgen.cmi
! asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi
! asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi
asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/cmm.cmi \
asmcomp/arch.cmo asmcomp/selectgen.cmi
asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/cmm.cmx \
asmcomp/arch.cmx asmcomp/selectgen.cmi
! asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
! utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
! asmcomp/selection.cmi
! asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
! utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
! asmcomp/selection.cmi
asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
***************
*** 622,653 ****
asmcomp/split.cmi
driver/compile.cmi: typing/env.cmi
driver/optcompile.cmi: typing/env.cmi
driver/compile.cmo: utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi bytecomp/translmod.cmi bytecomp/simplif.cmi \
! typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \
! parsing/printast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \
! typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \
! utils/clflags.cmo utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi
driver/compile.cmx: utils/warnings.cmx typing/typemod.cmx \
typing/typedtree.cmx bytecomp/translmod.cmx bytecomp/simplif.cmx \
! typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \
! parsing/printast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \
! typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \
! utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi
driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \
typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
! parsing/syntaxerr.cmi bytecomp/symtable.cmi driver/pparse.cmi \
! parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \
! typing/env.cmi typing/ctype.cmi bytecomp/bytepackager.cmi \
! bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/errors.cmi
driver/errors.cmx: utils/warnings.cmx typing/typetexp.cmx typing/typemod.cmx \
typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \
bytecomp/translmod.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
! parsing/syntaxerr.cmx bytecomp/symtable.cmx driver/pparse.cmx \
! parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
! typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \
! bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi
driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmo \
bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
--- 629,668 ----
asmcomp/split.cmi
driver/compile.cmi: typing/env.cmi
driver/optcompile.cmi: typing/env.cmi
+ driver/seminal.cmi: typing/typedtree.cmi parsing/parsetree.cmi utils/misc.cmi \
+ parsing/location.cmi utils/config.cmi
driver/compile.cmo: utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi bytecomp/translmod.cmi bytecomp/simplif.cmi \
! driver/seminal.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
! bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \
! parsing/parse.cmi utils/misc.cmi typing/ident.cmi driver/errors.cmi \
! typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmo \
! utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi
driver/compile.cmx: utils/warnings.cmx typing/typemod.cmx \
typing/typedtree.cmx bytecomp/translmod.cmx bytecomp/simplif.cmx \
! driver/seminal.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
! bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \
! parsing/parse.cmx utils/misc.cmx typing/ident.cmx driver/errors.cmx \
! typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \
! utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi
driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \
typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
! parsing/syntaxerr.cmi bytecomp/symtable.cmi driver/seminal.cmi \
! driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \
! typing/includemod.cmi typing/env.cmi typing/ctype.cmi \
! bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
! bytecomp/bytelibrarian.cmi driver/errors.cmi
driver/errors.cmx: utils/warnings.cmx typing/typetexp.cmx typing/typemod.cmx \
typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \
bytecomp/translmod.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
! parsing/syntaxerr.cmx bytecomp/symtable.cmx driver/seminal.cmx \
! driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \
! typing/includemod.cmx typing/env.cmx typing/ctype.cmx \
! bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
! bytecomp/bytelibrarian.cmx driver/errors.cmi
! driver/main_args.cmo: driver/main_args.cmi
! driver/main_args.cmx: driver/main_args.cmi
driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmo \
bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
***************
*** 656,663 ****
driver/errors.cmx utils/config.cmx driver/compile.cmx utils/clflags.cmx \
bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
bytecomp/bytelibrarian.cmx driver/main.cmi
- driver/main_args.cmo: driver/main_args.cmi
- driver/main_args.cmx: driver/main_args.cmi
driver/optcompile.cmo: utils/warnings.cmi typing/typemod.cmi \
typing/typedtree.cmi bytecomp/translmod.cmi bytecomp/simplif.cmi \
typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \
--- 671,676 ----
***************
*** 700,705 ****
--- 713,728 ----
utils/ccomp.cmi driver/pparse.cmi
driver/pparse.cmx: utils/misc.cmx parsing/location.cmx utils/clflags.cmx \
utils/ccomp.cmx driver/pparse.cmi
+ driver/seminal.cmo: typing/typetexp.cmi typing/typemod.cmi \
+ typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
+ parsing/printcode.cmi parsing/parsetree.cmi utils/misc.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \
+ utils/config.cmi parsing/asttypes.cmi driver/seminal.cmi
+ driver/seminal.cmx: typing/typetexp.cmx typing/typemod.cmx \
+ typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \
+ parsing/printcode.cmx parsing/parsetree.cmi utils/misc.cmx \
+ parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \
+ utils/config.cmx parsing/asttypes.cmi driver/seminal.cmi
toplevel/genprintval.cmi: typing/types.cmi typing/path.cmi \
typing/outcometree.cmi typing/env.cmi
toplevel/topdirs.cmi: parsing/longident.cmi
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/compile.ml seminalOcaml/driver/compile.ml
*** ocaml-3.08.4/driver/compile.ml 2004-06-13 05:46:41.000000000 -0700
--- seminalOcaml/driver/compile.ml 2009-01-19 09:37:59.283902623 -0800
***************
*** 18,23 ****
--- 18,24 ----
open Config
open Format
open Typedtree
+ open Seminal
(* Initialize the search path.
The current directory is always searched first,
***************
*** 59,64 ****
--- 60,66 ----
let ast =
Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ if !Clflags.dump_printcode then fprintf ppf "%a@." Printcode.interface ast;
let sg = Typemod.transl_signature (initial_env()) ast in
if !Clflags.print_types then
fprintf std_formatter "%a@." Printtyp.signature
***************
*** 77,105 ****
if !flag then fprintf ppf "%a@." printer arg;
arg
! let (++) x f = f x
! let implementation ppf sourcefile outputprefix =
init_path();
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
let inputfile = Pparse.preprocess sourcefile in
let env = initial_env() in
! if !Clflags.print_types then begin
try ignore(
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
++ Typemod.type_implementation sourcefile outputprefix modulename env)
with x ->
Pparse.remove_preprocessed_if_ast inputfile;
raise x
! end else begin
let objfile = outputprefix ^ ".cmo" in
let oc = open_out_bin objfile in
try
! Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
! ++ print_if ppf Clflags.dump_parsetree Printast.implementation
! ++ Typemod.type_implementation sourcefile outputprefix modulename env
++ Translmod.transl_implementation modulename
++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
++ Simplif.simplify_lambda
--- 79,207 ----
if !flag then fprintf ppf "%a@." printer arg;
arg
! let printSeminalErrors_if shouldPrint (ret, ex) =
! if shouldPrint then (match ex with
! Seminal.FixedErrors(exs) ->
! if exs <> [] then Errors.report_error Format.err_formatter ex
! | _ -> ());
! ret
!
!
! (*
! let createFeedback inputfile =
! let init_rand () =
! let initDone = ref false in
! if !initDone then () else (Random.self_init(); initDone := true) in
!
! let copyFile ifile ofile =
! let ic = open_in ifile in
! let oc = open_out ofile in
!
! let sanitize charStream =
! try
! let curDepth = ref 0 in
! let junk n = for i = 1 to n do Stream.junk charStream done in
! while true do
! let nextChar = Stream.next charStream in
! begin
! match (nextChar :: (Stream.npeek 5 charStream)) with
! ['('; '*'; '\r'; '\n'; '*'; ')'] -> if (!curDepth = 0) then (output_string oc "(*\r\n*)") else (output_string oc "##\r\n##"); junk 5
! | ['('; '*'; '\n'; '\r'; '*'; ')'] -> if (!curDepth = 0) then (output_string oc "(*\n\r*)") else (output_string oc "##\n\r##"); junk 5
! | _ -> match (nextChar :: (Stream.npeek 4 charStream)) with
! ['('; '*'; '\n'; '*'; ')'] -> if (!curDepth = 0) then (output_string oc "(*\n*)") else (output_string oc "##\n##"); junk 4
! | ['('; '*'; '\r'; '*'; ')'] -> if (!curDepth = 0) then (output_string oc "(*\r*)") else (output_string oc "##\r##"); junk 4
! | ['('; '*'; '\t'; '*'; ')'] -> if (!curDepth = 0) then (output_string oc "(*\t*)") else (output_string oc "#####"); junk 4
! | ['('; '*'; ' '; '*'; ')'] -> if (!curDepth = 0) then (output_string oc "(* *)") else (output_string oc "#####"); junk 4
! | _ -> match (nextChar :: (Stream.npeek 3 charStream)) with
! ['('; '*'; '\n'; '\r'] -> (if (!curDepth = 0) then (output_string oc "(*\n\r") else (output_string oc "##\n\r")); junk 3; incr curDepth
! | ['('; '*'; '\r'; '\n'] -> (if (!curDepth = 0) then (output_string oc "(*\r\n") else (output_string oc "##\r\n")); junk 3; incr curDepth
! | ['\n'; '\r'; '*'; ')'] -> (if (!curDepth = 1) then (output_string oc "\n\r*)") else (output_string oc "\n\r##")); junk 3; decr curDepth
! | ['\r'; '\n'; '*'; ')'] -> (if (!curDepth = 1) then (output_string oc "\r\n*)") else (output_string oc "\r\n##")); junk 3; decr curDepth
! | _ -> match (nextChar :: (Stream.npeek 2 charStream)) with
! | ['('; '*'; '\r'] -> (if (!curDepth = 0) then (output_string oc "(*\r") else (output_string oc "##\r")); junk 2; incr curDepth
! | ['('; '*'; '\n'] -> (if (!curDepth = 0) then (output_string oc "(*\n") else (output_string oc "##\n")); junk 2; incr curDepth
! | ['('; '*'; '\t'] -> (if (!curDepth = 0) then (output_string oc "(*\t") else (output_string oc "###")); junk 2; incr curDepth
! | ['('; '*'; ' '] -> (if (!curDepth = 0) then (output_string oc "(* ") else (output_string oc "###")); junk 2; incr curDepth
! | ['\r'; '*'; ')'] -> (if (!curDepth = 1) then (output_string oc "\r*)") else (output_string oc "\r##")); junk 2; decr curDepth
! | ['\n'; '*'; ')'] -> (if (!curDepth = 1) then (output_string oc "\n*)") else (output_string oc "\n##")); junk 2; decr curDepth
! | ['\t'; '*'; ')'] -> (if (!curDepth = 1) then (output_string oc "\t*)") else (output_string oc "###")); junk 2; decr curDepth
! | [' '; '*'; ')'] -> (if (!curDepth = 1) then (output_string oc " *)") else (output_string oc "###")); junk 2; decr curDepth
! | _ -> match nextChar with
! '\n'
! | '\r' -> output_char oc nextChar
! | _ -> if (!curDepth = 0) then output_char oc nextChar else output_char oc '#'
! end
! done
! with Stream.Failure -> () in
!
! sanitize (Stream.of_channel ic);
! close_in ic; close_out oc in
!
! init_rand();
! let os = Sys.os_type in
! let safeGetEnv envStr =
! try
! (Sys.getenv envStr)
! with Not_found -> envStr ^ "NOTFOUND" in
! let semDir = safeGetEnv "SEMINAL_DIR" in
! let uname = if (os = "Win32") then (safeGetEnv "USERNAME") else (safeGetEnv "USER") in
! let hashUname = Digest.to_hex(Digest.string (uname ^ string_of_int(Random.bits()))) in
! let destFile = Filename.concat semDir (hashUname ^ ".seminal.ml") in
! if (semDir = "SEMINAL_DIRNOTFOUND")
! then (print_string "Not generating Seminal feedback file\n")
! else (try
! copyFile inputfile destFile
! with Not_found -> print_string ("Could not generate backup file on " ^ os ^ "\n"))
! *)
!
!
!
! let rec implementation ppf sourcefile outputprefix =
init_path();
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
let inputfile = Pparse.preprocess sourcefile in
let env = initial_env() in
! let (++) x f = f x in
! if !Clflags.print_types then begin (* this branch just dumps types out *)
try ignore(
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ print_if ppf Clflags.dump_printcode Printcode.implementation
++ Typemod.type_implementation sourcefile outputprefix modulename env)
with x ->
Pparse.remove_preprocessed_if_ast inputfile;
raise x
! end else begin (* this actually compiles the code *)
let objfile = outputprefix ^ ".cmo" in
let oc = open_out_bin objfile in
try
! let frontEnd =
! if !Clflags.use_seminal then
! (hookSeminal
! (function file ->
! (Pparse.file ppf file Parse.implementation ast_impl_magic_number)
! ++ print_if ppf Clflags.dump_parsetree Printast.implementation
! ++ print_if ppf Clflags.dump_printcode Printcode.implementation)
! (function ast ->
! let initenv = initial_env() in
! Typemod.type_implementation sourcefile outputprefix modulename initenv ast)
! inputfile
! outputprefix
! initial_env
! interface
! implementation)
! ++ printSeminalErrors_if false
! else
! (try
! Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
! ++ print_if ppf Clflags.dump_parsetree Printast.implementation
! ++ print_if ppf Clflags.dump_printcode Printcode.implementation
! ++ Typemod.type_implementation sourcefile outputprefix modulename env
! with x -> ((* createFeedback inputfile; *) raise x))
! in
! frontEnd
++ Translmod.transl_implementation modulename
++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
++ Simplif.simplify_lambda
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/errors.ml seminalOcaml/driver/errors.ml
*** ocaml-3.08.4/driver/errors.ml 2003-06-19 08:53:49.000000000 -0700
--- seminalOcaml/driver/errors.ml 2009-01-19 09:37:55.431982015 -0800
***************
*** 20,27 ****
(* Report an error *)
! let report_error ppf exn =
! let report ppf = function
| Lexer.Error(err, loc) ->
Location.print ppf loc;
Lexer.report_error ppf err
--- 20,27 ----
(* Report an error *)
! let rec report_error ppf exn =
! let rec report ppf = function
| Lexer.Error(err, loc) ->
Location.print ppf loc;
Lexer.report_error ppf err
***************
*** 64,69 ****
--- 64,73 ----
fprintf ppf "I/O error: %s" msg
| Warnings.Errors (n) ->
fprintf ppf "@.Error: %d error-enabled warnings occurred." n
+ | Seminal.TooManyErrors ->
+ fprintf ppf "\nToo many errors caught; aborting"
+ | Seminal.FixedErrors (exs) ->
+ ()
| x -> fprintf ppf "@]"; raise x in
fprintf ppf "@[%a@]@." report exn
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/main_args.ml seminalOcaml/driver/main_args.ml
*** ocaml-3.08.4/driver/main_args.ml 2003-07-17 01:38:27.000000000 -0700
--- seminalOcaml/driver/main_args.ml 2009-01-19 09:37:59.435899616 -0800
***************
*** 56,61 ****
--- 56,64 ----
val _nopervasives : unit -> unit
val _dparsetree : unit -> unit
+ val _dprintcode : unit -> unit
+ val _use_seminal : unit -> unit
+ val _no_triage : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dinstr : unit -> unit
***************
*** 109,114 ****
--- 112,119 ----
"-principal", Arg.Unit F._principal,
" Check principality of type inference";
"-rectypes", Arg.Unit F._rectypes, " Allow arbitrary recursive types";
+ "-seminal", Arg.Unit F._use_seminal, " Automatic search for fixes to errors in code";
+ "-no-triage", Arg.Unit F._no_triage, " Skip triage fixes when using Seminal search";
"-thread", Arg.Unit F._thread, " Generate code that supports the system threads library";
"-unsafe", Arg.Unit F._unsafe,
" No bounds checking on array and string access";
***************
*** 145,150 ****
--- 150,156 ----
" Print location of standard library and exit";
"-nopervasives", Arg.Unit F._nopervasives, " (undocumented)";
"-dparsetree", Arg.Unit F._dparsetree, " (undocumented)";
+ "-dprintcode", Arg.Unit F._dprintcode, " (undocumented)";
"-drawlambda", Arg.Unit F._drawlambda, " (undocumented)";
"-dlambda", Arg.Unit F._dlambda, " (undocumented)";
"-dinstr", Arg.Unit F._dinstr, " (undocumented)";
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/main_args.mli seminalOcaml/driver/main_args.mli
*** ocaml-3.08.4/driver/main_args.mli 2003-07-17 01:38:27.000000000 -0700
--- seminalOcaml/driver/main_args.mli 2009-01-19 09:37:59.327901864 -0800
***************
*** 56,61 ****
--- 56,64 ----
val _nopervasives : unit -> unit
val _dparsetree : unit -> unit
+ val _dprintcode : unit -> unit
+ val _use_seminal : unit -> unit
+ val _no_triage : unit -> unit
val _drawlambda : unit -> unit
val _dlambda : unit -> unit
val _dinstr : unit -> unit
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/main.ml seminalOcaml/driver/main.ml
*** ocaml-3.08.4/driver/main.ml 2004-06-13 05:46:41.000000000 -0700
--- seminalOcaml/driver/main.ml 2009-01-19 09:37:59.935889236 -0800
***************
*** 125,130 ****
--- 125,133 ----
let _verbose = set verbose
let _nopervasives = set nopervasives
let _dparsetree = set dump_parsetree
+ let _dprintcode = set dump_printcode
+ let _use_seminal = set use_seminal
+ let _no_triage = set no_triage
let _drawlambda = set dump_rawlambda
let _dlambda = set dump_lambda
let _dinstr = set dump_instr
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/optcompile.ml seminalOcaml/driver/optcompile.ml
*** ocaml-3.08.4/driver/optcompile.ml 2004-06-13 05:46:41.000000000 -0700
--- seminalOcaml/driver/optcompile.ml 2009-01-19 09:37:56.391962219 -0800
***************
*** 56,61 ****
--- 56,62 ----
let ast =
Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ if !Clflags.dump_printcode then fprintf ppf "%a@." Printcode.interface ast;
let sg = Typemod.transl_signature (initial_env()) ast in
if !Clflags.print_types then
fprintf std_formatter "%a@." Printtyp.signature
***************
*** 88,97 ****
--- 89,100 ----
if !Clflags.print_types then ignore(
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ print_if ppf Clflags.dump_printcode Printcode.implementation
++ Typemod.type_implementation sourcefile outputprefix modulename env)
else begin
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ print_if ppf Clflags.dump_printcode Printcode.implementation
++ Typemod.type_implementation sourcefile outputprefix modulename env
++ Translmod.transl_store_implementation modulename
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/optmain.ml seminalOcaml/driver/optmain.ml
*** ocaml-3.08.4/driver/optmain.ml 2004-06-13 05:46:41.000000000 -0700
--- seminalOcaml/driver/optmain.ml 2009-01-19 09:37:56.459960835 -0800
***************
*** 176,181 ****
--- 176,182 ----
"-nopervasives", Arg.Set nopervasives, " (undocumented)";
"-dparsetree", Arg.Set dump_parsetree, " (undocumented)";
+ "-dprintcode", Arg.Set dump_printcode, " (undocumented)";
"-drawlambda", Arg.Set dump_rawlambda, " (undocumented)";
"-dlambda", Arg.Set dump_lambda, " (undocumented)";
"-dcmm", Arg.Set dump_cmm, " (undocumented)";
diff -Nacr --exclude='*cvsignore*' --exclude='*CVS*' --exclude='*TESTS*' ocaml-3.08.4/driver/seminal.ml seminalOcaml/driver/seminal.ml
*** ocaml-3.08.4/driver/seminal.ml 1969-12-31 16:00:00.000000000 -0800
--- seminalOcaml/driver/seminal.ml 2009-01-19 09:37:56.583958258 -0800
***************
*** 0 ****
--- 1,5006 ----
+ open Misc
+ open Config
+ open Format
+ open Parsetree
+ open Location
+ open Lexing
+ open Warnings
+
+
+ (* XXXXXXXXXXXXXXXX Temporary functions until main work complete XXXXXXXXXXX *)
+ let time_delta t2 t1 =
+ let df = t2 -. t1 in
+ let di = int_of_float df in
+ let s = di mod 60 in
+ let m = (di / 60) mod 60 in
+ let h = (di / 3600) in
+ let frac = int_of_float (10000000. *. fst (modf df)) in
+ Printf.sprintf "%02d:%02d:%02d.%07d" h m s frac
+
+ let timeFns = ref [];;
+ let timeFn fn incrfun =
+ let sTime = Sys.time() in
+ let (eTime, ans) =
+ try
+ let ans = fn () in
+ let eTime = Sys.time() in
+ timeFns := (sTime, eTime) :: !timeFns;
+ incrfun (eTime -. sTime);
+ (eTime, ans)
+ with x ->
+ let eTime = Sys.time() in
+ timeFns := (sTime, eTime) :: !timeFns;
+ incrfun (eTime -. sTime);
+ raise x
+ in (ans, eTime -. sTime, (time_delta eTime sTime))
+
+ let mock_report_error exn =
+ let ppf = str_formatter in
+ let rec report ppf = function
+ | Typecore.Error(loc, err) ->
+ Location.print ppf loc; Typecore.report_error ppf err
+ | Typetexp.Error(loc, err) ->
+ Location.print ppf loc; Typetexp.report_error ppf err
+ | Typedecl.Error(loc, err) ->
+ Location.print ppf loc; Typedecl.report_error ppf err
+ | Typeclass.Error(loc, err) ->
+ Location.print ppf loc; Typeclass.report_error ppf err
+ | Includemod.Error err ->
+ Includemod.report_error ppf err
+ | Typemod.Error(loc, err) ->
+ Location.print ppf loc; Typemod.report_error ppf err
+ | x -> fprintf ppf "@]" in
+
+ fprintf ppf "@[%a@]@." report exn
+
+
+
+ let rec fmt_longident_aux f x =
+ match x with
+ | Longident.Lident (s) -> fprintf f "%s" s;
+ | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s;
+ | Longident.Lapply (y, z) ->
+ fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z;
+ ;;
+
+ let fmt_longident f x = fprintf f "%a" fmt_longident_aux x;;
+
+ let longidentToStr id = fmt_longident str_formatter id; flush_str_formatter ()
+ let rec strToLongident str =
+ let splitAtParens str =
+ try
+ if str = "" then (false, "", "") else
+ let strlen = String.length str in
+ if (str.[strlen-1] <> ')') then
+ (false, str, "")
+ else
+ let parenCount = ref 1 in
+ let lastParenIdx = ref 0 in
+ for i = strlen-2 downto 0 do
+ if (str.[i] = '(') then decr parenCount
+ else if (str.[i] = ')') then incr parenCount;
+ if (!parenCount = 0 && !lastParenIdx < i) then lastParenIdx := i
+ done;
+ let leftsub = try String.sub str 0 !lastParenIdx with _ -> "" in
+ let rightsub = try String.sub str (!lastParenIdx + 1) (strlen - !lastParenIdx - 2) with _ -> "" in
+ (true, leftsub, rightsub)
+ with Invalid_argument _ ->(false, str, "") in
+ let splitAtPeriod str =
+ try
+ if str = "" then (false, "", "") else
+ let strlen = String.length str in
+ let lastPeriodIdx = try String.rindex str '.' with Not_found -> strlen in
+ if (lastPeriodIdx < strlen) then
+ let leftsub = try String.sub str 0 lastPeriodIdx with _ -> "" in
+ let rightsub = try String.sub str (lastPeriodIdx + 1) (strlen - lastPeriodIdx - 1) with _ -> "" in
+ (true, leftsub, rightsub)
+ else
+ (false, str, "")
+ with Invalid_argument _ -> (false, str, "") in
+ let (resParen, lparen, rparen) = splitAtParens str in
+ if resParen then
+ Longident.Lapply (strToLongident lparen, strToLongident rparen)
+ else
+ let (resPeriod, lperiod, rperiod) = splitAtPeriod str in
+ if resPeriod then
+ Longident.Ldot (strToLongident lperiod, rperiod)
+ else
+ Longident.Lident str
+
+
+
+ (*XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+ exception TooManyErrors
+ exception FixedErrors of exn list
+
+ let locNone = ref { loc_start = {Lexing.dummy_pos with pos_cnum = -3} ;
+ loc_end = {Lexing.dummy_pos with pos_cnum = -2} ;
+ loc_ghost = true }
+
+ let locBefore loc1 loc2 = (* loc1 before loc2 *)
+ (loc1.loc_end.pos_cnum <= loc2.loc_end.pos_cnum)
+
+ let locAfter loc1 loc2 = (* loc1 after loc2 *)
+ (loc1.loc_start.pos_cnum >= loc2.loc_start.pos_cnum)
+
+ let locOverlap loc1 loc2 =
+ (loc1.loc_start.pos_cnum <= loc2.loc_end.pos_cnum ||
+ loc2.loc_start.pos_cnum <= loc1.loc_end.pos_cnum)
+
+ let locInside loc1 loc2 = (* loc1 inside loc2 *)
+ (loc1.loc_start.pos_cnum >= loc2.loc_start.pos_cnum &&
+ loc1.loc_end.pos_cnum <= loc2.loc_end.pos_cnum)
+
+ let locLen loc = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum
+
+ let locJoin loc1 loc2 = (* smallest location containing both loc1 and loc2 *)
+ if loc1 = !locNone then loc2 else
+ if loc2 = !locNone then loc1 else
+ let lS = if (locBefore loc1 loc2) then loc1.loc_start else loc2.loc_start in
+ let lE = if (locAfter loc1 loc2) then loc1.loc_end else loc2.loc_end in
+ let lG = loc1.loc_ghost && loc2.loc_ghost in
+ {loc_start = lS; loc_end = lE; loc_ghost = lG}
+
+ let locSub loc1 loc2 =
+ if (locAfter loc2 loc1) then
+ if (loc2.loc_start.pos_cnum < loc1.loc_end.pos_cnum) then
+ {loc1 with loc_end = loc2.loc_start}
+ else loc1
+ else loc1
+
+ let sourceFromLoc loc =
+ if (loc.loc_start.pos_fname = "") then
+ (print_string "Something is really really wrong!!\n"; ">>Error: no filename given!<<")
+ else
+ let ic = open_in loc.loc_start.pos_fname in
+ let n = (loc.loc_end.pos_cnum - loc.loc_start.pos_cnum) in
+ if (n <= 0) then "" else
+ let src = String.create n in
+ seek_in ic (loc.loc_start.pos_cnum);
+ Pervasives.really_input ic src 0 n;
+ close_in ic;
+ src
+
+ (* Constructs generic instances of each syntactic category. *)
+ let alphaStr = []
+ let alphaSig = []
+ let alphaExp exnName loc =
+ let expRaise = { pexp_desc = Pexp_ident (Longident.parse "Pervasives.raise"); pexp_loc = loc } in
+ let expExn = { pexp_desc = Pexp_construct (Longident.parse ("SEMINAL_" ^ exnName), None, false); pexp_loc = loc }
+ in { pexp_desc = Pexp_apply (expRaise, [ ("", expExn) ] ); pexp_loc = loc }
+ let alphaPat loc = { ppat_desc = Ppat_any; ppat_loc = loc }
+ let alphaTyp =
+ let tyCount = ref 0 in
+ let alphaTy loc =
+ tyCount := !tyCount + 1;
+ { ptyp_desc = Ptyp_var ("SEMINAL_" ^ (string_of_int !tyCount)); ptyp_loc = loc }
+ in alphaTy
+ let alphaStritem exnName loc = { pstr_desc = Pstr_eval(alphaExp exnName loc); pstr_loc = loc }
+ let alphaMod loc = { pmod_desc = Pmod_structure(alphaStr); pmod_loc = loc }
+ let alphaModty loc = { pmty_desc = Pmty_signature(alphaSig); pmty_loc = loc }
+ let alphaTydec loc = { ptype_params = []; ptype_cstrs = []; ptype_kind = Ptype_abstract; ptype_manifest = None; ptype_variance = []; ptype_loc = loc }
+ let alphaClsig loc = (alphaTyp loc, [])
+ let alphaClinfo a loc = { pci_virt = Asttypes.Virtual; pci_params = ([], Location.none); pci_name = "SEMINAL_BOGUS"; pci_expr = a; pci_variance = []; pci_loc = loc }
+ let alphaClty loc = { pcty_desc = Pcty_signature(alphaClsig loc); pcty_loc = loc }
+ let alphaCldec loc = (alphaClinfo alphaClty loc)
+ let alphaCltydec loc = (alphaClinfo alphaClty loc)
+
+
+
+
+
+
+ (* constructs a nullary exception declaration of the given name *)
+ let globalPrologue = ref []
+ let declareException exnName : Parsetree.structure =
+ let newexn =
+ { pstr_desc = Pstr_exception (("SEMINAL_" ^ exnName), []);
+ pstr_loc = !locNone } in
+ if (not (List.exists (fun s -> s = newexn) !globalPrologue)) then
+ globalPrologue := newexn :: !globalPrologue;
+ []
+
+ (* inline function composition *)
+ let (<<==) f g = function x -> f(g(x))
+
+ (* splits list before nth element -- tail-recursive *)
+ let splitAt n lst =
+ let rec splitAcc frontAccRev n lst =
+ match (lst, n) with
+ ([], _) -> (List.rev frontAccRev, [])
+ | (back, i) when (i <= 0) -> (List.rev frontAccRev, back)
+ | (hd :: tl, i) -> splitAcc (hd :: frontAccRev) (i-1) tl
+ in splitAcc [] n lst
+
+ (* swaps a single item of a list for a new value -- tail-recursive *)
+ let replaceNthWith lst n item =
+ let rec replaceNthAcc accRev lst n item =
+ match (lst, n) with
+ ([], _) -> List.rev accRev
+ | (hd :: tl, 0) -> List.rev_append accRev (item :: tl)
+ | (hd :: tl, i) -> replaceNthAcc (hd :: accRev) tl (i-1) item
+ in replaceNthAcc [] lst n item
+
+ (* removes the nth item -- tail-recursive *)
+ let removeNth n lst =
+ match splitAt n lst with
+ (front, []) -> front
+ | (front, nth :: back) -> List.rev_append (List.rev front) back
+
+ (* inserts an item at position n -- tail-recursive *)
+ let insertNth lst n item =
+ let (front, back) = splitAt n lst in List.rev_append (List.rev front) (item :: back)
+
+ (* returns the list [0..n-1] -- tail-recursive *)
+ let tabulate n =
+ let rec tabAcc acc n i =
+ if (i > n) then acc else tabAcc ((n-i) :: acc) n (i+1)
+ in tabAcc [] n 1
+
+ (* fold_left, carrying a counter argument -- tail-recursive *)
+ let fold_left_n f accu l =
+ let rec aux n accu l =
+ match l with
+ [] -> accu
+ | a::l -> aux (n+1) (f n accu a) l in
+ aux 0 accu l
+
+ (* applies (f : int -> 'a -> 'b) to each element of l -- tail-recursive
+ * n is the zero-based position of the element a in the list l *)
+ let map_at f l =
+ let rec aux accu n l =
+ match l with
+ [] -> List.rev accu
+ | a::l -> let r = f n a in aux (r::accu) (n+1) l in
+ aux [] 0 l
+
+ (* applies (f : int -> 'a option -> 'b) to each gap between elements of l
+ * including before the first element, and after the last element
+ * n is the zero-based index before element a in list l -- tail-recursive *)
+ let map_between f l =
+ let rec aux accu n l =
+ match l with
+ [] -> List.rev ((f n None) :: accu)
+ | a::l -> let r = f n (Some a) in aux (r::accu) (n+1) l in
+ aux [] 0 l
+
+ (* map, with a count instead of the argument -- tail-recursive *)
+ let map_c f l =
+ map_at (fun n x -> f n) l
+
+
+ (* List.flatten (mapper f l) -- tail-recursive *)
+ let mapper_and_flatten mapper f l =
+ let flatten_and_rev l =
+ let rec aux2 innerlist acc =
+ match innerlist with
+ [] -> acc
+ | hd::tl -> aux2 tl (hd::acc) in
+ let rec aux1 outerlist acc =
+ match outerlist with
+ [] -> acc
+ | hd::tl -> aux1 tl (aux2 hd acc) in
+ aux1 l [] in
+ List.rev (flatten_and_rev (mapper f l))
+
+ (* List.flatten (List.map f l) -- tail-recursive *)
+ let map_and_flatten f l = mapper_and_flatten List.map f l
+
+ (* List.flatten (map_n f l) -- tail-recursive *)
+ let map_at_and_flatten f l = mapper_and_flatten map_at f l
+
+ (* List.flatten (map_between f l) -- tail-recursive *)
+ let map_between_and_flatten f l = mapper_and_flatten map_between f l
+
+
+
+
+
+
+
+ (* XXXXXXXXXXXXXXXXXXXXXX Modifications Data Type XXXXXXXXXXXXXXXXXX *)
+ exception DynamicTypeError
+ type astThing =
+ Exp of expression
+ | StrItem of structure_item
+ | Str of structure
+ | Pat of pattern
+ | Typ of core_type
+ | Mod of module_expr
+ | Modty of module_type
+ | Tydec of type_declaration
+ | Cldec of class_declaration
+ | Cldesc of class_description
+ | Cltydec of class_type_declaration
+ | Clfield of class_field
+ | Clexp of class_expr
+ | Sigitem of signature_item
+ | Clty of class_type
+ | Cltyfield of class_type_field
+ and astContext = astThing -> astThing
+ and descent = astThing * astContext (* hole to explore, context to typecheck it in *)
+ and followups = unit -> (astMod list)
+ and fallbacks = unit -> (astMod list)
+ and elision = astThing * (astThing -> astThing) * (astThing -> astThing) * astContext * (astThing -> astContext)
+ (* hole * adapt hole to parent * knockout hole in parent * ideal context * put hole back in some parent *)
+ and singlerepl = {trep_prologue : Parsetree.structure; (* Any additional code needed to construct _ values *)
+ trep_revision : (unit -> astThing); (* what to replace the current astNode with *)
+ trep_replaced : astThing; (* what was replaced *)
+ trep_validate : (unit -> bool); (* whether this modification is valid or not *)
+ trep_desc : string; (* diagnostic message *)
+ trep_tag : int; (* tag for comparing same modifications *)
+ trep_loc : Location.t; (* error location *)
+ trep_type : typedTreeType} (* TypedAst type, if any *)
+ and triagerepl = {ttri_prologue : Parsetree.structure; (* Any additonal code to construct the repair *)
+ ttri_idealctx : (astThing -> astThing); (* idealized context from triaging all expressions -- triage change == ttri_idealctx(ttri_replaced.trep_revision()) *)
+ ttri_triaged : astThing list; (* all the expressions which were triaged *)
+ ttri_adapted : astThing list; (* all the expressions which were adapted *)
+ ttri_original : astThing; (* original parent node of all triaged parts *)
+ ttri_desc : string; (* diagnostic message *)
+ ttri_tag : int; (* tag for comparing same modifications *)
+ ttri_locs : Location.t list; (* locations of all triaged expressions *)
+ ttri_replaced : singlerepl} (* after triage, what change was needed? *)
+ and astMod =
+ | Attempt of astMod list * followups * fallbacks
+ | TriggerSingle of descent
+ | TriggerMulti of descent
+ | TriggerTriage of descent
+ | SingleRecur of descent
+ | SingleReplace of singlerepl
+ | TriageElide of (astThing * astThing list * elision list) list
+ and replacement =
+ | SingleRepl of singlerepl
+ | TriageRepl of triagerepl
+ and typedTreeType =
+ SimpleType of Types.type_expr
+ | ClassType of Types.class_type
+ | ModType of Types.module_type
+ | NoType
+ and searchResults = (replacement * (astContext * astContext * astContext)) list (* outerCtx, searchCtx, displayCtx *)
+
+ let spf = ref (fun a -> ())
+ let sp () = !spf
+ let toExp a : expression = match a with Exp x -> x | _ -> sp () a; raise DynamicTypeError
+ let toStrItem a : structure_item = match a with StrItem x -> x | _ -> sp () a; raise DynamicTypeError
+ let toStr a : structure = match a with Str x -> x | _ -> sp () a; raise DynamicTypeError
+ let toPat a : pattern = match a with Pat x -> x | _ -> sp () a; raise DynamicTypeError
+ let toTyp a : core_type = match a with Typ x -> x | _ -> sp () a; raise DynamicTypeError
+ let toMod a : module_expr = match a with Mod x -> x | _ -> sp () a; raise DynamicTypeError
+ let toModty a : module_type = match a with Modty x -> x | _ -> sp () a; raise DynamicTypeError
+ let toTydec a : type_declaration = match a with Tydec x -> x | _ -> sp () a; raise DynamicTypeError
+ let toCldec a : class_declaration = match a with Cldec x -> x | _ -> sp () a; raise DynamicTypeError
+ let toCldesc a : class_description = match a with Cldesc x -> x | _ -> sp () a; raise DynamicTypeError
+ let toCltydec a : class_type_declaration = match a with Cltydec x -> x | _ -> sp () a; raise DynamicTypeError
+ let toClfield a : class_field = match a with Clfield x -> x | _ -> sp () a; raise DynamicTypeError
+ let toClexp a : class_expr = match a with Clexp x -> x | _ -> sp () a; raise DynamicTypeError
+ let toSigitem a : signature_item = match a with Sigitem x -> x | _ -> sp () a; raise DynamicTypeError
+ let toClty a : class_type = match a with Clty x -> x | _ -> sp () a; raise DynamicTypeError
+ let toCltyfield a : class_type_field = match a with Cltyfield x -> x | _ -> sp () a; raise DynamicTypeError
+
+
+ let noFollowups (_ : unit) = [] (* for use in the new types of modifications *)
+ let noFallbacks (_ : unit) = [] (* for use in the new types of modifications *)
+ let alwaysValid _ = true (* for use in the new types of modifications *)
+ let neverValid _ = false (* for use in the new types of modifications *)
+
+ let validations = ref []
+ let registerValidate astThing fn = validations := (astThing, fn) :: !validations
+
+ let numClosures = ref 0
+
+ let followup a f = Attempt(a, f, noFallbacks)
+
+ let recurStritemStr (s, ctx) = incr numClosures; SingleRecur(StrItem s, (fun x -> Str (ctx (toStrItem x))))
+ let replaceStr a p s v d t l = incr numClosures; SingleReplace({trep_prologue = p; trep_revision = (fun () -> Str (s ())); trep_replaced = a; trep_validate = v; trep_desc = d; trep_tag = t; trep_loc = l; trep_type = NoType})
+
+ let recurExpStritem (e, ctx) = incr numClosures; SingleRecur((Exp e, (fun x -> StrItem (ctx (toExp x)))))
+ let recurPatStritem (p, ctx) = incr numClosures; SingleRecur((Pat p, (fun x -> StrItem (ctx (toPat x)))))
+ let recurTypStritem (t, ctx) = incr numClosures; SingleRecur((Typ t, (fun x -> StrItem (ctx (toTyp x)))))
+ let recurTypdecStritem (t, ctx) = incr numClosures; SingleRecur((Tydec t, (fun x -> StrItem (ctx (toTydec x)))))
+ let recurModStritem (m, ctx) = incr numClosures; SingleRecur((Mod m, (fun x -> StrItem (ctx (toMod x)))))
+ let recurModtyStritem (m, ctx) = incr numClosures; SingleRecur((Modty m, (fun x -> StrItem (ctx (toModty x)))))
+ let recurCldecStritem (c, ctx) = incr numClosures; SingleRecur((Cldec c, (fun x -> StrItem (ctx (toCldec x)))))
+ let recurCltydecStritem (c, ctx) = incr numClosures; SingleRecur((Cltydec c, (fun x -> StrItem (ctx (toCltydec x)))))
+ let replaceStritem a p s v d t l = incr numClosures; SingleReplace({trep_prologue = p; trep_revision = (fun () -> StrItem (s ())); trep_replaced = a; trep_validate = v; trep_desc = d; trep_tag = t; trep_loc = l; trep_type = NoType})
+
+ let recurExpExp (e, ctx) = incr numClosures; SingleRecur((Exp e, (fun x -> Exp (ctx (toExp x)))))
+ let recurPatExp (p, ctx) = incr numClosures; SingleRecur((Pat p, (fun x -> Exp (ctx (toPat x)))))
+ let recurModExp (m, ctx) = incr numClosures; SingleRecur((Mod m, (fun x -> Exp (ctx (toMod x)))))
+ let recurTypExp (t, ctx) = incr numClosures; SingleRecur((Typ t, (fun x -> Exp (ctx (toTyp x)))))
+ let replaceExp a p e v d t l = incr numClosures; SingleReplace({trep_prologue = p; trep_revision = (fun () -> Exp (e ())); trep_replaced = a; trep_validate = v; trep_desc = d; trep_tag = t; trep_loc = l; trep_type = NoType})
+
+ let recurTypTypdec (t, ctx) = incr numClosures; SingleRecur((Typ t, (fun x -> Tydec (ctx (toTyp x)))))
+ let replaceTypdec a p t v d t' l = incr numClosures; SingleReplace({trep_prologue = p; trep_revision = (fun () -> Tydec (t ())); trep_replaced = a; trep_validate = v; trep_desc = d; trep_tag = t'; trep_loc = l; trep_type = NoType})
+
+ let recurTypTyp (t, ctx) = incr numClosures; SingleRecur((Typ t, (fun x -> Typ (ctx (toTyp x)))))
+ let replaceTyp a p t v d t' l = incr numClosures; SingleReplace({trep_prologue = p; trep_revision = (fun () -> Typ (t ())); trep_replaced = a; trep_validate = v; trep_desc = d; trep_tag = t'; trep_loc = l; trep_type = NoType})
+
+ let recurStrMod (s, ctx) = incr numClosures; SingleRecur((Str s, (fun x -> Mod (ctx (toStr x)))))
+ let recurModMod (m, ctx) = incr numClosures; SingleRecur((Mod m, (fun x -> Mod (ctx (toMod x)))))
+ let recurModtyMod (m, ctx) = incr numClosures; SingleRecur((Modty m, (fun x -> Mod (ctx (toModty x)))))
+ let replaceMod a p m v d t l = incr numClosures; SingleReplace({trep_prologue = p; trep_revision = (fun () -> Mod (m ())); trep_replaced = a; trep_validate = v; trep_desc = d; trep_tag = t; trep_loc = l; trep_type = NoType})
+
+ let recurPatPat (p, ctx) = incr numClosures; SingleRecur((Pat p, (fun x -> Pat (ctx (toPat x)))))
+ let recurTypPat (t, ctx) = incr numClosures; SingleRecur((Typ t, (fun x -> Pat (ctx (toTyp x)))))
+ let replacePat a p' p v d t l = incr numClosures; SingleReplace({trep_prologue = p'; trep_revision = (fun () -> Pat (p ())); trep_replaced = a; trep_validate = v; trep_desc = d; trep_tag = t; trep_loc = l; trep_type = NoType})
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+
+
+ let rec astRevisionName a =
+ let nameOf a =
+ match a with
+ Exp _ -> "Exp"
+ | StrItem _ -> "Stritem"
+ | Str _ -> "Str"
+ | Pat _ -> "Pat"
+ | Typ _ -> "Typ"
+ | Mod _ -> "Mod"
+ | Modty _ -> "Modty"
+ | Tydec _ -> "Tydec"
+ | Cldec _ -> "Cldec"
+ | Cldesc _ -> "Cldesc"
+ | Cltydec _ -> "Cltydec"
+ | Clfield _ -> "Clfield"
+ | Clexp _ -> "Clexp"
+ | Sigitem _ -> "Sigitem"
+ | Clty _ -> "Clty"
+ | Cltyfield _ -> "Cltyfield" in
+ match a with
+ | TriggerSingle (hole, ctx) -> "triggersingle" ^ (nameOf hole) ^ (nameOf (ctx hole))
+ | TriggerMulti (hole, ctx) -> "triggermulti" ^ (nameOf hole) ^ (nameOf (ctx hole))
+ | TriggerTriage (hole, ctx) -> "triggertriage" ^ (nameOf hole) ^ (nameOf (ctx hole))
+ | Attempt (a, _, _) -> "attempt(" ^ (List.fold_left (fun accu a -> accu ^ "," ^ (astRevisionName a)) "" a) ^ ")"
+ | SingleRecur (hole, ctx) -> "singlerecur" ^ (nameOf hole) ^ (nameOf (ctx hole))
+ | SingleReplace rep -> "singlereplace" ^ (nameOf (rep.trep_revision ()))
+ | TriageElide phases -> "triageelide(" ^ (string_of_int (List.length phases)) ^ "phases)"
+
+
+ module TagMap = Map.Make(struct type t = string let compare = compare end)
+ let modTags = ref TagMap.empty
+ let nextTag = ref 0
+ let t tag = try (TagMap.find tag !modTags) with Not_found -> (incr nextTag; modTags := TagMap.add tag !nextTag !modTags; !nextTag)
+
+
+ let shouldTryFix phraseLoc locOpt =
+ match locOpt with
+ None -> true
+ | Some loc -> (* locInside loc phraseLoc *) true
+
+
+
+
+
+
+
+ (* XXXXXXXXXXXXXXX Print modification in context of AST XXXXXXXXXXXXXXXXXXX *)
+ type contextList = astContext array
+ let makeContext len = Array.make len (fun x -> x)
+ let narrowContext oldCtx innerCtx =
+ Array.init (Array.length oldCtx)
+ (fun idx -> if idx = 0 then innerCtx else oldCtx.(idx-1) <<== innerCtx)
+ let widestContext ctx = ctx.(Array.length ctx - 1)
+
+
+ let print_exp = Printcode.expression std_formatter
+ let print_stritem = Printcode.stritem std_formatter
+ let print_str = Printcode.implementation std_formatter
+ let print_pat = Printcode.pattern std_formatter
+ let print_typ = Printcode.coretype std_formatter
+ let print_mod = Printcode.modexp std_formatter
+ let print_modty = Printcode.modtyp std_formatter
+ let print_tydec = Printcode.tydec std_formatter
+ let print_cldec = Printcode.cldec std_formatter
+ let print_cldesc = Printcode.cldesc std_formatter
+ let print_cltydec = Printcode.cltydec std_formatter
+ let print_clfield = Printcode.classfld std_formatter
+ let print_clexp = Printcode.clexp std_formatter
+ let print_sigitem = Printcode.sigitem std_formatter
+ let print_clty = Printcode.clty std_formatter
+ let print_cltf = Printcode.cltf std_formatter
+
+ let smartPrintTo stream astThing =
+ (match astThing with
+ Exp exp -> Printcode.expression stream exp
+ | StrItem strItem -> Printcode.stritem stream strItem
+ | Str str -> Printcode.implementation stream str
+ | Pat pat -> Printcode.pattern stream pat
+ | Typ typ -> Printcode.coretype stream typ
+ | Mod md -> Printcode.modexp stream md
+ | Modty mty -> Printcode.modtyp stream mty
+ | Tydec tyd -> Printcode.tydec stream tyd
+ | Cldec cld -> Printcode.cldec stream cld
+ | Cldesc cld -> Printcode.cldesc stream cld
+ | Cltydec ctd -> Printcode.cltydec stream ctd
+ | Clfield clf -> Printcode.classfld stream clf
+ | Clexp cle -> Printcode.clexp stream cle
+ | Sigitem sit -> Printcode.sigitem stream sit
+ | Clty clt -> Printcode.clty stream clt
+ | Cltyfield cltf -> Printcode.cltf stream cltf)
+ let smartPrint astThing =
+ (smartPrintTo std_formatter astThing;
+ print_string "\n===============\n")
+ let smartPrintTypeTo stream astType =
+ match astType with
+ SimpleType t -> Printtyp.type_expr stream t
+ | ClassType t -> Printtyp.class_type stream t
+ | ModType t -> Printtyp.modtype stream t
+ | NoType -> fprintf stream "No type\n"
+ let smartPrintType = smartPrintTypeTo std_formatter;;
+ spf := (fun x -> print_string "Type error!! "; smartPrint x);;
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+
+
+
+
+ (* XXXXXXXXXXXXXXXXXXXXXX Convert AST to uniform AST XXXXXXXXXXXXXXXXXXXXXX *)
+ module ASTMap = Map.Make(struct type t = astThing let compare = compare end)
+ type 'a uniformAST = { past_data : 'a;
+ past_node : astThing;
+ past_idxs : int ASTMap.t;
+ past_kids : 'a uniformAST list
+ }
+ let rec convertUniform (f : astThing -> 'a) (ast : astThing) : 'a uniformAST =
+ let emptyUniformAST = { past_data = f (Str []); past_node = Str []; past_idxs = ASTMap.empty; past_kids = []} in
+ let indexList lst =
+ fold_left_n (fun idx accu item -> ASTMap.add item idx accu) (ASTMap.empty) lst in
+ let buildUniformAST childList =
+ { past_data = f ast;
+ past_node = ast;
+ past_idxs = indexList childList;
+ past_kids = List.map (convertUniform f) childList } in
+ match ast with
+ Str str ->
+ begin
+ let strList = List.map (fun x -> StrItem x) str in
+ buildUniformAST strList
+ end
+ | StrItem stritem ->
+ begin
+ let flatPElist peList = List.flatten
+ (List.fold_right (fun (p,e) accu -> [Pat p; Exp e] :: accu) peList []) in
+ match stritem.pstr_desc with
+ Pstr_eval e -> buildUniformAST [ Exp e ]
+ | Pstr_value(rec_flag, peList) -> buildUniformAST (flatPElist peList)
+ | Pstr_primitive(prim, value_desc) -> buildUniformAST [ Typ value_desc.pval_type ]
+ | Pstr_type tytydecList ->
+ let tydecList = List.map (fun (tyname, tydec) -> Tydec tydec) tytydecList in
+ buildUniformAST tydecList
+ | Pstr_exception (exn, exDec) ->
+ let exndec = List.map (fun x -> Typ x) exDec in
+ buildUniformAST exndec
+ | Pstr_exn_rebind (str, id) -> buildUniformAST []
+ | Pstr_module (str, modexp) -> buildUniformAST [ Mod modexp ]
+ | Pstr_recmodule strModtyModexpList ->
+ let flatmtymexpList = List.flatten
+ (List.fold_right (fun (s, mty, md) accu -> [Modty mty; Mod md] :: accu) strModtyModexpList []) in
+ buildUniformAST flatmtymexpList
+ | Pstr_modtype (str, mty) -> buildUniformAST [ Modty mty ]
+ | Pstr_open id -> buildUniformAST []
+ | Pstr_class cldecList ->
+ let cldecs = List.map (fun x -> Cldec x) cldecList in
+ buildUniformAST cldecs
+ | Pstr_class_type cltydecList ->
+ let cltydecs = List.map (fun x -> Cltydec x) cltydecList in
+ buildUniformAST cltydecs
+ | Pstr_include md -> buildUniformAST [ Mod md ]
+ end
+ | Tydec tyd ->
+ begin
+ let cstrs = List.flatten
+ (List.fold_right (fun (t1, t2, l) accu -> [Typ t1; Typ t2] :: accu) tyd.ptype_cstrs []) in
+ let tykinds =
+ match tyd.ptype_kind with
+ Ptype_abstract -> []
+ | Ptype_variant (strtyList, _) -> List.flatten
+ (List.fold_right (fun (_, tyList) accu -> (List.map (fun ty -> Typ ty) tyList) :: accu) strtyList [])
+ | Ptype_record (strmuttyList, _) -> List.fold_right (fun (_, _, ty) accu -> (Typ ty) :: accu) strmuttyList [] in
+ let manifest = match tyd.ptype_manifest with None -> [] | Some t -> [Typ t] in
+ buildUniformAST (cstrs @ tykinds @ manifest)
+ end
+ | Pat pat ->
+ begin
+ match pat.ppat_desc with
+ Ppat_any -> buildUniformAST []
+ | Ppat_var str -> buildUniformAST []
+ | Ppat_alias (pat, str) -> buildUniformAST [ Pat pat ]
+ | Ppat_constant c -> buildUniformAST []
+ | Ppat_tuple pList ->
+ let patList = (List.map (fun x -> Pat x) pList) in
+ buildUniformAST patList
+ | Ppat_construct (id, pOpt, b) ->
+ let p = match pOpt with None -> [] | Some pat -> [ Pat pat ] in
+ buildUniformAST p
+ | Ppat_variant (lab, pOpt) ->
+ let p = match pOpt with None -> [] | Some pat -> [ Pat pat ] in
+ buildUniformAST p
+ | Ppat_record idpatList ->
+ let patList = (List.map (fun (id, p) -> Pat p) idpatList) in
+ buildUniformAST patList
+ | Ppat_array pList ->
+ let patList = (List.map (fun x -> Pat x) pList) in
+ buildUniformAST patList
+ | Ppat_or (p1, p2) -> buildUniformAST [ Pat p1; Pat p2 ]
+ | Ppat_constraint (p, ty) -> buildUniformAST [ Pat p; Typ ty ]
+ | Ppat_type id -> buildUniformAST []
+ end
+ | Exp exp ->
+ begin
+ let flatPElist peList = List.flatten
+ (List.fold_right (fun (p,e) accu -> [Pat p; Exp e] :: accu) peList []) in
+ match exp.pexp_desc with
+ Pexp_ident id -> buildUniformAST []
+ | Pexp_constant c -> buildUniformAST []
+ | Pexp_let (recf, peList, e) ->
+ let pes = flatPElist peList in
+ buildUniformAST ( pes @ [ Exp e ] )
+ | Pexp_function (lab, eOpt, peList) ->
+ let pes = flatPElist peList in
+ let e = match eOpt with None -> [] | Some e -> [ Exp e ] in
+ buildUniformAST (e @ pes)
+ | Pexp_apply (e, leList) ->
+ let flatLElist leList = List.fold_right (fun (_,e) accu -> ( Exp e ) :: accu) leList [] in
+ buildUniformAST (( Exp e ) :: (flatLElist leList))
+ | Pexp_match (e, peList) -> buildUniformAST ((Exp e) :: (flatPElist peList))
+ | Pexp_try (e, peList) -> buildUniformAST ((Exp e) :: (flatPElist peList))
+ | Pexp_tuple eList ->
+ let es = List.map (fun x -> Exp x) eList in
+ buildUniformAST es
+ | Pexp_construct (id, eOpt, b) ->
+ let e = match eOpt with None -> [] | Some e -> [ Exp e ] in
+ buildUniformAST e
+ | Pexp_variant (lab, eOpt) ->
+ let e = match eOpt with None -> [] | Some e -> [ Exp e ] in
+ buildUniformAST e
+ | Pexp_record (ideList, eOpt) ->
+ let e = match eOpt with None -> [] | Some e -> [ Exp e ] in
+ let es = List.fold_right (fun (_, e) accu -> (Exp e) :: accu) ideList e in
+ buildUniformAST es
+ | Pexp_field (e, id) -> buildUniformAST [ Exp e ]
+ | Pexp_setfield (e1, id, e2) -> buildUniformAST [ Exp e1; Exp e2 ]
+ | Pexp_array eList ->
+ let es = List.map (fun x -> Exp x) eList in
+ buildUniformAST es
+ | Pexp_ifthenelse (e1,e2,e3Opt) ->
+ let e3 = match e3Opt with None -> [] | Some e3 -> [ Exp e3 ] in
+ buildUniformAST (Exp e1 :: Exp e2 :: e3)
+ | Pexp_sequence (e1, e2) -> buildUniformAST [ Exp e1; Exp e2 ]
+ | Pexp_while (e1, e2) -> buildUniformAST [ Exp e1; Exp e2 ]
+ | Pexp_for (s, e1, e2, d, e3) -> buildUniformAST [ Exp e1; Exp e2; Exp e3 ]
+ | Pexp_constraint (e, ty1Opt, ty2Opt) ->
+ let t1 = match ty1Opt with None -> [] | Some ty1 -> [ Typ ty1 ] in
+ let t2 = match ty2Opt with None -> [] | Some ty2 -> [ Typ ty2 ] in
+ buildUniformAST ((Exp e) :: (t1 @ t2))
+ | Pexp_when (e1, e2) -> buildUniformAST [ Exp e1; Exp e2 ]
+ | Pexp_send (e, s) -> buildUniformAST [ Exp e ]
+ | Pexp_new id -> buildUniformAST []
+ | Pexp_setinstvar (s, e) -> buildUniformAST [ Exp e ]
+ | Pexp_override seList ->
+ let flatSElist seList = List.fold_right (fun (_,e) accu -> ( Exp e ) :: accu) seList [] in
+ buildUniformAST (flatSElist seList)
+ | Pexp_letmodule (s, md, e) -> buildUniformAST [ Mod md ; Exp e ]
+ | Pexp_assert e -> buildUniformAST [ Exp e ]
+ | Pexp_assertfalse -> buildUniformAST []
+ | Pexp_lazy e -> buildUniformAST [ Exp e ]
+ | Pexp_poly (e, tyOpt) ->
+ let ty = match tyOpt with None -> [] | Some ty -> [ Typ ty ] in
+ buildUniformAST ((Exp e) :: ty)
+ | Pexp_object (p, cfList) ->
+ let clfs = List.map (fun x -> Clfield x) cfList in
+ buildUniformAST ((Pat p) :: clfs)
+ end
+ | Mod mdl ->
+ begin
+ match mdl.pmod_desc with
+ Pmod_ident id -> buildUniformAST []
+ | Pmod_structure str -> buildUniformAST [ Str str ]
+ | Pmod_functor (s, mty, md') -> buildUniformAST [ Modty mty ; Mod md' ]
+ | Pmod_apply (m1, m2) -> buildUniformAST [ Mod m1 ; Mod m2 ]
+ | Pmod_constraint (m, mty) -> buildUniformAST [ Mod m ; Modty mty ]
+ end
+ | Modty mty ->
+ begin
+ match mty.pmty_desc with
+ Pmty_ident id -> buildUniformAST []
+ | Pmty_signature sgn ->
+ let sits = List.map (fun x -> Sigitem x) sgn in
+ buildUniformAST sits
+ | Pmty_functor (s, mty1, mty2) -> buildUniformAST [ Modty mty1 ; Modty mty2 ]
+ | Pmty_with (mt1, idwithList) ->
+ let withList = List.fold_right
+ (fun (id, wconstraint) accu -> match wconstraint with Pwith_type tyd -> (Tydec tyd) :: accu | _ -> accu) idwithList [] in
+ buildUniformAST ((Modty mt1)::withList)
+ end
+ | Sigitem sit ->
+ begin
+ match sit.psig_desc with
+ Psig_value (s, valu) -> buildUniformAST [ Typ valu.pval_type ]
+ | Psig_type styList ->
+ let tys = List.map (fun (s, ty) -> Tydec ty) styList in
+ buildUniformAST tys
+ | Psig_exception (s, exn) ->
+ let tys = List.map (fun x -> Typ x) exn in
+ buildUniformAST tys
+ | Psig_module (s, mty) -> buildUniformAST [ Modty mty ]
+ | Psig_recmodule smtyList ->
+ let mtys = List.map (fun (s, mty) -> Modty mty) smtyList in
+ buildUniformAST mtys
+ | Psig_modtype (s, mtydec) ->
+ let mtydecs = match mtydec with Pmodtype_manifest mty -> [ Modty mty ] | _ -> [] in
+ buildUniformAST mtydecs
+ | Psig_open id -> buildUniformAST []
+ | Psig_include mty -> buildUniformAST [ Modty mty ]
+ | Psig_class cldecList ->
+ let cldecs = List.map (fun x -> Cldesc x) cldecList in
+ buildUniformAST cldecs
+ | Psig_class_type cltydecList ->
+ let cltydecs = List.map (fun x -> Cltydec x) cltydecList in
+ buildUniformAST cltydecs
+ end
+ | Typ typ ->
+ begin
+ match typ.ptyp_desc with
+ Ptyp_any -> buildUniformAST []
+ | Ptyp_var s -> buildUniformAST []
+ | Ptyp_arrow (l, ty1, ty2) -> buildUniformAST [ Typ ty1 ; Typ ty2 ]
+ | Ptyp_tuple tyList ->
+ let tys = List.map (fun x -> Typ x) tyList in
+ buildUniformAST tys
+ | Ptyp_constr (id, tyList) ->
+ let tys = List.map (fun x -> Typ x) tyList in
+ buildUniformAST tys
+ | Ptyp_object cftyList ->
+ let tys = (List.fold_right
+ (fun cfty accu ->
+ match cfty.pfield_desc with
+ Pfield (s, ty) -> (Typ ty)::accu
+ | Pfield_var -> accu) cftyList []) in
+ buildUniformAST tys
+ | Ptyp_class (id, tyList, labList) ->
+ let tys = List.map (fun x -> Typ x) tyList in
+ buildUniformAST tys
+ | Ptyp_alias (ty, s) -> buildUniformAST [ Typ ty ]
+ | Ptyp_variant (rfList, b, lablistOpt) ->
+ let tys = List.flatten
+ (List.fold_right
+ (fun rf accu ->
+ match rf with
+ Rtag (l, b, tyList) -> (List.map (fun x -> Typ x) tyList) :: accu
+ | Rinherit ty -> [ Typ ty ] :: accu) rfList []) in
+ buildUniformAST tys
+ | Ptyp_poly (sList, ty) -> buildUniformAST [ Typ ty ]
+ end
+ | Cldec cli ->
+ begin
+ buildUniformAST [ Clexp cli.pci_expr ]
+ end
+ | Cldesc cli ->
+ begin
+ buildUniformAST [ Clty cli.pci_expr ]
+ end
+ | Cltydec cli ->
+ begin
+ buildUniformAST [ Clty cli.pci_expr ]
+ end
+ | Clfield clf ->
+ begin
+ match clf with
+ Pcf_inher (cle, s) -> buildUniformAST [ Clexp cle ]
+ | Pcf_val (s, mut, e, loc) -> buildUniformAST [ Exp e ]
+ | Pcf_virt (s, priv, ty, loc) -> buildUniformAST [ Typ ty ]
+ | Pcf_meth (s, priv, e, loc) -> buildUniformAST [ Exp e ]
+ | Pcf_cstr (ty1, ty2, loc) -> buildUniformAST [ Typ ty1; Typ ty2 ]
+ | Pcf_let (r, peList, loc) ->
+ let flatPElist peList = List.flatten
+ (List.fold_right (fun (p,e) accu -> [Pat p; Exp e]::accu) peList []) in
+ buildUniformAST (flatPElist peList)
+ | Pcf_init e -> buildUniformAST [ Exp e ]
+ end
+ | Clexp cle ->
+ begin
+ match cle.pcl_desc with
+ Pcl_constr (id, tyList) ->
+ let tys = List.map (fun x -> Typ x) tyList in
+ buildUniformAST tys
+ | Pcl_structure (pat, clfieldList) ->
+ let clfs = List.map (fun x -> Clfield x) clfieldList in
+ buildUniformAST ((Pat pat)::clfs)
+ | Pcl_fun (lab, eOpt, pat, clexp) ->
+ let e = match eOpt with None -> [] | Some e -> [ Exp e ] in
+ buildUniformAST (e @ [ Pat pat ; Clexp clexp ])
+ | Pcl_apply (clexp, labeList) ->
+ let es = List.map (fun (_, e) -> Exp e) labeList in
+ buildUniformAST ((Clexp clexp)::es)
+ | Pcl_let (recflag, peList, clexp) ->
+ let pes = List.flatten
+ (List.fold_right (fun (pat, exp) accu -> [ Pat pat ; Exp exp ] :: accu) peList []) in
+ buildUniformAST (pes @ [ Clexp clexp ] )
+ | Pcl_constraint (clexp, clty) ->
+ buildUniformAST [ Clexp clexp ; Clty clty ]
+ end
+ | Clty clty ->
+ begin
+ match clty.pcty_desc with
+ Pcty_constr (id, tyList) ->
+ let tys = List.map (fun x -> Typ x) tyList in
+ buildUniformAST tys
+ | Pcty_signature (ty, cltyfieldList) ->
+ let cltfs = List.map (fun x -> Cltyfield x) cltyfieldList in
+ buildUniformAST ((Typ ty)::cltfs)
+ | Pcty_fun (l, ty, clty) -> buildUniformAST [ Typ ty ; Clty clty ]
+ end
+ | Cltyfield cltf ->
+ begin
+ match cltf with
+ Pctf_inher clty -> buildUniformAST [ Clty clty ]
+ | Pctf_val (s, mut, tyOpt, loc) ->
+ let ty = match tyOpt with None -> [] | Some ty -> [ Typ ty ] in
+ buildUniformAST ty
+ | Pctf_virt (s, privflag, ty, loc) -> buildUniformAST [ Typ ty ]
+ | Pctf_meth (s, privflag, ty, loc) -> buildUniformAST [ Typ ty ]
+ | Pctf_cstr (ty1, ty2, loc) -> buildUniformAST [ Typ ty1 ; Typ ty2 ]
+ end
+
+ let equalNode x y =
+ match (x.past_node, y.past_node) with
+ (Str _, Str _) -> true
+ | (StrItem stritem1, StrItem stritem2) ->
+ begin
+ match (stritem1.pstr_desc, stritem2.pstr_desc) with
+ (Pstr_eval _, Pstr_eval _) -> true
+ | (Pstr_value(rec_flag1, _), Pstr_value(rec_flag2, _)) -> rec_flag1 = rec_flag2
+ | (Pstr_primitive(prim1, _), Pstr_primitive(prim2, _)) -> prim1 = prim2
+ | (Pstr_type _, Pstr_type _) -> true
+ | (Pstr_exception (exn1, _), Pstr_exception(exn2, _)) -> exn1 = exn2
+ | (Pstr_exn_rebind (str1, id1), Pstr_exn_rebind(str2, id2)) -> str1 = str2 && id1 = id2
+ | (Pstr_module (str1, _), Pstr_module(str2, _)) -> str1 = str2
+ | (Pstr_recmodule _, Pstr_recmodule _) -> true
+ | (Pstr_modtype (str1, _), Pstr_modtype (str2, _)) -> str1 = str2
+ | (Pstr_open id1, Pstr_open id2) -> id1 = id2
+ | (Pstr_class _, Pstr_class _) -> true
+ | (Pstr_class_type _, Pstr_class_type _) -> true
+ | (Pstr_include _, Pstr_include _) -> true
+ | _ -> false
+ end
+ | (Tydec _, Tydec _) -> true
+ | (Pat pat1, Pat pat2) ->
+ begin
+ match (pat1.ppat_desc, pat2.ppat_desc) with
+ (Ppat_any, Ppat_any) -> true
+ | (Ppat_var str1, Ppat_var str2) -> str1 = str2
+ | (Ppat_alias (_, str1), Ppat_alias (_, str2)) -> str1 = str2
+ | (Ppat_constant c1, Ppat_constant c2) -> c1 = c2
+ | (Ppat_tuple _, Ppat_tuple _) -> true
+ | (Ppat_construct (id1, _, b1), Ppat_construct (id2, _, b2)) -> id1 = id2 && b1 = b2
+ | (Ppat_variant (lab1, _), Ppat_variant (lab2, _)) -> lab1 = lab2
+ | (Ppat_record _, Ppat_record _) -> true
+ | (Ppat_array _, Ppat_array _) -> true
+ | (Ppat_or _, Ppat_or _) -> true
+ | (Ppat_constraint _, Ppat_constraint _) -> true
+ | (Ppat_type id1, Ppat_type id2) -> id1 = id2
+ | _ -> false
+ end
+ | (Exp exp1, Exp exp2) ->
+ begin
+ match (exp1.pexp_desc, exp2.pexp_desc) with
+ (Pexp_ident id1, Pexp_ident id2) -> id1 = id2
+ | (Pexp_constant c1, Pexp_constant c2) -> c1 = c2
+ | (Pexp_let (recf1, _, _), Pexp_let (recf2, _, _)) -> recf1 = recf2
+ | (Pexp_function (lab1, _, _), Pexp_function (lab2, _, _)) -> lab1 = lab2
+ | (Pexp_apply _, Pexp_apply _) -> true
+ | (Pexp_match _, Pexp_match _) -> true
+ | (Pexp_try _, Pexp_try _) -> true
+ | (Pexp_tuple _, Pexp_tuple _) -> true
+ | (Pexp_construct (id1, _, b1), Pexp_construct (id2, _, b2)) -> id1 = id2 && b1 = b2
+ | (Pexp_variant (lab1, _), Pexp_variant (lab2, _)) -> lab1 = lab2
+ | (Pexp_record _, Pexp_record _) -> true
+ | (Pexp_field (_, id1), Pexp_field (_, id2)) -> id1 = id2
+ | (Pexp_setfield (_, id1, _), Pexp_setfield (_, id2, _)) -> id1 = id2
+ | (Pexp_array _, Pexp_array _) -> true
+ | (Pexp_ifthenelse _, Pexp_ifthenelse _) -> true
+ | (Pexp_sequence _, Pexp_sequence _) -> true
+ | (Pexp_while _, Pexp_while _) -> true
+ | (Pexp_for (s1, _, _, d1, _), Pexp_for (s2, _, _, d2, _)) -> s1 = s2 && d1 = d2
+ | (Pexp_constraint _, Pexp_constraint _) -> true
+ | (Pexp_when _, Pexp_when _) -> true
+ | (Pexp_send (_, s1), Pexp_send (_, s2)) -> s1 = s2
+ | (Pexp_new id1, Pexp_new id2) -> id1 = id2
+ | (Pexp_setinstvar (s1, _), Pexp_setinstvar (s2, _)) -> s1 = s2
+ | (Pexp_override _, Pexp_override _) -> true
+ | (Pexp_letmodule (s1, _, _), Pexp_letmodule (s2, _, _)) -> s1 = s2
+ | (Pexp_assert _, Pexp_assert _) -> true
+ | (Pexp_assertfalse, Pexp_assertfalse) -> true
+ | (Pexp_lazy _, Pexp_lazy _) -> true
+ | (Pexp_poly _, Pexp_poly _) -> true
+ | (Pexp_object _, Pexp_object _) -> true
+ | _ -> false
+ end
+ | (Mod mdl1, Mod mdl2) ->
+ begin
+ match (mdl1.pmod_desc, mdl2.pmod_desc) with
+ (Pmod_ident id1, Pmod_ident id2) -> id1 = id2
+ | (Pmod_structure _, Pmod_structure _) -> true
+ | (Pmod_functor (s1, _, _), Pmod_functor (s2, _, _)) -> s1 = s2
+ | (Pmod_apply _, Pmod_apply _) -> true
+ | (Pmod_constraint _, Pmod_constraint _) -> true
+ | _ -> false
+ end
+ | (Typ typ1, Typ typ2) ->
+ begin
+ match (typ1.ptyp_desc, typ2.ptyp_desc) with
+ (Ptyp_any, Ptyp_any) -> true
+ | (Ptyp_var s1, Ptyp_var s2) -> s1 = s2
+ | (Ptyp_arrow (l1, _, _), Ptyp_arrow (l2, _, _)) -> l1 = l2
+ | (Ptyp_tuple _, Ptyp_tuple _) -> true
+ | (Ptyp_constr (id1, _), Ptyp_constr (id2, _)) -> id1 = id2
+ | (Ptyp_object _, Ptyp_object _) -> true
+ | (Ptyp_class (id1, _, _), Ptyp_class (id2, _, _)) -> id1 = id2
+ | (Ptyp_alias (_, s1), Ptyp_alias (_, s2)) -> s1 = s2
+ | (Ptyp_variant (_, b1, _), Ptyp_variant (_, b2, _)) -> b1 = b2
+ | (Ptyp_poly _, Ptyp_poly _) -> true
+ | _ -> false
+ end
+ | _ -> false
+ (* | Modty mty ->
+ begin
+ match mty.pmty_desc with
+ Pmty_ident id -> buildUniformAST []
+ | Pmty_signature sgn ->
+ let sits = List.map (fun x -> Sigitem x) sgn in
+ buildUniformAST sits
+ | Pmty_functor (s, mty1, mty2) -> buildUniformAST [ Modty mty1 ; Modty mty2 ]
+ | Pmty_with (mt1, idwithList) ->
+ let withList = List.fold_right
+ (fun (id, wconstraint) accu -> match wconstraint with Pwith_type tyd -> (Tydec tyd) :: accu | _ -> accu) idwithList [] in
+ buildUniformAST ((Modty mt1)::withList)
+ end
+ | Sigitem sit ->
+ begin
+ match sit.psig_desc with
+ Psig_value (s, valu) -> buildUniformAST [ Typ valu.pval_type ]
+ | Psig_type styList ->
+ let tys = List.map (fun (s, ty) -> Tydec ty) styList in
+ buildUniformAST tys
+ | Psig_exception (s, exn) ->
+ let tys = List.map (fun x -> Typ x) exn in
+ buildUniformAST tys
+ | Psig_module (s, mty) -> buildUniformAST [ Modty mty ]
+ | Psig_recmodule smtyList ->
+ let mtys = List.map (fun (s, mty) -> Modty mty) smtyList in
+ buildUniformAST mtys
+ | Psig_modtype (s, mtydec) ->
+ let mtydecs = match mtydec with Pmodtype_manifest mty -> [ Modty mty ] | _ -> [] in
+ buildUniformAST mtydecs
+ | Psig_open id -> buildUniformAST []
+ | Psig_include mty -> buildUniformAST [ Modty mty ]
+ | Psig_class cldecList ->
+ let cldecs = List.map (fun x -> Cldesc x) cldecList in
+ buildUniformAST cldecs
+ | Psig_class_type cltydecList ->
+ let cltydecs = List.map (fun x -> Cltydec x) cltydecList in
+ buildUniformAST cltydecs
+ end
+ | Cldec cli ->
+ begin
+ buildUniformAST [ Clexp cli.pci_expr ]
+ end
+ | Cldesc cli ->
+ begin
+ buildUniformAST [ Clty cli.pci_expr ]
+ end
+ | Cltydec cli ->
+ begin
+ buildUniformAST [ Clty cli.pci_expr ]
+ end
+ | Clfield clf ->
+ begin
+ match clf with
+ Pcf_inher (cle, s) -> buildUniformAST [ Clexp cle ]
+ | Pcf_val (s, mut, e, loc) -> buildUniformAST [ Exp e ]
+ | Pcf_virt (s, priv, ty, loc) -> buildUniformAST [ Typ ty ]
+ | Pcf_meth (s, priv, e, loc) -> buildUniformAST [ Exp e ]
+ | Pcf_cstr (ty1, ty2, loc) -> buildUniformAST [ Typ ty1; Typ ty2 ]
+ | Pcf_let (r, peList, loc) ->
+ let flatPElist peList = List.flatten
+ (List.fold_right (fun (p,e) accu -> [Pat p; Exp e]::accu) peList []) in
+ buildUniformAST (flatPElist peList)
+ | Pcf_init e -> buildUniformAST [ Exp e ]
+ end
+ | Clexp cle ->
+ begin
+ match cle.pcl_desc with
+ Pcl_constr (id, tyList) ->
+ let tys = List.map (fun x -> Typ x) tyList in
+ buildUniformAST tys
+ | Pcl_structure (pat, clfieldList) ->
+ let clfs = List.map (fun x -> Clfield x) clfieldList in
+ buildUniformAST ((Pat pat)::clfs)
+ | Pcl_fun (lab, eOpt, pat, clexp) ->
+ let e = match eOpt with None -> [] | Some e -> [ Exp e ] in
+ buildUniformAST (e @ [ Pat pat ; Clexp clexp ])
+ | Pcl_apply (clexp, labeList) ->
+ let es = List.map (fun (_, e) -> Exp e) labeList in
+ buildUniformAST ((Clexp clexp)::es)
+ | Pcl_let (recflag, peList, clexp) ->
+ let pes = List.flatten
+ (List.fold_right (fun (pat, exp) accu -> [ Pat pat ; Exp exp ] :: accu) peList []) in
+ buildUniformAST (pes @ [ Clexp clexp ] )
+ | Pcl_constraint (clexp, clty) ->
+ buildUniformAST [ Clexp clexp ; Clty clty ]
+ end
+ | Clty clty ->
+ begin
+ match clty.pcty_desc with
+ Pcty_constr (id, tyList) ->
+ let tys = List.map (fun x -> Typ x) tyList in
+ buildUniformAST tys
+ | Pcty_signature (ty, cltyfieldList) ->
+ let cltfs = List.map (fun x -> Cltyfield x) cltyfieldList in
+ buildUniformAST ((Typ ty)::cltfs)
+ | Pcty_fun (l, ty, clty) -> buildUniformAST [ Typ ty ; Clty clty ]
+ end
+ | Cltyfield cltf ->
+ begin
+ match cltf with
+ Pctf_inher clty -> buildUniformAST [ Clty clty ]
+ | Pctf_val (s, mut, tyOpt, loc) ->
+ let ty = match tyOpt with None -> [] | Some ty -> [ Typ ty ] in
+ buildUniformAST ty
+ | Pctf_virt (s, privflag, ty, loc) -> buildUniformAST [ Typ ty ]
+ | Pctf_meth (s, privflag, ty, loc) -> buildUniformAST [ Typ ty ]
+ | Pctf_cstr (ty1, ty2, loc) -> buildUniformAST [ Typ ty1 ; Typ ty2 ]
+ end
+ *)
+ let itemLocation ast =
+ match ast with
+ Str str ->
+ begin
+ match str with
+ [] -> Location.none
+ | hd::tl -> List.fold_left (fun loc stritem -> locJoin loc stritem.pstr_loc) hd.pstr_loc tl
+ end
+ | StrItem stritem -> stritem.pstr_loc
+ | Tydec tyd -> tyd.ptype_loc
+ | Pat pat -> pat.ppat_loc
+ | Exp exp -> exp.pexp_loc
+ | Mod mdl -> mdl.pmod_loc
+ | Modty mty -> mty.pmty_loc
+ | Typ typ -> typ.ptyp_loc
+ | Cldec cli -> cli.pci_loc
+ | Cldesc cli -> cli.pci_loc
+ | Cltydec cli -> cli.pci_loc
+ | Clfield clf -> Location.none
+ | Clexp cle -> cle.pcl_loc
+ | Sigitem sit -> sit.psig_loc
+ | Clty clt -> clt.pcty_loc
+ | Cltyfield cltf -> (match cltf with
+ Pctf_inher t -> t.pcty_loc
+ | Pctf_val (_, _, _, loc)
+ | Pctf_virt (_, _, _, loc)
+ | Pctf_meth (_, _, _, loc)
+ | Pctf_cstr (_, _, loc) -> loc)
+ let nameOf a =
+ match a with
+ Str str -> "Str"
+ | StrItem stritem ->
+ begin "StrItem:" ^
+ match stritem.pstr_desc with
+ Pstr_eval e -> "Pstr_eval"
+ | Pstr_value(rec_flag, peList) -> "Pstr_value"
+ | Pstr_primitive(prim, value_desc) -> "Pstr_primitive"
+ | Pstr_type tytydecList -> "Pstr_type"
+ | Pstr_exception (exn, exDec) -> "Pstr_exception"
+ | Pstr_exn_rebind (str, id) -> "Pstr_exn_rebind"
+ | Pstr_module (str, modexp) -> "Pstr_module"
+ | Pstr_recmodule strModtyModexpList -> "Pstr_recmodule"
+ | Pstr_modtype (str, mty) -> "Pstr_modtype"
+ | Pstr_open id -> "Pstr_open"
+ | Pstr_class cldecList -> "Pstr_class"
+ | Pstr_class_type cltydecList -> "Pstr_class_type"
+ | Pstr_include md -> "Pstr_include"
+ end
+ | Tydec tyd ->
+ begin "Tydec:" ^
+ match tyd.ptype_kind with
+ Ptype_abstract -> "Ptype_abstract"
+ | Ptype_variant (strtyList, _) -> "Ptype_variant"
+ | Ptype_record (strmuttyList, _) -> "Ptype_record"
+ end
+ | Pat pat ->
+ begin "Pat:" ^
+ match pat.ppat_desc with
+ Ppat_any -> "Ppat_any"
+ | Ppat_var str -> "Ppat_var"
+ | Ppat_alias (pat, str) -> "Ppat_alias"
+ | Ppat_constant c -> "Ppat_constant"
+ | Ppat_tuple pList -> "Ppat_tuple"
+ | Ppat_construct (id, pOpt, b) -> "Ppat_construct"
+ | Ppat_variant (lab, pOpt) -> "Ppat_variant"
+ | Ppat_record idpatList -> "Ppat_record"
+ | Ppat_array pList -> "Ppat_array"
+ | Ppat_or (p1, p2) -> "Ppat_or"
+ | Ppat_constraint (p, ty) -> "Ppat_constraint"
+ | Ppat_type id -> "Ppat_type"
+ end
+ | Exp exp ->
+ begin "Exp:" ^
+ match exp.pexp_desc with
+ Pexp_ident id -> "Pexp_ident"
+ | Pexp_constant c -> "Pexp_constant"
+ | Pexp_let (recf, peList, e) -> "Pexp_let"
+ | Pexp_function (lab, eOpt, peList) -> "Pexp_function"
+ | Pexp_apply (e, leList) -> "Pexp_apply"
+ | Pexp_match (e, peList) -> "Pexp_match"
+ | Pexp_try (e, peList) -> "Pexp_try"
+ | Pexp_tuple eList -> "Pexp_tuple"
+ | Pexp_construct (id, eOpt, b) -> "Pexp_construct"
+ | Pexp_variant (lab, eOpt) -> "Pexp_variant"
+ | Pexp_record (ideList, eOpt) -> "Pexp_record"
+ | Pexp_field (e, id) -> "Pexp_field"
+ | Pexp_setfield (e1, id, e2) -> "Pexp_setfield"
+ | Pexp_array eList -> "Pexp_array"
+ | Pexp_ifthenelse (e1,e2,e3Opt) -> "Pexp_ifthenelse"
+ | Pexp_sequence (e1, e2) -> "Pexp_sequence"
+ | Pexp_while (e1, e2) -> "Pexp_while"
+ | Pexp_for (s, e1, e2, d, e3) -> "Pexp_for"
+ | Pexp_constraint (e, ty1Opt, ty2Opt) -> "Pexp_constraint"
+ | Pexp_when (e1, e2) -> "Pexp_when"
+ | Pexp_send (e, s) -> "Pexp_send"
+ | Pexp_new id -> "Pexp_new"
+ | Pexp_setinstvar (s, e) -> "Pexp_setinstvar"
+ | Pexp_override seList -> "Pexp_override"
+ | Pexp_letmodule (s, md, e) -> "Pexp_letmodule"
+ | Pexp_assert e -> "Pexp_assert"
+ | Pexp_assertfalse -> "Pexp_assertfalse"
+ | Pexp_lazy e -> "Pexp_lazy"
+ | Pexp_poly (e, tyOpt) -> "Pexp_poly"
+ | Pexp_object (p, cfList) -> "Pexp_object"
+ end
+ | Mod mdl ->
+ begin "Mod:" ^
+ match mdl.pmod_desc with
+ Pmod_ident id -> "Pmod_ident"
+ | Pmod_structure str -> "Pmod_structure"
+ | Pmod_functor (s, mty, md') -> "Pmod_functor"
+ | Pmod_apply (m1, m2) -> "Pmod_apply"
+ | Pmod_constraint (m, mty) -> "Pmod_constraint"
+ end
+ | Modty mty ->
+ begin "Modty:" ^
+ match mty.pmty_desc with
+ Pmty_ident id -> "Pmty_ident"
+ | Pmty_signature sgn -> "Pmty_signature"
+ | Pmty_functor (s, mty1, mty2) -> "Pmty_functor"
+ | Pmty_with (mt1, idwithList) -> "Pmty_with"
+ end
+ | Sigitem sit ->
+ begin "Sigitem:" ^
+ match sit.psig_desc with
+ Psig_value (s, valu) -> "Psig_value"
+ | Psig_type styList -> "Psig_type"
+ | Psig_exception (s, exn) -> "Psig_exception"
+ | Psig_module (s, mty) -> "Psig_module"
+ | Psig_recmodule smtyList -> "Psig_recmodule"
+ | Psig_modtype (s, mtydec) -> "Psig_modtype"
+ | Psig_open id -> "Psig_open"
+ | Psig_include mty -> "Psig_include"
+ | Psig_class cldecList -> "Psig_class"
+ | Psig_class_type cltydecList -> "Psig_class_type"
+ end
+ | Typ typ ->
+ begin "Typ:" ^
+ match typ.ptyp_desc with
+ Ptyp_any -> "Ptyp_any"
+ | Ptyp_var s -> "Ptyp_var"
+ | Ptyp_arrow (l, ty1, ty2) -> "Ptyp_arrow"
+ | Ptyp_tuple tyList -> "Ptyp_tuple"
+ | Ptyp_constr (id, tyList) -> "Ptyp_constr"
+ | Ptyp_object cftyList -> "Ptyp_object"
+ | Ptyp_class (id, tyList, labList) -> "Ptyp_class"
+ | Ptyp_alias (ty, s) -> "Ptyp_alias"
+ | Ptyp_variant (rfList, b, lablistOpt) -> "Ptyp_variant"
+ | Ptyp_poly (sList, ty) -> "Ptyp_poly"
+ end
+ | Cldec cli -> "Cldec"
+ | Cldesc cli -> "Cldesc"
+ | Cltydec cli -> "Cltydec"
+ | Clfield clf ->
+ begin "Clfield:" ^
+ match clf with
+ Pcf_inher (cle, s) -> "Pcf_inher"
+ | Pcf_val (s, mut, e, loc) -> "Pcf_val"
+ | Pcf_virt (s, priv, ty, loc) -> "Pcf_virt"
+ | Pcf_meth (s, priv, e, loc) -> "Pcf_meth"
+ | Pcf_cstr (ty1, ty2, loc) -> "Pcf_cstr"
+ | Pcf_let (r, peList, loc) -> "Pcf_let"
+ | Pcf_init e -> "Pcf_init"
+ end
+ | Clexp cle ->
+ begin "Clexp:" ^
+ match cle.pcl_desc with
+ Pcl_constr (id, tyList) -> "Pcl_constr"
+ | Pcl_structure (pat, clfieldList) -> "Pcl_structure"
+ | Pcl_fun (lab, eOpt, pat, clexp) -> "Pcl_fun"
+ | Pcl_apply (clexp, labeList) -> "Pcl_apply"
+ | Pcl_let (recflag, peList, clexp) -> "Pcl_let"
+ | Pcl_constraint (clexp, clty) -> "Pcl_constraint"
+ end
+ | Clty clty ->
+ begin "Clty:" ^
+ match clty.pcty_desc with
+ Pcty_constr (id, tyList) -> "Pcty_constr"
+ | Pcty_signature (ty, cltyfieldList) -> "Pcty_signature"
+ | Pcty_fun (l, ty, clty) -> "Pcty_fun"
+ end
+ | Cltyfield cltf ->
+ begin "Cltyfield:" ^
+ match cltf with
+ Pctf_inher clty -> "Pctf_inher"
+ | Pctf_val (s, mut, tyOpt, loc) -> "Pctf_val"
+ | Pctf_virt (s, privflag, ty, loc) -> "Pctf_virt"
+ | Pctf_meth (s, privflag, ty, loc) -> "Pctf_meth"
+ | Pctf_cstr (ty1, ty2, loc) -> "Pctf_cstr"
+ end
+ let printUniformAST (f : 'a -> string -> astThing -> unit) (x : 'a uniformAST) =
+ let rec printAST indent x =
+ f x.past_data indent x.past_node;
+ List.iter (printAST (indent ^ " ")) x.past_kids in
+ printAST "" x
+ let printNamedLocatedAST ast =
+ let printItem (name, loc) indent node =
+ print_string (indent ^ name ^ " "); Location.print std_formatter loc;
+ (* try
+ print_string (indent ^ (sourceFromLoc loc) ^ "\n")
+ with _ -> *) (print_string indent; smartPrintTo std_formatter node; print_string "\n") in
+ printUniformAST printItem ast
+ let makeNamedLocatedAST ast : (string * Location.t) uniformAST =
+ convertUniform (fun a -> (nameOf a, itemLocation a)) ast
+ let rec mapUniformAST (f : 'a -> 'b) (ast : 'a uniformAST) : 'b uniformAST =
+ let newKids = List.map (mapUniformAST f) ast.past_kids in
+ {ast with past_kids = newKids; past_data = (f ast.past_data)}
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+
+
+
+
+
+ (* XXXXXXXXXXXXXXXXXXXXX Find node type in typed AST XXXXXXXXXXXXXXXXXXXXXX *)
+ (* typeAST: (Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion) *)
+ exception FoundType of typedTreeType
+ let findType typedAst targetLoc =
+ let foundType typ = raise (FoundType typ) in
+ let rec findInStructure str : unit = List.iter findInStritem str
+ and findInStritem stritem : unit =
+ match stritem with
+ Typedtree.Tstr_eval e -> findInExp e
+ | Typedtree.Tstr_value (_, peList) -> List.iter (fun (p,e) -> findInPat p; findInExp e) peList
+ | Typedtree.Tstr_primitive (id, valdesc) -> ()
+ | Typedtree.Tstr_type idTydecs -> () (* no location info *)
+ | Typedtree.Tstr_exception (id, eDec) -> () (* no location info *)
+ | Typedtree.Tstr_exn_rebind _ -> ()
+ | Typedtree.Tstr_module (id, modexp) -> findInMod modexp
+ | Typedtree.Tstr_recmodule idmodList -> List.iter (fun (id,md) -> findInStritem (Typedtree.Tstr_module (id,md))) idmodList
+ | Typedtree.Tstr_modtype (id, modty) -> () (* no location info *)
+ | Typedtree.Tstr_open _ -> ()
+ | Typedtree.Tstr_class idisclexpList -> List.iter (fun (id, i, sList, clexp) ->
+ findInClexp clexp) idisclexpList
+ | Typedtree.Tstr_cltype _ -> () (* no location info *)
+ | Typedtree.Tstr_include (modexp, ids) -> findInMod modexp
+ and findInPat p : unit =
+ if (targetLoc = p.Typedtree.pat_loc) then foundType (SimpleType p.Typedtree.pat_type)
+ else if (locInside targetLoc p.Typedtree.pat_loc) then
+ begin
+ (match p.Typedtree.pat_desc with
+ Typedtree.Tpat_any -> ()
+ | Typedtree.Tpat_var _ -> ()
+ | Typedtree.Tpat_alias (p, _) -> findInPat p
+ | Typedtree.Tpat_constant _ -> ()
+ | Typedtree.Tpat_tuple pList -> List.iter findInPat pList
+ | Typedtree.Tpat_construct (constrDesc, pList) -> List.iter findInPat pList
+ | Typedtree.Tpat_variant (l, pOpt, rDesc) -> (match pOpt with None -> () | Some p' -> findInPat p')
+ | Typedtree.Tpat_record lpList -> List.iter (fun (l, p') -> findInPat p') lpList
+ | Typedtree.Tpat_array pList -> List.iter findInPat pList
+ | Typedtree.Tpat_or (p1, p2, _) -> findInPat p1; findInPat p2
+ );
+ foundType (SimpleType p.Typedtree.pat_type) (* was inside, but not any smaller... *)
+ end
+ and findInExp e : unit =
+ if (targetLoc = e.Typedtree.exp_loc) then foundType (SimpleType e.Typedtree.exp_type)
+ else if (locInside targetLoc e.Typedtree.exp_loc) then
+ begin
+ (match e.Typedtree.exp_desc with
+ Typedtree.Texp_ident _ -> ()
+ | Typedtree.Texp_constant _ -> ()
+ | Typedtree.Texp_let (_, peList, e) -> List.iter (fun (p,e) -> findInPat p; findInExp e) peList; findInExp e
+ | Typedtree.Texp_function (peList, _) -> List.iter (fun (p,e) -> findInPat p; findInExp e) peList
+ | Typedtree.Texp_apply (e, eooList) ->
+ findInExp e;
+ List.iter (fun (eOpt, _) -> match eOpt with None -> () | Some e' -> findInExp e') eooList
+ | Typedtree.Texp_match (e, peList, _)
+ | Typedtree.Texp_try (e, peList) -> findInExp e; List.iter (fun (p,e) -> findInPat p; findInExp e) peList
+ | Typedtree.Texp_tuple eList -> List.iter findInExp eList
+ | Typedtree.Texp_construct (constrDesc, eList) -> List.iter findInExp eList
+ | Typedtree.Texp_variant (_, eOpt) -> (match eOpt with None -> () | Some e' -> findInExp e')
+ | Typedtree.Texp_record (leList, eOpt) ->
+ List.iter (fun (_, e) -> findInExp e) leList;
+ (match eOpt with None -> () | Some e' -> findInExp e')
+ | Typedtree.Texp_field (e, _) -> findInExp e
+ | Typedtree.Texp_setfield (e1, _, e2) -> findInExp e1; findInExp e2
+ | Typedtree.Texp_array eList -> List.iter findInExp eList
+ | Typedtree.Texp_ifthenelse (e1, e2, e3Opt) -> findInExp e1; findInExp e2; (match e3Opt with None -> () | Some e' -> findInExp e')
+ | Typedtree.Texp_sequence (e1, e2) -> findInExp e1; findInExp e2
+ | Typedtree.Texp_while (e1, e2) -> findInExp e1; findInExp e2
+ | Typedtree.Texp_for (_, e1, e2, _, e3) -> findInExp e1; findInExp e2; findInExp e3
+ | Typedtree.Texp_when (e1, e2) -> findInExp e1; findInExp e2
+ | Typedtree.Texp_send (e, _) -> findInExp e
+ | Typedtree.Texp_new _ -> ()
+ | Typedtree.Texp_instvar _ -> ()
+ | Typedtree.Texp_setinstvar (_, _, e) -> findInExp e
+ | Typedtree.Texp_override (_, heList) -> List.iter (fun (path, e) -> findInExp e) heList
+ | Typedtree.Texp_letmodule (_, m, e) -> findInMod m; findInExp e
+ | Typedtree.Texp_assert e -> findInExp e
+ | Typedtree.Texp_assertfalse -> ()
+ | Typedtree.Texp_lazy e -> findInExp e
+ | Typedtree.Texp_object (clstr, clsig, _) -> findInClstr clstr
+ );
+ foundType (SimpleType e.Typedtree.exp_type) (* was inside, but not any smaller... *)
+ end
+ and findInMod m : unit =
+ if (targetLoc = m.Typedtree.mod_loc) then foundType (ModType m.Typedtree.mod_type)
+ else if (locInside targetLoc m.Typedtree.mod_loc) then
+ begin
+ (match m.Typedtree.mod_desc with
+ Typedtree.Tmod_ident _ -> ()
+ | Typedtree.Tmod_structure str -> findInStructure str
+ | Typedtree.Tmod_functor (id, mty, mexp) -> findInMod mexp
+ | Typedtree.Tmod_apply (m1, m2, mcoerce) -> findInMod m1; findInMod m2
+ | Typedtree.Tmod_constraint (mexp, mty, mcoerce) -> findInMod mexp
+ );
+ foundType (ModType m.Typedtree.mod_type) (* was inside, but not any smaller... *)
+ end
+ and findInClexp cl : unit =
+ if (targetLoc = cl.Typedtree.cl_loc) then foundType (ClassType cl.Typedtree.cl_type)
+ else if (locInside targetLoc cl.Typedtree.cl_loc) then
+ begin
+ (match cl.Typedtree.cl_desc with
+ Typedtree.Tclass_ident _ -> ()
+ | Typedtree.Tclass_structure cls -> findInClstr cls
+ | Typedtree.Tclass_fun (p, ideList, clexp, _) -> findInPat p; List.iter (fun (id, e) -> findInExp e) ideList; findInClexp clexp
+ | Typedtree.Tclass_apply (clexp, eooList) ->
+ findInClexp clexp; List.iter (fun (eOpt, _) -> match eOpt with None -> () | Some e -> findInExp e) eooList
+ | Typedtree.Tclass_let (rFlag, peList, ieList, clexp) ->
+ List.iter (fun (p,e) -> findInPat p; findInExp e) peList;
+ List.iter (fun (id, e) -> findInExp e) ieList;
+ findInClexp clexp
+ | Typedtree.Tclass_constraint (clexp, _, _, _) -> findInClexp clexp
+ );
+ foundType (ClassType cl.Typedtree.cl_type) (* was inside, but not any smaller... *)
+ end
+ and findInClstr cls =
+ List.iter (fun clf ->
+ match clf with
+ Typedtree.Cf_inher (clexp, _, _) -> findInClexp clexp
+ | Typedtree.Cf_val (_, _, e) -> findInExp e
+ | Typedtree.Cf_meth (_, e) -> findInExp e
+ | Typedtree.Cf_let (_, peList, ieList) ->
+ List.iter (fun (p,e) -> findInPat p; findInExp e) peList;
+ List.iter (fun (i,e) -> findInExp e) ieList
+ | Typedtree.Cf_init e -> findInExp e
+ ) cls.Typedtree.cl_field
+ in try
+ findInStructure typedAst;
+ NoType
+ with FoundType typ -> typ
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+
+
+
+
+
+
+ (* XXXXXXXXXXXXXXXXXXXX Collect Strings and Longidents XXXXXXXXXXXXXXXXXXXX *)
+ module StrLIdMap = Map.Make(struct type t = string let compare = compare end)
+ let safeLookup setref strlid =
+ try StrLIdMap.find (strlid) !setref with Not_found -> []
+ let safeUpdate setref strlid loc isDef = (* Normalize everything to a string *)
+ setref := StrLIdMap.add strlid ((loc, isDef)::(safeLookup setref strlid)) !setref
+
+ let astStrLIds = ref StrLIdMap.empty
+ let collectStrIDs ast =
+ let rec addStr str loc isDef = safeUpdate astStrLIds (str) loc isDef
+ and addId lid loc isDef = safeUpdate astStrLIds (longidentToStr lid) loc isDef
+
+ and findInStr str =
+ List.iter (fun stritem -> findInStritem stritem) str
+ and findInStritem stritem =
+ let loc = stritem.pstr_loc in
+ match stritem.pstr_desc with
+ Pstr_eval e -> findInExp e
+ | Pstr_value(rec_flag, peList) -> List.iter (fun (p,e) -> findInPat p; findInExp e) peList
+ | Pstr_primitive(prim, value_desc) -> addStr prim loc true; findInValue value_desc loc
+ | Pstr_type tytydecList -> List.iter (fun (typ, tydec) -> addStr typ loc true; findInTydec tydec) tytydecList
+ | Pstr_exception (exn, exDec) -> addStr exn loc true; List.iter findInTyp exDec
+ | Pstr_exn_rebind (str, id) -> addStr str loc true; addId id loc false
+ | Pstr_module (str, modexp) -> addStr str loc true; findInMod modexp
+ | Pstr_recmodule strModtyModexpList ->
+ List.iter (fun (str, mty, md) ->
+ addStr str loc true; findInModty mty; findInMod md) strModtyModexpList
+ | Pstr_modtype (str, mty) -> addStr str loc true; findInModty mty
+ | Pstr_open id -> addId id loc true
+ | Pstr_class cldecList -> List.iter findInCldec cldecList
+ | Pstr_class_type cltydecList -> List.iter findInCltydec cltydecList
+ | Pstr_include md -> findInMod md
+ and findInTydec tydec =
+ let loc = tydec.ptype_loc in
+ List.iter (fun str -> addStr str loc true) tydec.ptype_params;
+ List.iter (fun (t1, t2, loc) -> findInTyp t1; findInTyp t2) tydec.ptype_cstrs;
+ findInTykind tydec.ptype_kind loc;
+ (match tydec.ptype_manifest with
+ None -> () | Some t -> findInTyp t)
+ and findInTykind tkn loc =
+ match tkn with
+ Ptype_abstract -> ()
+ | Ptype_variant (strtyListList, priv_flag) ->
+ List.iter (fun (str, tylist) -> addStr str loc true; List.iter findInTyp tylist) strtyListList
+ | Ptype_record (strmuttyList, priv_flat) ->
+ List.iter (fun (str, mut, ty) -> addStr str loc true; findInTyp ty) strmuttyList
+ and findInValue valu loc =
+ findInTyp valu.pval_type; List.iter (fun str -> addStr str loc true) valu.pval_prim
+ and findInPat pat =
+ let loc = pat.ppat_loc in
+ match pat.ppat_desc with
+ Ppat_any -> ()
+ | Ppat_var str -> addStr str loc true
+ | Ppat_alias (pat, str) -> findInPat pat; addStr str loc false
+ | Ppat_constant c -> ()
+ | Ppat_tuple pList -> List.iter findInPat pList
+ | Ppat_construct (id, pOpt, b) ->
+ addId id loc false; (match pOpt with None -> () | Some p -> findInPat p)
+ | Ppat_variant (lab, pOpt) ->
+ addStr lab loc false; (match pOpt with None -> () | Some p -> findInPat p)
+ | Ppat_record idpatList ->
+ List.iter (fun (id, pat) -> addId id loc false; findInPat pat) idpatList
+ | Ppat_array pList -> List.iter findInPat pList
+ | Ppat_or (p1, p2) -> findInPat p1; findInPat p2
+ | Ppat_constraint (p, ty) -> findInPat p; findInTyp ty
+ | Ppat_type id -> addId id loc false
+ and findInExp exp =
+ let loc = exp.pexp_loc in
+ let findInPEList peList =
+ List.iter (fun (p, e) -> findInPat p; findInExp e) peList in
+ match exp.pexp_desc with
+ Pexp_ident id -> addId id loc false
+ | Pexp_constant c -> ()
+ | Pexp_let (recf, peList, e) -> findInPEList peList; findInExp e
+ | Pexp_function (lab, eOpt, peList) ->
+ addStr lab loc false; findInPEList peList;
+ (match eOpt with None -> () | Some e -> findInExp e)
+ | Pexp_apply (e, leList) -> findInExp e;
+ List.iter (fun (l, e) -> addStr l loc false; findInExp e) leList
+ | Pexp_match (e, peList) -> findInExp e; findInPEList peList
+ | Pexp_try (e, peList) -> findInExp e; findInPEList peList
+ | Pexp_tuple eList -> List.iter findInExp eList
+ | Pexp_construct (id, eOpt, b) -> addId id loc false; (match eOpt with None -> () | Some e -> findInExp e)
+ | Pexp_variant (lab, eOpt) -> addStr lab loc false; (match eOpt with None -> () | Some e -> findInExp e)
+ | Pexp_record (ideList, eOpt) ->
+ List.iter (fun (id, e) -> addId id loc false; findInExp e) ideList;
+ (match eOpt with None -> () | Some e -> findInExp e)
+ | Pexp_field (e, id) -> findInExp e; addId id loc false
+ | Pexp_setfield (e1, id, e2) -> findInExp e1; addId id loc false; findInExp e2
+ | Pexp_array eList -> List.iter findInExp eList
+ | Pexp_ifthenelse (e1,e2,e3Opt) -> findInExp e1; findInExp e2;
+ (match e3Opt with None -> () | Some e -> findInExp e)
+ | Pexp_sequence (e1, e2) -> findInExp e1; findInExp e2
+ | Pexp_while (e1, e2) -> findInExp e1; findInExp e2
+ | Pexp_for (s, e1, e2, d, e3) -> addStr s loc true; findInExp e1; findInExp e2; findInExp e3
+ | Pexp_constraint (e, ty1Opt, ty2Opt) -> findInExp e;
+ (match ty1Opt with None -> () | Some t -> findInTyp t);
+ (match ty2Opt with None -> () | Some t -> findInTyp t)
+ | Pexp_when (e1, e2) -> findInExp e1; findInExp e2
+ | Pexp_send (e, s) -> findInExp e; addStr s loc false
+ | Pexp_new id -> addId id loc false
+ | Pexp_setinstvar (s, e) -> addStr s loc false; findInExp e
+ | Pexp_override seList -> List.iter (fun (s, e) -> addStr s loc false; findInExp e) seList
+ | Pexp_letmodule (s, md, e) -> addStr s loc true; findInMod md; findInExp e
+ | Pexp_assert e -> findInExp e;
+ | Pexp_assertfalse -> ()
+ | Pexp_lazy e -> findInExp e
+ | Pexp_poly (e, tyOpt) -> findInExp e;
+ (match tyOpt with None -> () | Some t -> findInTyp t)
+ | Pexp_object (p, cfList) -> findInPat p; List.iter (fun clfield -> findInClfield clfield loc) cfList
+ and findInMod md =
+ let loc = md.pmod_loc in
+ match md.pmod_desc with
+ Pmod_ident id -> addId id loc false
+ | Pmod_structure str -> findInStr str
+ | Pmod_functor (s, mty, md) -> addStr s loc true; findInModty mty; findInMod md
+ | Pmod_apply (md1, md2) -> findInMod md1; findInMod md2
+ | Pmod_constraint (md, mty) -> findInMod md; findInModty mty
+ and findInModty mty =
+ let loc = mty.pmty_loc in
+ match mty.pmty_desc with
+ Pmty_ident id -> addId id loc false
+ | Pmty_signature sigList -> List.iter findInSigitem sigList
+ | Pmty_functor (s, mty1, mty2) -> addStr s loc true; findInModty mty1; findInModty mty2
+ | Pmty_with (mty, idconstrList) -> findInModty mty;
+ List.iter (fun (id, constr) -> addId id loc true;
+ match constr with
+ Pwith_type tydec -> findInTydec tydec
+ | Pwith_module id -> addId id loc false) idconstrList
+ and findInSigitem sigitem =
+ let loc = sigitem.psig_loc in
+ match sigitem.psig_desc with
+ Psig_value (s, valu) -> addStr s loc true; findInValue valu loc
+ | Psig_type styList -> List.iter (fun (s, ty) -> addStr s loc true; findInTydec ty) styList
+ | Psig_exception (s, tyList) -> addStr s loc true; List.iter findInTyp tyList
+ | Psig_module (s, mty) -> addStr s loc true; findInModty mty
+ | Psig_recmodule smtyList -> List.iter (fun (s, mty) -> addStr s loc true; findInModty mty) smtyList
+ | Psig_modtype (s, mtydec) -> addStr s loc true;
+ (match mtydec with Pmodtype_abstract -> () | Pmodtype_manifest mty -> findInModty mty)
+ | Psig_open id -> addId id loc false
+ | Psig_include mty -> findInModty mty
+ | Psig_class cldecList -> List.iter findInCldesc cldecList
+ | Psig_class_type cltydecList -> List.iter findInCltydec cltydecList
+ and findInTyp ty =
+ let loc = ty.ptyp_loc in
+ match ty.ptyp_desc with
+ Ptyp_any -> ()
+ | Ptyp_var s -> addStr s loc false
+ | Ptyp_arrow (l, t1, t2) -> addStr l loc false; findInTyp t1; findInTyp t2
+ | Ptyp_tuple tList -> List.iter findInTyp tList
+ | Ptyp_constr (id, tList) -> addId id loc false; List.iter findInTyp tList
+ | Ptyp_object cftList -> List.iter findInCfty cftList
+ | Ptyp_class (id, tList, lList) -> addId id loc true; List.iter (fun str -> addStr str loc false) lList; List.iter findInTyp tList
+ | Ptyp_alias (ty, s) -> findInTyp ty; addStr s loc false
+ | Ptyp_variant (rList, b, lListOpt) -> List.iter (fun rf -> findInRfield rf loc) rList;
+ (match lListOpt with None -> () | Some lList -> List.iter (fun str -> addStr str loc false) lList)
+ | Ptyp_poly (sList, ty) -> findInTyp ty; List.iter (fun str -> addStr str loc false) sList
+ and findInRfield rf loc =
+ match rf with
+ Rtag (l, b, tList) -> addStr l loc true; List.iter findInTyp tList
+ | Rinherit ty -> findInTyp ty
+ and findInCfty cft =
+ let loc = cft.pfield_loc in
+ match cft.pfield_desc with
+ Pfield (s, ty) -> addStr s loc false; findInTyp ty
+ | Pfield_var -> ()
+ and findInCldec cli =
+ let loc = cli.pci_loc in
+ List.iter (fun str -> addStr str loc true) (fst cli.pci_params);
+ addStr cli.pci_name loc true;
+ findInClexp cli.pci_expr
+ and findInCldesc cli =
+ let loc = cli.pci_loc in
+ List.iter (fun str -> addStr str loc true) (fst cli.pci_params);
+ addStr cli.pci_name loc true;
+ findInClty cli.pci_expr
+ and findInCltydec cli = findInCldesc cli
+ and findInClfield clfield loc =
+ match clfield with
+ Pcf_inher (clexp, sOpt) -> findInClexp clexp;
+ (match sOpt with None -> () | Some s -> addStr s loc true)
+ | Pcf_val (s, mut, e, loc) -> addStr s loc true; findInExp e
+ | Pcf_virt (s, priv, ty, loc) -> addStr s loc true; findInTyp ty
+ | Pcf_meth (s, priv, e, loc) -> addStr s loc true; findInExp e
+ | Pcf_cstr (t1, t2, loc) -> findInTyp t1; findInTyp t2
+ | Pcf_let (r, peList, loc) -> List.iter (fun (p, e) -> findInPat p; findInExp e) peList
+ | Pcf_init e -> findInExp e
+ and findInClexp cle =
+ let loc = cle.pcl_loc in
+ match cle.pcl_desc with
+ Pcl_constr (id, tyList) -> addId id loc true; List.iter findInTyp tyList
+ | Pcl_structure (p, cfList) -> findInPat p; List.iter (fun clfield -> findInClfield clfield loc) cfList
+ | Pcl_fun (l, eOpt, p, cle) -> addStr l loc true; findInPat p; findInClexp cle;
+ (match eOpt with None -> () | Some e -> findInExp e)
+ | Pcl_apply (cle, leList) -> findInClexp cle; List.iter (fun (l, e) -> addStr l loc false; findInExp e) leList
+ | Pcl_let (r, peList, cle) -> findInClexp cle; List.iter (fun (p, e) -> findInPat p; findInExp e) peList
+ | Pcl_constraint (cle, clt) -> findInClexp cle; findInClty clt
+ and findInClty clt =
+ let loc = clt.pcty_loc in
+ match clt.pcty_desc with
+ Pcty_constr (id, tyList) -> addId id loc true; List.iter findInTyp tyList
+ | Pcty_signature (ty, ctfList) -> findInTyp ty; List.iter (fun ctf -> findInCltyfield ctf loc) ctfList
+ | Pcty_fun (l, t, clty) -> addStr l loc false; findInTyp t; findInClty clty
+ and findInCltyfield ctf loc =
+ match ctf with
+ Pctf_inher cty -> findInClty cty
+ | Pctf_val (s, mut, tOpt, loc') -> addStr s loc false; (match tOpt with None -> () | Some t -> findInTyp t)
+ | Pctf_virt (s, priv, ty, loc') -> addStr s loc false; findInTyp ty
+ | Pctf_meth (s, priv, ty, loc') -> addStr s loc false; findInTyp ty
+ | Pctf_cstr (t1, t2, loc') -> findInTyp t1; findInTyp t2
+ in
+ astStrLIds := StrLIdMap.empty;
+ findInStr ast
+
+ let strLIdsOf ast =
+ let temp = !astStrLIds in
+ collectStrIDs ast;
+ let result = !astStrLIds in
+ astStrLIds := temp;
+ result
+
+
+ let nearestDefStrLId strlid loc = (* nearest definition of strlid from given loc *)
+ try
+ (* locations are in reversed pre-order, which means that the first location
+ * in the list is the last location in the source file *)
+ Some (List.find (fun (defloc, isdef) -> isdef && locAfter loc defloc)
+ (safeLookup astStrLIds strlid))
+ with Not_found -> None
+ let reachingDefStrLId loc = (* all other definitions which reach this location *)
+ StrLIdMap.fold (fun strlid loclist acc ->
+ let reachingdefs = (List.filter (fun (defloc, isdef) -> isdef && locAfter loc defloc) loclist) in
+ if reachingdefs != [] then StrLIdMap.add strlid reachingdefs acc else acc
+ ) !astStrLIds StrLIdMap.empty
+
+ let printStrLIdMap map =
+ StrLIdMap.iter (fun strlid deflocs ->
+ print_string ("Str: \'" ^ strlid ^ "\' => [\n");
+ List.iter (fun (loc, isdef) -> print_string (if isdef then "Def: " else " ");
+ Location.print std_formatter loc) deflocs;
+ print_string "]\n") map
+
+
+ let tryStrs loc f =
+ (* (let temp = reachingDefStrLId loc in
+ print_string "Printing reaching defs for "; Location.print std_formatter loc;
+ printStrLIdMap temp); *)
+ StrLIdMap.fold (fun s _ acc -> (f s)::acc) !astStrLIds []
+
+
+
+ (* Based on Longest Common Subsequence algorithm from CLRS, sec15.4 *)
+ let stringEditDistance s1 s2 =
+ let len1 = String.length s1 in
+ let len2 = String.length s2 in
+ let idDist = Array.make_matrix (len1+1) (len2+1) 0 in
+ for i = 0 to len1 do
+ idDist.(i).(0) <- i
+ done;
+ for j = 0 to len2 do
+ idDist.(0).(j) <- j
+ done;
+ for j = 1 to len2 do
+ for i = 1 to len1 do
+ idDist.(i).(j) <- 1+ (min idDist.(i-1).(j) idDist.(i).(j-1));
+ if (s1.[i-1] = s2.[j-1]) then
+ idDist.(i).(j) <- (min idDist.(i).(j) idDist.(i-1).(j-1));
+ done
+ done;
+ idDist.(len1).(len2)
+
+
+
+ module CachedIDIDsMap = Map.Make(struct type t = string let compare = compare end)
+ let strIDsCache = ref CachedIDIDsMap.empty
+ module StrIDStrs = Set.Make(struct type t = string let compare = compare end)
+ let allStrIDs = ref StrIDStrs.empty
+ let tryIDs id loc f =
+ (* (let temp = reachingDefStrLId loc in
+ print_string "Printing reaching defs for "; Location.print std_formatter loc;
+ printStrLIdMap temp); *)
+ let asLId strlid = strToLongident strlid in
+ let asStr strlid = strlid in
+ let refstr = longidentToStr id in
+ let compareStrIDsTo refstr str1 str2 =
+ let strdist = compare (stringEditDistance refstr str1) (stringEditDistance refstr str2) in
+ if strdist = 0 then compare str1 str2 else strdist in
+ if !allStrIDs = StrIDStrs.empty then
+ allStrIDs := StrLIdMap.fold (fun s _ acc -> StrIDStrs.add (asStr s) acc) !astStrLIds StrIDStrs.empty;
+ if (CachedIDIDsMap.mem refstr !strIDsCache) then
+ List.rev_map f (CachedIDIDsMap.find refstr !strIDsCache)
+ else begin
+ let res = List.map (fun s -> (s, stringEditDistance refstr s)) (StrIDStrs.elements !allStrIDs) in
+ let res = fst (List.split (List.sort (fun (s1,d1) (s2,d2) -> compare d1 d2) res)) in
+ let rec first n lst acc =
+ if n = 0 then acc else
+ match lst with
+ [] -> acc
+ | hd::tl -> first (n-1) tl ((strToLongident hd)::acc ) in
+ let res = first 10 res [] in
+ strIDsCache := CachedIDIDsMap.add refstr res (!strIDsCache);
+ List.rev_map f res
+ end
+
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+ (* XXXXXXXXXXXXXXXXXXX Collect top-level type constructors XXXXXXXXXXXXXXXX *)
+ let astTypeIds = ref StrLIdMap.empty
+ let collectTypeIDs ast =
+ let rec addStr str loc isShadow = safeUpdate astTypeIds (str) loc isShadow
+ and findInStr str =
+ List.iter (fun stritem -> findInStritem stritem) str
+ and findInStritem stritem =
+ match stritem.pstr_desc with
+ Pstr_type tytydecList -> List.iter (fun (typ, tydec) -> findInTydec tydec) tytydecList
+ | _ -> ()
+ and findInTydec tydec =
+ let loc = tydec.ptype_loc in
+ findInTykind tydec.ptype_kind loc;
+ and findInTykind tkn loc =
+ match tkn with
+ Ptype_abstract -> ()
+ | Ptype_variant (strtyListList, priv_flag) ->
+ List.iter (fun (str, tylist) ->
+ let prevBindings = safeLookup astTypeIds str in
+ match prevBindings with
+ [] -> addStr str loc false
+ | (loc', shadowed)::tl -> addStr str loc' true) strtyListList
+ | Ptype_record (strmuttyList, priv_flat) -> ()
+ in
+ astTypeIds := StrLIdMap.empty;
+ findInStr ast
+
+ let findShadowedIDs ast =
+ let unAst = match ast with
+ Str a -> a
+ | Exp a -> [{pstr_desc = Pstr_eval a; pstr_loc = !locNone}]
+ | StrItem a -> [a]
+ | Pat a -> [{pstr_desc = Pstr_value (Asttypes.Default, [a, alphaExp "NOT_A_MATCH" !locNone]); pstr_loc = !locNone}]
+ | Typ a -> [{pstr_desc = Pstr_eval {pexp_desc = Pexp_poly (alphaExp "NOT_A_MATCH" !locNone, Some a); pexp_loc = !locNone}; pstr_loc = !locNone}]
+ | Mod a -> [{pstr_desc = Pstr_module ("NOT_A_MATCH", a); pstr_loc = !locNone}]
+ | Modty a -> [{pstr_desc = Pstr_modtype ("NOT_A_MATCH", a); pstr_loc = !locNone}]
+ | Tydec a -> [{pstr_desc = Pstr_type ["NOT_A_MATCH", a]; pstr_loc = !locNone}]
+ | Cldec a -> [{pstr_desc = Pstr_class [a]; pstr_loc = !locNone}]
+ | Cldesc a -> [{pstr_desc = Pstr_modtype ("NOT_A_MATCH", {pmty_desc = Pmty_signature [{psig_desc = Psig_class [a]; psig_loc = !locNone}]; pmty_loc = !locNone}); pstr_loc = !locNone}]
+ | Cltydec a -> [{pstr_desc = Pstr_class_type [a]; pstr_loc = !locNone}]
+ | Clfield a -> [{pstr_desc = Pstr_class [{pci_virt = Asttypes.Concrete;
+ pci_params = ([], !locNone);
+ pci_name = "NOT_A_MATCH";
+ pci_expr = {pcl_desc = Pcl_structure (alphaPat !locNone, [a]);
+ pcl_loc = !locNone};
+ pci_variance = [];
+ pci_loc = !locNone}];
+ pstr_loc = !locNone}]
+ | Clexp a -> [{pstr_desc = Pstr_class [{pci_virt = Asttypes.Concrete; pci_params = ([], !locNone); pci_name = "NOT_A_MATCH"; pci_expr = a; pci_variance = []; pci_loc = !locNone}]; pstr_loc = !locNone}]
+ | Sigitem a -> [{pstr_desc = Pstr_modtype ("NOT_A_MATCH", {pmty_desc = Pmty_signature [a]; pmty_loc = !locNone}); pstr_loc = !locNone}]
+ | Clty a -> [{pstr_desc = Pstr_modtype ("NOT_A_MATCH", {pmty_desc = Pmty_signature [{psig_desc = Psig_class [{pci_virt = Asttypes.Concrete;
+ pci_params = ([], !locNone);
+ pci_name = "NOT_A_MATCH";
+ pci_expr = a; pci_variance = [];
+ pci_loc = !locNone}];
+ psig_loc = !locNone}];
+ pmty_loc = !locNone});
+ pstr_loc = !locNone}]
+ | Cltyfield a -> [{pstr_desc = Pstr_modtype ("NOT_A_MATCH", {pmty_desc = Pmty_signature [{psig_desc = Psig_class_type [{pci_virt = Asttypes.Concrete;
+ pci_params = ([], !locNone);
+ pci_name = "NOT_A_MATCH";
+ pci_expr = {pcty_desc = Pcty_signature (alphaTyp !locNone, [a]);
+ pcty_loc = !locNone};
+ pci_variance = [];
+ pci_loc = !locNone}];
+ psig_loc = !locNone}];
+ pmty_loc = !locNone});
+ pstr_loc = !locNone}]
+ in
+
+ let ids = strLIdsOf unAst in
+ StrLIdMap.fold (fun id binding shadowed ->
+ match safeLookup astTypeIds id with
+ (_, true)::tl -> id :: shadowed
+ | _ -> shadowed) ids []
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+
+
+
+
+
+
+
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXX Single-point Modification Enumerators XXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+ let totalFixNesteds = ref 0
+ let totalDelays = ref 0
+ let matchCache : expression list ref = ref []
+ let matchCacheExceptions : expression list ref = ref []
+ let fixNestedTrysMatchsFunctions exp =
+ let replaceExp = replaceExp (Exp exp) in (* pre-bind the first argument *)
+ totalFixNesteds := !totalFixNesteds + 1;
+ let catchAll = (alphaPat !locNone, alphaExp "temporaryPlaceholder" !locNone) in
+ let rec lastSeq e =
+ match e.pexp_desc with
+ Pexp_sequence(_, e') -> lastSeq e'
+ | Pexp_let(_, _, e') -> lastSeq e'
+ | _ -> e in
+ let flattenDepthPEList peList =
+ let rec flattenPE d revPEList (pat, exp) =
+ let flattenPE = flattenPE (d+1) in
+ match exp.pexp_desc with
+ Pexp_match(e', peList') -> List.fold_left flattenPE ((d, (pat, {exp with pexp_desc = Pexp_match(e', [])})) :: revPEList) peList'
+ | Pexp_try(e', peList') -> List.fold_left flattenPE ((d, (pat, {exp with pexp_desc = Pexp_try(e', [])})) :: revPEList) peList'
+ | Pexp_function(l', dOpt', peList') -> List.fold_left flattenPE ((d, (pat, {exp with pexp_desc = Pexp_function(l', dOpt', [])})) :: revPEList) peList'
+ | Pexp_sequence(e1, e2) ->
+ let flattenTail = List.rev (flattenPE [] (pat, e2)) in (* pat doesn't really matter, since it can only be used in the head of the returned list, which will be modified anyway *)
+ (match flattenTail with
+ [] -> (d, (pat, exp)) :: revPEList
+ | hd::tl ->
+ List.rev_append tl ((d, (pat, {exp with pexp_desc = Pexp_sequence(e1, snd (snd hd))})) :: revPEList) (* this takes the front of the list, and wraps the sequence back around it *)
+ )
+ | Pexp_let(r, peList, e) ->
+ let flattenTail = List.rev (flattenPE [] (pat, e)) in (* pat doesn't really matter, since it can only be used in the head of the returned list, which will be modified anyway *)
+ (match flattenTail with
+ [] -> (d, (pat, exp)) :: revPEList
+ | hd::tl ->
+ List.rev_append tl ((d, (pat, {exp with pexp_desc = Pexp_let(r, peList, snd (snd hd))})) :: revPEList) (* this takes the front of the list, and wraps the let back around it *)
+ )
+ | _ -> (d, (pat, exp)) :: revPEList in
+ List.rev (List.fold_left (flattenPE 0) [] peList) in
+ let flattenPEList peList = (List.map snd (flattenDepthPEList peList)) in
+ let rec stripTemporaries exp =
+ let filterCA peList = List.filter (function pe -> pe <> catchAll) peList in
+ let peStrip (p, e) = (p, stripTemporaries e) in
+ let recStrip peList = List.map peStrip (filterCA peList) in
+ match exp.pexp_desc with
+ Pexp_match(e', peList) -> {exp with pexp_desc = Pexp_match(e', recStrip peList)}
+ | Pexp_try(e', peList) -> {exp with pexp_desc = Pexp_try(e', recStrip peList)}
+ | Pexp_function(l', dOpt, peList) -> {exp with pexp_desc = Pexp_function(l', dOpt, recStrip peList)}
+ | Pexp_let(r, peList, e') -> {exp with pexp_desc = Pexp_let(r, peList, stripTemporaries e')}
+ | Pexp_sequence(e1, e2) -> {exp with pexp_desc = Pexp_sequence(e1, stripTemporaries e2)}
+ | _ -> exp in
+ let checkNoTemporaries exp =
+ match exp.pexp_desc with
+ Pexp_match(_, peList) | Pexp_try(_, peList) | Pexp_function(_, _, peList) ->
+ not (List.exists (function pe -> pe = catchAll) (flattenPEList peList))
+ | _ -> true in
+ let checkRightLength exp target =
+ match exp.pexp_desc with
+ Pexp_match(_, peList) | Pexp_try(_, peList) | Pexp_function(_, _, peList) ->
+ List.length(flattenPEList peList) = target
+ | _ -> true in
+ let rec checkNoEmpties exp =
+ match exp.pexp_desc with
+ Pexp_match(_, peList) | Pexp_try(_, peList) | Pexp_function(_, _, peList) ->
+ (List.length peList > 0) && (List.for_all (checkNoEmpties <<== snd) peList)
+ | Pexp_sequence(e1, e2) -> checkNoEmpties e2
+ | Pexp_let(r, peList, e) -> checkNoEmpties e
+ | _ -> true in
+ let rebuildToSingleRecur e' followupMods target =
+ (followup [replaceExp (declareException "temporaryPlaceholder")
+ (function () -> e')
+ (function _ -> (checkNoTemporaries e') && (checkRightLength e' target) && (checkNoEmpties e'))
+ "Reparenthesized nested matches, trys or functions one at a time."
+ (t("Exp_TryMatch_Reparenthesize"))
+ exp.pexp_loc]
+ followupMods) in
+ let rebuildNestedTryMatch (exp' : expression) : astMod list =
+ let rec appendToExp exp peAppend = (* attaches the (pat, exp) pair peAppend to any open match or try in exp *)
+ let mapAllNewPELists newExpDesc peList' = List.map (function peList -> {exp with pexp_desc = newExpDesc peList}) (allNewPELists peList' peAppend) in
+ match exp.pexp_desc with
+ Pexp_match(e', peList) -> mapAllNewPELists (fun peL -> Pexp_match(e', peL)) peList
+ | Pexp_try(e', peList) -> mapAllNewPELists (fun peL -> Pexp_try(e', peL)) peList
+ | Pexp_function(l', dOpt, peList) -> mapAllNewPELists (fun peL -> Pexp_function(l', dOpt, peL)) peList
+ | Pexp_sequence(e1, e2) ->
+ List.map (function e2' -> {exp with pexp_desc = Pexp_sequence(e1, e2')}) (appendToExp e2 peAppend)
+ | Pexp_let(r, peList, e) ->
+ List.map (function e' -> {exp with pexp_desc = Pexp_let(r, peList, e')}) (appendToExp e peAppend)
+ | _ -> []
+ and allNewPELists peList peAdd =
+ let revPeList = List.rev peList in
+ match revPeList with
+ ca :: (p,e) :: front when (ca = catchAll) -> rebuildPELists peAdd (p,e) front
+ | (p, e) :: front -> rebuildPELists peAdd (p,e) front (* can't be one case because of the guard *)
+ | [] -> [[peAdd; catchAll]]
+ and rebuildPELists peAdd (p,e) front =
+ let insertPE = List.rev (catchAll :: peAdd :: (p,e) :: front) in
+ let recursiveInsertPE =
+ (match e.pexp_desc with
+ Pexp_match _ | Pexp_try _ | Pexp_function _ | Pexp_sequence _ | Pexp_let _ ->
+ List.map (function e' -> List.rev (catchAll :: (p, e') :: front)) (appendToExp e peAdd)
+ | _ -> []) in
+ insertPE :: recursiveInsertPE in
+ let rec delaySingleRecurs exp peList targetLen : astMod list =
+ totalDelays := !totalDelays + 1;
+ match peList with
+ [] -> [rebuildToSingleRecur (stripTemporaries exp) (function _ -> []) targetLen]
+ | pe'' :: peList' ->
+ let allAppends = appendToExp exp pe'' in
+ let laterSingleRecurs expWpe = function _ -> (delaySingleRecurs expWpe peList' targetLen) in (* expWpe is exp, with pe appended within it *)
+ List.map (function expWpe -> rebuildToSingleRecur exp (laterSingleRecurs expWpe) targetLen) allAppends in
+ let flattenAndDelay newExpDesc peList =
+ let flat = (flattenPEList peList) in
+ delaySingleRecurs {exp' with pexp_desc = newExpDesc} flat (List.length flat) in
+ match exp'.pexp_desc with
+ Pexp_match(e', peList') -> flattenAndDelay (Pexp_match(e', [])) peList'
+ | Pexp_try(e', peList') -> flattenAndDelay (Pexp_try(e', [])) peList'
+ | Pexp_function(l', dOpt', peList') -> flattenAndDelay (Pexp_function(l', dOpt', [])) peList'
+ | _ -> [] in
+ let isNestedTryMatch peList =
+ List.exists (function pat_exp ->
+ match (lastSeq (snd pat_exp)).pexp_desc with
+ Pexp_match _ | Pexp_try _ | Pexp_function _ -> true
+ | _ -> false) peList in
+ let flatPEList exp = match exp.pexp_desc with
+ Pexp_match(_, peList) | Pexp_try(_, peList) | Pexp_function(_, _, peList) -> flattenPEList peList | _ -> [] in
+ let isCached exp =
+ let flatPE = flatPEList exp in
+ (List.exists (fun exp' -> locInside exp.pexp_loc exp'.pexp_loc && (flatPEList exp') = flatPE) !matchCache) &&
+ not (List.exists (fun exp' -> locInside exp.pexp_loc exp'.pexp_loc) !matchCacheExceptions) in
+ let cache suggestions =
+ matchCache := exp :: !matchCache;
+ let rec whitelistLeftSeqs exp =
+ match exp.pexp_desc with
+ Pexp_sequence(e1, e2) -> matchCacheExceptions := e1 :: !matchCacheExceptions
+ | Pexp_let(r, peList, e) -> matchCacheExceptions := List.rev_append (List.map snd peList) !matchCacheExceptions
+ | Pexp_match(_, peList) | Pexp_try(_, peList) | Pexp_function(_, _, peList) ->
+ List.iter (fun (_,e) -> whitelistLeftSeqs e) peList
+ | _ -> ()
+ in whitelistLeftSeqs exp;
+ suggestions in
+ match exp.pexp_desc with
+ Pexp_match(_, pat_exp_list) | Pexp_try(_, pat_exp_list) | Pexp_function(_, _, pat_exp_list) ->
+ if (isNestedTryMatch pat_exp_list) then begin
+ if (isCached exp) then ((* print_string "cached, ignoring\n"; Printcode.expression std_formatter exp; *) print_string "\n"; [])
+ else ((* print_string "Not ignored: "; Printcode.expression std_formatter exp; print_string "\n"; *) cache (rebuildNestedTryMatch exp))
+ end else []
+ | _ -> assert false; []
+
+
+
+
+ let destructStr str locOpt =
+ let replaceStr = replaceStr (Str str) in (* pre-bind the first argument *)
+ match locOpt with
+ None -> []
+ | Some loc ->
+ let truncatedStructure =
+ List.rev (List.filter (function sItem -> locBefore sItem.pstr_loc loc || locInside loc sItem.pstr_loc) str)
+ in
+ begin match truncatedStructure with
+ [] -> []
+ | hd :: tl ->
+ [recurStritemStr (hd, (function str_item' -> List.rev (str_item' :: tl)))]
+ end
+
+ let destructStrItem strItem locOpt =
+ let replaceStritem = replaceStritem (StrItem strItem) in (* pre-bind the first argument *)
+ if not (shouldTryFix strItem.pstr_loc locOpt) then [] else
+ let genericSingleReplacement =
+ (replaceStritem (declareException "RemoveStritem")
+ (function () -> alphaStritem "RemoveStritem" strItem.pstr_loc)
+ alwaysValid
+ "Replaced stritem with _"
+ (t("Stritem_Remove"))
+ strItem.pstr_loc) in
+ let otherSingleReplacements =
+ match strItem.pstr_desc with
+ Pstr_eval e ->
+ (* let _ = e, so just evaluate e *)
+ (* Possible errors:
+ * Any expression error
+ *)
+ (* Possible fixes:
+ * fixing the subexpression
+ *)
+ [recurExpStritem (e, (function exp' -> {strItem with pstr_desc = Pstr_eval exp'}))]
+ | Pstr_value(rec_flag, pat_exp_list) ->
+ (* let (rec) bindings *)
+ (* Possible errors:
+ * Any errors in bindings
+ *)
+ (* Possible fixes:
+ * deleting the whole list
+ * marking the pattern recursive if it wasn't already
+ * fixing an individual expression to match the pattern it's bound to
+ * fixing an individual pattern to not constrain the expression it binds
+ *)
+ let removeAll =
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_value (Asttypes.Recursive, [])})
+ alwaysValid
+ ("Removed the binding list at " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_Value_RemoveAll"))
+ strItem.pstr_loc) in
+ let fixRec =
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_value (Asttypes.Recursive, pat_exp_list)})
+ alwaysValid
+ ("Added rec flag to " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_Value_FixRec"))
+ strItem.pstr_loc) in
+ let fixPatExps =
+ let processSinglePatExp n (pat, exp) =
+ [
+ recurPatStritem (pat, (function pat' ->
+ {strItem with pstr_desc =
+ Pstr_value(rec_flag, (replaceNthWith pat_exp_list n (pat', exp)))}));
+ recurExpStritem (exp, (function exp' ->
+ {strItem with pstr_desc =
+ Pstr_value(rec_flag, (replaceNthWith pat_exp_list n (pat, exp')))}));
+ ] in
+ map_at_and_flatten processSinglePatExp pat_exp_list in
+ if (rec_flag <> Asttypes.Recursive)
+ then fixRec :: removeAll :: fixPatExps
+ else removeAll :: fixPatExps
+ | Pstr_primitive(prim, value_desc) ->
+ (* external foo : tau = "c-function" *)
+ (* Possible errors:
+ * Any type error from transl_type
+ *)
+ (* Possible fixes:
+ * fix the type
+ *)
+ [recurTypStritem (value_desc.pval_type, (function ty' ->
+ {strItem with pstr_desc =
+ Pstr_primitive (prim, {pval_type = ty';
+ pval_prim = value_desc.pval_prim})}));
+ ]
+ | Pstr_type str_ty_list ->
+ (* type declarations *)
+ (* Possible errors:
+ * Any type error from transl_type
+ *)
+ (* Possible fixes:
+ * fix a type subexpression
+ *)
+ let fixStrTys =
+ let processSingleStrTy n (str, ty) =
+ recurTypdecStritem (ty, (function ty' ->
+ {strItem with pstr_desc =
+ Pstr_type (replaceNthWith str_ty_list n (str, ty'))}))
+ in
+ map_at processSingleStrTy str_ty_list
+ in fixStrTys
+ | Pstr_exception(name, exn) ->
+ (* exception Foo of Bar *)
+ (* Possible errors:
+ * Any error from transl_type
+ *)
+ (* Possible fixes:
+ * remove the body list altogether
+ * generalize one of the types in the list -- but polymorphic exceptions not allowed? not sure what to do
+ *)
+ [(replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_exception(name, [])})
+ alwaysValid
+ ("Removed body of exception constructor " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_Exception_RemoveBody"))
+ strItem.pstr_loc)
+ ]
+ | Pstr_exn_rebind(newName, oldName) ->
+ (* exception Foo = Baz *)
+ (* Possible errors:
+ * Unbound_exception
+ * Not_an_exception
+ *)
+ (* Possible fixes:
+ * SingleReplace with newly declared exception
+ *)
+ [(replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_exception(newName, [])})
+ alwaysValid
+ ("Unaliased exception " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_ExnRebind_Unalias"))
+ strItem.pstr_loc)
+ ]
+ | Pstr_module(name, modexp) ->
+ (* module Name = ModuleExpression *)
+ (* Possible errors:
+ * Any module error
+ *)
+ (* Possible fixes:
+ * fixing the module
+ *)
+ [recurModStritem (modexp, (function mod' -> {strItem with pstr_desc = Pstr_module(name, mod')}))]
+ | Pstr_recmodule(str_modty_modexp_list) ->
+ (* module rec Name1 : Modty1 = ModExp1 and Name2 : Modty2 = ModExp2 and ... *)
+ (* Possible errors:
+ * Any module expression error
+ * Any module type error
+ *)
+ (* Possible fixes:
+ * Remove a single binding
+ * Remove all bindings
+ * Fix a module expression
+ * Fix a module type
+ *)
+ let removeAll =
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_recmodule []})
+ alwaysValid
+ ("Removed the module binding list at " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_Recmodule_RemoveAll"))
+ strItem.pstr_loc) in
+ let fixModModtys =
+ let processSingleModModty n (name, mty, mdl) =
+ [
+ recurModStritem (mdl, (function mdl' ->
+ {strItem with pstr_desc =
+ Pstr_recmodule (replaceNthWith str_modty_modexp_list n (name, mty, mdl'))}));
+ recurModtyStritem (mty, (function mty' ->
+ {strItem with pstr_desc =
+ Pstr_recmodule (replaceNthWith str_modty_modexp_list n (name, mty', mdl))}));
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_recmodule (removeNth n str_modty_modexp_list)})
+ alwaysValid
+ ("Removed module binding " ^ string_of_int(n))
+ (t("Str_Recmodule_RemoveOne"))
+ strItem.pstr_loc)
+ ] in
+ map_at_and_flatten processSingleModModty str_modty_modexp_list in
+ removeAll :: fixModModtys
+ | Pstr_modtype(name, modty) ->
+ (* module type Name = ModuleType *)
+ (* Possible errors:
+ * Any module type error
+ *)
+ (* Possible fixes:
+ * fixing the module type
+ *)
+ [recurModtyStritem (modty, (function mty' ->
+ {strItem with pstr_desc =
+ Pstr_modtype(name, mty')}));
+ ]
+ | Pstr_open name ->
+ (* open ModuleName *)
+ (* Possible errors:
+ * Unbound_module
+ * Structure_expected
+ *)
+ (* Possible fixes:
+ * Remove the open directive, even if it causes later errors
+ *)
+ [(replaceStritem (declareException "OpenDirectiveRemoved")
+ (function () ->
+ {strItem with pstr_desc =
+ Pstr_eval (alphaExp "OpenDirectiveRemoved" strItem.pstr_loc)})
+ alwaysValid
+ ("Removed the directive " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_Open_Remove"))
+ strItem.pstr_loc)
+ ]
+ | Pstr_class class_dec_list ->
+ (* class (virtual) (type_params) Name1 = ClsExp1 and Name2 : ClsTy2 = ClsExp2 and ... *)
+ (* Possible errors:
+ * Any class declaration error
+ *)
+ (* Possible fixes:
+ * Remove a single binding
+ * Remove all bindings
+ * Fix a class declaration
+ *)
+ let removeAll =
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_class []})
+ alwaysValid
+ ("Removed the class binding list at " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_Class_RemoveAll"))
+ strItem.pstr_loc) in
+ let fixClassDecs =
+ let processSingleClass n cls =
+ [
+ recurCldecStritem (cls, (function cls' -> {strItem with pstr_desc = Pstr_class (replaceNthWith class_dec_list n cls')}));
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_class (removeNth n class_dec_list)})
+ alwaysValid
+ ("Removed class binding " ^ string_of_int(n))
+ (t("Str_Class_RemoveOne"))
+ strItem.pstr_loc)
+ ] in
+ map_at_and_flatten processSingleClass class_dec_list in
+ removeAll :: fixClassDecs
+ | Pstr_class_type class_ty_dec_list ->
+ (* class type (virtual) (type_params) Name1 = ClsSig1 and Name2 = ClsSig2 and ... *)
+ (* Possible errors:
+ * Any class type declaration error
+ *)
+ (* Possible fixes:
+ * Remove a single binding
+ * Remove all bindings
+ * Fix a class type declaration
+ *)
+ let removeAll =
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_class_type []})
+ alwaysValid
+ ("Removed the class binding list at " ^ (sourceFromLoc strItem.pstr_loc))
+ (t("Str_Class_RemoveAll"))
+ strItem.pstr_loc) in
+ let fixClassTyDecs =
+ let processSingleClassTy n clsty =
+ [
+ recurCltydecStritem (clsty, (function clsty' ->
+ {strItem with pstr_desc =
+ Pstr_class_type (replaceNthWith class_ty_dec_list n clsty')}));
+ (replaceStritem []
+ (function () -> {strItem with pstr_desc = Pstr_class_type (removeNth n class_ty_dec_list)})
+ alwaysValid
+ ("Removed class binding " ^ string_of_int(n))
+ (t("Str_ClassType_RemoveOne"))
+ strItem.pstr_loc)
+ ] in
+ map_at_and_flatten processSingleClassTy class_ty_dec_list in
+ removeAll :: fixClassTyDecs
+ | Pstr_include modexp ->
+ (* include ModuleExpression *)
+ (* Possible errors:
+ * Any module error
+ *)
+ (* Possible fixes:
+ * fixing the module
+ *)
+ [recurModStritem (modexp, (function mod' ->
+ {strItem with pstr_desc =
+ Pstr_include mod'}));
+ ]
+ in [followup [genericSingleReplacement] (fun _ -> otherSingleReplacements)]
+
+ let destructPat pat locOpt =
+ let replacePat = replacePat (Pat pat) in (* pre-bind the first argument *)
+ if not (shouldTryFix pat.ppat_loc locOpt) then [] else
+ let genericSingleReplacement =
+ (replacePat []
+ (function () -> alphaPat pat.ppat_loc)
+ alwaysValid
+ "Replaced pattern with _"
+ (t("Pat_Remove"))
+ pat.ppat_loc) in
+ let otherSingleReplacements =
+ match pat.ppat_desc with
+ Ppat_any -> []
+ | Ppat_var s -> []
+ | Ppat_alias(p, s) ->
+ [
+ recurPatPat (p, (function p' ->
+ {pat with ppat_desc =
+ Ppat_alias(p', s)}));
+ (replacePat []
+ (function () -> {pat with ppat_desc = Ppat_var s})
+ alwaysValid
+ "Removed subpattern and replaced with aliased variable"
+ (t("Pat_Alias_RemoveSubpat"))
+ p.ppat_loc)
+ ]
+ | Ppat_constant c -> []
+ | Ppat_tuple pList ->
+ let recurOrInsert =
+ let processSinglePat n p =
+ [
+ recurPatPat (p, (function p' ->
+ {pat with ppat_desc =
+ Ppat_tuple(replaceNthWith pList n p')}));
+ (replacePat []
+ (function () -> {pat with ppat_desc = Ppat_tuple(removeNth n pList)})
+ alwaysValid
+ ("Removed subpattern " ^ (sourceFromLoc p.ppat_loc))
+ (t("Pat_Tuple_RemoveSubpat"))
+ p.ppat_loc)
+ ] in
+ map_at_and_flatten processSinglePat pList in
+ let addPat =
+ let insertSinglePat n _ =
+ (replacePat []
+ (function () -> {pat with ppat_desc = Ppat_tuple(insertNth pList n (alphaPat !locNone))})
+ alwaysValid
+ ("Inserted new pattern before pattern " ^ string_of_int(n))
+ (t("Pat_Tuple_InsertSubpat"))
+ pat.ppat_loc) in
+ map_between insertSinglePat pList in
+ List.flatten (recurOrInsert :: addPat :: [])
+ | Ppat_construct(id, pOpt, b) ->
+ (match pOpt with
+ None -> []
+ | Some p -> [ recurPatPat (p, function p' ->
+ {pat with ppat_desc =
+ Ppat_construct(id, Some p', b)}) ])
+ | Ppat_variant(l, pOpt) ->
+ (match pOpt with
+ None -> []
+ | Some p -> [ recurPatPat (p, function p' ->
+ {pat with ppat_desc =
+ Ppat_variant(l, Some p')}) ])
+ | Ppat_record idpList -> []
+ | Ppat_array pList ->
+ let recurOrInsert =
+ let processSinglePat n p =
+ [
+ recurPatPat (p, (function p' ->
+ {pat with ppat_desc =
+ Ppat_array(replaceNthWith pList n p')}));
+ (replacePat []
+ (function () -> {pat with ppat_desc = Ppat_array(removeNth n pList)})
+ alwaysValid
+ ("Removed subpattern " ^ (sourceFromLoc p.ppat_loc))
+ (t("Pat_Array_RemoveSubpat"))
+ p.ppat_loc)
+ ] in
+ map_at_and_flatten processSinglePat pList in
+ recurOrInsert
+ | Ppat_or(p1, p2) ->
+ [recurPatPat (p1, (function p1' -> {pat with ppat_desc = Ppat_or(p1', p2)}));
+ recurPatPat (p2, (function p2' -> {pat with ppat_desc = Ppat_or(p1, p2')}));
+ (replacePat []
+ (function () -> p1)
+ alwaysValid
+ ("Removed one branch of an or pattern")
+ (t("Pat_Or_RemovePat"))
+ p2.ppat_loc);
+ (replacePat []
+ (function () -> p2)
+ alwaysValid
+ ("Removed one branch of an or pattern")
+ (t("Pat_Or_RemovePat"))
+ p1.ppat_loc)
+ ]
+ | Ppat_constraint(p, ty) ->
+ [recurPatPat (p, (function p' -> {pat with ppat_desc = Ppat_constraint(p', ty)}));
+ recurTypPat (ty, (function t' -> {pat with ppat_desc = Ppat_constraint(p, t')}));
+ (replacePat []
+ (function () -> p)
+ alwaysValid
+ ("Remove pattern constraint")
+ (t("Pat_Constraint_RemoveConstraint"))
+ ty.ptyp_loc)
+ ]
+ | Ppat_type t -> []
+ in [followup [genericSingleReplacement] (fun _ -> otherSingleReplacements)]
+
+ let destructMod mdl locOpt =
+ let replaceMod = replaceMod (Mod mdl) in (* pre-bind the first argument *)
+ if not (shouldTryFix mdl.pmod_loc locOpt) then [] else
+ let genericSingleReplacement =
+ (replaceMod []
+ (function () -> {mdl with pmod_desc = Pmod_structure []})
+ alwaysValid
+ "Removed module expression"
+ (t("Mod_Remove"))
+ mdl.pmod_loc) in
+ let otherSingleReplacements =
+ match mdl.pmod_desc with
+ Pmod_ident id -> []
+ | Pmod_structure str ->
+ [
+ recurStrMod (str, (function str' ->
+ {mdl with pmod_desc =
+ Pmod_structure str'}));
+ ]
+ | Pmod_functor(s, mty, mexp) ->
+ [
+ recurModMod (mexp, (function mexp' ->
+ {mdl with pmod_desc =
+ Pmod_functor(s, mty, mexp')}));
+ recurModtyMod (mty, (function mty' ->
+ {mdl with pmod_desc =
+ Pmod_functor(s, mty', mexp)}));
+ ]
+ | Pmod_apply(mexp1, mexp2) ->
+ [
+ recurModMod (mexp1, (function mexp1' ->
+ {pmod_desc = Pmod_apply(mexp1', mexp2);
+ pmod_loc = mdl.pmod_loc}));
+ recurModMod (mexp2, (function mexp2' ->
+ {mdl with pmod_desc =
+ Pmod_apply(mexp1, mexp2')}));
+ ]
+ | Pmod_constraint(mexp, mty) ->
+ [
+ (replaceMod []
+ (function () -> {mdl with pmod_desc = mexp.pmod_desc})
+ alwaysValid
+ "Relaxed constraint on module"
+ (t("Mod_Constraint_Relax"))
+ mty.pmty_loc);
+ recurModMod (mexp, (function mexp' ->
+ {mdl with pmod_desc =
+ Pmod_constraint(mexp', mty)}));
+ recurModtyMod (mty, (function mty' ->
+ {mdl with pmod_desc =
+ Pmod_constraint(mexp, mty')}));
+ ]
+ in [followup [genericSingleReplacement] (fun _ -> otherSingleReplacements)]
+
+
+
+ let destructModty mty locOpt = []
+ let destructClass cls locOpt = []
+ let destructCldesc cld locOpt = []
+ let destructClassty clsty locOpt = []
+ let destructClasstydec clstydec locOpt = []
+ let destructClfield clf locOpt = []
+ let destructClexp cle locOpt = []
+ let destructSigitem sit locOpt = []
+ let destructClty clt locOpt = []
+ let destructCltf cltf locOpt = []
+ let destructTypdec typ locOpt = []
+ let destructTyp typ locOpt =
+ let replaceTyp = replaceTyp (Typ typ) in (* pre-bind the first argument *)
+ if not (shouldTryFix typ.ptyp_loc locOpt) then [] else
+ match typ.ptyp_desc with
+ Ptyp_any ->
+ (* Possible fixes:
+ * none
+ *)
+ []
+ | Ptyp_constr(id, ty_list) ->
+ (* Possible fixes:
+ * generalize the entire type to 'a
+ * fix some local problem within the type list
+ *)
+ let relaxType =
+ (replaceTyp []
+ (fun () -> alphaTyp typ.ptyp_loc)
+ alwaysValid
+ ("Generalized type at " ^ (sourceFromLoc typ.ptyp_loc))
+ (t("Typ_Constr_Generalize"))
+ typ.ptyp_loc) in
+ let processSingleTyp n typ =
+ recurTypTyp (typ, (function typ' ->
+ {typ with ptyp_desc =
+ Ptyp_constr(id, replaceNthWith ty_list n typ')})) in
+ let fixType = (map_at processSingleTyp ty_list) in
+ relaxType :: fixType
+ | _ -> []
+
+ let destructExp exp locOpt inMulti inTriage =
+ let replaceExp = replaceExp (Exp exp) in (* pre-bind the first argument *)
+ if not (shouldTryFix exp.pexp_loc locOpt) then [] else
+ let genericSingleReplacements =
+ [(replaceExp (declareException "ExpRemoved")
+ (function () -> alphaExp "ExpRemoved" exp.pexp_loc)
+ alwaysValid
+ ("Replaced expression " ^ (sourceFromLoc exp.pexp_loc) ^ " with _")
+ (t("Exp_Remove"))
+ exp.pexp_loc);
+ (replaceExp (declareException "ChangedType")
+ (function () -> {pexp_desc = Pexp_sequence(exp, alphaExp "ChangedType" exp.pexp_loc); pexp_loc = exp.pexp_loc})
+ alwaysValid
+ ("Adapted a single expression " ^ (sourceFromLoc exp.pexp_loc) ^ " with ; [[...]]")
+ (t("Exp_Adapt"))
+ exp.pexp_loc)] in
+ let otherSingleReplacements =
+ match exp.pexp_desc with
+ Pexp_ident name ->
+ let identFixes = tryIDs name exp.pexp_loc (function id' ->
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_ident id'})
+ alwaysValid
+ ("Replaced id " ^ (longidentToStr name) ^ " with id " ^ (longidentToStr id'))
+ (t("Exp_Ident_FixId"))
+ exp.pexp_loc)
+ ) in
+ let refFix =
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_apply({pexp_desc = Pexp_ident (strToLongident "!"); pexp_loc = exp.pexp_loc}, ["", exp])})
+ alwaysValid
+ ("Dereferenced a ref-cell " ^ (longidentToStr name))
+ (t("Exp_Ident_Deref"))
+ exp.pexp_loc) in
+ refFix :: identFixes
+ | Pexp_constant const -> []
+ | Pexp_let (rec_flag, pat_exp_list, ex) ->
+ (* Possible fixes:
+ * setting the rec flag
+ * fixing a subpattern in a single binding
+ * fixing a subexpression in a single binding
+ * generalizing a single binding
+ * generalizing all bindings
+ * generalizing the target expression
+ * removing a broken binding (note: could do all subsets, but that's 2^n)
+ * fixing a subexpression in the target expression
+ * hoisting nested lets into one binding list
+ *)
+ let fixRec =
+ [(replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_let(Asttypes.Recursive, pat_exp_list, ex)})
+ alwaysValid
+ "Changed let to be recursive"
+ (t("Exp_Let_FixRec"))
+ (locSub exp.pexp_loc ex.pexp_loc))
+ ] in
+ let fixPatExps =
+ let processSinglePatExp n (patN, expN) =
+ [
+ recurPatExp (patN, (function patN' ->
+ {exp with pexp_desc =
+ Pexp_let(rec_flag, (replaceNthWith pat_exp_list n (patN', expN)), ex)}));
+ recurExpExp (expN, (function expN' ->
+ {exp with pexp_desc =
+ Pexp_let(rec_flag, (replaceNthWith pat_exp_list n (patN, expN')), ex)}));
+ ] in
+ map_at_and_flatten processSinglePatExp pat_exp_list in
+ let generalizeAllBindings =
+ [(replaceExp (declareException "ReplacedBindings")
+ (function () -> {exp with pexp_desc =
+ Pexp_let(rec_flag, List.map (fun (pat, exp) -> (pat, alphaExp "ReplacedBindings" exp.pexp_loc)) pat_exp_list, ex)})
+ alwaysValid
+ ("Replaced all bound subexpressions with (Pervasives.raise ReplacedBindings)")
+ (t("Exp_Let_ReplaceAllBindings"))
+ (locSub exp.pexp_loc ex.pexp_loc))
+ ] in
+ let deleteItems =
+ let removeSingleExp n =
+ (replaceExp []
+ (function () -> if (List.length pat_exp_list = 1)
+ then {exp with pexp_desc = ex.pexp_desc}
+ else {exp with pexp_desc =
+ Pexp_let(rec_flag, removeNth n pat_exp_list, ex)})
+ alwaysValid
+ ("Removed binding " ^ string_of_int(n) ^ " (zero-indexed) from let-binding")
+ (t("Exp_Let_DeleteBinding"))
+ exp.pexp_loc) in
+ map_c removeSingleExp pat_exp_list in
+ let fixTarget =
+ (* fprintf std_formatter "Fixing inner expression of let:\n";
+ Printcode.expression std_formatter ex;
+ fprintf std_formatter "\n"; flush stdout; *)
+ [recurExpExp (ex, (function ex' ->
+ {exp with pexp_desc =
+ Pexp_let(rec_flag, pat_exp_list, ex')}));
+ ] in
+ let hoistInnerLets =
+ let rec hoist curHoists =
+ let exp = List.hd curHoists in
+ match exp.pexp_desc with
+ Pexp_let(recFlag, pat_exp_list, ex) ->
+ (match ex.pexp_desc with
+ Pexp_let(inner_recFlag, inner_pat_exp_list, inner_ex) ->
+ let hoistedExp =
+ {exp with pexp_desc =
+ Pexp_let(Asttypes.Recursive, List.rev_append (List.rev pat_exp_list) inner_pat_exp_list, inner_ex)}
+ in hoist (hoistedExp :: curHoists)
+ | _ -> curHoists)
+ | _ -> curHoists in
+ let rebuildTorecur exp =
+ let endLoc =
+ match exp.pexp_desc with
+ Pexp_let(_, _, inner_ex) -> locSub exp.pexp_loc inner_ex.pexp_loc
+ | _ -> exp.pexp_loc in
+ (replaceExp []
+ (function () -> exp)
+ alwaysValid
+ ("Joined several let-bindings into one recursive binding list: \n" ^ (sourceFromLoc endLoc))
+ (t("Exp_Let_HoistInner"))
+ endLoc) in
+ List.map rebuildTorecur (hoist [exp]) in
+ List.flatten (fixRec :: fixPatExps :: generalizeAllBindings :: deleteItems :: fixTarget :: hoistInnerLets :: [])
+ | Pexp_constraint(exp', sty1, sty2) ->
+ (* Possible fixes:
+ * fix a subexpression
+ * remove the constraint
+ *)
+ [
+ recurExpExp (exp', (function exp' ->
+ {exp with pexp_desc =
+ Pexp_constraint(exp', sty1, sty2)}));
+ (replaceExp []
+ (function () -> {exp with pexp_desc = exp'.pexp_desc})
+ alwaysValid
+ (match sty1 with
+ None -> "Removed constraint at " ^ (sourceFromLoc exp'.pexp_loc)
+ | Some ty -> "Removed constraint " ^ (sourceFromLoc ty.ptyp_loc) ^ " at " ^ (sourceFromLoc exp'.pexp_loc))
+ (t("Exp_Constraint_RemoveConstraint"))
+ exp'.pexp_loc)
+ ]
+ | Pexp_tuple exp_list ->
+ (* Possible fixes:
+ * generalize the entire tuple to 'a
+ * generalize a specific item to 'a
+ * remove an item
+ * add an item
+ *)
+ let generalizeItem =
+ let processSingleExp n exp =
+ recurExpExp (exp, function ex' ->
+ {exp with pexp_desc =
+ Pexp_tuple(replaceNthWith exp_list n ex')}) in
+ map_at processSingleExp exp_list in
+ let deleteItem =
+ let removeSingleExp n =
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_tuple(removeNth n exp_list)})
+ alwaysValid
+ ("Removed field " ^ string_of_int(n) ^ " (zero-indexed) from tuple " ^ (sourceFromLoc exp.pexp_loc))
+ (t("Exp_Tuple_DeleteItem"))
+ exp.pexp_loc) in
+ map_c removeSingleExp exp_list in
+ let addGeneralItem =
+ let insertSingleExp n eOpt =
+ let nthLoc = match eOpt with
+ None -> {loc_start = exp.pexp_loc.loc_end; loc_end = exp.pexp_loc.loc_end; loc_ghost = true}
+ | Some e -> {loc_start = e.pexp_loc.loc_end; loc_end = e.pexp_loc.loc_end; loc_ghost = true} in
+ (replaceExp (declareException "TupleFieldInserted")
+ (function () -> {exp with pexp_desc = Pexp_tuple(insertNth exp_list n (alphaExp "TupleFieldInserted" nthLoc))})
+ alwaysValid
+ ("Inserted new field before field " ^ string_of_int(n) ^ " (zero-indexed) into tuple " ^ (sourceFromLoc exp.pexp_loc))
+ (t("Exp_Tuple_AddItem"))
+ exp.pexp_loc) in
+ map_between insertSingleExp exp_list in
+ let swapArgs =
+ let swap n m = (* assume n < m *)
+ let (front, nAndTail) = splitAt n exp_list in
+ let (nAndMid, mAndTail) = splitAt (m-n) nAndTail in
+ match (front, nAndMid, mAndTail) with
+ (front, n::mid, m::tail) -> front @ (m::mid) @ (n::tail)
+ | _ -> exp_list in
+ let relocate n m =
+ let (min, max) = if (n < m) then (n,m) else (m,n) in
+ let (front, minAndTail) = splitAt min exp_list in
+ let (minAndMid, maxAndTail) = splitAt (max-min) minAndTail in
+ if (n < m) then
+ match (front, minAndMid, maxAndTail) with
+ (front, minAndMid, m::tail) -> front @ (m::minAndMid) @ tail
+ | _ -> exp_list
+ else
+ match (front, minAndMid, maxAndTail) with
+ (front, n::mid, maxAndTail) -> front @ mid @ (n::maxAndTail)
+ | _ -> exp_list in
+ let allSwaps = List.filter (fun (m,n) -> (m < n))
+ (List.flatten (map_c (fun n -> map_c (fun m -> (n,m)) exp_list) exp_list)) in
+ let swapToMod (n,m) =
+ [(replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_tuple(swap n m)})
+ alwaysValid
+ ("Swapped argument " ^ (string_of_int n) ^ " with argument " ^ (string_of_int m))
+ (t("Exp_Tuple_SwapArgs"))
+ (locJoin (List.nth exp_list n).pexp_loc (List.nth exp_list m).pexp_loc));
+ (replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_tuple(relocate n m)})
+ alwaysValid
+ ("Relocated argument " ^ (string_of_int m) ^ " to position " ^ (string_of_int n))
+ (t("Exp_Tuple_RelocateArgs"))
+ (locJoin (List.nth exp_list n).pexp_loc (List.nth exp_list m).pexp_loc));
+ (replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_tuple(relocate m n)})
+ alwaysValid
+ ("Relocated argument " ^ (string_of_int n) ^ " to position " ^ (string_of_int m))
+ (t("Exp_Tuple_RelocateArgs"))
+ (locJoin (List.nth exp_list n).pexp_loc (List.nth exp_list m).pexp_loc))
+ ] in
+ List.flatten (List.map swapToMod allSwaps) in
+ List.flatten (generalizeItem :: deleteItem :: addGeneralItem :: swapArgs :: [])
+ | Pexp_construct (id, exp_opt, b) ->
+ (* Possible fixes:
+ * generalize the body of the constructor to 'a
+ * remove the body of the constructor
+ * find some local fix in the expression if there is one
+ * ad-hoc fix A (A (x, y, z)) into A (A (x,y), z)
+ * ad-hoc fix [x,y,z] into [x;y;z]
+ * ad-hoc fix () into []
+ * ad-hoc fix [] into ()
+ *)
+ let generalizeBody =
+ let (exnName, replacementMessage) = match exp_opt with
+ None -> ("ConstructBodyAdded", "Inserted generic body into constructor ")
+ | Some _ -> ("ConstructBodyGeneralized", "Generalized body of constructor ") in
+ (replaceExp (declareException exnName)
+ (function () -> {exp with pexp_desc = Pexp_construct (id, Some (alphaExp exnName !locNone), false)})
+ alwaysValid
+ (replacementMessage ^ (sourceFromLoc exp.pexp_loc))
+ (t("Exp_Construct_GeneralizeBody"))
+ exp.pexp_loc) in
+ let removeBodyOrTag =
+ match exp_opt with
+ None -> []
+ | Some body ->
+ [(replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_construct (id, None, false)})
+ alwaysValid
+ ("Removed body of constructor " ^ (sourceFromLoc exp.pexp_loc))
+ (t("Exp_Construct_DeleteBody"))
+ exp.pexp_loc);
+ (replaceExp []
+ (function () -> body)
+ alwaysValid
+ ("Removed construct tag")
+ (t("Exp_Construct_DeleteTag"))
+ exp.pexp_loc)
+ ] in
+ let fixTuplefiedList =
+ (* fprintf std_formatter "Trying to untuplefy expression:\n"; Printcode.expression std_formatter exp; fprintf std_formatter "\n"; flush stdout; *)
+ match (id, exp_opt) with
+ (Longident.Lident id', None) when (id' = "()" || id' = "[]") ->
+ [(replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_construct(Longident.Lident (if id' = "()" then "[]" else "()"), None, b)})
+ alwaysValid
+ "Transformed () into [] or vice versa"
+ (t("Exp_Construct_FixUnitList"))
+ exp.pexp_loc)]
+ | ((Longident.Lident "::"), Some ({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple items; pexp_loc = l1}; {pexp_desc = Pexp_construct(Longident.Lident "[]", None, false); pexp_loc = l2}]; pexp_loc = l})) ->
+ let newExp = List.fold_right
+ (fun (item : expression) (accu : expression) ->
+ {pexp_desc = Pexp_construct(strToLongident "::", Some {pexp_desc = Pexp_tuple([item; accu]); pexp_loc = item.pexp_loc}, false);
+ pexp_loc = locJoin item.pexp_loc accu.pexp_loc}) items
+ {pexp_desc = Pexp_construct(strToLongident "[]", None, false); pexp_loc = l2} in
+ [(replaceExp []
+ (fun () -> newExp)
+ alwaysValid
+ "Transformed a list of a single tuple into a list of the tuple's elements"
+ (t("Exp_Construct_FixTuplelist"))
+ exp.pexp_loc)]
+ | _ -> [] in
+ let childrenFixes =
+ match exp_opt with
+ None -> []
+ | Some {pexp_desc = Pexp_tuple subexps; pexp_loc = loc'} ->
+ let processSingleExp n subexp =
+ recurExpExp (subexp, function ex' ->
+ {exp with pexp_desc =
+ Pexp_construct(id, Some {pexp_desc = Pexp_tuple(replaceNthWith subexps n ex'); pexp_loc = loc'}, b)}) in
+ map_at processSingleExp subexps
+ | Some {pexp_desc = Pexp_construct (id2, Some {pexp_desc = Pexp_tuple subexps; pexp_loc = loc3}, b2); pexp_loc = loc2} when id2 = id ->
+ begin
+ match subexps with
+ e1::e2::e3::[] ->
+ let newExp = {exp with pexp_desc =
+ Pexp_construct (id,
+ Some ({pexp_desc = Pexp_tuple [{pexp_desc =
+ Pexp_construct (id2,
+ Some ({pexp_desc = Pexp_tuple [e1;e2]; pexp_loc = loc2}),
+ b2);
+ pexp_loc = loc2};
+ e3];
+ pexp_loc = locJoin loc2 loc3}),
+ b)
+ } in
+ [(replaceExp []
+ (fun () -> newExp)
+ alwaysValid
+ "Rotated A (A (x,y,z)) into A (A (x,y), z)"
+ (t("Exp_Construct_RotateConstructs"))
+ exp.pexp_loc)]
+ | _ -> []
+ end
+ | Some exp' ->
+ [recurExpExp (exp', function ex' -> {exp with pexp_desc = Pexp_construct(id, Some ex', b)});
+ recurExpExp ({exp' with pexp_desc = Pexp_tuple [exp']}, function ex' -> {exp with pexp_desc = Pexp_construct(id, Some ex', b)});
+ ] in
+ (generalizeBody :: (removeBodyOrTag @ childrenFixes @ fixTuplefiedList))
+ | Pexp_record (idExpList, eOpt) ->
+ let fixIdExps =
+ let processIdExp n (id, ex) =
+ recurExpExp(ex, function ex' -> {exp with pexp_desc = Pexp_record(replaceNthWith idExpList n (id, ex'), eOpt)})
+ :: tryIDs id exp.pexp_loc (function id' ->
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_record(replaceNthWith idExpList n (id', ex), eOpt)})
+ alwaysValid
+ ("Replaced id " ^ (longidentToStr id) ^ " with id " ^ (longidentToStr id') ^ " in record")
+ (t("Exp_Record_FixId"))
+ ex.pexp_loc);
+ ) in
+ map_at_and_flatten processIdExp idExpList in
+ let optFix =
+ match eOpt with None -> [] | Some e ->
+ [recurExpExp(e, function e' ->
+ {exp with pexp_desc =
+ Pexp_record(idExpList, Some e')});
+ ] in
+ List.flatten (optFix :: fixIdExps :: [])
+ | Pexp_field(e, id) ->
+ let fixExp =
+ recurExpExp(e, function e' ->
+ {exp with pexp_desc =
+ Pexp_field(e', id)}) in
+ let fixId = tryIDs id exp.pexp_loc (function id' ->
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_field(e, id')})
+ alwaysValid
+ ("Replaced id " ^ (longidentToStr id) ^ " with id " ^ (longidentToStr id') ^ " in field expression")
+ (t("Exp_Field_FixId"))
+ {loc_start = e.pexp_loc.loc_end; loc_end = exp.pexp_loc.loc_end; loc_ghost = true})) in
+ fixExp :: fixId
+ | Pexp_setfield(e1, id, e2) ->
+ let fixExp1 = recurExpExp(e1, function e' -> {exp with pexp_desc = Pexp_setfield(e', id, e2)}) in
+ let fixExp2 = recurExpExp(e2, function e' -> {exp with pexp_desc = Pexp_setfield(e1, id, e')}) in
+ let fixId = tryIDs id exp.pexp_loc (function id' ->
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_setfield(e1, id', e2)})
+ alwaysValid
+ ("Replaced id " ^ (longidentToStr id) ^ " with id " ^ (longidentToStr id') ^ " in setfield expression")
+ (t("Exp_Setfield_FixId"))
+ {loc_start = e1.pexp_loc.loc_end; loc_end = e2.pexp_loc.loc_start; loc_ghost = true})) in
+ fixExp1 :: fixExp2 :: fixId
+ | Pexp_send(e, s) ->
+ let fixExp = recurExpExp(e, function e' -> {exp with pexp_desc = Pexp_send(e', s)}) in
+ let fixStr = tryStrs exp.pexp_loc (function s' ->
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_send(e, s')})
+ alwaysValid
+ ("Replaced str " ^ s ^ " with str " ^ s' ^ " in send expression")
+ (t("Exp_Send_FixStr"))
+ {loc_start = e.pexp_loc.loc_end; loc_end = exp.pexp_loc.loc_end; loc_ghost = true})) in
+ fixExp :: fixStr
+ | Pexp_setinstvar(s, e) ->
+ let fixExp = recurExpExp(e, function e' -> {exp with pexp_desc = Pexp_setinstvar(s, e')}) in
+ let fixStr = tryStrs exp.pexp_loc (function s' ->
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_setinstvar(s', e)})
+ alwaysValid
+ ("Replaced str " ^ s ^ " with str " ^ s' ^ " in setinstvar expression")
+ (t("Exp_Setinstvar_FixStr"))
+ {loc_start = exp.pexp_loc.loc_start; loc_end = e.pexp_loc.loc_start; loc_ghost = true})) in
+ fixExp :: fixStr
+ | Pexp_override seList ->
+ let processStrExp n (s, e) =
+ let fixExp = recurExpExp(e, function e' -> {exp with pexp_desc = Pexp_override(replaceNthWith seList n (s, e'))}) in
+ let fixStr = tryStrs exp.pexp_loc (function s' ->
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_override(replaceNthWith seList n (s', e))})
+ alwaysValid
+ ("Replaced str " ^ s ^ " with str " ^ s' ^ " in override expression")
+ (t("Exp_Override_FixStr"))
+ {loc_start = exp.pexp_loc.loc_start; loc_end = e.pexp_loc.loc_start; loc_ghost = true})) in
+ fixExp :: fixStr in
+ map_at_and_flatten processStrExp seList
+ | Pexp_poly(e, tyOpt) ->
+ let fixExp = recurExpExp(e, function e' -> {exp with pexp_desc = Pexp_poly(e', tyOpt)}) in
+ let fixTy = match tyOpt with None -> [] | Some ty ->
+ [recurTypExp(ty, (function ty' -> {exp with pexp_desc = Pexp_poly(e, Some ty')}))] in
+ fixExp :: fixTy
+ | Pexp_object patClsfieldList -> [] (* NOT COMPLETE *)
+ | Pexp_variant(l, eOpt) ->
+ (* `Lab(eOpt) *)
+ (* Possible errors:
+ * Undefined label
+ * error in the expression (if present)
+ *)
+ (* Possible fixes:
+ * fix the expression if present
+ *)
+ (match eOpt with
+ None ->
+ [(replaceExp (declareException "VariantBody")
+ (function () -> {exp with pexp_desc = Pexp_variant(l, Some (alphaExp "VariantBody" !locNone))})
+ alwaysValid
+ "Added arbitrary body to variant"
+ (t("Exp_Variant_AddBody"))
+ exp.pexp_loc);
+ ]
+ | Some e ->
+ [
+ recurExpExp(e, function ex' -> {exp with pexp_desc = Pexp_variant(l, Some ex')});
+ (replaceExp (declareException "SingleReplaceVariantBody")
+ (function () -> {exp with pexp_desc = Pexp_variant(l, Some (alphaExp "SingleReplaceVariantBody" e.pexp_loc))})
+ alwaysValid
+ "SingleReplace body of variant"
+ (t("Exp_Variant_SingleReplaceSubexp"))
+ e.pexp_loc);
+ ])
+ | Pexp_letmodule(name, modExp, exp') ->
+ (* let name = modExp in exp' *)
+ (* Possible errors:
+ * any module expression error
+ * any expression error
+ *)
+ (* Possible fixes:
+ * delete the entire expression
+ * fix the module expression
+ * fix the expression
+ *)
+ [
+ recurModExp(modExp, (function mex' -> {exp with pexp_desc = Pexp_letmodule(name, mex', exp')}));
+ recurExpExp(exp', (function ex' -> {exp with pexp_desc = Pexp_letmodule(name, modExp, ex')}));
+ ]
+ | Pexp_array expList ->
+ (* [| e1; e2; ... |] *)
+ (* Possible errors:
+ * any error expression in any subexpression
+ *)
+ (* Possible fixes:
+ * delete the entire array expression
+ * any recursive fix of a subexpression
+ *)
+ let processSingleSubexp n exp = recurExpExp(exp, function ex' -> {exp with pexp_desc = Pexp_array(replaceNthWith expList n ex')}) in
+ map_at processSingleSubexp expList
+ | Pexp_new id -> []
+ | Pexp_sequence(e1, e2) ->
+ (* e1 ; e2 *)
+ (* Possible errors:
+ * any expression error in either e1 or e2
+ *)
+ (* Possible fixes:
+ * recursively fix either expression
+ *)
+ [
+ recurExpExp(e1, (function e' -> {exp with pexp_desc = Pexp_sequence(e', e2)}));
+ recurExpExp(e2, (function e' -> {exp with pexp_desc = Pexp_sequence(e1, e')}));
+ ]
+ | Pexp_while(guard, body) ->
+ (* e1 ; e2 *)
+ (* Possible errors:
+ * any expression error in either e1 or e2
+ *)
+ (* Possible fixes:
+ * recursively fix either expression
+ *)
+ [
+ recurExpExp(guard, (function g' -> {exp with pexp_desc = Pexp_while(g', body)}));
+ recurExpExp(body, (function b' -> {exp with pexp_desc = Pexp_while(guard, b')}));
+ ]
+ | Pexp_ifthenelse(guard, iftrue, iffalseOpt) ->
+ (* if guard then iftrue (else iffalse) *)
+ (* Possible errors:
+ * any expression error in guard, iftrue, or iffalse
+ * dangling elses
+ *)
+ (* Possible fixes:
+ * delete the whole expression
+ * fix each expression
+ * reassociate elses outwards
+ * AD-HOC: fix any expression and delete the other two
+ *)
+ let mainTests =
+ [
+ recurExpExp(guard, (function g' -> {exp with pexp_desc = Pexp_ifthenelse(g', iftrue, iffalseOpt)}));
+ recurExpExp(iftrue, (function t' -> {exp with pexp_desc = Pexp_ifthenelse(guard, t', iffalseOpt)}));
+ ] in
+ let elseTests =
+ match iffalseOpt with
+ None -> (* see if there's a dangling else problem *)
+ (match iftrue.pexp_desc with
+ Pexp_ifthenelse(g2, if2, Some else2) ->
+ [ replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_ifthenelse(guard, {iftrue with pexp_desc = Pexp_ifthenelse(g2, if2, None)}, Some else2)})
+ alwaysValid
+ "Reassociated dangling else"
+ (t("Exp_If_DanglingElse"))
+ else2.pexp_loc;
+ ]
+ | _ -> [])
+ | Some iffalse -> (* fix the false branch *)
+ [
+ recurExpExp(iffalse, (function f' -> {exp with pexp_desc = Pexp_ifthenelse(guard, iftrue, Some f')}));
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_ifthenelse(guard, iftrue, None)})
+ alwaysValid
+ "Removed else branch of if expression"
+ (t("Exp_If_RemoveElse"))
+ iffalse.pexp_loc);
+ ] in
+ List.rev_append mainTests elseTests
+ | Pexp_for(v, init, term, dir, body) ->
+ (* for v = init (to | downto) term do body done *)
+ (* Possible fixes:
+ * fix init, term, or body
+ *)
+ [
+ recurExpExp(init, (function i' -> {exp with pexp_desc = Pexp_for(v, i', term, dir, body)}));
+ recurExpExp(term, (function t' -> {exp with pexp_desc = Pexp_for(v, init, t', dir, body)}));
+ recurExpExp(body, (function b' -> {exp with pexp_desc = Pexp_for(v, init, term, dir, b')}));
+ ]
+ | Pexp_when(matchGuard, matchCase) ->
+ (* match ... | exp when MatchGuard -> MatchCase *)
+ (* Possible errors:
+ * guard is faulty
+ * expression is faulty
+ *)
+ (* Possible fixes:
+ * remove the guard
+ * fix the guard
+ * fix the expression
+ *)
+ [
+ (replaceExp (declareException "RemovedGuard")
+ (function () -> {exp with pexp_desc = matchCase.pexp_desc})
+ alwaysValid
+ "Removed `when' guard on match case"
+ (t("Exp_When_RemoveGuard"))
+ matchGuard.pexp_loc);
+ recurExpExp(matchGuard, (function g' -> {exp with pexp_desc = Pexp_when(g', matchCase)}));
+ recurExpExp(matchCase, (function c' -> {exp with pexp_desc = Pexp_when(matchGuard, c')}));
+ ]
+ | Pexp_function(lab, defaultOpt, peList) ->
+ (* fun p1 -> fun p2 -> .. pn -> body, where p1..pn could be labeled or optional
+ * function p1 -> e1 | p2 when g2 -> e2 ... *)
+ (* Possible errors:
+ * any pattern error
+ * any default expression's error
+ * any case/body's expression error
+ * too many arguments
+ * too few arguments
+ * swapped or rotated arguments
+ *)
+ (* Possible fixes:
+ * fix any patterns
+ * fix any expressions
+ * hoist inner function bodies (remove one curried argument)
+ * insert an additional function body (add one curried argument)
+ * swap or rotate arguments
+ *)
+ let fixPatExps =
+ let numCases = List.length peList in
+ let processSinglePatExp n (p, e) =
+ [
+ recurPatExp(p, (function pat' -> {exp with pexp_desc = Pexp_function(lab, defaultOpt, (replaceNthWith peList n (pat', e)))}));
+ recurExpExp(e, (function exp' -> {exp with pexp_desc = Pexp_function(lab, defaultOpt, (replaceNthWith peList n (p, exp')))}));
+ (replaceExp (declareException "RemovedCase")
+ (function () ->
+ {exp with pexp_desc =
+ Pexp_function(lab, defaultOpt, (replaceNthWith peList n
+ (alphaPat p.ppat_loc, alphaExp "RemovedCase" e.pexp_loc)))})
+ (fun _ -> numCases > 1)
+ ("Generalized case " ^ string_of_int n)
+ (t("Exp_Function_GeneralizedCase"))
+ (locJoin p.ppat_loc e.pexp_loc));
+ ] in
+ map_at_and_flatten processSinglePatExp peList in
+ let fixDefault =
+ match defaultOpt with
+ None -> []
+ | Some d ->
+ [
+ (replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_function(lab, None, peList)})
+ alwaysValid
+ "Removed argument's default expression"
+ (t("Exp_Function_RemoveDefault"))
+ d.pexp_loc);
+ recurExpExp(d, (function d' -> {exp with pexp_desc = Pexp_function(lab, Some d', peList)}));
+ ] in
+ let addArgumentBefore =
+ (* fun x -> y ===> fun _ -> fun x -> y *)
+ [(replaceExp []
+ (function () ->
+ {exp with pexp_desc =
+ Pexp_function("", None,
+ [alphaPat !locNone,
+ {exp with pexp_desc = Pexp_function(lab, defaultOpt, peList)}])})
+ alwaysValid
+ ("Added new parameter to function before parameter " ^ (sourceFromLoc (fst (List.hd peList)).ppat_loc))
+ (t("Exp_Function_AddParamBefore"))
+ exp.pexp_loc);
+ ] in
+ let addArgumentAfter =
+ if (List.length peList = 1) then
+ let pe = List.hd peList in
+ match (snd pe).pexp_desc with
+ Pexp_function _ -> []
+ | _ ->
+ (* fun x -> y ===> fun x -> fun _ -> y *)
+ [(replaceExp []
+ (function () ->
+ {exp with pexp_desc =
+ Pexp_function(lab, defaultOpt,
+ [(fst pe),
+ {exp with pexp_desc =
+ Pexp_function("", None, [alphaPat !locNone, (snd pe)])}])})
+ alwaysValid
+ "Added new parameter to function as last parameter"
+ (t("Exp_Function_AddParamAfter"))
+ exp.pexp_loc);
+ ]
+ else [] in
+ let curryArgs =
+ if (List.length peList = 1) then
+ let pe = List.hd peList in
+ match (fst pe).ppat_desc with
+ Ppat_tuple pList ->
+ [(replaceExp []
+ (fun () -> List.fold_right (fun p accu -> {exp with pexp_desc = Pexp_function("", None, [p, accu])}) pList (snd pe))
+ alwaysValid
+ "Changed a tupled function into a curried one"
+ (t("Exp_Function_CurryArgs"))
+ ((fst pe).ppat_loc))]
+ | _ -> []
+ else [] in
+ let uncurryArgs =
+ let rec tupledArgsAndBody ((revPList : pattern list), body) =
+ match body.pexp_desc with
+ Pexp_function(l', dOpt', peList') ->
+ if (List.length peList' = 1) then
+ let (p, e) = List.hd peList' in
+ tupledArgsAndBody (p :: revPList, e)
+ else (revPList, body)
+ | _ -> (revPList, body) in
+ if (List.length peList = 1) then
+ let (p, e) = List.hd peList in
+ let (revPList, body) = tupledArgsAndBody ([p], e) in
+ if (body = e) then []
+ else
+ let pLoc = List.fold_left (fun accu p -> locJoin accu p.ppat_loc) !locNone revPList in
+ let newPat = {ppat_loc = pLoc; ppat_desc = Ppat_tuple (List.rev revPList)} in
+ [(replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_function(lab, defaultOpt, [newPat, body])})
+ alwaysValid
+ "Changed a curried function into one taking a tuple"
+ (t("Exp_Function_UncurryArgs"))
+ pLoc)]
+ else [] in
+ let removeArgument =
+ if (List.length peList = 1) then
+ let pe = List.hd peList in
+ match (snd pe).pexp_desc with
+ Pexp_function _ -> []
+ | _ ->
+ [(replaceExp []
+ (function () -> {exp with pexp_desc = (snd pe).pexp_desc})
+ alwaysValid
+ ("Removed parameter " ^ (sourceFromLoc (fst pe).ppat_loc))
+ (t("Exp_Function_RemoveParam"))
+ (fst pe).ppat_loc);
+ ]
+ else [] in
+ let swapArgs =
+ let rec getFunArgsAndBody ex =
+ try
+ match ex.pexp_desc with
+ Pexp_function(_, _, peList) ->
+ let (p1, e1) = (List.hd peList) in
+ let (args', body) = getFunArgsAndBody e1 in
+ (p1 :: args', body)
+ | _ -> [], ex
+ with _ -> [], ex in
+ let funOfArgsAndBody args body =
+ List.fold_right (fun arg body -> {pexp_desc = Pexp_function("", None, [arg, body]);
+ pexp_loc = locJoin arg.ppat_loc body.pexp_loc})
+ args body in
+ let (allArgs, innerBody) = getFunArgsAndBody exp in
+ let swap n m = (* assume n < m *)
+ let (front, nAndTail) = splitAt n allArgs in
+ let (nAndMid, mAndTail) = splitAt (m-n) nAndTail in
+ match (front, nAndMid, mAndTail) with
+ (front, n::mid, m::tail) -> front @ (m::mid) @ (n::tail)
+ | _ -> allArgs in
+ let relocate n m =
+ let (min, max) = if (n < m) then (n,m) else (m,n) in
+ let (front, minAndTail) = splitAt min allArgs in
+ let (minAndMid, maxAndTail) = splitAt (max-min) minAndTail in
+ if (n < m) then
+ match (front, minAndMid, maxAndTail) with
+ (front, minAndMid, m::tail) -> front @ (m::minAndMid) @ tail
+ | _ -> allArgs
+ else
+ match (front, minAndMid, maxAndTail) with
+ (front, n::mid, maxAndTail) -> front @ mid @ (n::maxAndTail)
+ | _ -> allArgs in
+ let allSwaps = List.filter (fun (m,n) -> (m < n))
+ (List.flatten (map_c (fun n -> map_c (fun m -> (n,m)) allArgs) allArgs)) in
+ let swapToMod (n,m) =
+ [(replaceExp []
+ (fun () -> funOfArgsAndBody (swap n m) innerBody)
+ alwaysValid
+ ("Swapped parameter " ^ (string_of_int n) ^ " with parameter " ^ (string_of_int m))
+ (t("Exp_Function_SwapArgs"))
+ (locJoin (List.nth allArgs n).ppat_loc (List.nth allArgs m).ppat_loc));
+ (replaceExp []
+ (fun () -> funOfArgsAndBody (relocate n m) innerBody)
+ alwaysValid
+ ("Relocated parameter " ^ (string_of_int m) ^ " to position " ^ (string_of_int n))
+ (t("Exp_Function_RelocateArgs"))
+ (locJoin (List.nth allArgs n).ppat_loc (List.nth allArgs m).ppat_loc));
+ (replaceExp []
+ (fun () -> funOfArgsAndBody (relocate m n) innerBody)
+ alwaysValid
+ ("Relocated parameter " ^ (string_of_int n) ^ " to position " ^ (string_of_int m))
+ (t("Exp_Funtion_RelocateArgs"))
+ (locJoin (List.nth allArgs n).ppat_loc (List.nth allArgs m).ppat_loc))
+ ] in
+ List.flatten (List.map swapToMod allSwaps) in
+ let fixNestedFunctions = fixNestedTrysMatchsFunctions exp in
+ List.flatten (fixPatExps :: fixDefault :: swapArgs :: addArgumentAfter :: addArgumentBefore :: curryArgs :: uncurryArgs :: removeArgument :: fixNestedFunctions :: [])
+ | Pexp_try (tExp, pat_exp_list) ->
+ (* try tExp with pat1 -> exp1 | pat2 -> exp2 ... *)
+ (* Possible errors:
+ * any expression error
+ * any pattern error
+ * non-exhaustive match error
+ *)
+ (* Possible fixes:
+ * fix tExp
+ * fix each pattern or expression
+ * add a generic catch-all case
+ * reparenthesize nested trys, matches
+ *)
+ let fixExp = [recurExpExp(tExp, (function e' -> {exp with pexp_desc = Pexp_try(e', pat_exp_list)}))] in
+ let fixPatExps =
+ let processSinglePatExp n (pat, exp) =
+ [
+ recurPatExp (pat, (function pat' -> {exp with pexp_desc = Pexp_try(tExp, (replaceNthWith pat_exp_list n (pat', exp)))}));
+ recurExpExp (exp, (function exp' -> {exp with pexp_desc = Pexp_try(tExp, (replaceNthWith pat_exp_list n (pat, exp')))}));
+ ] in
+ map_at_and_flatten processSinglePatExp pat_exp_list in
+ let catchAll =
+ [(replaceExp (declareException "CatchAllTry")
+ (function () ->
+ {exp with pexp_desc =
+ Pexp_try(tExp, List.rev ((alphaPat !locNone, alphaExp "CatchAllTry" !locNone) ::
+ (List.rev pat_exp_list)))})
+ alwaysValid
+ "Added catch-all case to try expression"
+ (t("Exp_Try_CatchAll"))
+ exp.pexp_loc);
+ ] in
+ let fixNestedTrys = fixNestedTrysMatchsFunctions exp in
+ List.flatten (fixExp :: fixPatExps :: fixNestedTrys :: catchAll :: [])
+ | Pexp_apply (fExp, lab_exp_list) ->
+ (* fExp (~lab1:e1) (~lab2:e2) ... *)
+ (* Possible errors:
+ * Wrong labels
+ * Wrong expressions
+ * Too many arguments
+ * Too few arguments
+ * Curried arguments
+ * Uncurried arguments
+ * wrong order of arguments
+ * Wrong associativity
+ * mistakenly wrote rec.field := exp instead of rec.field <- exp
+ *)
+ (* Possible fixes:
+ * remove labels
+ * fix function
+ * fix subexpressions
+ * remove a subexpression
+ * add a subexpression
+ * generalize the entire application
+ * swap pairs of arguments
+ * relocate one argument to another position
+ * rotate two applications ((f g) h) <-> (f (g h))
+ * Curry or un-Curry arguments
+ *)
+ let removeLabels =
+ let removeLabel (lab, exp) = ("", exp) in
+ [(replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_apply (fExp, List.map removeLabel lab_exp_list)})
+ alwaysValid
+ "Removed labels from function arguments"
+ (t("Exp_Apply_RemoveLabels"))
+ exp.pexp_loc);
+ ] in
+ let fixSetfield =
+ try
+ match (fExp.pexp_desc, (snd (List.hd lab_exp_list)).pexp_desc) with
+ (Pexp_ident(Longident.Lident ":="), Pexp_field(e, id)) ->
+ [(replaceExp []
+ (function () -> {exp with pexp_desc = Pexp_setfield(e,id, (snd (List.hd (List.tl (lab_exp_list)))))})
+ alwaysValid
+ "Replaced binding assignment with field assignment"
+ (t("Exp_Apply_SingleReplaceBinding"))
+ fExp.pexp_loc);
+ ]
+ | _ -> []
+ with _ -> [] in
+ let fixFun = [followup [recurExpExp (fExp, (function ex' -> {exp with pexp_desc = Pexp_apply(ex', lab_exp_list)}))] (fun _ -> [TriggerTriage (Exp exp, (fun x -> x))])] in
+ let funValidate =
+ let argLocs = List.fold_left (fun l (_, e) -> locJoin l e.pexp_loc) !locNone lab_exp_list in
+ (fun thisrepl otherFixes -> List.for_all (fun (md, _) -> match md with SingleRepl r -> not (locInside r.trep_loc argLocs) | TriageRepl r -> true) otherFixes) in
+ registerValidate (Exp fExp) funValidate;
+ let fixArg =
+ let processSingleLabExp n (lab, ex) =
+ (* fprintf std_formatter "Fixing argument subexpression:\n";
+ Printcode.expression std_formatter ex;
+ fprintf std_formatter "\n";
+ flush stdout; *)
+ recurExpExp (ex, function ex' -> {exp with pexp_desc = Pexp_apply(fExp, replaceNthWith lab_exp_list n (lab,ex'))}) in
+ map_at processSingleLabExp lab_exp_list in
+ let deleteArg =
+ let removeSingleExp n =
+ (replaceExp []
+ (function () ->
+ if (List.length lab_exp_list = 1)
+ then {exp with pexp_desc = fExp.pexp_desc}
+ else {exp with pexp_desc =
+ Pexp_apply(fExp, removeNth n lab_exp_list)})
+ alwaysValid
+ ("Removed argument " ^ (sourceFromLoc (snd (List.hd (snd (splitAt n lab_exp_list)))).pexp_loc) ^ " from argument list of " ^ (sourceFromLoc exp.pexp_loc))
+ (t("Exp_Apply_DeleteArg"))
+ (snd (List.hd (snd (splitAt n lab_exp_list)))).pexp_loc) in
+ map_c removeSingleExp lab_exp_list in
+ let addGeneralArg =
+ let insertSingleExp n eOpt =
+ let nthLoc = match eOpt with
+ None -> {loc_start = exp.pexp_loc.loc_end; loc_end = exp.pexp_loc.loc_end; loc_ghost = true}
+ | Some (_, e) -> {loc_start = e.pexp_loc.loc_end; loc_end = e.pexp_loc.loc_end; loc_ghost = true} in
+ (replaceExp (declareException "ArgumentInserted")
+ (function () ->
+ {pexp_desc = Pexp_apply(fExp, insertNth lab_exp_list n ("", (alphaExp "ArgumentInserted" nthLoc)));
+ pexp_loc = nthLoc})
+ alwaysValid
+ ("Inserted new field before field " ^ string_of_int(n) ^ " (zero-indexed) into argument list " ^ (sourceFromLoc exp.pexp_loc))
+ (t("Exp_Apply_AddArg"))
+ nthLoc) in
+ map_between insertSingleExp lab_exp_list in
+ let swapArgs =
+ let swap n m = (* assume n < m *)
+ let (front, nAndTail) = splitAt n lab_exp_list in
+ let (nAndMid, mAndTail) = splitAt (m-n) nAndTail in
+ match (front, nAndMid, mAndTail) with
+ (front, n::mid, m::tail) -> front @ (m::mid) @ (n::tail)
+ | _ -> lab_exp_list in
+ let relocate n m =
+ let (min, max) = if (n < m) then (n,m) else (m,n) in
+ let (front, minAndTail) = splitAt min lab_exp_list in
+ let (minAndMid, maxAndTail) = splitAt (max-min) minAndTail in
+ if (n < m) then
+ match (front, minAndMid, maxAndTail) with
+ (front, minAndMid, m::tail) -> front @ (m::minAndMid) @ tail
+ | _ -> lab_exp_list
+ else
+ match (front, minAndMid, maxAndTail) with
+ (front, n::mid, maxAndTail) -> front @ mid @ (n::maxAndTail)
+ | _ -> lab_exp_list in
+ let allSwaps = List.filter (fun (m,n) -> (m < n))
+ (List.flatten (map_c (fun n -> map_c (fun m -> (n,m)) lab_exp_list) lab_exp_list)) in
+ let swapToMod (n,m) =
+ [(replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_apply(fExp, swap n m)})
+ alwaysValid
+ ("Swapped argument " ^ (string_of_int n) ^ " with argument " ^ (string_of_int m))
+ (t("Exp_Apply_SwapArgs"))
+ (locJoin (snd (List.nth lab_exp_list n)).pexp_loc (snd (List.nth lab_exp_list m)).pexp_loc));
+ (replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_apply(fExp, relocate n m)})
+ alwaysValid
+ ("Relocated argument " ^ (string_of_int m) ^ " to position " ^ (string_of_int n))
+ (t("Exp_Apply_RelocateArgs"))
+ (locJoin (snd (List.nth lab_exp_list n)).pexp_loc (snd (List.nth lab_exp_list m)).pexp_loc));
+ (replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_apply(fExp, relocate m n)})
+ alwaysValid
+ ("Relocated argument " ^ (string_of_int n) ^ " to position " ^ (string_of_int m))
+ (t("Exp_Apply_RelocateArgs"))
+ (locJoin (snd (List.nth lab_exp_list n)).pexp_loc (snd (List.nth lab_exp_list m)).pexp_loc))
+ ] in
+ List.flatten (List.map swapToMod allSwaps) in
+ let uncurryArgs =
+ if (List.length lab_exp_list > 1) then
+ let firstLoc = (snd (List.hd lab_exp_list)).pexp_loc in
+ let (argsAsList, loc) = List.fold_right (fun (lab, item) (accu, l) ->
+ ((item :: accu), locJoin item.pexp_loc l)) lab_exp_list ([], firstLoc) in
+ [(replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_apply(fExp, ["", {pexp_desc = Pexp_tuple argsAsList; pexp_loc = loc}])})
+ alwaysValid
+ "Changed a curried function into one taking a tuple"
+ (t("Exp_Apply_UncurryArgs"))
+ loc)]
+ else [] in
+ let curryArgs =
+ match lab_exp_list with
+ [(l, {pexp_desc = Pexp_tuple args; pexp_loc = loc})] ->
+ [(replaceExp []
+ (fun () -> {exp with pexp_desc = Pexp_apply(fExp, List.map (fun arg -> ("", arg)) args)})
+ alwaysValid
+ "Changed a tuple of arguments into curried form"
+ (t("Exp_Apply_CurryArgs"))
+ loc)]
+ | _ -> [] in
+ let rotateApply =
+ let rotateL =
+ match lab_exp_list with
+ [] -> []
+ | (l, e') :: leList ->
+ [(replaceExp []
+ (function () ->
+ {exp with pexp_desc =
+ Pexp_apply(fExp, [l, {pexp_desc = Pexp_apply(e', leList); pexp_loc = e'.pexp_loc}])})
+ alwaysValid
+ "Reassociated expression to the left"
+ (t("Exp_Apply_RotateL"))
+ (locJoin fExp.pexp_loc e'.pexp_loc));
+ ] in
+ let rotateR =
+ match lab_exp_list with
+ [] -> []
+ | (l, e') :: leList ->
+ match e'.pexp_desc with
+ Pexp_apply(gExp, gLEList) ->
+ [(replaceExp []
+ (function () ->
+ {exp with pexp_desc =
+ Pexp_apply(gExp,
+ ["",
+ {pexp_desc = Pexp_apply(fExp, List.rev_append (List.rev gLEList) leList);
+ pexp_loc = fExp.pexp_loc}])})
+ alwaysValid
+ "Reassociated expression to the right"
+ (t("Exp_Apply_RotateR"))
+ (locJoin e'.pexp_loc gExp.pexp_loc));
+ ]
+ | _ -> [] in
+ List.rev_append rotateL rotateR in
+ List.flatten (removeLabels :: fixSetfield :: fixFun :: fixArg :: deleteArg :: addGeneralArg :: curryArgs :: uncurryArgs :: swapArgs :: rotateApply :: [])
+ | Pexp_match (e, pat_exp_list) ->
+ (* match e with pat_exp_list *)
+ (* Possible errors:
+ * e is wrong
+ * some pattern doesn't have the right type
+ * nested pattern escaped to outer level
+ * non-exhaustive match error
+ *)
+ (* Possible fixes:
+ * fix e
+ * fix each pattern or expression
+ * try to reparenthesize -- change match m with A | B -> match n with (Z | Y -> foo | C -> bar) to be correct
+ * add a catch-all case
+ *)
+ let fixExp = [recurExpExp(e, (function e' -> {exp with pexp_desc = Pexp_match(e', pat_exp_list)}))] in
+ let fixCases =
+ let numCases = List.length pat_exp_list in
+ let processSingleCase n (pat', exp') =
+ (replaceExp (declareException "CaseReplaced")
+ (function () -> {exp with pexp_desc = Pexp_match(e, replaceNthWith pat_exp_list n (alphaPat pat'.ppat_loc, alphaExp "CaseReplaced" exp'.pexp_loc))})
+ (fun _ -> numCases > 1)
+ "Generalized an entire case"
+ (t("Exp_Match_FixCase"))
+ (locJoin pat'.ppat_loc exp'.pexp_loc)) in
+ map_at processSingleCase pat_exp_list in
+ let fixPatExps =
+ let processSinglePatExp n (pat, exp) =
+ [
+ recurPatExp (pat, (function pat' -> {exp with pexp_desc = Pexp_match(e, (replaceNthWith pat_exp_list n (pat', exp)))}));
+ recurExpExp (exp, (function exp' -> {exp with pexp_desc = Pexp_match(e, (replaceNthWith pat_exp_list n (pat, exp')))}));
+ ] in
+ map_at_and_flatten processSinglePatExp pat_exp_list in
+ let catchAll =
+ [(replaceExp (declareException "CatchAllMatch")
+ (function () ->
+ {exp with pexp_desc =
+ Pexp_match(e, List.rev ((alphaPat !locNone, alphaExp "CatchAllMatch" !locNone) ::
+ (List.rev pat_exp_list)))})
+ alwaysValid
+ "Added catch-all case to match expression"
+ (t("Exp_Match_CatchAll"))
+ exp.pexp_loc);
+ ] in
+ let fixNestedMatches = fixNestedTrysMatchsFunctions exp in
+ let triggerTriage = (TriggerTriage (Exp exp, (fun x -> x))) :: catchAll in
+ List.flatten (fixExp :: fixCases :: fixPatExps :: fixNestedMatches :: triggerTriage :: [])
+ | Pexp_lazy e ->
+ (* lazy someExp *)
+ (* Possible errors:
+ * Any expression error
+ * Should not be lazy
+ *)
+ (* Possible fixes:
+ * fixing the subexpression
+ * Removing the laziness
+ *)
+ [
+ (replaceExp []
+ (function () -> {exp with pexp_desc = e.pexp_desc})
+ alwaysValid
+ ("Removed laziness on expression " ^ (sourceFromLoc exp.pexp_loc))
+ (t("Exp_Lazy_RemoveLazy"))
+ exp.pexp_loc);
+ recurExpExp (e, (function exp' -> {exp with pexp_desc = Pexp_lazy exp'}));
+ ]
+ | Pexp_assert e ->
+ (* assert someExp *)
+ (* Possible errors:
+ * Any expression error
+ *)
+ (* Possible fixes:
+ * fixing the subexpression
+ *)
+ [recurExpExp (e, (function exp' -> {exp with pexp_desc = Pexp_assert exp'}))]
+ | Pexp_assertfalse -> []
+ in
+ let genericAndOther fallbacks = [followup genericSingleReplacements (fun _ -> [Attempt(otherSingleReplacements, noFollowups, fallbacks)])] in
+ let triggerTriage = (fun _ -> [TriggerTriage(Exp exp, (fun x -> x))]) in
+ if inMulti then
+ let idempotentSingleReplacement =
+ (replaceExp [] (function () -> exp) alwaysValid "Did Nothing" (t("Exp_Identity")) exp.pexp_loc) in
+ [Attempt([idempotentSingleReplacement], noFollowups, (fun _ -> genericAndOther triggerTriage))]
+ else genericAndOther (fun _ -> [Attempt([TriggerMulti(Exp exp, (fun x -> x))], noFollowups, triggerTriage)])
+
+ let destructNode astThing locOpt inMulti inTriage =
+ match astThing with
+ Exp exp -> destructExp exp locOpt inMulti inTriage
+ | StrItem strItem -> destructStrItem strItem locOpt
+ | Str str -> destructStr str locOpt
+ | Pat pat -> destructPat pat locOpt
+ | Typ typ -> destructTyp typ locOpt
+ | Mod md -> destructMod md locOpt
+ | Modty mty -> destructModty mty locOpt
+ | Tydec tyd -> destructTypdec tyd locOpt
+ | Cldec cld -> destructClassty cld locOpt
+ | Cldesc cld -> destructCldesc cld locOpt
+ | Cltydec ctd -> destructClasstydec ctd locOpt
+ | Clfield clf -> destructClfield clf locOpt
+ | Clexp cle -> destructClexp cle locOpt
+ | Clty clt -> destructClty clt locOpt
+ | Cltyfield cltf -> destructCltf cltf locOpt
+ | Sigitem sit -> destructSigitem sit locOpt
+
+
+
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXXXXX Triage Modification Enumerators XXXXXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ let triageNode astThing =
+ ignore(declareException "ELIDED_CODE");
+ ignore(declareException "ChangedType");
+ let expexpify ctx = fun x -> Exp (ctx (toExp x)) in
+ let patexpify ctx = fun x -> Exp (ctx (toPat x)) in
+ let elision = alphaExp "ELIDED_CODE" in
+ let adapter = alphaExp "ChangedType" in
+ let adaptThing t = match t with
+ Exp e -> Exp {pexp_desc = Pexp_sequence(e, adapter e.pexp_loc); pexp_loc = e.pexp_loc}
+ | Pat p -> Pat (alphaPat p.ppat_loc)
+ | _ -> print_string "adaptThing"; raise DynamicTypeError in
+ let alphaThing t = match t with
+ Exp e -> Exp (elision e.pexp_loc)
+ | Pat p -> Pat (alphaPat p.ppat_loc)
+ | _ -> print_string "alphaThing"; raise DynamicTypeError in
+
+ match astThing with
+ Exp exp ->
+ let expexpexpify ctx = fun x y -> Exp (ctx (toExp x) (toExp y)) in
+ begin match exp.pexp_desc with
+ | Pexp_constant c -> []
+ | Pexp_ident id -> []
+ | Pexp_assertfalse -> []
+ | Pexp_assert e ->
+ let eCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_assert _ -> {exp' with pexp_desc = Pexp_assert e}
+ | _ -> exp') in
+ [TriageElide [astThing, [(* Exp e *)], [(Exp e, adaptThing, eCtx (Exp (elision e.pexp_loc)), adaptThing, eCtx)]]]
+ | Pexp_tuple eList ->
+ (* how would I implement checking for both an erroneous subexp and a missing subexp? *)
+ let expCtxMakers =
+ let blankList = List.map (fun e -> elision e.pexp_loc) eList in
+ let expCtxMaker n en =
+ let expCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_tuple(eList') -> {exp' with pexp_desc = Pexp_tuple(replaceNthWith eList' n hole')}
+ | _ -> exp') in
+ let knockoutExp exp' = expCtx exp' (Exp (elision en.pexp_loc)) in
+ (Exp en, adaptThing, knockoutExp, adaptThing, expCtx) in
+ map_at expCtxMaker eList in
+ [TriageElide [astThing, [] (* List.rev_map (fun (h, _, _, _, _) -> h) expCtxMakers *), expCtxMakers]]
+ | Pexp_array eList ->
+ let expCtxMakers =
+ let blankList = List.map (fun e -> elision e.pexp_loc) eList in
+ let expCtxMaker n en =
+ let expCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_array(eList') -> {exp' with pexp_desc = Pexp_array(replaceNthWith eList' n hole')}
+ | _ -> exp') in
+ let knockoutExp exp' = expCtx exp' (Exp (elision en.pexp_loc)) in
+ (Exp en, adaptThing, knockoutExp, adaptThing, expCtx) in
+ map_at expCtxMaker eList in
+ [TriageElide [astThing, [] (* List.rev_map (fun (h, _, _, _, _) -> h) expCtxMakers *), expCtxMakers]]
+ | Pexp_sequence(e1,e2) ->
+ let sndCtxMaker =
+ let sndCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_sequence(f, _) -> {exp' with pexp_desc = Pexp_sequence(f, hole')}
+ | _ -> exp') in
+ let knockoutSnd exp' = sndCtx exp' (Exp (elision e1.pexp_loc)) in
+ (Exp e2, adaptThing, knockoutSnd, adaptThing, sndCtx) in
+ let fstCtxMaker =
+ let fstCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_sequence(_, s) -> {exp' with pexp_desc = Pexp_sequence(hole', s)}
+ | _ -> exp') in
+ let knockoutFst exp' = fstCtx exp' (Exp (elision e2.pexp_loc)) in
+ (Exp e1, adaptThing, knockoutFst, adaptThing, fstCtx) in
+ [TriageElide [astThing, [(* Exp e1; Exp e2 *)], [sndCtxMaker; fstCtxMaker]]]
+ | Pexp_ifthenelse (guard, iftrue, iffalseOpt) ->
+ let (elseE, elseLoc) = match iffalseOpt with None -> (adapter !locNone, !locNone) | Some e -> (e, e.pexp_loc) in
+ let elseCtxMaker =
+ let elseCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_ifthenelse(g, t, _) -> {exp' with pexp_desc = Pexp_ifthenelse(g, t, Some hole')}
+ | _ -> exp') in
+ let knockoutElse exp' = elseCtx exp' (Exp (elision elseLoc)) in
+ (Exp elseE, adaptThing, knockoutElse, adaptThing, elseCtx) in
+ let thenCtxMaker =
+ let thenCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_ifthenelse(g, _, e) -> {exp' with pexp_desc = Pexp_ifthenelse(g, hole', e)}
+ | _ -> exp') in
+ let knockoutThen exp' = thenCtx exp' (Exp (elision iftrue.pexp_loc)) in
+ (Exp iftrue, adaptThing, knockoutThen, adaptThing, thenCtx) in
+ let guardCtxMaker =
+ let guardCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_ifthenelse(_, t, e) -> {exp' with pexp_desc = Pexp_ifthenelse(hole', t, e)}
+ | _ -> exp') in
+ let knockoutGuard exp' = guardCtx exp' (Exp (elision guard.pexp_loc)) in
+ let idealCtx = expexpify (fun hole' -> {exp with pexp_desc =
+ Pexp_ifthenelse(hole', elision iftrue.pexp_loc, Some (elision elseLoc))}) in
+ (Exp guard, adaptThing, knockoutGuard, adaptThing <<== idealCtx, guardCtx) in
+ (* let holes = (Exp guard) :: (Exp iftrue) :: (match iffalseOpt with None -> [] | Some e -> [Exp e]) in *)
+ [TriageElide [astThing, [], [guardCtxMaker; thenCtxMaker; elseCtxMaker]]]
+ | Pexp_apply (fExp, lab_exp_list) ->
+ let funCtxMaker =
+ let funCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_apply(_, leList) -> {exp' with pexp_desc = Pexp_apply(hole', leList)}
+ | _ -> exp') in
+ let knockoutFun exp' = funCtx exp' (Exp (elision fExp.pexp_loc)) in
+ (Exp fExp, adaptThing, knockoutFun, adaptThing, funCtx) in
+ let argCtxMakers =
+ let argCtxMaker n (l, e) =
+ let argCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_apply(f, leList) -> {exp' with pexp_desc = Pexp_apply(f, replaceNthWith leList n (l, hole'))}
+ | _ -> exp') in
+ let knockoutArg exp' = argCtx exp' (Exp (elision e.pexp_loc)) in
+ (Exp e, adaptThing, knockoutArg, adaptThing, argCtx) in
+ map_at argCtxMaker lab_exp_list in
+ [TriageElide [astThing, [] (* (Exp fExp) :: (List.rev_map (fun (h, _, _, _, _) -> h) argCtxMakers) *), (List.rev_append argCtxMakers [funCtxMaker])]]
+ | Pexp_match (e, pat_exp_list) ->
+ let exppatexpify ctx = fun x y -> Exp (ctx (toExp x) (toPat y)) in
+ (* phase 1: just the matched expression *)
+ let blankMatch = {exp with pexp_desc = Pexp_match (e, [alphaPat e.pexp_loc, elision e.pexp_loc])} in
+ let matchCtxMaker =
+ let matchCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_match(_, peList) -> {exp' with pexp_desc = Pexp_match(hole', peList)}
+ | _ -> exp') in
+ let knockoutMatch exp' = matchCtx exp' (Exp (elision e.pexp_loc)) in
+ (Exp e, adaptThing, knockoutMatch, adaptThing, matchCtx) in
+ let phase1elided = map_and_flatten (fun (p,e) -> [Exp e; Pat p]) pat_exp_list in
+ let phase1 = (Exp blankMatch, phase1elided, [matchCtxMaker]) in
+ (* phase 2: the matched expression and the patterns *)
+ let rec stripLeafExps exp =
+ match exp.pexp_desc with
+ Pexp_match(e, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_match(e, peList')}, joinedElided)
+ | Pexp_try(e, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_try(e, peList')}, joinedElided)
+ | Pexp_function(l, dOpt, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_function(l, dOpt, peList')}, joinedElided)
+ | Pexp_sequence(e1, e2) ->
+ let (e2', elidedE2) = stripLeafExps e2 in
+ ({exp with pexp_desc = Pexp_sequence(elision e1.pexp_loc, e2')}, ((Exp e1) :: elidedE2))
+ | Pexp_let(r, peList, e) ->
+ let (e', elidedE) = stripLeafExps e in
+ let (blankPEs, es) = List.split (List.map (fun (p,e) -> ((p,elision e.pexp_loc), Exp e)) peList) in
+ ({exp with pexp_desc = Pexp_let(r, blankPEs, e')}, (List.rev_append es elidedE))
+ | _ -> (elision exp.pexp_loc, [Exp exp]) in
+ let (strippedTree, phase2elided) = stripLeafExps exp in
+ let patCtxMakers =
+ let patCtxMaker n (pn, en) =
+ let patCtx = exppatexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_match(e, peList) -> {exp' with pexp_desc = Pexp_match(e, replaceNthWith peList n (hole', elision en.pexp_loc))}
+ | _ -> exp') in
+ let knockoutPat exp' = patCtx exp' (Pat (alphaPat { loc_start = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_end = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_ghost = true })) in
+ let idealCtx = patexpify (fun pat' -> {strippedTree with pexp_desc = Pexp_match(e,
+ [(pat', elision en.pexp_loc);
+ (alphaPat pn.ppat_loc, elision en.pexp_loc)])}) in
+ (Pat pn, adaptThing, knockoutPat, adaptThing <<== idealCtx, patCtx) in
+ map_at patCtxMaker pat_exp_list in
+ let phase2 = (Exp strippedTree, phase2elided, patCtxMakers) in
+ (* phase 3: just the expressions *)
+ let expCtxMakers =
+ let expCtxMaker n (pn, en) =
+ let expCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_match(e, peList) -> {exp' with pexp_desc = Pexp_match(e, replaceNthWith peList n (pn, hole'))}
+ | _ -> exp') in
+ let knockoutExp exp' = expCtx exp' (Exp (elision en.pexp_loc)) in
+ let idealCtx = expexpify (fun hole' -> {exp with pexp_desc = Pexp_match(elision e.pexp_loc,
+ [(toPat (adaptThing (Pat pn)), hole');
+ (alphaPat pn.ppat_loc, elision en.pexp_loc)])}) in
+ (Exp en, adaptThing, knockoutExp, adaptThing <<== idealCtx, expCtx) in
+ map_at expCtxMaker pat_exp_list in
+ let phase3 = (astThing, [], expCtxMakers) in
+ [TriageElide [phase1; phase2; phase3]]
+ | Pexp_try (e, pat_exp_list) ->
+ let exppatexpify ctx = fun x y -> Exp (ctx (toExp x) (toPat y)) in
+ (* phase 1: just the matched expression *)
+ let blankMatch = {exp with pexp_desc = Pexp_try (e, [alphaPat e.pexp_loc, elision e.pexp_loc])} in
+ let tryCtxMaker =
+ let tryCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_try(_, peList) -> {exp' with pexp_desc = Pexp_try(hole', peList)}
+ | _ -> exp') in
+ let knockoutMatch exp' = tryCtx exp' (Exp (elision e.pexp_loc)) in
+ (Exp e, adaptThing, knockoutMatch, adaptThing, tryCtx) in
+ let phase1elided = map_and_flatten (fun (p,e) -> [Exp e; Pat p]) pat_exp_list in
+ let phase1 = (Exp blankMatch, phase1elided, [tryCtxMaker]) in
+ (* phase 2: the tryed expression and the patterns *)
+ let rec stripLeafExps exp =
+ match exp.pexp_desc with
+ Pexp_match(e, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_match(e, peList')}, joinedElided)
+ | Pexp_try(e, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_try(e, peList')}, joinedElided)
+ | Pexp_function(l, dOpt, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_function(l, dOpt, peList')}, joinedElided)
+ | Pexp_sequence(e1, e2) ->
+ let (e2', elidedE2) = stripLeafExps e2 in
+ ({exp with pexp_desc = Pexp_sequence(elision e1.pexp_loc, e2')}, ((Exp e1) :: elidedE2))
+ | Pexp_let(r, peList, e) ->
+ let (e', elidedE) = stripLeafExps e in
+ let (blankPEs, es) = List.split (List.map (fun (p,e) -> ((p,elision e.pexp_loc), Exp e)) peList) in
+ ({exp with pexp_desc = Pexp_let(r, blankPEs, e')}, (List.rev_append es elidedE))
+ | _ -> (elision exp.pexp_loc, [Exp exp]) in
+ let (strippedTree, phase2elided) = stripLeafExps exp in
+ let patCtxMakers =
+ let patCtxMaker n (pn, en) =
+ let patCtx = exppatexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_try(e, peList) -> {exp' with pexp_desc = Pexp_try(e, replaceNthWith peList n (hole', elision en.pexp_loc))}
+ | _ -> exp') in
+ let knockoutPat exp' = patCtx exp' (Pat (alphaPat { loc_start = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_end = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_ghost = true })) in
+ let idealCtx = patexpify (fun pat' -> {strippedTree with pexp_desc = Pexp_try(e,
+ [(pat', elision en.pexp_loc);
+ (alphaPat pn.ppat_loc, elision en.pexp_loc)])}) in
+ (Pat pn, adaptThing, knockoutPat, adaptThing <<== idealCtx, patCtx) in
+ map_at patCtxMaker pat_exp_list in
+ let phase2 = (Exp strippedTree, phase2elided, patCtxMakers) in
+ (* phase 3: just the expressions *)
+ let expCtxMakers =
+ let expCtxMaker n (pn, en) =
+ let expCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_try(e, peList) -> {exp' with pexp_desc = Pexp_try(e, replaceNthWith peList n (pn, hole'))}
+ | _ -> exp') in
+ let knockoutExp exp' = expCtx exp' (Exp (elision en.pexp_loc)) in
+ let idealCtx = expexpify (fun hole' -> {exp with pexp_desc = Pexp_try(elision e.pexp_loc,
+ [(toPat (adaptThing (Pat pn)), hole');
+ (alphaPat pn.ppat_loc, elision en.pexp_loc)])}) in
+ (Exp en, adaptThing, knockoutExp, adaptThing <<== idealCtx, expCtx) in
+ map_at expCtxMaker pat_exp_list in
+ let phase3 = (astThing, [], expCtxMakers) in
+ [TriageElide [phase1; phase2; phase3]]
+ | Pexp_function(lab, defaultOpt, peList) ->
+ let exppatexpify ctx = fun x y -> Exp (ctx (toExp x) (toPat y)) in
+ (* phase 1: just the default expression *)
+ let phase1 =
+ match defaultOpt with
+ None -> None
+ | Some def ->
+ let blankMatch = {exp with pexp_desc = Pexp_function(lab, Some def, [alphaPat def.pexp_loc, elision def.pexp_loc])} in
+ let functionCtxMaker =
+ let functionCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_function(lab, _, peList) -> {exp' with pexp_desc = Pexp_function(lab, Some hole', peList)}
+ | _ -> exp') in
+ let knockoutMatch exp' = functionCtx exp' (Exp (elision def.pexp_loc)) in
+ (Exp def, adaptThing, knockoutMatch, adaptThing, functionCtx) in
+ let phase1elided = map_and_flatten (fun (p,e) -> [Exp e; Pat p]) peList in
+ Some (Exp blankMatch, phase1elided, [functionCtxMaker]) in
+ (* phase 2: the matched expression and the patterns *)
+ let rec stripLeafExps exp =
+ match exp.pexp_desc with
+ Pexp_match(e, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_match(e, peList')}, joinedElided)
+ | Pexp_try(e, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_try(e, peList')}, joinedElided)
+ | Pexp_function(l, dOpt, peList) ->
+ let (peList', elidedLists) = List.split (List.map (fun (p, e) -> let (newE, elided) = stripLeafExps e in ((p, newE), elided)) peList) in
+ let joinedElided = List.fold_left List.rev_append [] elidedLists in
+ ({exp with pexp_desc = Pexp_function(l, dOpt, peList')}, joinedElided)
+ | Pexp_sequence(e1, e2) ->
+ let (e2', elidedE2) = stripLeafExps e2 in
+ ({exp with pexp_desc = Pexp_sequence(elision e1.pexp_loc, e2')}, ((Exp e1) :: elidedE2))
+ | Pexp_let(r, peList, e) ->
+ let (e', elidedE) = stripLeafExps e in
+ let (blankPEs, es) = List.split (List.map (fun (p,e) -> ((p,elision e.pexp_loc), Exp e)) peList) in
+ ({exp with pexp_desc = Pexp_let(r, blankPEs, e')}, (List.rev_append es elidedE))
+ | _ -> (elision exp.pexp_loc, [Exp exp]) in
+ let (strippedTree, phase2elided) = stripLeafExps exp in
+ let patCtxMakers =
+ let patCtxMaker n (pn, en) =
+ let patCtx = exppatexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_function(l, dOpt, peList) -> {exp' with pexp_desc = Pexp_function(l, dOpt, replaceNthWith peList n (hole', elision en.pexp_loc))}
+ | _ -> exp') in
+ let knockoutPat exp' = patCtx exp' (Pat (alphaPat { loc_start = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_end = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_ghost = true })) in
+ let idealCtx = patexpify (fun pat' -> {strippedTree with pexp_desc = Pexp_function(lab, defaultOpt,
+ [(pat', elision en.pexp_loc);
+ (alphaPat pn.ppat_loc, elision en.pexp_loc)])}) in
+ (Pat pn, adaptThing, knockoutPat, adaptThing <<== idealCtx, patCtx) in
+ map_at patCtxMaker peList in
+ let phase2 = (Exp strippedTree, phase2elided, patCtxMakers) in
+ (* phase 3: just the expressions *)
+ let expCtxMakers =
+ let expCtxMaker n (pn, en) =
+ let expCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_function(l, dOpt, peList) -> {exp' with pexp_desc = Pexp_function(l, dOpt, replaceNthWith peList n (pn, hole'))}
+ | _ -> exp') in
+ let knockoutExp exp' = expCtx exp' (Exp (elision en.pexp_loc)) in
+ let idealCtx = expexpify (fun hole' -> {exp with pexp_desc = Pexp_function(lab, defaultOpt,
+ [(toPat (adaptThing (Pat pn)), hole');
+ (alphaPat pn.ppat_loc, elision en.pexp_loc)])}) in
+ (Exp en, adaptThing, knockoutExp, adaptThing <<== idealCtx, expCtx) in
+ map_at expCtxMaker peList in
+ let phase3 = (astThing, [], expCtxMakers) in
+ [TriageElide (match phase1 with Some phase1 -> [phase1; phase2; phase3] | None -> [phase2; phase3])]
+ | Pexp_let (recFlag, peList, e) ->
+ let exppatexpify ctx = fun x y -> Exp (ctx (toExp x) (toPat y)) in
+ (* phase 1: binding patterns *)
+ let blankBodies = {exp with pexp_desc = Pexp_let(recFlag, List.map (fun (p, e) -> (p, elision e.pexp_loc)) peList, elision e.pexp_loc)} in
+ let patCtxMakers =
+ let patCtxMaker n (pn, en) =
+ let patCtx = exppatexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_let(rFlag, peList, e) -> {exp' with pexp_desc = Pexp_let(rFlag, replaceNthWith peList n (hole', elision en.pexp_loc), e)}
+ | _ -> exp') in
+ let knockoutPat exp' = patCtx exp' (Pat (alphaPat { loc_start = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_end = {Lexing.dummy_pos with pos_cnum = -666} ;
+ loc_ghost = true })) in
+ let idealCtx = patexpify (fun pat' -> {exp with pexp_desc = Pexp_let(recFlag, [pat', elision pat'.ppat_loc], elision e.pexp_loc)}) in
+ (Pat pn, adaptThing, knockoutPat, adaptThing <<== idealCtx, patCtx) in
+ map_at patCtxMaker peList in
+ let phase1elisions = (Exp e) :: (List.rev_map (fun (p, e) -> Exp e) peList) in
+ let phase1 = (Exp blankBodies, phase1elisions, patCtxMakers) in
+ (* phase 2: bound expressions *)
+ let blankInner = {exp with pexp_desc = Pexp_let(recFlag, peList, elision e.pexp_loc)} in
+ let expCtxMakers =
+ let expCtxMaker n (pn, en) =
+ let expCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_let(rFlag, peList, e) -> {exp' with pexp_desc = Pexp_let(rFlag, replaceNthWith peList n (pn, hole'), e)}
+ | _ -> exp') in
+ let knockoutExp exp' = expCtx exp' (Exp (elision en.pexp_loc)) in
+ (Exp en, adaptThing, knockoutExp, adaptThing, expCtx) in
+ map_at expCtxMaker peList in
+ let phase2elisions = [Exp e] in
+ let phase2 = (Exp blankInner, phase2elisions, expCtxMakers) in
+ (* phase 3: body expression *)
+ let eCtxMaker =
+ let eCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_let(rFlag, peList, _) -> {exp' with pexp_desc = Pexp_let(rFlag, peList, hole')}
+ | _ -> exp') in
+ let knockoutMatch exp' = eCtx exp' (Exp (elision e.pexp_loc)) in
+ (Exp e, adaptThing, knockoutMatch, adaptThing, eCtx) in
+ let phase3 = (astThing, [], [eCtxMaker]) in
+ [TriageElide [phase1; phase2; phase3]]
+ | Pexp_constraint(exp', sty1, sty2) -> []
+ | Pexp_construct (id, exp_opt, b) -> []
+ | Pexp_record (idExpList, eOpt) -> []
+ | Pexp_field(e, id) -> []
+ | Pexp_setfield(e1, id, e2) -> []
+ | Pexp_send(e, s) -> []
+ | Pexp_setinstvar(s, e) -> []
+ | Pexp_override seList -> []
+ | Pexp_poly(e, tyOpt) -> []
+ | Pexp_object patClsfieldList -> []
+ | Pexp_variant(l, eOpt) -> []
+ | Pexp_letmodule(name, modExp, exp') -> []
+ | Pexp_new id -> []
+ | Pexp_while(guard, body) ->
+ let guardCtxMaker =
+ let guardCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_while(_, body) -> {exp' with pexp_desc = Pexp_while(hole', body)}
+ | _ -> exp') in
+ let knockoutGuard exp' = guardCtx exp' (Exp (elision guard.pexp_loc)) in
+ (Exp guard, adaptThing, knockoutGuard, adaptThing, guardCtx) in
+ let bodyCtxMaker =
+ let bodyCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_while(guard, _) -> {exp' with pexp_desc = Pexp_while(guard, hole')}
+ | _ -> exp') in
+ let knockoutBody exp' = bodyCtx exp' (Exp (elision body.pexp_loc)) in
+ (Exp body, adaptThing, knockoutBody, adaptThing, bodyCtx) in
+ [TriageElide [(Exp exp, [], [guardCtxMaker; bodyCtxMaker])]]
+ | Pexp_for(v, init, term, dir, body) ->
+ let initCtxMaker =
+ let initCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_for(v, _, term, dir, body) -> {exp' with pexp_desc = Pexp_for(v, hole', term, dir, body)}
+ | _ -> exp') in
+ let knockoutGuard exp' = initCtx exp' (Exp (elision init.pexp_loc)) in
+ (Exp init, adaptThing, knockoutGuard, adaptThing, initCtx) in
+ let termCtxMaker =
+ let termCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_for(v, init, _, dir, body) -> {exp' with pexp_desc = Pexp_for(v, init, hole', dir, body)}
+ | _ -> exp') in
+ let knockoutGuard exp' = termCtx exp' (Exp (elision term.pexp_loc)) in
+ (Exp term, adaptThing, knockoutGuard, adaptThing, termCtx) in
+ let bodyCtxMaker =
+ let bodyCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_for(v, init, term, dir, _) -> {exp' with pexp_desc = Pexp_for(v, init, term, dir, hole')}
+ | _ -> exp') in
+ let knockoutBody exp' = bodyCtx exp' (Exp (elision body.pexp_loc)) in
+ (Exp body, adaptThing, knockoutBody, adaptThing, bodyCtx) in
+ [TriageElide [(Exp exp, [], [initCtxMaker; termCtxMaker; bodyCtxMaker])]]
+ | Pexp_when(guard, case) ->
+ let guardCtxMaker =
+ let guardCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_when(_, case) -> {exp' with pexp_desc = Pexp_when(hole', case)}
+ | _ -> exp') in
+ let knockoutGuard exp' = guardCtx exp' (Exp (elision guard.pexp_loc)) in
+ (Exp guard, adaptThing, knockoutGuard, adaptThing, guardCtx) in
+ let caseCtxMaker =
+ let caseCtx = expexpexpify (fun exp' hole' -> match exp'.pexp_desc with
+ Pexp_when(guard, _) -> {exp' with pexp_desc = Pexp_when(guard, hole')}
+ | _ -> exp') in
+ let knockoutBody exp' = caseCtx exp' (Exp (elision case.pexp_loc)) in
+ (Exp case, adaptThing, knockoutBody, adaptThing, caseCtx) in
+ [TriageElide [(Exp exp, [], [guardCtxMaker; caseCtxMaker])]]
+ | Pexp_lazy e -> []
+ end
+ | _ -> (* print_string ("Failure: not an Exp: " ^ (nameOf astThing) ^ "\n"); *) []
+
+
+
+
+
+
+
+ let addPrologue prologue program = List.rev_append (List.rev prologue) program
+ let totalMods = ref 0
+ let totalInterestingNodes = ref 0
+ let totalAttempts = ref 0
+ let rec explore outerCtx searchCtx innerCtxLst typeAst locOpt astThing : searchResults =
+
+
+ let rec attemptSearcher searcher (mods, followups, fallbacks) : searchResults =
+ incr totalAttempts;
+ decr totalMods;
+ let modsThatWorked = map_and_flatten searcher (List.rev mods) in (* List.fold_left List.rev_append [] (List.rev_map searcher mods) in *)
+ match modsThatWorked with
+ [] -> map_and_flatten searcher (fallbacks ()) (* List.fold_left List.rev_append [] (List.rev_map searcher (fallbacks ())) *)
+ | _ ->
+ let moreMods = map_and_flatten searcher (followups ()) in (* List.fold_left List.rev_append [] (List.rev_map searcher (followups ())) in *)
+ let validMods = List.filter (fun (r, _) -> match r with SingleRepl r -> r.trep_validate() | _ -> true) modsThatWorked in
+ List.rev_append validMods moreMods
+
+ and search inMulti inTriage outerCtx searchCtx innerCtxLst astmod : searchResults =
+ incr totalMods;
+ match astmod with
+ Attempt (mods, followups, fallbacks) ->
+ attemptSearcher (search inMulti inTriage outerCtx searchCtx innerCtxLst) (mods, followups, fallbacks)
+ | TriggerSingle (hole, ctx) ->
+ searchSingle inMulti inTriage (outerCtx <<== ctx) ctx (narrowContext innerCtxLst ctx) hole
+ | TriggerMulti (hole, ctx) ->
+ if (not inMulti) then searchMulti inMulti inTriage (outerCtx <<== ctx) ctx (narrowContext innerCtxLst ctx) hole else []
+ | TriggerTriage (hole, ctx) ->
+ if (!Clflags.no_triage) then []
+ else if (inTriage) then []
+ else searchTriage inMulti inTriage (outerCtx <<== ctx) ctx (narrowContext innerCtxLst ctx) hole
+ | _ -> print_string ("Should not have happened! Modification is search-specific: " ^ (astRevisionName astmod) ^ "\n");
+ raise DynamicTypeError
+
+ and searchSingle inMulti inTriage outerCtx searchCtx innerCtxLst astThing : searchResults =
+ incr totalInterestingNodes;
+ let mods = destructNode astThing locOpt inMulti inTriage in
+ let rec trySingleMod md =
+ incr totalMods;
+ match md with
+ Attempt (mods, followups, fallbacks) ->
+ attemptSearcher trySingleMod (mods, followups, fallbacks)
+ | SingleRecur (hole, ctx) ->
+ searchSingle inMulti inTriage (outerCtx <<== ctx) (searchCtx <<== ctx) (narrowContext innerCtxLst ctx) hole
+ | SingleReplace r ->
+ let revision = r.trep_revision () in
+ let newProg = toStr (outerCtx revision) in
+ begin try
+ let ast = addPrologue !globalPrologue (addPrologue r.trep_prologue newProg) in
+ let (typedAST, _) = typeAst ast in
+ let newR = SingleRepl {r with trep_type = findType typedAST (itemLocation revision)} in
+ [newR, (outerCtx, searchCtx, (widestContext innerCtxLst))]
+ with y -> [] end
+ | _ -> search inMulti inTriage outerCtx searchCtx innerCtxLst md
+ in map_and_flatten trySingleMod (List.rev mods) (* List.fold_left List.rev_append [] (List.rev_map trySingleMod mods) *)
+
+ and searchMulti inMulti inTriage outerCtx searchCtx innerCtxLst astThing : searchResults =
+ (* print_string "Multisearch not implemented\n"; *)
+ []
+
+ and searchTriage inMulti inTriage outerCtx searchCtx innerCtxLst astThing : searchResults =
+ incr totalInterestingNodes;
+ let tryExp exp outerCtx =
+ try
+ ignore(typeAst (addPrologue !globalPrologue (toStr (outerCtx exp)))); true
+ with _ -> false in
+ let triageRepl (p, i, t, a, o, d, g, l, r) =
+ TriageRepl {ttri_prologue = p; ttri_idealctx = i; ttri_triaged = t; ttri_adapted = a; ttri_original = o; ttri_desc = d; ttri_tag = g; ttri_locs = l; ttri_replaced = r} in
+ let mods = triageNode astThing in
+ let rec tryTriageMod md =
+ incr totalMods;
+ match md with
+ Attempt (mods, followups, fallbacks) ->
+ attemptSearcher tryTriageMod (mods, followups, fallbacks)
+ | TriageElide phases ->
+ let processRefExp refExp elidedExps =
+ if elidedExps = [] then [] else (* if nothing's been changed, why bother re-searching what already failed? *)
+ let singleSearch = search inMulti true outerCtx searchCtx innerCtxLst (TriggerSingle (refExp, (fun x -> x))) in
+ let wrapSingle (md, (outerCtx', searchCtx', innerCtx')) =
+ match md with
+ SingleRepl r -> (triageRepl ([], searchCtx', elidedExps, [], astThing,
+ "Knocked out all leaf expressions, and " ^ r.trep_desc, t("Triage_SingleFix"),
+ List.rev_map itemLocation elidedExps, {r with trep_replaced = (if r.trep_replaced = refExp then astThing else r.trep_replaced)}),
+ (outerCtx, searchCtx', widestContext innerCtxLst))
+ | TriageRepl r -> print_string "Should not have happened!\n"; raise DynamicTypeError
+ in List.rev_map wrapSingle singleSearch in
+ let processElisions elisions elidedExps =
+ (* figure out which subexpressions don't typecheck even in an ideal context *)
+ let revTypecorrectInIdeal = List.rev_map (function (hole, _, _, ideal, _) as el -> (el, tryExp (ideal hole) outerCtx)) elisions in
+ (* and knock them out of consideration *)
+ let (mustBeKnockedout, elided) = List.fold_left (fun (accuKO, accuEl) ((hole, _, knockout, _, _) as el, tcInIdeal) ->
+ if tcInIdeal then (accuKO, accuEl) else (knockout :: accuKO, el :: accuEl)) ([], []) revTypecorrectInIdeal in
+ let knockedOut = List.fold_left (fun exp ko -> ko exp) astThing mustBeKnockedout in
+ (* adapt everything else, then greedily unadapt them *)
+ let (adaptRest, adaptedHoles) = List.fold_left (fun (accuExp, accuEl) ((hole, adapt, _, _, ctx) as el, tcInIdeal) ->
+ if tcInIdeal then (ctx accuExp (adapt hole), el :: accuEl) else (accuExp, accuEl)) (knockedOut, []) revTypecorrectInIdeal in
+ let (minAdapted, minAdaptedHoles) =
+ let unAdaptIfPossible (accuExp, accuEl) ((hole, _, _, _, ctx) as el) =
+ if tryExp hole (outerCtx <<== (ctx accuExp)) then (ctx accuExp hole, accuEl) else (accuExp, el :: accuEl) in
+ List.fold_left unAdaptIfPossible (adaptRest, []) adaptedHoles in
+ (* for those knocked out, try individual fixes *)
+ let elideAllButOne = map_at
+ (fun n lst -> (List.fold_left (fun accu f -> accu <<== f) (fun x -> x) lst,
+ List.nth elided n,
+ List.rev_map (fun (h, _, _, _, _) -> h) (removeNth n elided))) (* for each list below, compose all the functions together, and return the nth thing and all-but-nth *)
+ (map_c (fun n -> removeNth n mustBeKnockedout) mustBeKnockedout) in (* construct the list of lists where one element was removed *)
+ (* for each one of these all-but-one-knockedout contexts *)
+ let processSingleHole (ko, (hole, _, _, _, ctx), knockedOut) =
+ (* search for a single-point fix to them, since other problems have been elided *)
+ let searchMds = search inMulti true outerCtx searchCtx innerCtxLst (TriggerSingle(hole, (ctx minAdapted))) in
+ (* again greedily remove as many unnecessary adaptations as possible *)
+ let unAdaptIfPossible (md, (outerCtx', searchCtx', innerCtx')) =
+ let (rev, rctx) = match md with
+ SingleRepl r -> (r.trep_revision ()), searchCtx'
+ | TriageRepl r -> (r.ttri_replaced.trep_revision()), r.ttri_idealctx in
+ List.fold_left (* this returns a new context which undoes the adaptations, and a list of those still adapted *)
+ (fun (accu, adapted) (hole, _, _, _, ctx) -> if tryExp hole (outerCtx <<== (ctx (accu rev))) then ((fun rev' -> ctx (accu rev') hole), adapted) else (accu, hole :: adapted))
+ (rctx, []) adaptedHoles in
+ (* wrap the found changes in a TriageRepl, which indicates what has been knocked out or adapted *)
+ let fullKnockedOut = List.rev_append elidedExps knockedOut in
+ let wrapSingleFix (md, (outerCtx', searchCtx', innerCtx')) =
+ let (newSearchCtx, adapted) = unAdaptIfPossible (md, (outerCtx', searchCtx', innerCtx')) in
+ match md with
+ SingleRepl r -> (triageRepl ([], newSearchCtx, fullKnockedOut, adapted, astThing,
+ "1Adapted some expressions, knocked some out, and " ^ r.trep_desc, t("Triage_Elide"),
+ List.rev_map itemLocation (List.rev_append fullKnockedOut adapted), r), (outerCtx, newSearchCtx, widestContext innerCtxLst))
+ | TriageRepl r -> (triageRepl ([], newSearchCtx, fullKnockedOut, adapted, astThing,
+ "2Adapted some expressions, knocked some out, and " ^ r.ttri_desc, r.ttri_replaced.trep_tag,
+ List.rev_map itemLocation (List.rev_append fullKnockedOut adapted), r.ttri_replaced), (outerCtx, newSearchCtx, widestContext innerCtxLst))
+ in List.rev_map wrapSingleFix searchMds in
+ (* put it all together: process each hole as above *)
+ map_and_flatten processSingleHole elideAllButOne in
+ let rec processTriagePhaseList triagePhases =
+ match triagePhases with
+ [] -> []
+ | (refExp, elidedExps, elisions) :: tl ->
+ if (tryExp refExp outerCtx) then
+ processTriagePhaseList tl
+ else
+ List.rev_append (processRefExp refExp elidedExps) (processElisions elisions elidedExps) in
+ processTriagePhaseList phases
+ | _ -> search inMulti true outerCtx searchCtx innerCtxLst md
+ in map_and_flatten tryTriageMod mods
+
+ in (search false false outerCtx searchCtx innerCtxLst (TriggerSingle (astThing, searchCtx)))
+
+
+
+
+ let seminalSearch typeAst ast locOpt : (replacement * (astContext * astContext)) list =
+ let fixes = explore (fun x -> x) (fun x -> x) (makeContext 5) typeAst locOpt (Str ast) in
+ List.map (fun (rep, (outerCtx, _, innerCtx)) -> (rep, (innerCtx, outerCtx))) fixes
+
+ ;;
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+ (* XXXXXXXXXXXXXXXXXXXX Ranking and Reporting XXXXXXXXXXXXXXXXXXXXXX *)
+
+ (* Thoughts: reorder this list, in desired sorted order. Is that possible? Is there a consistent sort order? *)
+ let initTags () = List.iter (fun s -> ignore(t s)) [
+ "Triage_SingleFix"; "Triage_Elide";
+ "Exp_Apply_AddArg"; "Exp_Apply_DeleteArg"; "Exp_Apply_FixArg"; "Exp_Apply_FixFun"; "Exp_Apply_GeneralizeApply"; "Exp_Apply_CurryArgs"; "Exp_Apply_UncurryArgs";
+ "Exp_Apply_SwapArgs"; "Exp_Apply_RelocateArgs"; "Exp_Apply_RemoveLabels"; "Exp_Apply_SingleReplaceBinding"; "Exp_Apply_RotateL"; "Exp_Apply_RotateR";
+ "Exp_Apply_RemoveFun"; "Exp_Ident_FixId"; "Exp_Ident_Deref";
+ "Exp_Array_FixSubexp"; "Exp_Assert_FixSubexp"; "Exp_Constraint_FixSubexp"; "Exp_Constraint_RemoveConstraint";
+ "Exp_Construct_DeleteBody"; "Exp_Construct_FixSubexp"; "Exp_Construct_GeneralizeBody"; "Exp_Construct_FixTuplelist"; "Exp_Construct_RotateConstructs"; "Exp_Construct_FixUnitList";
+ "Exp_Field_FixId"; "Exp_Field_FixSubexp"; "Exp_For_FixBody"; "Exp_For_FixInit"; "Exp_For_FixTerm"; "Exp_Function_AddParamAfter";
+ "Exp_Function_SwapArgs"; "Exp_Function_RelocateArgs"; "Exp_Adapt"; "Exp_Function_CurryArgs"; "Exp_Function_UncurryArgs";
+ "Exp_Function_AddParamBefore"; "Exp_Function_FixDefault"; "Exp_Function_FixSubexp"; "Exp_Function_FixSubpat";
+ "Exp_Function_GeneralizedCase"; "Exp_Function_RemoveDefault"; "Exp_Function_RemoveParam"; "Exp_If_FixElse"; "Exp_If_FixTest";
+ "Exp_If_FixThen"; "Exp_If_RemoveElse"; "Exp_If_DanglingElse"; "Exp_Lazy_FixSubexp"; "Exp_Lazy_RemoveLazy"; "Exp_Let_DeleteBinding"; "Exp_Let_FixRec";
+ "Exp_Let_FixSubexp"; "Exp_Let_FixSubpat"; "Exp_Let_FixTarget"; "Exp_Let_HoistInner"; "Exp_Letmodule_FixExp";
+ "Exp_Letmodule_FixModexp"; "Exp_Let_ReplaceAllBindings"; "Exp_Match_CatchAll"; "Exp_Match_FixCase";
+ "Exp_Match_FixMatchexp"; "Exp_Match_FixSubexp"; "Exp_Match_FixSubpat"; "Exp_Object_Removed"; "Exp_Override_FixStr";
+ "Exp_Override_FixSubexp"; "Exp_Poly_FixSubexp"; "Exp_Poly_FixTy"; "Exp_Record_FixId"; "Exp_Record_FixIdExp";
+ "Exp_Record_FixOptSubexp"; "Exp_Remove"; "Exp_Send_FixStr"; "Exp_Send_FixSubexp"; "Exp_Sequence_FixLeft";
+ "Exp_Sequence_FixRight"; "Exp_Setfield_FixId"; "Exp_Setfield_FixSubexp1"; "Exp_Setfield_FixSubexp2";
+ "Exp_Setinstvar_FixStr"; "Exp_Setinstvar_FixSubexp"; "Exp_Try_CatchAll"; "Exp_Try_FixBody"; "Exp_Try_FixSubexp";
+ "Exp_Try_FixSubpat"; "Exp_TryMatch_Reparenthesize"; "Exp_Tuple_AddItem"; "Exp_Tuple_DeleteItem";
+ "Exp_Variant_AddBody"; "Exp_Variant_FixSubexp"; "Exp_Variant_SingleReplaceSubexp";
+ "Exp_When_FixCase"; "Exp_When_FixGuard"; "Exp_When_RemoveGuard"; "Exp_While_FixBody"; "Exp_While_FixGuard";
+ "Mod_Apply_FixNestedApp1"; "Mod_Apply_FixNestedApp2"; "Mod_Constraint_FixNestedMod"; "Mod_Constraint_FixNestedType";
+ "Mod_Constraint_Relax"; "Mod_Functor_FixNestedMod"; "Mod_Functor_FixNestedType"; "Mod_Remove"; "Mod_Structure_FixStr";
+ "Pat_Alias_FixSubpat"; "Pat_Alias_RemoveSubpat"; "Pat_Remove"; "Pat_Tuple_FixSubpat"; "Pat_Tuple_InsertSubpat";
+ "Pat_Tuple_RemoveSubpat"; "Prog_Truncate"; "Str_Class_FixClass"; "Str_Class_RemoveAll"; "Str_Class_RemoveOne";
+ "Str_ClassType_FixClassType"; "Str_ClassType_RemoveOne"; "Str_Eval_Subexpression"; "Str_Exception_RemoveBody";
+ "Str_ExnRebind_Unalias"; "Str_Include_FixModexp"; "Stritem_Remove"; "Str_Modtype_FixModty"; "Str_Module_FixModexp"; "Str_Open_Remove";
+ "Str_Primitive_FixType"; "Str_Recmodule_Modty"; "Str_Recmodule_Module"; "Str_Recmodule_RemoveAll";
+ "Str_Recmodule_RemoveOne"; "Str_Type_FixType"; "Str_Value_FixRec"; "Str_Value_RemoveAll"; "Str_Value_Subexpression";
+ "Str_Value_Subpattern"; "Typ_Constr_FixSubtyp"; "Typ_Constr_Generalize"; "TAGS_INITIALIZED"
+ ]
+
+ module ModDominanceMap = Map.Make(struct type t = int * int let compare = compare end)
+ type dominance = Does | DoesNot | Maybe | NotSure
+ let string_of_dom d = match d with Does -> "Does" | DoesNot -> "DoesNot" | Maybe -> "Maybe" | NotSure -> "NotSure"
+ let modDominance = ref ModDominanceMap.empty
+
+
+
+ let domRel = [ (* most specific rules must come first *)
+ ("Triage_SingleFix", "Triage_Elide", Does);
+ ("Triage_Elide", "Triage_SingleFix", DoesNot);
+ ("Exp_TryMatch_Reparenthesize", "*", Does);
+ ("*", "Exp_TryMatch_Reparenthesize", DoesNot);
+ ("Exp_Tuple_RelocateArgs", "Exp_Tuple_SwapArgs", DoesNot);
+ ("Exp_Tuple_SwapArgs", "Exp_Tuple_RelocateArgs", Does);
+ ("Exp_Apply_RelocateArgs", "Exp_Apply_SwapArgs", DoesNot);
+ ("Exp_Apply_SwapArgs", "Exp_Apply_RelocateArgs", Does);
+ ("Exp_Function_RelocateArgs", "Exp_Function_SwapArgs", DoesNot);
+ ("Exp_Function_SwapArgs", "Exp_Function_RelocateArgs", Does);
+ ("Exp_Apply_RotateL", "Exp_Apply_RotateR", NotSure);
+ ("Exp_Apply_RotateR", "Exp_Apply_RotateL", NotSure);
+ (* ("Exp_Adapt", "Exp_Construct_FixTuplelist", DoesNot); *)
+ ("Exp_Construct_FixTuplelist", "*", Does);
+ ("Exp_Apply_RelocateArgs", "*", Does);
+ ("Exp_Apply_SwapArgs", "*", Does);
+ ("Exp_Function_RelocateArgs", "*", Does);
+ ("Exp_Function_SwapArgs", "*", Does);
+ ("Exp_Apply_RotateR", "*", Does);
+ ("Exp_Apply_RotateL", "*", Does);
+ ("Exp_Function_CurryArgs", "Exp_Apply_CurryArgs", DoesNot);
+ ("Exp_Function_UncurryArgs", "Exp_Apply_UncurryArgs", DoesNot);
+ ("Exp_Apply_CurryArgs", "Exp_Function_CurryArgs", DoesNot);
+ ("Exp_Apply_UncurryArgs", "Exp_Function_UncurryArgs", DoesNot);
+ ("Exp_Function_CurryArgs", "*", Does);
+ ("Exp_Function_UncurryArgs", "*", Does);
+ ("Exp_Apply_CurryArgs", "*", Does);
+ ("Exp_Apply_UncurryArgs", "*", Does);
+ ("Stritem_Remove", "Exp_Remove", DoesNot);
+ ("Exp_Tuple_DeleteItem", "Exp_Adapt", DoesNot);
+ ("Exp_Tuple_*", "Exp_Adapt", Does);
+ ("Exp_Adapt", "Exp_Tuple_DeleteArg", Does);
+ ("Exp_Adapt", "Exp_Tuple_*", DoesNot);
+ ("Exp_Apply_DeleteArg", "Exp_Adapt", DoesNot);
+ ("Exp_Apply_*", "Exp_Adapt", Does);
+ ("Exp_Adapt", "Exp_Apply_DeleteArg", Does);
+ ("Exp_Adapt", "Exp_Apply_*", DoesNot);
+ (* ("Exp_Adapt", "*", Does);*)
+ ("*", "Exp_Apply_DeleteArg", Does);
+ ("*", "Exp_Function_Remove*", Does);
+ ("*", "Exp_Function_GeneralizedCase", Does);
+ ("*", "Exp_Match_FixCase", Does);
+ ("*", "Mod_Remove", Does);
+ ("*", "Pat_Remove", Does);
+ ("*", "Stritem_Remove", Does);
+ ("*", "Exp_Remove", Does);
+ ("*", "Prog_Truncate", Does);
+ ("*", "Exp_Let_ReplaceAllBindings", Does);
+ ("*", "Str_Value_RemoveAll", Does);
+ ]
+
+
+
+
+ let initDominance () =
+ (* make sure all tags have been seen *)
+ try (ignore(ModDominanceMap.find (t("TAGS_INITIALIZED"), t("TAGS_INITIALIZED")) !modDominance))
+ with Not_found -> begin
+ initTags();
+ let tags = TagMap.fold (fun k _ tags -> k :: tags) !modTags [] in
+ (* empty the dominance map *)
+ modDominance := ModDominanceMap.empty;
+ (* initialize the map to the identity mapping *)
+ modDominance := TagMap.fold
+ (fun k1 d1 mprev -> TagMap.fold
+ (fun k2 d2 map -> (if (d1=d2) then ModDominanceMap.add (d1, d2) Does map else map))
+ !modTags
+ mprev)
+ !modTags
+ ModDominanceMap.empty;
+ (* add any manually described pairs. * is the wildcard, representing total dominance up to that point in the name *)
+ modDominance := List.fold_right
+ (fun (t1, t2, rel) map ->
+ let star_idx1 = try String.index t1 '*' with _ -> -1 in
+ let star_idx2 = try String.index t2 '*' with _ -> -1 in
+ let prefix1 = try String.sub t1 0 star_idx1 with _ -> t1 in
+ let prefix2 = try String.sub t2 0 star_idx2 with _ -> t2 in
+ let k1s = (List.filter (fun s1 -> (try (String.sub s1 0 star_idx1) with _ -> s1) = prefix1) tags) in
+ let k2s = (List.filter (fun s2 -> (try (String.sub s2 0 star_idx2) with _ -> s2) = prefix2) tags) in
+ List.fold_right (fun k1 map ->
+ let d1 = t(k1) in
+ List.fold_right (fun k2 map -> ModDominanceMap.add (d1, t(k2)) rel map)
+ k2s map)
+ k1s map)
+ domRel
+ !modDominance;
+ end
+ let smartFindDom t map = (try ModDominanceMap.find t map with Not_found -> DoesNot)
+
+
+
+ (* Based on algorithm in Zhang & Shasha, 1987 *)
+ (* Based further on Barnard 1995 *)
+ type teOp =
+ TEDelNode of int * int
+ | TEInsNode of int * int
+ | TEDelTree of int * int
+ | TEInsTree of int * int
+ | TEChange of int * int
+ | TERotR of int * int * int * int
+ | TERotL of int * int * int * int
+ | TENone
+ let treeEditDistance t1 t2 pr =
+ let rec treeSize t = 1 + List.fold_left (+) 0 (List.rev_map treeSize t.past_kids) in
+ let gammaIns x = 2 in (* change these later *)
+ let gammaDel x = 2 in
+ let gammaSwap x y = 2 in
+ let gammaDelTree x = (gammaDel x) * (treeSize x) / 2 in
+ let gammaInsTree x = max ((gammaIns x) * (treeSize x) / 2) 1 in
+ let gammaChange x y = if equalNode x y then 0 else ((gammaDel x) + (gammaIns y)) / 3 in
+ let gammaRotR b1 a1 b2 a2 = ((gammaChange a1 a2) + (gammaChange b1 b2)) / 2 + 2 in
+ let gammaRotL a1 b1 a2 b2 = ((gammaChange a1 a2) + (gammaChange a2 b2)) / 2 + 2 in
+ let postorderLRNumbering t =
+ let len = treeSize t in
+ let n = Array.make (len+1) t in
+ let p = Array.make (len+1) (-1) in
+ let rec postorder (startIdx, sibIdxs) node =
+ let (lastKidIdx, revKidIdxs) = List.fold_left postorder (startIdx, []) node.past_kids in
+ let myIdx = lastKidIdx + 1 in
+ n.(myIdx) <- node;
+ List.iter (fun kidIdx -> (p.(kidIdx) <- myIdx)) revKidIdxs;
+ (myIdx, myIdx :: sibIdxs) in
+ ignore(postorder (0, []) t);
+ (len, n, p) in
+ let computeLeftmost (len, p) =
+ let l = Array.make (len+1) (-1) in
+ for i = 1 to len do
+ if l.(i) = -1 then
+ l.(i) <- i; (* I am my leftmost *)
+ if (p.(i) <> -1) && (l.(p.(i)) = -1) then
+ l.(p.(i)) <- l.(i) (* if my parent isn't set, set parent *)
+ done;
+ l in
+ let keyrootsLR (len, l, p) =
+ let (_, revKeyroots) = Array.fold_left (fun (curIdx,curLRkeyroots) _ ->
+ if (curIdx = 0) then (curIdx + 1, curLRkeyroots) else
+ if ((curIdx < len) && (l.(curIdx) <> l.(p.(curIdx)))) then
+ (curIdx + 1, curIdx :: curLRkeyroots)
+ else
+ (curIdx + 1, curLRkeyroots)
+ ) (0,[]) l in
+ let keyroots = Array.of_list (List.rev (len::revKeyroots)) in
+ (Array.length keyroots, keyroots) in
+ let (len1, n1, p1) = postorderLRNumbering t1 in
+ let (len2, n2, p2) = postorderLRNumbering t2 in
+ let l1 = computeLeftmost (len1, p1) in
+ let l2 = computeLeftmost (len2, p2) in
+ let (lenKR1, keyroots1) = keyrootsLR (len1, l1, p1) in
+ let (lenKR2, keyroots2) = keyrootsLR (len2, l2, p2) in
+ let min xs = List.fold_left
+ (fun (wacc, cacc) (w', c') -> if w' < wacc then (w', c') else (wacc, cacc)) (List.hd xs) xs in
+ let treedist = Array.make_matrix (len1 + 1) (len2 + 1) ((gammaDelTree t1)+(gammaInsTree t2)) in
+ let treeedit = Array.make_matrix (len1 + 1) (len2 + 1) [] in
+ let computeTreedist i j =
+ let li = l1.(i) in
+ let lj = l2.(j) in
+ let forestdist = Array.make_matrix (i-li + 2) (j-lj + 2) ((gammaDelTree n1.(i)) + (gammaInsTree n2.(j))) in
+ let forestedit = Array.make_matrix (i-li + 2) (j-lj + 2) [] in
+ forestdist.(0).(0) <- 0;
+ forestedit.(0).(0) <- [TENone];
+ for i' = li to i do
+ forestdist.(i'-li+1).(0) <- forestdist.(l1.(i')-li).(0) + gammaDelTree(n1.(i'));
+ forestedit.(i'-li+1).(0) <- TEDelTree(i',lj) :: forestedit.(l1.(i')-li).(0);
+ done;
+ for j' = lj to j do
+ forestdist.(0).(j'-lj+1) <- forestdist.(0).(l2.(j')-lj) + gammaInsTree(n2.(j'));
+ forestedit.(0).(j'-lj+1) <- TEInsTree(li,j') :: forestedit.(0).(l2.(j')-lj);
+ done;
+ for i' = li to i do
+ for j' = lj to j do
+ let rotates =
+ List.flatten
+ [
+ (try
+ let a1 = i' and b2 = j' in (* /a\ /b\ *)
+ let c1 = a1-1 and a2 = b2-1 in (* /b\ c ===> d /a\ *)
+ let b1 = l1.(c1)-1 and c2 = a2-1 in (* d e e c *)
+ let e1 = b1-1 and d2 = l2.(a2)-1 in
+ let d1 = l1.(e1)-1 and e2 = l2.(c2)-1 in
+ assert (l1.(d1) >= l1.(b1) && l2.(e2) >= l2.(a2) && l1.(a1) = l1.(b1) && l2.(a2) >= l2.(b2));
+ [ (forestdist.(l1.(d1)-li).(l2.(d2)-lj) + treedist.(d1).(d2) + treedist.(e1).(e2) + treedist.(c1).(c2) + (gammaRotR n1.(b1) n1.(a1) n2.(b2) n2.(a2)),
+ TERotR(b1,a1,b2,a2) :: forestedit.(l1.(d1)-li).(l2.(d2)-lj) @ treeedit.(d1).(d2) @ treeedit.(e1).(e2) @ treeedit.(c1).(c2))
+ ]
+ with _ -> []);
+ (try
+ let fapp1 = i' in
+ let gapp1fArgs1 = List.filter (fun k -> k >= l1.(fapp1) && k < fapp1 && p1.(k) = fapp1) (Array.to_list keyroots1) in
+ let f1 = l1.(List.hd gapp1fArgs1)-1 in
+ let (gapp1, fArgs1) = (List.hd gapp1fArgs1, List.tl gapp1fArgs1) in
+ let gArgs1 = List.filter (fun k -> k >= l1.(gapp1) && k < gapp1 && p1.(k) = gapp1) (Array.to_list keyroots1) in
+ let g1 = l1.(List.hd gArgs1)-1 in
+ let gandfArgs1 = gArgs1 @ fArgs1 in
+ let gapp2 = j' in
+ let fapp2 = j' - 1 in
+ let g2 = l2.(fapp2)-1 in
+ let gandfArgs2 = List.filter (fun k -> k >= l2.(fapp2) && k < fapp2 && p2.(k) = fapp2) (Array.to_list keyroots2) in
+ let f2 = l2.(List.hd gandfArgs2) - 1 in
+ let allFGArgs12 = List.combine gandfArgs1 gandfArgs2 in
+ assert (List.length gandfArgs1 = List.length gandfArgs2 && g1 > f1 && f2 > g2);
+ [ (forestdist.(l1.(fapp1)-li).(l2.(gapp2)-lj) + (gammaRotR n1.(g1) n1.(f1) n2.(g2) n2.(f2)) + List.fold_left (fun acc (arg1, arg2) -> acc + treedist.(arg1).(arg2)) 0 allFGArgs12,
+ TERotR(g1,f1,g2,f2) :: forestedit.(l1.(fapp1)-li).(l2.(gapp2)-lj) @ (List.fold_left (fun acc (arg1, arg2) -> treeedit.(arg1).(arg2) @ acc) [] allFGArgs12))
+ ]
+ with _ -> [])
+ ] in
+ let m =
+ min ([ (forestdist.( i' -li).( j'+1-lj) + gammaDel(n1.(i')), TEDelNode(i',j') :: forestedit.(i'-li).(j'+1-lj));
+ (forestdist.( i'+1-li).( j' -lj) + gammaIns(n2.(j')), TEInsNode(i',j') :: forestedit.(i'+1-li).(j'-lj));
+ (forestdist.(l1.(i') -li).( j'+1-lj) + gammaDelTree(n1.(i')), TEDelTree(i',j') :: forestedit.(l1.(i')-li).(j'+1-lj));
+ (forestdist.( i'+1-li).(l2.(j') -lj) + gammaInsTree(n2.(j')), TEInsTree(i',j') :: forestedit.(i'+1-li).(l2.(j')-lj));
+ ] @ rotates) in
+ if (l1.(i') = li && l2.(j') = lj) then begin
+ let (minFD, teOp) =
+ min [ m;
+ (forestdist.( i' -li).( j' -lj) + gammaChange n1.(i') n2.(j'), TEChange(i',j') :: forestedit.(i'-li).(j'-lj));
+ ] in
+ treedist.(i').(j') <- minFD;
+ treeedit.(i').(j') <- teOp;
+ forestdist.(i'+1-li).(j'+1-lj) <- minFD;
+ forestedit.(i'+1-li).(j'+1-lj) <- teOp;
+ end else begin
+ let (minFD, teOp) =
+ min [ m;
+ (forestdist.(l1.(i') -li).(l2.(j') -lj) + treedist.(i').(j'), treeedit.(i').(j') @ forestedit.(l1.(i')-li).(l2.(j')-lj));
+ ] in
+ forestdist.(i'+1-li).(j'+1-lj) <- minFD;
+ forestedit.(i'+1-li).(j'+1-lj) <- teOp;
+ end;
+ done;
+ done;
+ () in
+ let printEditScript f script =
+ List.iter (fun action ->
+ flush stdout;
+ match action with
+ TENone -> ()
+ | TEDelNode(i',j') -> print_string ("Delete node (cost " ^ (string_of_int (gammaDel n1.(i'))) ^ ") " ^ (fst n1.(i').past_data) ^ ": "); f n1.(i'); print_string "\n"
+ | TEInsNode(i',j') -> print_string ("Insert node (cost " ^ (string_of_int (gammaIns n2.(j'))) ^ ") " ^ (fst n2.(j').past_data) ^ ": "); f n2.(j'); print_string "\n"
+ | TEDelTree(i',j') -> print_string ("Delete tree (cost " ^ (string_of_int (gammaDelTree n1.(i'))) ^ ") " ^ (fst n1.(i').past_data) ^ ": "); smartPrintTo std_formatter n1.(i').past_node; print_string "\n"
+ | TEInsTree(i',j') -> print_string ("Insert tree (cost " ^ (string_of_int (gammaInsTree n2.(j'))) ^ ") " ^ (fst n2.(j').past_data) ^ ": "); smartPrintTo std_formatter n2.(j').past_node; print_string "\n"
+ | TEChange (i',j') -> if (gammaChange n1.(i') n2.(j') > 0) then
+ (print_string ("Change node (cost " ^ (string_of_int (gammaChange n1.(i') n2.(j'))) ^ ") from " ^ (fst n1.(i').past_data) ^ ": "); f n1.(i'); print_string (" to " ^ (fst n2.(j').past_data) ^ ": "); f n2.(j'); print_string "\n")
+ | TERotR (lc1, r1, r2, rc2) -> print_string ("Rotate nodes right (cost " ^ (string_of_int (gammaRotR n1.(lc1) n1.(r1) n2.(r2) n2.(rc2))) ^ ")\n");
+ | TERotL (rc1, r1, r2, lc2) -> print_string ("Rotate nodes right (cost " ^ (string_of_int (gammaRotR n1.(rc1) n1.(r1) n2.(r2) n2.(lc2))) ^ ")\n");
+ ) (List.rev script)
+ in
+ for x = 1 to lenKR1 do
+ for y = 1 to lenKR2 do
+ if (n1.(keyroots1.(x-1)).past_node = n2.(keyroots2.(y-1)).past_node) then begin
+ treedist.(keyroots1.(x-1)).(keyroots2.(y-1)) <- 0; (* there's no cost to not change a tree *)
+ treeedit.(keyroots1.(x-1)).(keyroots2.(y-1)) <- treeedit.(l1.(keyroots1.(x-1))).(l2.(keyroots2.(y-1))); (* so the only edits are the prior forest, if any *)
+ end else
+ computeTreedist keyroots1.(x-1) keyroots2.(y-1)
+ done
+ done;
+ if pr then (
+ Printcode.showExns();
+ (* printNamedLocatedAST t1; printNamedLocatedAST t2; *)
+ printEditScript (fun n -> Location.print std_formatter (snd n.past_data); smartPrintTo std_formatter n.past_node) treeedit.(len1).(len2);
+ Printcode.hideExns();
+ );
+ treedist.(len1).(len2)
+
+
+ let testTreeDiff () =
+ let mT a kids = {past_data = (a, !locNone); past_node = (Str alphaStr); past_idxs = ASTMap.empty; past_kids = kids} in
+ let mL a = mT a [] in
+ let prog1 = mT "x" [ mL "y"; mL "z"; mT "a" [ mT "b" [ mL "w"; mL "v"; mL "d"; mL "e" ] ; mL "c" ] ] in
+ let prog2 = mT "x" [ mL "y"; mL "z"; mT "b" [ mL "w"; mL "v"; mL "d"; mT "a" [ mL "e" ; mL "c" ] ] ] in
+ let td = treeEditDistance prog1 prog2 true in
+ print_string ("Tree edit distance is " ^ (string_of_int td) ^ "\n")
+
+
+
+
+
+ let printChange out_fm (md, (ctx, progCtx)) =
+ let output_string ignoreMe = fprintf out_fm "@[%s@]@?" in
+ flush stderr; flush stdout;
+ if out_fm != std_formatter then output_string out_fm "
\n";
+ let splitLines str =
+ let rec splitHelp str acc =
+ if str = "" then List.rev acc else
+ try
+ let nlidx = String.index str '\n' in
+ let head = String.sub str 0 nlidx in
+ let tail = String.sub str (nlidx+1) ((String.length str) - nlidx - 1) in
+ splitHelp tail (head::acc)
+ with _ -> List.rev (str :: acc) in
+ splitHelp str [] in
+ let rec noTempMod s =
+ let rec matchStr s t i =
+ try
+ let startIdx = String.index_from s i t.[0] in
+ if (String.sub s startIdx (String.length t)) = t then Some startIdx else matchStr s t (startIdx+1)
+ with _ -> None in
+ let modname = "Seminalprefixtemp." in
+ match matchStr s modname 0 with
+ None -> s
+ | Some idx ->
+ let restlen = String.length s - (idx + (String.length modname)) in
+ noTempMod ((String.sub s 0 idx) ^ (String.sub s (idx + (String.length modname)) restlen)) in
+
+ begin match md with
+ | SingleRepl md ->
+ Location.print out_fm md.trep_loc;
+ if out_fm != std_formatter then begin
+ let debugONLYTagLookup t =
+ let ans = ref "" in
+ TagMap.iter (fun k1 d1 -> if d1 = t then ans := k1) !modTags;
+ !ans in
+ output_string out_fm ("Modification tag is " ^ debugONLYTagLookup md.trep_tag ^ "\n");
+ output_string out_fm md.trep_desc; output_string out_fm "\n"
+ end;
+ let origProg = md.trep_replaced in
+ let replProg = (md.trep_revision ()) in
+ let origStr = (smartPrintTo str_formatter origProg; flush_str_formatter ()) in
+ let replStr = (smartPrintTo str_formatter replProg; flush_str_formatter ()) in
+ output_string out_fm "Try replacing\n";
+ let splitOrig = splitLines origStr in
+ List.iter (fun s -> output_string out_fm (" " ^ s ^ "\n")) splitOrig;
+ output_string out_fm "with\n";
+ let splitRepl = splitLines replStr in
+ List.iter (fun s -> output_string out_fm (" " ^ s ^ "\n")) splitRepl;
+ output_string out_fm "of type\n";
+ let splitType = splitLines (smartPrintTypeTo str_formatter md.trep_type; flush_str_formatter ()) in
+ List.iter (fun s -> output_string out_fm (" " ^ (noTempMod s) ^ "\n")) splitType;
+ if (List.length splitOrig < 3) then begin
+ output_string out_fm "within context\n";
+ let splitCtxt = splitLines (smartPrintTo str_formatter (ctx replProg); flush_str_formatter ()) in
+ List.iter (fun s -> output_string out_fm (" " ^ s ^ "\n")) splitCtxt;
+ end;
+ begin
+ match (findShadowedIDs origProg) with
+ [] -> ()
+ | idList ->
+ output_string out_fm "The following ids may be shadowed and causing problems:\n ";
+ List.iter (fun s -> output_string out_fm (s ^ " ")) idList;
+ output_string out_fm "\n";
+ end;
+ (* let tED = (treeEditDistance (makeNamedLocatedAST origProg) (makeNamedLocatedAST replProg) false) in
+ output_string out_fm "Tree edit distance is "; print_int tED; output_string out_fm "\n"; *)
+ (* fix this to be a shorter context, even at the topmost level *)
+ | TriageRepl md ->
+ output_string out_fm "Triaged the following locations:\n";
+ List.iter (Location.print out_fm) (List.stable_sort (fun m n -> compare m.loc_start.pos_cnum n.loc_end.pos_cnum) md.ttri_locs);
+ output_string out_fm "And modified the following location:\n";
+ Location.print out_fm md.ttri_replaced.trep_loc;
+ if out_fm != std_formatter then begin
+ let debugONLYTagLookup t =
+ let ans = ref "" in
+ TagMap.iter (fun k1 d1 -> if d1 = t then ans := k1) !modTags;
+ !ans in
+ output_string out_fm ("Modification tag is " ^ debugONLYTagLookup md.ttri_tag ^ "\n");
+ output_string out_fm md.ttri_desc ; output_string out_fm "\n";
+ end;
+ let origProg = md.ttri_replaced.trep_replaced in
+ let replProg = (md.ttri_replaced.trep_revision ()) in
+ let origStr = (smartPrintTo str_formatter origProg; flush_str_formatter ()) in
+ let replStr = (smartPrintTo str_formatter replProg; flush_str_formatter ()) in
+ output_string out_fm "Your code has several type errors. ";
+ if (md.ttri_adapted != []) then begin
+ output_string out_fm "The following subexpressions are type-correct on their own, but do not fit with the rest of the program:";
+ List.iter (fun thing ->
+ let str = (smartPrintTo str_formatter thing; flush_str_formatter ()) in
+ let split = splitLines str in
+ List.iter (fun s -> output_string out_fm ("\n " ^ s ^ "\n")) split;
+ ) md.ttri_adapted;
+ end;
+ output_string out_fm "If you ignore other surrounding code, try replacing\n";
+ let splitOrig = splitLines origStr in
+ List.iter (fun s -> output_string out_fm (" " ^ s ^ "\n")) splitOrig;
+ output_string out_fm "with\n";
+ let splitRepl = splitLines replStr in
+ List.iter (fun s -> output_string out_fm (" " ^ s ^ "\n")) splitRepl;
+ output_string out_fm "The actual replacement has type\n";
+ let splitType = splitLines (smartPrintTypeTo str_formatter md.ttri_replaced.trep_type; flush_str_formatter ()) in
+ List.iter (fun s -> output_string out_fm (" " ^ (noTempMod s) ^ "\n")) splitType;
+ if (List.length splitOrig < 3) then begin
+ output_string out_fm "within context\n";
+ let splitCtxt = splitLines (smartPrintTo str_formatter (ctx (md.ttri_idealctx replProg)); flush_str_formatter ()) in
+ List.iter (fun s -> output_string out_fm (" " ^ s ^ "\n")) splitCtxt;
+ end;
+ begin
+ match (findShadowedIDs origProg) with
+ [] -> ()
+ | idList ->
+ output_string out_fm "The following ids may be shadowed and causing problems:\n ";
+ List.iter (fun s -> output_string out_fm (s ^ " ")) idList;
+ output_string out_fm "\n";
+ end;
+ end;
+ if out_fm == std_formatter then
+ output_string out_fm "==============================\n"
+ else
+ output_string out_fm "
\n"
+
+
+
+ module FixSet = Set.Make(struct type t = (replacement * (astContext * astContext)) let compare = (fun x y -> try compare (fst x) (fst y) with _ -> 1) end)
+ let rankFixes ast (fixList : (replacement * (astContext * astContext)) list) diagOutput : (replacement * (astContext * astContext)) list =
+ let (++) x f = f x in
+ let removeDominated fixList =
+ (* Retain only those modifications that are not superceded by *)
+ (* a dominant kind of operation that is strictly smaller *)
+
+ initDominance ();
+
+ let fixSet = List.fold_left (fun s e -> FixSet.add e s) FixSet.empty fixList in
+ let containedBy lst1 lst2 = List.for_all (fun l1 -> List.exists (locInside l1) lst2) lst1 in
+ let same y e = y.trep_tag = e.trep_tag && y.trep_loc = e.trep_loc && y.trep_replaced = e.trep_replaced & y.trep_revision() = e.trep_revision() in
+ let domSingleSingle y e =
+ (y != e) && ((smartFindDom (y.trep_tag, e.trep_tag) !modDominance) = Does) &&
+ if (y.trep_tag = t("Exp_TryMatch_Reparenthesize")) then
+ (((e.trep_tag != y.trep_tag) && ((locInside y.trep_loc e.trep_loc) || (locInside e.trep_loc y.trep_loc))) (* TryMatch dominates all fixes, even those smaller than it... *)
+ || ((e.trep_tag = y.trep_tag) && (locInside y.trep_loc e.trep_loc) && (not (locInside e.trep_loc y.trep_loc)))) (* except for strictly smaller TryMatch fixes *)
+ else if (y.trep_tag = t("Exp_Adapt")) then
+ (((e.trep_tag != y.trep_tag) && ((locInside y.trep_loc e.trep_loc) || (locInside e.trep_loc y.trep_loc))) (* Adapt dominates all fixes, even those smaller than it... *)
+ || ((e.trep_tag = y.trep_tag) && (locInside e.trep_loc y.trep_loc) && (not (locInside y.trep_loc e.trep_loc)))) (* except for strictly larger Adapt fixes *)
+ else
+ (locInside y.trep_loc e.trep_loc) (* and y is smaller than e, and strictly smaller if they're they same exact type *)
+ && ((y.trep_tag != e.trep_tag) || (not (locInside e.trep_loc y.trep_loc))) in
+ let domSingleTriage y e =
+ let handleReparens y e =
+ let elocs = e.ttri_replaced.trep_loc :: e.ttri_locs in
+ let compare y e = (* is e' the same modification, but knocked out? *)
+ let yrep = y.trep_revision() in
+ let erep = e.ttri_replaced.trep_revision() in
+ let elision = alphaExp "ELIDED_CODE" in
+ let isKnockout yExp eExp = (yExp = eExp || eExp = elision yExp.pexp_loc) in
+ let rec compare yExp eExp =
+ match yExp.pexp_desc, eExp.pexp_desc with
+ Pexp_match(y1, yPE), Pexp_match(e1, ePE) -> isKnockout y1 e1 && (try List.for_all2 (fun (yp, ye) (ep, ee) -> yp = ep && compare ye ee) yPE ePE with _ -> false)
+ | Pexp_try(y1, yPE), Pexp_try(e1, ePE) -> isKnockout y1 e1 && (try List.for_all2 (fun (yp, ye) (ep, ee) -> yp = ep && compare ye ee) yPE ePE with _ -> false)
+ | Pexp_function(yL, ydOpt, yPE), Pexp_function(eL, edOpt, ePE) -> yL = eL && ydOpt = edOpt && (try List.for_all2 (fun (yp, ye) (ep, ee) -> yp = ep && compare ye ee) yPE ePE with _ -> false)
+ | Pexp_sequence (y1, y2), Pexp_sequence (e1, e2) -> compare y1 e1 && compare y2 e2
+ | Pexp_let (yr, yPE, ye), Pexp_let (er, ePE, ee) -> compare ye ee && (try List.for_all2 (fun (yp, ye) (ep, ee) -> yp = ep && compare ye ee) yPE ePE with _ -> false)
+ | _, _ -> isKnockout yExp eExp in
+ try compare (toExp yrep) (toExp erep) with _ -> false in
+ (y.trep_tag = t("Exp_TryMatch_Reparenthesize")) &&
+ (((e.ttri_replaced.trep_tag != y.trep_tag) && ((containedBy [y.trep_loc] elocs) || (containedBy elocs [y.trep_loc]))) (* TryMatch dominates all fixes, even those smaller than it... *)
+ || ((e.ttri_replaced.trep_tag = y.trep_tag) && (((containedBy elocs [y.trep_loc]) && (not (containedBy [y.trep_loc] elocs))) || compare y e))) in (* except for strictly larger TryMatch fixes *)
+ let elocs = e.ttri_replaced.trep_loc :: e.ttri_locs in
+ (* ((smartFindDom (y.trep_tag, e.ttri_tag) !modDominance) = Does) && *)
+ (y.trep_tag = t("Exp_Adapt") && (containedBy elocs [y.trep_loc] || containedBy [y.trep_loc] elocs)) ||
+ (handleReparens y e) ||
+ (containedBy [y.trep_loc] elocs && (domSingleSingle y e.ttri_replaced || same y e.ttri_replaced)) in
+ let domTriageSingle y e =
+ let ylocs = y.ttri_replaced.trep_loc :: y.ttri_locs in
+ (* ((smartFindDom (y.ttri_tag, e.trep_tag) !modDominance) = Does) && *)
+ (y.ttri_locs != []) &&
+ (not (containedBy [e.trep_loc] ylocs && (domSingleSingle e y.ttri_replaced || same e y.ttri_replaced))) &&
+ containedBy ylocs [e.trep_loc] &&
+ (e.trep_tag != t("Exp_TryMatch_Reparenthesize") && e.trep_tag != t("Exp_Adapt")) in
+ let domTriageTriage y e =
+ let ylocs = y.ttri_replaced.trep_loc :: y.ttri_locs in
+ let elocs = e.ttri_replaced.trep_loc :: e.ttri_locs in
+ (y != e) && ((smartFindDom (y.ttri_tag, e.ttri_tag) !modDominance) = Does) &&
+ if (containedBy y.ttri_locs e.ttri_locs && containedBy e.ttri_locs y.ttri_locs) then
+ (domSingleSingle y.ttri_replaced e.ttri_replaced || same y.ttri_replaced e.ttri_replaced)
+ else if (y.ttri_replaced.trep_tag = t("Exp_TryMatch_Reparenthesize")) then
+ (e.ttri_replaced.trep_tag != y.ttri_replaced.trep_tag &&
+ (containedBy elocs [y.ttri_replaced.trep_loc] || containedBy [y.ttri_replaced.trep_loc] elocs) &&
+ domSingleSingle y.ttri_replaced e.ttri_replaced) ||
+ (e.ttri_replaced.trep_tag = y.ttri_replaced.trep_tag &&
+ containedBy ylocs elocs && not (containedBy elocs ylocs))
+ else if (e.ttri_replaced.trep_tag = t("Exp_TryMatch_Reparenthesize")) then
+ false
+ else if (containedBy ylocs elocs) then
+ if (containedBy elocs ylocs) then
+ (domSingleSingle y.ttri_replaced e.ttri_replaced) ||
+ ((smartFindDom (y.ttri_tag, e.ttri_tag) !modDominance = Does) &&
+ (y.ttri_replaced.trep_revision() = e.ttri_replaced.trep_revision()))
+ else
+ true
+ else false in
+ let dominantTypeSmallerMod y e =
+ (y != e) &&
+ (match y, e with
+ | SingleRepl y, SingleRepl e -> domSingleSingle y e
+ | SingleRepl y, TriageRepl e -> domSingleTriage y e
+ | TriageRepl y, SingleRepl e -> domTriageSingle y e
+ | TriageRepl y, TriageRepl e -> domTriageTriage y e
+ ) in
+
+
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+ if diagOutput != std_formatter then begin
+ let output_string out_fm = fprintf out_fm "@[%s@]@?" in
+ let hackSameType (y', _) (e', _) =
+ match y', e' with
+ TriageRepl _, TriageRepl _ | SingleRepl _, SingleRepl _ -> true | _ -> false in
+ let domArr : bool array array = Array.make_matrix (List.length fixList) (List.length fixList) false in
+ output_string diagOutput "
Is x a dominantMod over y?
\n";
+ if (List.length fixList < 100) then begin
+ output_string diagOutput "
\n";
+ output_string diagOutput "
x\\y
"; List.iter (fun i -> output_string diagOutput ("
\n";
+ end else
+ output_string diagOutput "Too many modifications to print a meaningful table\n";
+ for x = 0 to (List.length fixList) - 1 do
+ for y = x to (List.length fixList) - 1 do
+ if (domArr.(x).(y) = true && domArr.(y).(x) = true) then output_string diagOutput ("
Error: Mods " ^ (string_of_int x) ^ " and " ^ (string_of_int y) ^ " are mutually dominant.
\n";
+ end;
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+ FixSet.elements (FixSet.filter (fun e -> not (FixSet.exists (fun y -> dominantTypeSmallerMod (fst y) (fst e)) fixSet)) fixSet) in
+ (* such that there is no other mod y which dominates this mod e *)
+ let filterInvalid fixList =
+ let pseudoFixes = List.rev_map (fun (md, (c1, c2)) -> (md, (c1, (fun x -> x), c2))) fixList in
+ List.filter (function (md, ctx) -> match md with SingleRepl md -> md.trep_validate() | TriageRepl md -> true) fixList in
+ let sortByTreeEditDistance fixList =
+ let fixTreeDists = List.map (fun (x, (_, progCtxX)) ->
+ match x with
+ SingleRepl x ->
+ let uast = makeNamedLocatedAST (x.trep_replaced) in
+ let uastX = makeNamedLocatedAST (x.trep_revision ()) in
+ print_string "."; flush stdout;
+ treeEditDistance uast uastX false
+ | TriageRepl x ->
+ let uast = makeNamedLocatedAST (x.ttri_original) in
+ let uastX = makeNamedLocatedAST (x.ttri_idealctx (x.ttri_replaced.trep_revision())) in
+ treeEditDistance uast uastX false) fixList in
+ let fixDistList = List.combine fixList fixTreeDists in
+ let sortedOutput = List.stable_sort (fun (fixX, distX) (fixY, distY) -> compare distX distY) fixDistList in
+ fst (List.split sortedOutput) in
+ let sortMultisAndTriages fixList =
+ let (multisTriages, others) = List.partition (function (x, _) -> match x with SingleRepl _ -> false | _ -> true) fixList in
+ multisTriages @ others in
+ let removeDotsIfUnneeded fixList =
+ let replStr a = (smartPrintTo str_formatter a; flush_str_formatter ()) in
+ let substring (s1 : string) (s2 : string) =
+ let ssat i =
+ try (String.sub s2 i (String.length s1)) = s1 with _ -> false in
+ List.exists ssat (tabulate ((String.length s2) - (String.length s1) + 1)) in
+ match (List.partition (function (x, _) ->
+ match x with
+ SingleRepl r -> substring "[[...]]" (replStr (r.trep_revision()))
+ | TriageRepl r -> r.ttri_locs != []) fixList) with
+ _, [] -> fixList
+ | _, noDots -> noDots in
+ let secondFilterInvalid fixList =
+ let validated = List.stable_sort (fun (x, _) (y, ctx) ->
+ match x with
+ SingleRepl r ->
+ (try
+ let validate = List.assoc r.trep_replaced !validations in
+ if (validate x [y, ctx]) then 0 else 1
+ with _ -> 0)
+ | _ -> 0) fixList in
+ List.stable_sort (fun (x, _) (y, _) ->
+ match x with
+ SingleRepl r -> if r.trep_tag = t("Exp_Ident_FixId") then 1 else 0
+ | _ -> 0) validated in
+ let sortBySize fixList =
+ List.stable_sort (fun (x, _) (y, _) ->
+ let xLoc = match x with SingleRepl x -> x.trep_loc | TriageRepl x -> List.fold_left locJoin x.ttri_replaced.trep_loc x.ttri_locs in
+ let yLoc = match y with SingleRepl y -> y.trep_loc | TriageRepl y -> List.fold_left locJoin y.ttri_replaced.trep_loc y.ttri_locs in
+ compare (locLen xLoc) (locLen yLoc)) fixList in
+ let sortByType fixList =
+ List.stable_sort (fun (x, _) (y, _) ->
+ let xTag = match x with SingleRepl x -> x.trep_tag | TriageRepl x -> x.ttri_tag in
+ let yTag = match y with SingleRepl y -> y.trep_tag | TriageRepl y -> y.ttri_tag in
+ compare xTag yTag) fixList in
+ let showFirst n fixList =
+ let rec take n tail acc =
+ if n = 0 then List.rev acc else
+ match tail with
+ [] -> List.rev acc
+ | hd::tl -> take (n-1) tl (hd :: acc)
+ in take n fixList [] in
+ fixList
+ ++ sortMultisAndTriages
+ ++ filterInvalid
+ ++ removeDominated
+ ++ removeDotsIfUnneeded
+ ++ sortBySize
+ ++ secondFilterInvalid
+ (* ++ sortByTreeEditDistance *)
+ (* ++ sortByType *)
+ ++ showFirst 15
+
+
+ (* XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX *)
+
+
+
+
+
+
+
+
+ (*
+ Generic algorithm:
+ SingleRecur down the AST, given the location and the structure, to the smallest node containing the error
+ Starting from the deepest node, attempt to generalize the node. If it fails, pop up to a higher node.
+ If it succeeds, attempt to generalize the siblings of that node (independently of the first modification).
+ If any of those succeed, attempt generalizing all smaller subtrees of that sibling, to find the tightest change which could work.
+ *)
+
+ let hookSeminal parseToAST typeAST inputfile outputprefix initial_env interface implementation =
+ let timeTypeChecking = ref 0.0 in
+
+ let typeAST ast =
+ Location.set_warning_fmt str_formatter;
+ try
+ let ans = typeAST ast in
+ ignore (flush_str_formatter ());
+ Location.reset_warnings ();
+ ans
+ with err ->
+ (ignore (flush_str_formatter ());
+ Location.reset_warnings ();
+ raise err) in
+ let typeAST ast =
+ let (ans, timeTC, _) = timeFn (fun () -> typeAST ast) (fun td -> timeTypeChecking := !timeTypeChecking +. td) in
+ ans in
+
+ let print_string = fprintf std_formatter "@[%s@]@?" in (* rebind print_string to use the formatters *)
+ let fixedErrors : exn list ref = ref [] in
+
+
+ let splitLines str =
+ let rec splitHelp str acc =
+ if str = "" then List.rev acc else
+ try
+ let nlidx = String.index str '\n' in
+ let head = String.sub str 0 nlidx in
+ let tail = String.sub str (nlidx+1) ((String.length str) - nlidx - 1) in
+ splitHelp tail (head::acc)
+ with _ -> List.rev (str :: acc) in
+ splitHelp str [] in
+
+ let rec noTempMod s =
+ let rec matchStr s t i =
+ try
+ let startIdx = String.index_from s i t.[0] in
+ if (String.sub s startIdx (String.length t)) = t then Some startIdx else matchStr s t (startIdx+1)
+ with _ -> None in
+ let modname = "Seminalprefixtemp." in
+ match matchStr s modname 0 with
+ None -> s
+ | Some idx ->
+ let restlen = String.length s - (idx + (String.length modname)) in
+ noTempMod ((String.sub s 0 idx) ^ (String.sub s (idx + (String.length modname)) restlen)) in
+
+
+ let handleError exn ast loc =
+ let sTime = Sys.time() in
+
+ Location.set_warning_fmt str_formatter;
+ let fixes = seminalSearch typeAST ast (Some loc) in
+ Location.reset_warnings ();
+ ignore (flush_str_formatter ());
+ let eTime = Sys.time() in
+
+ let diagOutput = open_out "testoutput.html" in
+ let out_fm = formatter_of_out_channel diagOutput in
+ let output_string out_fm = fprintf out_fm "@[%s@]@?" in
+ output_string out_fm ("\n" ^
+ " Diagnostic output for " ^ loc.loc_start.pos_fname ^ "" ^
+ " \n" ^
+ " \n\n" ^
+ "