diff --git a/Makefile b/Makefile index b4fab4c..540869f 100644 --- a/Makefile +++ b/Makefile @@ -5,4 +5,4 @@ run: ./build-unix.sh && ./shf tests: - mlton shf-tests.mlb && ./shf-tests + mlton -const "Exn.keepHistory true" shf-tests.mlb && ./shf-tests diff --git a/fcore/app-update.sml b/fcore/app-update.sml index bfe3444..3006c26 100644 --- a/fcore/app-update.sml +++ b/fcore/app-update.sml @@ -569,6 +569,7 @@ struct fun deleteLineBack (app: app_type, count) = let + val _ = raise Empty val {buffer, cursorIdx, ...} = app val low = Cursor.vi0 (buffer, cursorIdx) val high = Cursor.viDlr (buffer, cursorIdx, 1) + 1 diff --git a/fcore/build-search-list.sml b/fcore/build-search-list.sml index 6bf30ce..5295cc4 100644 --- a/fcore/build-search-list.sml +++ b/fcore/build-search-list.sml @@ -130,12 +130,15 @@ struct end fun fromRange (startIdx, length, buffer, searchString, searchList) = - let - val finishIdx = startIdx + length + String.size searchString - val bufferIdx = startIdx - String.size searchString - val bufferIdx = Int.max (bufferIdx, 0) - in - helpFromRange - (startIdx, bufferIdx, finishIdx, buffer, searchString, searchList) - end + if String.size searchString = 0 then + (buffer, searchList) + else + let + val finishIdx = startIdx + length + String.size searchString + val bufferIdx = startIdx - String.size searchString + val bufferIdx = Int.max (bufferIdx, 0) + in + helpFromRange + (startIdx, bufferIdx, finishIdx, buffer, searchString, searchList) + end end diff --git a/shell/exception-logger.sml b/shell/exception-logger.sml new file mode 100644 index 0000000..a6d1e54 --- /dev/null +++ b/shell/exception-logger.sml @@ -0,0 +1,38 @@ +structure ExceptionLogger = +struct + open InputMsg + + val textCommands = ref "" + + fun addCommand inputMsg = + case inputMsg of + CHAR_EVENT chr => + let + val chr = CharVector.fromList [chr] + val newInput = !textCommands ^ chr + in + textCommands := newInput + end + | _ => () + + fun log e = + let + (* print stack trace for debugging purposes, + * and then raise another exception to exit the program *) + val stackTrace = MLton.Exn.history e + val stackTrace = String.concatWith "\n" stackTrace + val () = print "ERROR:\n" + val () = print (stackTrace ^ "\n\n") + + val history = !textCommands ^ "\n\n" + val () = print ("HISTORY: " ^ history) + + val textOutput = stackTrace ^ "\n" ^ history + + val io = TextIO.openAppend "exceptions.log" + val () = TextIO.output (io, textOutput) + val () = TextIO.closeOut io + in + raise Empty + end +end diff --git a/shell/update-thread.sml b/shell/update-thread.sml index 1e08440..fdab6f3 100644 --- a/shell/update-thread.sml +++ b/shell/update-thread.sml @@ -2,7 +2,6 @@ structure UpdateThread = struct open CML open MailboxType - open InputMsg fun sendMsg (msg, drawMailbox) = case msg of DRAW msg => Mailbox.send (drawMailbox, msg) @@ -15,46 +14,12 @@ struct end | [] => () - val textCommands = ref "" - - fun addTextCommand inputMsg = - case inputMsg of - CHAR_EVENT chr => - let - val chr = CharVector.fromList [chr] - val newInput = !textCommands ^ chr - in - textCommands := newInput - end - | _ => () - - fun handleException e = - let - (* print stack trace for debugging purposes, - * and then raise another exception to exit the program *) - val stackTrace = MLton.Exn.history e - val stackTrace = String.concatWith "\n" stackTrace - val () = print "ERROR:\n" - val () = print (stackTrace ^ "\n\n") - - val history = !textCommands ^ "\n\n" - val () = print ("HISTORY: " ^ history) - - val textOutput = stackTrace ^ "\n" ^ history - - val io = TextIO.openAppend "exceptions.log" - val () = TextIO.output (io, textOutput) - val () = TextIO.closeOut io - in - raise Empty - end - fun loop (app: AppType.app_type, inputMailbox, drawMailbox) = let val inputMsg = Mailbox.recv inputMailbox - val () = addTextCommand inputMsg + val () = ExceptionLogger.addCommand inputMsg - val app = AppUpdate.update (app, inputMsg) handle e => handleException e + val app = AppUpdate.update (app, inputMsg) handle e => ExceptionLogger.log e val () = sendMsgs (#msgs app, drawMailbox) in diff --git a/shf-tests.mlb b/shf-tests.mlb index 7419d36..6432c9d 100644 --- a/shf-tests.mlb +++ b/shf-tests.mlb @@ -35,6 +35,10 @@ fcore/move.sml fcore/app-update.sml (* TEST FILES *) +$(SML_LIB)/basis/mlton.mlb + +shell/exception-logger.sml + test/Railroad/src/railroad.mlb test/normal-move.sml test/normal-delete.sml diff --git a/shf.mlb b/shf.mlb index 8450677..5958273 100644 --- a/shf.mlb +++ b/shf.mlb @@ -46,6 +46,7 @@ in ffi/glfw-input.sml end +shell/exception-logger.sml shell/update-thread.sml shell/gl-shaders.sml shell/gl-draw.sml diff --git a/test/regression.sml b/test/regression.sml index 11e85cd..67da7e1 100644 --- a/test/regression.sml +++ b/test/regression.sml @@ -9,8 +9,8 @@ struct else let val chr = String.sub (str, pos) + val () = ExceptionLogger.addCommand (InputMsg.CHAR_EVENT chr) val app = AppUpdate.update (app, InputMsg.CHAR_EVENT chr) - handle _ => raise Fail (Int.toString pos) in updateLoop (pos + 1, str, app) end diff --git a/test/test.sml b/test/test.sml index bd87bdb..e515900 100644 --- a/test/test.sml +++ b/test/test.sml @@ -10,6 +10,7 @@ struct val tests = concat tests in runWithConfig [Configuration.PrintPassed false] tests + handle e => ExceptionLogger.log e end end