Add 'shf/' from commit 'b6c5a95b664aeb861d7b33ffc9eefe447ba99dd7'
git-subtree-dir: shf git-subtree-mainline:401408448fgit-subtree-split:b6c5a95b66
This commit is contained in:
4
shf/.gitignore
vendored
Normal file
4
shf/.gitignore
vendored
Normal file
@@ -0,0 +1,4 @@
|
||||
shf-glfw
|
||||
shf-rgfw
|
||||
shf-tests
|
||||
exceptions.log
|
||||
3
shf/.gitmodules
vendored
Normal file
3
shf/.gitmodules
vendored
Normal file
@@ -0,0 +1,3 @@
|
||||
[submodule "test/Railroad"]
|
||||
path = test/Railroad
|
||||
url = https://github.com/PerplexSystems/Railroad
|
||||
11
shf/Makefile
Normal file
11
shf/Makefile
Normal file
@@ -0,0 +1,11 @@
|
||||
rgfw-debug:
|
||||
./build-unix-rgfw-debug-.sh && ./shf-rgfw
|
||||
|
||||
glfw-debug:
|
||||
./build-unix-glfw-debug.sh && ./shf-glfw
|
||||
|
||||
glfw:
|
||||
./build-unix-glfw.sh && ./shf-glfw
|
||||
|
||||
tests:
|
||||
mlton -const "Exn.keepHistory true" shf-tests.mlb && ./shf-tests
|
||||
7
shf/build-unix-glfw-debug.sh
Executable file
7
shf/build-unix-glfw-debug.sh
Executable file
@@ -0,0 +1,7 @@
|
||||
#!/bin/sh
|
||||
mlton -const 'Exn.keepHistory true' -link-opt "$(pkg-config --cflags glfw3) $(pkg-config --static --libs glfw3)" \
|
||||
-export-header ffi/mlton-glfw-export.h \
|
||||
shf-glfw.mlb \
|
||||
ffi/glad.c \
|
||||
ffi/glfw-export.c \
|
||||
ffi/glfw-input.c
|
||||
7
shf/build-unix-glfw.sh
Executable file
7
shf/build-unix-glfw.sh
Executable file
@@ -0,0 +1,7 @@
|
||||
#!/bin/sh
|
||||
mlton -link-opt "$(pkg-config --cflags glfw3) $(pkg-config --static --libs glfw3)" \
|
||||
-export-header ffi/mlton-glfw-export.h \
|
||||
shf-glfw.mlb \
|
||||
ffi/glad.c \
|
||||
ffi/glfw-export.c \
|
||||
ffi/glfw-input.c
|
||||
4
shf/build-unix-rgfw-debug-.sh
Executable file
4
shf/build-unix-rgfw-debug-.sh
Executable file
@@ -0,0 +1,4 @@
|
||||
#!/bin/sh
|
||||
mlton -const 'Exn.keepHistory true' -link-opt "-lX11 -lXrandr -lGL" \
|
||||
shf-rgfw.mlb \
|
||||
ffi/rgfw-export.c
|
||||
61
shf/fcore.mlb
Normal file
61
shf/fcore.mlb
Normal file
@@ -0,0 +1,61 @@
|
||||
$(SML_LIB)/basis/basis.mlb
|
||||
|
||||
(* LIBRARIES (purely functional) *)
|
||||
../brolib-sml/src/line_gap.sml
|
||||
../cozette-sml/fonts-with-z-index/cozette-ascii.mlb
|
||||
|
||||
(* FUNCTIONAL CORE *)
|
||||
fcore/bin-search.sml
|
||||
|
||||
ann
|
||||
"allowVectorExps true"
|
||||
in
|
||||
fcore/persistent-vector.sml
|
||||
end
|
||||
fcore/search-list/dfa-gen.sml
|
||||
fcore/search-list/search-list.sml
|
||||
|
||||
message-types/input-msg.sml
|
||||
message-types/draw-msg.sml
|
||||
message-types/mailbox-type.sml
|
||||
|
||||
fcore/app-type.sml
|
||||
fcore/normal-mode/normal-mode-with.sml
|
||||
fcore/normal-mode/normal-search-mode-with.sml
|
||||
fcore/app-with.sml
|
||||
|
||||
fcore/text-constants.sml
|
||||
ann
|
||||
"allowVectorExps true"
|
||||
in
|
||||
fcore/cursor-dfa/make-dfa-loop.sml
|
||||
fcore/cursor-dfa/vi-word-dfa.sml
|
||||
fcore/cursor-dfa/vi-caps-word-dfa.sml
|
||||
fcore/cursor-dfa/vi-dlr-dfa.sml
|
||||
fcore/cursor-dfa/vi-l-dfa.sml
|
||||
fcore/cursor-dfa/vi-h-dfa.sml
|
||||
fcore/rect.sml
|
||||
fcore/pipe-cursor.sml
|
||||
end
|
||||
fcore/text-builder/text-builder-utils.sml
|
||||
fcore/text-builder/text-builder-with-cursor.sml
|
||||
fcore/text-builder/text-builder-with-highlight.sml
|
||||
fcore/text-builder/normal-mode-text-builder.sml
|
||||
fcore/text-builder/search-bar.sml
|
||||
|
||||
fcore/cursor.sml
|
||||
fcore/text-scroll.sml
|
||||
|
||||
fcore/normal-mode/normal-finish.sml
|
||||
fcore/normal-mode/normal-search-finish.sml
|
||||
fcore/move.sml
|
||||
|
||||
fcore/normal-mode/normal-move.sml
|
||||
fcore/normal-mode/normal-yank.sml
|
||||
fcore/normal-mode/make-normal-delete.sml
|
||||
fcore/normal-mode/normal-delete.sml
|
||||
fcore/normal-mode/normal-yank-delete.sml
|
||||
fcore/normal-mode/normal-mode.sml
|
||||
fcore/normal-mode/normal-search-mode.sml
|
||||
|
||||
fcore/app-update.sml
|
||||
45
shf/fcore/app-type.sml
Normal file
45
shf/fcore/app-type.sml
Normal file
@@ -0,0 +1,45 @@
|
||||
structure AppType =
|
||||
struct
|
||||
datatype mode =
|
||||
NORMAL_MODE of string
|
||||
| NORMAL_SEARCH_MODE of
|
||||
{ searchString: string
|
||||
, tempSearchList: PersistentVector.t
|
||||
, searchCursorIdx: int
|
||||
, searchScrollColumn: int
|
||||
, caseSensitive: bool
|
||||
}
|
||||
|
||||
type app_type =
|
||||
{ mode: mode
|
||||
, buffer: LineGap.t
|
||||
, bufferModifyTime: Time.time
|
||||
, searchList: PersistentVector.t
|
||||
, windowWidth: int
|
||||
, windowHeight: int
|
||||
(* line to start drawing from *)
|
||||
, startLine: int
|
||||
(* absolute index of movable cursor *)
|
||||
, cursorIdx: int
|
||||
(* column to start drawing text at for horizontal scrolling. *)
|
||||
, visualScrollColumn: int
|
||||
, dfa: int vector vector
|
||||
(* msgs to send after an update.
|
||||
* The list of messages is reset on each invocation of AppUpdate.update. *)
|
||||
, msgs: MailboxType.t list
|
||||
}
|
||||
|
||||
fun init (buffer, windowWidth, windowHeight, time) : app_type =
|
||||
{ mode = NORMAL_MODE ""
|
||||
, buffer = buffer
|
||||
, bufferModifyTime = time
|
||||
, searchList = PersistentVector.empty
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, startLine = 0
|
||||
, cursorIdx = 0
|
||||
, visualScrollColumn = 0
|
||||
, dfa = Vector.fromList []
|
||||
, msgs = []
|
||||
}
|
||||
end
|
||||
10
shf/fcore/app-update.sml
Normal file
10
shf/fcore/app-update.sml
Normal file
@@ -0,0 +1,10 @@
|
||||
structure AppUpdate =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
fun update (app: app_type, msg, time) =
|
||||
case #mode app of
|
||||
NORMAL_MODE modeData => NormalMode.update (app, modeData, msg, time)
|
||||
| NORMAL_SEARCH_MODE modeData =>
|
||||
NormalSearchMode.update (app, modeData, msg, time)
|
||||
end
|
||||
35
shf/fcore/app-with.sml
Normal file
35
shf/fcore/app-with.sml
Normal file
@@ -0,0 +1,35 @@
|
||||
structure AppWith =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
(* this function exists only for testing *)
|
||||
fun idx (app, newIdx) =
|
||||
let
|
||||
val
|
||||
{ startLine
|
||||
, buffer
|
||||
, bufferModifyTime
|
||||
, searchList
|
||||
, dfa
|
||||
, mode
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, msgs
|
||||
, visualScrollColumn
|
||||
, cursorIdx = _
|
||||
} = app
|
||||
in
|
||||
{ startLine = startLine
|
||||
, buffer = buffer
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, searchList = searchList
|
||||
, dfa = dfa
|
||||
, mode = mode
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, msgs = msgs
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, cursorIdx = newIdx
|
||||
}
|
||||
end
|
||||
end
|
||||
120
shf/fcore/bin-search.sml
Normal file
120
shf/fcore/bin-search.sml
Normal file
@@ -0,0 +1,120 @@
|
||||
structure BinSearch =
|
||||
struct
|
||||
local
|
||||
fun reverseLinearSearch (findNum, idx, vec) =
|
||||
if idx < 0 then
|
||||
~1
|
||||
else
|
||||
let
|
||||
val curVal = Vector.sub (vec, idx)
|
||||
in
|
||||
if curVal < findNum then idx
|
||||
else reverseLinearSearch (findNum, idx - 1, vec)
|
||||
end
|
||||
|
||||
fun helpBinSearch (findNum, vec, low, high) =
|
||||
let
|
||||
val mid = low + ((high - low) div 2)
|
||||
in
|
||||
if high >= low then
|
||||
let
|
||||
val midVal = Vector.sub (vec, mid)
|
||||
in
|
||||
if midVal = findNum then
|
||||
mid
|
||||
else if midVal < findNum then
|
||||
helpBinSearch (findNum, vec, mid + 1, high)
|
||||
else
|
||||
helpBinSearch (findNum, vec, low, mid - 1)
|
||||
end
|
||||
else
|
||||
reverseLinearSearch (findNum, mid, vec)
|
||||
end
|
||||
in
|
||||
fun equalOrLess (findNum, vec) =
|
||||
helpBinSearch (findNum, vec, 0, Vector.length vec - 1)
|
||||
end
|
||||
|
||||
local
|
||||
fun forwardLinearSearch (findNum, idx, vec) =
|
||||
if idx = Vector.length vec then
|
||||
~1
|
||||
else
|
||||
let
|
||||
val curVal = Vector.sub (vec, idx)
|
||||
in
|
||||
if curVal > findNum then idx
|
||||
else forwardLinearSearch (findNum, idx + 1, vec)
|
||||
end
|
||||
|
||||
fun helpBinSearch (findNum, vec, low, high) =
|
||||
let
|
||||
val mid = low + ((high - low) div 2)
|
||||
in
|
||||
if high >= low then
|
||||
let
|
||||
val midVal = Vector.sub (vec, mid)
|
||||
in
|
||||
if midVal = findNum then
|
||||
mid
|
||||
else if midVal < findNum then
|
||||
helpBinSearch (findNum, vec, mid + 1, high)
|
||||
else
|
||||
helpBinSearch (findNum, vec, low, mid - 1)
|
||||
end
|
||||
else
|
||||
forwardLinearSearch (findNum, Int.max (mid, 0), vec)
|
||||
end
|
||||
in
|
||||
fun equalOrMore (findNum, vec) =
|
||||
helpBinSearch (findNum, vec, 0, Vector.length vec - 1)
|
||||
end
|
||||
|
||||
local
|
||||
fun helpExists (findNum, vec, low, high) =
|
||||
let
|
||||
val mid = low + ((high - low) div 2)
|
||||
in
|
||||
if high >= low then
|
||||
let
|
||||
val midVal = Vector.sub (vec, mid)
|
||||
in
|
||||
if midVal = findNum then
|
||||
true
|
||||
else if midVal < findNum then
|
||||
helpExists (findNum, vec, mid + 1, high)
|
||||
else
|
||||
helpExists (findNum, vec, low, mid - 1)
|
||||
end
|
||||
else
|
||||
false
|
||||
end
|
||||
in
|
||||
fun exists (findNum, vec) =
|
||||
helpExists (findNum, vec, 0, Vector.length vec - 1)
|
||||
end
|
||||
|
||||
local
|
||||
fun helpEqualOrMinus1 (findNum, vec, low, high) =
|
||||
let
|
||||
val mid = low + ((high - low) div 2)
|
||||
in
|
||||
if high >= low then
|
||||
let
|
||||
val midVal = Vector.sub (vec, mid)
|
||||
in
|
||||
if midVal = findNum then
|
||||
mid
|
||||
else if midVal < findNum then
|
||||
helpEqualOrMinus1 (findNum, vec, mid + 1, high)
|
||||
else
|
||||
helpEqualOrMinus1 (findNum, vec, low, mid - 1)
|
||||
end
|
||||
else
|
||||
~1
|
||||
end
|
||||
in
|
||||
fun equalOrMinus1 (findNum, vec) =
|
||||
helpEqualOrMinus1 (findNum, vec, 0, Vector.length vec - 1)
|
||||
end
|
||||
end
|
||||
303
shf/fcore/cursor-dfa/make-dfa-loop.sml
Normal file
303
shf/fcore/cursor-dfa/make-dfa-loop.sml
Normal file
@@ -0,0 +1,303 @@
|
||||
signature MAKE_DFA_LOOP =
|
||||
sig
|
||||
val fStart: int * int * string * string list * Word8.word * int -> int
|
||||
val startState: Word8.word
|
||||
end
|
||||
|
||||
functor MakeNextDfaLoop(M: MAKE_DFA_LOOP) =
|
||||
struct
|
||||
fun next (lineGap: LineGap.t, cursorIdx, count) =
|
||||
let
|
||||
val {rightStrings, idx = bufferIdx, ...} = lineGap
|
||||
(* convert absolute cursorIdx to idx relative to hd string *)
|
||||
val strIdx = cursorIdx - bufferIdx
|
||||
in
|
||||
case rightStrings of
|
||||
shd :: stl =>
|
||||
if strIdx < String.size shd then
|
||||
(* strIdx is in this string *)
|
||||
M.fStart (strIdx, cursorIdx, shd, stl, M.startState, count)
|
||||
else
|
||||
(* strIdx is in tl *)
|
||||
(case stl of
|
||||
stlhd :: stltl =>
|
||||
let
|
||||
val strIdx = strIdx - String.size shd
|
||||
in
|
||||
M.fStart
|
||||
(strIdx, cursorIdx, stlhd, stltl, M.startState, count)
|
||||
end
|
||||
| _ => cursorIdx)
|
||||
| [] => cursorIdx
|
||||
end
|
||||
end
|
||||
|
||||
functor MakeNextDfaLoopPlus1(M: MAKE_DFA_LOOP) =
|
||||
struct
|
||||
fun next (lineGap: LineGap.t, cursorIdx, count) =
|
||||
let
|
||||
val {rightStrings, idx = bufferIdx, ...} = lineGap
|
||||
(* convert absolute cursorIdx to idx relative to hd string *)
|
||||
val strIdx = cursorIdx - bufferIdx + 1
|
||||
val absIdx = cursorIdx + 1
|
||||
in
|
||||
case rightStrings of
|
||||
shd :: stl =>
|
||||
if strIdx < String.size shd then
|
||||
(* strIdx is in this string *)
|
||||
M.fStart (strIdx, absIdx, shd, stl, M.startState, count)
|
||||
else
|
||||
(* strIdx is in tl *)
|
||||
(case stl of
|
||||
stlhd :: stltl =>
|
||||
let val strIdx = strIdx - String.size shd
|
||||
in M.fStart (strIdx, absIdx, stlhd, stltl, M.startState, count)
|
||||
end
|
||||
| _ => cursorIdx)
|
||||
| [] => cursorIdx
|
||||
end
|
||||
end
|
||||
|
||||
functor MakePrevDfaLoop(M: MAKE_DFA_LOOP) =
|
||||
struct
|
||||
fun startLeftStrings (leftStrings, absIdx, count) =
|
||||
case leftStrings of
|
||||
lhd :: ltl =>
|
||||
M.fStart (String.size lhd - 1, absIdx, lhd, ltl, M.startState, count)
|
||||
| [] => 0
|
||||
|
||||
fun prev (lineGap: LineGap.t, cursorIdx, count) =
|
||||
let
|
||||
val {rightStrings, leftStrings, idx = bufferIdx, ...} = lineGap
|
||||
(* convert absolute cursorIdx to idx relative to hd string *)
|
||||
val strIdx = cursorIdx - bufferIdx
|
||||
in
|
||||
case rightStrings of
|
||||
shd :: stl =>
|
||||
if strIdx < String.size shd then
|
||||
(* strIdx is in this string *)
|
||||
M.fStart (strIdx, cursorIdx, shd, leftStrings, M.startState, count)
|
||||
else
|
||||
(* strIdx is in tl *)
|
||||
(case stl of
|
||||
stlhd :: stltl =>
|
||||
let
|
||||
val strIdx = strIdx - String.size shd
|
||||
val leftStrings = shd :: leftStrings
|
||||
in
|
||||
M.fStart
|
||||
( strIdx
|
||||
, cursorIdx
|
||||
, stlhd
|
||||
, leftStrings
|
||||
, M.startState
|
||||
, count
|
||||
)
|
||||
end
|
||||
| [] => startLeftStrings (leftStrings, cursorIdx, count))
|
||||
| [] => startLeftStrings (leftStrings, cursorIdx, count)
|
||||
end
|
||||
end
|
||||
|
||||
functor MakePrevDfaLoopMinus1(M: MAKE_DFA_LOOP) =
|
||||
struct
|
||||
fun startLeftStrings (leftStrings, absIdx, count) =
|
||||
case leftStrings of
|
||||
lhd :: ltl =>
|
||||
M.fStart (String.size lhd - 1, absIdx, lhd, ltl, M.startState, count)
|
||||
| [] => 0
|
||||
|
||||
fun prev (lineGap: LineGap.t, cursorIdx, count) =
|
||||
let
|
||||
val {idx = bufferIdx, leftStrings, ...} = lineGap
|
||||
val strIdx = cursorIdx - bufferIdx - 1
|
||||
val absIdx = cursorIdx - 1
|
||||
in
|
||||
if strIdx < 0 then
|
||||
startLeftStrings (leftStrings, absIdx, count)
|
||||
else
|
||||
case #rightStrings lineGap of
|
||||
rhd :: _ =>
|
||||
M.fStart (strIdx, absIdx, rhd, leftStrings, M.startState, count)
|
||||
| [] => startLeftStrings (leftStrings, absIdx, count)
|
||||
end
|
||||
end
|
||||
|
||||
signature MAKE_CHAR_FOLDER =
|
||||
sig
|
||||
val startState: Word8.word
|
||||
val tables: Word8.word vector vector
|
||||
|
||||
val isFinal: Word8.word -> bool
|
||||
val finish: int -> int
|
||||
end
|
||||
|
||||
functor MakeCharFolderNext(Fn: MAKE_CHAR_FOLDER) =
|
||||
struct
|
||||
fun nextState (currentState, currentChar) =
|
||||
let
|
||||
val currentState = Word8.toInt currentState
|
||||
val currentTable = Vector.sub (Fn.tables, currentState)
|
||||
val charIdx = Char.ord currentChar
|
||||
in
|
||||
Vector.sub (currentTable, charIdx)
|
||||
end
|
||||
|
||||
fun foldNext (idx, absIdx, str, tl, currentState, counter) =
|
||||
if idx = String.size str then
|
||||
case tl of
|
||||
str :: tl => foldNext (0, absIdx, str, tl, currentState, counter)
|
||||
| [] => absIdx
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, idx)
|
||||
val newState = nextState (currentState, chr)
|
||||
in
|
||||
if Fn.isFinal newState then
|
||||
if counter - 1 = 0 then
|
||||
Fn.finish absIdx
|
||||
else
|
||||
(* new loop, so reset start state and proceed *)
|
||||
let val newState = nextState (Fn.startState, chr)
|
||||
in foldNext (idx + 1, absIdx + 1, str, tl, newState, counter - 1)
|
||||
end
|
||||
else
|
||||
foldNext (idx + 1, absIdx + 1, str, tl, newState, counter)
|
||||
end
|
||||
end
|
||||
|
||||
functor MakeCharFolderPrev(Fn: MAKE_CHAR_FOLDER) =
|
||||
struct
|
||||
fun nextState (currentState, currentChar) =
|
||||
let
|
||||
val currentState = Word8.toInt currentState
|
||||
val currentTable = Vector.sub (Fn.tables, currentState)
|
||||
val charIdx = Char.ord currentChar
|
||||
in
|
||||
Vector.sub (currentTable, charIdx)
|
||||
end
|
||||
|
||||
fun foldPrev (idx, absIdx, str, tl, currentState, counter) =
|
||||
if idx < 0 then
|
||||
case tl of
|
||||
str :: tl =>
|
||||
foldPrev (String.size str - 1, absIdx, str, tl, currentState, counter)
|
||||
| [] => 0
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, idx)
|
||||
val newState = nextState (currentState, chr)
|
||||
in
|
||||
if Fn.isFinal newState then
|
||||
if counter - 1 = 0 then
|
||||
Fn.finish absIdx
|
||||
else
|
||||
let val newState = nextState (Fn.startState, chr)
|
||||
in foldPrev (idx - 1, absIdx - 1, str, tl, newState, counter - 1)
|
||||
end
|
||||
else
|
||||
foldPrev (idx - 1, absIdx - 1, str, tl, newState, counter)
|
||||
end
|
||||
end
|
||||
|
||||
signature MAKE_IF_CHAR_FOLDER =
|
||||
sig
|
||||
type env
|
||||
|
||||
val fStart:
|
||||
int * string * int vector * int * string list * int vector list * env
|
||||
-> int
|
||||
end
|
||||
|
||||
functor MakeIfCharFolderPrev(Fn: MAKE_IF_CHAR_FOLDER) =
|
||||
struct
|
||||
fun foldPrev (lineGap: LineGap.t, cursorIdx, env: Fn.env) =
|
||||
let
|
||||
val
|
||||
{rightStrings, idx = bufferIdx, rightLines, leftStrings, leftLines, ...} =
|
||||
lineGap
|
||||
in
|
||||
case (rightStrings, rightLines) of
|
||||
(strHd :: strTl, lnHd :: lnTl) =>
|
||||
let
|
||||
(* convert absolute cursorIdx to idx relative to hd string *)
|
||||
val strIdx = cursorIdx - bufferIdx
|
||||
in
|
||||
if strIdx < String.size strHd then
|
||||
(* strIdx is either in this string or in leftStrings *)
|
||||
if strIdx < 0 then
|
||||
case (leftStrings, leftLines) of
|
||||
(lshd :: lstl, llhd :: lltl) =>
|
||||
Fn.fStart
|
||||
( String.size lshd - 1
|
||||
, lshd
|
||||
, llhd
|
||||
, cursorIdx
|
||||
, lstl
|
||||
, lltl
|
||||
, env
|
||||
)
|
||||
| (_, _) => 0
|
||||
else
|
||||
Fn.fStart
|
||||
(strIdx, strHd, lnHd, cursorIdx, leftStrings, leftLines, env)
|
||||
else
|
||||
(* strIdx must be in the strTl *)
|
||||
(case (strTl, lnTl) of
|
||||
(nestStrHd :: _, nestLnHd :: _) =>
|
||||
let
|
||||
val strIdx = strIdx - String.size strHd
|
||||
in
|
||||
Fn.fStart
|
||||
( strIdx
|
||||
, nestStrHd
|
||||
, nestLnHd
|
||||
, cursorIdx
|
||||
, strHd :: leftStrings
|
||||
, lnHd :: leftLines
|
||||
, env
|
||||
)
|
||||
end
|
||||
| (_, _) => cursorIdx)
|
||||
end
|
||||
| (_, _) => (* nowhere to go, so return cursorIdx *) cursorIdx
|
||||
end
|
||||
end
|
||||
|
||||
functor MakeIfCharFolderNext(Fn: MAKE_IF_CHAR_FOLDER) =
|
||||
struct
|
||||
fun foldNext (lineGap: LineGap.t, cursorIdx, env: Fn.env) =
|
||||
let
|
||||
val {rightStrings, idx = bufferIdx, rightLines, ...} = lineGap
|
||||
in
|
||||
case (rightStrings, rightLines) of
|
||||
(strHd :: strTl, lnHd :: lnTl) =>
|
||||
let
|
||||
(* convert absolute cursorIdx to idx relative to hd string *)
|
||||
val strIdx = cursorIdx - bufferIdx
|
||||
in
|
||||
if strIdx < String.size strHd then
|
||||
(* strIdx is in this string *)
|
||||
Fn.fStart (strIdx, strHd, lnHd, cursorIdx, strTl, lnTl, env)
|
||||
else
|
||||
(* strIdx must be in the strTl *)
|
||||
(case (strTl, lnTl) of
|
||||
(nestStrHd :: nestStrTl, nestLnHd :: nestLnTl) =>
|
||||
let
|
||||
val strIdx = strIdx - String.size strHd
|
||||
in
|
||||
Fn.fStart
|
||||
( strIdx
|
||||
, nestStrHd
|
||||
, nestLnHd
|
||||
, cursorIdx
|
||||
, nestStrTl
|
||||
, nestLnTl
|
||||
, env
|
||||
)
|
||||
end
|
||||
| (_, _) => cursorIdx)
|
||||
end
|
||||
| (_, _) => (* nowhere to go, so return cursorIdx *) cursorIdx
|
||||
end
|
||||
end
|
||||
239
shf/fcore/cursor-dfa/vi-caps-word-dfa.sml
Normal file
239
shf/fcore/cursor-dfa/vi-caps-word-dfa.sml
Normal file
@@ -0,0 +1,239 @@
|
||||
structure ViCapsWordDfa =
|
||||
struct
|
||||
val startState: Word8.word = 0w0
|
||||
val startNonBlankState: Word8.word = 0w1
|
||||
val startSpaceState: Word8.word = 0w2
|
||||
val nonBlankAfterSpaceState: Word8.word = 0w3
|
||||
val spaceAfterNonBlankState = 0w4
|
||||
val startNewline: Word8.word = 0w5
|
||||
val newlineToNewline: Word8.word = 0w6
|
||||
val chrToNewline: Word8.word = 0w07
|
||||
|
||||
fun makeStart i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if chr = #"\n" then startNewline
|
||||
else if Char.isSpace chr then startSpaceState
|
||||
else startNonBlankState
|
||||
end
|
||||
|
||||
fun makeStartNonBlankState i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if chr = #"\n" then chrToNewline
|
||||
else if Char.isSpace chr then spaceAfterNonBlankState
|
||||
else startNonBlankState
|
||||
end
|
||||
|
||||
fun makeStartSpace i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if chr = #"\n" then chrToNewline
|
||||
else if Char.isSpace chr then startSpaceState
|
||||
else nonBlankAfterSpaceState
|
||||
end
|
||||
|
||||
fun makeNonBlankAfterSpace i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if chr = #"\n" then chrToNewline
|
||||
else if Char.isSpace chr then spaceAfterNonBlankState
|
||||
else nonBlankAfterSpaceState
|
||||
end
|
||||
|
||||
fun makeStartNewline i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if chr = #"\n" then newlineToNewline
|
||||
else if Char.isSpace chr then startSpaceState
|
||||
else nonBlankAfterSpaceState
|
||||
end
|
||||
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
val startNonBlankTable = Vector.tabulate (255, makeStartNonBlankState)
|
||||
val startSpaceTable = Vector.tabulate (255, makeStartSpace)
|
||||
val nonBlankAfterSpaceTable = Vector.tabulate (255, makeNonBlankAfterSpace)
|
||||
val spaceAfterNonBlankTable = nonBlankAfterSpaceTable
|
||||
val newlineTable = Vector.tabulate (255, makeStartNewline)
|
||||
|
||||
val tables =
|
||||
#[ startTable
|
||||
, startNonBlankTable
|
||||
, startSpaceTable
|
||||
, nonBlankAfterSpaceTable
|
||||
, spaceAfterNonBlankTable
|
||||
, newlineTable
|
||||
, newlineTable
|
||||
, newlineTable
|
||||
]
|
||||
|
||||
structure StartOfNextWORD =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun finish x = x
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = nonBlankAfterSpaceState
|
||||
orelse currentState = newlineToNewline
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldNext
|
||||
end)
|
||||
|
||||
structure StartOfNextWORDForDelete =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun finish x = x
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = nonBlankAfterSpaceState
|
||||
orelse currentState = chrToNewline
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldNext
|
||||
end)
|
||||
|
||||
structure EndOfPrevWORD =
|
||||
MakePrevDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderPrev
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun finish x = x
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = nonBlankAfterSpaceState
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldPrev
|
||||
end)
|
||||
|
||||
structure StartOfCurrentWORDFolder =
|
||||
MakeCharFolderPrev
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = spaceAfterNonBlankState
|
||||
orelse currentState = chrToNewline
|
||||
orelse currentState = newlineToNewline
|
||||
|
||||
fun finish idx = idx + 1
|
||||
end)
|
||||
|
||||
structure StartOfCurrentWORD =
|
||||
MakePrevDfaLoopMinus1
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = StartOfCurrentWORDFolder.foldPrev
|
||||
end)
|
||||
|
||||
structure StartOfNextWORDStrict =
|
||||
MakePrevDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = StartOfCurrentWORDFolder.foldPrev
|
||||
end)
|
||||
|
||||
fun endOfCurrentWORDFolderIsFinal currentState =
|
||||
currentState = spaceAfterNonBlankState orelse currentState = chrToNewline
|
||||
|
||||
structure EndOfCurrentWORDFolder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
val isFinal = endOfCurrentWORDFolderIsFinal
|
||||
|
||||
fun finish idx =
|
||||
Int.max (0, idx - 1)
|
||||
end)
|
||||
|
||||
structure EndOfCurrentWORD =
|
||||
MakeNextDfaLoopPlus1
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = EndOfCurrentWORDFolder.foldNext
|
||||
end)
|
||||
|
||||
structure EndOfCurrentWORDForDelete =
|
||||
MakeNextDfaLoopPlus1
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
val isFinal = endOfCurrentWORDFolderIsFinal
|
||||
|
||||
fun finish idx = idx
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldNext
|
||||
end)
|
||||
|
||||
structure EndOfCurrentWORDStrict =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = EndOfCurrentWORDFolder.foldNext
|
||||
end)
|
||||
|
||||
(* W *)
|
||||
val startOfNextWORD = StartOfNextWORD.next
|
||||
val startOfNextWORDForDelete = StartOfNextWORDForDelete.next
|
||||
(* gE *)
|
||||
val endOfPrevWORD = EndOfPrevWORD.prev
|
||||
(* B *)
|
||||
val startOfCurrentWORD = StartOfCurrentWORD.prev
|
||||
(* E *)
|
||||
val endOfCurrentWORD = EndOfCurrentWORD.next
|
||||
val endOfCurrentWORDForDelete = EndOfCurrentWORDForDelete.next
|
||||
|
||||
(* functions to strictly get the start and end of the current word.
|
||||
* Problem: We want to support Vi motions like viW (selects a single word),
|
||||
* as well as ciW (change one WORD) and diW (delete one WORD).
|
||||
*
|
||||
* The 'startOfCurrentWORD' and 'endOfCurrentWORD' functions do this
|
||||
* (representing the vi 'B' and 'E' commands respectively),
|
||||
* except that 'B' goes to the previous WORD if the cursor is on the first
|
||||
* character of the current WORD, and 'E' goes to the next WORD if the cursor
|
||||
* is on the last character of the current WORD.
|
||||
*
|
||||
* What is meant by "strict" is that these below functions always stay
|
||||
* within the current WORD, not making the two exceptions mentioned above.
|
||||
*)
|
||||
val startOfCurrentWORDStrict = StartOfNextWORDStrict.prev
|
||||
val endOfCurrentWORDStrict = EndOfCurrentWORDStrict.next
|
||||
end
|
||||
64
shf/fcore/cursor-dfa/vi-dlr-dfa.sml
Normal file
64
shf/fcore/cursor-dfa/vi-dlr-dfa.sml
Normal file
@@ -0,0 +1,64 @@
|
||||
structure ViDlrDfa =
|
||||
struct
|
||||
val startState: Word8.word = 0w0
|
||||
val newlineState: Word8.word = 0w1
|
||||
val notNewlineState = 0w2
|
||||
|
||||
fun makeStart i =
|
||||
if Char.chr i = #"\n" then newlineState else notNewlineState
|
||||
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
val newlineTable = startTable
|
||||
val notNewlineTable = startTable
|
||||
|
||||
val tables = #[startTable, newlineTable, notNewlineTable]
|
||||
|
||||
fun isFinal currentState = currentState = newlineState
|
||||
|
||||
structure ViDlr =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun finish x = x - 1
|
||||
val isFinal = isFinal
|
||||
end)
|
||||
|
||||
fun fStart (idx, absIdx, str, tl, currentState, counter) =
|
||||
if String.sub (str, idx) = #"\n" then
|
||||
if counter = 1 then
|
||||
absIdx
|
||||
else
|
||||
Folder.foldNext
|
||||
(idx + 1, absIdx + 1, str, tl, currentState, counter - 1)
|
||||
else
|
||||
Folder.foldNext (idx, absIdx, str, tl, currentState, counter)
|
||||
end)
|
||||
|
||||
structure ViDlrForDelete =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun finish x = x + 1
|
||||
val isFinal = isFinal
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldNext
|
||||
end)
|
||||
|
||||
val next = ViDlr.next
|
||||
val nextForDelete = ViDlrForDelete.next
|
||||
end
|
||||
76
shf/fcore/cursor-dfa/vi-h-dfa.sml
Normal file
76
shf/fcore/cursor-dfa/vi-h-dfa.sml
Normal file
@@ -0,0 +1,76 @@
|
||||
structure ViHDfa =
|
||||
struct
|
||||
val startState: Word8.word = 0w0
|
||||
val oneNewlineState: Word8.word = 0w1
|
||||
val twoNewlineState: Word8.word = 0w2
|
||||
val chrState: Word8.word = 0w3
|
||||
val chrBeforeNewlieState: Word8.word = 0w4
|
||||
|
||||
fun makeStart i =
|
||||
if Char.chr i = #"\n" then oneNewlineState else chrState
|
||||
|
||||
fun makeOneNewline i =
|
||||
if Char.chr i = #"\n" then twoNewlineState else chrBeforeNewlieState
|
||||
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
val oneNewlineTable = Vector.tabulate (255, makeOneNewline)
|
||||
val twoNewlineTable = oneNewlineTable
|
||||
val chrTable = startTable
|
||||
val chrBeforeNewlieTable = startTable
|
||||
|
||||
val tables =
|
||||
#[ startTable
|
||||
, oneNewlineTable
|
||||
, twoNewlineTable
|
||||
, chrTable
|
||||
, chrBeforeNewlieTable
|
||||
]
|
||||
|
||||
fun next (currentState, chr) =
|
||||
let val table = Vector.sub (tables, Word8.toInt currentState)
|
||||
in Vector.sub (table, Char.ord chr)
|
||||
end
|
||||
|
||||
structure ViH =
|
||||
MakePrevDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
fun loop (idx, absIdx, str, tl, currentState, counter) =
|
||||
if idx < 0 then
|
||||
case tl of
|
||||
str :: tl =>
|
||||
loop
|
||||
(String.size str - 1, absIdx, str, tl, currentState, counter)
|
||||
| [] => 0
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, idx)
|
||||
val newState = next (currentState, chr)
|
||||
in
|
||||
if newState = chrBeforeNewlieState orelse newState = chrState then
|
||||
if counter - 1 = ~1 then
|
||||
absIdx
|
||||
else
|
||||
loop (idx - 1, absIdx - 1, str, tl, startState, counter - 1)
|
||||
else if newState = twoNewlineState then
|
||||
if counter - 1 = ~1 then
|
||||
absIdx + 1
|
||||
else
|
||||
loop
|
||||
( idx - 1
|
||||
, absIdx - 1
|
||||
, str
|
||||
, tl
|
||||
, oneNewlineState
|
||||
, counter - 1
|
||||
)
|
||||
else
|
||||
loop (idx - 1, absIdx - 1, str, tl, newState, counter)
|
||||
end
|
||||
|
||||
val fStart = loop
|
||||
end)
|
||||
|
||||
val prev = ViH.prev
|
||||
end
|
||||
53
shf/fcore/cursor-dfa/vi-l-dfa.sml
Normal file
53
shf/fcore/cursor-dfa/vi-l-dfa.sml
Normal file
@@ -0,0 +1,53 @@
|
||||
structure ViLDfa =
|
||||
struct
|
||||
val startState: Word8.word = 0w0
|
||||
val newlineState: Word8.word = 0w1
|
||||
val chrState: Word8.word = 0w2
|
||||
val newlineAfterCHrState: Word8.word = 0w3
|
||||
|
||||
fun makeStart i =
|
||||
if Char.chr i = #"\n" then newlineState else chrState
|
||||
|
||||
fun makeChr i =
|
||||
if Char.chr i = #"\n" then newlineAfterCHrState else chrState
|
||||
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
val newlineTable = startTable
|
||||
val chrTable = Vector.tabulate (255, makeChr)
|
||||
val newlineAfterCHrTable = startTable
|
||||
|
||||
val tables = #[startTable, newlineTable, chrTable, newlineAfterCHrTable]
|
||||
|
||||
fun next (currentState, chr) =
|
||||
let val table = Vector.sub (tables, Word8.toInt currentState)
|
||||
in Vector.sub (table, Char.ord chr)
|
||||
end
|
||||
|
||||
structure ViL =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
fun loop (idx, absIdx, str, tl, currentState, counter) =
|
||||
if idx = String.size str then
|
||||
case tl of
|
||||
str :: tl => loop (0, absIdx, str, tl, currentState, counter)
|
||||
| [] => absIdx
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, idx)
|
||||
val newState = next (currentState, chr)
|
||||
in
|
||||
if newState = newlineAfterCHrState then
|
||||
loop (idx + 1, absIdx + 1, str, tl, newState, counter)
|
||||
else if counter - 1 = ~1 then
|
||||
absIdx
|
||||
else
|
||||
loop (idx + 1, absIdx + 1, str, tl, newState, counter - 1)
|
||||
end
|
||||
|
||||
val fStart = loop
|
||||
end)
|
||||
|
||||
val next = ViL.next
|
||||
end
|
||||
285
shf/fcore/cursor-dfa/vi-word-dfa.sml
Normal file
285
shf/fcore/cursor-dfa/vi-word-dfa.sml
Normal file
@@ -0,0 +1,285 @@
|
||||
structure ViWordDfa =
|
||||
struct
|
||||
val startState: Word8.word = 0w0
|
||||
|
||||
val startAlpha: Word8.word = 0w1
|
||||
val startSpace: Word8.word = 0w2
|
||||
val startPunct: Word8.word = 0w3
|
||||
|
||||
val alphaToSpace: Word8.word = 0w4
|
||||
val punctToSpace: Word8.word = 0w5
|
||||
|
||||
val spaceToAlpha: Word8.word = 0w6
|
||||
val spaceToPunct: Word8.word = 0w7
|
||||
|
||||
val startNewline: Word8.word = 0w8
|
||||
val newlineToNewline: Word8.word = 0w9
|
||||
val chrToNewline: Word8.word = 0w10
|
||||
|
||||
val newlineToAlpha: Word8.word = 0w11
|
||||
val newlineToPunct: Word8.word = 0w12
|
||||
|
||||
val alphaToPunct: Word8.word = 0w13
|
||||
val punctToAlpha: Word8.word = 0w14
|
||||
|
||||
fun makeStart i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if Char.isAlphaNum chr orelse chr = #"_" then startAlpha
|
||||
else if chr = #"\n" then startNewline
|
||||
else if Char.isSpace chr then startSpace
|
||||
else startPunct
|
||||
end
|
||||
|
||||
fun makeStartAlpha i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if Char.isAlphaNum chr orelse chr = #"_" then startAlpha
|
||||
else if chr = #"\n" then chrToNewline
|
||||
else if Char.isSpace chr then alphaToSpace
|
||||
else alphaToPunct
|
||||
end
|
||||
|
||||
fun makeStartSpace i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if Char.isAlphaNum chr orelse chr = #"_" then spaceToAlpha
|
||||
else if chr = #"\n" then chrToNewline
|
||||
else if Char.isSpace chr then startSpace
|
||||
else spaceToPunct
|
||||
end
|
||||
|
||||
fun makeStartPunct i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if Char.isAlphaNum chr orelse chr = #"_" then punctToAlpha
|
||||
else if chr = #"\n" then chrToNewline
|
||||
else if Char.isSpace chr then punctToSpace
|
||||
else startPunct
|
||||
end
|
||||
|
||||
fun makeStartNewline i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if Char.isAlphaNum chr orelse chr = #"_" then newlineToAlpha
|
||||
else if chr = #"\n" then newlineToNewline
|
||||
else if Char.isSpace chr then startSpace
|
||||
else newlineToPunct
|
||||
end
|
||||
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
|
||||
val startAlphaTable = Vector.tabulate (255, makeStartAlpha)
|
||||
val startSpaceTable = Vector.tabulate (255, makeStartSpace)
|
||||
val startPunctTable = Vector.tabulate (255, makeStartPunct)
|
||||
|
||||
val alphaToSpaceTable = startSpaceTable
|
||||
val punctToSpaceTable = startSpaceTable
|
||||
|
||||
val spaceToAlphaTable = startAlphaTable
|
||||
val spaceToPunctTable = startPunctTable
|
||||
|
||||
val newlineTable = Vector.tabulate (255, makeStartNewline)
|
||||
|
||||
val tables =
|
||||
#[ startTable
|
||||
|
||||
, startAlphaTable
|
||||
, startSpaceTable
|
||||
, startPunctTable
|
||||
|
||||
, alphaToSpaceTable
|
||||
, punctToSpaceTable
|
||||
|
||||
, spaceToAlphaTable
|
||||
, spaceToPunctTable
|
||||
|
||||
, newlineTable
|
||||
, newlineTable
|
||||
, newlineTable
|
||||
|
||||
, startAlphaTable
|
||||
, startPunctTable
|
||||
]
|
||||
|
||||
structure StartOfNextWord =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = alphaToPunct orelse currentState = punctToAlpha
|
||||
orelse currentState = spaceToAlpha
|
||||
orelse currentState = spaceToPunct
|
||||
orelse currentState = newlineToNewline
|
||||
orelse currentState = newlineToAlpha
|
||||
orelse currentState = newlineToPunct
|
||||
|
||||
fun finish x = x
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldNext
|
||||
end)
|
||||
|
||||
(* This is the same as StartOfNextWord, except for the `isFinal` function.
|
||||
* The difference is that the `isFinal` function here considers
|
||||
* the state where any character goes to a newline,
|
||||
* to be a final state.
|
||||
* This is because, in Vim, the 'w' motion will move past a newline
|
||||
* when that newline is preceded by a non-newline character.
|
||||
* However, the 'dw' motion deletes until that newline
|
||||
* (not including the newline itself).
|
||||
* It is easier, less fragile, and perhaps clearer,
|
||||
* to implement the difference using a transition table like this
|
||||
* than convoluted if-statements. *)
|
||||
structure StartOfNextWordForDelete =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = alphaToPunct orelse currentState = punctToAlpha
|
||||
orelse currentState = spaceToAlpha
|
||||
orelse currentState = spaceToPunct
|
||||
orelse currentState = chrToNewline
|
||||
|
||||
fun finish x = x
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldNext
|
||||
end)
|
||||
|
||||
structure EndOfPrevWord =
|
||||
MakePrevDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderPrev
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = alphaToPunct orelse currentState = punctToAlpha
|
||||
orelse currentState = spaceToAlpha
|
||||
orelse currentState = spaceToPunct
|
||||
orelse currentState = newlineToNewline
|
||||
orelse currentState = newlineToAlpha
|
||||
orelse currentState = newlineToPunct
|
||||
|
||||
fun finish x = x
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldPrev
|
||||
end)
|
||||
|
||||
structure StartOfCurrentWordFolder =
|
||||
MakeCharFolderPrev
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
fun isFinal currentState =
|
||||
currentState = alphaToSpace orelse currentState = punctToSpace
|
||||
orelse currentState = alphaToPunct orelse currentState = punctToAlpha
|
||||
orelse currentState = chrToNewline
|
||||
orelse currentState = newlineToNewline
|
||||
|
||||
fun finish idx = idx + 1
|
||||
end)
|
||||
|
||||
structure StartOfCurrentWord =
|
||||
MakePrevDfaLoopMinus1
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = StartOfCurrentWordFolder.foldPrev
|
||||
end)
|
||||
|
||||
structure StartOfCurrentWordStrict =
|
||||
MakePrevDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = StartOfCurrentWordFolder.foldPrev
|
||||
end)
|
||||
|
||||
fun isFinalForEndOfCurrentWord currentState =
|
||||
currentState = alphaToSpace orelse currentState = punctToSpace
|
||||
orelse currentState = alphaToPunct orelse currentState = punctToAlpha
|
||||
orelse currentState = chrToNewline
|
||||
|
||||
structure EndOfCurrentWordFolder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
val isFinal = isFinalForEndOfCurrentWord
|
||||
fun finish x = x - 1
|
||||
end)
|
||||
|
||||
structure EndOfCurrentWord =
|
||||
MakeNextDfaLoopPlus1
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = EndOfCurrentWordFolder.foldNext
|
||||
end)
|
||||
|
||||
structure EndOfCurrentWordStrict =
|
||||
MakeNextDfaLoop
|
||||
(struct
|
||||
val startState = startState
|
||||
val fStart = EndOfCurrentWordFolder.foldNext
|
||||
end)
|
||||
|
||||
structure EndOfCurrentWordForDelete =
|
||||
MakeNextDfaLoopPlus1
|
||||
(struct
|
||||
val startState = startState
|
||||
|
||||
structure Folder =
|
||||
MakeCharFolderNext
|
||||
(struct
|
||||
val startState = startState
|
||||
val tables = tables
|
||||
|
||||
val isFinal = isFinalForEndOfCurrentWord
|
||||
fun finish x = x
|
||||
end)
|
||||
|
||||
val fStart = Folder.foldNext
|
||||
end)
|
||||
|
||||
(* w *)
|
||||
val startOfNextWord = StartOfNextWord.next
|
||||
val startOfNextWordForDelete = StartOfNextWordForDelete.next
|
||||
(* ge *)
|
||||
val endOfPrevWord = EndOfPrevWord.prev
|
||||
(* b *)
|
||||
val startOfCurrentWord = StartOfCurrentWord.prev
|
||||
(* e *)
|
||||
val endOfCurrentWord = EndOfCurrentWord.next
|
||||
val endOfCurrentWordForDelete = EndOfCurrentWordForDelete.next
|
||||
|
||||
(* the meaning of "Strict" and the utility of these two functions
|
||||
* is described in vi-WORD-dfa.sml *)
|
||||
val startOfCurrentWordStrict = StartOfCurrentWordStrict.prev
|
||||
val endOfCurrentWordStrict = EndOfCurrentWordStrict.next
|
||||
end
|
||||
1028
shf/fcore/cursor.sml
Normal file
1028
shf/fcore/cursor.sml
Normal file
File diff suppressed because it is too large
Load Diff
103
shf/fcore/move.sml
Normal file
103
shf/fcore/move.sml
Normal file
@@ -0,0 +1,103 @@
|
||||
signature MOVE =
|
||||
sig
|
||||
val fMove: LineGap.t * int -> int
|
||||
end
|
||||
|
||||
signature MAKE_MOVE =
|
||||
sig
|
||||
val move: AppType.app_type * int -> AppType.app_type
|
||||
end
|
||||
|
||||
functor MakeMove(Fn: MOVE): MAKE_MOVE =
|
||||
struct
|
||||
fun finish (app: AppType.app_type, buffer, cursorIdx) =
|
||||
let
|
||||
val {searchList, bufferModifyTime, ...} = app
|
||||
in
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, cursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
fun helpMove (app: AppType.app_type, buffer, cursorIdx, count) =
|
||||
if count = 0 then
|
||||
finish (app, buffer, cursorIdx)
|
||||
else
|
||||
(* move LineGap to cursorIdx, which is necessary for finding newCursorIdx *)
|
||||
let
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val textLength = #textLength buffer
|
||||
val newCursorIdx = Fn.fMove (buffer, cursorIdx)
|
||||
in
|
||||
if newCursorIdx >= textLength - 1 then
|
||||
let val newCursorIdx = Int.max (textLength - 1, 0)
|
||||
in finish (app, buffer, newCursorIdx)
|
||||
end
|
||||
else
|
||||
helpMove (app, buffer, newCursorIdx, count - 1)
|
||||
end
|
||||
|
||||
fun move (app: AppType.app_type, count) =
|
||||
let val {cursorIdx, buffer, ...} = app
|
||||
in helpMove (app, buffer, cursorIdx, count)
|
||||
end
|
||||
end
|
||||
|
||||
structure MoveToStartOfLine = MakeMove (struct val fMove = Cursor.vi0 end)
|
||||
|
||||
signature DFA_MOVE =
|
||||
sig
|
||||
val fMove: LineGap.t * int * int -> int
|
||||
end
|
||||
|
||||
signature MAKE_DFA_MOVE =
|
||||
sig
|
||||
val move: AppType.app_type * int -> AppType.app_type
|
||||
end
|
||||
|
||||
functor MakeDfaMove(Fn: DFA_MOVE): MAKE_DFA_MOVE =
|
||||
struct
|
||||
fun move (app: AppType.app_type, count) : AppType.app_type =
|
||||
let
|
||||
val {buffer, cursorIdx, searchList, bufferModifyTime, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorIdx = Fn.fMove (buffer, cursorIdx, count)
|
||||
|
||||
val textLength = #textLength buffer
|
||||
in
|
||||
if cursorIdx >= textLength - 1 then
|
||||
let
|
||||
val cursorIdx = Int.max (textLength - 1, 0)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorIdx =
|
||||
if Cursor.isOnNewlineAfterChr (buffer, cursorIdx) then cursorIdx - 1
|
||||
else cursorIdx
|
||||
in
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, cursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
else
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, cursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
end
|
||||
|
||||
structure MoveViH = MakeDfaMove (struct val fMove = Cursor.viH end)
|
||||
structure MoveViL = MakeDfaMove (struct val fMove = Cursor.viL end)
|
||||
|
||||
structure MoveToNextWord = MakeDfaMove (struct val fMove = Cursor.nextWord end)
|
||||
structure MoveToNextWORD = MakeDfaMove (struct val fMove = Cursor.nextWORD end)
|
||||
|
||||
structure MoveToEndOfWord =
|
||||
MakeDfaMove (struct val fMove = Cursor.endOfWord end)
|
||||
structure MoveToEndOfWORD =
|
||||
MakeDfaMove (struct val fMove = Cursor.endOfWORD end)
|
||||
|
||||
structure MoveToPrevWord = MakeDfaMove (struct val fMove = Cursor.prevWord end)
|
||||
structure MoveToPrevWORD = MakeDfaMove (struct val fMove = Cursor.prevWORD end)
|
||||
|
||||
structure MoveToEndOfPrevWord =
|
||||
MakeDfaMove (struct val fMove = Cursor.endOfPrevWord end)
|
||||
structure MoveToEndOfPrevWORD =
|
||||
MakeDfaMove (struct val fMove = Cursor.endOfPrevWORD end)
|
||||
|
||||
structure MoveToEndOfLine = MakeDfaMove (struct val fMove = Cursor.viDlr end)
|
||||
1298
shf/fcore/normal-mode/make-normal-delete.sml
Normal file
1298
shf/fcore/normal-mode/make-normal-delete.sml
Normal file
File diff suppressed because it is too large
Load Diff
5
shf/fcore/normal-mode/normal-delete.sml
Normal file
5
shf/fcore/normal-mode/normal-delete.sml
Normal file
@@ -0,0 +1,5 @@
|
||||
structure NormalDelete =
|
||||
MakeNormalDelete
|
||||
(struct
|
||||
fun initMsgs _ = []
|
||||
end)
|
||||
155
shf/fcore/normal-mode/normal-finish.sml
Normal file
155
shf/fcore/normal-mode/normal-finish.sml
Normal file
@@ -0,0 +1,155 @@
|
||||
structure NormalFinish =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
open MailboxType
|
||||
open DrawMsg
|
||||
open InputMsg
|
||||
|
||||
fun clearMode app =
|
||||
NormalModeWith.mode (app, NORMAL_MODE "", [])
|
||||
|
||||
fun buildTextAndClear
|
||||
(app: app_type, buffer, cursorIdx, searchList, msgs, bufferModifyTime) =
|
||||
let
|
||||
val
|
||||
{ windowWidth
|
||||
, windowHeight
|
||||
, visualScrollColumn = prevScrollColumn
|
||||
, startLine = prevLineNumber
|
||||
, ...
|
||||
} = app
|
||||
|
||||
(* calculate new scroll column and start line, if there are any changes *)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val visualScrollColumn =
|
||||
TextScroll.getScrollColumn
|
||||
(buffer, cursorIdx, windowWidth, prevScrollColumn)
|
||||
|
||||
val cursorLine = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val startLine =
|
||||
TextScroll.getStartLine
|
||||
(prevLineNumber, cursorLine, windowHeight, #lineLength buffer)
|
||||
|
||||
(* move buffer to new startLine as required by TextBuilder.build *)
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DRAW_TEXT drawMsg
|
||||
val msgs = DRAW drawMsg :: msgs
|
||||
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.bufferAndCursorIdx
|
||||
( app
|
||||
, buffer
|
||||
, cursorIdx
|
||||
, mode
|
||||
, startLine
|
||||
, searchList
|
||||
, msgs
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
)
|
||||
end
|
||||
|
||||
fun resizeText (app: app_type, newWidth, newHeight) =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine
|
||||
, cursorIdx
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn = prevScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
|
||||
val newBuffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val visualScrollColumn =
|
||||
TextScroll.getScrollColumn
|
||||
(newBuffer, cursorIdx, newWidth, prevScrollColumn)
|
||||
val newBuffer = LineGap.goToLine (startLine, newBuffer)
|
||||
val lineIdx = TextBuilderUtils.getLineAbsIdxFromBuffer (startLine, buffer)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, newWidth
|
||||
, newHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DRAW_TEXT drawMsg
|
||||
val msgs = [DRAW drawMsg]
|
||||
in
|
||||
NormalModeWith.bufferAndSize
|
||||
( app
|
||||
, newBuffer
|
||||
, newWidth
|
||||
, newHeight
|
||||
, searchList
|
||||
, msgs
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
)
|
||||
end
|
||||
|
||||
fun centreToCursor (app: app_type) =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine = prevLineNumber
|
||||
, cursorIdx
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorLine = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val startLine = TextScroll.getLineCentre (cursorLine, windowHeight)
|
||||
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DRAW_TEXT drawMsg
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
NormalModeWith.bufferAndCursorIdx
|
||||
( app
|
||||
, buffer
|
||||
, cursorIdx
|
||||
, NORMAL_MODE ""
|
||||
, startLine
|
||||
, searchList
|
||||
, drawMsg
|
||||
, bufferModifyTime
|
||||
, #visualScrollColumn app
|
||||
)
|
||||
end
|
||||
end
|
||||
203
shf/fcore/normal-mode/normal-mode-with.sml
Normal file
203
shf/fcore/normal-mode/normal-mode-with.sml
Normal file
@@ -0,0 +1,203 @@
|
||||
structure NormalModeWith =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
fun bufferMsgsAndMode (app: app_type, newBuffer, newMsgs, newMode) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, buffer = _
|
||||
, msgs = _
|
||||
, bufferModifyTime
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
, startLine
|
||||
, cursorIdx
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, buffer = newBuffer
|
||||
, msgs = newMsgs
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, searchList = searchList
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, startLine = startLine
|
||||
, cursorIdx = cursorIdx
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
|
||||
fun bufferAndSize
|
||||
( app: app_type
|
||||
, newBuffer
|
||||
, newWidth
|
||||
, newHeight
|
||||
, newSearchList
|
||||
, newMsgs
|
||||
, newBufferModifyTime
|
||||
, newVisualScrollColumn
|
||||
) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, buffer = _
|
||||
, bufferModifyTime = _
|
||||
, windowWidth = _
|
||||
, windowHeight = _
|
||||
, searchList = _
|
||||
, visualScrollColumn = _
|
||||
, msgs = _
|
||||
, startLine
|
||||
, cursorIdx
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, buffer = newBuffer
|
||||
, bufferModifyTime = newBufferModifyTime
|
||||
, windowWidth = newWidth
|
||||
, windowHeight = newHeight
|
||||
, searchList = newSearchList
|
||||
, visualScrollColumn = newVisualScrollColumn
|
||||
, msgs = newMsgs
|
||||
, startLine = startLine
|
||||
, cursorIdx = cursorIdx
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
|
||||
fun bufferAndCursorIdx
|
||||
( app: app_type
|
||||
, newBuffer
|
||||
, newCursorIdx
|
||||
, newMode
|
||||
, newStartLine
|
||||
, newSearchList
|
||||
, newMsgs
|
||||
, newBufferModifyTime
|
||||
, newVisualScrollColumn
|
||||
) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, buffer = _
|
||||
, bufferModifyTime = _
|
||||
, cursorIdx = _
|
||||
, startLine = _
|
||||
, searchList = _
|
||||
, visualScrollColumn = _
|
||||
, msgs = _
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, buffer = newBuffer
|
||||
, bufferModifyTime = newBufferModifyTime
|
||||
, cursorIdx = newCursorIdx
|
||||
, startLine = newStartLine
|
||||
, searchList = newSearchList
|
||||
, visualScrollColumn = newVisualScrollColumn
|
||||
, msgs = newMsgs
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
|
||||
fun mode (app: app_type, newMode, newMsgs) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, msgs = _
|
||||
, buffer
|
||||
, bufferModifyTime
|
||||
, searchList
|
||||
, cursorIdx
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine
|
||||
, visualScrollColumn
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, msgs = newMsgs
|
||||
, buffer = buffer
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, searchList = searchList
|
||||
, cursorIdx = cursorIdx
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, startLine = startLine
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
|
||||
fun modeAndBuffer (app: app_type, newBuffer, newMode, newMsgs) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, msgs = _
|
||||
, buffer = _
|
||||
, bufferModifyTime
|
||||
, searchList
|
||||
, cursorIdx
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine
|
||||
, visualScrollColumn
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, msgs = newMsgs
|
||||
, buffer = newBuffer
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, searchList = searchList
|
||||
, cursorIdx = cursorIdx
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, startLine = startLine
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
|
||||
fun searchList (app: app_type, newSearchList, newBuffer, newBufferModifyTime) =
|
||||
let
|
||||
val
|
||||
{ searchList = _
|
||||
, buffer = _
|
||||
, bufferModifyTime
|
||||
, msgs
|
||||
, mode
|
||||
, cursorIdx
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine
|
||||
, visualScrollColumn
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ searchList = newSearchList
|
||||
, buffer = newBuffer
|
||||
, bufferModifyTime = newBufferModifyTime
|
||||
, msgs = msgs
|
||||
, mode = mode
|
||||
, cursorIdx = cursorIdx
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, startLine = startLine
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
end
|
||||
693
shf/fcore/normal-mode/normal-mode.sml
Normal file
693
shf/fcore/normal-mode/normal-mode.sml
Normal file
@@ -0,0 +1,693 @@
|
||||
structure NormalMode =
|
||||
struct
|
||||
(* parsing functions, deciding what to do while we are in normal mode *)
|
||||
|
||||
open AppType
|
||||
open InputMsg
|
||||
|
||||
fun switchToNormalSearchMode (app: app_type, caseSensitive) =
|
||||
NormalSearchFinish.onSearchChanged
|
||||
(app, "", PersistentVector.empty, 0, 0, caseSensitive, #buffer app)
|
||||
|
||||
fun getNumLength (pos, str) =
|
||||
if pos = String.size str then
|
||||
pos
|
||||
else
|
||||
let val chr = String.sub (str, pos)
|
||||
in if Char.isDigit chr then getNumLength (pos + 1, str) else pos
|
||||
end
|
||||
|
||||
fun appendChr (app: app_type, chr, str) =
|
||||
let
|
||||
val str = str ^ Char.toString chr
|
||||
val mode = NORMAL_MODE str
|
||||
in
|
||||
NormalModeWith.mode (app, mode, [])
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (app: app_type, cursorIdx, buffer, searchList, count, time) =
|
||||
if count = 0 then
|
||||
NormalDelete.finishAfterDeletingBuffer
|
||||
(app, #cursorIdx app, buffer, searchList, time, [])
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val lineStart = Cursor.vi0 (buffer, cursorIdx)
|
||||
|
||||
val (buffer, searchList) = SearchList.insert
|
||||
(lineStart, " ", buffer, searchList, #dfa app)
|
||||
|
||||
val buffer = LineGap.goToIdx (lineStart, buffer)
|
||||
val lineEnd = Cursor.viDlr (buffer, lineStart, 1)
|
||||
val buffer = LineGap.goToIdx (lineEnd, buffer)
|
||||
val nextLine = Cursor.viL (buffer, lineEnd, 1)
|
||||
|
||||
val count = if lineEnd = nextLine then 0 else count - 1
|
||||
in
|
||||
loop (app, nextLine, buffer, searchList, count, time)
|
||||
end
|
||||
in
|
||||
fun indnetLine (app: app_type, count, time) =
|
||||
let val {buffer, searchList, cursorIdx, ...} = app
|
||||
in loop (app, cursorIdx, buffer, searchList, count, time)
|
||||
end
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (cursorIdx, buffer, searchList, dfa, count) =
|
||||
if count = 0 then
|
||||
(buffer, searchList)
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val lineStart = Cursor.vi0 (buffer, cursorIdx)
|
||||
val firstNonSpaceChr = Cursor.firstNonSpaceChr (buffer, lineStart)
|
||||
|
||||
(* delete from buffer *)
|
||||
val difference = firstNonSpaceChr - lineStart
|
||||
val deleteLength = Int.min (difference, 2)
|
||||
val (buffer, searchList) =
|
||||
if difference = 0 then
|
||||
(* can't dedent as there is no leading space *)
|
||||
(buffer, searchList)
|
||||
else
|
||||
SearchList.deleteBufferAndSearchList
|
||||
(lineStart, deleteLength, buffer, searchList, dfa)
|
||||
|
||||
(* get next line to dedent *)
|
||||
val buffer = LineGap.goToIdx (lineStart, buffer)
|
||||
val lineEnd = Cursor.viDlr (buffer, lineStart, 1)
|
||||
val buffer = LineGap.goToIdx (lineEnd, buffer)
|
||||
val nextLine = Cursor.viL (buffer, lineEnd, 1)
|
||||
|
||||
val count = if lineEnd = nextLine then 0 else count - 1
|
||||
in
|
||||
loop (nextLine, buffer, searchList, dfa, count)
|
||||
end
|
||||
in
|
||||
fun dedentLine (app: app_type, count, time) =
|
||||
let
|
||||
open MailboxType
|
||||
|
||||
val {cursorIdx, buffer, searchList, dfa, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
val lineStart = Cursor.vi0 (buffer, cursorIdx)
|
||||
val firstNonSpaceChr = Cursor.firstNonSpaceChr (buffer, lineStart)
|
||||
|
||||
(* calculate length to delete *)
|
||||
val difference = firstNonSpaceChr - lineStart
|
||||
val deleteLength = Int.min (difference, 2)
|
||||
|
||||
(* delete once *)
|
||||
val (buffer, searchList) =
|
||||
if deleteLength = 0 then
|
||||
(buffer, searchList)
|
||||
else
|
||||
SearchList.deleteBufferAndSearchList
|
||||
(lineStart, deleteLength, buffer, searchList, dfa)
|
||||
|
||||
(* Calculate nextLine and newCursorIdx.
|
||||
* The cursorIdx might be past the current line after we dedent.
|
||||
* If it is, we put the cursorIdx at the last char of the line. *)
|
||||
val buffer = LineGap.goToIdx (lineStart, buffer)
|
||||
val lineEnd = Cursor.viDlr (buffer, lineStart, 1)
|
||||
val buffer = LineGap.goToIdx (lineEnd, buffer)
|
||||
val nextLine = Cursor.viL (buffer, lineEnd, 1)
|
||||
val newCursorIdx = Int.min (lineEnd, cursorIdx)
|
||||
|
||||
val (buffer, searchList) =
|
||||
if lineEnd = nextLine then
|
||||
(* at end of file, so we cannot dedent anymore *)
|
||||
(buffer, searchList)
|
||||
else
|
||||
(* dedent remaining lines specified by count *)
|
||||
loop (nextLine, buffer, searchList, dfa, count - 1)
|
||||
|
||||
val buffer = LineGap.goToStart buffer
|
||||
in
|
||||
NormalDelete.finishAfterDeletingBuffer
|
||||
(app, newCursorIdx, buffer, searchList, time, [])
|
||||
end
|
||||
end
|
||||
|
||||
fun parseGo (count, app, chrCmd) =
|
||||
case chrCmd of
|
||||
#"e" => MoveToEndOfPrevWord.move (app, count)
|
||||
| #"E" => MoveToEndOfPrevWORD.move (app, count)
|
||||
| #"g" => NormalMove.moveToStart app
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseChr (app: app_type, count, chr, str, time) =
|
||||
case chr of
|
||||
#"h" => MoveViH.move (app, count)
|
||||
| #"j" => NormalMove.moveCursorDown (app, count)
|
||||
| #"k" => NormalMove.moveCursorUp (app, count)
|
||||
| #"l" => MoveViL.move (app, count)
|
||||
| #"w" => MoveToNextWord.move (app, count)
|
||||
| #"W" => MoveToNextWORD.move (app, count)
|
||||
| #"b" => MoveToPrevWord.move (app, count)
|
||||
| #"B" => MoveToPrevWORD.move (app, count)
|
||||
| #"e" => MoveToEndOfWord.move (app, count)
|
||||
| #"E" => MoveToEndOfWORD.move (app, count)
|
||||
| #"n" => NormalMove.moveToNextMatch (app, count)
|
||||
| #"N" => NormalMove.moveToPrevMatch (app, count)
|
||||
| #"z" => NormalFinish.centreToCursor app
|
||||
(* can only move to start or end of line once
|
||||
* so hardcode count as 1 *)
|
||||
| #"0" =>
|
||||
(* 0 is a bit of a special case.
|
||||
* If 0 is pressed without any preceding characters,
|
||||
* then it should move cursor to the start of the line.
|
||||
* However, if a number was pressed previously before 0 was,
|
||||
* then this means user is entering a count.
|
||||
* In that case, we append 0 to the string. *)
|
||||
if String.size str > 0 then
|
||||
let
|
||||
val lastChr = String.sub (str, String.size str - 1)
|
||||
in
|
||||
if Char.isDigit lastChr then
|
||||
let
|
||||
val chr = Char.toString chr
|
||||
val str = str ^ chr
|
||||
val mode = NORMAL_MODE str
|
||||
in
|
||||
NormalModeWith.mode (app, mode, [])
|
||||
end
|
||||
else
|
||||
MoveToStartOfLine.move (app, 1)
|
||||
end
|
||||
else
|
||||
MoveToStartOfLine.move (app, 1)
|
||||
| #"$" => MoveToEndOfLine.move (app, 1)
|
||||
| #"^" => NormalMove.firstNonSpaceChr app
|
||||
| #"G" =>
|
||||
(* if str has a size larger than 0,
|
||||
* interpret as "go to line" command;
|
||||
* else, interpret as a command to move to end *)
|
||||
if String.size str = 0 then NormalMove.moveToEnd app
|
||||
else NormalMove.moveToLine (app, count)
|
||||
| #"%" => NormalMove.moveToMatchingPair app
|
||||
| #"D" => NormalDelete.deleteToEndOfLine (app, time)
|
||||
| #"x" => NormalDelete.removeChr (app, count, time)
|
||||
| #"J" => NormalDelete.removeLineBreaks (app, count, time)
|
||||
| #"/" => switchToNormalSearchMode (app, false)
|
||||
| #"?" => switchToNormalSearchMode (app, true)
|
||||
| #">" => indnetLine (app, count, time)
|
||||
| #"<" => dedentLine (app, count, time)
|
||||
(* multi-char commands which can be appended *)
|
||||
| #"t" => appendChr (app, chr, str)
|
||||
| #"T" => appendChr (app, chr, str)
|
||||
| #"y" => appendChr (app, chr, str)
|
||||
| #"d" => appendChr (app, chr, str)
|
||||
| #"f" => appendChr (app, chr, str)
|
||||
| #"F" => appendChr (app, chr, str)
|
||||
| #"g" => appendChr (app, chr, str)
|
||||
| #"c" => appendChr (app, chr, str)
|
||||
| _ =>
|
||||
(* user may be entering a cmd with more than one chr
|
||||
* such as "2dw" to delete two word
|
||||
* so add current chr to mode, and save it in the app state *)
|
||||
let
|
||||
val str = if Char.isDigit chr then str ^ Char.toString chr else ""
|
||||
val mode = NORMAL_MODE str
|
||||
in
|
||||
NormalModeWith.mode (app, mode, [])
|
||||
end
|
||||
|
||||
structure ParseDelete =
|
||||
struct
|
||||
fun parseDeleteInside (app, chr, time) =
|
||||
case chr of
|
||||
#"w" => NormalDelete.deleteInsideWord (app, time)
|
||||
| #"W" => NormalDelete.deleteInsideWORD (app, time)
|
||||
|
||||
| #"(" => NormalDelete.deleteInsidePair (app, #"(", #")", time)
|
||||
| #")" => NormalDelete.deleteInsidePair (app, #"(", #")", time)
|
||||
|
||||
| #"[" => NormalDelete.deleteInsidePair (app, #"[", #"]", time)
|
||||
| #"]" => NormalDelete.deleteInsidePair (app, #"[", #"]", time)
|
||||
|
||||
| #"{" => NormalDelete.deleteInsidePair (app, #"{", #"}", time)
|
||||
| #"}" => NormalDelete.deleteInsidePair (app, #"{", #"}", time)
|
||||
|
||||
| #"<" => NormalDelete.deleteInsidePair (app, #"<", #">", time)
|
||||
| #">" => NormalDelete.deleteInsidePair (app, #"<", #">", time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDeleteAround (app, chr, time) =
|
||||
case chr of
|
||||
#"w" => NormalDelete.deleteAroundWord (app, time)
|
||||
| #"W" => NormalDelete.deleteAroundWORD (app, time)
|
||||
|
||||
|
||||
| #"(" => NormalDelete.deleteAroundPair (app, #"(", #")", time)
|
||||
| #")" => NormalDelete.deleteAroundPair (app, #"(", #")", time)
|
||||
|
||||
| #"[" => NormalDelete.deleteAroundPair (app, #"[", #"]", time)
|
||||
| #"]" => NormalDelete.deleteAroundPair (app, #"[", #"]", time)
|
||||
|
||||
| #"{" => NormalDelete.deleteAroundPair (app, #"{", #"}", time)
|
||||
| #"}" => NormalDelete.deleteAroundPair (app, #"{", #"}", time)
|
||||
|
||||
| #"<" => NormalDelete.deleteAroundPair (app, #"<", #">", time)
|
||||
| #">" => NormalDelete.deleteAroundPair (app, #"<", #">", time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDeleteTerminal (str, count, app, chrCmd, time) =
|
||||
case chrCmd of
|
||||
(* terminal commands: require no input after *)
|
||||
#"h" => NormalDelete.deleteCharsLeft (app, count, time)
|
||||
| #"l" => NormalDelete.removeChr (app, count, time)
|
||||
(* vi's 'j' and 'k' commands move up or down a column
|
||||
* but 'dj' or 'dk' delete whole lines
|
||||
* so their implementation differs from
|
||||
* other cursor motions *)
|
||||
| #"j" => NormalDelete.deleteLineDown (app, count, time)
|
||||
| #"k" => NormalDelete.deleteLineUp (app, count, time)
|
||||
| #"w" => NormalDelete.deleteWord (app, count, time)
|
||||
| #"W" => NormalDelete.deleteWORD (app, count, time)
|
||||
| #"b" => NormalDelete.deleteByDfa (app, count, Cursor.prevWord, time)
|
||||
| #"B" => NormalDelete.deleteByDfa (app, count, Cursor.prevWORD, time)
|
||||
| #"e" =>
|
||||
NormalDelete.deleteByDfa (app, count, Cursor.endOfWordForDelete, time)
|
||||
| #"E" =>
|
||||
NormalDelete.deleteByDfa (app, count, Cursor.endOfWORDForDelete, time)
|
||||
| #"0" => NormalDelete.delete (app, 1, Cursor.vi0, time)
|
||||
| #"$" => NormalDelete.deleteToEndOfLine (app, time)
|
||||
| #"^" => NormalDelete.deleteToFirstNonSpaceChr (app, time)
|
||||
| #"d" => NormalDelete.deleteLine (app, count, time)
|
||||
| #"n" => NormalDelete.deleteToNextMatch (app, count, time)
|
||||
| #"N" => NormalDelete.deleteToPrevMatch (app, count, time)
|
||||
| #"%" => NormalDelete.deletePair (app, time)
|
||||
| #"G" => NormalDelete.deleteToEnd (app, time)
|
||||
(* non-terminal commands which require appending chr *)
|
||||
| #"t" => appendChr (app, chrCmd, str)
|
||||
| #"T" => appendChr (app, chrCmd, str)
|
||||
| #"f" => appendChr (app, chrCmd, str)
|
||||
| #"F" => appendChr (app, chrCmd, str)
|
||||
| #"g" => appendChr (app, chrCmd, str)
|
||||
| #"i" => appendChr (app, chrCmd, str)
|
||||
| #"a" => appendChr (app, chrCmd, str)
|
||||
(* invalid command: reset mode *)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDeleteGo (app, count, chrCmd, time) =
|
||||
case chrCmd of
|
||||
#"e" => NormalDelete.deleteToEndOfPrevWord (app, count, time)
|
||||
| #"E" => NormalDelete.deleteToEndOfPrevWORD (app, count, time)
|
||||
| #"g" => NormalDelete.deleteToStart (app, time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDelete (strPos, str, count, app, chrCmd, time) =
|
||||
if strPos = String.size str - 1 then
|
||||
parseDeleteTerminal (str, count, app, chrCmd, time)
|
||||
else
|
||||
(* have to continue parsing string *)
|
||||
case String.sub (str, strPos + 1) of
|
||||
#"t" => NormalDelete.deleteTillNextChr (app, count, chrCmd, time)
|
||||
| #"T" => NormalDelete.deleteTillPrevChr (app, count, chrCmd, time)
|
||||
| #"f" => NormalDelete.deleteToNextChr (app, count, chrCmd, time)
|
||||
| #"F" => NormalDelete.deleteToPrevChr (app, count, chrCmd, time)
|
||||
| #"g" => parseDeleteGo (app, count, chrCmd, time)
|
||||
| #"i" => parseDeleteInside (app, chrCmd, time)
|
||||
| #"a" => parseDeleteAround (app, chrCmd, time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
end
|
||||
|
||||
structure ParseYankDelete =
|
||||
struct
|
||||
fun parseDeleteInside (app, chr, time) =
|
||||
case chr of
|
||||
#"w" => NormalYankDelete.deleteInsideWord (app, time)
|
||||
| #"W" => NormalYankDelete.deleteInsideWORD (app, time)
|
||||
|
||||
| #"(" => NormalYankDelete.deleteInsidePair (app, #"(", #")", time)
|
||||
| #")" => NormalYankDelete.deleteInsidePair (app, #"(", #")", time)
|
||||
|
||||
| #"[" => NormalYankDelete.deleteInsidePair (app, #"[", #"]", time)
|
||||
| #"]" => NormalYankDelete.deleteInsidePair (app, #"[", #"]", time)
|
||||
|
||||
| #"{" => NormalYankDelete.deleteInsidePair (app, #"{", #"}", time)
|
||||
| #"}" => NormalYankDelete.deleteInsidePair (app, #"{", #"}", time)
|
||||
|
||||
| #"<" => NormalYankDelete.deleteInsidePair (app, #"<", #">", time)
|
||||
| #">" => NormalYankDelete.deleteInsidePair (app, #"<", #">", time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDeleteAround (app, chr, time) =
|
||||
case chr of
|
||||
#"w" => NormalYankDelete.deleteAroundWord (app, time)
|
||||
| #"W" => NormalYankDelete.deleteAroundWORD (app, time)
|
||||
|
||||
|
||||
| #"(" => NormalYankDelete.deleteAroundPair (app, #"(", #")", time)
|
||||
| #")" => NormalYankDelete.deleteAroundPair (app, #"(", #")", time)
|
||||
|
||||
| #"[" => NormalYankDelete.deleteAroundPair (app, #"[", #"]", time)
|
||||
| #"]" => NormalYankDelete.deleteAroundPair (app, #"[", #"]", time)
|
||||
|
||||
| #"{" => NormalYankDelete.deleteAroundPair (app, #"{", #"}", time)
|
||||
| #"}" => NormalYankDelete.deleteAroundPair (app, #"{", #"}", time)
|
||||
|
||||
| #"<" => NormalYankDelete.deleteAroundPair (app, #"<", #">", time)
|
||||
| #">" => NormalYankDelete.deleteAroundPair (app, #"<", #">", time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDeleteTerminal (str, count, app, chrCmd, time) =
|
||||
case chrCmd of
|
||||
(* terminal commands: require no input after *)
|
||||
#"h" => NormalYankDelete.deleteCharsLeft (app, count, time)
|
||||
| #"l" => NormalYankDelete.removeChr (app, count, time)
|
||||
(* vi's 'j' and 'k' commands move up or down a column
|
||||
* but 'dj' or 'dk' delete whole lines
|
||||
* so their implementation differs from
|
||||
* other cursor motions *)
|
||||
| #"j" => NormalYankDelete.deleteLineDown (app, count, time)
|
||||
| #"k" => NormalYankDelete.deleteLineUp (app, count, time)
|
||||
| #"w" => NormalYankDelete.deleteWord (app, count, time)
|
||||
| #"W" => NormalYankDelete.deleteWORD (app, count, time)
|
||||
| #"b" => NormalYankDelete.deleteByDfa (app, count, Cursor.prevWord, time)
|
||||
| #"B" => NormalYankDelete.deleteByDfa (app, count, Cursor.prevWORD, time)
|
||||
| #"e" =>
|
||||
NormalYankDelete.deleteByDfa
|
||||
(app, count, Cursor.endOfWordForDelete, time)
|
||||
| #"E" =>
|
||||
NormalYankDelete.deleteByDfa
|
||||
(app, count, Cursor.endOfWORDForDelete, time)
|
||||
| #"0" => NormalYankDelete.delete (app, 1, Cursor.vi0, time)
|
||||
| #"$" => NormalYankDelete.deleteToEndOfLine (app, time)
|
||||
| #"^" => NormalYankDelete.deleteToFirstNonSpaceChr (app, time)
|
||||
| #"d" => NormalYankDelete.deleteLine (app, count, time)
|
||||
| #"n" => NormalYankDelete.deleteToNextMatch (app, count, time)
|
||||
| #"N" => NormalYankDelete.deleteToPrevMatch (app, count, time)
|
||||
| #"%" => NormalYankDelete.deletePair (app, time)
|
||||
| #"G" => NormalYankDelete.deleteToEnd (app, time)
|
||||
(* non-terminal commands which require appending chr *)
|
||||
| #"t" => appendChr (app, chrCmd, str)
|
||||
| #"T" => appendChr (app, chrCmd, str)
|
||||
| #"f" => appendChr (app, chrCmd, str)
|
||||
| #"F" => appendChr (app, chrCmd, str)
|
||||
| #"g" => appendChr (app, chrCmd, str)
|
||||
| #"i" => appendChr (app, chrCmd, str)
|
||||
| #"a" => appendChr (app, chrCmd, str)
|
||||
(* invalid command: reset mode *)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDeleteGo (app, count, chrCmd, time) =
|
||||
case chrCmd of
|
||||
#"e" => NormalYankDelete.deleteToEndOfPrevWord (app, count, time)
|
||||
| #"E" => NormalYankDelete.deleteToEndOfPrevWORD (app, count, time)
|
||||
| #"g" => NormalYankDelete.deleteToStart (app, time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseDelete (strPos, str, count, app, chrCmd, time) =
|
||||
if strPos = String.size str - 1 then
|
||||
parseDeleteTerminal (str, count, app, chrCmd, time)
|
||||
else
|
||||
(* have to continue parsing string *)
|
||||
case String.sub (str, strPos + 1) of
|
||||
#"t" => NormalYankDelete.deleteTillNextChr (app, count, chrCmd, time)
|
||||
| #"T" => NormalYankDelete.deleteTillPrevChr (app, count, chrCmd, time)
|
||||
| #"f" => NormalYankDelete.deleteToNextChr (app, count, chrCmd, time)
|
||||
| #"F" => NormalYankDelete.deleteToPrevChr (app, count, chrCmd, time)
|
||||
| #"g" => parseDeleteGo (app, count, chrCmd, time)
|
||||
| #"i" => parseDeleteInside (app, chrCmd, time)
|
||||
| #"a" => parseDeleteAround (app, chrCmd, time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
end
|
||||
|
||||
structure ParseYank =
|
||||
struct
|
||||
fun yankWhenMovingBack (app: app_type, fMove, count) =
|
||||
let
|
||||
open DrawMsg
|
||||
open MailboxType
|
||||
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val low = fMove (buffer, cursorIdx, count)
|
||||
|
||||
val length = cursorIdx - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
|
||||
val msg = YANK str
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.modeAndBuffer (app, buffer, mode, [DRAW msg])
|
||||
end
|
||||
|
||||
fun yankWhenMovingForward (app: app_type, fMove, count) =
|
||||
let
|
||||
open DrawMsg
|
||||
open MailboxType
|
||||
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val high = fMove (buffer, cursorIdx, count)
|
||||
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val length = high - cursorIdx
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
|
||||
val msg = YANK str
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.modeAndBuffer (app, buffer, mode, [DRAW msg])
|
||||
end
|
||||
|
||||
fun parseYankTerminal (str, count, app, chrCmd, time) =
|
||||
case chrCmd of
|
||||
#"h" => NormalYank.yankLeft (app, count)
|
||||
| #"k" => NormalYank.yankLineUp (app, count)
|
||||
| #"j" => NormalYank.yankLineDown (app, count)
|
||||
| #"l" => NormalYank.yankRight (app, count)
|
||||
| #"y" => NormalYank.yankLine (app, count)
|
||||
| #"0" => NormalYank.yankToStartOfLine app
|
||||
| #"w" => NormalYank.yankWhenMovingForward (app, Cursor.nextWord, count)
|
||||
| #"W" => NormalYank.yankWhenMovingForward (app, Cursor.nextWORD, count)
|
||||
| #"b" => NormalYank.yankWhenMovingBack (app, Cursor.prevWord, count)
|
||||
| #"B" => NormalYank.yankWhenMovingBack (app, Cursor.prevWORD, count)
|
||||
| #"e" =>
|
||||
NormalYank.yankWhenMovingForward
|
||||
(app, Cursor.endOfWordForDelete, count)
|
||||
| #"E" =>
|
||||
NormalYank.yankWhenMovingForward
|
||||
(app, Cursor.endOfWORDForDelete, count)
|
||||
| #"$" => NormalYank.yankWhenMovingForward (app, Cursor.viDlr, 1)
|
||||
| #"^" => NormalYank.yankToFirstNonSpaceChr app
|
||||
| #"G" => NormalYank.yankToEndOfText app
|
||||
| #"%" => NormalYank.yankToMatchingPair app
|
||||
| #"n" => NormalYank.yankToNextMatch (app, count)
|
||||
| #"N" => NormalYank.yankToPrevMatch (app, count)
|
||||
| #"x" => NormalYankDelete.removeChr (app, count, time)
|
||||
(* append non-terminal characters to string *)
|
||||
| #"d" =>
|
||||
let (* 'yd' motion, like 'ydw'; meant to be 'yank then delete' *)
|
||||
in appendChr (app, chrCmd, str)
|
||||
end
|
||||
| #"t" => appendChr (app, chrCmd, str)
|
||||
| #"T" => appendChr (app, chrCmd, str)
|
||||
| #"f" => appendChr (app, chrCmd, str)
|
||||
| #"F" => appendChr (app, chrCmd, str)
|
||||
| #"g" => appendChr (app, chrCmd, str)
|
||||
| #"i" => appendChr (app, chrCmd, str)
|
||||
| #"a" => appendChr (app, chrCmd, str)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseYankGo (count, app, chrCmd) =
|
||||
case chrCmd of
|
||||
#"e" =>
|
||||
NormalYank.yankWhenMovingBackPlusOne
|
||||
(app, Cursor.endOfPrevWord, count)
|
||||
| #"E" =>
|
||||
NormalYank.yankWhenMovingBackPlusOne
|
||||
(app, Cursor.endOfPrevWORD, count)
|
||||
| #"g" => NormalYank.yankToStart app
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseYankInside (app, chr) =
|
||||
case chr of
|
||||
#"w" => NormalYank.yankInsideWord app
|
||||
| #"W" => NormalYank.yankInsideWORD app
|
||||
| #"(" => NormalYank.yankInsideChrOpen (app, chr)
|
||||
| #"[" => NormalYank.yankInsideChrOpen (app, chr)
|
||||
| #"{" => NormalYank.yankInsideChrOpen (app, chr)
|
||||
| #"<" => NormalYank.yankInsideChrOpen (app, chr)
|
||||
| #")" => NormalYank.yankInsideChrClose (app, chr)
|
||||
| #"]" => NormalYank.yankInsideChrClose (app, chr)
|
||||
| #"}" => NormalYank.yankInsideChrClose (app, chr)
|
||||
| #">" => NormalYank.yankInsideChrClose (app, chr)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseYankAround (app, chr) =
|
||||
case chr of
|
||||
#"(" => NormalYank.yankAroundChrOpen (app, chr)
|
||||
| #"[" => NormalYank.yankAroundChrOpen (app, chr)
|
||||
| #"{" => NormalYank.yankAroundChrOpen (app, chr)
|
||||
| #"<" => NormalYank.yankAroundChrOpen (app, chr)
|
||||
| #")" => NormalYank.yankAroundChrClose (app, chr)
|
||||
| #"]" => NormalYank.yankAroundChrClose (app, chr)
|
||||
| #"}" => NormalYank.yankAroundChrClose (app, chr)
|
||||
| #">" => NormalYank.yankAroundChrClose (app, chr)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parseYank (strPos, str, count, app, chrCmd, time) =
|
||||
if strPos = String.size str - 1 then
|
||||
parseYankTerminal (str, count, app, chrCmd, time)
|
||||
else
|
||||
case String.sub (str, strPos + 1) of
|
||||
#"t" => NormalYank.yankTillNextChr (app, count, chrCmd)
|
||||
| #"T" => NormalYank.yankTillPrevChr (app, count, chrCmd)
|
||||
| #"f" => NormalYank.yankToNextChr (app, count, chrCmd)
|
||||
| #"F" => NormalYank.yankToPrevChr (app, count, chrCmd)
|
||||
| #"g" => parseYankGo (count, app, chrCmd)
|
||||
| #"i" => parseYankInside (app, chrCmd)
|
||||
| #"a" => parseYankAround (app, chrCmd)
|
||||
| #"d" =>
|
||||
ParseYankDelete.parseDelete
|
||||
(strPos + 1, str, count, app, chrCmd, time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
end
|
||||
|
||||
(* useful reference as list of non-terminal commands *)
|
||||
fun parseAfterCount (strPos, str, count, app, chrCmd, time) =
|
||||
(* we are trying to parse multi-char but non-terminal strings here.
|
||||
* For example, we don't want to parse 3w which is a terminal commmand
|
||||
* to go 3 words forwards
|
||||
* but we do want to parse 3d which is a non-terminal command
|
||||
* which can be made terminal by adding "w" or "e" at the end.
|
||||
* *)
|
||||
case String.sub (str, strPos) of
|
||||
#"t" => NormalMove.tillNextChr (app, count, chrCmd)
|
||||
| #"T" => NormalMove.tillPrevChr (app, count, chrCmd)
|
||||
| #"y" => ParseYank.parseYank (strPos, str, count, app, chrCmd, time)
|
||||
| #"d" => ParseDelete.parseDelete (strPos, str, count, app, chrCmd, time)
|
||||
| #"f" => NormalMove.toNextChr (app, count, chrCmd)
|
||||
| #"F" => NormalMove.toPrevChr (app, count, chrCmd)
|
||||
| #"g" => (* go *) parseGo (count, app, chrCmd)
|
||||
| #"c" => (* change *) NormalFinish.clearMode app
|
||||
| _ =>
|
||||
(* isn't a non-terminal cmd
|
||||
* this case should never happen*)
|
||||
NormalFinish.clearMode app
|
||||
|
||||
fun parseNormalModeCommand (app, str, chrCmd, time) =
|
||||
if String.size str = 0 then
|
||||
parseChr (app, 1, chrCmd, str, time)
|
||||
else if String.size str = 1 then
|
||||
case Int.fromString str of
|
||||
SOME count => parseChr (app, count, chrCmd, str, time)
|
||||
| NONE => parseAfterCount (0, str, 1, app, chrCmd, time)
|
||||
else
|
||||
let
|
||||
val numLength = getNumLength (0, str)
|
||||
val count = String.substring (str, 0, numLength)
|
||||
val count =
|
||||
case Int.fromString count of
|
||||
SOME x => x
|
||||
| NONE => 1
|
||||
in
|
||||
if numLength = String.size str then
|
||||
(* reached end of str; str only contained numbers *)
|
||||
parseChr (app, count, chrCmd, str, time)
|
||||
else
|
||||
(* continue parsing. *)
|
||||
parseAfterCount (numLength, str, count, app, chrCmd, time)
|
||||
end
|
||||
|
||||
structure LeftArrow =
|
||||
struct
|
||||
fun parseLeftArrowCommand (strPos, str, count, app, time) =
|
||||
case String.sub (str, strPos) of
|
||||
#"y" =>
|
||||
if strPos + 1 = String.size str then
|
||||
(* terminal command, so simple yank *)
|
||||
raise Fail "left-arrow-yank unimplemnted"
|
||||
else
|
||||
(case String.sub (str, strPos + 1) of
|
||||
#"d" => NormalYankDelete.deleteCharsLeft (app, count, time)
|
||||
| _ => NormalFinish.clearMode app)
|
||||
| #"d" => NormalDelete.deleteCharsLeft (app, count, time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parse (app, str, time) =
|
||||
if String.size str = 0 then
|
||||
MoveViH.move (app, 1)
|
||||
else if String.size str = 1 then
|
||||
case Int.fromString str of
|
||||
SOME count => MoveViH.move (app, count)
|
||||
| NONE => parseLeftArrowCommand (0, str, 1, app, time)
|
||||
else
|
||||
let
|
||||
val numLength = getNumLength (0, str)
|
||||
val count = String.substring (str, 0, numLength)
|
||||
val count =
|
||||
case Int.fromString count of
|
||||
SOME x => x
|
||||
| NONE => 1
|
||||
in
|
||||
if numLength = String.size str then
|
||||
(* reached end of string; string only contained numbers *)
|
||||
MoveViH.move (app, count)
|
||||
else
|
||||
parseLeftArrowCommand (numLength, str, count, app, time)
|
||||
end
|
||||
end
|
||||
|
||||
structure RightArrow =
|
||||
struct
|
||||
fun parseRightArrowCommand (strPos, str, count, app, time) =
|
||||
case String.sub (str, strPos) of
|
||||
#"y" =>
|
||||
if strPos + 1 = String.size str then
|
||||
raise Fail "right-arrow-yank unimplemnted"
|
||||
else
|
||||
(case String.sub (str, strPos + 1) of
|
||||
#"d" => NormalYankDelete.removeChr (app, count, time)
|
||||
| _ => NormalFinish.clearMode app)
|
||||
| #"d" => NormalDelete.removeChr (app, count, time)
|
||||
| _ => NormalFinish.clearMode app
|
||||
|
||||
fun parse (app, str, time) =
|
||||
if String.size str = 0 then
|
||||
MoveViL.move (app, 1)
|
||||
else if String.size str = 1 then
|
||||
case Int.fromString str of
|
||||
SOME count => MoveViL.move (app, count)
|
||||
| NONE => parseRightArrowCommand (0, str, 1, app, time)
|
||||
else
|
||||
let
|
||||
val numLength = getNumLength (0, str)
|
||||
val count = String.substring (str, 0, numLength)
|
||||
val count =
|
||||
case Int.fromString count of
|
||||
SOME x => x
|
||||
| NONE => 1
|
||||
in
|
||||
if numLength = String.size str then
|
||||
(* reached end of string; string only contained numbers *)
|
||||
MoveViH.move (app, count)
|
||||
else
|
||||
parseRightArrowCommand (numLength, str, count, app, time)
|
||||
end
|
||||
end
|
||||
|
||||
fun update (app, str, msg, time) =
|
||||
case msg of
|
||||
CHAR_EVENT chrCmd => parseNormalModeCommand (app, str, chrCmd, time)
|
||||
| KEY_ESC => NormalFinish.clearMode app
|
||||
| RESIZE_EVENT (width, height) =>
|
||||
NormalFinish.resizeText (app, width, height)
|
||||
|
||||
| ARROW_RIGHT => RightArrow.parse (app, str, time)
|
||||
| ARROW_LEFT => LeftArrow.parse (app, str, time)
|
||||
| ARROW_UP => NormalFinish.clearMode app
|
||||
| ARROW_DOWN => NormalFinish.clearMode app
|
||||
|
||||
| KEY_ENTER => NormalFinish.clearMode app
|
||||
| KEY_BACKSPACE => NormalFinish.clearMode app
|
||||
end
|
||||
586
shf/fcore/normal-mode/normal-move.sml
Normal file
586
shf/fcore/normal-mode/normal-move.sml
Normal file
@@ -0,0 +1,586 @@
|
||||
structure NormalMove =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
fun moveToStart (app: app_type) : AppType.app_type =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
|
||||
val cursorIdx = 0
|
||||
val startLine = 0
|
||||
val buffer = LineGap.goToStart buffer
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val drawMsg = [MailboxType.DRAW drawMsg]
|
||||
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.bufferAndCursorIdx
|
||||
( app
|
||||
, buffer
|
||||
, cursorIdx
|
||||
, mode
|
||||
, startLine
|
||||
, searchList
|
||||
, drawMsg
|
||||
, bufferModifyTime
|
||||
, 0
|
||||
)
|
||||
end
|
||||
|
||||
fun moveToEnd (app: app_type) =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn = prevScrollColumn
|
||||
, startLine = prevLineNumber
|
||||
, ...
|
||||
} = app
|
||||
|
||||
val buffer = LineGap.goToEnd buffer
|
||||
val {line = bufferLine, textLength, ...} = buffer
|
||||
|
||||
val bufferIdx = Int.max (0, textLength - 1)
|
||||
val bufferLine = bufferLine - 1
|
||||
|
||||
val buffer = LineGap.goToIdx (bufferIdx, buffer)
|
||||
val bufferIdx =
|
||||
if Cursor.isOnNewlineAfterChr (buffer, bufferIdx) then
|
||||
Int.max (0, bufferIdx - 1)
|
||||
else
|
||||
bufferIdx
|
||||
|
||||
val buffer = LineGap.goToIdx (bufferIdx, buffer)
|
||||
val visualScrollColumn =
|
||||
TextScroll.getScrollColumn
|
||||
(buffer, bufferIdx, windowWidth, prevScrollColumn)
|
||||
|
||||
val bufferLine =
|
||||
TextScroll.getStartLine
|
||||
(prevLineNumber, bufferLine, windowHeight, #lineLength buffer)
|
||||
val buffer = LineGap.goToLine (bufferLine, buffer)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( bufferLine
|
||||
, bufferIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val drawMsg = [MailboxType.DRAW drawMsg]
|
||||
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.bufferAndCursorIdx
|
||||
( app
|
||||
, buffer
|
||||
, bufferIdx
|
||||
, mode
|
||||
, bufferLine
|
||||
, searchList
|
||||
, drawMsg
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
)
|
||||
end
|
||||
|
||||
fun finishMoveCursorUpDown
|
||||
(app: app_type, newCursorLineNumber, buffer, column, lineIdx) =
|
||||
let
|
||||
val
|
||||
{ windowWidth
|
||||
, windowHeight
|
||||
, visualScrollColumn = prevScrollColumn
|
||||
, startLine = prevLineNumber
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, ...
|
||||
} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (lineIdx, buffer)
|
||||
val endOfLineIdx = Cursor.viDlr (buffer, lineIdx, 1)
|
||||
val endOfLineIdx =
|
||||
if endOfLineIdx >= #textLength buffer - 1 then
|
||||
Int.max (0, #textLength buffer - 1)
|
||||
else
|
||||
endOfLineIdx
|
||||
|
||||
val cursorIdx = Int.min (endOfLineIdx, lineIdx + column)
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
(* create draw message *)
|
||||
val visualScrollColumn =
|
||||
TextScroll.getScrollColumn
|
||||
(buffer, cursorIdx, windowWidth, prevScrollColumn)
|
||||
|
||||
val startLine =
|
||||
TextScroll.getStartLine
|
||||
( prevLineNumber
|
||||
, newCursorLineNumber
|
||||
, windowHeight
|
||||
, #lineLength buffer
|
||||
)
|
||||
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val drawMsg = [MailboxType.DRAW drawMsg]
|
||||
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.bufferAndCursorIdx
|
||||
( app
|
||||
, buffer
|
||||
, cursorIdx
|
||||
, mode
|
||||
, startLine
|
||||
, searchList
|
||||
, drawMsg
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
)
|
||||
end
|
||||
|
||||
fun moveCursorUp (app: app_type, count) =
|
||||
let
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val startOfLine = Cursor.vi0 (buffer, cursorIdx)
|
||||
in
|
||||
if Cursor.isCursorAtStartOfLine (buffer, cursorIdx) then
|
||||
let
|
||||
val cursorLineNumber = LineGap.idxToLineNumber (cursorIdx + 1, buffer)
|
||||
val newCursorLineNumber = Int.max (0, cursorLineNumber - count)
|
||||
val buffer = LineGap.goToLine (newCursorLineNumber, buffer)
|
||||
val lineIdx = LineGap.lineNumberToIdx (newCursorLineNumber, buffer)
|
||||
|
||||
val lineIdx =
|
||||
if Cursor.isPrevChrStartOfLine (buffer, lineIdx) then lineIdx
|
||||
else lineIdx - 1
|
||||
|
||||
val buffer = LineGap.goToIdx (lineIdx, buffer)
|
||||
val lineIdx = Cursor.vi0 (buffer, lineIdx)
|
||||
|
||||
val lineIdx = Int.max (0, lineIdx)
|
||||
in
|
||||
finishMoveCursorUpDown (app, newCursorLineNumber, buffer, 0, lineIdx)
|
||||
end
|
||||
else
|
||||
let
|
||||
val cursorLineNumber = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val newCursorLineNumber = Int.max (cursorLineNumber - count, 0)
|
||||
|
||||
val buffer = LineGap.goToLine (newCursorLineNumber, buffer)
|
||||
val lineIdx =
|
||||
LineGap.lineNumberToIdx (newCursorLineNumber, buffer) + 1
|
||||
|
||||
val column = cursorIdx - startOfLine
|
||||
val column = if newCursorLineNumber = 0 then column - 1 else column
|
||||
in
|
||||
finishMoveCursorUpDown
|
||||
(app, newCursorLineNumber, buffer, column, lineIdx)
|
||||
end
|
||||
end
|
||||
|
||||
fun moveCursorDown (app: app_type, count) =
|
||||
let
|
||||
val
|
||||
{ windowWidth
|
||||
, windowHeight
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, startLine = prevLineNumber
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn = prevScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
|
||||
(* calculate new idx to move to *)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val startOfLine = Cursor.vi0 (buffer, cursorIdx)
|
||||
val column = cursorIdx - startOfLine
|
||||
in
|
||||
if Cursor.isCursorAtStartOfLine (buffer, cursorIdx) then
|
||||
let
|
||||
val cursorLineNumber = LineGap.idxToLineNumber (cursorIdx + 1, buffer)
|
||||
val newCursorLineNumber = cursorLineNumber + count
|
||||
|
||||
val buffer = LineGap.goToLine (newCursorLineNumber, buffer)
|
||||
val lineIdx = LineGap.lineNumberToIdx (newCursorLineNumber, buffer)
|
||||
|
||||
val lineIdx =
|
||||
if Cursor.isPrevChrStartOfLine (buffer, lineIdx) then lineIdx
|
||||
else lineIdx - 1
|
||||
val buffer = LineGap.goToIdx (lineIdx, buffer)
|
||||
val lineIdx = Cursor.vi0 (buffer, lineIdx)
|
||||
|
||||
val lineIdx =
|
||||
if lineIdx >= #textLength buffer - 1 then
|
||||
Int.max (0, #textLength buffer - 1)
|
||||
else
|
||||
lineIdx
|
||||
in
|
||||
finishMoveCursorUpDown (app, newCursorLineNumber, buffer, 0, lineIdx)
|
||||
end
|
||||
else
|
||||
let
|
||||
val cursorLineNumber = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val newCursorLineNumber = cursorLineNumber + count
|
||||
|
||||
val buffer = LineGap.goToLine (newCursorLineNumber, buffer)
|
||||
val lineIdx = LineGap.lineNumberToIdx (newCursorLineNumber, buffer)
|
||||
val buffer = LineGap.goToIdx (lineIdx, buffer)
|
||||
in
|
||||
if lineIdx >= #textLength buffer - 1 then
|
||||
(* we reached last line *)
|
||||
let
|
||||
val lineIdx = Int.max (#textLength buffer - 1, 0)
|
||||
val buffer = LineGap.goToIdx (lineIdx, buffer)
|
||||
|
||||
val lineIdx =
|
||||
if Cursor.isOnNewlineAfterChr (buffer, lineIdx) then lineIdx - 1
|
||||
else lineIdx
|
||||
|
||||
val startOfLine = Cursor.vi0 (buffer, lineIdx)
|
||||
in
|
||||
if cursorIdx >= startOfLine then
|
||||
(* we are already on last line so don't move *)
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, cursorIdx, searchList, [], bufferModifyTime)
|
||||
else
|
||||
finishMoveCursorUpDown
|
||||
(app, newCursorLineNumber, buffer, column, startOfLine)
|
||||
end
|
||||
else
|
||||
let
|
||||
val lineIdx =
|
||||
if lineIdx >= #textLength buffer - 2 then
|
||||
Int.max (0, #textLength buffer - 2)
|
||||
else
|
||||
lineIdx
|
||||
|
||||
val buffer = LineGap.goToIdx (lineIdx, buffer)
|
||||
val lineIdx =
|
||||
if Cursor.isOnNewlineAfterChr (buffer, lineIdx) then lineIdx + 1
|
||||
else lineIdx
|
||||
in
|
||||
finishMoveCursorUpDown
|
||||
(app, newCursorLineNumber, buffer, column, lineIdx)
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
fun moveToLine (app: app_type, reqLine) =
|
||||
let
|
||||
val reqLine = reqLine - 1
|
||||
in
|
||||
if reqLine = 0 then
|
||||
moveToStart app
|
||||
else
|
||||
let
|
||||
val
|
||||
{ windowWidth
|
||||
, windowHeight
|
||||
, buffer
|
||||
, startLine = prevLineNumber
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn = prevScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
val buffer = LineGap.goToLine (reqLine, buffer)
|
||||
|
||||
(* get idx of first chr after linebreak *)
|
||||
val cursorIdx = LineGap.lineNumberToIdx (reqLine, buffer)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
(* we got the line start idx, but we want to move to the index
|
||||
* after it, where the first character of the line is.
|
||||
* Unless the next character is a line break,
|
||||
* in which case we want to stay at the current idx. *)
|
||||
val cursorIdx =
|
||||
if Cursor.isNextChrEndOfLine (buffer, cursorIdx) then cursorIdx
|
||||
else cursorIdx + 1
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
val visualScrollColumn =
|
||||
TextScroll.getScrollColumn
|
||||
(buffer, cursorIdx, windowWidth, prevScrollColumn)
|
||||
|
||||
val cursorLine = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val startLine =
|
||||
TextScroll.getStartLine
|
||||
(prevLineNumber, cursorLine, windowHeight, #lineLength buffer)
|
||||
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val drawMsg = [MailboxType.DRAW drawMsg]
|
||||
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.bufferAndCursorIdx
|
||||
( app
|
||||
, buffer
|
||||
, cursorIdx
|
||||
, mode
|
||||
, startLine
|
||||
, searchList
|
||||
, drawMsg
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
)
|
||||
end
|
||||
end
|
||||
|
||||
fun moveToMatchingPair (app: app_type) =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, cursorIdx
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine = prevLineNumber
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn = prevScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
|
||||
(* move LineGap and buffer to start of line *)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorIdx = Cursor.nextPairChr (buffer, cursorIdx)
|
||||
in
|
||||
if cursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorIdx = Cursor.matchPair (buffer, cursorIdx)
|
||||
in
|
||||
if cursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val visualScrollColumn =
|
||||
TextScroll.getScrollColumn
|
||||
(buffer, cursorIdx, windowWidth, prevScrollColumn)
|
||||
|
||||
val cursorLine = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val startLine =
|
||||
TextScroll.getStartLine
|
||||
(prevLineNumber, cursorLine, windowHeight, #lineLength buffer)
|
||||
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val drawMsg = [MailboxType.DRAW drawMsg]
|
||||
in
|
||||
NormalModeWith.bufferAndCursorIdx
|
||||
( app
|
||||
, buffer
|
||||
, cursorIdx
|
||||
, NORMAL_MODE ""
|
||||
, startLine
|
||||
, searchList
|
||||
, drawMsg
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
)
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
fun firstNonSpaceChr (app: app_type) =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, cursorIdx
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine
|
||||
, searchList
|
||||
, bufferModifyTime
|
||||
, ...
|
||||
} = app
|
||||
|
||||
(* move LineGap and buffer to start of line *)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorIdx = Cursor.vi0 (buffer, cursorIdx)
|
||||
|
||||
(* move cursorIdx to first character on line *)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorIdx = Cursor.firstNonSpaceChr (buffer, cursorIdx)
|
||||
in
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, cursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
fun helpMoveToChr (app: app_type, buffer, cursorIdx, count, fMove, chr) =
|
||||
if count = 0 then
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, cursorIdx, #searchList app, [], #bufferModifyTime app)
|
||||
else
|
||||
let
|
||||
(* move LineGap to cursorIdx, which is necessary for finding newCursorIdx *)
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx = fMove (buffer, cursorIdx, chr)
|
||||
val newCount = if cursorIdx = newCursorIdx then 0 else count - 1
|
||||
in
|
||||
helpMoveToChr (app, buffer, newCursorIdx, newCount, fMove, chr)
|
||||
end
|
||||
|
||||
fun moveToChr (app: app_type, count, fMove, chr) =
|
||||
let val {cursorIdx, buffer, ...} = app
|
||||
in helpMoveToChr (app, buffer, cursorIdx, count, fMove, chr)
|
||||
end
|
||||
|
||||
fun moveToNextMatch (app: app_type, count) =
|
||||
let
|
||||
val
|
||||
{ cursorIdx
|
||||
, searchList
|
||||
, buffer
|
||||
, bufferModifyTime
|
||||
, visualScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
val newCursorIdx =
|
||||
PersistentVector.nextMatch (cursorIdx, searchList, count)
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, newCursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
fun moveToPrevMatch (app: app_type, count) =
|
||||
let
|
||||
val {cursorIdx, searchList, buffer, bufferModifyTime, ...} = app
|
||||
val newCursorIdx =
|
||||
PersistentVector.prevMatch (cursorIdx, searchList, count)
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, newCursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
fun toNextChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, searchList, bufferModifyTime, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toNextChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, newCursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
fun tillNextChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, searchList, bufferModifyTime, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toNextChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, newCursorIdx - 1, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
fun toPrevChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, searchList, bufferModifyTime, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toPrevChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, newCursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
fun tillPrevChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, searchList, bufferModifyTime, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toPrevChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, newCursorIdx + 1, searchList, [], bufferModifyTime)
|
||||
end
|
||||
end
|
||||
156
shf/fcore/normal-mode/normal-search-finish.sml
Normal file
156
shf/fcore/normal-mode/normal-search-finish.sml
Normal file
@@ -0,0 +1,156 @@
|
||||
structure NormalSearchFinish =
|
||||
struct
|
||||
open AppType
|
||||
open DrawMsg
|
||||
|
||||
fun onSearchChanged
|
||||
( app: app_type
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
, buffer
|
||||
) =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, cursorIdx
|
||||
, startLine = prevLineNumber
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, visualScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
|
||||
val searchScrollColumn =
|
||||
TextScroll.getScrollColumnFromString
|
||||
(searchCursorIdx, windowWidth, searchScrollColumn)
|
||||
|
||||
val mode = NORMAL_SEARCH_MODE
|
||||
{ searchString = searchString
|
||||
, tempSearchList = tempSearchList
|
||||
, searchCursorIdx = searchCursorIdx
|
||||
, searchScrollColumn = searchScrollColumn
|
||||
, caseSensitive = caseSensitive
|
||||
}
|
||||
|
||||
val floatWindowWidth = Real32.fromInt windowWidth
|
||||
val floatWindowHeight = Real32.fromInt windowHeight
|
||||
|
||||
val searchStringPosY = windowHeight - TextConstants.ySpace - 5
|
||||
|
||||
val initialTextAcc = SearchBar.build
|
||||
( searchString
|
||||
, 5
|
||||
, searchStringPosY
|
||||
, windowWidth
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
)
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorLine = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val startLine =
|
||||
TextScroll.getStartLine
|
||||
(prevLineNumber, cursorLine, windowHeight, #lineLength buffer)
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
val remainingWindowHeight = windowHeight - (TextConstants.ySpace * 2)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.startBuild
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, remainingWindowHeight
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, tempSearchList
|
||||
, visualScrollColumn
|
||||
, initialTextAcc
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val msgs = [MailboxType.DRAW drawMsg]
|
||||
in
|
||||
NormalSearchModeWith.changeTempSearchString
|
||||
(app, buffer, startLine, mode, msgs)
|
||||
end
|
||||
|
||||
fun resize
|
||||
( app: app_type
|
||||
, newWindowWidth
|
||||
, newWindowHeight
|
||||
, searchString
|
||||
, searchCursorIdx
|
||||
, tempSearchList
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
) =
|
||||
let
|
||||
val
|
||||
{buffer, cursorIdx, startLine = prevLineNumber, visualScrollColumn, ...} =
|
||||
app
|
||||
|
||||
val floatWindowWidth = Real32.fromInt newWindowWidth
|
||||
val floatWindowHeight = Real32.fromInt newWindowHeight
|
||||
|
||||
val searchScrollColumn =
|
||||
TextScroll.getScrollColumnFromString
|
||||
(searchCursorIdx, newWindowWidth, searchScrollColumn)
|
||||
|
||||
val mode = NORMAL_SEARCH_MODE
|
||||
{ searchString = searchString
|
||||
, tempSearchList = tempSearchList
|
||||
, searchCursorIdx = searchCursorIdx
|
||||
, searchScrollColumn = searchScrollColumn
|
||||
, caseSensitive = caseSensitive
|
||||
}
|
||||
|
||||
val searchStringPosY = newWindowHeight - TextConstants.ySpace - 5
|
||||
|
||||
val initialTextAcc = SearchBar.build
|
||||
( searchString
|
||||
, 5
|
||||
, searchStringPosY
|
||||
, newWindowWidth
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
)
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val cursorLine = LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val startLine =
|
||||
TextScroll.getStartLine
|
||||
(prevLineNumber, cursorLine, newWindowHeight, #lineLength buffer)
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
val remainingWindowHeight = newWindowHeight - (TextConstants.ySpace * 2)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.startBuild
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, newWindowWidth
|
||||
, remainingWindowHeight
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, tempSearchList
|
||||
, visualScrollColumn
|
||||
, initialTextAcc
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val msgs = [MailboxType.DRAW drawMsg]
|
||||
in
|
||||
NormalSearchModeWith.bufferAndSize
|
||||
(app, mode, buffer, newWindowWidth, newWindowHeight, msgs)
|
||||
end
|
||||
end
|
||||
140
shf/fcore/normal-mode/normal-search-mode-with.sml
Normal file
140
shf/fcore/normal-mode/normal-search-mode-with.sml
Normal file
@@ -0,0 +1,140 @@
|
||||
structure NormalSearchModeWith =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
fun returnToNormalMode
|
||||
( app: app_type
|
||||
, newBuffer
|
||||
, newSearchList
|
||||
, newStartLine
|
||||
, newMode
|
||||
, newDfa
|
||||
, newMsgs
|
||||
) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, buffer = _
|
||||
, searchList = _
|
||||
, startLine = _
|
||||
, msgs = _
|
||||
, dfa = _
|
||||
, bufferModifyTime
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, cursorIdx
|
||||
, visualScrollColumn
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, buffer = newBuffer
|
||||
, searchList = newSearchList
|
||||
, startLine = newStartLine
|
||||
, dfa = newDfa
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, msgs = newMsgs
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, cursorIdx = cursorIdx
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
}
|
||||
end
|
||||
|
||||
fun changeTempSearchString
|
||||
(app: app_type, newBuffer, newStartLine, newMode, newMsgs) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, buffer = _
|
||||
, searchList
|
||||
, startLine = _
|
||||
, msgs = _
|
||||
, bufferModifyTime
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, cursorIdx
|
||||
, visualScrollColumn
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, buffer = newBuffer
|
||||
, startLine = newStartLine
|
||||
, msgs = newMsgs
|
||||
, searchList = searchList
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, cursorIdx = cursorIdx
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
|
||||
fun searchList (app: app_type, newSearchList) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, buffer
|
||||
, searchList = _
|
||||
, startLine
|
||||
, msgs
|
||||
, bufferModifyTime
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, cursorIdx
|
||||
, visualScrollColumn
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, searchList = newSearchList
|
||||
, buffer = buffer
|
||||
, startLine = startLine
|
||||
, msgs = msgs
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, cursorIdx = cursorIdx
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
|
||||
fun bufferAndSize
|
||||
( app: app_type
|
||||
, newMode
|
||||
, newBuffer
|
||||
, newWindowWidth
|
||||
, newWindowHeight
|
||||
, newMsgs
|
||||
) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, windowWidth = _
|
||||
, windowHeight = _
|
||||
, msgs = _
|
||||
, buffer = _
|
||||
, searchList
|
||||
, startLine
|
||||
, bufferModifyTime
|
||||
, cursorIdx
|
||||
, visualScrollColumn
|
||||
, dfa
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, buffer = newBuffer
|
||||
, windowWidth = newWindowWidth
|
||||
, windowHeight = newWindowHeight
|
||||
, msgs = newMsgs
|
||||
, searchList = searchList
|
||||
, startLine = startLine
|
||||
, bufferModifyTime = bufferModifyTime
|
||||
, cursorIdx = cursorIdx
|
||||
, visualScrollColumn = visualScrollColumn
|
||||
, dfa = dfa
|
||||
}
|
||||
end
|
||||
end
|
||||
274
shf/fcore/normal-mode/normal-search-mode.sml
Normal file
274
shf/fcore/normal-mode/normal-search-mode.sml
Normal file
@@ -0,0 +1,274 @@
|
||||
structure NormalSearchMode =
|
||||
struct
|
||||
open AppType
|
||||
open InputMsg
|
||||
open MailboxType
|
||||
|
||||
fun buildTempSearchList (searchString, buffer, cursorIdx, caseSensitive) =
|
||||
let
|
||||
val dfa =
|
||||
if caseSensitive then CaseSensitiveDfa.fromString searchString
|
||||
else CaseInsensitiveDfa.fromString searchString
|
||||
in
|
||||
SearchList.buildRange (buffer, cursorIdx + 1111, dfa)
|
||||
end
|
||||
|
||||
fun addChr
|
||||
( app: app_type
|
||||
, searchString
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
, chr
|
||||
) =
|
||||
let
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
|
||||
val c = String.implode [chr]
|
||||
val searchString =
|
||||
if searchCursorIdx = String.size searchString then
|
||||
searchString ^ c
|
||||
else
|
||||
let
|
||||
val sub1 = Substring.extract (searchString, 0, SOME searchCursorIdx)
|
||||
val sub2 = Substring.full c
|
||||
val sub3 = Substring.extract (searchString, searchCursorIdx, NONE)
|
||||
in
|
||||
Substring.concat [sub1, sub2, sub3]
|
||||
end
|
||||
val searchCursorIdx = searchCursorIdx + 1
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx - 1111, buffer)
|
||||
val (buffer, tempSearchList) =
|
||||
buildTempSearchList (searchString, buffer, cursorIdx, caseSensitive)
|
||||
in
|
||||
NormalSearchFinish.onSearchChanged
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
, buffer
|
||||
)
|
||||
end
|
||||
|
||||
(* return to normal mode, keeping the same searchString and searchList
|
||||
* from before entering this mode. *)
|
||||
fun exitToNormalMode (app: app_type) =
|
||||
let
|
||||
val {buffer, cursorIdx, searchList, bufferModifyTime, ...} = app
|
||||
in
|
||||
NormalFinish.buildTextAndClear
|
||||
(app, buffer, cursorIdx, searchList, [], bufferModifyTime)
|
||||
end
|
||||
|
||||
(* save search string and searchList and return to normal mode *)
|
||||
fun saveSearch (app: app_type, searchString, caseSensitive, time) =
|
||||
let
|
||||
val
|
||||
{ buffer
|
||||
, cursorIdx
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, startLine
|
||||
, visualScrollColumn
|
||||
, ...
|
||||
} = app
|
||||
|
||||
val dfa =
|
||||
if caseSensitive then CaseSensitiveDfa.fromString searchString
|
||||
else CaseInsensitiveDfa.fromString searchString
|
||||
|
||||
val buffer = LineGap.goToStart buffer
|
||||
val (buffer, searchList) = SearchList.build (buffer, dfa)
|
||||
|
||||
(* move LineGap to first line displayed on screen *)
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
(* move buffer to new startLine as required by TextBuilder.build *)
|
||||
val buffer = LineGap.goToLine (startLine, buffer)
|
||||
|
||||
val drawMsg = NormalModeTextBuilder.build
|
||||
( startLine
|
||||
, cursorIdx
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
)
|
||||
val drawMsg = Vector.concat drawMsg
|
||||
val drawMsg = DrawMsg.DRAW_TEXT drawMsg
|
||||
val msgs = [DRAW drawMsg]
|
||||
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalSearchModeWith.returnToNormalMode
|
||||
(app, buffer, searchList, startLine, mode, dfa, msgs)
|
||||
end
|
||||
|
||||
fun backspace
|
||||
( app: app_type
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchScrollColumn
|
||||
, searchCursorIdx
|
||||
, caseSensitive
|
||||
) =
|
||||
if searchCursorIdx = 0 then
|
||||
app
|
||||
else
|
||||
let
|
||||
val searchString =
|
||||
if searchCursorIdx = String.size searchString then
|
||||
String.substring (searchString, 0, String.size searchString - 1)
|
||||
else
|
||||
let
|
||||
val sub1 = Substring.extract
|
||||
(searchString, 0, SOME (searchCursorIdx - 1))
|
||||
val sub2 = Substring.extract (searchString, searchCursorIdx, SOME
|
||||
(String.size searchString - searchCursorIdx))
|
||||
in
|
||||
Substring.concat [sub1, sub2]
|
||||
end
|
||||
val searchCursorIdx = searchCursorIdx - 1
|
||||
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx - 1111, buffer)
|
||||
val (buffer, tempSearchList) =
|
||||
buildTempSearchList (searchString, buffer, cursorIdx, caseSensitive)
|
||||
in
|
||||
NormalSearchFinish.onSearchChanged
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
, buffer
|
||||
)
|
||||
end
|
||||
|
||||
fun moveLeft
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
) =
|
||||
if searchCursorIdx = 0 then
|
||||
app
|
||||
else
|
||||
let
|
||||
val searchCursorIdx = Int.max (0, searchCursorIdx - 1)
|
||||
in
|
||||
NormalSearchFinish.onSearchChanged
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
, #buffer app
|
||||
)
|
||||
end
|
||||
|
||||
fun moveRight
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
) =
|
||||
if searchCursorIdx = String.size searchString then
|
||||
app
|
||||
else
|
||||
let
|
||||
val searchCursorIdx =
|
||||
Int.min (searchCursorIdx + 1, String.size searchString)
|
||||
in
|
||||
NormalSearchFinish.onSearchChanged
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
, #buffer app
|
||||
)
|
||||
end
|
||||
|
||||
fun update
|
||||
( app
|
||||
, { searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
}
|
||||
, msg
|
||||
, time
|
||||
) =
|
||||
case msg of
|
||||
CHAR_EVENT chr =>
|
||||
addChr
|
||||
( app
|
||||
, searchString
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
, chr
|
||||
)
|
||||
| KEY_BACKSPACE =>
|
||||
backspace
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchScrollColumn
|
||||
, searchCursorIdx
|
||||
, caseSensitive
|
||||
)
|
||||
| KEY_ESC => exitToNormalMode app
|
||||
| KEY_ENTER => saveSearch (app, searchString, caseSensitive, time)
|
||||
| ARROW_LEFT =>
|
||||
moveLeft
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
)
|
||||
| ARROW_RIGHT =>
|
||||
moveRight
|
||||
( app
|
||||
, searchString
|
||||
, tempSearchList
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
)
|
||||
| RESIZE_EVENT (width, height) =>
|
||||
NormalSearchFinish.resize
|
||||
( app
|
||||
, width
|
||||
, height
|
||||
, searchString
|
||||
, searchCursorIdx
|
||||
, tempSearchList
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
)
|
||||
|
||||
(* In Vim's search mode, the up and down arrows can be used
|
||||
* to scroll through the search history.
|
||||
* I don't find this feature too useful as it is often easier to type
|
||||
* the whole search string again, so I'm leaving it unimplemented
|
||||
* until/unless I find that I wish this functionality was there
|
||||
* while using the program. *)
|
||||
| ARROW_UP => app
|
||||
| ARROW_DOWN => app
|
||||
end
|
||||
14
shf/fcore/normal-mode/normal-yank-delete.sml
Normal file
14
shf/fcore/normal-mode/normal-yank-delete.sml
Normal file
@@ -0,0 +1,14 @@
|
||||
structure NormalYankDelete =
|
||||
MakeNormalDelete
|
||||
(struct
|
||||
open DrawMsg
|
||||
open MailboxType
|
||||
|
||||
fun initMsgs (low, length, buffer) =
|
||||
let
|
||||
val str = LineGap.substring (low, length + 1, buffer)
|
||||
val msg = YANK str
|
||||
in
|
||||
[DRAW msg]
|
||||
end
|
||||
end)
|
||||
534
shf/fcore/normal-mode/normal-yank.sml
Normal file
534
shf/fcore/normal-mode/normal-yank.sml
Normal file
@@ -0,0 +1,534 @@
|
||||
structure NormalYank =
|
||||
struct
|
||||
open AppType
|
||||
open DrawMsg
|
||||
open MailboxType
|
||||
|
||||
fun finish (app, buffer, yankedString) =
|
||||
let
|
||||
val msgs = [DRAW (YANK yankedString)]
|
||||
val mode = NORMAL_MODE ""
|
||||
in
|
||||
NormalModeWith.modeAndBuffer (app, buffer, mode, msgs)
|
||||
end
|
||||
|
||||
fun yankLeft (app: app_type, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val min = Cursor.vi0 (buffer, cursorIdx)
|
||||
val low = Cursor.viH (buffer, cursorIdx, count)
|
||||
|
||||
val low = Int.max (min, low)
|
||||
val length = cursorIdx - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankRight (app: app_type, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
val endOfLineIdx = Cursor.viDlr (buffer, cursorIdx, 1) + 1
|
||||
val high = Cursor.viL (buffer, cursorIdx, count)
|
||||
val high = Int.min (high, endOfLineIdx)
|
||||
val length = high - cursorIdx
|
||||
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankLineUp (app: app_type, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
val cursorLineNumber =
|
||||
if Cursor.isNextChrEndOfLine (buffer, cursorIdx) then
|
||||
LineGap.idxToLineNumber (cursorIdx + 1, buffer)
|
||||
else
|
||||
LineGap.idxToLineNumber (cursorIdx, buffer)
|
||||
val newCursorLineNumber = Int.max (cursorLineNumber - count, 0)
|
||||
in
|
||||
if cursorLineNumber = 0 then
|
||||
NormalFinish.clearMode app
|
||||
else if newCursorLineNumber = 0 then
|
||||
let
|
||||
val endOfLine = Cursor.viDlr (buffer, cursorIdx, 1)
|
||||
val buffer = LineGap.goToIdx (endOfLine, buffer)
|
||||
|
||||
val endOfLine =
|
||||
if Cursor.isCursorAtStartOfLine (buffer, endOfLine) then
|
||||
endOfLine + 1
|
||||
else
|
||||
endOfLine + 2
|
||||
|
||||
val buffer = LineGap.goToIdx (endOfLine, buffer)
|
||||
val str = LineGap.substring (0, endOfLine, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
else
|
||||
let
|
||||
val endOfLine = Cursor.viDlr (buffer, cursorIdx, 1)
|
||||
val buffer = LineGap.goToIdx (endOfLine, buffer)
|
||||
val endsOnNewline = Cursor.isCursorAtStartOfLine (buffer, endOfLine)
|
||||
|
||||
val endOfLine = if endsOnNewline then endOfLine else endOfLine + 1
|
||||
|
||||
val newCursorLineNumber =
|
||||
if endsOnNewline andalso endOfLine = #textLength buffer - 1 then
|
||||
newCursorLineNumber - 1
|
||||
else
|
||||
newCursorLineNumber
|
||||
val buffer = LineGap.goToLine (newCursorLineNumber, buffer)
|
||||
|
||||
val lineIdx = LineGap.lineNumberToIdx (newCursorLineNumber, buffer)
|
||||
val length = endOfLine - lineIdx
|
||||
|
||||
val buffer = LineGap.goToIdx (endOfLine, buffer)
|
||||
val str = LineGap.substring (lineIdx + 1, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankLineDown (app: app_type, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
val startIdx = Cursor.vi0 (buffer, cursorIdx)
|
||||
val buffer = LineGap.goToIdx (startIdx, buffer)
|
||||
|
||||
val startLine =
|
||||
if Cursor.isCursorAtStartOfLine (buffer, startIdx) then
|
||||
LineGap.idxToLineNumber (startIdx, buffer)
|
||||
else
|
||||
LineGap.idxToLineNumber (startIdx + 1, buffer)
|
||||
val endLine = startLine + count + 1
|
||||
|
||||
val buffer = LineGap.goToLine (endLine, buffer)
|
||||
val endLineIdx = LineGap.lineNumberToIdx (endLine, buffer)
|
||||
val buffer = LineGap.goToIdx (endLineIdx - 1, buffer)
|
||||
|
||||
(* get "real" endLine by not considering newline after non-newline *)
|
||||
val endLine =
|
||||
if Cursor.isOnNewlineAfterChr (buffer, endLineIdx - 1) then
|
||||
LineGap.idxToLineNumber (endLineIdx - 1, buffer)
|
||||
else
|
||||
LineGap.idxToLineNumber (endLineIdx, buffer)
|
||||
in
|
||||
if endLineIdx = #textLength buffer andalso endLine = startLine then
|
||||
(* cursor is already on last line so don't yank *)
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val endLineIdx = endLineIdx + 1
|
||||
val length = endLineIdx - startIdx
|
||||
|
||||
(* perform the actual yank *)
|
||||
val buffer = LineGap.goToIdx (endLineIdx, buffer)
|
||||
val str = LineGap.substring (startIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankLine (app: app_type, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val low = Cursor.vi0 (buffer, cursorIdx)
|
||||
|
||||
val buffer = LineGap.goToIdx (low, buffer)
|
||||
val high = Cursor.viDlrForDelete (buffer, low, count)
|
||||
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val length = high - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankToStartOfLine (app: app_type) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val low = Cursor.vi0 (buffer, cursorIdx)
|
||||
|
||||
val length = cursorIdx - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankWhenMovingBack (app: app_type, fMove, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val low = fMove (buffer, cursorIdx, count)
|
||||
|
||||
val length = cursorIdx - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankWhenMovingBackPlusOne (app: app_type, fMove, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val low = fMove (buffer, cursorIdx, count)
|
||||
|
||||
val length = (cursorIdx + 1) - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankWhenMovingForward (app: app_type, fMove, count) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
val high = fMove (buffer, cursorIdx, count)
|
||||
val beforeHigh = high - 1
|
||||
val buffer = LineGap.goToIdx (beforeHigh, buffer)
|
||||
|
||||
val high =
|
||||
if Cursor.isOnNewlineAfterChr (buffer, beforeHigh) then beforeHigh
|
||||
else high
|
||||
|
||||
val length = high - cursorIdx
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankToFirstNonSpaceChr (app: app_type) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val otherIdx = Cursor.vi0 (buffer, cursorIdx)
|
||||
|
||||
val buffer = LineGap.goToIdx (otherIdx, buffer)
|
||||
val otherIdx = Cursor.firstNonSpaceChr (buffer, otherIdx)
|
||||
in
|
||||
if cursorIdx > otherIdx then
|
||||
(* yanking backwards from cursorIdx *)
|
||||
let
|
||||
val length = cursorIdx - otherIdx + 1
|
||||
val buffer = LineGap.goToIdx (otherIdx, buffer)
|
||||
val str = LineGap.substring (otherIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
else if cursorIdx < otherIdx then
|
||||
(* yanking forward from cursorIdx *)
|
||||
let
|
||||
val length = otherIdx - cursorIdx
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
else
|
||||
NormalFinish.clearMode app
|
||||
end
|
||||
|
||||
fun yankToEndOfText (app: app_type) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
|
||||
val buffer = LineGap.goToEnd buffer
|
||||
val {rightStrings, idx, ...} = buffer
|
||||
val finishIdx = Int.max (0, idx - 1)
|
||||
|
||||
val length = finishIdx - cursorIdx
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankToMatchingPair (app: app_type) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val otherIdx = Cursor.matchPair (buffer, cursorIdx)
|
||||
in
|
||||
if cursorIdx = otherIdx then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val low = Int.min (cursorIdx, otherIdx)
|
||||
val high = Int.max (cursorIdx, otherIdx)
|
||||
val length = high - low + 1
|
||||
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankToNextMatch (app: app_type, count) =
|
||||
let
|
||||
val {cursorIdx, searchList, buffer, ...} = app
|
||||
val high = PersistentVector.nextMatch (cursorIdx, searchList, count)
|
||||
in
|
||||
if high = ~1 orelse high <= cursorIdx then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val length = high - cursorIdx
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankToPrevMatch (app: app_type, count) =
|
||||
let
|
||||
val {cursorIdx, searchList, buffer, ...} = app
|
||||
val low = PersistentVector.prevMatch (cursorIdx, searchList, count)
|
||||
in
|
||||
if low = ~1 orelse low >= cursorIdx then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val length = cursorIdx - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun helpYankToChr
|
||||
(app: app_type, buffer, cursorIdx, otherIdx, count, fMove, fInc, chr) =
|
||||
if count = 0 then
|
||||
let
|
||||
val low = Int.min (cursorIdx, otherIdx)
|
||||
val high = Int.max (cursorIdx, otherIdx)
|
||||
val length = high - low
|
||||
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (otherIdx, buffer)
|
||||
val newOtherIdx = fMove (buffer, otherIdx, chr)
|
||||
val newCount = if newOtherIdx = otherIdx then 0 else count - 1
|
||||
val newOtherIdx = fInc (newOtherIdx, 1)
|
||||
in
|
||||
helpYankToChr
|
||||
(app, buffer, cursorIdx, newOtherIdx, newCount, fMove, fInc, chr)
|
||||
end
|
||||
|
||||
fun yankToNextChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toNextChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val length = newCursorIdx - cursorIdx + 1
|
||||
val buffer = LineGap.goToIdx (newCursorIdx, buffer)
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankTillNextChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toNextChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val length = newCursorIdx - cursorIdx
|
||||
val buffer = LineGap.goToIdx (newCursorIdx, buffer)
|
||||
val str = LineGap.substring (cursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankToPrevChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toPrevChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val length = cursorIdx - newCursorIdx
|
||||
val str = LineGap.substring (newCursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankTillPrevChr (app: app_type, count, chr) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val newCursorIdx =
|
||||
Cursor.toPrevChr (buffer, cursorIdx, {findChr = chr, count = count})
|
||||
in
|
||||
if newCursorIdx = ~1 then
|
||||
NormalFinish.clearMode app
|
||||
else
|
||||
let
|
||||
val newCursorIdx = newCursorIdx + 1
|
||||
val length = cursorIdx - newCursorIdx
|
||||
val str = LineGap.substring (newCursorIdx, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
end
|
||||
|
||||
fun yankToStart (app: app_type) =
|
||||
let
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
|
||||
val high = Cursor.viDlrForDelete (buffer, cursorIdx, 1)
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val str = LineGap.substring (0, high, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankInsideWord (app: app_type) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val low = Cursor.prevWordStrict (buffer, cursorIdx, 1)
|
||||
val high = Cursor.endOfWordStrict (buffer, cursorIdx, 1)
|
||||
|
||||
val high = high + 1
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val length = high - low
|
||||
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
if str = "\n" then NormalFinish.clearMode app
|
||||
else finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankInsideWORD (app: app_type) =
|
||||
let
|
||||
val {buffer, cursorIdx, ...} = app
|
||||
val buffer = LineGap.goToIdx (cursorIdx, buffer)
|
||||
val low = Cursor.prevWORDStrict (buffer, cursorIdx, 1)
|
||||
val high = Cursor.endOfWORDStrict (buffer, cursorIdx, 1)
|
||||
|
||||
val high = high + 1
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val length = high - low
|
||||
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
if str = "\n" then NormalFinish.clearMode app
|
||||
else finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun finishAfterYankInside (app: app_type, low, high, buffer) =
|
||||
let
|
||||
val length = high - low
|
||||
val str = LineGap.substring (low, length, buffer)
|
||||
in
|
||||
finish (app, buffer, str)
|
||||
end
|
||||
|
||||
fun yankInsideChrOpen (app: app_type, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
|
||||
val start = cursorIdx + 1
|
||||
val buffer = LineGap.goToIdx (start, buffer)
|
||||
|
||||
val low = Cursor.toPrevChr (buffer, start, {findChr = chr, count = 1})
|
||||
val buffer = LineGap.goToIdx (low, buffer)
|
||||
val high = Cursor.matchPair (buffer, low)
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val low = low + 1
|
||||
in
|
||||
if low = high then NormalFinish.clearMode app
|
||||
else finishAfterYankInside (app, low, high, buffer)
|
||||
end
|
||||
|
||||
fun yankInsideChrClose (app: app_type, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
|
||||
val start = Int.max (cursorIdx - 1, 0)
|
||||
val buffer = LineGap.goToIdx (start, buffer)
|
||||
|
||||
val high = Cursor.toNextChr (buffer, start, {findChr = chr, count = 1})
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val low = Cursor.matchPair (buffer, high) + 1
|
||||
in
|
||||
if low = high then NormalFinish.clearMode app
|
||||
else finishAfterYankInside (app, low, high, buffer)
|
||||
end
|
||||
|
||||
fun yankAroundChrOpen (app: app_type, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
|
||||
val start = cursorIdx + 1
|
||||
val buffer = LineGap.goToIdx (start, buffer)
|
||||
|
||||
val low = Cursor.toPrevChr (buffer, start, {findChr = chr, count = 1})
|
||||
val buffer = LineGap.goToIdx (low, buffer)
|
||||
val high = Cursor.matchPair (buffer, low) + 1
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val low = low
|
||||
in
|
||||
if low = high then NormalFinish.clearMode app
|
||||
else finishAfterYankInside (app, low, high, buffer)
|
||||
end
|
||||
|
||||
fun yankAroundChrClose (app: app_type, chr) =
|
||||
let
|
||||
val {cursorIdx, buffer, ...} = app
|
||||
|
||||
val start = Int.max (cursorIdx - 1, 0)
|
||||
val buffer = LineGap.goToIdx (start, buffer)
|
||||
|
||||
val high = Cursor.toNextChr (buffer, start, {findChr = chr, count = 1})
|
||||
val buffer = LineGap.goToIdx (high, buffer)
|
||||
val low = Cursor.matchPair (buffer, high)
|
||||
val high = high + 1
|
||||
in
|
||||
if low = high then NormalFinish.clearMode app
|
||||
else finishAfterYankInside (app, low, high, buffer)
|
||||
end
|
||||
end
|
||||
937
shf/fcore/persistent-vector.sml
Normal file
937
shf/fcore/persistent-vector.sml
Normal file
@@ -0,0 +1,937 @@
|
||||
structure PersistentVector =
|
||||
struct
|
||||
(* Clojure-style persistent vector, for building search list.
|
||||
* There is an "int table" too, which stores the last index
|
||||
* at the node with the same index.
|
||||
* We can use the size table for binary search.
|
||||
* *)
|
||||
datatype t =
|
||||
BRANCH of t vector * int vector
|
||||
| LEAF of {start: int, finish: int} vector * int vector
|
||||
|
||||
val maxSize = 32
|
||||
val halfSize = 16
|
||||
|
||||
fun isEmpty t =
|
||||
case t of
|
||||
LEAF (_, sizes) => Vector.length sizes = 0
|
||||
| BRANCH (_, sizes) => Vector.length sizes = 0
|
||||
|
||||
val empty = LEAF (#[], #[])
|
||||
|
||||
datatype append_result = APPEND of t | UPDATE of t
|
||||
|
||||
fun isInRange (checkIdx, t) =
|
||||
case t of
|
||||
BRANCH (nodes, sizes) =>
|
||||
let
|
||||
val searchIdx = BinSearch.equalOrMore (checkIdx, sizes)
|
||||
in
|
||||
if searchIdx = ~1 then
|
||||
false
|
||||
else if searchIdx = 0 then
|
||||
isInRange (checkIdx, Vector.sub (nodes, searchIdx))
|
||||
else
|
||||
let
|
||||
val nextCheckIdx = checkIdx - Vector.sub (sizes, searchIdx - 1)
|
||||
in
|
||||
isInRange (nextCheckIdx, Vector.sub (nodes, searchIdx))
|
||||
end
|
||||
end
|
||||
| LEAF (values, sizes) =>
|
||||
let
|
||||
val searchIdx = BinSearch.equalOrMore (checkIdx, sizes)
|
||||
in
|
||||
if searchIdx = ~1 then
|
||||
false
|
||||
else
|
||||
let
|
||||
val {start, finish} = Vector.sub (values, searchIdx)
|
||||
in
|
||||
checkIdx >= start andalso checkIdx <= finish
|
||||
end
|
||||
end
|
||||
|
||||
fun getFinishIdx t =
|
||||
case t of
|
||||
BRANCH (_, sizes) => Vector.sub (sizes, Vector.length sizes - 1)
|
||||
| LEAF (_, sizes) => Vector.sub (sizes, Vector.length sizes - 1)
|
||||
|
||||
fun getStartIdx t =
|
||||
case t of
|
||||
BRANCH (nodes, _) => getStartIdx (Vector.sub (nodes, 0))
|
||||
| LEAF (items, _) =>
|
||||
if Vector.length items = 0 then
|
||||
0
|
||||
else
|
||||
#start (Vector.sub (items, 0))
|
||||
|
||||
fun helpAppend (start, finish, tree) =
|
||||
case tree of
|
||||
BRANCH (nodes, sizes) =>
|
||||
let
|
||||
val lastNode = Vector.sub (nodes, Vector.length nodes - 1)
|
||||
val prevSize =
|
||||
if Vector.length sizes > 1 then
|
||||
Vector.sub (sizes, Vector.length sizes - 2)
|
||||
else
|
||||
0
|
||||
in
|
||||
case helpAppend (start - prevSize, finish - prevSize, lastNode) of
|
||||
UPDATE newLast =>
|
||||
let
|
||||
val lastPos = Vector.length nodes - 1
|
||||
val newNode = Vector.update (nodes, lastPos, newLast)
|
||||
val newSizes = Vector.update (sizes, lastPos, finish)
|
||||
val newNode = BRANCH (newNode, newSizes)
|
||||
in
|
||||
UPDATE newNode
|
||||
end
|
||||
| APPEND newVec =>
|
||||
if Vector.length nodes = maxSize then
|
||||
let
|
||||
(* adjust "finish" so that it does not consider
|
||||
* offset for "lower" vector *)
|
||||
val finish = finish - Vector.sub (sizes, Vector.length sizes - 1)
|
||||
val newNode = BRANCH (#[newVec], #[finish])
|
||||
in
|
||||
APPEND newNode
|
||||
end
|
||||
else
|
||||
let
|
||||
val newNodes = Vector.concat [nodes, #[newVec]]
|
||||
val newSizes = Vector.concat [sizes, #[finish]]
|
||||
val newNodes = BRANCH (newNodes, newSizes)
|
||||
in
|
||||
UPDATE newNodes
|
||||
end
|
||||
end
|
||||
| LEAF (values, sizes) =>
|
||||
if Vector.length values + 1 > maxSize then
|
||||
(* when we split a leaf into two vectors,
|
||||
* we want to adjust the start and finish parameters
|
||||
* so that they don't contain the offset relevant to the
|
||||
* "lower" vector, which was split from *)
|
||||
let
|
||||
val prevFinish = Vector.sub (sizes, Vector.length sizes - 1)
|
||||
val start = start - prevFinish
|
||||
val finish = finish - prevFinish
|
||||
val newNode = LEAF (#[{start = start, finish = finish}], #[finish])
|
||||
in
|
||||
APPEND newNode
|
||||
end
|
||||
else
|
||||
let
|
||||
val newNode = Vector.concat
|
||||
[values, #[{start = start, finish = finish}]]
|
||||
val newSizes = Vector.concat [sizes, #[finish]]
|
||||
val newNode = LEAF (newNode, newSizes)
|
||||
in
|
||||
UPDATE newNode
|
||||
end
|
||||
|
||||
fun append (start, finish, tree) =
|
||||
case helpAppend (start, finish, tree) of
|
||||
UPDATE t => t
|
||||
| APPEND newNode =>
|
||||
let
|
||||
val maxSize = getFinishIdx tree
|
||||
in
|
||||
BRANCH (#[tree, newNode], #[maxSize, finish])
|
||||
end
|
||||
|
||||
fun getStart tree =
|
||||
case tree of
|
||||
LEAF (values, _) => Vector.sub (values, 0)
|
||||
| BRANCH (nodes, _) => getStart (Vector.sub (nodes, 0))
|
||||
|
||||
fun helpNextMatch (cursorIdx, tree, absOffset) =
|
||||
case tree of
|
||||
LEAF (values, sizes) =>
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (cursorIdx, sizes)
|
||||
in
|
||||
if idx = ~1 then {start = ~1, finish = ~1}
|
||||
else
|
||||
let
|
||||
val {start, finish} = Vector.sub (values, idx)
|
||||
in
|
||||
{start = start + absOffset, finish = finish + absOffset}
|
||||
end
|
||||
end
|
||||
| BRANCH (nodes, sizes) =>
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (cursorIdx, sizes)
|
||||
in
|
||||
if idx = ~1 then
|
||||
{start = ~1, finish = ~1}
|
||||
else if idx = 0 then
|
||||
helpNextMatch (cursorIdx, Vector.sub (nodes, idx), absOffset)
|
||||
else
|
||||
let
|
||||
val prevSize = Vector.sub (sizes, idx - 1)
|
||||
val cursorIdx = cursorIdx - prevSize
|
||||
val absOffset = absOffset + prevSize
|
||||
in
|
||||
helpNextMatch (cursorIdx, Vector.sub (nodes, idx), absOffset)
|
||||
end
|
||||
end
|
||||
|
||||
fun loopNextMatch (prevStart, prevFinish, tree, count) =
|
||||
if count = 0 then
|
||||
prevStart
|
||||
else
|
||||
let
|
||||
val {start, finish} = helpNextMatch (prevFinish + 1, tree, 0)
|
||||
in
|
||||
if start = ~1 then
|
||||
let val {start, finish} = getStart tree
|
||||
in loopNextMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
else
|
||||
loopNextMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
|
||||
fun nextMatch (cursorIdx, tree, count) =
|
||||
if isEmpty tree then
|
||||
~1
|
||||
else
|
||||
let
|
||||
val {start, finish} = helpNextMatch (cursorIdx, tree, 0)
|
||||
in
|
||||
if start = ~1 then
|
||||
let val {start, finish} = getStart tree
|
||||
in loopNextMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
else if cursorIdx >= start andalso cursorIdx <= finish then
|
||||
loopNextMatch (start, finish, tree, count)
|
||||
else
|
||||
loopNextMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
|
||||
fun getLast (tree, absOffset) =
|
||||
case tree of
|
||||
LEAF (values, _) =>
|
||||
let
|
||||
val {start, finish} = Vector.sub (values, Vector.length values - 1)
|
||||
in
|
||||
{start = start + absOffset, finish = finish + absOffset}
|
||||
end
|
||||
| BRANCH (nodes, sizes) =>
|
||||
let
|
||||
val prevSize =
|
||||
if Vector.length sizes - 2 >= 0 then
|
||||
Vector.sub (sizes, Vector.length sizes - 2)
|
||||
else
|
||||
0
|
||||
val absOffset = absOffset + prevSize
|
||||
in
|
||||
getLast (Vector.sub (nodes, Vector.length nodes - 1), absOffset)
|
||||
end
|
||||
|
||||
(* slightly tricky.
|
||||
* The `sizes` vector contains the last/finish position of the item
|
||||
* at the corresponding index in the `nodes` or `values` vector
|
||||
* However, what we when searching for the previous match
|
||||
* is different: we want the node that has a start prior
|
||||
* to the cursorIdx.
|
||||
* This information cannot be retrieved with 100% accuracy
|
||||
* using the `sizes` vector.
|
||||
* To get what we want, we recurse downwards using the `sizes` vector.
|
||||
* If we found the node we want, we return it.
|
||||
* Otherwise, we return a state meaning "no node at this position"
|
||||
* and we use the call stack to descend down the node at the previous index.
|
||||
* There might not be a previous index because the current index is 0.
|
||||
* In this case, either the call stack will handle it,
|
||||
* or the caller to `helpPrevMatch` will. *)
|
||||
fun helpPrevMatch (cursorIdx, tree, absOffset) =
|
||||
case tree of
|
||||
LEAF (values, sizes) =>
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (cursorIdx, sizes)
|
||||
in
|
||||
if idx < 0 then
|
||||
{start = ~1, finish = ~1}
|
||||
else if idx = 0 then
|
||||
let
|
||||
val {start, finish} = Vector.sub (values, 0)
|
||||
in
|
||||
if start < cursorIdx then
|
||||
{start = start + absOffset, finish = finish + absOffset}
|
||||
else
|
||||
{start = ~1, finish = ~1}
|
||||
end
|
||||
else
|
||||
let
|
||||
val {start, finish} = Vector.sub (values, idx)
|
||||
in
|
||||
if cursorIdx > start then
|
||||
{start = start + absOffset, finish = finish + absOffset}
|
||||
else
|
||||
let
|
||||
val {start, finish} = Vector.sub (values, idx - 1)
|
||||
in
|
||||
{start = start + absOffset, finish = finish + absOffset}
|
||||
end
|
||||
end
|
||||
end
|
||||
| BRANCH (nodes, sizes) =>
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (cursorIdx, sizes)
|
||||
in
|
||||
if idx < 0 then
|
||||
{start = ~1, finish = ~1}
|
||||
else if idx = 0 then
|
||||
helpPrevMatch (cursorIdx, Vector.sub (nodes, idx), absOffset)
|
||||
else
|
||||
let
|
||||
val prevSize = Vector.sub (sizes, idx - 1)
|
||||
val node = Vector.sub (nodes, idx)
|
||||
val result =
|
||||
helpPrevMatch (cursorIdx - prevSize, node, absOffset + prevSize)
|
||||
in
|
||||
if #start result = ~1 then
|
||||
let
|
||||
val prevSize =
|
||||
if idx - 2 >= 0 then
|
||||
Vector.sub (sizes, idx - 2)
|
||||
else
|
||||
0
|
||||
val absOffset = absOffset + prevSize
|
||||
in
|
||||
getLast (Vector.sub (nodes, idx - 1), absOffset)
|
||||
end
|
||||
else result
|
||||
end
|
||||
end
|
||||
|
||||
fun loopPrevMatch (prevStart, prevFinish, tree, count) =
|
||||
if count = 0 then
|
||||
prevStart
|
||||
else
|
||||
let
|
||||
val {start, finish} = helpPrevMatch (prevFinish - 1, tree, 0)
|
||||
in
|
||||
if start = ~1 then
|
||||
let val {start, finish} = getLast (tree, 0)
|
||||
in loopPrevMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
else
|
||||
loopPrevMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
|
||||
fun prevMatch (cursorIdx, tree, count) =
|
||||
if isEmpty tree then
|
||||
~1
|
||||
else
|
||||
let
|
||||
val {start, finish} = helpPrevMatch (cursorIdx, tree, 0)
|
||||
in
|
||||
if start = ~1 then
|
||||
let val {start, finish} = getLast (tree, 0)
|
||||
in loopPrevMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
else if cursorIdx >= start andalso cursorIdx <= finish then
|
||||
loopPrevMatch (start, finish, tree, count)
|
||||
else
|
||||
loopPrevMatch (start, finish, tree, count - 1)
|
||||
end
|
||||
|
||||
fun splitLeft (splitIdx, tree) =
|
||||
case tree of
|
||||
LEAF (items, sizes) =>
|
||||
if Vector.length items = 0 then
|
||||
(* if tree is empty, then just return tree *)
|
||||
tree
|
||||
else
|
||||
let
|
||||
val {start, ...} = Vector.sub (items, 0)
|
||||
in
|
||||
(* if all items are after splitIdx,
|
||||
* then we want to return an empty tree,
|
||||
* splitting everything *)
|
||||
if splitIdx < start then
|
||||
empty
|
||||
else if splitIdx > Vector.sub (sizes, Vector.length sizes - 1) then
|
||||
(* if all items are before splitIdx,
|
||||
* then we want to return the same tree,
|
||||
* splitting nothing *)
|
||||
tree
|
||||
else
|
||||
(* we want to split from somewhere in middle, keeping left *)
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (splitIdx, sizes)
|
||||
val idx = SOME idx
|
||||
|
||||
val items = VectorSlice.slice (items, 0, idx)
|
||||
val items = VectorSlice.vector items
|
||||
|
||||
val sizes = VectorSlice.slice (sizes, 0, idx)
|
||||
val sizes = VectorSlice.vector sizes
|
||||
in
|
||||
LEAF (items, sizes)
|
||||
end
|
||||
end
|
||||
| BRANCH (nodes, sizes) =>
|
||||
if Vector.length nodes = 0 then
|
||||
tree
|
||||
else
|
||||
if splitIdx < Vector.sub (sizes, 0) then
|
||||
(* we want to split first node from rest *)
|
||||
splitLeft (splitIdx, Vector.sub (nodes, 0))
|
||||
else if splitIdx > Vector.sub (sizes, Vector.length sizes - 1) then
|
||||
(* split point is after this subtree,
|
||||
* so return this subtree unchanged *)
|
||||
tree
|
||||
else
|
||||
(* we want to split from somewhere in middle *)
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (splitIdx, sizes)
|
||||
val prevSize =
|
||||
if idx = 0 then
|
||||
0
|
||||
else
|
||||
Vector.sub (sizes, idx - 1)
|
||||
val child =
|
||||
splitLeft (splitIdx - prevSize, Vector.sub (nodes, idx))
|
||||
|
||||
val sizes = VectorSlice.slice (sizes, 0, SOME idx)
|
||||
val nodes = VectorSlice.slice (nodes, 0, SOME idx)
|
||||
in
|
||||
if isEmpty child then
|
||||
let
|
||||
val sizes = VectorSlice.vector sizes
|
||||
val nodes = VectorSlice.vector nodes
|
||||
in
|
||||
BRANCH (nodes, sizes)
|
||||
end
|
||||
else
|
||||
let
|
||||
val childSize = VectorSlice.full #[getFinishIdx child + prevSize]
|
||||
val sizes =VectorSlice.concat [sizes, childSize]
|
||||
|
||||
val childNode = VectorSlice.full #[child]
|
||||
val nodes = VectorSlice.concat [nodes, childNode]
|
||||
in
|
||||
BRANCH (nodes, sizes)
|
||||
end
|
||||
end
|
||||
|
||||
(* When we split in this function,
|
||||
* we always want to update the sizes vector
|
||||
* so that the relative rope-like metadata is valid *)
|
||||
fun splitRight (splitIdx, tree) =
|
||||
case tree of
|
||||
BRANCH (nodes, sizes) =>
|
||||
if splitIdx > Vector.sub (sizes, Vector.length sizes - 1) then
|
||||
(* splitIdx is greater than largest element,
|
||||
* so we want to remove everything;
|
||||
* or, in other words, we want to return an empty vec *)
|
||||
empty
|
||||
else
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (splitIdx, sizes)
|
||||
val prevSize =
|
||||
if idx = 0 then
|
||||
0
|
||||
else
|
||||
Vector.sub (sizes, idx - 1)
|
||||
|
||||
val oldChildSize = Vector.sub (sizes, idx)
|
||||
val child = splitRight (splitIdx - prevSize, Vector.sub (nodes, idx))
|
||||
|
||||
val len = Vector.length nodes - (idx + 1)
|
||||
val sizesSlice = VectorSlice.slice (sizes, idx + 1, SOME len)
|
||||
val nodesSlice = VectorSlice.slice (nodes, idx + 1, SOME len)
|
||||
in
|
||||
if isEmpty child then
|
||||
if VectorSlice.length sizesSlice = 0 then
|
||||
(* if we descended down last node and last node became empty,
|
||||
* then return empty vector *)
|
||||
empty
|
||||
else
|
||||
let
|
||||
val nodes = VectorSlice.vector nodesSlice
|
||||
val sizes = VectorSlice.map (fn el => el - oldChildSize) sizesSlice
|
||||
in
|
||||
BRANCH (nodes, sizes)
|
||||
end
|
||||
else
|
||||
let
|
||||
val newChildSize = getFinishIdx child
|
||||
val sizes = Vector.tabulate (VectorSlice.length sizesSlice + 1,
|
||||
fn i =>
|
||||
if i = 0 then
|
||||
newChildSize
|
||||
else
|
||||
let
|
||||
val el = VectorSlice.sub (sizesSlice, i - 1)
|
||||
in
|
||||
el - oldChildSize + newChildSize
|
||||
end
|
||||
)
|
||||
|
||||
val child = VectorSlice.full #[child]
|
||||
val nodes = VectorSlice.concat [child, nodesSlice]
|
||||
in
|
||||
BRANCH (nodes, sizes)
|
||||
end
|
||||
end
|
||||
| LEAF (items, sizes) =>
|
||||
if Vector.length items = 0 then
|
||||
tree
|
||||
else
|
||||
if splitIdx > Vector.sub (sizes, Vector.length sizes - 1) then
|
||||
empty
|
||||
else if splitIdx < #start (Vector.sub (items, 0)) then
|
||||
tree
|
||||
else
|
||||
let
|
||||
val idx = BinSearch.equalOrMore (splitIdx, sizes)
|
||||
val {start, finish} = Vector.sub (items, idx)
|
||||
val idx =
|
||||
if splitIdx >= start then
|
||||
idx + 1
|
||||
else
|
||||
idx
|
||||
in
|
||||
if idx >= Vector.length items then
|
||||
empty
|
||||
else
|
||||
let
|
||||
val prevSize =
|
||||
if idx > 0 then
|
||||
Vector.sub (sizes, idx - 1)
|
||||
else
|
||||
0
|
||||
val len = Vector.length items - idx
|
||||
val itemsSlice = VectorSlice.slice (items, idx, SOME len)
|
||||
val items = VectorSlice.map
|
||||
(fn {start, finish} =>
|
||||
{start = start - prevSize, finish = finish - prevSize}
|
||||
)
|
||||
itemsSlice
|
||||
val sizes = Vector.map #finish items
|
||||
in
|
||||
LEAF (items, sizes)
|
||||
end
|
||||
end
|
||||
|
||||
fun decrementBy (decBy, tree) =
|
||||
case tree of
|
||||
BRANCH (nodes, sizes) =>
|
||||
let
|
||||
val child = decrementBy (decBy, Vector.sub (nodes, 0))
|
||||
val nodes = Vector.update (nodes, 0, child)
|
||||
val sizes = Vector.map (fn sz => sz - decBy) sizes
|
||||
in
|
||||
BRANCH (nodes, sizes)
|
||||
end
|
||||
| LEAF (items, sizes) =>
|
||||
let
|
||||
val items = Vector.map
|
||||
(fn {start, finish} =>
|
||||
{start = start - decBy, finish = finish - decBy}
|
||||
) items
|
||||
val sizes = Vector.map #finish items
|
||||
in
|
||||
LEAF (items, sizes)
|
||||
end
|
||||
|
||||
fun incrementBy (incBy, tree) =
|
||||
case tree of
|
||||
BRANCH (nodes, sizes) =>
|
||||
let
|
||||
val child = incrementBy (incBy, Vector.sub (nodes, 0))
|
||||
val nodes = Vector.update (nodes, 0, child)
|
||||
val sizes = Vector.map (fn sz => sz + incBy) sizes
|
||||
in
|
||||
BRANCH (nodes, sizes)
|
||||
end
|
||||
| LEAF (items, sizes) =>
|
||||
let
|
||||
val items = Vector.map
|
||||
(fn {start, finish} =>
|
||||
{start = start + incBy, finish = finish + incBy}
|
||||
) items
|
||||
val sizes = Vector.map #finish items
|
||||
in
|
||||
LEAF (items, sizes)
|
||||
end
|
||||
|
||||
fun countDepthLoop (counter, tree) =
|
||||
case tree of
|
||||
BRANCH (nodes, _) => countDepthLoop (counter + 1, Vector.sub (nodes, 0))
|
||||
| LEAF (_, _) => counter + 1
|
||||
|
||||
fun countDepth tree = countDepthLoop (0, tree)
|
||||
|
||||
datatype merge_same_depth_result =
|
||||
MERGE_SAME_DEPTH_UPDATE of t
|
||||
| MERGE_SAME_DEPTH_FULL
|
||||
|
||||
fun mergeSameDepth (left, right) =
|
||||
case (left, right) of
|
||||
(LEAF (leftItems, leftSizes), LEAF (rightItems, rightSizes)) =>
|
||||
if Vector.length leftItems + Vector.length rightItems <= maxSize then
|
||||
let
|
||||
val offset = Vector.sub (leftSizes, Vector.length leftSizes - 1)
|
||||
val newVecLen = Vector.length leftItems + Vector.length rightItems
|
||||
val items = Vector.tabulate (newVecLen,
|
||||
fn i =>
|
||||
if i < Vector.length leftItems then
|
||||
Vector.sub (leftItems, i)
|
||||
else
|
||||
let
|
||||
val {start, finish} =
|
||||
Vector.sub (rightItems, i - Vector.length leftItems)
|
||||
in
|
||||
{start = start + offset, finish = finish + offset}
|
||||
end
|
||||
)
|
||||
val sizes = Vector.map #finish items
|
||||
in
|
||||
MERGE_SAME_DEPTH_UPDATE (LEAF (items, sizes))
|
||||
end
|
||||
else
|
||||
MERGE_SAME_DEPTH_FULL
|
||||
| (BRANCH (leftNodes, leftSizes), BRANCH (rightNodes, rightSizes)) =>
|
||||
if Vector.length leftNodes + Vector.length rightNodes <= maxSize then
|
||||
let
|
||||
val offset = Vector.sub (leftSizes, Vector.length leftSizes - 1)
|
||||
val nodes = Vector.concat [leftNodes, rightNodes]
|
||||
|
||||
val sizes = Vector.tabulate (Vector.length nodes,
|
||||
fn i =>
|
||||
if i < Vector.length leftSizes then
|
||||
Vector.sub (leftSizes, i)
|
||||
else
|
||||
Vector.sub (rightSizes, i - Vector.length leftSizes) + offset
|
||||
)
|
||||
in
|
||||
MERGE_SAME_DEPTH_UPDATE (BRANCH (nodes, sizes))
|
||||
end
|
||||
else
|
||||
MERGE_SAME_DEPTH_FULL
|
||||
| _ =>
|
||||
raise Fail "PersistentVector.mergeSameDepth: \
|
||||
\left and right should both be BRANCH or both be LEAF \
|
||||
\but one is BRANCH and one is LEAF"
|
||||
|
||||
datatype merge_diff_depth_result =
|
||||
MERGE_DIFF_DEPTH_UPDATE of t
|
||||
| MERGE_DIFF_DEPTH_FULL
|
||||
|
||||
fun mergeWhenRightDepthIsGreater (left, right, targetDepth, curDepth) =
|
||||
if curDepth = targetDepth then
|
||||
case mergeSameDepth (left, right) of
|
||||
MERGE_SAME_DEPTH_UPDATE tree => MERGE_DIFF_DEPTH_UPDATE tree
|
||||
| MERGE_SAME_DEPTH_FULL => MERGE_DIFF_DEPTH_FULL
|
||||
else
|
||||
case right of
|
||||
BRANCH (nodes, sizes) =>
|
||||
(case mergeWhenRightDepthIsGreater
|
||||
(left, Vector.sub (nodes, 0), targetDepth, curDepth + 1) of
|
||||
MERGE_DIFF_DEPTH_UPDATE child =>
|
||||
let
|
||||
val oldChildSize = Vector.sub (sizes, 0)
|
||||
val newChildSize = getFinishIdx child
|
||||
val difference = newChildSize - oldChildSize
|
||||
|
||||
val nodes = Vector.update (nodes, 0, child)
|
||||
val sizes = Vector.map (fn el => el + difference) sizes
|
||||
in
|
||||
MERGE_DIFF_DEPTH_UPDATE (BRANCH (nodes, sizes))
|
||||
end
|
||||
| MERGE_DIFF_DEPTH_FULL =>
|
||||
let
|
||||
val leftSize = getFinishIdx left
|
||||
val sizes = Vector.tabulate (Vector.length nodes + 1,
|
||||
fn i =>
|
||||
if i = 0 then
|
||||
leftSize
|
||||
else
|
||||
Vector.sub (sizes, i - 1) + leftSize
|
||||
)
|
||||
val nodes = Vector.concat [#[left], nodes]
|
||||
in
|
||||
MERGE_DIFF_DEPTH_UPDATE (BRANCH (nodes, sizes))
|
||||
end)
|
||||
| LEAF _ =>
|
||||
raise Fail "PersistentVector.mergeWhenRightDepthIsGreater: \
|
||||
\reached LEAF before (curDepth = targetDepth)"
|
||||
|
||||
fun mergeWhenLeftDepthIsGreater (left, right, targetDepth, curDepth) =
|
||||
if targetDepth = curDepth then
|
||||
case mergeSameDepth (left, right) of
|
||||
MERGE_SAME_DEPTH_UPDATE tree => MERGE_DIFF_DEPTH_UPDATE tree
|
||||
| MERGE_SAME_DEPTH_FULL => MERGE_DIFF_DEPTH_FULL
|
||||
else
|
||||
case left of
|
||||
BRANCH (nodes, sizes) =>
|
||||
(case
|
||||
mergeWhenLeftDepthIsGreater (
|
||||
Vector.sub (nodes, Vector.length nodes - 1),
|
||||
right,
|
||||
targetDepth,
|
||||
curDepth + 1) of
|
||||
MERGE_DIFF_DEPTH_UPDATE child =>
|
||||
let
|
||||
val lastIdx = Vector.length sizes - 1
|
||||
val oldChildSize = Vector.sub (sizes, lastIdx)
|
||||
val newChildSize = getFinishIdx child
|
||||
val difference = newChildSize - oldChildSize
|
||||
|
||||
val nodes = Vector.update (nodes, lastIdx, child)
|
||||
val sizes = Vector.map (fn el => el + difference) sizes
|
||||
in
|
||||
MERGE_DIFF_DEPTH_UPDATE (BRANCH (nodes, sizes))
|
||||
end
|
||||
| MERGE_DIFF_DEPTH_FULL =>
|
||||
let
|
||||
val maxLeftSize = Vector.sub (sizes, Vector.length sizes - 1)
|
||||
val rightSize = getFinishIdx right + maxLeftSize
|
||||
val sizes = Vector.concat [sizes, #[rightSize]]
|
||||
val nodes = Vector.concat [nodes, #[right]]
|
||||
in
|
||||
MERGE_DIFF_DEPTH_UPDATE (BRANCH (nodes, sizes))
|
||||
end)
|
||||
| LEAF _ =>
|
||||
raise Fail "PersistentVector.mergeWhenLeftDepthIsGreater: \
|
||||
\reached LEAF before (curDepth = targetDepth)"
|
||||
|
||||
fun merge (left, right) =
|
||||
let
|
||||
val leftDepth = countDepth left
|
||||
val rightDepth = countDepth right
|
||||
in
|
||||
if leftDepth = rightDepth then
|
||||
case mergeSameDepth (left, right) of
|
||||
MERGE_SAME_DEPTH_UPDATE t => t
|
||||
| MERGE_SAME_DEPTH_FULL =>
|
||||
let
|
||||
val leftSize = getFinishIdx left
|
||||
val sizes = #[leftSize, getFinishIdx right + leftSize]
|
||||
val nodes = #[left, right]
|
||||
in
|
||||
BRANCH (nodes, sizes)
|
||||
end
|
||||
else if leftDepth < rightDepth then
|
||||
let
|
||||
val targetDepth = rightDepth - leftDepth
|
||||
in
|
||||
case mergeWhenRightDepthIsGreater
|
||||
(left, right, targetDepth, 0) of
|
||||
MERGE_DIFF_DEPTH_UPDATE t => t
|
||||
| MERGE_DIFF_DEPTH_FULL => empty
|
||||
end
|
||||
else
|
||||
let
|
||||
val targetDepth = leftDepth - rightDepth
|
||||
in
|
||||
case mergeWhenLeftDepthIsGreater
|
||||
(left, right, targetDepth, 0) of
|
||||
MERGE_DIFF_DEPTH_UPDATE t => t
|
||||
| MERGE_DIFF_DEPTH_FULL => empty
|
||||
end
|
||||
end
|
||||
|
||||
fun delete (start, length, tree) =
|
||||
if isEmpty tree then
|
||||
empty
|
||||
else
|
||||
let
|
||||
val finish = start + length
|
||||
|
||||
val matchAfterFinish = nextMatch (finish, tree, 1)
|
||||
val matchAfterFinish =
|
||||
if matchAfterFinish < finish then
|
||||
~1
|
||||
else
|
||||
matchAfterFinish
|
||||
in
|
||||
let
|
||||
val left = splitLeft (start, tree)
|
||||
val right = splitRight (finish, tree)
|
||||
in
|
||||
if isEmpty left andalso isEmpty right then
|
||||
empty
|
||||
else if isEmpty left then
|
||||
(* just decrement right and return it *)
|
||||
let
|
||||
val rightStart = getStartIdx right
|
||||
val shouldBeStartIdx = matchAfterFinish - length
|
||||
val difference = rightStart - shouldBeStartIdx
|
||||
in
|
||||
if difference = 0 then
|
||||
right
|
||||
else
|
||||
decrementBy (difference, right)
|
||||
end
|
||||
else if isEmpty right then
|
||||
(* return left half without doing anything *)
|
||||
left
|
||||
else
|
||||
(* decrement right, and then merge both together *)
|
||||
let
|
||||
val leftSize = getFinishIdx left
|
||||
val rightStartRelative = getStartIdx right
|
||||
val rightStartAbsolute = leftSize + rightStartRelative
|
||||
|
||||
val shouldBeStartIdx = matchAfterFinish - length
|
||||
val difference = rightStartAbsolute - shouldBeStartIdx
|
||||
in
|
||||
if difference = 0 then
|
||||
merge (left, right)
|
||||
else
|
||||
let
|
||||
val right = decrementBy (difference, right)
|
||||
in
|
||||
merge (left, right)
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
(* Usually, when inserting, we want the absolute metadata
|
||||
* to be adjusted appropriately.
|
||||
* An insertion should cause the absolute metadata to increment.
|
||||
* However, we sometimes want to insert a match without adjusting
|
||||
* the absolute metadata in this way.
|
||||
* We want to do this when deleting some part of the buffer
|
||||
* would cause a new match to be found, for example. *)
|
||||
fun insertMatchKeepingAbsoluteInddices (start, finish, tree) =
|
||||
let
|
||||
val matchAfterFinish = nextMatch (finish, tree, 1)
|
||||
in
|
||||
if matchAfterFinish <= finish then
|
||||
(* no match after the 'finish', so we can just append to 'tree' *)
|
||||
append (start, finish, tree)
|
||||
else
|
||||
let
|
||||
val left = splitLeft (start, tree)
|
||||
val right = splitRight (finish, tree)
|
||||
|
||||
val left = append (start, finish, left)
|
||||
|
||||
val rightStartRelative = getStartIdx right
|
||||
val rightStartAbsolute = rightStartRelative + finish
|
||||
val difference = rightStartAbsolute - matchAfterFinish
|
||||
val right = decrementBy (difference, right)
|
||||
in
|
||||
merge (left, right)
|
||||
end
|
||||
end
|
||||
|
||||
fun extendExistingMatch (start, newFinish, tree) =
|
||||
let
|
||||
val matchAfterFinish = nextMatch (newFinish, tree, 1)
|
||||
val left = splitLeft (start, tree)
|
||||
val left = append (start, newFinish, left)
|
||||
in
|
||||
if matchAfterFinish <= newFinish then
|
||||
(* no match after newFinish, so we can return 'left'
|
||||
* which has the newFinish appended *)
|
||||
left
|
||||
else
|
||||
let
|
||||
val right = splitRight (newFinish, tree)
|
||||
|
||||
val leftFinish = getFinishIdx left
|
||||
val rightStartRelative = getStartIdx right
|
||||
|
||||
val rightStartAbsolute = rightStartRelative + leftFinish
|
||||
val difference = rightStartAbsolute - matchAfterFinish
|
||||
val right = decrementBy (difference, right)
|
||||
in
|
||||
merge (left, right)
|
||||
end
|
||||
end
|
||||
|
||||
(* functions only for testing *)
|
||||
fun childrenHaveSameDepth (pos, nodes, expectedDepth) =
|
||||
if pos = Vector.length nodes then
|
||||
true
|
||||
else
|
||||
let
|
||||
val node = Vector.sub (nodes, pos)
|
||||
in
|
||||
if allLeavesAtSameDepth node then
|
||||
let
|
||||
val nodeDepth = countDepth node
|
||||
in
|
||||
if nodeDepth = expectedDepth then
|
||||
childrenHaveSameDepth (pos + 1, nodes, expectedDepth)
|
||||
else
|
||||
false
|
||||
end
|
||||
else
|
||||
false
|
||||
end
|
||||
|
||||
and allLeavesAtSameDepth tree =
|
||||
case tree of
|
||||
BRANCH (nodes, _) =>
|
||||
let
|
||||
val expectedDepth = countDepth (Vector.sub (nodes, 0))
|
||||
in
|
||||
childrenHaveSameDepth (0, nodes, expectedDepth)
|
||||
end
|
||||
| LEAF _ => true
|
||||
|
||||
fun fromListLoop (lst, acc) =
|
||||
case lst of
|
||||
{start, finish} :: tl =>
|
||||
let
|
||||
val acc = append (start, finish, acc)
|
||||
in
|
||||
fromListLoop (tl, acc)
|
||||
end
|
||||
| [] => acc
|
||||
|
||||
fun fromList coords = fromListLoop (coords, empty)
|
||||
|
||||
fun toListLoop (tree, acc) =
|
||||
case tree of
|
||||
BRANCH (nodes, _) =>
|
||||
let
|
||||
fun branchLoop (pos, acc) =
|
||||
if pos = Vector.length nodes then
|
||||
acc
|
||||
else
|
||||
let
|
||||
val acc = toListLoop (Vector.sub (nodes, pos), acc)
|
||||
in
|
||||
branchLoop (pos + 1, acc)
|
||||
end
|
||||
in
|
||||
branchLoop (0, acc)
|
||||
end
|
||||
| LEAF (items, _) =>
|
||||
let
|
||||
fun itemLoop (pos, acc, offset) =
|
||||
if pos = Vector.length items then
|
||||
acc
|
||||
else
|
||||
let
|
||||
val {start, finish} = Vector.sub (items, pos)
|
||||
val item = {start = start + offset, finish = finish + offset}
|
||||
in
|
||||
itemLoop (pos + 1, item :: acc, offset)
|
||||
end
|
||||
|
||||
val offset =
|
||||
case acc of
|
||||
{finish, ...} :: _ => finish
|
||||
| [] => 0
|
||||
in
|
||||
itemLoop (0, acc, offset)
|
||||
end
|
||||
|
||||
fun toList tree =
|
||||
let
|
||||
val result = toListLoop (tree, [])
|
||||
in
|
||||
List.rev result
|
||||
end
|
||||
end
|
||||
41
shf/fcore/pipe-cursor.sml
Normal file
41
shf/fcore/pipe-cursor.sml
Normal file
@@ -0,0 +1,41 @@
|
||||
structure PipeCursor =
|
||||
struct
|
||||
fun xToNdc (xOffset, xpos, scale, halfWidth) =
|
||||
((xpos * scale + xOffset) - halfWidth) / halfWidth
|
||||
|
||||
fun yToNdc (yOffset, ypos, scale, halfHeight) =
|
||||
~(((ypos * scale + yOffset) - halfHeight) / halfHeight)
|
||||
|
||||
fun lerp (xOffset: Real32.real, yOffset, z, scale, windowWidth, windowHeight, r, g, b) =
|
||||
let
|
||||
val halfWidth = windowWidth / 2.0
|
||||
val halfHeight = windowHeight / 2.0
|
||||
in
|
||||
#[
|
||||
xToNdc (xOffset, 0.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 13.000000000000000, scale, halfHeight),
|
||||
z,
|
||||
r, g, b,
|
||||
xToNdc (xOffset, 1.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 13.000000000000000, scale, halfHeight),
|
||||
z,
|
||||
r, g, b,
|
||||
xToNdc (xOffset, 0.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 0.000000000000000, scale, halfHeight),
|
||||
z,
|
||||
r, g, b,
|
||||
xToNdc (xOffset, 0.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 0.000000000000000, scale, halfHeight),
|
||||
z,
|
||||
r, g, b,
|
||||
xToNdc (xOffset, 1.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 13.000000000000000, scale, halfHeight),
|
||||
z,
|
||||
r, g, b,
|
||||
xToNdc (xOffset, 1.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 0.000000000000000, scale, halfHeight),
|
||||
z,
|
||||
r, g, b
|
||||
]
|
||||
end
|
||||
end
|
||||
35
shf/fcore/rect.sml
Normal file
35
shf/fcore/rect.sml
Normal file
@@ -0,0 +1,35 @@
|
||||
structure Rect =
|
||||
struct
|
||||
fun xToNdc (xOffset, xpos, scale, halfWidth) =
|
||||
((xpos * scale + xOffset) - halfWidth) / halfWidth
|
||||
|
||||
fun yToNdc (yOffset, ypos, scale, halfHeight) =
|
||||
~(((ypos * scale + yOffset) - halfHeight) / halfHeight)
|
||||
|
||||
fun lerp (xOffset: Real32.real, yOffset, z, scale, windowWidth, windowHeight, r, g, b) =
|
||||
let
|
||||
val halfWidth = windowWidth / 2.0
|
||||
val halfHeight = windowHeight / 2.0
|
||||
in
|
||||
#[
|
||||
xToNdc (xOffset, 0.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 13.000000000000000, scale, halfHeight),
|
||||
z, r, g, b,
|
||||
xToNdc (xOffset, 7.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 13.000000000000000, scale, halfHeight),
|
||||
z, r, g, b,
|
||||
xToNdc (xOffset, 0.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 0.000000000000000, scale, halfHeight),
|
||||
z, r, g, b,
|
||||
xToNdc (xOffset, 0.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 0.000000000000000, scale, halfHeight),
|
||||
z, r, g, b,
|
||||
xToNdc (xOffset, 7.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 13.000000000000000, scale, halfHeight),
|
||||
z, r, g, b,
|
||||
xToNdc (xOffset, 7.000000000000000, scale, halfWidth),
|
||||
yToNdc (yOffset, 0.000000000000000, scale, halfHeight),
|
||||
z, r, g, b
|
||||
]
|
||||
end
|
||||
end
|
||||
928
shf/fcore/search-list/dfa-gen.sml
Normal file
928
shf/fcore/search-list/dfa-gen.sml
Normal file
@@ -0,0 +1,928 @@
|
||||
signature DFA_GEN_PARAMS =
|
||||
sig
|
||||
val endMarker: char
|
||||
val charIsEqual: char * char -> bool
|
||||
end
|
||||
|
||||
signature DFA_GEN =
|
||||
sig
|
||||
type dfa = int vector vector
|
||||
type dfa_state = int
|
||||
|
||||
val fromString: string -> dfa
|
||||
|
||||
val nextState: dfa * dfa_state * char -> dfa_state
|
||||
val isFinal: dfa * dfa_state -> bool
|
||||
val isDead: dfa_state -> bool
|
||||
|
||||
val matchString: dfa * string -> (int * int) list
|
||||
end
|
||||
|
||||
functor MakeDfaGen(Fn: DFA_GEN_PARAMS): DFA_GEN =
|
||||
struct
|
||||
datatype parse_tree =
|
||||
CHAR_LITERAL of {char: char, position: int}
|
||||
| WILDCARD of int
|
||||
| IS_ANY_CHARACTER of {chars: char vector, position: int}
|
||||
| NOT_ANY_CHARACTER of {chars: char vector, position: int}
|
||||
| CONCAT of
|
||||
{l: parse_tree, r: parse_tree, leftMaxState: int, rightMaxState: int}
|
||||
| ALTERNATION of
|
||||
{l: parse_tree, r: parse_tree, leftMaxState: int, rightMaxState: int}
|
||||
| ZERO_OR_ONE of parse_tree
|
||||
| ZERO_OR_MORE of parse_tree
|
||||
| ONE_OR_MORE of parse_tree
|
||||
| GROUP of parse_tree
|
||||
|
||||
fun isNullable tree =
|
||||
case tree of
|
||||
CHAR_LITERAL _ => false
|
||||
| WILDCARD _ => false
|
||||
| IS_ANY_CHARACTER _ => false
|
||||
| NOT_ANY_CHARACTER _ => false
|
||||
|
||||
| CONCAT {l, r, ...} => isNullable l andalso isNullable r
|
||||
| ALTERNATION {l, r, ...} => isNullable l orelse isNullable r
|
||||
|
||||
| ZERO_OR_ONE _ => true
|
||||
| ZERO_OR_MORE _ => true
|
||||
| ONE_OR_MORE regex => isNullable regex
|
||||
|
||||
| GROUP regex => isNullable regex
|
||||
|
||||
fun firstpos (tree, acc) =
|
||||
case tree of
|
||||
CHAR_LITERAL {position, ...} => position :: acc
|
||||
| IS_ANY_CHARACTER {position, ...} => position :: acc
|
||||
| NOT_ANY_CHARACTER {position, ...} => position :: acc
|
||||
| WILDCARD i => i :: acc
|
||||
|
||||
| CONCAT {l, r, ...} =>
|
||||
if isNullable l then
|
||||
let val acc = firstpos (l, acc)
|
||||
in firstpos (r, acc)
|
||||
end
|
||||
else
|
||||
firstpos (l, acc)
|
||||
| ALTERNATION {l, r, ...} =>
|
||||
let val acc = firstpos (l, acc)
|
||||
in firstpos (r, acc)
|
||||
end
|
||||
|
||||
| ZERO_OR_ONE regex => firstpos (regex, acc)
|
||||
| ZERO_OR_MORE regex => firstpos (regex, acc)
|
||||
| ONE_OR_MORE regex => firstpos (regex, acc)
|
||||
| GROUP regex => firstpos (regex, acc)
|
||||
|
||||
fun lastpos (tree, acc) =
|
||||
case tree of
|
||||
CHAR_LITERAL {position, ...} => position :: acc
|
||||
| IS_ANY_CHARACTER {position, ...} => position :: acc
|
||||
| NOT_ANY_CHARACTER {position, ...} => position :: acc
|
||||
| WILDCARD i => i :: acc
|
||||
|
||||
| CONCAT {l, r, ...} =>
|
||||
if isNullable r then
|
||||
let val acc = lastpos (l, acc)
|
||||
in lastpos (r, acc)
|
||||
end
|
||||
else
|
||||
lastpos (r, acc)
|
||||
| ALTERNATION {l, r, ...} =>
|
||||
let val acc = lastpos (l, acc)
|
||||
in lastpos (r, acc)
|
||||
end
|
||||
|
||||
| ZERO_OR_ONE regex => lastpos (regex, acc)
|
||||
| ZERO_OR_MORE regex => lastpos (regex, acc)
|
||||
| ONE_OR_MORE regex => lastpos (regex, acc)
|
||||
| GROUP regex => lastpos (regex, acc)
|
||||
|
||||
structure Set =
|
||||
struct
|
||||
datatype 'a set = BRANCH of 'a set * int * 'a * 'a set | LEAF
|
||||
|
||||
fun isEmpty set =
|
||||
case set of
|
||||
BRANCH _ => false
|
||||
| LEAF => true
|
||||
|
||||
fun insertOrReplace (newKey, newVal, tree) =
|
||||
case tree of
|
||||
BRANCH (l, curKey, curVal, r) =>
|
||||
if newKey > curKey then
|
||||
let val r = insertOrReplace (newKey, newVal, r)
|
||||
in BRANCH (l, curKey, curVal, r)
|
||||
end
|
||||
else if newKey < curKey then
|
||||
let val l = insertOrReplace (newKey, newVal, l)
|
||||
in BRANCH (l, curKey, curVal, r)
|
||||
end
|
||||
else
|
||||
BRANCH (l, newKey, newVal, r)
|
||||
| LEAF => BRANCH (LEAF, newKey, newVal, LEAF)
|
||||
|
||||
fun addFromList (lst, tree) =
|
||||
case lst of
|
||||
[] => tree
|
||||
| k :: tl =>
|
||||
let val tree = insertOrReplace (k, (), tree)
|
||||
in addFromList (tl, tree)
|
||||
end
|
||||
|
||||
fun getOrDefault (findKey, tree, default) =
|
||||
case tree of
|
||||
BRANCH (l, curKey, curVal, r) =>
|
||||
if findKey > curKey then getOrDefault (findKey, r, default)
|
||||
else if findKey < curKey then getOrDefault (findKey, l, default)
|
||||
else curVal
|
||||
| LEAF => default
|
||||
|
||||
fun helpToList (tree, acc) =
|
||||
case tree of
|
||||
BRANCH (l, curKey, curVal, r) =>
|
||||
let
|
||||
val acc = helpToList (r, acc)
|
||||
val acc = (curKey, curVal) :: acc
|
||||
in
|
||||
helpToList (l, acc)
|
||||
end
|
||||
| LEAF => acc
|
||||
|
||||
fun toList tree = helpToList (tree, [])
|
||||
|
||||
fun helpKeysToList (tree, acc) =
|
||||
case tree of
|
||||
BRANCH (l, curKey, _, r) =>
|
||||
let
|
||||
val acc = helpKeysToList (r, acc)
|
||||
val acc = curKey :: acc
|
||||
in
|
||||
helpKeysToList (l, acc)
|
||||
end
|
||||
| LEAF => acc
|
||||
|
||||
fun keysToList tree = helpKeysToList (tree, [])
|
||||
|
||||
fun helpValuesToList (tree, acc) =
|
||||
case tree of
|
||||
BRANCH (l, _, v, r) =>
|
||||
let
|
||||
val acc = helpValuesToList (r, acc)
|
||||
val acc = v :: acc
|
||||
in
|
||||
helpValuesToList (l, acc)
|
||||
end
|
||||
| LEAF => acc
|
||||
|
||||
fun valuesToList tree = helpValuesToList (tree, [])
|
||||
|
||||
fun map (f, tree) =
|
||||
case tree of
|
||||
BRANCH (l, key, value, r) =>
|
||||
let
|
||||
val r = map (f, r)
|
||||
val l = map (f, l)
|
||||
val value = f value
|
||||
in
|
||||
BRANCH (l, key, value, r)
|
||||
end
|
||||
| LEAF => LEAF
|
||||
|
||||
fun foldl (f, tree, acc) =
|
||||
case tree of
|
||||
BRANCH (l, k, v, r) =>
|
||||
let
|
||||
val acc = foldl (f, l, acc)
|
||||
val acc = f (v, acc)
|
||||
in
|
||||
foldl (f, r, acc)
|
||||
end
|
||||
| LEAF => acc
|
||||
|
||||
fun foldr (f, tree, acc) =
|
||||
case tree of
|
||||
BRANCH (l, k, v, r) =>
|
||||
let
|
||||
val acc = foldr (f, r, acc)
|
||||
val acc = f (v, acc)
|
||||
in
|
||||
foldr (f, l, acc)
|
||||
end
|
||||
| LEAF => acc
|
||||
end
|
||||
|
||||
structure ParseDfa =
|
||||
struct
|
||||
(* parsing through precedence climbing algorithm. *)
|
||||
val postfixLevel = 1
|
||||
val concatLevel = 2
|
||||
val altLevel = 3
|
||||
|
||||
local
|
||||
fun loop (pos, str, openParens, closeParens) =
|
||||
if pos = String.size str then
|
||||
NONE
|
||||
else
|
||||
case String.sub (str, pos) of
|
||||
#"(" => loop (pos + 1, str, openParens + 1, closeParens)
|
||||
| #")" =>
|
||||
if closeParens + 1 = openParens then SOME pos
|
||||
else loop (pos + 1, str, openParens, closeParens + 1)
|
||||
| _ => loop (pos + 1, str, openParens, closeParens)
|
||||
in
|
||||
fun getRightParenIdx (pos, str) = loop (pos, str, 1, 0)
|
||||
end
|
||||
|
||||
(* assumes previous char is a backslash *)
|
||||
fun isValidEscapeSequence chr =
|
||||
case chr of
|
||||
(* regex metacharacters *)
|
||||
#"(" => (true, chr)
|
||||
| #")" => (true, chr)
|
||||
| #"[" => (true, chr)
|
||||
| #"]" => (true, chr)
|
||||
| #"+" => (true, chr)
|
||||
| #"*" => (true, chr)
|
||||
| #"|" => (true, chr)
|
||||
| #"?" => (true, chr)
|
||||
| #"." => (true, chr)
|
||||
| #"-" => (true, chr)
|
||||
(* standard escape sequences *)
|
||||
| #"a" => (true, #"\a")
|
||||
| #"b" => (true, #"\b")
|
||||
| #"t" => (true, #"\t")
|
||||
| #"n" => (true, #"\n")
|
||||
| #"v" => (true, #"\v")
|
||||
| #"f" => (true, #"\f")
|
||||
| #"r" => (true, #"\r")
|
||||
| #"\\" => (true, chr)
|
||||
| _ => (false, chr)
|
||||
|
||||
fun getCharsBetween (lowChr, highChr, acc) =
|
||||
if lowChr = highChr then
|
||||
highChr :: acc
|
||||
else
|
||||
let
|
||||
val acc = lowChr :: acc
|
||||
val lowChr = Char.succ lowChr
|
||||
in
|
||||
getCharsBetween (lowChr, highChr, acc)
|
||||
end
|
||||
|
||||
fun getCharsInBrackets (pos, str, acc) =
|
||||
if pos = String.size str then
|
||||
NONE
|
||||
else
|
||||
case String.sub (str, pos) of
|
||||
#"\\" =>
|
||||
(* escape sequences *)
|
||||
if pos + 1 = String.size str then
|
||||
NONE
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, pos + 1)
|
||||
val (isValid, chr) = isValidEscapeSequence chr
|
||||
in
|
||||
if isValid then
|
||||
(* Edge case:
|
||||
* We have to check if there is a char range like a-z,
|
||||
* and if there is,
|
||||
* we have to check if the second char in the range
|
||||
* is another escaped-character *)
|
||||
if
|
||||
pos + 2 < String.size str
|
||||
andalso String.sub (str, pos + 2) = #"-"
|
||||
andalso pos + 3 < String.size str
|
||||
then
|
||||
(* we do have a character range,
|
||||
* which may possibly be escaped *)
|
||||
case String.sub (str, pos + 3) of
|
||||
#"(" => NONE
|
||||
| #")" => NONE
|
||||
| #"[" => NONE
|
||||
| #"]" => NONE
|
||||
| #"+" => NONE
|
||||
| #"*" => NONE
|
||||
| #"|" => NONE
|
||||
| #"?" => NONE
|
||||
| #"." => NONE
|
||||
| #"-" => NONE
|
||||
| #"\\" =>
|
||||
if pos + 4 < String.size str then
|
||||
let
|
||||
val chr2 = String.sub (str, pos + 4)
|
||||
val (isValid, chr2) = isValidEscapeSequence chr2
|
||||
val acc =
|
||||
if chr < chr2 then
|
||||
getCharsBetween (chr, chr2, acc)
|
||||
else
|
||||
getCharsBetween (chr2, chr, acc)
|
||||
in
|
||||
getCharsInBrackets (pos + 5, str, acc)
|
||||
end
|
||||
else
|
||||
NONE
|
||||
| chr2 =>
|
||||
let
|
||||
val acc =
|
||||
if chr < chr2 then getCharsBetween (chr, chr2, acc)
|
||||
else getCharsBetween (chr2, chr, acc)
|
||||
in
|
||||
getCharsInBrackets (pos + 4, str, acc)
|
||||
end
|
||||
else
|
||||
(* no character range we have to check *)
|
||||
getCharsInBrackets (pos + 2, str, chr :: acc)
|
||||
else
|
||||
NONE
|
||||
end
|
||||
| #"]" =>
|
||||
let val chars = Vector.fromList acc
|
||||
in SOME (pos + 1, chars)
|
||||
end
|
||||
| chr =>
|
||||
if
|
||||
pos + 1 < String.size str andalso String.sub (str, pos + 1) = #"-"
|
||||
andalso pos + 2 < String.size str
|
||||
then
|
||||
(* handle character ranges like a-z.
|
||||
* There are edge cases regarding
|
||||
* the second character in the range.
|
||||
* We have to check that any unescaped metacharacters
|
||||
* return an invalid parse state.
|
||||
* We also have to unescape any escape sequences.
|
||||
* *)
|
||||
case String.sub (str, pos + 2) of
|
||||
#"\\" =>
|
||||
(* second char contains an escape sequence *)
|
||||
if pos + 3 < String.size str then
|
||||
let
|
||||
val chr2 = String.sub (str, pos + 3)
|
||||
val (isValid, chr2) = isValidEscapeSequence chr2
|
||||
val acc =
|
||||
if chr < chr2 then getCharsBetween (chr, chr2, acc)
|
||||
else getCharsBetween (chr2, chr, acc)
|
||||
in
|
||||
if isValid then getCharsInBrackets (pos + 4, str, acc)
|
||||
else NONE
|
||||
end
|
||||
else
|
||||
NONE
|
||||
| #"(" => NONE
|
||||
| #")" => NONE
|
||||
| #"[" => NONE
|
||||
| #"]" => NONE
|
||||
| #"+" => NONE
|
||||
| #"*" => NONE
|
||||
| #"|" => NONE
|
||||
| #"?" => NONE
|
||||
| #"." => NONE
|
||||
| #"-" => NONE
|
||||
| chr2 =>
|
||||
(* valid char range *)
|
||||
let
|
||||
val acc =
|
||||
if chr < chr2 then getCharsBetween (chr, chr2, acc)
|
||||
else getCharsBetween (chr2, chr, acc)
|
||||
in
|
||||
getCharsInBrackets (pos + 3, str, acc)
|
||||
end
|
||||
else
|
||||
getCharsInBrackets (pos + 1, str, chr :: acc)
|
||||
|
||||
fun parseCharacterClass (pos, str, stateNum) =
|
||||
case getCharsInBrackets (pos, str, []) of
|
||||
SOME (pos, chars) =>
|
||||
let
|
||||
val node = IS_ANY_CHARACTER {chars = chars, position = stateNum + 1}
|
||||
in
|
||||
SOME (pos, node, stateNum + 1)
|
||||
end
|
||||
| NONE => NONE
|
||||
|
||||
fun parseNegateCharacterClass (pos, str, stateNum) =
|
||||
case getCharsInBrackets (pos, str, []) of
|
||||
SOME (pos, chars) =>
|
||||
let
|
||||
val node =
|
||||
NOT_ANY_CHARACTER {chars = chars, position = stateNum + 1}
|
||||
in
|
||||
SOME (pos, node, stateNum + 1)
|
||||
end
|
||||
| NONE => NONE
|
||||
|
||||
fun computeAtom (pos, str, stateNum) =
|
||||
if pos = String.size str then
|
||||
NONE
|
||||
else
|
||||
case String.sub (str, pos) of
|
||||
#"(" =>
|
||||
(case getRightParenIdx (pos + 1, str) of
|
||||
SOME groupEndIdx =>
|
||||
let
|
||||
val substr = String.substring
|
||||
(str, pos + 1, groupEndIdx - pos - 1)
|
||||
in
|
||||
case parse (substr, stateNum) of
|
||||
SOME (rhs, stateNum) =>
|
||||
SOME (groupEndIdx + 1, rhs, stateNum)
|
||||
| NONE => NONE
|
||||
end
|
||||
| NONE => NONE)
|
||||
| #"\\" =>
|
||||
(* escape sequences *)
|
||||
if pos + 1 = String.size str then
|
||||
NONE
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, pos + 1)
|
||||
val (isValid, chr) = isValidEscapeSequence chr
|
||||
in
|
||||
if Fn.charIsEqual (chr, Fn.endMarker) then
|
||||
NONE
|
||||
else if isValid then
|
||||
let
|
||||
val chr = CHAR_LITERAL {char = chr, position = stateNum + 1}
|
||||
in
|
||||
SOME (pos + 2, chr, stateNum + 1)
|
||||
end
|
||||
else
|
||||
NONE
|
||||
end
|
||||
| #"." =>
|
||||
let val w = WILDCARD (stateNum + 1)
|
||||
in SOME (pos + 1, w, stateNum + 1)
|
||||
end
|
||||
| #"[" =>
|
||||
if pos + 1 = String.size str then
|
||||
NONE
|
||||
else if String.sub (str, pos + 1) = #"^" then
|
||||
parseNegateCharacterClass (pos + 2, str, stateNum)
|
||||
else
|
||||
parseCharacterClass (pos + 1, str, stateNum)
|
||||
| #")" => NONE
|
||||
| #"]" => NONE
|
||||
| #"+" => NONE
|
||||
| #"*" => NONE
|
||||
| #"|" => NONE
|
||||
| #"?" => NONE
|
||||
| #"-" => NONE
|
||||
| chr =>
|
||||
if Fn.charIsEqual (chr, Fn.endMarker) then
|
||||
NONE
|
||||
else
|
||||
let val chr = CHAR_LITERAL {char = chr, position = stateNum + 1}
|
||||
in SOME (pos + 1, chr, stateNum + 1)
|
||||
end
|
||||
|
||||
and climb (pos, str, lhs, level, stateNum) : (int * parse_tree * int) option =
|
||||
if pos = String.size str then
|
||||
SOME (pos, lhs, stateNum)
|
||||
else
|
||||
case String.sub (str, pos) of
|
||||
#"|" =>
|
||||
if level < altLevel then
|
||||
SOME (pos, lhs, stateNum)
|
||||
else if pos + 1 < String.size str then
|
||||
let
|
||||
val chr = String.sub (str, pos + 1)
|
||||
val chr = CHAR_LITERAL {char = chr, position = stateNum + 1}
|
||||
in
|
||||
case climb (pos + 2, str, chr, altLevel, stateNum + 1) of
|
||||
SOME (pos, rhs, rightStateNum) =>
|
||||
let
|
||||
val result = ALTERNATION
|
||||
{ l = lhs
|
||||
, r = rhs
|
||||
, leftMaxState = stateNum
|
||||
, rightMaxState = rightStateNum
|
||||
}
|
||||
in
|
||||
SOME (pos, result, rightStateNum)
|
||||
end
|
||||
| NONE => NONE
|
||||
end
|
||||
else
|
||||
NONE
|
||||
| #"?" =>
|
||||
if level < postfixLevel then
|
||||
SOME (pos, lhs, stateNum)
|
||||
else
|
||||
let val lhs = ZERO_OR_ONE lhs
|
||||
in climb (pos + 1, str, lhs, postfixLevel, stateNum)
|
||||
end
|
||||
| #"*" =>
|
||||
if level < postfixLevel then
|
||||
SOME (pos, lhs, stateNum)
|
||||
else
|
||||
let val lhs = ZERO_OR_MORE lhs
|
||||
in climb (pos + 1, str, lhs, postfixLevel, stateNum)
|
||||
end
|
||||
| #"+" =>
|
||||
if level < postfixLevel then
|
||||
SOME (pos, lhs, stateNum)
|
||||
else
|
||||
let val lhs = ONE_OR_MORE lhs
|
||||
in climb (pos + 1, str, lhs, postfixLevel, stateNum)
|
||||
end
|
||||
| chr =>
|
||||
if level < concatLevel then
|
||||
SOME (pos, lhs, stateNum)
|
||||
else
|
||||
case computeAtom (pos, str, stateNum) of
|
||||
SOME (nextPos, curAtom, atomStateNum) =>
|
||||
(case climb (nextPos, str, curAtom, concatLevel, atomStateNum) of
|
||||
SOME (pos, rhs, rightStateNum) =>
|
||||
let
|
||||
val result = CONCAT
|
||||
{ l = lhs
|
||||
, r = rhs
|
||||
, leftMaxState = stateNum
|
||||
, rightMaxState = rightStateNum
|
||||
}
|
||||
in
|
||||
SOME (pos, result, rightStateNum)
|
||||
end
|
||||
| NONE => NONE)
|
||||
| NONE => NONE
|
||||
|
||||
and loop (pos, str, ast, stateNum) =
|
||||
if pos = String.size str then
|
||||
SOME (ast, stateNum)
|
||||
else
|
||||
case climb (pos, str, ast, altLevel, stateNum) of
|
||||
SOME (pos, ast, stateNum) => loop (pos, str, ast, stateNum)
|
||||
| NONE => NONE
|
||||
|
||||
and parse (str, stateNum) =
|
||||
if String.size str > 0 then
|
||||
case computeAtom (0, str, stateNum) of
|
||||
SOME (nextPos, lhs, stateNum) => loop (nextPos, str, lhs, stateNum)
|
||||
| NONE => NONE
|
||||
else
|
||||
NONE
|
||||
end
|
||||
|
||||
structure ToDfa =
|
||||
struct
|
||||
type dstate_element = {marked: bool, transitions: int list}
|
||||
type dstate_vec = dstate_element vector
|
||||
|
||||
fun chrExistsInVec (idx, vec, curChr) =
|
||||
if idx = Vector.length vec then
|
||||
false
|
||||
else
|
||||
let
|
||||
val idxChr = Vector.sub (vec, idx)
|
||||
in
|
||||
Fn.charIsEqual (idxChr, curChr)
|
||||
orelse chrExistsInVec (idx + 1, vec, curChr)
|
||||
end
|
||||
|
||||
fun addKeysToFollowSet (lst, addSet, followSet) =
|
||||
case lst of
|
||||
hd :: tl =>
|
||||
let
|
||||
val currentFollows = Set.getOrDefault (hd, followSet, [])
|
||||
val updatedFollows = Set.addFromList (currentFollows, addSet)
|
||||
val updatedFollows: int list = Set.keysToList updatedFollows
|
||||
val followSet = Set.insertOrReplace (hd, updatedFollows, followSet)
|
||||
in
|
||||
addKeysToFollowSet (tl, addSet, followSet)
|
||||
end
|
||||
| [] => followSet
|
||||
|
||||
fun addToFollowSet (tree, followSet) =
|
||||
case tree of
|
||||
WILDCARD _ => followSet
|
||||
| CHAR_LITERAL {char, position} =>
|
||||
(* we add the endMarker and its position to the followSet *)
|
||||
if char = Fn.endMarker then
|
||||
Set.insertOrReplace (position, [Char.ord Fn.endMarker], followSet)
|
||||
else
|
||||
followSet
|
||||
| IS_ANY_CHARACTER _ => followSet
|
||||
| NOT_ANY_CHARACTER _ => followSet
|
||||
| CONCAT {l, r, ...} =>
|
||||
let
|
||||
val followSet = addToFollowSet (l, followSet)
|
||||
val followSet = addToFollowSet (r, followSet)
|
||||
|
||||
val lpOfLeft = lastpos (l, [])
|
||||
val fpOfRight = firstpos (r, [])
|
||||
val fpOfRight = Set.addFromList (fpOfRight, Set.LEAF)
|
||||
in
|
||||
addKeysToFollowSet (lpOfLeft, fpOfRight, followSet)
|
||||
end
|
||||
| ALTERNATION {l, r, ...} =>
|
||||
let val followSet = addToFollowSet (l, followSet)
|
||||
in addToFollowSet (r, followSet)
|
||||
end
|
||||
| ZERO_OR_MORE child =>
|
||||
let
|
||||
val followSet = addToFollowSet (child, followSet)
|
||||
val fp = firstpos (child, [])
|
||||
val fp = Set.addFromList (fp, Set.LEAF)
|
||||
val lp = lastpos (child, [])
|
||||
in
|
||||
addKeysToFollowSet (lp, fp, followSet)
|
||||
end
|
||||
| ONE_OR_MORE child =>
|
||||
let
|
||||
val followSet = addToFollowSet (child, followSet)
|
||||
val lp = lastpos (child, [])
|
||||
val fp = firstpos (child, [])
|
||||
val fp = Set.addFromList (fp, Set.LEAF)
|
||||
in
|
||||
addKeysToFollowSet (lp, fp, followSet)
|
||||
end
|
||||
| ZERO_OR_ONE child => addToFollowSet (child, followSet)
|
||||
| GROUP child => addToFollowSet (child, followSet)
|
||||
|
||||
fun appendIfNew (pos, dstates, newStates) =
|
||||
if pos = Vector.length dstates then
|
||||
let
|
||||
val record = {transitions = newStates, marked = false}
|
||||
val dstates = Vector.concat [dstates, Vector.fromList [record]]
|
||||
in
|
||||
(pos, dstates)
|
||||
end
|
||||
else
|
||||
let
|
||||
val {transitions: int list, marked = _} = Vector.sub (dstates, pos)
|
||||
in
|
||||
if transitions = newStates then (pos, dstates)
|
||||
else appendIfNew (pos + 1, dstates, newStates)
|
||||
end
|
||||
|
||||
fun getUnmarkedTransitionsIfExists (pos, dstates) =
|
||||
if pos = Vector.length dstates then
|
||||
NONE
|
||||
else
|
||||
let
|
||||
val record: dstate_element = Vector.sub (dstates, pos)
|
||||
in
|
||||
if #marked record then
|
||||
getUnmarkedTransitionsIfExists (pos + 1, dstates)
|
||||
else
|
||||
SOME (pos, #transitions record)
|
||||
end
|
||||
|
||||
fun isCharMatch (regex, pos, curChr) =
|
||||
case regex of
|
||||
CHAR_LITERAL {char, ...} => Fn.charIsEqual (char, curChr)
|
||||
| WILDCARD _ => true
|
||||
| IS_ANY_CHARACTER {chars, ...} => chrExistsInVec (0, chars, curChr)
|
||||
| NOT_ANY_CHARACTER {chars, ...} =>
|
||||
let val charIsValid = chrExistsInVec (0, chars, curChr)
|
||||
in not charIsValid
|
||||
end
|
||||
| ALTERNATION {l, r, leftMaxState, ...} =>
|
||||
if pos > leftMaxState then isCharMatch (r, pos, curChr)
|
||||
else isCharMatch (l, pos, curChr)
|
||||
| CONCAT {l, r, leftMaxState, ...} =>
|
||||
if pos > leftMaxState then isCharMatch (r, pos, curChr)
|
||||
else isCharMatch (l, pos, curChr)
|
||||
| ZERO_OR_ONE child => isCharMatch (child, pos, curChr)
|
||||
| ZERO_OR_MORE child => isCharMatch (child, pos, curChr)
|
||||
| ONE_OR_MORE child => isCharMatch (child, pos, curChr)
|
||||
| GROUP child => isCharMatch (child, pos, curChr)
|
||||
|
||||
fun positionsThatCorrespondToChar
|
||||
(char, curStates, regex, acc, followSet, hasAnyMatch) =
|
||||
case curStates of
|
||||
[] => List.concat (Set.valuesToList acc)
|
||||
| pos :: tl =>
|
||||
if isCharMatch (regex, pos, Char.chr char) then
|
||||
let
|
||||
(* get union of new and previous follows *)
|
||||
val prevFollows = Set.getOrDefault (char, acc, [])
|
||||
val newFollows = Set.getOrDefault (pos, followSet, [])
|
||||
|
||||
val tempSet = Set.addFromList (prevFollows, Set.LEAF)
|
||||
val tempSet = Set.addFromList (newFollows, tempSet)
|
||||
val allFollowList = Set.keysToList tempSet
|
||||
|
||||
(* store union of new and previous follows so far *)
|
||||
val acc = Set.insertOrReplace (char, allFollowList, acc)
|
||||
in
|
||||
positionsThatCorrespondToChar
|
||||
(char, tl, regex, acc, followSet, true)
|
||||
end
|
||||
else
|
||||
positionsThatCorrespondToChar
|
||||
(char, tl, regex, acc, followSet, hasAnyMatch)
|
||||
|
||||
structure Dtran =
|
||||
struct
|
||||
(* vector, with idx corresponding to state in dstate,
|
||||
* an int key which corresponds to char's ascii code,
|
||||
* and an int value corresponding to state we will transition to *)
|
||||
type t = int Set.set vector
|
||||
|
||||
fun insert (dStateIdx, char, toStateIdx, dtran: t) =
|
||||
if dStateIdx = Vector.length dtran then
|
||||
let
|
||||
val el = Set.insertOrReplace (char, toStateIdx, Set.LEAF)
|
||||
val el = Vector.fromList [el]
|
||||
in
|
||||
Vector.concat [dtran, el]
|
||||
end
|
||||
else if dStateIdx < Vector.length dtran then
|
||||
let
|
||||
val el = Vector.sub (dtran, dStateIdx)
|
||||
val el = Set.insertOrReplace (char, toStateIdx, el)
|
||||
in
|
||||
Vector.update (dtran, dStateIdx, el)
|
||||
end
|
||||
else
|
||||
let
|
||||
val appendLength = dStateIdx - Vector.length dtran
|
||||
val appendVecs = Vector.tabulate (appendLength, fn _ => Set.LEAF)
|
||||
val dtran = Vector.concat [dtran, appendVecs]
|
||||
in
|
||||
insert (dStateIdx, char, toStateIdx, dtran)
|
||||
end
|
||||
end
|
||||
|
||||
fun convertChar
|
||||
( char
|
||||
, regex
|
||||
, dstates
|
||||
, dtran: Dtran.t
|
||||
, unmarkedState
|
||||
, unmarkedIdx
|
||||
, followSet
|
||||
, prevDstateLength
|
||||
) =
|
||||
if char < 0 then
|
||||
(dstates, dtran)
|
||||
else
|
||||
let
|
||||
val u = positionsThatCorrespondToChar
|
||||
(char, unmarkedState, regex, Set.LEAF, followSet, false)
|
||||
in
|
||||
case u of
|
||||
[] =>
|
||||
convertChar
|
||||
( char - 1
|
||||
, regex
|
||||
, dstates
|
||||
, dtran
|
||||
, unmarkedState
|
||||
, unmarkedIdx
|
||||
, followSet
|
||||
, prevDstateLength
|
||||
)
|
||||
| _ =>
|
||||
let
|
||||
(* dtran is idx -> char -> state_list map *)
|
||||
val (uIdx, dstates) = appendIfNew (0, dstates, u)
|
||||
val dtran = Dtran.insert (unmarkedIdx, char, uIdx, dtran)
|
||||
in
|
||||
convertChar
|
||||
( char - 1
|
||||
, regex
|
||||
, dstates
|
||||
, dtran
|
||||
, unmarkedState
|
||||
, unmarkedIdx
|
||||
, followSet
|
||||
, prevDstateLength
|
||||
)
|
||||
end
|
||||
end
|
||||
|
||||
fun convertLoop (regex, dstates, dtran, followSet) =
|
||||
case getUnmarkedTransitionsIfExists (0, dstates) of
|
||||
SOME (unmarkedIdx, unamarkedTransition) =>
|
||||
let
|
||||
(* mark transition *)
|
||||
val dstates =
|
||||
let
|
||||
val newMark = {marked = true, transitions = unamarkedTransition}
|
||||
in
|
||||
Vector.update (dstates, unmarkedIdx, newMark)
|
||||
end
|
||||
|
||||
val (dstates, dtran) = convertChar
|
||||
( 255
|
||||
, regex
|
||||
, dstates
|
||||
, dtran
|
||||
, unamarkedTransition
|
||||
, unmarkedIdx
|
||||
, followSet
|
||||
, Vector.length dstates
|
||||
)
|
||||
in
|
||||
convertLoop (regex, dstates, dtran, followSet)
|
||||
end
|
||||
| NONE =>
|
||||
Vector.map
|
||||
(fn set =>
|
||||
Vector.tabulate (256, fn i => Set.getOrDefault (i, set, ~1)))
|
||||
dtran
|
||||
|
||||
fun convert regex =
|
||||
let
|
||||
val followSet = addToFollowSet (regex, Set.LEAF)
|
||||
|
||||
(* get firstpos, sorted *)
|
||||
val first = firstpos (regex, [])
|
||||
val first = Set.addFromList (first, Set.LEAF)
|
||||
val first = Set.keysToList first
|
||||
|
||||
val dstates = Vector.fromList [{transitions = first, marked = false}]
|
||||
in
|
||||
convertLoop (regex, dstates, Vector.fromList [Set.LEAF], followSet)
|
||||
end
|
||||
end
|
||||
|
||||
fun fromString str =
|
||||
case ParseDfa.parse (str, 0) of
|
||||
SOME (ast, numStates) =>
|
||||
let
|
||||
val endMarker =
|
||||
CHAR_LITERAL {char = Fn.endMarker, position = numStates + 1}
|
||||
val ast = CONCAT
|
||||
{ l = ast
|
||||
, leftMaxState = numStates
|
||||
, r = endMarker
|
||||
, rightMaxState = numStates + 1
|
||||
}
|
||||
in
|
||||
ToDfa.convert ast
|
||||
end
|
||||
| NONE => Vector.fromList []
|
||||
|
||||
type dfa = int vector vector
|
||||
type dfa_state = int
|
||||
|
||||
fun nextState (dfa: dfa, curState: dfa_state, chr) =
|
||||
let val curTable = Vector.sub (dfa, curState)
|
||||
in Vector.sub (curTable, Char.ord chr)
|
||||
end
|
||||
|
||||
fun isFinal (dfa: dfa, curState: dfa_state) =
|
||||
curState <> ~1
|
||||
andalso
|
||||
let
|
||||
val curTable = Vector.sub (dfa, curState)
|
||||
val endMarkerCode = Char.ord Fn.endMarker
|
||||
in
|
||||
Vector.sub (curTable, endMarkerCode) <> ~1
|
||||
end
|
||||
|
||||
fun isDead (curState: dfa_state) = curState = ~1
|
||||
|
||||
fun helpMatchString (strPos, str, dfa, curState, startPos, prevFinalPos, acc) =
|
||||
if strPos = String.size str then
|
||||
let
|
||||
val acc =
|
||||
if prevFinalPos = ~1 then acc else (startPos, prevFinalPos) :: acc
|
||||
in
|
||||
List.rev acc
|
||||
end
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, strPos)
|
||||
val newState = nextState (dfa, curState, chr)
|
||||
val prevFinalPos =
|
||||
if isFinal (dfa, newState) then strPos else prevFinalPos
|
||||
in
|
||||
if isDead newState then
|
||||
if prevFinalPos = ~1 then
|
||||
(* restart from startPos *)
|
||||
helpMatchString (startPos + 1, str, dfa, 0, startPos + 1, ~1, acc)
|
||||
else
|
||||
let
|
||||
val acc = (startPos, prevFinalPos) :: acc
|
||||
in
|
||||
helpMatchString
|
||||
(prevFinalPos + 1, str, dfa, 0, prevFinalPos + 1, ~1, acc)
|
||||
end
|
||||
else
|
||||
helpMatchString
|
||||
(strPos + 1, str, dfa, newState, startPos, prevFinalPos, acc)
|
||||
end
|
||||
|
||||
fun matchString (dfa, string) =
|
||||
if Vector.length dfa = 0 then []
|
||||
else helpMatchString (0, string, dfa, 0, 0, ~1, [])
|
||||
end
|
||||
|
||||
structure CaseInsensitiveDfa =
|
||||
MakeDfaGen
|
||||
(struct
|
||||
val endMarker = #"\^@"
|
||||
fun charIsEqual (a: char, b: char) = Char.toLower a = Char.toLower b
|
||||
end)
|
||||
|
||||
structure CaseSensitiveDfa =
|
||||
MakeDfaGen
|
||||
(struct
|
||||
val endMarker = #"\^@"
|
||||
fun charIsEqual (a: char, b: char) = a = b
|
||||
end)
|
||||
254
shf/fcore/search-list/search-list.sml
Normal file
254
shf/fcore/search-list/search-list.sml
Normal file
@@ -0,0 +1,254 @@
|
||||
structure SearchList =
|
||||
struct
|
||||
structure Dfa = CaseInsensitiveDfa
|
||||
|
||||
fun buildLoop (idx, buffer, dfa, acc, curState, startPos, prevFinalPos) =
|
||||
let
|
||||
val buffer = LineGap.goToIdx (idx, buffer)
|
||||
in
|
||||
if idx = #textLength buffer then
|
||||
let
|
||||
val acc =
|
||||
if prevFinalPos < 0 then acc
|
||||
else PersistentVector.append (startPos, prevFinalPos, acc)
|
||||
in
|
||||
(buffer, acc)
|
||||
end
|
||||
else
|
||||
let
|
||||
val chr = LineGap.sub (idx, buffer)
|
||||
val newState = Dfa.nextState (dfa, curState, chr)
|
||||
val prevFinalPos =
|
||||
if Dfa.isFinal (dfa, newState) then idx else prevFinalPos
|
||||
in
|
||||
if Dfa.isDead newState then
|
||||
if prevFinalPos = ~1 then
|
||||
(* no match found: restart search from `startPos + 1` *)
|
||||
buildLoop (startPos + 1, buffer, dfa, acc, 0, startPos + 1, ~1)
|
||||
else
|
||||
(* match found: append and continue *)
|
||||
let
|
||||
val acc = PersistentVector.append (startPos, prevFinalPos, acc)
|
||||
|
||||
(* we start 1 idx after the final position we found *)
|
||||
val newStart = prevFinalPos + 1
|
||||
in
|
||||
buildLoop (newStart, buffer, dfa, acc, 0, newStart, ~1)
|
||||
end
|
||||
else
|
||||
buildLoop
|
||||
(idx + 1, buffer, dfa, acc, newState, startPos, prevFinalPos)
|
||||
end
|
||||
end
|
||||
|
||||
fun build (buffer, dfa) =
|
||||
if Vector.length dfa > 0 then
|
||||
let val buffer = LineGap.goToStart buffer
|
||||
in buildLoop (0, buffer, dfa, PersistentVector.empty, 0, 0, ~1)
|
||||
end
|
||||
else
|
||||
(buffer, PersistentVector.empty)
|
||||
|
||||
fun rangeLoop
|
||||
( dfa
|
||||
, bufferPos
|
||||
, buffer
|
||||
, finishIdx
|
||||
, searchList
|
||||
, curState
|
||||
, startPos
|
||||
, prevFinalPos
|
||||
) =
|
||||
if bufferPos = #textLength buffer orelse bufferPos > finishIdx then
|
||||
let
|
||||
val searchList =
|
||||
if prevFinalPos = ~1 then searchList
|
||||
else PersistentVector.append (startPos, prevFinalPos, searchList)
|
||||
in
|
||||
(buffer, searchList)
|
||||
end
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (bufferPos, buffer)
|
||||
val chr = LineGap.sub (bufferPos, buffer)
|
||||
val newState = Dfa.nextState (dfa, curState, chr)
|
||||
val prevFinalPos =
|
||||
if Dfa.isFinal (dfa, newState) then bufferPos else prevFinalPos
|
||||
in
|
||||
if Dfa.isDead newState then
|
||||
if prevFinalPos = ~1 then
|
||||
(* no match found: restart search from `startPos + 1` *)
|
||||
rangeLoop
|
||||
( dfa
|
||||
, startPos + 1
|
||||
, buffer
|
||||
, finishIdx
|
||||
, searchList
|
||||
, 0
|
||||
, startPos + 1
|
||||
, ~1
|
||||
)
|
||||
else
|
||||
(* match found: append and continue *)
|
||||
let
|
||||
val searchList =
|
||||
PersistentVector.append (startPos, prevFinalPos, searchList)
|
||||
|
||||
(* we start 1 idx after the final position we found *)
|
||||
val newStart = prevFinalPos + 1
|
||||
in
|
||||
rangeLoop
|
||||
(dfa, newStart, buffer, finishIdx, searchList, 0, newStart, ~1)
|
||||
end
|
||||
else
|
||||
(* continue searching for match *)
|
||||
rangeLoop
|
||||
( dfa
|
||||
, bufferPos + 1
|
||||
, buffer
|
||||
, finishIdx
|
||||
, searchList
|
||||
, newState
|
||||
, startPos
|
||||
, prevFinalPos
|
||||
)
|
||||
end
|
||||
|
||||
fun buildRange (buffer, finishIdx, dfa) =
|
||||
if Vector.length dfa > 0 then
|
||||
rangeLoop
|
||||
( dfa
|
||||
, #idx buffer
|
||||
, buffer
|
||||
, finishIdx
|
||||
, PersistentVector.empty
|
||||
, 0
|
||||
, #idx buffer
|
||||
, ~1
|
||||
)
|
||||
else
|
||||
(buffer, PersistentVector.empty)
|
||||
|
||||
fun insertUntilMatch
|
||||
(idx, buffer, searchList, dfa, curState, startPos, prevFinalPos) =
|
||||
if idx = #textLength buffer then
|
||||
if prevFinalPos < 0 then
|
||||
(buffer, searchList)
|
||||
else if PersistentVector.isInRange (prevFinalPos, searchList) then
|
||||
(buffer, searchList)
|
||||
else
|
||||
let
|
||||
val searchList =
|
||||
PersistentVector.insertMatchKeepingAbsoluteInddices
|
||||
(startPos, prevFinalPos, searchList)
|
||||
in
|
||||
(buffer, searchList)
|
||||
end
|
||||
else if Dfa.isDead curState then
|
||||
if prevFinalPos = ~1 then
|
||||
(* no match found: restart search from `startPos + 1` *)
|
||||
insertUntilMatch
|
||||
(startPos + 1, buffer, searchList, dfa, 0, startPos + 1, ~1)
|
||||
else if PersistentVector.isInRange (prevFinalPos, searchList) then
|
||||
(buffer, searchList)
|
||||
else
|
||||
(* new match. Insert and continue *)
|
||||
let
|
||||
val searchList =
|
||||
PersistentVector.insertMatchKeepingAbsoluteInddices
|
||||
(startPos, prevFinalPos, searchList)
|
||||
val newStart = prevFinalPos + 1
|
||||
in
|
||||
insertUntilMatch (newStart, buffer, searchList, dfa, 0, newStart, ~1)
|
||||
end
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (idx, buffer)
|
||||
val chr = LineGap.sub (idx, buffer)
|
||||
val newState = Dfa.nextState (dfa, curState, chr)
|
||||
val prevFinalPos =
|
||||
if Dfa.isFinal (dfa, newState) then idx else prevFinalPos
|
||||
in
|
||||
(* continue *)
|
||||
insertUntilMatch
|
||||
(idx + 1, buffer, searchList, dfa, newState, startPos, prevFinalPos)
|
||||
end
|
||||
|
||||
fun tryExtendingPrevMatch
|
||||
(idx, buffer, searchList, dfa, finalPos, curState, start) =
|
||||
if idx = #textLength buffer then
|
||||
let
|
||||
val searchList =
|
||||
PersistentVector.extendExistingMatch (start, finalPos, searchList)
|
||||
in
|
||||
(buffer, searchList)
|
||||
end
|
||||
else if Dfa.isDead curState then
|
||||
let
|
||||
val searchList =
|
||||
PersistentVector.extendExistingMatch (start, finalPos, searchList)
|
||||
in
|
||||
insertUntilMatch
|
||||
(finalPos + 1, buffer, searchList, dfa, 0, finalPos + 1, ~1)
|
||||
end
|
||||
else
|
||||
let
|
||||
val buffer = LineGap.goToIdx (idx, buffer)
|
||||
val chr = LineGap.sub (idx, buffer)
|
||||
val newState = Dfa.nextState (dfa, curState, chr)
|
||||
val finalPos = if Dfa.isFinal (dfa, newState) then idx else finalPos
|
||||
in
|
||||
(* continue *)
|
||||
tryExtendingPrevMatch
|
||||
(idx + 1, buffer, searchList, dfa, finalPos, newState, start)
|
||||
end
|
||||
|
||||
fun deleteBufferAndSearchList (start, length, buffer, searchList, dfa) =
|
||||
let
|
||||
val buffer = LineGap.delete (start, length, buffer)
|
||||
val searchList = PersistentVector.delete (start, length, searchList)
|
||||
val oldStart = PersistentVector.prevMatch (start, searchList, 1)
|
||||
in
|
||||
if Vector.length dfa = 0 then
|
||||
(buffer, searchList)
|
||||
else if oldStart >= start orelse oldStart = ~1 then
|
||||
(* no previous match, so try searching for a match from start of buffer *)
|
||||
insertUntilMatch (0, buffer, searchList, dfa, 0, 0, ~1)
|
||||
else
|
||||
tryExtendingPrevMatch
|
||||
(oldStart, buffer, searchList, dfa, ~1, 0, oldStart)
|
||||
end
|
||||
|
||||
(* inserts into buffer and searchList both *)
|
||||
fun insert (insIdx, insString, buffer, searchList, dfa) =
|
||||
let
|
||||
val buffer = LineGap.insert (insIdx, insString, buffer)
|
||||
|
||||
(* incremennt existing elements in the searchList after the insIdx
|
||||
* by the length of the string that was just inserted *)
|
||||
val searchList =
|
||||
let
|
||||
val searchListLeft = PersistentVector.splitLeft (insIdx, searchList)
|
||||
|
||||
val insLength = String.size insString
|
||||
val searchListRight =
|
||||
PersistentVector.splitRight (insIdx + insLength, searchList)
|
||||
val searchListRight = PersistentVector.empty
|
||||
in
|
||||
if PersistentVector.isEmpty searchListLeft then searchListRight
|
||||
else if PersistentVector.isEmpty searchListRight then searchListLeft
|
||||
else PersistentVector.merge (searchListLeft, searchListRight)
|
||||
end
|
||||
|
||||
val oldStart = PersistentVector.prevMatch (insIdx, searchList, 1)
|
||||
in
|
||||
if Vector.length dfa = 0 then
|
||||
(buffer, searchList)
|
||||
else if oldStart >= insIdx orelse oldStart = ~1 then
|
||||
(* no previous match, so try searching for a match from start of buffer *)
|
||||
insertUntilMatch (0, buffer, searchList, dfa, 0, 0, ~1)
|
||||
else
|
||||
tryExtendingPrevMatch
|
||||
(oldStart, buffer, searchList, dfa, ~1, 0, oldStart)
|
||||
end
|
||||
end
|
||||
142
shf/fcore/text-builder/normal-mode-text-builder.sml
Normal file
142
shf/fcore/text-builder/normal-mode-text-builder.sml
Normal file
@@ -0,0 +1,142 @@
|
||||
structure NormalModeTextBuilder =
|
||||
struct
|
||||
structure Utils = TextBuilderUtils
|
||||
|
||||
(* Prerequisite to all functions in this structure:
|
||||
* - Move buffer to startLine before calling any function. *)
|
||||
|
||||
fun startBuild
|
||||
( startLine
|
||||
, cursorPos
|
||||
, buffer: LineGap.t
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
, acc
|
||||
) =
|
||||
let
|
||||
val
|
||||
{ rightStrings
|
||||
, rightLines
|
||||
, line = curLine
|
||||
, idx = curIdx
|
||||
, textLength
|
||||
, ...
|
||||
} = buffer
|
||||
|
||||
val env = Utils.initEnv
|
||||
( 0
|
||||
, 0
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
, startLine
|
||||
)
|
||||
val {startX, startY, ...} = env
|
||||
in
|
||||
if textLength = 1 then
|
||||
(* empty string, so there is nothing we can draw
|
||||
* except a cursor at the line start.
|
||||
* An empty string is usually thought of to have a length of 0
|
||||
* and this is true, but we always have a \n at the end of the buffer
|
||||
* to respect Unix-style file endings, which we always uphold.
|
||||
* So, for us, an empty string has a length of 1. *)
|
||||
[Utils.makeCursor (startX, startY, env)]
|
||||
else
|
||||
case (rightStrings, rightLines) of
|
||||
(shd :: stl, lhd :: ltl) =>
|
||||
let
|
||||
(* get relative index of line to start building from *)
|
||||
val strPos =
|
||||
Utils.getRelativeLineStartFromRightHead
|
||||
(startLine, curLine, lhd)
|
||||
(* get absolute idx of line *)
|
||||
val absIdx = curIdx + strPos
|
||||
in
|
||||
if PersistentVector.isEmpty searchList then
|
||||
TextBuilderWithCursor.build
|
||||
( strPos
|
||||
, shd
|
||||
, stl
|
||||
, lhd
|
||||
, ltl
|
||||
, startX
|
||||
, startY
|
||||
, 0
|
||||
, startLine
|
||||
, absIdx
|
||||
, cursorPos
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
else
|
||||
TextBuilderWithHighlight.build
|
||||
( strPos
|
||||
, shd
|
||||
, stl
|
||||
, lhd
|
||||
, ltl
|
||||
, startX
|
||||
, startY
|
||||
, 0
|
||||
, startLine
|
||||
, absIdx
|
||||
, cursorPos
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
| (_, _) => acc
|
||||
end
|
||||
|
||||
fun buildWithExisting
|
||||
( startLine
|
||||
, cursorPos
|
||||
, buffer: LineGap.t
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
, acc
|
||||
) =
|
||||
startBuild
|
||||
( startLine
|
||||
, cursorPos
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, Real32.fromInt windowWidth
|
||||
, Real32.fromInt windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
, []
|
||||
)
|
||||
|
||||
fun build
|
||||
( startLine
|
||||
, cursorPos
|
||||
, buffer: LineGap.t
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
) =
|
||||
startBuild
|
||||
( startLine
|
||||
, cursorPos
|
||||
, buffer
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, Real32.fromInt windowWidth
|
||||
, Real32.fromInt windowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
, []
|
||||
)
|
||||
end
|
||||
131
shf/fcore/text-builder/search-bar.sml
Normal file
131
shf/fcore/text-builder/search-bar.sml
Normal file
@@ -0,0 +1,131 @@
|
||||
structure SearchBar =
|
||||
struct
|
||||
structure TC = TextConstants
|
||||
structure Utils = TextBuilderUtils
|
||||
|
||||
fun loop
|
||||
(pos, str, posX, posY, endX, acc, floatWindowWidth, floatWindowHeight) =
|
||||
if pos = String.size str then
|
||||
acc
|
||||
else if posX >= endX then
|
||||
acc
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, pos)
|
||||
val r: Real32.real = 0.01
|
||||
val g: Real32.real = 0.01
|
||||
val b: Real32.real = 0.01
|
||||
val fPosX = Real32.fromInt posX
|
||||
val fPosY = Real32.fromInt posY
|
||||
val z: Real32.real = 0.1
|
||||
|
||||
val chr = CozetteAscii.make
|
||||
( chr
|
||||
, fPosX
|
||||
, fPosY
|
||||
, z
|
||||
, TC.scale
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
)
|
||||
|
||||
val acc = chr :: acc
|
||||
val nextPosX = posX + TC.xSpace
|
||||
in
|
||||
loop
|
||||
( pos + 1
|
||||
, str
|
||||
, nextPosX
|
||||
, posY
|
||||
, endX
|
||||
, acc
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
)
|
||||
end
|
||||
|
||||
(* builds a single text line from a string.
|
||||
* Used for getting Real32.real vector representing search input.
|
||||
* Todo: add scrolling, so that text scrolls horizontally when greater than width. *)
|
||||
fun build
|
||||
( str
|
||||
, startX
|
||||
, startY
|
||||
, endX
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, searchCursorIdx
|
||||
, searchScrollColumn
|
||||
, caseSensitive
|
||||
) =
|
||||
let
|
||||
val r: Real32.real = 0.1
|
||||
val g: Real32.real = 0.1
|
||||
val b: Real32.real = 0.1
|
||||
val z: Real32.real = 0.1
|
||||
|
||||
val width = endX - startX
|
||||
val (startX, endX) =
|
||||
if TC.textLineWidth > width then
|
||||
(startX, endX)
|
||||
else
|
||||
let
|
||||
val startX = (width - TC.textLineWidth) div 2
|
||||
val endX = startX + TC.textLineWidth
|
||||
in
|
||||
(startX, endX)
|
||||
end
|
||||
|
||||
val fPosX = Real32.fromInt startX
|
||||
val fPosY = Real32.fromInt startY
|
||||
|
||||
val searchSymbol = CozetteAscii.make
|
||||
( if caseSensitive then #"?" else #"/"
|
||||
, fPosX
|
||||
, fPosY
|
||||
, z
|
||||
, TC.scale
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
)
|
||||
|
||||
val cursor =
|
||||
let
|
||||
val xpos = (searchCursorIdx + 1) - searchScrollColumn
|
||||
val xpos = TextConstants.xSpace * xpos + startX
|
||||
val xpos = Int.min (endX, xpos)
|
||||
val x = Real32.fromInt xpos
|
||||
in
|
||||
PipeCursor.lerp
|
||||
( x
|
||||
, fPosY
|
||||
, 0.01
|
||||
, TC.scale
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
)
|
||||
end
|
||||
|
||||
val posX = startX + TC.xSpace
|
||||
in
|
||||
loop
|
||||
( searchScrollColumn
|
||||
, str
|
||||
, posX
|
||||
, startY
|
||||
, endX
|
||||
, [cursor, searchSymbol]
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
)
|
||||
end
|
||||
end
|
||||
250
shf/fcore/text-builder/text-builder-utils.sml
Normal file
250
shf/fcore/text-builder/text-builder-utils.sml
Normal file
@@ -0,0 +1,250 @@
|
||||
structure TextBuilderUtils =
|
||||
struct
|
||||
structure TC = TextConstants
|
||||
|
||||
type env_data =
|
||||
{ charR: Real32.real
|
||||
, charG: Real32.real
|
||||
, charB: Real32.real
|
||||
|
||||
, cursorR: Real32.real
|
||||
, cursorG: Real32.real
|
||||
, cursorB: Real32.real
|
||||
|
||||
, searchHighlightR: Real32.real
|
||||
, searchHighlightG: Real32.real
|
||||
, searchHighlightB: Real32.real
|
||||
|
||||
(* different colours for char when cursor is on char *)
|
||||
, cursorHighlightedCharR: Real32.real
|
||||
, cursorHighlightedCharG: Real32.real
|
||||
, cursorHighlightedCharB: Real32.real
|
||||
|
||||
, searchHighlightedCharR: Real32.real
|
||||
, searchHighlightedCharG: Real32.real
|
||||
, searchHighlightedCharB: Real32.real
|
||||
|
||||
, charZ: Real32.real
|
||||
, cursorZ: Real32.real
|
||||
, searchHighlightZ: Real32.real
|
||||
|
||||
, startX: int
|
||||
, startY: int
|
||||
|
||||
, scrollColumnStart: int
|
||||
, scrollColumnEnd: int
|
||||
, lastLineNumber: int
|
||||
|
||||
(* fw/fh = float window width and float window height *)
|
||||
, fw: Real32.real
|
||||
, fh: Real32.real
|
||||
|
||||
, searchList: PersistentVector.t
|
||||
}
|
||||
|
||||
fun initEnv
|
||||
( startX
|
||||
, startY
|
||||
, endX
|
||||
, endY
|
||||
, floatWindowWidth
|
||||
, floatWindowHeight
|
||||
, searchList
|
||||
, visualScrollColumn
|
||||
, startLine
|
||||
) : env_data =
|
||||
let
|
||||
val width = endX - startX
|
||||
val lastLineNumber =
|
||||
let
|
||||
val height = endY - startY
|
||||
val howManyLines = height div TC.ySpace
|
||||
in
|
||||
startLine + howManyLines
|
||||
end
|
||||
in
|
||||
if TC.textLineWidth > width then
|
||||
{ charR = 0.0
|
||||
, charG = 0.0
|
||||
, charB = 0.0
|
||||
|
||||
, searchHighlightR = 0.41
|
||||
, searchHighlightG = 0.05
|
||||
, searchHighlightB = 0.67
|
||||
|
||||
, cursorR = 0.0
|
||||
, cursorG = 0.0
|
||||
, cursorB = 0.0
|
||||
|
||||
, searchHighlightedCharR = 0.89
|
||||
, searchHighlightedCharG = 0.89
|
||||
, searchHighlightedCharB = 0.89
|
||||
|
||||
, cursorHighlightedCharR = 0.89
|
||||
, cursorHighlightedCharG = 0.89
|
||||
, cursorHighlightedCharB = 0.89
|
||||
|
||||
, charZ = 0.01
|
||||
, cursorZ = 0.03
|
||||
, searchHighlightZ = 0.05
|
||||
|
||||
, startX = startX
|
||||
, startY = startX
|
||||
|
||||
, scrollColumnStart = visualScrollColumn
|
||||
, scrollColumnEnd = width div TC.xSpace + visualScrollColumn
|
||||
, lastLineNumber = lastLineNumber
|
||||
|
||||
, fw = floatWindowWidth
|
||||
, fh = floatWindowHeight
|
||||
|
||||
, searchList = searchList
|
||||
}
|
||||
else
|
||||
let
|
||||
val startX = (width - TC.textLineWidth) div 2
|
||||
in
|
||||
{ charR = 0.0
|
||||
, charG = 0.0
|
||||
, charB = 0.0
|
||||
|
||||
, searchHighlightR = 0.41
|
||||
, searchHighlightG = 0.05
|
||||
, searchHighlightB = 0.67
|
||||
|
||||
, cursorR = 0.0
|
||||
, cursorG = 0.0
|
||||
, cursorB = 0.0
|
||||
|
||||
, searchHighlightedCharR = 0.89
|
||||
, searchHighlightedCharG = 0.89
|
||||
, searchHighlightedCharB = 0.89
|
||||
|
||||
, cursorHighlightedCharR = 0.89
|
||||
, cursorHighlightedCharG = 0.89
|
||||
, cursorHighlightedCharB = 0.89
|
||||
|
||||
, charZ = 0.01
|
||||
, cursorZ = 0.03
|
||||
, searchHighlightZ = 0.05
|
||||
|
||||
, startX = startX
|
||||
, startY = startY
|
||||
|
||||
, scrollColumnStart = visualScrollColumn
|
||||
, scrollColumnEnd = visualScrollColumn + TC.textLineCount
|
||||
, lastLineNumber = lastLineNumber
|
||||
|
||||
, fw = floatWindowWidth
|
||||
, fh = floatWindowHeight
|
||||
|
||||
, searchList = searchList
|
||||
}
|
||||
end
|
||||
end
|
||||
|
||||
(* different functions to make vectors of different things we want to draw. *)
|
||||
fun makeCursor (posX, posY, env: env_data) =
|
||||
Rect.lerp
|
||||
( Real32.fromInt (posX - 2)
|
||||
, Real32.fromInt posY
|
||||
, #cursorZ env
|
||||
, TC.scale
|
||||
, #fw env
|
||||
, #fh env
|
||||
, #cursorR env
|
||||
, #cursorG env
|
||||
, #cursorB env
|
||||
)
|
||||
|
||||
fun makeSearchHighlight (posX, posY, env: env_data) =
|
||||
Rect.lerp
|
||||
( Real32.fromInt (posX - 2)
|
||||
, Real32.fromInt posY
|
||||
, #searchHighlightZ env
|
||||
, TC.scale
|
||||
, #fw env
|
||||
, #fh env
|
||||
, #searchHighlightR env
|
||||
, #searchHighlightG env
|
||||
, #searchHighlightB env
|
||||
)
|
||||
|
||||
fun makeChr (chr, posX, posY, env: env_data) =
|
||||
CozetteAscii.make
|
||||
( chr
|
||||
, Real32.fromInt posX
|
||||
, Real32.fromInt posY
|
||||
, #charZ env
|
||||
, TC.scale
|
||||
, #fw env
|
||||
, #fh env
|
||||
, #charR env
|
||||
, #charG env
|
||||
, #charB env
|
||||
)
|
||||
|
||||
fun makeCursorHighlightedChr (chr, posX, posY, env: env_data) =
|
||||
CozetteAscii.make
|
||||
( chr
|
||||
, Real32.fromInt posX
|
||||
, Real32.fromInt posY
|
||||
, #charZ env
|
||||
, TC.scale
|
||||
, #fw env
|
||||
, #fh env
|
||||
, #cursorHighlightedCharR env
|
||||
, #cursorHighlightedCharG env
|
||||
, #cursorHighlightedCharB env
|
||||
)
|
||||
|
||||
fun makeSearchHighlightedChr (chr, posX, posY, env: env_data) =
|
||||
CozetteAscii.make
|
||||
( chr
|
||||
, Real32.fromInt posX
|
||||
, Real32.fromInt posY
|
||||
, #charZ env
|
||||
, TC.scale
|
||||
, #fw env
|
||||
, #fh env
|
||||
, #searchHighlightedCharR env
|
||||
, #searchHighlightedCharG env
|
||||
, #searchHighlightedCharB env
|
||||
)
|
||||
|
||||
(* gets line start idx, relative to right hd *)
|
||||
fun getRelativeLineStartFromRightHead (startLine, curLine, rLnHd) =
|
||||
if startLine > curLine then
|
||||
let val lnPos = startLine - curLine - 1
|
||||
in Vector.sub (rLnHd, lnPos) + 1
|
||||
end
|
||||
else
|
||||
0
|
||||
|
||||
(* gets line start idx, absolute *)
|
||||
fun getAbsoluteLineStartFromRightHead (curIdx, startLine, curLine, rLnHd) =
|
||||
let
|
||||
val startIdx =
|
||||
if startLine > curLine then
|
||||
let val lnPos = startLine - curLine - 1
|
||||
in Vector.sub (rLnHd, lnPos) + 1
|
||||
end
|
||||
else
|
||||
0
|
||||
in
|
||||
curIdx + startIdx
|
||||
end
|
||||
|
||||
fun getLineAbsIdxFromBuffer (startLine, buffer: LineGap.t) =
|
||||
let
|
||||
val {rightLines, line = curLine, idx = curIdx, ...} = buffer
|
||||
in
|
||||
case rightLines of
|
||||
rLnHd :: _ =>
|
||||
getAbsoluteLineStartFromRightHead (curIdx, startLine, curLine, rLnHd)
|
||||
| [] =>
|
||||
raise Fail
|
||||
"text-builder-utils.sml 268:\
|
||||
\should never call function when at end of buffer"
|
||||
end
|
||||
end
|
||||
253
shf/fcore/text-builder/text-builder-with-cursor.sml
Normal file
253
shf/fcore/text-builder/text-builder-with-cursor.sml
Normal file
@@ -0,0 +1,253 @@
|
||||
structure TextBuilderWithCursor =
|
||||
struct
|
||||
structure TC = TextConstants
|
||||
structure Utils = TextBuilderUtils
|
||||
|
||||
fun goToFirstLineAfter
|
||||
(stl, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc) =
|
||||
case (stl, ltl) of
|
||||
(shd :: stl, lhd :: ltl) =>
|
||||
if Vector.length lhd > 0 then
|
||||
let
|
||||
val lineOffset = Vector.sub (lhd, 0)
|
||||
val strPos = lineOffset + 1
|
||||
val absIdx = absIdx + strPos
|
||||
val posY = posY + TC.ySpace
|
||||
val lineNumber = lineNumber + 1
|
||||
in
|
||||
build
|
||||
( strPos
|
||||
, shd
|
||||
, stl
|
||||
, lhd
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY
|
||||
, 0
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
else
|
||||
(* keep looping until we find a linebreak *)
|
||||
goToFirstLineAfter
|
||||
( stl
|
||||
, ltl
|
||||
, posY
|
||||
, lineNumber
|
||||
, absIdx + String.size shd
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
| (_, _) => acc
|
||||
|
||||
and skipToNextLine
|
||||
(pos, str, stl, line, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc) =
|
||||
if Vector.length line = 0 then
|
||||
let
|
||||
(* get index of buffer after this string *)
|
||||
val absIdx = absIdx - pos
|
||||
val absIdx = absIdx + String.size str
|
||||
in
|
||||
goToFirstLineAfter
|
||||
(stl, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc)
|
||||
end
|
||||
else
|
||||
(* bin search lines *)
|
||||
let
|
||||
val linePos = BinSearch.equalOrMore (pos + 1, line)
|
||||
in
|
||||
if linePos = ~1 then
|
||||
(* next line is not in this node *)
|
||||
let
|
||||
val absIdx = absIdx - pos
|
||||
val absIdx = absIdx + String.size str
|
||||
in
|
||||
goToFirstLineAfter
|
||||
(stl, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc)
|
||||
end
|
||||
else
|
||||
let
|
||||
val lineOffset = Vector.sub (line, linePos)
|
||||
val newStrPos = lineOffset + 1
|
||||
val absIdx = absIdx - pos + newStrPos
|
||||
val posY = posY + TC.ySpace
|
||||
val lineNumber = lineNumber + 1
|
||||
in
|
||||
build
|
||||
( newStrPos
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY
|
||||
, 0
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
end
|
||||
|
||||
and build
|
||||
( pos
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX
|
||||
, posY
|
||||
, column
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env: Utils.env_data
|
||||
, acc
|
||||
) =
|
||||
if pos = String.size str then
|
||||
case (stl, ltl) of
|
||||
(str :: stl, line :: ltl) =>
|
||||
build
|
||||
( 0
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX
|
||||
, posY
|
||||
, column
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
| (_, _) => acc
|
||||
else
|
||||
case String.sub (str, pos) of
|
||||
#"\n" =>
|
||||
if lineNumber + 1 > #lastLineNumber env then
|
||||
acc
|
||||
else
|
||||
let
|
||||
val acc =
|
||||
if absIdx = cursorIdx then
|
||||
Utils.makeCursor (posX, posY, env) :: acc
|
||||
else
|
||||
acc
|
||||
in
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY + TC.ySpace
|
||||
, 0
|
||||
, lineNumber + 1
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
| #" " =>
|
||||
let
|
||||
val acc =
|
||||
if absIdx = cursorIdx then
|
||||
Utils.makeCursor (posX, posY, env) :: acc
|
||||
else
|
||||
acc
|
||||
val posX =
|
||||
if column < #scrollColumnStart env then
|
||||
(* if we are prior to the start column,
|
||||
* we want to set the x position to be at the start
|
||||
* in preparation for when we are at the start column *)
|
||||
#startX env
|
||||
else
|
||||
posX + TC.xSpace
|
||||
in
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX
|
||||
, posY
|
||||
, column + 1
|
||||
, lineNumber
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
| chr =>
|
||||
if column < #scrollColumnStart env then
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY
|
||||
, column + 1
|
||||
, lineNumber
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
else if column > #scrollColumnEnd env then
|
||||
skipToNextLine
|
||||
( pos
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posY
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
else
|
||||
let
|
||||
val acc =
|
||||
if absIdx = cursorIdx then
|
||||
let
|
||||
val acc = Utils.makeCursor (posX, posY, env) :: acc
|
||||
in
|
||||
Utils.makeCursorHighlightedChr (chr, posX, posY, env) :: acc
|
||||
end
|
||||
else
|
||||
Utils.makeChr (chr, posX, posY, env) :: acc
|
||||
in
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX + TC.xSpace
|
||||
, posY
|
||||
, column + 1
|
||||
, lineNumber
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
end
|
||||
258
shf/fcore/text-builder/text-builder-with-highlight.sml
Normal file
258
shf/fcore/text-builder/text-builder-with-highlight.sml
Normal file
@@ -0,0 +1,258 @@
|
||||
structure TextBuilderWithHighlight =
|
||||
struct
|
||||
structure TC = TextConstants
|
||||
structure Utils = TextBuilderUtils
|
||||
|
||||
fun isSecondLastChr (pos, str, tl) =
|
||||
case tl of
|
||||
[] => pos = String.size str - 2
|
||||
| _ => false
|
||||
|
||||
fun goToFirstLineAfter
|
||||
(stl, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc) =
|
||||
case (stl, ltl) of
|
||||
(shd :: stl, lhd :: ltl) =>
|
||||
if Vector.length lhd > 0 then
|
||||
let
|
||||
val lineOffset = Vector.sub (lhd, 0)
|
||||
val strPos = lineOffset + 1
|
||||
val absIdx = absIdx + strPos
|
||||
val posY = posY + TC.ySpace
|
||||
val lineNumber = lineNumber + 1
|
||||
in
|
||||
build
|
||||
( strPos
|
||||
, shd
|
||||
, stl
|
||||
, lhd
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY
|
||||
, 0
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
else
|
||||
(* keep looping until we find a linebreak *)
|
||||
goToFirstLineAfter
|
||||
( stl
|
||||
, ltl
|
||||
, posY
|
||||
, lineNumber
|
||||
, absIdx + String.size shd
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
| (_, _) => acc
|
||||
|
||||
and skipToNextLine
|
||||
(pos, str, stl, line, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc) =
|
||||
if Vector.length line = 0 then
|
||||
let
|
||||
(* get index of buffer after this string *)
|
||||
val absIdx = absIdx - pos
|
||||
val absIdx = absIdx + String.size str
|
||||
in
|
||||
goToFirstLineAfter
|
||||
(stl, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc)
|
||||
end
|
||||
else
|
||||
(* bin search lines *)
|
||||
let
|
||||
val linePos = BinSearch.equalOrMore (pos + 1, line)
|
||||
in
|
||||
if linePos = ~1 then
|
||||
(* next line is not in this node *)
|
||||
let
|
||||
val absIdx = absIdx - pos
|
||||
val absIdx = absIdx + String.size str
|
||||
in
|
||||
goToFirstLineAfter
|
||||
(stl, ltl, posY, lineNumber, absIdx, cursorIdx, env, acc)
|
||||
end
|
||||
else
|
||||
let
|
||||
val lineOffset = Vector.sub (line, linePos)
|
||||
val newStrPos = lineOffset + 1
|
||||
val absIdx = absIdx - pos + newStrPos
|
||||
val posY = posY + TC.ySpace
|
||||
val lineNumber = lineNumber + 1
|
||||
in
|
||||
build
|
||||
( newStrPos
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY
|
||||
, 0
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
end
|
||||
|
||||
and build
|
||||
( pos
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX
|
||||
, posY
|
||||
, column
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env: Utils.env_data
|
||||
, acc
|
||||
) =
|
||||
if pos = String.size str then
|
||||
case (stl, ltl) of
|
||||
(str :: stl, line :: ltl) =>
|
||||
build
|
||||
( 0
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX
|
||||
, posY
|
||||
, column
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
| (_, _) => acc
|
||||
else
|
||||
case String.sub (str, pos) of
|
||||
#" " =>
|
||||
let
|
||||
val acc =
|
||||
if absIdx = cursorIdx then
|
||||
Utils.makeCursor (posX, posY, env) :: acc
|
||||
else
|
||||
acc
|
||||
val acc =
|
||||
if PersistentVector.isInRange (absIdx, #searchList env) then
|
||||
Utils.makeSearchHighlight (posX, posY, env) :: acc
|
||||
else
|
||||
acc
|
||||
val posX =
|
||||
if column < #scrollColumnStart env then #startX env
|
||||
else posX + TC.xSpace
|
||||
in
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX
|
||||
, posY
|
||||
, column + 1
|
||||
, lineNumber
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
| #"\n" =>
|
||||
if lineNumber + 1 > #lastLineNumber env then
|
||||
acc
|
||||
else
|
||||
let
|
||||
val acc =
|
||||
if absIdx = cursorIdx then
|
||||
Utils.makeCursor (posX, posY, env) :: acc
|
||||
else
|
||||
acc
|
||||
in
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY + TC.ySpace
|
||||
, 0
|
||||
, lineNumber + 1
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
| chr =>
|
||||
if column < #scrollColumnStart env then
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, #startX env
|
||||
, posY
|
||||
, column + 1
|
||||
, lineNumber
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
else if column > #scrollColumnEnd env then
|
||||
skipToNextLine
|
||||
( pos
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posY
|
||||
, lineNumber
|
||||
, absIdx
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
else
|
||||
let
|
||||
val acc =
|
||||
if absIdx = cursorIdx then
|
||||
Utils.makeCursorHighlightedChr (chr, posX, posY, env)
|
||||
:: Utils.makeCursor (posX, posY, env) :: acc
|
||||
else if PersistentVector.isInRange (absIdx, #searchList env) then
|
||||
Utils.makeSearchHighlightedChr (chr, posX, posY, env)
|
||||
:: Utils.makeSearchHighlight (posX, posY, env) :: acc
|
||||
else
|
||||
Utils.makeChr (chr, posX, posY, env) :: acc
|
||||
in
|
||||
build
|
||||
( pos + 1
|
||||
, str
|
||||
, stl
|
||||
, line
|
||||
, ltl
|
||||
, posX + TC.xSpace
|
||||
, posY
|
||||
, column + 1
|
||||
, lineNumber
|
||||
, absIdx + 1
|
||||
, cursorIdx
|
||||
, env
|
||||
, acc
|
||||
)
|
||||
end
|
||||
end
|
||||
10
shf/fcore/text-constants.sml
Normal file
10
shf/fcore/text-constants.sml
Normal file
@@ -0,0 +1,10 @@
|
||||
structure TextConstants =
|
||||
struct
|
||||
val xSpace = 13
|
||||
val xSpace3 = xSpace * 3
|
||||
val ySpace = 25
|
||||
val scale: Real32.real = 2.0
|
||||
|
||||
val textLineCount = 80
|
||||
val textLineWidth = xSpace * textLineCount
|
||||
end
|
||||
68
shf/fcore/text-scroll.sml
Normal file
68
shf/fcore/text-scroll.sml
Normal file
@@ -0,0 +1,68 @@
|
||||
structure TextScroll =
|
||||
struct
|
||||
structure TC = TextConstants
|
||||
|
||||
(* calculates new scroll column from integer arguments *)
|
||||
fun calculateScrollColumn
|
||||
(startOfLine, cursorIdx, windowWidth, prevScrollColumn) =
|
||||
let
|
||||
val newColumn = cursorIdx - startOfLine
|
||||
val howManyColumnsCanWeFit =
|
||||
if windowWidth >= TC.textLineWidth then TC.textLineCount
|
||||
else windowWidth div TC.xSpace
|
||||
val howManyColumnsCanWeFit = howManyColumnsCanWeFit - 1
|
||||
in
|
||||
if newColumn < prevScrollColumn then
|
||||
(* we are moving the cursor backwards
|
||||
* so make sure that newColumn is on the left side *)
|
||||
newColumn
|
||||
else if newColumn > prevScrollColumn + howManyColumnsCanWeFit then
|
||||
(* we are scrolling forwards *)
|
||||
newColumn - howManyColumnsCanWeFit
|
||||
else
|
||||
(* we can display the current column without moving the scroll column
|
||||
* so we do that *)
|
||||
prevScrollColumn
|
||||
end
|
||||
|
||||
(* Preqreuisite: move buffer to cursorIdx *)
|
||||
fun getScrollColumn (buffer, cursorIdx, windowWidth, prevScrollColumn) =
|
||||
let
|
||||
val startOfLine = Cursor.vi0 (buffer, cursorIdx)
|
||||
in
|
||||
calculateScrollColumn
|
||||
(startOfLine, cursorIdx, windowWidth, prevScrollColumn)
|
||||
end
|
||||
|
||||
fun getScrollColumnFromString (cursorIdx, windowWidth, prevScrollColumn) =
|
||||
calculateScrollColumn (0, cursorIdx, windowWidth, prevScrollColumn)
|
||||
|
||||
fun getStartLine (prevLineNumber, cursorLine, windowHeight, totalLines) =
|
||||
if cursorLine <= (prevLineNumber + 3) then
|
||||
(* cursorLine is prior to or same as prevLineNumber,
|
||||
* so use cursorLine to calculate the start line we want. *)
|
||||
Int.max (cursorLine - 3, 0)
|
||||
else
|
||||
(* cursorLine > prevLineNumber *)
|
||||
let
|
||||
val howManyLinesWeCanFit = windowHeight div TC.ySpace
|
||||
in
|
||||
if cursorLine > prevLineNumber + (howManyLinesWeCanFit - 3) then
|
||||
(* cursorLine is after the visible part of the screen
|
||||
* so return the mimimum line where cursorLine is visible *)
|
||||
if cursorLine >= totalLines - 3 then
|
||||
Int.max (totalLines - howManyLinesWeCanFit, 0)
|
||||
else
|
||||
cursorLine - howManyLinesWeCanFit + 3
|
||||
else
|
||||
prevLineNumber
|
||||
end
|
||||
|
||||
fun getLineCentre (cursorLine, windowHeight) =
|
||||
let
|
||||
val howManyLinesWeCanFit = windowHeight div TC.ySpace
|
||||
val startLine = cursorLine - (howManyLinesWeCanFit div 2)
|
||||
in
|
||||
Int.max (startLine, 0)
|
||||
end
|
||||
end
|
||||
15217
shf/ffi/RGFW.h
Normal file
15217
shf/ffi/RGFW.h
Normal file
File diff suppressed because it is too large
Load Diff
1463
shf/ffi/glad.c
Normal file
1463
shf/ffi/glad.c
Normal file
File diff suppressed because it is too large
Load Diff
2749
shf/ffi/glad.h
Normal file
2749
shf/ffi/glad.h
Normal file
File diff suppressed because it is too large
Load Diff
63
shf/ffi/gles3-import.sml
Normal file
63
shf/ffi/gles3-import.sml
Normal file
@@ -0,0 +1,63 @@
|
||||
structure Gles3 =
|
||||
struct
|
||||
type buffer = Word32.word
|
||||
type shader_type = Word32.word
|
||||
type shader = Word32.word
|
||||
type program = Word32.word
|
||||
type draw_mode = Word32.word
|
||||
type update_mode = Word32.word
|
||||
|
||||
(* OpenGL constants used. *)
|
||||
val (VERTEX_SHADER, _) =
|
||||
_symbol "VERTEX_SHADER" public : ( unit -> shader_type ) * ( shader_type -> unit );
|
||||
val VERTEX_SHADER = VERTEX_SHADER ()
|
||||
|
||||
val (FRAGMENT_SHADER, _) =
|
||||
_symbol "FRAGMENT_SHADER" public : ( unit -> shader_type ) * ( shader_type -> unit );
|
||||
val FRAGMENT_SHADER = FRAGMENT_SHADER ()
|
||||
|
||||
val (TRIANGLES, _) =
|
||||
_symbol "TRIANGLES" public : ( unit -> draw_mode ) * ( draw_mode -> unit );
|
||||
val TRIANGLES = TRIANGLES ()
|
||||
|
||||
val (STATIC_DRAW, _) =
|
||||
_symbol "STATIC_DRAW" public : ( unit -> update_mode ) * ( update_mode -> unit );
|
||||
val STATIC_DRAW = STATIC_DRAW ()
|
||||
|
||||
val (DYNAMIC_DRAW, _) =
|
||||
_symbol "DYNAMIC_DRAW" public : ( unit -> update_mode ) * ( update_mode -> unit );
|
||||
val DYNAMIC_DRAW = DYNAMIC_DRAW ()
|
||||
|
||||
(* OpenGL functions used. *)
|
||||
val viewport = _import "viewport" public : int * int -> unit;
|
||||
val enableDepthTest = _import "enableDepthTest" : unit -> unit;
|
||||
|
||||
val createBuffer = _import "createBuffer" public : unit -> buffer;
|
||||
val bindBuffer = _import "bindBuffer" public : buffer -> unit;
|
||||
val bufferData =
|
||||
_import "bufferData" public : Real32.real vector * int * update_mode -> unit;
|
||||
|
||||
val createShader = _import "createShader" public : shader_type -> shader;
|
||||
val compileShader = _import "compileShader" public : shader -> unit;
|
||||
val deleteShader = _import "deleteShader" public : shader -> unit;
|
||||
val shaderSource = _import "shaderSource" public : shader * string -> unit;
|
||||
|
||||
val vertexAttribPointer =
|
||||
_import "vertexAttribPointer" public : int * int * int * int -> unit;
|
||||
val enableVertexAttribArray =
|
||||
_import "enableVertexAttribArray" public : int -> unit;
|
||||
|
||||
val createProgram = _import "createProgram" public : unit -> program;
|
||||
val attachShader = _import "attachShader" public : program * shader -> unit;
|
||||
val linkProgram = _import "linkProgram" public : program -> unit;
|
||||
val useProgram = _import "useProgram" public : program -> unit;
|
||||
|
||||
val deleteShader = _import "deleteShader" public : program -> unit;
|
||||
val deleteProgram = _import "deleteProgram" public : program -> unit;
|
||||
|
||||
val clearColor =
|
||||
_import "clearColor" public : Real32.real * Real32.real * Real32.real * Real32.real -> unit;
|
||||
val clear = _import "clear" public : unit -> unit;
|
||||
|
||||
val drawArrays = _import "drawArrays" public : draw_mode * int * int -> unit;
|
||||
end
|
||||
144
shf/ffi/glfw-export.c
Normal file
144
shf/ffi/glfw-export.c
Normal file
@@ -0,0 +1,144 @@
|
||||
#define GLFW_INCLUDE_NONE
|
||||
#include "glad.h"
|
||||
#include <GLFW/glfw3.h>
|
||||
#include <stdbool.h>
|
||||
|
||||
// GLFW constants used below
|
||||
int CONTEXT_VERSION_MAJOR = GLFW_CONTEXT_VERSION_MAJOR;
|
||||
int DEPRECATED = GLFW_DECORATED;
|
||||
int GLFW_FFI_FALSE = GLFW_FALSE;
|
||||
|
||||
// GLFW functions used below
|
||||
void init() {
|
||||
glfwInit();
|
||||
}
|
||||
|
||||
void windowHint(int hint, int value) {
|
||||
glfwWindowHint(hint, value);
|
||||
}
|
||||
|
||||
GLFWwindow* createWindow(int width, int height, const char *title) {
|
||||
return glfwCreateWindow(width, height, title, NULL, NULL);
|
||||
}
|
||||
|
||||
void terminate() {
|
||||
glfwTerminate();
|
||||
}
|
||||
|
||||
void makeContextCurrent(GLFWwindow* window) {
|
||||
glfwMakeContextCurrent(window);
|
||||
}
|
||||
|
||||
bool windowShouldClose(GLFWwindow *window) {
|
||||
glfwWindowShouldClose(window);
|
||||
}
|
||||
|
||||
void waitEvents() {
|
||||
glfwWaitEvents();
|
||||
}
|
||||
|
||||
void swapBuffers(GLFWwindow *window) {
|
||||
glfwSwapBuffers(window);
|
||||
}
|
||||
|
||||
void setClipboardString (GLFWwindow *window, const char *copyString) {
|
||||
glfwSetClipboardString(window, copyString);
|
||||
}
|
||||
|
||||
void loadGlad() {
|
||||
gladLoadGLLoader((GLADloadproc)glfwGetProcAddress);
|
||||
}
|
||||
|
||||
// OpenGL constants used below
|
||||
unsigned int VERTEX_SHADER = GL_VERTEX_SHADER;
|
||||
unsigned int FRAGMENT_SHADER = GL_FRAGMENT_SHADER;
|
||||
unsigned int TRIANGLES = GL_TRIANGLES;
|
||||
unsigned int STATIC_DRAW = GL_STATIC_DRAW;
|
||||
unsigned int DYNAMIC_DRAW = GL_DYNAMIC_DRAW;
|
||||
|
||||
// OpenGL functions used below
|
||||
void enableDepthTest() {
|
||||
glEnable(GL_DEPTH_TEST);
|
||||
}
|
||||
|
||||
void viewport(int width, int height) {
|
||||
glViewport(0, 0, width, height);
|
||||
}
|
||||
|
||||
void clearColor(float r, float g, float b, float a) {
|
||||
glClearColor(r, g, b, a);
|
||||
}
|
||||
|
||||
void clear() {
|
||||
glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT);
|
||||
}
|
||||
|
||||
unsigned int createBuffer() {
|
||||
unsigned int buffer;
|
||||
glGenBuffers(1, &buffer);
|
||||
return buffer;
|
||||
}
|
||||
|
||||
void bindBuffer(unsigned int buffer) {
|
||||
glBindBuffer(GL_ARRAY_BUFFER, buffer);
|
||||
}
|
||||
|
||||
void bufferData(float* vector, int vectorLength, unsigned int updateMode) {
|
||||
glBufferData(GL_ARRAY_BUFFER, sizeof(float) * vectorLength, vector, updateMode);
|
||||
}
|
||||
|
||||
unsigned int createShader(unsigned int shaderType) {
|
||||
return glCreateShader(shaderType);
|
||||
}
|
||||
|
||||
void shaderSource(unsigned int shader, const char *sourceString) {
|
||||
glShaderSource(shader, 1, &sourceString, NULL);
|
||||
}
|
||||
|
||||
void compileShader(unsigned int shader) {
|
||||
glCompileShader(shader);
|
||||
}
|
||||
|
||||
void deleteShader(unsigned int shader) {
|
||||
glDeleteShader(shader);
|
||||
}
|
||||
|
||||
void vertexAttribPointer(int location, int numVecComponents, int stride, int offset) {
|
||||
glVertexAttribPointer(location, numVecComponents, GL_FLOAT, GL_FALSE, stride * sizeof(float), (void*)offset);
|
||||
}
|
||||
|
||||
void enableVertexAttribArray(int location) {
|
||||
glEnableVertexAttribArray(location);
|
||||
}
|
||||
|
||||
unsigned int createProgram() {
|
||||
return glCreateProgram();
|
||||
}
|
||||
|
||||
void attachShader(unsigned int program, unsigned int shader) {
|
||||
glAttachShader(program, shader);
|
||||
}
|
||||
|
||||
void linkProgram(unsigned int program) {
|
||||
glLinkProgram(program);
|
||||
}
|
||||
|
||||
void useProgram(unsigned int program) {
|
||||
glUseProgram(program);
|
||||
}
|
||||
|
||||
void deleteProgram(unsigned int program) {
|
||||
glDeleteProgram(program);
|
||||
}
|
||||
|
||||
void drawArrays(unsigned int drawMode, int startIndex, int numVertices) {
|
||||
glDrawArrays(drawMode, startIndex, numVertices);
|
||||
}
|
||||
|
||||
int getUniformLocation(unsigned int program, const char *uniformName) {
|
||||
glGetUniformLocation(program, uniformName);
|
||||
}
|
||||
|
||||
void uniform4f(int uniformLocation, float a, float b, float c, float d) {
|
||||
glUniform4f(uniformLocation, a, b, c, d);
|
||||
}
|
||||
25
shf/ffi/glfw-import.sml
Normal file
25
shf/ffi/glfw-import.sml
Normal file
@@ -0,0 +1,25 @@
|
||||
structure Glfw =
|
||||
struct
|
||||
type window = MLton.Pointer.t
|
||||
|
||||
(* Window hint constants. *)
|
||||
val (CONTEXT_VERSION_MAJOR, _) =
|
||||
_symbol "CONTEXT_VERSION_MAJOR" public : ( unit -> int ) * ( int -> unit );
|
||||
val (DEPRECATED, _) =
|
||||
_symbol "DEPRECATED" public : ( unit -> int ) * ( int -> unit );
|
||||
val (FALSE, _) =
|
||||
_symbol "GLFW_FFI_FALSE" public : ( unit -> int ) * ( int -> unit );
|
||||
|
||||
(* GLFW functions. *)
|
||||
val init = _import "init" public : unit -> unit;
|
||||
val windowHint = _import "windowHint" public : int * int -> unit;
|
||||
val createWindow =
|
||||
_import "createWindow" public : int * int * string -> window;
|
||||
val terminate = _import "terminate" public : unit -> unit;
|
||||
val makeContextCurrent = _import "makeContextCurrent" public : window -> unit;
|
||||
val windowShouldClose = _import "windowShouldClose" public : window -> bool;
|
||||
val waitEvents = _import "waitEvents" public reentrant : unit -> unit;
|
||||
val swapBuffers = _import "swapBuffers" public : window -> unit;
|
||||
val setClipboardString = _import "setClipboardString" public : window * string -> unit;
|
||||
val loadGlad = _import "loadGlad" public : unit -> unit;
|
||||
end
|
||||
119
shf/ffi/glfw-input.c
Normal file
119
shf/ffi/glfw-input.c
Normal file
@@ -0,0 +1,119 @@
|
||||
#include "mlton-glfw-export.h"
|
||||
#include "glad.h"
|
||||
#define GLFW_INCLUDE_NONE
|
||||
#include <GLFW/glfw3.h>
|
||||
|
||||
int PRESS = GLFW_PRESS;
|
||||
int REPEAT = GLFW_REPEAT;
|
||||
int RELEASE = GLFW_RELEASE;
|
||||
int KEY_ESC = GLFW_KEY_ESCAPE;
|
||||
int KEY_ENTER = GLFW_KEY_ENTER;
|
||||
int KEY_BACKSPACE = GLFW_KEY_BACKSPACE;
|
||||
|
||||
int KEY_ARROW_LEFT = GLFW_KEY_LEFT;
|
||||
int KEY_ARROW_RIGHT = GLFW_KEY_RIGHT;
|
||||
int KEY_ARROW_UP = GLFW_KEY_UP;
|
||||
int KEY_ARROW_DOWN = GLFW_KEY_DOWN;
|
||||
|
||||
void framebufferSizeCallback(GLFWwindow* window, int width, int height) {
|
||||
glViewport(0, 0, width, height);
|
||||
mltonFramebufferSizeCallback(width, height);
|
||||
}
|
||||
|
||||
void setFramebufferSizeCallback(GLFWwindow* window) {
|
||||
glfwSetFramebufferSizeCallback(window, framebufferSizeCallback);
|
||||
}
|
||||
|
||||
void charCallback(GLFWwindow* window, unsigned int codepoint) {
|
||||
mltonCharCallback(codepoint);
|
||||
}
|
||||
|
||||
void setCharCallback(GLFWwindow* window) {
|
||||
glfwSetCharCallback(window, charCallback);
|
||||
}
|
||||
|
||||
void keyCallback(GLFWwindow *window, int key, int scancode, int action, int mods) {
|
||||
mltonKeyCallback(key, scancode, action, mods);
|
||||
}
|
||||
|
||||
void setKeyCallback(GLFWwindow *window) {
|
||||
glfwSetKeyCallback(window, keyCallback);
|
||||
}
|
||||
|
||||
// gamepad code
|
||||
GLFWgamepadstate state;
|
||||
float* axes;
|
||||
int axesCount = -1;
|
||||
|
||||
int getGamepadState(int joystickID) {
|
||||
if (glfwJoystickIsGamepad(joystickID) && glfwGetGamepadState(joystickID, &state)) {
|
||||
axes = glfwGetJoystickAxes(joystickID, &axesCount);
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
float getLeftJoystickXAxisState() {
|
||||
if (axesCount >= 2) {
|
||||
return axes[0];
|
||||
} else {
|
||||
return 99.0;
|
||||
}
|
||||
}
|
||||
|
||||
float getLeftJoystickYAxisState() {
|
||||
if (axesCount >= 2) {
|
||||
return axes[1];
|
||||
} else {
|
||||
return 99.0;
|
||||
}
|
||||
}
|
||||
|
||||
float getL2State() {
|
||||
return axes[2];
|
||||
}
|
||||
|
||||
float getR2State() {
|
||||
return axes[5];
|
||||
}
|
||||
|
||||
int isCrossButtonPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_CROSS];
|
||||
}
|
||||
|
||||
int isCircleButtonPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_CIRCLE];
|
||||
}
|
||||
|
||||
int isSquareButtonPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_SQUARE];
|
||||
}
|
||||
|
||||
int isTriangleButtonPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_TRIANGLE];
|
||||
}
|
||||
|
||||
int isR1ButtonPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_RIGHT_BUMPER];
|
||||
}
|
||||
|
||||
int isL1ButtonPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_LEFT_BUMPER];
|
||||
}
|
||||
|
||||
int isDpadUpPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_DPAD_UP];
|
||||
}
|
||||
|
||||
int isDpadDownPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_DPAD_DOWN];
|
||||
}
|
||||
|
||||
int isDpadLeftPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_DPAD_LEFT];
|
||||
}
|
||||
|
||||
int isDpadRightPressed() {
|
||||
return state.buttons[GLFW_GAMEPAD_BUTTON_DPAD_RIGHT];
|
||||
}
|
||||
91
shf/ffi/glfw-input.sml
Normal file
91
shf/ffi/glfw-input.sml
Normal file
@@ -0,0 +1,91 @@
|
||||
structure Input =
|
||||
struct
|
||||
type window = MLton.Pointer.t
|
||||
|
||||
(* Constants. *)
|
||||
val (PRESS, _) =
|
||||
_symbol "PRESS" public : ( unit -> int ) * ( int -> unit );
|
||||
val PRESS = PRESS ()
|
||||
|
||||
val (REPEAT, _) =
|
||||
_symbol "REPEAT" public : ( unit -> int ) * ( int -> unit );
|
||||
val REPEAT = REPEAT ()
|
||||
|
||||
val (RELEASE, _) =
|
||||
_symbol "RELEASE" public : ( unit -> int ) * ( int -> unit );
|
||||
val RELEASE = RELEASE ()
|
||||
|
||||
val exportFramebufferSizeCallback =
|
||||
_export "mltonFramebufferSizeCallback" public : (int * int -> unit) -> unit;
|
||||
val setFramebufferSizeCallback =
|
||||
_import "setFramebufferSizeCallback" public : window -> unit;
|
||||
|
||||
val exportCharCallback =
|
||||
_export "mltonCharCallback" public : (Word32.word -> unit) -> unit;
|
||||
val setCharCallback =
|
||||
_import "setCharCallback" public : window -> unit;
|
||||
|
||||
val exportKeyCallback =
|
||||
_export "mltonKeyCallback" public : (int * int * int * int -> unit) -> unit;
|
||||
val setKeyCallback =
|
||||
_import "setKeyCallback" public : window -> unit;
|
||||
|
||||
val (KEY_ESC, _) =
|
||||
_symbol "KEY_ESC" public : ( unit -> int ) * ( int -> unit );
|
||||
val KEY_ESC = KEY_ESC ()
|
||||
val (KEY_ENTER, _) =
|
||||
_symbol "KEY_ENTER" public : ( unit -> int ) * ( int -> unit );
|
||||
val KEY_ENTER = KEY_ENTER ()
|
||||
val (KEY_BACKSPACE, _) =
|
||||
_symbol "KEY_BACKSPACE" public : ( unit -> int ) * ( int -> unit );
|
||||
val KEY_BACKSPACE = KEY_BACKSPACE ()
|
||||
|
||||
val (KEY_ARROW_LEFT, _) =
|
||||
_symbol "KEY_ARROW_LEFT" public : ( unit -> int ) * ( int -> unit );
|
||||
val KEY_ARROW_LEFT = KEY_ARROW_LEFT ()
|
||||
val (KEY_ARROW_UP, _) =
|
||||
_symbol "KEY_ARROW_UP" public : ( unit -> int ) * ( int -> unit );
|
||||
val KEY_ARROW_UP = KEY_ARROW_UP ()
|
||||
val (KEY_ARROW_RIGHT, _) =
|
||||
_symbol "KEY_ARROW_RIGHT" public : ( unit -> int ) * ( int -> unit );
|
||||
val KEY_ARROW_RIGHT = KEY_ARROW_RIGHT ()
|
||||
val (KEY_ARROW_DOWN, _) =
|
||||
_symbol "KEY_ARROW_DOWN" public : ( unit -> int ) * ( int -> unit );
|
||||
val KEY_ARROW_DOWN = KEY_ARROW_DOWN ()
|
||||
|
||||
(* gamepad bindings below *)
|
||||
val getGamepadState =
|
||||
_import "getGamepadState" public : int -> int;
|
||||
|
||||
val getLeftJoystickXAxisState =
|
||||
_import "getLeftJoystickXAxisState" public : unit -> Real32.real;
|
||||
val getLeftJoystickYAxisState =
|
||||
_import "getLeftJoystickYAxisState" public : unit -> Real32.real;
|
||||
|
||||
val isCrossButtonPressed =
|
||||
_import "isCrossButtonPressed" public : unit -> int;
|
||||
val isCircleButtonPressed =
|
||||
_import "isCircleButtonPressed" public : unit -> int;
|
||||
val isSquareButtonPressed =
|
||||
_import "isSquareButtonPressed" public : unit -> int;
|
||||
val isTriangleButtonPressed =
|
||||
_import "isTriangleButtonPressed" public : unit -> int;
|
||||
val isR1ButtonPressed =
|
||||
_import "isR1ButtonPressed" public : unit -> int;
|
||||
val isL1ButtonPressed =
|
||||
_import "isL1ButtonPressed" public : unit -> int;
|
||||
|
||||
val isDpadUpButtonPressed =
|
||||
_import "isDpadUpButtonPressed" public : unit -> int;
|
||||
val isDpadDownButtonPressed =
|
||||
_import "isDpadDownButtonPressed" public : unit -> int;
|
||||
val isDpadLeftButtonPressed =
|
||||
_import "isDpadLeftButtonPressed" public : unit -> int;
|
||||
val isDpadRightButtonPressed =
|
||||
_import "isDpadRightButtonPressed" public : unit -> int;
|
||||
|
||||
val getR2State =
|
||||
_import "getR2State" public : unit -> Real32.real;
|
||||
val getL2State =
|
||||
_import "getL2State" public : unit -> Real32.real;
|
||||
end
|
||||
282
shf/ffi/khrplatform.h
Normal file
282
shf/ffi/khrplatform.h
Normal file
@@ -0,0 +1,282 @@
|
||||
#ifndef __khrplatform_h_
|
||||
#define __khrplatform_h_
|
||||
|
||||
/*
|
||||
** Copyright (c) 2008-2018 The Khronos Group Inc.
|
||||
**
|
||||
** Permission is hereby granted, free of charge, to any person obtaining a
|
||||
** copy of this software and/or associated documentation files (the
|
||||
** "Materials"), to deal in the Materials without restriction, including
|
||||
** without limitation the rights to use, copy, modify, merge, publish,
|
||||
** distribute, sublicense, and/or sell copies of the Materials, and to
|
||||
** permit persons to whom the Materials are furnished to do so, subject to
|
||||
** the following conditions:
|
||||
**
|
||||
** The above copyright notice and this permission notice shall be included
|
||||
** in all copies or substantial portions of the Materials.
|
||||
**
|
||||
** THE MATERIALS ARE PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
** EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
** MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||
** IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
** CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
||||
** TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
||||
** MATERIALS OR THE USE OR OTHER DEALINGS IN THE MATERIALS.
|
||||
*/
|
||||
|
||||
/* Khronos platform-specific types and definitions.
|
||||
*
|
||||
* The master copy of khrplatform.h is maintained in the Khronos EGL
|
||||
* Registry repository at https://github.com/KhronosGroup/EGL-Registry
|
||||
* The last semantic modification to khrplatform.h was at commit ID:
|
||||
* 67a3e0864c2d75ea5287b9f3d2eb74a745936692
|
||||
*
|
||||
* Adopters may modify this file to suit their platform. Adopters are
|
||||
* encouraged to submit platform specific modifications to the Khronos
|
||||
* group so that they can be included in future versions of this file.
|
||||
* Please submit changes by filing pull requests or issues on
|
||||
* the EGL Registry repository linked above.
|
||||
*
|
||||
*
|
||||
* See the Implementer's Guidelines for information about where this file
|
||||
* should be located on your system and for more details of its use:
|
||||
* http://www.khronos.org/registry/implementers_guide.pdf
|
||||
*
|
||||
* This file should be included as
|
||||
* #include <KHR/khrplatform.h>
|
||||
* by Khronos client API header files that use its types and defines.
|
||||
*
|
||||
* The types in khrplatform.h should only be used to define API-specific types.
|
||||
*
|
||||
* Types defined in khrplatform.h:
|
||||
* khronos_int8_t signed 8 bit
|
||||
* khronos_uint8_t unsigned 8 bit
|
||||
* khronos_int16_t signed 16 bit
|
||||
* khronos_uint16_t unsigned 16 bit
|
||||
* khronos_int32_t signed 32 bit
|
||||
* khronos_uint32_t unsigned 32 bit
|
||||
* khronos_int64_t signed 64 bit
|
||||
* khronos_uint64_t unsigned 64 bit
|
||||
* khronos_intptr_t signed same number of bits as a pointer
|
||||
* khronos_uintptr_t unsigned same number of bits as a pointer
|
||||
* khronos_ssize_t signed size
|
||||
* khronos_usize_t unsigned size
|
||||
* khronos_float_t signed 32 bit floating point
|
||||
* khronos_time_ns_t unsigned 64 bit time in nanoseconds
|
||||
* khronos_utime_nanoseconds_t unsigned time interval or absolute time in
|
||||
* nanoseconds
|
||||
* khronos_stime_nanoseconds_t signed time interval in nanoseconds
|
||||
* khronos_boolean_enum_t enumerated boolean type. This should
|
||||
* only be used as a base type when a client API's boolean type is
|
||||
* an enum. Client APIs which use an integer or other type for
|
||||
* booleans cannot use this as the base type for their boolean.
|
||||
*
|
||||
* Tokens defined in khrplatform.h:
|
||||
*
|
||||
* KHRONOS_FALSE, KHRONOS_TRUE Enumerated boolean false/true values.
|
||||
*
|
||||
* KHRONOS_SUPPORT_INT64 is 1 if 64 bit integers are supported; otherwise 0.
|
||||
* KHRONOS_SUPPORT_FLOAT is 1 if floats are supported; otherwise 0.
|
||||
*
|
||||
* Calling convention macros defined in this file:
|
||||
* KHRONOS_APICALL
|
||||
* KHRONOS_APIENTRY
|
||||
* KHRONOS_APIATTRIBUTES
|
||||
*
|
||||
* These may be used in function prototypes as:
|
||||
*
|
||||
* KHRONOS_APICALL void KHRONOS_APIENTRY funcname(
|
||||
* int arg1,
|
||||
* int arg2) KHRONOS_APIATTRIBUTES;
|
||||
*/
|
||||
|
||||
/*-------------------------------------------------------------------------
|
||||
* Definition of KHRONOS_APICALL
|
||||
*-------------------------------------------------------------------------
|
||||
* This precedes the return type of the function in the function prototype.
|
||||
*/
|
||||
#if defined(_WIN32) && !defined(__SCITECH_SNAP__)
|
||||
# define KHRONOS_APICALL __declspec(dllimport)
|
||||
#elif defined (__SYMBIAN32__)
|
||||
# define KHRONOS_APICALL IMPORT_C
|
||||
#elif defined(__ANDROID__)
|
||||
# define KHRONOS_APICALL __attribute__((visibility("default")))
|
||||
#else
|
||||
# define KHRONOS_APICALL
|
||||
#endif
|
||||
|
||||
/*-------------------------------------------------------------------------
|
||||
* Definition of KHRONOS_APIENTRY
|
||||
*-------------------------------------------------------------------------
|
||||
* This follows the return type of the function and precedes the function
|
||||
* name in the function prototype.
|
||||
*/
|
||||
#if defined(_WIN32) && !defined(_WIN32_WCE) && !defined(__SCITECH_SNAP__)
|
||||
/* Win32 but not WinCE */
|
||||
# define KHRONOS_APIENTRY __stdcall
|
||||
#else
|
||||
# define KHRONOS_APIENTRY
|
||||
#endif
|
||||
|
||||
/*-------------------------------------------------------------------------
|
||||
* Definition of KHRONOS_APIATTRIBUTES
|
||||
*-------------------------------------------------------------------------
|
||||
* This follows the closing parenthesis of the function prototype arguments.
|
||||
*/
|
||||
#if defined (__ARMCC_2__)
|
||||
#define KHRONOS_APIATTRIBUTES __softfp
|
||||
#else
|
||||
#define KHRONOS_APIATTRIBUTES
|
||||
#endif
|
||||
|
||||
/*-------------------------------------------------------------------------
|
||||
* basic type definitions
|
||||
*-----------------------------------------------------------------------*/
|
||||
#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || defined(__GNUC__) || defined(__SCO__) || defined(__USLC__)
|
||||
|
||||
|
||||
/*
|
||||
* Using <stdint.h>
|
||||
*/
|
||||
#include <stdint.h>
|
||||
typedef int32_t khronos_int32_t;
|
||||
typedef uint32_t khronos_uint32_t;
|
||||
typedef int64_t khronos_int64_t;
|
||||
typedef uint64_t khronos_uint64_t;
|
||||
#define KHRONOS_SUPPORT_INT64 1
|
||||
#define KHRONOS_SUPPORT_FLOAT 1
|
||||
|
||||
#elif defined(__VMS ) || defined(__sgi)
|
||||
|
||||
/*
|
||||
* Using <inttypes.h>
|
||||
*/
|
||||
#include <inttypes.h>
|
||||
typedef int32_t khronos_int32_t;
|
||||
typedef uint32_t khronos_uint32_t;
|
||||
typedef int64_t khronos_int64_t;
|
||||
typedef uint64_t khronos_uint64_t;
|
||||
#define KHRONOS_SUPPORT_INT64 1
|
||||
#define KHRONOS_SUPPORT_FLOAT 1
|
||||
|
||||
#elif defined(_WIN32) && !defined(__SCITECH_SNAP__)
|
||||
|
||||
/*
|
||||
* Win32
|
||||
*/
|
||||
typedef __int32 khronos_int32_t;
|
||||
typedef unsigned __int32 khronos_uint32_t;
|
||||
typedef __int64 khronos_int64_t;
|
||||
typedef unsigned __int64 khronos_uint64_t;
|
||||
#define KHRONOS_SUPPORT_INT64 1
|
||||
#define KHRONOS_SUPPORT_FLOAT 1
|
||||
|
||||
#elif defined(__sun__) || defined(__digital__)
|
||||
|
||||
/*
|
||||
* Sun or Digital
|
||||
*/
|
||||
typedef int khronos_int32_t;
|
||||
typedef unsigned int khronos_uint32_t;
|
||||
#if defined(__arch64__) || defined(_LP64)
|
||||
typedef long int khronos_int64_t;
|
||||
typedef unsigned long int khronos_uint64_t;
|
||||
#else
|
||||
typedef long long int khronos_int64_t;
|
||||
typedef unsigned long long int khronos_uint64_t;
|
||||
#endif /* __arch64__ */
|
||||
#define KHRONOS_SUPPORT_INT64 1
|
||||
#define KHRONOS_SUPPORT_FLOAT 1
|
||||
|
||||
#elif 0
|
||||
|
||||
/*
|
||||
* Hypothetical platform with no float or int64 support
|
||||
*/
|
||||
typedef int khronos_int32_t;
|
||||
typedef unsigned int khronos_uint32_t;
|
||||
#define KHRONOS_SUPPORT_INT64 0
|
||||
#define KHRONOS_SUPPORT_FLOAT 0
|
||||
|
||||
#else
|
||||
|
||||
/*
|
||||
* Generic fallback
|
||||
*/
|
||||
#include <stdint.h>
|
||||
typedef int32_t khronos_int32_t;
|
||||
typedef uint32_t khronos_uint32_t;
|
||||
typedef int64_t khronos_int64_t;
|
||||
typedef uint64_t khronos_uint64_t;
|
||||
#define KHRONOS_SUPPORT_INT64 1
|
||||
#define KHRONOS_SUPPORT_FLOAT 1
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
* Types that are (so far) the same on all platforms
|
||||
*/
|
||||
typedef signed char khronos_int8_t;
|
||||
typedef unsigned char khronos_uint8_t;
|
||||
typedef signed short int khronos_int16_t;
|
||||
typedef unsigned short int khronos_uint16_t;
|
||||
|
||||
/*
|
||||
* Types that differ between LLP64 and LP64 architectures - in LLP64,
|
||||
* pointers are 64 bits, but 'long' is still 32 bits. Win64 appears
|
||||
* to be the only LLP64 architecture in current use.
|
||||
*/
|
||||
#ifdef _WIN64
|
||||
typedef signed long long int khronos_intptr_t;
|
||||
typedef unsigned long long int khronos_uintptr_t;
|
||||
typedef signed long long int khronos_ssize_t;
|
||||
typedef unsigned long long int khronos_usize_t;
|
||||
#else
|
||||
typedef signed long int khronos_intptr_t;
|
||||
typedef unsigned long int khronos_uintptr_t;
|
||||
typedef signed long int khronos_ssize_t;
|
||||
typedef unsigned long int khronos_usize_t;
|
||||
#endif
|
||||
|
||||
#if KHRONOS_SUPPORT_FLOAT
|
||||
/*
|
||||
* Float type
|
||||
*/
|
||||
typedef float khronos_float_t;
|
||||
#endif
|
||||
|
||||
#if KHRONOS_SUPPORT_INT64
|
||||
/* Time types
|
||||
*
|
||||
* These types can be used to represent a time interval in nanoseconds or
|
||||
* an absolute Unadjusted System Time. Unadjusted System Time is the number
|
||||
* of nanoseconds since some arbitrary system event (e.g. since the last
|
||||
* time the system booted). The Unadjusted System Time is an unsigned
|
||||
* 64 bit value that wraps back to 0 every 584 years. Time intervals
|
||||
* may be either signed or unsigned.
|
||||
*/
|
||||
typedef khronos_uint64_t khronos_utime_nanoseconds_t;
|
||||
typedef khronos_int64_t khronos_stime_nanoseconds_t;
|
||||
#endif
|
||||
|
||||
/*
|
||||
* Dummy value used to pad enum types to 32 bits.
|
||||
*/
|
||||
#ifndef KHRONOS_MAX_ENUM
|
||||
#define KHRONOS_MAX_ENUM 0x7FFFFFFF
|
||||
#endif
|
||||
|
||||
/*
|
||||
* Enumerated boolean type
|
||||
*
|
||||
* Values other than zero should be considered to be true. Therefore
|
||||
* comparisons should not be made against KHRONOS_TRUE.
|
||||
*/
|
||||
typedef enum {
|
||||
KHRONOS_FALSE = 0,
|
||||
KHRONOS_TRUE = 1,
|
||||
KHRONOS_BOOLEAN_ENUM_FORCE_SIZE = KHRONOS_MAX_ENUM
|
||||
} khronos_boolean_enum_t;
|
||||
|
||||
#endif /* __khrplatform_h_ */
|
||||
171
shf/ffi/mlton-glfw-export.h
Normal file
171
shf/ffi/mlton-glfw-export.h
Normal file
@@ -0,0 +1,171 @@
|
||||
#ifndef __SHF_GLFW_ML_H__
|
||||
#define __SHF_GLFW_ML_H__
|
||||
|
||||
/* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh
|
||||
* Jagannathan, and Stephen Weeks.
|
||||
*
|
||||
* MLton is released under a HPND-style license.
|
||||
* See the file MLton-LICENSE for details.
|
||||
*/
|
||||
|
||||
#ifndef _MLTON_MLTYPES_H_
|
||||
#define _MLTON_MLTYPES_H_
|
||||
|
||||
/* We need these because in header files for exported SML functions,
|
||||
* types.h is included without cenv.h.
|
||||
*/
|
||||
#if (defined (_AIX) || defined (__hpux__) || defined (__OpenBSD__))
|
||||
#include <inttypes.h>
|
||||
#elif (defined (__sun__))
|
||||
#include <sys/int_types.h>
|
||||
#else
|
||||
#include <stdint.h>
|
||||
#endif
|
||||
|
||||
/* ML types */
|
||||
typedef unsigned char PointerAux __attribute__ ((may_alias));
|
||||
typedef PointerAux* Pointer;
|
||||
#define Array(t) Pointer
|
||||
#define Ref(t) Pointer
|
||||
#define Vector(t) Pointer
|
||||
|
||||
typedef int8_t Int8_t;
|
||||
typedef int8_t Int8;
|
||||
typedef int16_t Int16_t;
|
||||
typedef int16_t Int16;
|
||||
typedef int32_t Int32_t;
|
||||
typedef int32_t Int32;
|
||||
typedef int64_t Int64_t;
|
||||
typedef int64_t Int64;
|
||||
typedef float Real32_t;
|
||||
typedef float Real32;
|
||||
typedef double Real64_t;
|
||||
typedef double Real64;
|
||||
typedef uint8_t Word8_t;
|
||||
typedef uint8_t Word8;
|
||||
typedef uint16_t Word16_t;
|
||||
typedef uint16_t Word16;
|
||||
typedef uint32_t Word32_t;
|
||||
typedef uint32_t Word32;
|
||||
typedef uint64_t Word64_t;
|
||||
typedef uint64_t Word64;
|
||||
|
||||
typedef Int8_t WordS8_t;
|
||||
typedef Int8_t WordS8;
|
||||
typedef Int16_t WordS16_t;
|
||||
typedef Int16_t WordS16;
|
||||
typedef Int32_t WordS32_t;
|
||||
typedef Int32_t WordS32;
|
||||
typedef Int64_t WordS64_t;
|
||||
typedef Int64_t WordS64;
|
||||
|
||||
typedef Word8_t WordU8_t;
|
||||
typedef Word8_t WordU8;
|
||||
typedef Word16_t WordU16_t;
|
||||
typedef Word16_t WordU16;
|
||||
typedef Word32_t WordU32_t;
|
||||
typedef Word32_t WordU32;
|
||||
typedef Word64_t WordU64_t;
|
||||
typedef Word64_t WordU64;
|
||||
|
||||
typedef WordU8_t Char8_t;
|
||||
typedef WordU8_t Char8;
|
||||
typedef WordU16_t Char16_t;
|
||||
typedef WordU16_t Char16;
|
||||
typedef WordU32_t Char32_t;
|
||||
typedef WordU32_t Char32;
|
||||
|
||||
typedef Vector(Char8_t) String8_t;
|
||||
typedef Vector(Char8_t) String8;
|
||||
typedef Vector(Char16_t) String16_t;
|
||||
typedef Vector(Char16_t) String16;
|
||||
typedef Vector(Char32_t) String32_t;
|
||||
typedef Vector(Char32_t) String32;
|
||||
|
||||
typedef Int32_t Bool_t;
|
||||
typedef Int32_t Bool;
|
||||
typedef String8_t NullString8_t;
|
||||
typedef String8_t NullString8;
|
||||
|
||||
typedef void* CPointer;
|
||||
typedef Pointer Objptr;
|
||||
|
||||
#endif /* _MLTON_MLTYPES_H_ */
|
||||
|
||||
/* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
|
||||
* Jagannathan, and Stephen Weeks.
|
||||
* Copyright (C) 1997-2000 NEC Research Institute.
|
||||
*
|
||||
* MLton is released under a HPND-style license.
|
||||
* See the file MLton-LICENSE for details.
|
||||
*/
|
||||
|
||||
#ifndef _MLTON_EXPORT_H_
|
||||
#define _MLTON_EXPORT_H_
|
||||
|
||||
/* ------------------------------------------------- */
|
||||
/* Symbols */
|
||||
/* ------------------------------------------------- */
|
||||
|
||||
/* An external symbol is something not defined by the module
|
||||
* (executable or library) being built. Rather, it is provided
|
||||
* from a library dependency (dll, dylib, or shared object).
|
||||
*
|
||||
* A public symbol is defined in this module as being available
|
||||
* to users outside of this module. If building a library, this
|
||||
* means the symbol will be part of the public interface.
|
||||
*
|
||||
* A private symbol is defined within this module, but will not
|
||||
* be made available outside of it. This is typically used for
|
||||
* internal implementation details that should not be accessible.
|
||||
*/
|
||||
|
||||
#if defined(_WIN32) || defined(_WIN64) || defined(__CYGWIN__)
|
||||
#define EXTERNAL __declspec(dllimport)
|
||||
#define PUBLIC __declspec(dllexport)
|
||||
#define PRIVATE
|
||||
#else
|
||||
#define EXTERNAL __attribute__((visibility("default")))
|
||||
#define PUBLIC __attribute__((visibility("default")))
|
||||
#define PRIVATE __attribute__((visibility("hidden")))
|
||||
#endif
|
||||
|
||||
#endif /* _MLTON_EXPORT_H_ */
|
||||
|
||||
#if !defined(PART_OF_SHF_GLFW) && \
|
||||
!defined(STATIC_LINK_SHF_GLFW) && \
|
||||
!defined(DYNAMIC_LINK_SHF_GLFW)
|
||||
#define PART_OF_SHF_GLFW
|
||||
#endif
|
||||
|
||||
#if defined(PART_OF_SHF_GLFW)
|
||||
#define MLLIB_PRIVATE(x) PRIVATE x
|
||||
#define MLLIB_PUBLIC(x) PUBLIC x
|
||||
#elif defined(STATIC_LINK_SHF_GLFW)
|
||||
#define MLLIB_PRIVATE(x)
|
||||
#define MLLIB_PUBLIC(x) PUBLIC x
|
||||
#elif defined(DYNAMIC_LINK_SHF_GLFW)
|
||||
#define MLLIB_PRIVATE(x)
|
||||
#define MLLIB_PUBLIC(x) EXTERNAL x
|
||||
#else
|
||||
#error Must specify linkage for shf_glfw
|
||||
#define MLLIB_PRIVATE(x)
|
||||
#define MLLIB_PUBLIC(x)
|
||||
#endif
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
MLLIB_PUBLIC(void mltonFramebufferSizeCallback (Int32 x0, Int32 x1);)
|
||||
MLLIB_PUBLIC(void mltonCharCallback (Word32 x0);)
|
||||
MLLIB_PUBLIC(void mltonKeyCallback (Int32 x0, Int32 x1, Int32 x2, Int32 x3);)
|
||||
|
||||
#undef MLLIB_PRIVATE
|
||||
#undef MLLIB_PUBLIC
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif /* __SHF_GLFW_ML_H__ */
|
||||
172
shf/ffi/mlton-rgfw-export.h
Normal file
172
shf/ffi/mlton-rgfw-export.h
Normal file
@@ -0,0 +1,172 @@
|
||||
#ifndef __SHF_RGFW_ML_H__
|
||||
#define __SHF_RGFW_ML_H__
|
||||
|
||||
/* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh
|
||||
* Jagannathan, and Stephen Weeks.
|
||||
*
|
||||
* MLton is released under a HPND-style license.
|
||||
* See the file MLton-LICENSE for details.
|
||||
*/
|
||||
|
||||
#ifndef _MLTON_MLTYPES_H_
|
||||
#define _MLTON_MLTYPES_H_
|
||||
|
||||
/* We need these because in header files for exported SML functions,
|
||||
* types.h is included without cenv.h.
|
||||
*/
|
||||
#if (defined (_AIX) || defined (__hpux__) || defined (__OpenBSD__))
|
||||
#include <inttypes.h>
|
||||
#elif (defined (__sun__))
|
||||
#include <sys/int_types.h>
|
||||
#else
|
||||
#include <stdint.h>
|
||||
#endif
|
||||
|
||||
/* ML types */
|
||||
typedef unsigned char PointerAux __attribute__ ((may_alias));
|
||||
typedef PointerAux* Pointer;
|
||||
#define Array(t) Pointer
|
||||
#define Ref(t) Pointer
|
||||
#define Vector(t) Pointer
|
||||
|
||||
typedef int8_t Int8_t;
|
||||
typedef int8_t Int8;
|
||||
typedef int16_t Int16_t;
|
||||
typedef int16_t Int16;
|
||||
typedef int32_t Int32_t;
|
||||
typedef int32_t Int32;
|
||||
typedef int64_t Int64_t;
|
||||
typedef int64_t Int64;
|
||||
typedef float Real32_t;
|
||||
typedef float Real32;
|
||||
typedef double Real64_t;
|
||||
typedef double Real64;
|
||||
typedef uint8_t Word8_t;
|
||||
typedef uint8_t Word8;
|
||||
typedef uint16_t Word16_t;
|
||||
typedef uint16_t Word16;
|
||||
typedef uint32_t Word32_t;
|
||||
typedef uint32_t Word32;
|
||||
typedef uint64_t Word64_t;
|
||||
typedef uint64_t Word64;
|
||||
|
||||
typedef Int8_t WordS8_t;
|
||||
typedef Int8_t WordS8;
|
||||
typedef Int16_t WordS16_t;
|
||||
typedef Int16_t WordS16;
|
||||
typedef Int32_t WordS32_t;
|
||||
typedef Int32_t WordS32;
|
||||
typedef Int64_t WordS64_t;
|
||||
typedef Int64_t WordS64;
|
||||
|
||||
typedef Word8_t WordU8_t;
|
||||
typedef Word8_t WordU8;
|
||||
typedef Word16_t WordU16_t;
|
||||
typedef Word16_t WordU16;
|
||||
typedef Word32_t WordU32_t;
|
||||
typedef Word32_t WordU32;
|
||||
typedef Word64_t WordU64_t;
|
||||
typedef Word64_t WordU64;
|
||||
|
||||
typedef WordU8_t Char8_t;
|
||||
typedef WordU8_t Char8;
|
||||
typedef WordU16_t Char16_t;
|
||||
typedef WordU16_t Char16;
|
||||
typedef WordU32_t Char32_t;
|
||||
typedef WordU32_t Char32;
|
||||
|
||||
typedef Vector(Char8_t) String8_t;
|
||||
typedef Vector(Char8_t) String8;
|
||||
typedef Vector(Char16_t) String16_t;
|
||||
typedef Vector(Char16_t) String16;
|
||||
typedef Vector(Char32_t) String32_t;
|
||||
typedef Vector(Char32_t) String32;
|
||||
|
||||
typedef Int32_t Bool_t;
|
||||
typedef String8_t NullString8_t;
|
||||
typedef String8_t NullString8;
|
||||
|
||||
typedef void* CPointer;
|
||||
typedef Pointer Objptr;
|
||||
|
||||
#endif /* _MLTON_MLTYPES_H_ */
|
||||
|
||||
/* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
|
||||
* Jagannathan, and Stephen Weeks.
|
||||
* Copyright (C) 1997-2000 NEC Research Institute.
|
||||
*
|
||||
* MLton is released under a HPND-style license.
|
||||
* See the file MLton-LICENSE for details.
|
||||
*/
|
||||
|
||||
#ifndef _MLTON_EXPORT_H_
|
||||
#define _MLTON_EXPORT_H_
|
||||
|
||||
/* ------------------------------------------------- */
|
||||
/* Symbols */
|
||||
/* ------------------------------------------------- */
|
||||
|
||||
/* An external symbol is something not defined by the module
|
||||
* (executable or library) being built. Rather, it is provided
|
||||
* from a library dependency (dll, dylib, or shared object).
|
||||
*
|
||||
* A public symbol is defined in this module as being available
|
||||
* to users outside of this module. If building a library, this
|
||||
* means the symbol will be part of the public interface.
|
||||
*
|
||||
* A private symbol is defined within this module, but will not
|
||||
* be made available outside of it. This is typically used for
|
||||
* internal implementation details that should not be accessible.
|
||||
*/
|
||||
|
||||
#if defined(_WIN32) || defined(_WIN64) || defined(__CYGWIN__)
|
||||
#define EXTERNAL __declspec(dllimport)
|
||||
#define PUBLIC __declspec(dllexport)
|
||||
#define PRIVATE
|
||||
#else
|
||||
#define EXTERNAL __attribute__((visibility("default")))
|
||||
#define PUBLIC __attribute__((visibility("default")))
|
||||
#define PRIVATE __attribute__((visibility("hidden")))
|
||||
#endif
|
||||
|
||||
#endif /* _MLTON_EXPORT_H_ */
|
||||
|
||||
#if !defined(PART_OF_SHF_RGFW) && \
|
||||
!defined(STATIC_LINK_SHF_RGFW) && \
|
||||
!defined(DYNAMIC_LINK_SHF_RGFW)
|
||||
#define PART_OF_SHF_RGFW
|
||||
#endif
|
||||
|
||||
#if defined(PART_OF_SHF_RGFW)
|
||||
#define MLLIB_PRIVATE(x) PRIVATE x
|
||||
#define MLLIB_PUBLIC(x) PUBLIC x
|
||||
#elif defined(STATIC_LINK_SHF_RGFW)
|
||||
#define MLLIB_PRIVATE(x)
|
||||
#define MLLIB_PUBLIC(x) PUBLIC x
|
||||
#elif defined(DYNAMIC_LINK_SHF_RGFW)
|
||||
#define MLLIB_PRIVATE(x)
|
||||
#define MLLIB_PUBLIC(x) EXTERNAL x
|
||||
#else
|
||||
#error Must specify linkage for shf_rgfw
|
||||
#define MLLIB_PRIVATE(x)
|
||||
#define MLLIB_PUBLIC(x)
|
||||
#endif
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
MLLIB_PUBLIC(void mltonEscape ();)
|
||||
MLLIB_PUBLIC(void mltonBackspace ();)
|
||||
MLLIB_PUBLIC(void mltonEnter ();)
|
||||
MLLIB_PUBLIC(void mltonChar (Word8 x0);)
|
||||
MLLIB_PUBLIC(void mltonResize (Int32 x0, Int32 x1);)
|
||||
|
||||
#undef MLLIB_PRIVATE
|
||||
#undef MLLIB_PUBLIC
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
#endif /* __SHF_RGFW_ML_H__ */
|
||||
380
shf/ffi/rgfw-export.c
Normal file
380
shf/ffi/rgfw-export.c
Normal file
@@ -0,0 +1,380 @@
|
||||
#define RGFW_OPENGL
|
||||
#define RGFW_ALLOC_DROPFILES
|
||||
#define RGFW_IMPLEMENTATION
|
||||
#define RGFW_PRINT_ERRORS
|
||||
#define RGFW_DEBUG
|
||||
#define GL_SILENCE_DEPRECATION
|
||||
#include "RGFW.h"
|
||||
#include <GLES3/gl3.h>
|
||||
#include <stdbool.h>
|
||||
#include <ctype.h>
|
||||
#include "mlton-rgfw-export.h"
|
||||
|
||||
RGFW_window* createWindow(char* title, int x, int y, int width, int height) {
|
||||
return RGFW_createWindow(title, x, y, width, height, RGFW_windowCenter | RGFW_windowOpenGL);
|
||||
}
|
||||
|
||||
void closeWindow(RGFW_window* window) {
|
||||
RGFW_window_close(window);
|
||||
}
|
||||
|
||||
bool shouldCloseWindow(RGFW_window* window) {
|
||||
if (RGFW_window_shouldClose(window)) {
|
||||
return true;
|
||||
} else {
|
||||
return false;
|
||||
}
|
||||
}
|
||||
|
||||
void swapBuffers(RGFW_window* window) {
|
||||
RGFW_window_swapBuffers_OpenGL(window);
|
||||
}
|
||||
|
||||
void enableVsync(RGFW_window* window) {
|
||||
// A swap interval of 1 will enable vsync
|
||||
RGFW_window_swapInterval_OpenGL(window, 1);
|
||||
}
|
||||
|
||||
void writeClipboard(char* string, int stringSize) {
|
||||
RGFW_writeClipboard(string, stringSize);
|
||||
}
|
||||
|
||||
void keyCallback(RGFW_window* window, unsigned char key, unsigned char symbol, unsigned char keymod, unsigned char repeated, unsigned char pressed) {
|
||||
if (pressed || repeated) {
|
||||
switch (key) {
|
||||
case RGFW_escape:
|
||||
mltonEscape();
|
||||
break;
|
||||
case RGFW_backSpace:
|
||||
mltonBackspace();
|
||||
break;
|
||||
case RGFW_enter:
|
||||
mltonEnter();
|
||||
break;
|
||||
|
||||
case RGFW_a:
|
||||
case RGFW_b:
|
||||
case RGFW_c:
|
||||
case RGFW_d:
|
||||
case RGFW_e:
|
||||
case RGFW_f:
|
||||
case RGFW_g:
|
||||
case RGFW_h:
|
||||
case RGFW_i:
|
||||
case RGFW_j:
|
||||
case RGFW_k:
|
||||
case RGFW_l:
|
||||
case RGFW_m:
|
||||
case RGFW_n:
|
||||
case RGFW_o:
|
||||
case RGFW_p:
|
||||
case RGFW_q:
|
||||
case RGFW_r:
|
||||
case RGFW_s:
|
||||
case RGFW_t:
|
||||
case RGFW_u:
|
||||
case RGFW_v:
|
||||
case RGFW_w:
|
||||
case RGFW_x:
|
||||
case RGFW_y:
|
||||
case RGFW_z:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar(toupper((char)key));
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
|
||||
// These two don't have "shifted versions"
|
||||
// so no need to turn to upper case
|
||||
case RGFW_tab:
|
||||
case RGFW_space:
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
|
||||
// Have to "shift" symbols manually
|
||||
// because toupper(char) does not produce
|
||||
// the desired character
|
||||
case RGFW_backtick:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('~');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_0:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar(')');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_1:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('!');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_2:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('@');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_3:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('#');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_4:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('$');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_5:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('%');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_6:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('^');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_7:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('&');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_8:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('*');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_9:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('(');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_minus:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('_');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_equal:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('+');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_period:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('>');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_comma:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('<');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_slash:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('?');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_bracket:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('{');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_closeBracket:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('}');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_semicolon:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar(':');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_apostrophe:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('"');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
case RGFW_backSlash:
|
||||
if (keymod == RGFW_modShift) {
|
||||
mltonChar('|');
|
||||
break;
|
||||
} else {
|
||||
mltonChar((char)key);
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void setKeyCallback() {
|
||||
RGFW_setKeyCallback(keyCallback);
|
||||
}
|
||||
|
||||
void resizeCallback(RGFW_window* window, int width, int height) {
|
||||
glViewport(0, 0, width, height);
|
||||
mltonResize(width, height);
|
||||
}
|
||||
|
||||
void setResizeCallback() {
|
||||
RGFW_setWindowResizedCallback(resizeCallback);
|
||||
}
|
||||
|
||||
void pollEvents() {
|
||||
RGFW_pollEvents();
|
||||
}
|
||||
|
||||
// OpenGL constants used below
|
||||
unsigned int VERTEX_SHADER = GL_VERTEX_SHADER;
|
||||
unsigned int FRAGMENT_SHADER = GL_FRAGMENT_SHADER;
|
||||
unsigned int TRIANGLES = GL_TRIANGLES;
|
||||
unsigned int STATIC_DRAW = GL_STATIC_DRAW;
|
||||
unsigned int DYNAMIC_DRAW = GL_DYNAMIC_DRAW;
|
||||
|
||||
// OpenGL functions used below
|
||||
void enableDepthTest() {
|
||||
glEnable(GL_DEPTH_TEST);
|
||||
}
|
||||
|
||||
void viewport(int width, int height) {
|
||||
glViewport(0, 0, width, height);
|
||||
}
|
||||
|
||||
void clearColor(float r, float g, float b, float a) {
|
||||
glClearColor(r, g, b, a);
|
||||
}
|
||||
|
||||
void clear() {
|
||||
glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT);
|
||||
}
|
||||
|
||||
unsigned int createBuffer() {
|
||||
unsigned int buffer;
|
||||
glGenBuffers(1, &buffer);
|
||||
return buffer;
|
||||
}
|
||||
|
||||
void bindBuffer(unsigned int buffer) {
|
||||
glBindBuffer(GL_ARRAY_BUFFER, buffer);
|
||||
}
|
||||
|
||||
void bufferData(float* vector, int vectorLength, unsigned int updateMode) {
|
||||
glBufferData(GL_ARRAY_BUFFER, sizeof(float) * vectorLength, vector, updateMode);
|
||||
}
|
||||
|
||||
unsigned int createShader(unsigned int shaderType) {
|
||||
return glCreateShader(shaderType);
|
||||
}
|
||||
|
||||
void shaderSource(unsigned int shader, const char *sourceString) {
|
||||
glShaderSource(shader, 1, &sourceString, NULL);
|
||||
}
|
||||
|
||||
void compileShader(unsigned int shader) {
|
||||
glCompileShader(shader);
|
||||
}
|
||||
|
||||
void deleteShader(unsigned int shader) {
|
||||
glDeleteShader(shader);
|
||||
}
|
||||
|
||||
void vertexAttribPointer(int location, int numVecComponents, int stride, int offset) {
|
||||
glVertexAttribPointer(location, numVecComponents, GL_FLOAT, GL_FALSE, stride * sizeof(float), (void*)offset);
|
||||
}
|
||||
|
||||
void enableVertexAttribArray(int location) {
|
||||
glEnableVertexAttribArray(location);
|
||||
}
|
||||
|
||||
unsigned int createProgram() {
|
||||
return glCreateProgram();
|
||||
}
|
||||
|
||||
void attachShader(unsigned int program, unsigned int shader) {
|
||||
glAttachShader(program, shader);
|
||||
}
|
||||
|
||||
void linkProgram(unsigned int program) {
|
||||
glLinkProgram(program);
|
||||
}
|
||||
|
||||
void useProgram(unsigned int program) {
|
||||
glUseProgram(program);
|
||||
}
|
||||
|
||||
void deleteProgram(unsigned int program) {
|
||||
glDeleteProgram(program);
|
||||
}
|
||||
|
||||
void drawArrays(unsigned int drawMode, int startIndex, int numVertices) {
|
||||
glDrawArrays(drawMode, startIndex, numVertices);
|
||||
}
|
||||
|
||||
int getUniformLocation(unsigned int program, const char *uniformName) {
|
||||
glGetUniformLocation(program, uniformName);
|
||||
}
|
||||
|
||||
void uniform4f(int uniformLocation, float a, float b, float c, float d) {
|
||||
glUniform4f(uniformLocation, a, b, c, d);
|
||||
}
|
||||
37
shf/ffi/rgfw-import.sml
Normal file
37
shf/ffi/rgfw-import.sml
Normal file
@@ -0,0 +1,37 @@
|
||||
structure Rgfw =
|
||||
struct
|
||||
type window = MLton.Pointer.t
|
||||
|
||||
(* RGFW functions. *)
|
||||
val createWindow =
|
||||
_import "createWindow" public : string * int * int * int * int -> window;
|
||||
val closeWindow =
|
||||
_import "closeWindow" public : window -> unit;
|
||||
val shouldCloseWindow =
|
||||
_import "shouldCloseWindow" public : window -> bool;
|
||||
val swapBuffers =
|
||||
_import "swapBuffers" public : window -> unit;
|
||||
val enableVsync =
|
||||
_import "enableVsync" public : window -> unit;
|
||||
val pollEvents =
|
||||
_import "pollEvents" public reentrant : unit -> unit;
|
||||
|
||||
val writeClipboard =
|
||||
_import "writeClipboard" public : string * int -> unit;
|
||||
|
||||
val exportEscapeCallback =
|
||||
_export "mltonEscape" public : (unit -> unit) -> unit;
|
||||
val exportBackspaceCallback =
|
||||
_export "mltonBackspace" public : (unit -> unit) -> unit;
|
||||
val exportEnterCallback =
|
||||
_export "mltonEnter" public : (unit -> unit) -> unit;
|
||||
val exportCharCallback =
|
||||
_export "mltonChar" public : (char -> unit) -> unit;
|
||||
val setKeyCallback =
|
||||
_import "setKeyCallback" public : unit -> unit;
|
||||
|
||||
val exportResizeCallback =
|
||||
_export "mltonResize" public : (int * int -> unit) -> unit;
|
||||
val setResizeCallback =
|
||||
_import "setResizeCallback" public : unit -> unit;
|
||||
end
|
||||
2
shf/message-types/draw-msg.sml
Normal file
2
shf/message-types/draw-msg.sml
Normal file
@@ -0,0 +1,2 @@
|
||||
structure DrawMsg =
|
||||
struct datatype t = DRAW_TEXT of Real32.real vector | YANK of string end
|
||||
13
shf/message-types/input-msg.sml
Normal file
13
shf/message-types/input-msg.sml
Normal file
@@ -0,0 +1,13 @@
|
||||
structure InputMsg =
|
||||
struct
|
||||
datatype t =
|
||||
CHAR_EVENT of char
|
||||
| KEY_ESC
|
||||
| KEY_ENTER
|
||||
| KEY_BACKSPACE
|
||||
| RESIZE_EVENT of int * int
|
||||
| ARROW_LEFT
|
||||
| ARROW_UP
|
||||
| ARROW_RIGHT
|
||||
| ARROW_DOWN
|
||||
end
|
||||
1
shf/message-types/mailbox-type.sml
Normal file
1
shf/message-types/mailbox-type.sml
Normal file
@@ -0,0 +1 @@
|
||||
structure MailboxType = struct datatype t = DRAW of DrawMsg.t end
|
||||
1
shf/shell/draw-mailbox.sml
Normal file
1
shf/shell/draw-mailbox.sml
Normal file
@@ -0,0 +1 @@
|
||||
structure DrawMailbox = MakeMailbox(DrawMsg)
|
||||
38
shf/shell/exception-logger.sml
Normal file
38
shf/shell/exception-logger.sml
Normal file
@@ -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 errName = General.exnName e ^ "\n"
|
||||
val stackTrace = MLton.Exn.history e
|
||||
val stackTrace = (String.concatWith "\n" stackTrace) ^ "\n"
|
||||
val history = !textCommands ^ "\n\n"
|
||||
|
||||
val log = String.concat
|
||||
["ERROR: ", errName, stackTrace, "HISTORY: ", history]
|
||||
|
||||
val () = print ("\n" ^ log)
|
||||
|
||||
val io = TextIO.openAppend "exceptions.log"
|
||||
val () = TextIO.output (io, log)
|
||||
val () = TextIO.closeOut io
|
||||
in
|
||||
raise e
|
||||
end
|
||||
end
|
||||
82
shf/shell/gl-draw.sml
Normal file
82
shf/shell/gl-draw.sml
Normal file
@@ -0,0 +1,82 @@
|
||||
structure GlDraw =
|
||||
struct
|
||||
open DrawMsg
|
||||
|
||||
type t =
|
||||
{ textVertexBuffer: Word32.word
|
||||
, textProgram: Word32.word
|
||||
, textDrawLength: int
|
||||
}
|
||||
|
||||
fun createShader (shaderType, shaderString) =
|
||||
let
|
||||
val shader = Gles3.createShader shaderType
|
||||
val _ = Gles3.shaderSource (shader, shaderString)
|
||||
val _ = Gles3.compileShader shader
|
||||
in
|
||||
shader
|
||||
end
|
||||
|
||||
fun createProgram (vertexShader, fragmentShader) =
|
||||
let
|
||||
val program = Gles3.createProgram ()
|
||||
val _ = Gles3.attachShader (program, vertexShader)
|
||||
val _ = Gles3.attachShader (program, fragmentShader)
|
||||
val _ = Gles3.linkProgram program
|
||||
in
|
||||
program
|
||||
end
|
||||
|
||||
fun create () =
|
||||
let
|
||||
(* create vertex buffer, program, etc. for text. *)
|
||||
val textVertexBuffer = Gles3.createBuffer ()
|
||||
val xyzRgbVertexShader = createShader
|
||||
(Gles3.VERTEX_SHADER, GlShaders.xyzRgbVertexShaderString)
|
||||
|
||||
val rgbFragmentShader = createShader
|
||||
(Gles3.FRAGMENT_SHADER, GlShaders.rgbFragmentShaderString)
|
||||
|
||||
val textProgram = createProgram (xyzRgbVertexShader, rgbFragmentShader)
|
||||
|
||||
(* clean up shaders which are no longer needed once progran is linked. *)
|
||||
val _ = Gles3.deleteShader xyzRgbVertexShader
|
||||
val _ = Gles3.deleteShader rgbFragmentShader
|
||||
|
||||
(* because we only have a single vertex buffer,
|
||||
* we only need to bind and set attributes once. *)
|
||||
val _ = Gles3.bindBuffer textVertexBuffer
|
||||
|
||||
(* enable xyz component from uploaded array *)
|
||||
val _ = Gles3.vertexAttribPointer (0, 3, 6, 0)
|
||||
val _ = Gles3.enableVertexAttribArray 0
|
||||
(* enable rgb component from uploaded array *)
|
||||
val _ = Gles3.vertexAttribPointer (1, 3, 6, 12)
|
||||
val _ = Gles3.enableVertexAttribArray 1
|
||||
|
||||
val _ = Gles3.useProgram textProgram
|
||||
in
|
||||
{ textVertexBuffer = textVertexBuffer
|
||||
, textProgram = textProgram
|
||||
, textDrawLength = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun uploadText (drawState: t, vec) =
|
||||
let
|
||||
val {textVertexBuffer, textProgram, textDrawLength = _} = drawState
|
||||
|
||||
val _ = Gles3.bufferData (vec, Vector.length vec, Gles3.STATIC_DRAW)
|
||||
val newTextDrawLength = Vector.length vec div 6
|
||||
in
|
||||
{ textVertexBuffer = textVertexBuffer
|
||||
, textProgram = textProgram
|
||||
, textDrawLength = newTextDrawLength
|
||||
}
|
||||
end
|
||||
|
||||
fun draw (drawObject: t) =
|
||||
let val {textVertexBuffer, textDrawLength, textProgram} = drawObject
|
||||
in Gles3.drawArrays (Gles3.TRIANGLES, 0, textDrawLength)
|
||||
end
|
||||
end
|
||||
23
shf/shell/gl-shaders.sml
Normal file
23
shf/shell/gl-shaders.sml
Normal file
@@ -0,0 +1,23 @@
|
||||
structure GlShaders =
|
||||
struct
|
||||
val xyzRgbVertexShaderString =
|
||||
"#version 300 es\n\
|
||||
\layout (location = 0) in vec3 apos;\n\
|
||||
\layout (location = 1) in vec3 col;\n\
|
||||
\out vec3 frag_col;\n\
|
||||
\void main()\n\
|
||||
\{\n\
|
||||
\ frag_col = col;\n\
|
||||
\ gl_Position = vec4(apos.x, apos.y, apos.z, 1.0f);\n\
|
||||
\}"
|
||||
|
||||
val rgbFragmentShaderString =
|
||||
"#version 300 es\n\
|
||||
\precision mediump float;\n\
|
||||
\in vec3 frag_col;\n\
|
||||
\out vec4 FragColor;\n\
|
||||
\void main()\n\
|
||||
\{\n\
|
||||
\ FragColor = vec4(frag_col.x, frag_col.y, frag_col.z, 1.0f);\n\
|
||||
\}"
|
||||
end
|
||||
264
shf/shell/glfw-gamepad.sml
Normal file
264
shf/shell/glfw-gamepad.sml
Normal file
@@ -0,0 +1,264 @@
|
||||
structure GlfwGamepad =
|
||||
struct
|
||||
datatype mode =
|
||||
PENDING
|
||||
(* we need to wait for all keys to be released after pressing a button *)
|
||||
| WAIT_FOR_KEY_RELEASE
|
||||
| TRIANGLE
|
||||
| TRIANGLE_CIRCLE
|
||||
| CIRCLE
|
||||
| CIRCLE_CROSS
|
||||
| CROSS
|
||||
| CROSS_SQUARE
|
||||
| SQUARE
|
||||
(* maybe SQUARE_TRIANGLE for numbers and symbols? *)
|
||||
| SQUARE_TRIANGLE
|
||||
|
||||
structure IM = InputMsg
|
||||
|
||||
type gamepad_state =
|
||||
{ mode: mode
|
||||
, shiftChr: bool
|
||||
, trianglePressed: bool
|
||||
, circlePressed: bool
|
||||
, crossPressed: bool
|
||||
, squarePressed: bool
|
||||
}
|
||||
|
||||
fun releaseKeysAndUnshift (gamepadState: gamepad_state) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, shiftChr = _
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
} = gamepadState
|
||||
in
|
||||
{ mode = WAIT_FOR_KEY_RELEASE
|
||||
, shiftChr = false
|
||||
, trianglePressed = false
|
||||
, circlePressed = false
|
||||
, crossPressed = false
|
||||
, squarePressed = false
|
||||
}
|
||||
end
|
||||
|
||||
fun onWaitForKeyRelease
|
||||
( gamepadState: gamepad_state
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, actions
|
||||
) =
|
||||
if
|
||||
trianglePressed orelse circlePressed orelse crossPressed
|
||||
orelse squarePressed
|
||||
then
|
||||
(gamepadState, actions)
|
||||
else
|
||||
let
|
||||
val newState =
|
||||
{ mode = PENDING
|
||||
, shiftChr = #shiftChr gamepadState
|
||||
, trianglePressed = false
|
||||
, circlePressed = false
|
||||
, crossPressed = false
|
||||
, squarePressed = false
|
||||
}
|
||||
in
|
||||
(newState, actions)
|
||||
end
|
||||
|
||||
fun onPendingMode
|
||||
( state: gamepad_state
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, actions: IM.t list
|
||||
) =
|
||||
if
|
||||
trianglePressed orelse circlePressed orelse crossPressed
|
||||
orelse squarePressed
|
||||
then
|
||||
(* some button is being pressed,
|
||||
* so we record that in the returned state,
|
||||
* in addition to whatever buttons were previously pressed *)
|
||||
let
|
||||
val trianglePressed = #trianglePressed state orelse trianglePressed
|
||||
val circlePressed = #circlePressed state orelse circlePressed
|
||||
val crossPressed = #crossPressed state orelse crossPressed
|
||||
val squarePressed = #squarePressed state orelse squarePressed
|
||||
|
||||
val newState =
|
||||
{ mode = #mode state
|
||||
, shiftChr = #shiftChr state
|
||||
, trianglePressed = trianglePressed
|
||||
, circlePressed = circlePressed
|
||||
, crossPressed = crossPressed
|
||||
, squarePressed = squarePressed
|
||||
}
|
||||
in
|
||||
(newState, actions)
|
||||
end
|
||||
else
|
||||
(* nothing is currently pressed,
|
||||
* so we check if there is a valid mode indicated by the state
|
||||
* and change the mode if so *)
|
||||
let
|
||||
val
|
||||
{ trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, shiftChr
|
||||
, mode = _
|
||||
} = state
|
||||
val newMode =
|
||||
if trianglePressed andalso not (crossPressed orelse squarePressed) then
|
||||
if not circlePressed then TRIANGLE else TRIANGLE_CIRCLE
|
||||
else if circlePressed andalso not squarePressed then
|
||||
if not crossPressed then CIRCLE else CIRCLE_CROSS
|
||||
else if crossPressed then
|
||||
if not squarePressed then CROSS else CROSS_SQUARE
|
||||
else if squarePressed then
|
||||
if not trianglePressed then SQUARE else SQUARE_TRIANGLE
|
||||
else
|
||||
(* some buttons are being pressed,
|
||||
* but not a valid combination to switch
|
||||
* to another mode, so we are still on PENDING *)
|
||||
PENDING
|
||||
|
||||
val newState =
|
||||
{ mode = newMode
|
||||
, shiftChr = shiftChr
|
||||
, trianglePressed = false
|
||||
, circlePressed = false
|
||||
, crossPressed = false
|
||||
, squarePressed = false
|
||||
}
|
||||
in
|
||||
(newState, actions)
|
||||
end
|
||||
|
||||
fun onTriangleMode
|
||||
( gamepadState
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, actions
|
||||
) =
|
||||
if trianglePressed then
|
||||
let
|
||||
val newState = releaseKeysAndUnshift gamepadState
|
||||
val actions = IM.CHAR_EVENT #"a" :: actions
|
||||
in
|
||||
(newState, actions)
|
||||
end
|
||||
else if circlePressed then
|
||||
let
|
||||
val newState = releaseKeysAndUnshift gamepadState
|
||||
val actions = IM.CHAR_EVENT #"b" :: actions
|
||||
in
|
||||
(newState, actions)
|
||||
end
|
||||
else if crossPressed then
|
||||
let
|
||||
val newState = releaseKeysAndUnshift gamepadState
|
||||
val actions = IM.CHAR_EVENT #"c" :: actions
|
||||
in
|
||||
(newState, actions)
|
||||
end
|
||||
else if squarePressed then
|
||||
let
|
||||
val newState = releaseKeysAndUnshift gamepadState
|
||||
val actions = IM.CHAR_EVENT #"d" :: actions
|
||||
in
|
||||
(newState, actions)
|
||||
end
|
||||
else
|
||||
(gamepadState, actions)
|
||||
|
||||
fun handleButtons
|
||||
( gamepadState
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, l1Pressed
|
||||
, r1Pressed
|
||||
) =
|
||||
let
|
||||
val actions = if l1Pressed then [IM.KEY_BACKSPACE] else []
|
||||
val actions =
|
||||
if r1Pressed then (IM.CHAR_EVENT #" ") :: actions else actions
|
||||
in
|
||||
case #mode gamepadState of
|
||||
PENDING =>
|
||||
onPendingMode
|
||||
( gamepadState
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, actions
|
||||
)
|
||||
| WAIT_FOR_KEY_RELEASE =>
|
||||
onWaitForKeyRelease
|
||||
( gamepadState
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, actions
|
||||
)
|
||||
| TRIANGLE =>
|
||||
onTriangleMode
|
||||
( gamepadState
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, actions
|
||||
)
|
||||
end
|
||||
|
||||
(* impure functions below *)
|
||||
fun getGamepadState () =
|
||||
Input.getGamepadState 0 <> 0 orelse Input.getGamepadState 1 <> 0
|
||||
orelse Input.getGamepadState 2 <> 0 orelse Input.getGamepadState 3 <> 0
|
||||
orelse Input.getGamepadState 4 <> 0 orelse Input.getGamepadState 5 <> 0
|
||||
orelse Input.getGamepadState 6 <> 0 orelse Input.getGamepadState 7 <> 0
|
||||
orelse Input.getGamepadState 8 <> 0 orelse Input.getGamepadState 9 <> 0
|
||||
orelse Input.getGamepadState 10 <> 0 orelse Input.getGamepadState 11 <> 0
|
||||
orelse Input.getGamepadState 12 <> 0 orelse Input.getGamepadState 13 <> 0
|
||||
orelse Input.getGamepadState 14 <> 0 orelse Input.getGamepadState 15 <> 0
|
||||
|
||||
fun query gamepadState =
|
||||
if getGamepadState () then
|
||||
let
|
||||
val trianglePressed = Input.isTriangleButtonPressed () <> 0
|
||||
val circlePressed = Input.isCircleButtonPressed () <> 0
|
||||
val crossPressed = Input.isCrossButtonPressed () <> 0
|
||||
val squarePressed = Input.isSquareButtonPressed () <> 0
|
||||
val l1Pressed = Input.isL1ButtonPressed () <> 0
|
||||
val r1Pressed = Input.isR1ButtonPressed () <> 0
|
||||
in
|
||||
handleButtons
|
||||
( gamepadState
|
||||
, trianglePressed
|
||||
, circlePressed
|
||||
, crossPressed
|
||||
, squarePressed
|
||||
, l1Pressed
|
||||
, r1Pressed
|
||||
)
|
||||
end
|
||||
else
|
||||
(* nothing to do, so return same state *)
|
||||
(gamepadState, [])
|
||||
end
|
||||
174
shf/shell/glfw-loop.sml
Normal file
174
shf/shell/glfw-loop.sml
Normal file
@@ -0,0 +1,174 @@
|
||||
structure GlfwLoop =
|
||||
struct
|
||||
fun yank (window, str) =
|
||||
let
|
||||
(* print when text is yanked
|
||||
* because GLFW currently has a bug on Wayland
|
||||
* when setting the clipboard string *)
|
||||
val msg = "|" ^ String.toCString str ^ "|\n"
|
||||
val () = print msg
|
||||
val () = Glfw.setClipboardString (window, str)
|
||||
in
|
||||
()
|
||||
end
|
||||
|
||||
fun consumeEvent (drawState, window, msg) =
|
||||
let
|
||||
open DrawMsg
|
||||
|
||||
val {textVertexBuffer, textProgram, textDrawLength = _, ...} = drawState
|
||||
in
|
||||
case msg of
|
||||
DRAW_TEXT textVec => GlDraw.uploadText (drawState, textVec)
|
||||
| YANK str => (yank (window, str); drawState)
|
||||
end
|
||||
|
||||
fun consumeEventsLoop (pos, msgVec, drawState, window) =
|
||||
if pos = Vector.length msgVec then
|
||||
drawState
|
||||
else
|
||||
let
|
||||
val msg = Vector.sub (msgVec, pos)
|
||||
val drawState = consumeEvent (drawState, window, msg)
|
||||
in
|
||||
consumeEventsLoop (pos + 1, msgVec, drawState, window)
|
||||
end
|
||||
|
||||
fun consumeEvents (drawState, window) =
|
||||
consumeEventsLoop (0, DrawMailbox.getMessagesAndClear (), drawState, window)
|
||||
|
||||
fun helpLoop (app, drawState, window, gamepad) =
|
||||
case Glfw.windowShouldClose window of
|
||||
false =>
|
||||
let
|
||||
val drawState = consumeEvents (drawState, window)
|
||||
|
||||
val _ = Gles3.clearColor (0.89, 0.89, 0.89, 1.0)
|
||||
val _ = Gles3.clear ()
|
||||
|
||||
(* one update reacting to gamepad events *)
|
||||
val (gamepad, actions) = GlfwGamepad.query gamepad
|
||||
val app = Updater.updateLoop (0, Vector.fromList actions, app)
|
||||
|
||||
(* one update reacting to keyboard events *)
|
||||
val app = Updater.update app
|
||||
val _ = GlDraw.draw drawState
|
||||
|
||||
val _ = Glfw.swapBuffers window
|
||||
val _ = Glfw.waitEvents ()
|
||||
in
|
||||
helpLoop (app, drawState, window, gamepad)
|
||||
end
|
||||
| true => Glfw.terminate ()
|
||||
|
||||
fun loop (app, window) =
|
||||
let
|
||||
val drawState = GlDraw.create ()
|
||||
|
||||
val gamepad: GlfwGamepad.gamepad_state =
|
||||
{ mode = GlfwGamepad.PENDING
|
||||
, shiftChr = false
|
||||
, trianglePressed = false
|
||||
, circlePressed = false
|
||||
, crossPressed = false
|
||||
, squarePressed = false
|
||||
}
|
||||
in
|
||||
helpLoop (app, drawState, window, gamepad)
|
||||
end
|
||||
|
||||
open InputMsg
|
||||
|
||||
fun frameBufferSizeCallback (width, height) =
|
||||
InputMailbox.append (RESIZE_EVENT (width, height))
|
||||
|
||||
fun charCallback word =
|
||||
let
|
||||
val word = Word32.toInt word
|
||||
val chr = Char.chr word
|
||||
in
|
||||
InputMailbox.append (CHAR_EVENT chr)
|
||||
end
|
||||
|
||||
fun keyCallback (key, scancode, action, mods) =
|
||||
let
|
||||
open Input
|
||||
in
|
||||
if key = KEY_ESC andalso action = PRESS andalso mods = 0 then
|
||||
InputMailbox.append (InputMsg.KEY_ESC)
|
||||
else if key = KEY_ENTER andalso action = PRESS andalso mods = 0 then
|
||||
InputMailbox.append (InputMsg.KEY_ENTER)
|
||||
else if key = KEY_BACKSPACE andalso action <> RELEASE andalso mods = 0 then
|
||||
InputMailbox.append (InputMsg.KEY_BACKSPACE)
|
||||
else if key = KEY_ARROW_LEFT andalso action <> RELEASE andalso mods = 0 then
|
||||
InputMailbox.append (InputMsg.ARROW_LEFT)
|
||||
else if key = KEY_ARROW_RIGHT andalso action <> RELEASE andalso mods = 0 then
|
||||
InputMailbox.append (InputMsg.ARROW_RIGHT)
|
||||
else if key = KEY_ARROW_UP andalso action <> RELEASE andalso mods = 0 then
|
||||
InputMailbox.append (InputMsg.ARROW_UP)
|
||||
else if key = KEY_ARROW_DOWN andalso action <> RELEASE andalso mods = 0 then
|
||||
InputMailbox.append (InputMsg.ARROW_DOWN)
|
||||
else
|
||||
()
|
||||
end
|
||||
|
||||
fun registerCallbacks window =
|
||||
let
|
||||
val () = Input.exportFramebufferSizeCallback frameBufferSizeCallback
|
||||
val () = Input.setFramebufferSizeCallback window
|
||||
|
||||
val () = Input.exportCharCallback charCallback
|
||||
val () = Input.setCharCallback window
|
||||
|
||||
val () = Input.exportKeyCallback keyCallback
|
||||
val () = Input.setKeyCallback window
|
||||
in
|
||||
()
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (io, acc, lastCharWasNewline) =
|
||||
case TextIO.inputLine io of
|
||||
SOME str =>
|
||||
let
|
||||
val endsWithNewline =
|
||||
String.size str > 0
|
||||
andalso String.sub (str, String.size str - 1) = #"\n"
|
||||
in
|
||||
loop (io, LineGap.append (str, acc), endsWithNewline)
|
||||
end
|
||||
| NONE =>
|
||||
if lastCharWasNewline then
|
||||
LineGap.goToStart acc
|
||||
else
|
||||
let val acc = LineGap.append ("\n", acc)
|
||||
in LineGap.goToStart acc
|
||||
end
|
||||
in
|
||||
fun ioToLineGap (io, acc) = loop (io, acc, false)
|
||||
end
|
||||
|
||||
fun main () =
|
||||
let
|
||||
(* Set up GLFW. *)
|
||||
val _ = Glfw.init ()
|
||||
val _ = Glfw.windowHint (Glfw.CONTEXT_VERSION_MAJOR (), 3)
|
||||
val _ = Glfw.windowHint (Glfw.DEPRECATED (), Glfw.FALSE ())
|
||||
val window = Glfw.createWindow (1920, 1080, "shf")
|
||||
val _ = Glfw.makeContextCurrent window
|
||||
val _ = Glfw.loadGlad ()
|
||||
val _ = Gles3.enableDepthTest ()
|
||||
|
||||
(* load file intol gap buffer and create initial app *)
|
||||
val io = TextIO.openIn "temp.txt"
|
||||
val lineGap = ioToLineGap (io, LineGap.empty)
|
||||
val _ = TextIO.closeIn io
|
||||
val app = AppType.init (lineGap, 1920, 1080, Time.now ())
|
||||
|
||||
val () = registerCallbacks window
|
||||
in
|
||||
loop (app, window)
|
||||
end
|
||||
end
|
||||
|
||||
val _ = GlfwLoop.main ()
|
||||
1
shf/shell/input-mailbox.sml
Normal file
1
shf/shell/input-mailbox.sml
Normal file
@@ -0,0 +1 @@
|
||||
structure InputMailbox = MakeMailbox(InputMsg)
|
||||
29
shf/shell/make-mailbox.sml
Normal file
29
shf/shell/make-mailbox.sml
Normal file
@@ -0,0 +1,29 @@
|
||||
signature MAKE_MAILBOX =
|
||||
sig
|
||||
type t
|
||||
end
|
||||
|
||||
functor MakeMailbox(Fn: MAKE_MAILBOX) =
|
||||
struct
|
||||
val messages: Fn.t vector ref = ref #[]
|
||||
|
||||
fun getMessagesAndClear () =
|
||||
let
|
||||
val () = MLton.Thread.atomicBegin ()
|
||||
val msgs = !messages
|
||||
val () = messages := #[]
|
||||
val () = MLton.Thread.atomicEnd ()
|
||||
in
|
||||
msgs
|
||||
end
|
||||
|
||||
fun append newMsg =
|
||||
let
|
||||
val () = MLton.Thread.atomicBegin ()
|
||||
val msgs = !messages
|
||||
val msgs = Vector.concat [msgs, #[newMsg]]
|
||||
val () = messages := msgs
|
||||
in
|
||||
MLton.Thread.atomicEnd ()
|
||||
end
|
||||
end
|
||||
118
shf/shell/rgfw-loop.sml
Normal file
118
shf/shell/rgfw-loop.sml
Normal file
@@ -0,0 +1,118 @@
|
||||
structure RgfwLoop =
|
||||
struct
|
||||
fun yank string =
|
||||
Rgfw.writeClipboard (string, String.size string)
|
||||
|
||||
fun consumeEvent (drawState, msg) =
|
||||
let
|
||||
open DrawMsg
|
||||
|
||||
val {textVertexBuffer, textProgram, textDrawLength = _, ...} = drawState
|
||||
in
|
||||
case msg of
|
||||
DRAW_TEXT textVec => GlDraw.uploadText (drawState, textVec)
|
||||
| YANK str => (yank str; drawState)
|
||||
end
|
||||
|
||||
fun consumeEventsLoop (pos, msgVec, drawState) =
|
||||
if pos = Vector.length msgVec then
|
||||
drawState
|
||||
else
|
||||
let
|
||||
val msg = Vector.sub (msgVec, pos)
|
||||
val drawState = consumeEvent (drawState, msg)
|
||||
in
|
||||
consumeEventsLoop (pos + 1, msgVec, drawState)
|
||||
end
|
||||
|
||||
fun consumeEvents drawState =
|
||||
consumeEventsLoop (0, DrawMailbox.getMessagesAndClear (), drawState)
|
||||
|
||||
fun loop (window, app, drawState) =
|
||||
if Rgfw.shouldCloseWindow window then
|
||||
Rgfw.closeWindow window
|
||||
else
|
||||
let
|
||||
val () = Gles3.clearColor (0.89, 0.89, 0.89, 1.0)
|
||||
val () = Gles3.clear ()
|
||||
|
||||
val () = Rgfw.pollEvents ()
|
||||
|
||||
val app = Updater.update app
|
||||
|
||||
val drawState = consumeEvents drawState
|
||||
val () = GlDraw.draw drawState
|
||||
val () = Rgfw.swapBuffers window
|
||||
in
|
||||
loop (window, app, drawState)
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (io, acc, lastCharWasNewline) =
|
||||
case TextIO.inputLine io of
|
||||
SOME str =>
|
||||
let
|
||||
val endsWithNewline =
|
||||
String.size str > 0
|
||||
andalso String.sub (str, String.size str - 1) = #"\n"
|
||||
in
|
||||
loop (io, LineGap.append (str, acc), endsWithNewline)
|
||||
end
|
||||
| NONE =>
|
||||
if lastCharWasNewline then
|
||||
LineGap.goToStart acc
|
||||
else
|
||||
let val acc = LineGap.append ("\n", acc)
|
||||
in LineGap.goToStart acc
|
||||
end
|
||||
in
|
||||
fun ioToLineGap (io, acc) = loop (io, acc, false)
|
||||
end
|
||||
|
||||
fun escapeCallback () = InputMailbox.append InputMsg.KEY_ESC
|
||||
|
||||
fun backspaceCallback () = InputMailbox.append InputMsg.KEY_BACKSPACE
|
||||
|
||||
fun enterCallback () = InputMailbox.append InputMsg.KEY_ENTER
|
||||
|
||||
fun charCallback chr =
|
||||
InputMailbox.append (InputMsg.CHAR_EVENT chr)
|
||||
|
||||
fun resizeCallback (width, height) =
|
||||
InputMailbox.append (InputMsg.RESIZE_EVENT (width, height))
|
||||
|
||||
fun registerCallbacks () =
|
||||
let
|
||||
val () = Rgfw.exportEscapeCallback escapeCallback
|
||||
val () = Rgfw.exportBackspaceCallback backspaceCallback
|
||||
val () = Rgfw.exportEnterCallback enterCallback
|
||||
val () = Rgfw.exportCharCallback charCallback
|
||||
val () = Rgfw.setKeyCallback ()
|
||||
|
||||
val () = Rgfw.exportResizeCallback resizeCallback
|
||||
val () = Rgfw.setResizeCallback ()
|
||||
in
|
||||
()
|
||||
end
|
||||
|
||||
fun main () =
|
||||
let
|
||||
val window = Rgfw.createWindow ("shf", 0, 0, 1920, 1080)
|
||||
val () = Rgfw.enableVsync window
|
||||
val () = Gles3.enableDepthTest ()
|
||||
|
||||
(* load file intol gap buffer and create initial app *)
|
||||
val io = TextIO.openIn "temp.txt"
|
||||
val lineGap = ioToLineGap (io, LineGap.empty)
|
||||
val () = TextIO.closeIn io
|
||||
|
||||
val () = registerCallbacks ()
|
||||
|
||||
val app = AppType.init (lineGap, 1920, 1080, Time.now ())
|
||||
val drawState = GlDraw.create ()
|
||||
in
|
||||
loop (window, app, drawState)
|
||||
end
|
||||
end
|
||||
|
||||
val _ = RgfwLoop.main ()
|
||||
47
shf/shell/updater.sml
Normal file
47
shf/shell/updater.sml
Normal file
@@ -0,0 +1,47 @@
|
||||
structure Updater =
|
||||
struct
|
||||
open MailboxType
|
||||
open InputMsg
|
||||
|
||||
fun sendMsg msg =
|
||||
case msg of DRAW msg => DrawMailbox.append msg
|
||||
|
||||
fun sendMsgs msgList =
|
||||
case msgList of
|
||||
hd :: tl => let val () = sendMsg hd in sendMsgs tl end
|
||||
| [] => ()
|
||||
|
||||
fun updateOne (app: AppType.app_type, inputMsg) =
|
||||
let
|
||||
val time = Time.now ()
|
||||
|
||||
val () =
|
||||
case inputMsg of
|
||||
CHAR_EVENT #"~" =>
|
||||
ExceptionLogger.log (Fail "intentionally caused exception")
|
||||
| _ => ()
|
||||
|
||||
val () = ExceptionLogger.addCommand inputMsg
|
||||
|
||||
val app = AppUpdate.update (app, inputMsg, time)
|
||||
handle e => ExceptionLogger.log e
|
||||
|
||||
val () = sendMsgs (#msgs app)
|
||||
in
|
||||
app
|
||||
end
|
||||
|
||||
fun updateLoop (pos, msgVec, app) =
|
||||
if pos = Vector.length msgVec then
|
||||
app
|
||||
else
|
||||
let
|
||||
val msg = Vector.sub (msgVec, pos)
|
||||
val app = updateOne (app, msg)
|
||||
in
|
||||
updateLoop (pos + 1, msgVec, app)
|
||||
end
|
||||
|
||||
fun update app =
|
||||
updateLoop (0, InputMailbox.getMessagesAndClear (), app)
|
||||
end
|
||||
29
shf/shf-glfw.mlb
Normal file
29
shf/shf-glfw.mlb
Normal file
@@ -0,0 +1,29 @@
|
||||
$(SML_LIB)/basis/basis.mlb
|
||||
|
||||
fcore.mlb
|
||||
|
||||
(* IMPERATIVE SHELL *)
|
||||
$(SML_LIB)/basis/mlton.mlb
|
||||
|
||||
ann
|
||||
"allowFFI true"
|
||||
in
|
||||
ffi/gles3-import.sml
|
||||
ffi/glfw-import.sml
|
||||
ffi/glfw-input.sml
|
||||
end
|
||||
|
||||
ann
|
||||
"allowVectorExps true"
|
||||
in
|
||||
shell/make-mailbox.sml
|
||||
end
|
||||
shell/input-mailbox.sml
|
||||
shell/draw-mailbox.sml
|
||||
|
||||
shell/exception-logger.sml
|
||||
shell/updater.sml
|
||||
shell/glfw-gamepad.sml
|
||||
shell/gl-shaders.sml
|
||||
shell/gl-draw.sml
|
||||
shell/glfw-loop.sml
|
||||
27
shf/shf-rgfw.mlb
Normal file
27
shf/shf-rgfw.mlb
Normal file
@@ -0,0 +1,27 @@
|
||||
$(SML_LIB)/basis/basis.mlb
|
||||
|
||||
fcore.mlb
|
||||
|
||||
(* IMPERATIVE SHELL *)
|
||||
$(SML_LIB)/basis/mlton.mlb
|
||||
ann
|
||||
"allowFFI true"
|
||||
in
|
||||
ffi/gles3-import.sml
|
||||
ffi/rgfw-import.sml
|
||||
end
|
||||
|
||||
ann
|
||||
"allowVectorExps true"
|
||||
in
|
||||
shell/make-mailbox.sml
|
||||
end
|
||||
|
||||
shell/input-mailbox.sml
|
||||
shell/draw-mailbox.sml
|
||||
|
||||
shell/exception-logger.sml
|
||||
shell/updater.sml
|
||||
shell/gl-shaders.sml
|
||||
shell/gl-draw.sml
|
||||
shell/rgfw-loop.sml
|
||||
17
shf/shf-tests.mlb
Normal file
17
shf/shf-tests.mlb
Normal file
@@ -0,0 +1,17 @@
|
||||
$(SML_LIB)/basis/basis.mlb
|
||||
|
||||
fcore.mlb
|
||||
|
||||
(* TEST FILES *)
|
||||
$(SML_LIB)/basis/mlton.mlb
|
||||
shell/exception-logger.sml
|
||||
test/Railroad/src/railroad.mlb
|
||||
|
||||
test/persistent-vector-tests.sml
|
||||
test/regex-tests.sml
|
||||
test/test-utils.sml
|
||||
test/normal-move-tests.sml
|
||||
test/normal-delete-tests.sml
|
||||
test/normal-yank-tests.sml
|
||||
test/regression-tests.sml
|
||||
test/test.sml
|
||||
2
shf/temp.txt
Normal file
2
shf/temp.txt
Normal file
@@ -0,0 +1,2 @@
|
||||
hello hello hello
|
||||
world world world
|
||||
7
shf/test/README.md
Normal file
7
shf/test/README.md
Normal file
@@ -0,0 +1,7 @@
|
||||
# shf-tests
|
||||
|
||||
Unit tests for shf.
|
||||
|
||||
The tests require (Railroad)[https://github.com/PerplexSystems/Railroad] testing framework.
|
||||
|
||||
|
||||
1
shf/test/Railroad
Submodule
1
shf/test/Railroad
Submodule
Submodule shf/test/Railroad added at b5aa94a880
7925
shf/test/normal-delete-tests.sml
Normal file
7925
shf/test/normal-delete-tests.sml
Normal file
File diff suppressed because it is too large
Load Diff
2143
shf/test/normal-move-tests.sml
Normal file
2143
shf/test/normal-move-tests.sml
Normal file
File diff suppressed because it is too large
Load Diff
836
shf/test/normal-yank-tests.sml
Normal file
836
shf/test/normal-yank-tests.sml
Normal file
@@ -0,0 +1,836 @@
|
||||
structure NormalYankTests =
|
||||
struct
|
||||
open Railroad
|
||||
open Railroad.Test
|
||||
open InputMsg
|
||||
|
||||
val yhYank = describe "yank motion 'yh'"
|
||||
[ test "yanks empty string when cursor is at index 0" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello world\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, 0)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yh")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = ""
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test "yanks empty string when character before cursor is a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, 6)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yh")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = ""
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test "yanks one char to the left when on a non-newline" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello world\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, 5)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yh")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "o"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test "yanks 3 chars when count is 3" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 5
|
||||
val originalString = "hello world\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "3yh")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "llo"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks from cursor position to start column when \
|
||||
\count is greater than current column"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 5
|
||||
val originalString = "hello world\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "9yh")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "hello"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
]
|
||||
|
||||
val ylYank = describe "yank motion 'yl'"
|
||||
[ test "yanks last char in line when next char is newline" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = 4
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yl")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "o"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test "yanks char that cursor is currently on when not on newline" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 0
|
||||
val originalString = "hello world\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yl")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "h"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test "yanks newline character when cursor is on a newline" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 5
|
||||
val originalString = "hello\n\nworld\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yl")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"does not yank past newline when specifying a range \
|
||||
\greater than number of columns"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 2
|
||||
val originalString = "hello\nworld\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yl")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "llo"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks last line, excluding newline, \
|
||||
\when cursor is on first character of last line \
|
||||
\and last line ends with a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 6
|
||||
val originalString = "hello\nworld\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yl")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks last line, excluding newline, \
|
||||
\when cursor is on first character of last line \
|
||||
\and last line does not end with a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 6
|
||||
val originalString = "hello\nworld"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yl")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
]
|
||||
|
||||
val ykYank = describe "yank motion 'yk'"
|
||||
[ test "does not yank when cursor is on first line" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yk")
|
||||
in
|
||||
(* assert *)
|
||||
TestUtils.expectNoYank app
|
||||
end)
|
||||
, test
|
||||
"yanks first two lines \
|
||||
\when there are two lines and cursor is on second line"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = 6
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yk")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "hello\nworld\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks last two lines when there are three lines in the buffer \
|
||||
\and cursor is on third line"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\nagain\n"
|
||||
val originalIdx = 15
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yk")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world\nagain\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks whole buffer when on last line \
|
||||
\and count is greater than number of lines"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\nagain\n"
|
||||
val originalIdx = 15
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yk")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = originalString
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks newline and preceding line when cursor is second line \
|
||||
\and second line contains only a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\n\nagain\n"
|
||||
val originalIdx = 6
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yk")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "hello\n\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks just newline and line above when cursor is on third line \
|
||||
\and third line contains only a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString =
|
||||
"hello\n\
|
||||
\world\n\
|
||||
\\n\
|
||||
\trello\n\
|
||||
\brillo\n"
|
||||
val originalIdx = 12
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yk")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world\n\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks second and third lines when cursor is on \
|
||||
\last non-newline character of third line"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\n\nagain\n"
|
||||
val originalString =
|
||||
"hello\n\
|
||||
\world\n\
|
||||
\trello\n\
|
||||
\brillo\n"
|
||||
val originalIdx = 17
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yk")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world\ntrello\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks last two lines when cursor is on last line \
|
||||
\and last line only has a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString =
|
||||
"hello\n\
|
||||
\world\n\
|
||||
\\n"
|
||||
val originalIdx = String.size originalString - 1
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yk")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world\n\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
]
|
||||
|
||||
val yjYank = describe "yank motion 'yj'"
|
||||
[ test "does not yank any text when cursor is on last line" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = String.size originalString - 3
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yj")
|
||||
in
|
||||
(* assert *)
|
||||
TestUtils.expectNoYank app
|
||||
end)
|
||||
, test "does not yank when there is only one line" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yj")
|
||||
in
|
||||
(* assert *)
|
||||
TestUtils.expectNoYank app
|
||||
end)
|
||||
, test
|
||||
"yanks first two lines when cursor is on first line \
|
||||
\and there are at least two lines"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yj")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = originalString
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks first two lines when there are three lines \
|
||||
\and cursor is on first line"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 0
|
||||
val originalString = "hello\nworld\nbye world\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yj")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "hello\nworld\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks last two lines when there are three lines \
|
||||
\and cursor is on second line"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalIdx = 6
|
||||
val originalString = "hello\nworld\nbye world\n"
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yj")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world\nbye world\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks entire file when cursor is on first line \
|
||||
\and a count is given which is larger \
|
||||
\than the total number of lines in the file"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yj")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = originalString
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks entire file when a count greater than the total number of lines \
|
||||
\is given, while the file does not end with a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yj")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = originalString
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test "yanks two lines when cursor is on a newline" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "\nhello\nworld\ntrello\nbrillo\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yj")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "\nhello\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
]
|
||||
|
||||
val yyYank = describe "yank motion 'yy'"
|
||||
[ test
|
||||
"yanks last line when there is more than one line \
|
||||
\and cursor is on last line"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = String.size originalString - 3
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yy")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test "yanks whole buffer when buffer consists of one line" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yy")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = originalString
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks first line when cursor is on first line \
|
||||
\and there are only two lines"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yy")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "hello\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks whole file when cursor is on first line \
|
||||
\and a count is given which is greater than \
|
||||
\the number of total lines"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yy")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = originalString
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks whole file when cursor is on first line, \
|
||||
\count given is greater than number of lines, \
|
||||
\and the file does not end with a newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "33yy")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = originalString
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks just newline when cursor is on a line \
|
||||
\that contains only a single newline"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "\nhello\nworld\n"
|
||||
val originalIdx = 0
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yy")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "\n"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
]
|
||||
|
||||
fun yankSeconWordAlpha (pos, expectedString) =
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello world again\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, pos)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
in
|
||||
(* assert *)
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end
|
||||
|
||||
val ywYank = describe "yank motion 'yw'"
|
||||
[ test "yanks last character when cursor is on last character of line"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello world\n"
|
||||
val originalIdx = String.size originalString - 2
|
||||
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, originalIdx)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "d"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks from second word up to (and excluding) third word \
|
||||
\when cursor is on first character of second word"
|
||||
(fn _ => yankSeconWordAlpha (6, "world "))
|
||||
, test
|
||||
"yanks from second character of second word \
|
||||
\up to (and excluding) third word \
|
||||
\when cursor is on second character of second word"
|
||||
(fn _ => yankSeconWordAlpha (7, "orld "))
|
||||
, test
|
||||
"yanks from third character of second word \
|
||||
\up to (and excluding) third word \
|
||||
\when cursor is on third character of second word"
|
||||
(fn _ => yankSeconWordAlpha (8, "rld "))
|
||||
, test
|
||||
"yanks from fourth character of second word \
|
||||
\up to (and excluding) third word \
|
||||
\when cursor is on fourth character of second word"
|
||||
(fn _ => yankSeconWordAlpha (9, "ld "))
|
||||
, test
|
||||
"yanks from fifth character of second word \
|
||||
\up to (and excluding) third word \
|
||||
\when cursor is on fifth character of second word"
|
||||
(fn _ => yankSeconWordAlpha (10, "d "))
|
||||
, test "yanks space when cursor is on space preceding an alpha char"
|
||||
(fn _ => yankSeconWordAlpha (11, " "))
|
||||
, test "does not yank newline when cursor is on last word of line" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello\nworld\nagain\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, 0)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "hello"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks until first punctuation char when on an alpha char \
|
||||
\and there is no space between alpha and punctuation"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "hello!world!again\n"
|
||||
val app = TestUtils.init originalString
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "hello"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks until first alpha char when on punctuation \
|
||||
\and there is no space between punctuation and alpha"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "!#%&QWERTY#!\n"
|
||||
val app = TestUtils.init originalString
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "!#%&"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks until first alpha char (exluding) \
|
||||
\when cursor is on space and next char is alpha"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "h ello\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, 1)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = " "
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks until first alpha char \
|
||||
\when cursor is on space, many spaces are ahead, \
|
||||
\and first char after spaces is alpha"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "h ello\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, 3)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = " "
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks until first punctuation char \
|
||||
\when cursor is on space and next non-space char is punctuation"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val originalString = "! @#$%\n"
|
||||
val app = TestUtils.init originalString
|
||||
val app = AppWith.idx (app, 2)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = " "
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
, test
|
||||
"yanks last char when on last word \
|
||||
\and there is no newline after current word"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val app = TestUtils.init "hello world"
|
||||
val app = AppWith.idx (app, 6)
|
||||
|
||||
(* act *)
|
||||
val app = TestUtils.updateMany (app, "yw")
|
||||
|
||||
(* assert *)
|
||||
val expectedString = "world"
|
||||
in
|
||||
TestUtils.expectYank (app, expectedString)
|
||||
end)
|
||||
]
|
||||
|
||||
val tests = [yhYank, ylYank, ykYank, yjYank, yyYank, ywYank]
|
||||
end
|
||||
630
shf/test/persistent-vector-tests.sml
Normal file
630
shf/test/persistent-vector-tests.sml
Normal file
@@ -0,0 +1,630 @@
|
||||
structure PersistentVectorTests =
|
||||
struct
|
||||
open Railroad
|
||||
open Railroad.Test
|
||||
|
||||
fun isNotInRange (lst, pv) =
|
||||
let
|
||||
fun loopNotInRange lst =
|
||||
case lst of
|
||||
hd :: tl =>
|
||||
if PersistentVector.isInRange (hd, pv) then
|
||||
let
|
||||
val msg =
|
||||
"idx " ^ Int.toString hd
|
||||
^ " is in range when it shouldn't be\n"
|
||||
val () = print msg
|
||||
in
|
||||
Expect.isTrue false
|
||||
end
|
||||
else
|
||||
loopNotInRange tl
|
||||
| [] => Expect.isTrue true
|
||||
in
|
||||
loopNotInRange lst
|
||||
end
|
||||
|
||||
fun isInRange (lst, pv) =
|
||||
let
|
||||
fun loopInRange lst =
|
||||
case lst of
|
||||
hd :: tl =>
|
||||
if PersistentVector.isInRange (hd, pv) then
|
||||
loopInRange tl
|
||||
else
|
||||
let
|
||||
val msg =
|
||||
"idx " ^ Int.toString hd
|
||||
^ " is not in range when it should be\n"
|
||||
val () = print msg
|
||||
in
|
||||
Expect.isTrue false
|
||||
end
|
||||
| [] => Expect.isTrue true
|
||||
in
|
||||
loopInRange lst
|
||||
end
|
||||
|
||||
fun printVec pv =
|
||||
let
|
||||
val outputList = PersistentVector.toList pv
|
||||
val str =
|
||||
List.map
|
||||
(fn {start, finish} =>
|
||||
"{start = " ^ Int.toString start ^ ", finish = "
|
||||
^ Int.toString finish ^ "}") outputList
|
||||
val str = String.concatWith "\n " str ^ "\n"
|
||||
in
|
||||
print str
|
||||
end
|
||||
|
||||
val appendTests = describe "PersistentVector.append"
|
||||
[ test "contains appended values in range" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val f = PersistentVector.append
|
||||
val pv = PersistentVector.empty
|
||||
|
||||
(* act *)
|
||||
val pv = f (1, 3, pv)
|
||||
val pv = f (5, 7, pv)
|
||||
val pv = f (9, 13, pv)
|
||||
val pv = f (19, 27, pv)
|
||||
val pv = f (33, 33, pv)
|
||||
|
||||
(* assert *)
|
||||
(* we split the list into several smaller lists
|
||||
* and then concatenate at the end
|
||||
* so that the formatter does not cause
|
||||
* each list element to take its own line *)
|
||||
val indicesInRange1 = [1, 2, 3, 5, 6, 7, 9]
|
||||
val indicesInRange2 = [10, 11, 12, 13, 19, 20]
|
||||
val indicesInRange3 = [21, 22, 23, 24, 25, 26, 27, 33]
|
||||
|
||||
val indicesInRange =
|
||||
indicesInRange1 @ indicesInRange2 @ indicesInRange3
|
||||
in
|
||||
isInRange (indicesInRange, pv)
|
||||
end)
|
||||
, test "does not contain values in range that were not appended" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val f = PersistentVector.append
|
||||
val pv = PersistentVector.empty
|
||||
(* act *)
|
||||
val pv = f (1, 3, pv)
|
||||
val pv = f (5, 7, pv)
|
||||
val pv = f (9, 13, pv)
|
||||
val pv = f (19, 27, pv)
|
||||
val pv = f (33, 33, pv)
|
||||
|
||||
(* assert *)
|
||||
val indicesNotInRange =
|
||||
[0, 4, 8, 14, 15, 16, 17, 18, 28, 29, 30, 31, 32, 34, 35]
|
||||
in
|
||||
isNotInRange (indicesNotInRange, pv)
|
||||
end)
|
||||
]
|
||||
|
||||
val toListTests = describe "PersistentVector.toList"
|
||||
[ test "returns input list when input list has 5 elements" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 3}
|
||||
, {start = 5, finish = 7}
|
||||
, {start = 9, finish = 13}
|
||||
, {start = 19, finish = 27}
|
||||
, {start = 33, finish = 33}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
|
||||
(* assert *)
|
||||
in
|
||||
Expect.isTrue (inputList = outputList)
|
||||
end)
|
||||
, test "returns input list when input list has more than 32 elements"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
, {start = 8, finish = 8}
|
||||
, {start = 9, finish = 9}
|
||||
, {start = 10, finish = 10}
|
||||
, {start = 11, finish = 11}
|
||||
, {start = 12, finish = 12}
|
||||
, {start = 13, finish = 13}
|
||||
, {start = 14, finish = 14}
|
||||
, {start = 15, finish = 15}
|
||||
, {start = 16, finish = 16}
|
||||
, {start = 17, finish = 17}
|
||||
, {start = 18, finish = 18}
|
||||
, {start = 19, finish = 19}
|
||||
, {start = 20, finish = 20}
|
||||
, {start = 21, finish = 21}
|
||||
, {start = 22, finish = 22}
|
||||
, {start = 23, finish = 23}
|
||||
, {start = 24, finish = 24}
|
||||
, {start = 25, finish = 25}
|
||||
, {start = 26, finish = 26}
|
||||
, {start = 27, finish = 27}
|
||||
, {start = 28, finish = 28}
|
||||
, {start = 29, finish = 29}
|
||||
, {start = 30, finish = 30}
|
||||
, {start = 31, finish = 31}
|
||||
, {start = 32, finish = 32}
|
||||
, {start = 33, finish = 33}
|
||||
, {start = 34, finish = 34}
|
||||
, {start = 35, finish = 35}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
|
||||
(* assert *)
|
||||
in
|
||||
Expect.isTrue (inputList = outputList)
|
||||
end)
|
||||
]
|
||||
|
||||
val splitLeftTests = describe "PersistentVector.splitLeft"
|
||||
[ test
|
||||
"returns same vector when split idx is greater than any idx in vector"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
, {start = 8, finish = 8}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.splitLeft (9, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
in
|
||||
Expect.isTrue (inputList = outputList)
|
||||
end)
|
||||
, test "removes last element when split idx is = to last element" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
, {start = 8, finish = 8}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.splitLeft (8, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test "removes all elements when split idx = first element" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
, {start = 8, finish = 8}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.splitLeft (1, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput = []
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"removes element whose start and finish is in range \
|
||||
\of the split idx, and removes all elements after it too"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 155}
|
||||
, {start = 200, finish = 200}
|
||||
, {start = 210, finish = 210}
|
||||
, {start = 220, finish = 220}
|
||||
, {start = 230, finish = 230}
|
||||
, {start = 240, finish = 240}
|
||||
, {start = 250, finish = 250}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.splitLeft (7, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
]
|
||||
|
||||
val deleteTests = describe "PersistentVector.delete"
|
||||
[ test "returns empty vector when deletion range includes every element"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
, {start = 8, finish = 8}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (0, 11, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput = []
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"returns the left side of the vector \
|
||||
\when 'length' is greater than any element in the vector"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
, {start = 8, finish = 8}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (5, 4, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"decrements subsequent elements correctly \
|
||||
\when deletion range is before first element to middle element"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 50, finish = 50}
|
||||
, {start = 60, finish = 60}
|
||||
, {start = 70, finish = 70}
|
||||
, {start = 80, finish = 80}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (0, 3, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 47, finish = 47}
|
||||
, {start = 57, finish = 57}
|
||||
, {start = 67, finish = 67}
|
||||
, {start = 77, finish = 77}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"decrements subsequent elements correctly \
|
||||
\when deletion range is between two elements, \
|
||||
\but deletes no elements"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 3}
|
||||
, {start = 15, finish = 19}
|
||||
, {start = 35, finish = 39}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (21, 3, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 3}
|
||||
, {start = 15, finish = 19}
|
||||
, {start = 32, finish = 36}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test "deletes element when deletion range is inside that element" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 3}
|
||||
, {start = 15, finish = 19}
|
||||
, {start = 35, finish = 39}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (17, 1, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[{start = 1, finish = 3}, {start = 34, finish = 38}]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"returns preceding elements when \
|
||||
\deletion range starts in middle and deletes to end of vector"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 6, finish = 6}
|
||||
, {start = 7, finish = 7}
|
||||
, {start = 8, finish = 8}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (5, 9, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"deletes middle elements and decrements subsequent elements \
|
||||
\when deletion range starts after first element \
|
||||
\and ends before last element"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 60, finish = 60}
|
||||
, {start = 70, finish = 70}
|
||||
, {start = 80, finish = 80}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (3, 3, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 57, finish = 57}
|
||||
, {start = 67, finish = 67}
|
||||
, {start = 77, finish = 77}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"maintains balance with all leaves at same depth \
|
||||
\when deleting a large portion of nodes in the middle"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList = List.tabulate (228, fn i =>
|
||||
{start = i, finish = i})
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.delete (19, 15, pv)
|
||||
|
||||
(* assert *)
|
||||
val isBalanced = PersistentVector.allLeavesAtSameDepth pv
|
||||
in
|
||||
Expect.isTrue isBalanced
|
||||
end)
|
||||
]
|
||||
|
||||
val extendExistingMatchTests = describe "PersistentVector.extendExistingMatch"
|
||||
[ test
|
||||
"leaves subsequent matches untouched \
|
||||
\if their 'finish' is greater than the extended finish"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 60, finish = 60}
|
||||
, {start = 70, finish = 70}
|
||||
, {start = 80, finish = 80}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.extendExistingMatch (5, 50, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 50}
|
||||
, {start = 60, finish = 60}
|
||||
, {start = 70, finish = 70}
|
||||
, {start = 80, finish = 80}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"removes subsequent matches whose 'finish' is less than \
|
||||
\the newly extended element's 'finish'"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 5}
|
||||
, {start = 60, finish = 60}
|
||||
, {start = 70, finish = 70}
|
||||
, {start = 80, finish = 80}
|
||||
]
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.extendExistingMatch (5, 75, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 75}
|
||||
, {start = 80, finish = 80}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
, test
|
||||
"removes all subsequent elements when new 'finish' is greater \
|
||||
\than any finish in the vector"
|
||||
(fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val inputList = List.tabulate (500, fn i =>
|
||||
{start = i, finish = i})
|
||||
val pv = PersistentVector.fromList inputList
|
||||
|
||||
(* act *)
|
||||
val pv = PersistentVector.extendExistingMatch (5, 999, pv)
|
||||
|
||||
(* assert *)
|
||||
val outputList = PersistentVector.toList pv
|
||||
val expectedOutput =
|
||||
[ {start = 0, finish = 0}
|
||||
, {start = 1, finish = 1}
|
||||
, {start = 2, finish = 2}
|
||||
, {start = 3, finish = 3}
|
||||
, {start = 4, finish = 4}
|
||||
, {start = 5, finish = 999}
|
||||
]
|
||||
in
|
||||
Expect.isTrue (outputList = expectedOutput)
|
||||
end)
|
||||
]
|
||||
|
||||
val tests =
|
||||
[ appendTests
|
||||
, toListTests
|
||||
, splitLeftTests
|
||||
, deleteTests
|
||||
, extendExistingMatchTests
|
||||
]
|
||||
end
|
||||
618
shf/test/regex-tests.sml
Normal file
618
shf/test/regex-tests.sml
Normal file
@@ -0,0 +1,618 @@
|
||||
structure RegexTests =
|
||||
struct
|
||||
open Railroad
|
||||
open Railroad.Test
|
||||
|
||||
structure CiDfa = CaseInsensitiveDfa
|
||||
structure CsDfa = CaseSensitiveDfa
|
||||
|
||||
val caseInsensitiveTests = describe "case insensitive regex"
|
||||
[ test "recognises word 'hello' in string 'Hello world'" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val regexString = "hello"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
val inputString = "Hello world"
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(0, 4)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "recognises word 'world' in string 'HELLO WORLD'" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val regexString = "world"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
val inputString = "HELLO WORLD"
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(6, 10)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
]
|
||||
|
||||
val caseSensitiveTests = describe "case sensitive regex"
|
||||
[ test "does not recognise word 'hello' in string 'Hello world'" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val regexString = "hello"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
val inputString = "Hello world"
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = []
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "recognises word 'Hello' in string 'Hello world'" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val regexString = "Hello"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
val inputString = "Hello world"
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(0, 4)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "does not recognise word 'world' in string 'HELLO WORLD'" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val regexString = "world"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
val inputString = "HELLO WORLD"
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = []
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "recognises word 'WORLD' in string 'HELLO WORLD'" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val regexString = "WORLD"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
val inputString = "HELLO WORLD"
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(6, 10)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
]
|
||||
|
||||
val endMarkerTests = describe "regex endMarker"
|
||||
[ test "returns an empty DFA when regexString contains endMarker" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
(* the end marker is #"\^@" *)
|
||||
val regexString = "hello \^@ world"
|
||||
|
||||
(* act *)
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* assert *)
|
||||
val actualLength = Vector.length dfa
|
||||
val expectedLength = 0
|
||||
in
|
||||
Expect.isTrue (actualLength = expectedLength)
|
||||
end)
|
||||
, test "matches a string when regex has question mark at the end" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "favo"
|
||||
val regexString = "favou?"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(0, 3)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
]
|
||||
|
||||
fun recogniseEscapeSequence (regexString, inputString) =
|
||||
let
|
||||
(* arrange *)
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(6, 6)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end
|
||||
|
||||
fun doesNotRecogniseUnescaped (regexString, inputString) =
|
||||
let
|
||||
(* arrange *)
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, inputString)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = []
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end
|
||||
|
||||
val escapeSequenceTests = describe "regex escape sequences"
|
||||
[ test "recognises alert" (fn _ =>
|
||||
recogniseEscapeSequence ("\\a", "hello \a world"))
|
||||
, test "recognises backspace" (fn _ =>
|
||||
recogniseEscapeSequence ("\\b", "hello \b world"))
|
||||
, test "recognises tab" (fn _ =>
|
||||
recogniseEscapeSequence ("\\t", "hello \t world"))
|
||||
, test "recognises newline" (fn _ =>
|
||||
recogniseEscapeSequence ("\\n", "hello \n world"))
|
||||
, test "recognises vertical tab" (fn _ =>
|
||||
recogniseEscapeSequence ("\\v", "hello \v world"))
|
||||
, test "recognises form feed" (fn _ =>
|
||||
recogniseEscapeSequence ("\\f", "hello \f world"))
|
||||
, test "recognises carriage return" (fn _ =>
|
||||
recogniseEscapeSequence ("\\r", "hello \r world"))
|
||||
, test "recognises backslash" (fn _ =>
|
||||
recogniseEscapeSequence ("\\\\", "hello \\ world"))
|
||||
]
|
||||
|
||||
val metacharacterEscapeTest = describe "regex metacharacter escape sequences"
|
||||
[ test "recognises (" (fn _ =>
|
||||
recogniseEscapeSequence ("\\(", "hello ( world"))
|
||||
, test "recognises )" (fn _ =>
|
||||
recogniseEscapeSequence ("\\)", "hello ) world"))
|
||||
, test "recognises [" (fn _ =>
|
||||
recogniseEscapeSequence ("\\[", "hello [ world"))
|
||||
, test "recognises ]" (fn _ =>
|
||||
recogniseEscapeSequence ("\\]", "hello ] world"))
|
||||
, test "recognises +" (fn _ =>
|
||||
recogniseEscapeSequence ("\\+", "hello + world"))
|
||||
, test "recognises |" (fn _ =>
|
||||
recogniseEscapeSequence ("\\|", "hello | world"))
|
||||
, test "recognises ?" (fn _ =>
|
||||
recogniseEscapeSequence ("\\?", "hello ? world"))
|
||||
, test "recognises ." (fn _ =>
|
||||
recogniseEscapeSequence ("\\.", "hello . world"))
|
||||
, test "recognises -" (fn _ =>
|
||||
recogniseEscapeSequence ("\\-", "hello - world"))
|
||||
|
||||
(* checking that unescaped metacharacter is not recognised *)
|
||||
, test "does not recognise (" (fn _ =>
|
||||
doesNotRecogniseUnescaped ("(", "hello ( world"))
|
||||
, test "does not recognise )" (fn _ =>
|
||||
doesNotRecogniseUnescaped (")", "hello ) world"))
|
||||
, test "does not recognise [" (fn _ =>
|
||||
doesNotRecogniseUnescaped ("[", "hello [ world"))
|
||||
, test "does not recognise ]" (fn _ =>
|
||||
doesNotRecogniseUnescaped ("[", "hello ] world"))
|
||||
, test "does not recognise +" (fn _ =>
|
||||
doesNotRecogniseUnescaped ("+", "hello + world"))
|
||||
, test "does not recognise |" (fn _ =>
|
||||
doesNotRecogniseUnescaped ("|", "hello | world"))
|
||||
, test "does not recognise ?" (fn _ =>
|
||||
doesNotRecogniseUnescaped ("?", "hello ? world"))
|
||||
, test "does not recognise -" (fn _ =>
|
||||
doesNotRecogniseUnescaped ("-", "hello - world"))
|
||||
]
|
||||
|
||||
(* tests based on regex tutorial by FreeCodeCamp *)
|
||||
val freeCodeCampTests = describe "regex freeCodeCamp tests"
|
||||
[ test "The dog chased the cat" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "The dog chased the cat"
|
||||
val regexString = "the"
|
||||
val caseSensitiveDfa = CsDfa.fromString regexString
|
||||
val caseInsensitiveDfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val caseSensitiveMatches =
|
||||
CsDfa.matchString (caseSensitiveDfa, sentence)
|
||||
val caseInsensitiveMatches =
|
||||
CiDfa.matchString (caseInsensitiveDfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedCaseSensitive = [(15, 17)]
|
||||
val expectedCaseInsensitive = [(0, 2), (15, 17)]
|
||||
val expected =
|
||||
caseSensitiveMatches = expectedCaseSensitive
|
||||
andalso caseInsensitiveMatches = expectedCaseInsensitive
|
||||
in
|
||||
Expect.isTrue (expected)
|
||||
end)
|
||||
, test "Somewhere Waldo is hiding in this text." (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Somewhere Waldo is hiding in this text."
|
||||
val regexString = "Waldo"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(10, 14)]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "James has a pet cat." (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "James has a pet cat."
|
||||
val regexString = "dog|cat|bird|fish"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(16, 18)]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "Ignore Case While Matching" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "freeCodeCamp"
|
||||
val regexString = "freecodecamp"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(0, 11)]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "Extract the word 'coding' from this string" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Extract the word 'coding' from this string"
|
||||
val regexString = "coding"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(18, 23)]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "Repeat, Repeat, Repeat" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Repeat, Repeat, Repeat"
|
||||
val regexString = "Repeat"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(0, 5), (8, 13), (16, 21)]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "Twinkle, twinkle, little start" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Twinkle, twinkle, little start"
|
||||
val regexString = "twinkle"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(0, 6), (9, 15)]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "hu. regex" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val regexString = "hu."
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
val humStr = "To mock a humming bird"
|
||||
val hugStr = "Bear hug"
|
||||
|
||||
(* act *)
|
||||
val humMatches = CiDfa.matchString (dfa, humStr)
|
||||
val hugMatches = CiDfa.matchString (dfa, hugStr)
|
||||
|
||||
(* assert *)
|
||||
val expectedHumMatches = [(10, 12)]
|
||||
val expectedHugMatches = [(5, 7)]
|
||||
val isExpected =
|
||||
humMatches = expectedHumMatches
|
||||
andalso hugMatches = expectedHugMatches
|
||||
in
|
||||
Expect.isTrue isExpected
|
||||
end)
|
||||
, test "Let's have fun with regular expressions!" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Let's have fun with regular expressions!"
|
||||
val regexString = ".un"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(11, 13)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "Beware of bugs in the above code" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence =
|
||||
"Beware of bugs in the above code;\
|
||||
\I have only proved it correct, not tried it."
|
||||
val regexString = "[aeiou]"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches =
|
||||
[ (1, 1)
|
||||
, (3, 3)
|
||||
, (5, 5)
|
||||
, (7, 7)
|
||||
, (11, 11)
|
||||
, (15, 15)
|
||||
, (20, 20)
|
||||
, (22, 22)
|
||||
, (24, 24)
|
||||
, (26, 26)
|
||||
, (29, 29)
|
||||
, (31, 31)
|
||||
, (33, 33)
|
||||
, (36, 36)
|
||||
, (38, 38)
|
||||
, (40, 40)
|
||||
, (47, 47)
|
||||
, (49, 49)
|
||||
, (52, 52)
|
||||
, (56, 56)
|
||||
, (59, 59)
|
||||
, (65, 65)
|
||||
, (70, 70)
|
||||
, (71, 71)
|
||||
, (74, 74)
|
||||
]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "The quick brown fox jumps over the lazy dog." (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "The quick brown fox jumps over the lazy dog."
|
||||
val regexString = "[a-zA-Z]"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches =
|
||||
[ (0, 0)
|
||||
, (1, 1)
|
||||
, (2, 2)
|
||||
, (4, 4)
|
||||
, (5, 5)
|
||||
, (6, 6)
|
||||
, (7, 7)
|
||||
, (8, 8)
|
||||
, (10, 10)
|
||||
, (11, 11)
|
||||
, (12, 12)
|
||||
, (13, 13)
|
||||
, (14, 14)
|
||||
, (16, 16)
|
||||
, (17, 17)
|
||||
, (18, 18)
|
||||
, (20, 20)
|
||||
, (21, 21)
|
||||
, (22, 22)
|
||||
, (23, 23)
|
||||
, (24, 24)
|
||||
, (26, 26)
|
||||
, (27, 27)
|
||||
, (28, 28)
|
||||
, (29, 29)
|
||||
, (31, 31)
|
||||
, (32, 32)
|
||||
, (33, 33)
|
||||
, (35, 35)
|
||||
, (36, 36)
|
||||
, (37, 37)
|
||||
, (38, 38)
|
||||
, (40, 40)
|
||||
, (41, 41)
|
||||
, (42, 42)
|
||||
]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "Blueberry 3.141592653s are delicious." (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Blueberry 3.141592653s are delicious."
|
||||
val regexString = "[2-6h-s]"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches =
|
||||
[ (1, 1)
|
||||
, (6, 6)
|
||||
, (7, 7)
|
||||
, (10, 10)
|
||||
, (13, 13)
|
||||
, (15, 15)
|
||||
, (17, 17)
|
||||
, (18, 18)
|
||||
, (19, 19)
|
||||
, (20, 20)
|
||||
, (21, 21)
|
||||
, (24, 24)
|
||||
, (29, 29)
|
||||
, (30, 30)
|
||||
, (32, 32)
|
||||
, (33, 33)
|
||||
, (35, 35)
|
||||
]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "3 blind mice." (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "3 blind mice."
|
||||
val regexString = "[^0-9aeiou]"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches =
|
||||
[ (1, 1)
|
||||
, (2, 2)
|
||||
, (3, 3)
|
||||
, (5, 5)
|
||||
, (6, 6)
|
||||
, (7, 7)
|
||||
, (8, 8)
|
||||
, (10, 10)
|
||||
, (12, 12)
|
||||
]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "Mississipi" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Mississipi"
|
||||
val regexString = "s+"
|
||||
val dfa = CiDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CiDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(2, 3), (5, 6)]
|
||||
in
|
||||
Expect.isTrue (expectedMatches = matches)
|
||||
end)
|
||||
, test "goooal" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val soccerSentence = "goooal"
|
||||
val gPhrase = "gut feeling"
|
||||
val oPhrase = "over the moon"
|
||||
|
||||
val goRegex = "go*"
|
||||
val dfa = CsDfa.fromString goRegex
|
||||
|
||||
(* act *)
|
||||
val soccerMatches = CsDfa.matchString (dfa, soccerSentence)
|
||||
val gPhraseMatches = CsDfa.matchString (dfa, gPhrase)
|
||||
val oPhraseMatches = CsDfa.matchString (dfa, oPhrase)
|
||||
|
||||
(* assert *)
|
||||
val expectedSoccerMatches = [(0, 3)]
|
||||
val expectedGPhraseMatches = [(0, 0), (10, 10)]
|
||||
val expectedOPhraseMatches = []
|
||||
|
||||
val isExpected =
|
||||
soccerMatches = expectedSoccerMatches
|
||||
andalso gPhraseMatches = expectedGPhraseMatches
|
||||
andalso oPhraseMatches = expectedOPhraseMatches
|
||||
in
|
||||
Expect.isTrue isExpected
|
||||
end)
|
||||
, test "chewie quote" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentence = "Aaaaaaargh"
|
||||
val regexString = "Aa*"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matches = CsDfa.matchString (dfa, sentence)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatches = [(0, 6)]
|
||||
in
|
||||
Expect.isTrue (matches = expectedMatches)
|
||||
end)
|
||||
, test "favorite" (fn _ =>
|
||||
let
|
||||
(* arrange *)
|
||||
val sentenceWithoutU = "favorite"
|
||||
val sentenceWithU = "favourite"
|
||||
|
||||
val regexString = "favou?rite"
|
||||
val dfa = CsDfa.fromString regexString
|
||||
|
||||
(* act *)
|
||||
val matchesWithoutU = CsDfa.matchString (dfa, sentenceWithoutU)
|
||||
val matchesWithU = CsDfa.matchString (dfa, sentenceWithU)
|
||||
|
||||
(* assert *)
|
||||
val expectedMatchesWithoutU = [(0, 7)]
|
||||
val expectedMatchesWithU = [(0, 8)]
|
||||
|
||||
val isExpected =
|
||||
matchesWithoutU = expectedMatchesWithoutU
|
||||
andalso matchesWithU = expectedMatchesWithU
|
||||
in
|
||||
Expect.isTrue isExpected
|
||||
end)
|
||||
]
|
||||
|
||||
val tests =
|
||||
[ caseInsensitiveTests
|
||||
, caseSensitiveTests
|
||||
, endMarkerTests
|
||||
, escapeSequenceTests
|
||||
, metacharacterEscapeTest
|
||||
, freeCodeCampTests
|
||||
]
|
||||
end
|
||||
82
shf/test/regression-tests.sml
Normal file
82
shf/test/regression-tests.sml
Normal file
@@ -0,0 +1,82 @@
|
||||
structure RegressionTests =
|
||||
struct
|
||||
open Railroad
|
||||
open Railroad.Test
|
||||
|
||||
fun updateLoop (pos, str, app) =
|
||||
if pos = String.size str then
|
||||
app
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, pos)
|
||||
val () = ExceptionLogger.addCommand (InputMsg.CHAR_EVENT chr)
|
||||
val app = TestUtils.update (app, InputMsg.CHAR_EVENT chr)
|
||||
in
|
||||
updateLoop (pos + 1, str, app)
|
||||
end
|
||||
|
||||
fun appFromText text = TestUtils.init text
|
||||
|
||||
fun loadFromFile (io, acc) =
|
||||
case TextIO.inputLine io of
|
||||
SOME line => loadFromFile (io, acc ^ line)
|
||||
| NONE => acc
|
||||
|
||||
val initialText =
|
||||
let
|
||||
val io = TextIO.openIn "temp.txt"
|
||||
val str = loadFromFile (io, "")
|
||||
val () = TextIO.closeIn io
|
||||
in
|
||||
str
|
||||
end
|
||||
|
||||
val charEventTests = describe "CHAR_EVENT regressions"
|
||||
[ test "SearchList.goToNum vector bounds regression (1)" (fn _ =>
|
||||
let
|
||||
val app = TestUtils.init initialText
|
||||
val history = "G12dk"
|
||||
val newApp = TestUtils.updateMany (app, history)
|
||||
in
|
||||
(* just expect that we do not fail or throw an exception *)
|
||||
Expect.isTrue true
|
||||
end)
|
||||
, test "No error raised when moving cursor up/down after deleting" (fn _ =>
|
||||
let
|
||||
val app = TestUtils.init initialText
|
||||
val history =
|
||||
"16G18ddjjjjjjjjjdkdkdkjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj"
|
||||
val newApp = TestUtils.updateMany (app, history)
|
||||
in
|
||||
Expect.isTrue true
|
||||
end)
|
||||
, test
|
||||
"SearchList.buildRange does not cause exception \
|
||||
\when deleting (1)"
|
||||
(fn _ =>
|
||||
let
|
||||
val app = TestUtils.init "h ello world\n"
|
||||
|
||||
(* search *)
|
||||
val search = "/ello"
|
||||
val app = TestUtils.updateMany (app, search)
|
||||
val app = TestUtils.update (app, InputMsg.KEY_ENTER)
|
||||
|
||||
(* move and then delete twice *)
|
||||
val app = TestUtils.updateMany (app, "edede")
|
||||
in
|
||||
Expect.isTrue true
|
||||
end)
|
||||
, test
|
||||
"DfaGen does not cause exception \
|
||||
\when parsing alternation that contains a char \
|
||||
\from the previous alternation (1)"
|
||||
(fn _ =>
|
||||
(let val dfa = CaseSensitiveDfa.fromString "str|s"
|
||||
in Expect.isTrue true
|
||||
end)
|
||||
handle _ => Expect.isTrue false)
|
||||
]
|
||||
|
||||
val tests = [charEventTests]
|
||||
end
|
||||
71
shf/test/test-utils.sml
Normal file
71
shf/test/test-utils.sml
Normal file
@@ -0,0 +1,71 @@
|
||||
structure TestUtils =
|
||||
struct
|
||||
fun init bufferString =
|
||||
let val buffer = LineGap.fromString bufferString
|
||||
in AppType.init (buffer, 0, 0, Time.now ())
|
||||
end
|
||||
|
||||
fun update (app, cmd) =
|
||||
AppUpdate.update (app, cmd, Time.now ())
|
||||
|
||||
fun updateMany (app, str) =
|
||||
let
|
||||
fun loop (pos, app) =
|
||||
if pos = String.size str then
|
||||
app
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, pos)
|
||||
val chr = InputMsg.CHAR_EVENT chr
|
||||
val app = update (app, chr)
|
||||
in
|
||||
loop (pos + 1, app)
|
||||
end
|
||||
in
|
||||
loop (0, app)
|
||||
end
|
||||
|
||||
fun expectYank (app: AppType.app_type, expectedString) =
|
||||
let
|
||||
open MailboxType
|
||||
open DrawMsg
|
||||
open Railroad
|
||||
open Railroad.Test
|
||||
|
||||
fun loop (hd :: tl) =
|
||||
(case hd of
|
||||
DRAW (YANK actualString) =>
|
||||
if actualString = expectedString then
|
||||
Expect.isTrue (actualString = expectedString)
|
||||
else
|
||||
let
|
||||
val () = print
|
||||
("expectedString = [" ^ expectedString ^ "]\n")
|
||||
val () = print ("actualString = [" ^ actualString ^ "]\n")
|
||||
val () = print "\n"
|
||||
in
|
||||
Expect.isTrue (actualString = expectedString)
|
||||
end
|
||||
| _ => loop tl)
|
||||
| loop ([]) =
|
||||
let val () = print "no string yanked\n"
|
||||
in Expect.isTrue false
|
||||
end
|
||||
in
|
||||
loop (#msgs app)
|
||||
end
|
||||
|
||||
fun expectNoYank (app: AppType.app_type) =
|
||||
let
|
||||
open MailboxType
|
||||
open DrawMsg
|
||||
open Railroad
|
||||
open Railroad.Test
|
||||
|
||||
fun loop (DRAW (YANK _) :: _) = Expect.isTrue false
|
||||
| loop (hd :: tl) = loop tl
|
||||
| loop ([]) = Expect.isTrue true
|
||||
in
|
||||
loop (#msgs app)
|
||||
end
|
||||
end
|
||||
23
shf/test/test.sml
Normal file
23
shf/test/test.sml
Normal file
@@ -0,0 +1,23 @@
|
||||
structure Test =
|
||||
struct
|
||||
open Railroad
|
||||
open Railroad.Test
|
||||
|
||||
fun main () =
|
||||
let
|
||||
val tests = List.concat
|
||||
[ NormalMoveTests.tests
|
||||
, NormalDeleteTests.tests
|
||||
, NormalYankTests.tests
|
||||
, PersistentVectorTests.tests
|
||||
, RegressionTests.tests
|
||||
, RegexTests.tests
|
||||
]
|
||||
val tests = concat tests
|
||||
in
|
||||
runWithConfig [Configuration.PrintPassed false] tests
|
||||
handle e => ExceptionLogger.log e
|
||||
end
|
||||
end
|
||||
|
||||
val () = Test.main ()
|
||||
12
shf/todo.md
Normal file
12
shf/todo.md
Normal file
@@ -0,0 +1,12 @@
|
||||
# To-do list
|
||||
- Add normal-delete tests for each motion, checking that searchList is as expected
|
||||
- Three cases for searchList:
|
||||
1. Deletion causes two words to join to form a new match
|
||||
2. Deletion causes an existing match to be extended
|
||||
3. Deletion introduces no match
|
||||
- Add tests for indent, dedent and remove-line-break motions
|
||||
- Add tests that searchList updates as expected too
|
||||
- Add tests for other yank motoins
|
||||
- Tests should be based on existing tests for delete-motions, and in the same order.
|
||||
- Bind gamepad functions from GLFW and/or RGFW
|
||||
- Add tests for NormalYankDelete functions, to make sure that they are yanking the expected string.
|
||||
Reference in New Issue
Block a user