From fc98658355171f7ff6d5d35e4c68143a10949516 Mon Sep 17 00:00:00 2001 From: Kazark Date: Tue, 28 Jul 2015 22:36:18 -0400 Subject: [PATCH 01/28] Stop view model from directly invoking functions on Buffer module + Subdivide the monolith EditorTypes.fs + Remove CoreEvent.BufferAdded + Add BufferEventMessage and BufferEvent message types + Added FileBufferProxy so that the FileBuffer, which is likely going to be a complex object and quite subject to change and probably subdivision as we go and shouldn't be depended on by other services, especially not in other assembly, could be made fully private. Even though I had made its constructor private, I still did not want the view model calling out to even Buffer.readlines. --- src/Void.Core/BufferList.fs | 13 +++++- src/Void.Core/CommandModeMessages.fs | 52 +++++++++++++++++++++ src/Void.Core/CoreMessages.fs | 54 ++++------------------ src/Void.Core/{EditorTypes.fs => Grids.fs} | 44 ------------------ src/Void.Core/ModeTypes.fs | 18 ++++++++ src/Void.Core/Motion.fs | 21 +++++++++ src/Void.Core/Void.Core.fsproj | 5 +- src/Void.ViewModel/ViewModel.fs | 5 +- src/Void.ViewModel/ViewModelService.fs | 14 ++++-- src/Void.ViewModel/WindowBufferMap.fs | 12 ++--- src/Void/Init.fs | 24 ++-------- 11 files changed, 139 insertions(+), 123 deletions(-) create mode 100644 src/Void.Core/CommandModeMessages.fs rename src/Void.Core/{EditorTypes.fs => Grids.fs} (58%) create mode 100644 src/Void.Core/ModeTypes.fs create mode 100644 src/Void.Core/Motion.fs diff --git a/src/Void.Core/BufferList.fs b/src/Void.Core/BufferList.fs index 1de7d95..8d3a13c 100644 --- a/src/Void.Core/BufferList.fs +++ b/src/Void.Core/BufferList.fs @@ -1,5 +1,12 @@ namespace Void.Core +// TODO This is naive, obviously +type FileBuffer = private { + Filepath : string option + Contents : string list + CursorPosition : CellGrid.Cell +} + module Buffer = open CellGrid @@ -36,7 +43,11 @@ module BufferList = List = bufferList.List.Add(id, buffer) LastId = id } - (listPlusOne, CoreEvent.BufferAdded (id, buffer) :> Message ) + let bufferProxy = { + MaybeFilepath = buffer.Filepath + Contents = Seq.ofList buffer.Contents + } + (listPlusOne, { BufferId = id; Event = BufferEvent.Added bufferProxy } :> Message ) let private addEmptyBuffer bufferList = addBuffer bufferList Buffer.emptyFile diff --git a/src/Void.Core/CommandModeMessages.fs b/src/Void.Core/CommandModeMessages.fs new file mode 100644 index 0000000..1c2c488 --- /dev/null +++ b/src/Void.Core/CommandModeMessages.fs @@ -0,0 +1,52 @@ +namespace Void.Core + +type InterpretFullScriptRequest = + { + Language : string + Script : string + } + interface RequestMessage + +[] +type InterpretFullScriptResponse = + | ParseFailed of Error + | Completed + interface ResponseMessage + +type InterpretScriptFragmentRequest = + { + Language : string + Fragment : string + } + interface RequestMessage + +[] +type InterpretScriptFragmentResponse = + | ParseFailed of Error + | ParseIncomplete + | Completed + interface ResponseMessage + +[] +type CommandHistoryCommand = + | MoveToPreviousCommand + | MoveToNextCommand + interface CommandMessage + +[] +type CommandHistoryEvent = + | MovedToCommand of string + | MovedToEmptyCommand + | CommandAdded + interface Message + +type GetCurrentCommandLanguageRequest = + | GetCurrentCommandLanguageRequest + interface RequestMessage + +type GetCurrentCommandLanguageResponse = + { + CurrentCommandLanguage : string + } + interface ResponseMessage + diff --git a/src/Void.Core/CoreMessages.fs b/src/Void.Core/CoreMessages.fs index 939d577..323a743 100644 --- a/src/Void.Core/CoreMessages.fs +++ b/src/Void.Core/CoreMessages.fs @@ -2,7 +2,6 @@ [] type CoreEvent = - | BufferAdded of int * FileBuffer | ErrorOccurred of Error | FileOpenedForEditing of string * string seq | FileSaved of string @@ -54,55 +53,22 @@ type BufferCommandMessage = } interface CommandMessage -type InterpretFullScriptRequest = - { - Language : string - Script : string - } - interface RequestMessage - -[] -type InterpretFullScriptResponse = - | ParseFailed of Error - | Completed - interface ResponseMessage - -type InterpretScriptFragmentRequest = - { - Language : string - Fragment : string - } - interface RequestMessage +type FileBufferProxy = { + MaybeFilepath : string option + Contents : string seq +} [] -type InterpretScriptFragmentResponse = - | ParseFailed of Error - | ParseIncomplete - | Completed - interface ResponseMessage - -[] -type CommandHistoryCommand = - | MoveToPreviousCommand - | MoveToNextCommand +type BufferEvent = + | Added of FileBufferProxy interface CommandMessage -[] -type CommandHistoryEvent = - | MovedToCommand of string - | MovedToEmptyCommand - | CommandAdded - interface Message - -type GetCurrentCommandLanguageRequest = - | GetCurrentCommandLanguageRequest - interface RequestMessage - -type GetCurrentCommandLanguageResponse = +type BufferEventMessage = { - CurrentCommandLanguage : string + BufferId : int + Event : BufferEvent } - interface ResponseMessage + interface CommandMessage [] module ``This module is auto-opened to provide message aliases`` = diff --git a/src/Void.Core/EditorTypes.fs b/src/Void.Core/Grids.fs similarity index 58% rename from src/Void.Core/EditorTypes.fs rename to src/Void.Core/Grids.fs index b5c7e71..7e35835 100644 --- a/src/Void.Core/EditorTypes.fs +++ b/src/Void.Core/Grids.fs @@ -1,22 +1,5 @@ namespace Void.Core -// TODO be very careful to get the abstractions right here! -// TODO could be very easy to shoot oneself in the foot with the wrong abstraction! -[] -type Mode = - | Insert - | Normal - | Command - | Visual - | VisualBlock // TODO should this be subsumed under Visual? - | OperatorPending // TODO is this a submode of command - // TODO there are many more modes - -type ModeChange = { - From : Mode - To : Mode -} - module PointGrid = type Point = { X : int @@ -90,30 +73,3 @@ module GridConvert = UpperLeftCorner = upperLeftCornerOf cell Dimensions = { Width = 1; Height = 1 } } - -// TODO This is naive, obviously -type FileBuffer = private { - Filepath : string option - Contents : string list - CursorPosition : CellGrid.Cell -} - -[] type mCharacter -[] type mLine -[] type mPararagraph -[] type mBuffer - -type Motion = interface end - -[] -type Move<[]'UnitOfMotion> = // Relative motion - | Backward of int<'UnitOfMotion> - | Forward of int<'UnitOfMotion> - interface Motion - -[] -type MoveTo<[]'InnerUnit, []'OuterUnit> = // Absolute motion - | First - | Nth of int<'InnerUnit> - | Last - interface Motion diff --git a/src/Void.Core/ModeTypes.fs b/src/Void.Core/ModeTypes.fs new file mode 100644 index 0000000..6ef585b --- /dev/null +++ b/src/Void.Core/ModeTypes.fs @@ -0,0 +1,18 @@ +namespace Void.Core + +// TODO be very careful to get the abstractions right here! +// TODO could be very easy to shoot oneself in the foot with the wrong abstraction! +[] +type Mode = + | Insert + | Normal + | Command + | Visual + | VisualBlock // TODO should this be subsumed under Visual? + | OperatorPending // TODO is this a submode of command + // TODO there are many more modes + +type ModeChange = { + From : Mode + To : Mode +} diff --git a/src/Void.Core/Motion.fs b/src/Void.Core/Motion.fs new file mode 100644 index 0000000..a659e70 --- /dev/null +++ b/src/Void.Core/Motion.fs @@ -0,0 +1,21 @@ +namespace Void.Core + +[] type mCharacter +[] type mLine +[] type mPararagraph +[] type mBuffer + +type Motion = interface end + +[] +type Move<[]'UnitOfMotion> = // Relative motion + | Backward of int<'UnitOfMotion> + | Forward of int<'UnitOfMotion> + interface Motion + +[] +type MoveTo<[]'InnerUnit, []'OuterUnit> = // Absolute motion + | First + | Nth of int<'InnerUnit> + | Last + interface Motion diff --git a/src/Void.Core/Void.Core.fsproj b/src/Void.Core/Void.Core.fsproj index e25f847..1a82b30 100644 --- a/src/Void.Core/Void.Core.fsproj +++ b/src/Void.Core/Void.Core.fsproj @@ -47,7 +47,10 @@ - + + + + diff --git a/src/Void.ViewModel/ViewModel.fs b/src/Void.ViewModel/ViewModel.fs index 24989b1..693f117 100644 --- a/src/Void.ViewModel/ViewModel.fs +++ b/src/Void.ViewModel/ViewModel.fs @@ -42,9 +42,8 @@ module ViewModel = |> Seq.toList } - let toScreenBuffer windowSize buffer = - Buffer.readLines buffer 1 - |> bufferFrom windowSize + let toScreenBuffer windowSize (buffer : FileBufferProxy) = + bufferFrom windowSize buffer.Contents let private loadBufferIntoWindow buffer window = { window with Buffer = toScreenBuffer window.Area.Dimensions buffer } diff --git a/src/Void.ViewModel/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index eb20be3..3e4551d 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -38,13 +38,16 @@ type ViewModelService() = | CommandBar.Event.TextReflowed commandBar -> renderCommandBar commandBar - member x.handleEvent = - function // TODO clearly the code below needs to be refactored - | CoreEvent.BufferAdded (id, buffer) -> + member x.handleBufferEvent event = + match event.Event with + | BufferEvent.Added buffer -> _viewModel <- ViewModel.loadBuffer buffer _viewModel let drawings = Render.currentBufferAsDrawingObjects _viewModel let area = GridConvert.boxAround (ViewModel.wholeArea _viewModel) (* TODO shouldn't redraw the whole UI *) VMEvent.ViewPortionRendered(area, drawings) :> Message + + member x.handleEvent = + function // TODO clearly the code below needs to be refactored | CoreEvent.NotificationAdded notification -> let area = ViewModel.areaOfCommandBarOrNotifications _viewModel let drawing = ViewModel.toScreenNotification notification @@ -52,3 +55,8 @@ type ViewModelService() = let areaInPoints = GridConvert.boxAround area VMEvent.ViewPortionRendered(areaInPoints, [drawing]) :> Message | _ -> noMessage + + member x.subscribe (subscribeHandler : SubscribeToBus) = + subscribeHandler.subscribe x.handleEvent + subscribeHandler.subscribe x.handleCommand + subscribeHandler.subscribe x.handleCommandBarEvent \ No newline at end of file diff --git a/src/Void.ViewModel/WindowBufferMap.fs b/src/Void.ViewModel/WindowBufferMap.fs index 19bef48..093b83f 100644 --- a/src/Void.ViewModel/WindowBufferMap.fs +++ b/src/Void.ViewModel/WindowBufferMap.fs @@ -72,12 +72,10 @@ module WindowBufferMap = | FileOrBufferId.BufferNumber bufferId -> (windowBufferMap, noMessage) - let handleEvent windowBufferMap event = - match event with - | CoreEvent.BufferAdded (bufferId, buffer) -> - loadBufferIntoCurrentWindow windowBufferMap bufferId - | _ -> - (windowBufferMap, noMessage) + let handleBufferEvent windowBufferMap event = + match event.Event with + | BufferEvent.Added _ -> + loadBufferIntoCurrentWindow windowBufferMap event.BufferId module Service = open Void.Core @@ -85,4 +83,4 @@ module WindowBufferMap = let subscribe (subscribeHandler : SubscribeToBus) = let windowBufferMap = ref empty subscribeHandler.subscribe <| Service.wrap windowBufferMap handleVMCommand - subscribeHandler.subscribe <| Service.wrap windowBufferMap handleEvent + subscribeHandler.subscribe <| Service.wrap windowBufferMap handleBufferEvent diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 61fd9a4..033b899 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -38,26 +38,9 @@ module Init = let buildVoid inputModeChanger (options : VoidOptions) = let editorService = EditorService() - let viewService = ViewModelService() - let coreCommandChannel = - Channel [ - viewService.handleCommand - editorService.handleCommand - ] - let coreEventChannel = - Channel [ - viewService.handleEvent - ] - let commandBarEventChannel = - Channel [ - viewService.handleCommandBarEvent - ] - let bus = - Bus [ - coreCommandChannel - coreEventChannel - commandBarEventChannel - ] + let viewModelService = ViewModelService() + let coreCommandChannel = Channel [ editorService.handleCommand ] + let bus = Bus [ coreCommandChannel ] let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter let modeService = ModeService(NormalMode.InputHandler(), @@ -66,6 +49,7 @@ module Init = InsertModeInputHandler(), setInputMode inputModeChanger bus.publish) modeService.subscribe bus + viewModelService.subscribe bus if options.EnableVerboseMessageLogging then MessageLog.Service.subscribe bus interpreterWrapperService.subscribe bus BufferList.Service.subscribe bus From 5e8abaec8e61e7b845b3d6e5107b3161be37506b Mon Sep 17 00:00:00 2001 From: Kazark Date: Tue, 28 Jul 2015 22:43:25 -0400 Subject: [PATCH 02/28] Rename NormalMode module -> NormalModeBindings I have realized that NormalMode is a much bigger thing and that this module/service's responsibility is really only the bindings portion of it. --- src/Void.Core.Spec/NormalModeSpec.fs | 2 +- src/Void.Core/ModeService.fs | 2 +- src/Void.Core/{NormalMode.fs => NormalModeBindings.fs} | 2 +- src/Void.Core/Void.Core.fsproj | 2 +- src/Void.ViewModel/ViewModelService.fs | 1 + src/Void/DefaultNormalModeBindings.fs | 2 +- src/Void/Init.fs | 2 +- 7 files changed, 7 insertions(+), 6 deletions(-) rename src/Void.Core/{NormalMode.fs => NormalModeBindings.fs} (96%) diff --git a/src/Void.Core.Spec/NormalModeSpec.fs b/src/Void.Core.Spec/NormalModeSpec.fs index 6c81ffa..6944236 100644 --- a/src/Void.Core.Spec/NormalModeSpec.fs +++ b/src/Void.Core.Spec/NormalModeSpec.fs @@ -1,7 +1,7 @@ namespace Void.Core.Spec open Void.Core -open Void.Core.NormalMode +open Void.Core.NormalModeBindings open NUnit.Framework open FsUnit diff --git a/src/Void.Core/ModeService.fs b/src/Void.Core/ModeService.fs index 5fb4dd5..f88073d 100644 --- a/src/Void.Core/ModeService.fs +++ b/src/Void.Core/ModeService.fs @@ -19,7 +19,7 @@ type ModeNotImplementedYet_FakeInputHandler() = type ModeService ( - normalModeInputHandler : NormalMode.InputHandler, + normalModeInputHandler : NormalModeBindings.InputHandler, commandModeInputHandler : CommandMode.InputHandler, visualModeInputHandler : VisualModeInputHandler, insertModeInputHandler : InsertModeInputHandler, diff --git a/src/Void.Core/NormalMode.fs b/src/Void.Core/NormalModeBindings.fs similarity index 96% rename from src/Void.Core/NormalMode.fs rename to src/Void.Core/NormalModeBindings.fs index c14b265..a7bc260 100644 --- a/src/Void.Core/NormalMode.fs +++ b/src/Void.Core/NormalModeBindings.fs @@ -10,7 +10,7 @@ type KeyPressed = } interface EventMessage -module NormalMode = +module NormalModeBindings = [] type Command = | Bind of KeyPress list * CommandMessage diff --git a/src/Void.Core/Void.Core.fsproj b/src/Void.Core/Void.Core.fsproj index 1a82b30..fafd189 100644 --- a/src/Void.Core/Void.Core.fsproj +++ b/src/Void.Core/Void.Core.fsproj @@ -52,7 +52,7 @@ - + diff --git a/src/Void.ViewModel/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index 3e4551d..d4461f0 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -58,5 +58,6 @@ type ViewModelService() = member x.subscribe (subscribeHandler : SubscribeToBus) = subscribeHandler.subscribe x.handleEvent + subscribeHandler.subscribe x.handleBufferEvent subscribeHandler.subscribe x.handleCommand subscribeHandler.subscribe x.handleCommandBarEvent \ No newline at end of file diff --git a/src/Void/DefaultNormalModeBindings.fs b/src/Void/DefaultNormalModeBindings.fs index 9964bdd..4716056 100644 --- a/src/Void/DefaultNormalModeBindings.fs +++ b/src/Void/DefaultNormalModeBindings.fs @@ -43,7 +43,7 @@ module DefaultNormalModeBindings = ] let bindAllCommands bindings = - Seq.map NormalMode.Command.Bind bindings + Seq.map NormalModeBindings.Command.Bind bindings let handleCommand (bus : Bus) command = match command with diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 033b899..219fb25 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -43,7 +43,7 @@ module Init = let bus = Bus [ coreCommandChannel ] let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter - let modeService = ModeService(NormalMode.InputHandler(), + let modeService = ModeService(NormalModeBindings.InputHandler(), CommandMode.InputHandler(), VisualModeInputHandler(), InsertModeInputHandler(), From 2f5bec3be2282a6cb35c93d36a5a5a6c0a9275f9 Mon Sep 17 00:00:00 2001 From: Kazark Date: Wed, 29 Jul 2015 23:00:53 -0400 Subject: [PATCH 03/28] Some faltering steps toward CTRL-E/CTRL-Y Began to realize my request/response stuff was badly mangled... --- src/Void.Core/BaseMessageTypes.fs | 4 ++- src/Void.Core/BufferList.fs | 30 ++++++++++++++++-- src/Void.Core/BufferMessages.fs | 42 ++++++++++++++++++++++++++ src/Void.Core/CoreMessages.fs | 29 ------------------ src/Void.Core/Void.Core.fsproj | 1 + src/Void.ViewModel/ViewModel.fs | 1 + src/Void.ViewModel/ViewModelService.fs | 14 ++++++++- src/Void.ViewModel/ViewModelTypes.fs | 1 + src/Void.ViewModel/WindowBufferMap.fs | 33 ++++++++++++++------ 9 files changed, 112 insertions(+), 43 deletions(-) create mode 100644 src/Void.Core/BufferMessages.fs diff --git a/src/Void.Core/BaseMessageTypes.fs b/src/Void.Core/BaseMessageTypes.fs index 6f0265d..d365f1f 100644 --- a/src/Void.Core/BaseMessageTypes.fs +++ b/src/Void.Core/BaseMessageTypes.fs @@ -5,6 +5,8 @@ type Message = interface end type CommandMessage = inherit Message type EventMessage = inherit Message +type EnvelopeMessage<'TInnerMessage when 'TInnerMessage :> Message> = inherit Message + type RequestMessage = inherit Message type ResponseMessage<'TRequest when 'TRequest :> RequestMessage> = inherit Message @@ -37,4 +39,4 @@ type SubscribeToBus = abstract member subscribe<'TMsg when 'TMsg :> Message> : Handle<'TMsg> -> unit abstract member subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> : HandleRequest<'TRequest> -> unit abstract member subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> : MaybeHandleRequest<'TRequest> -> unit - abstract member subscribeToResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleResponse<'TRequest, 'TResponse> -> unit \ No newline at end of file + abstract member subscribeToResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleResponse<'TRequest, 'TResponse> -> unit diff --git a/src/Void.Core/BufferList.fs b/src/Void.Core/BufferList.fs index 8d3a13c..844f14f 100644 --- a/src/Void.Core/BufferList.fs +++ b/src/Void.Core/BufferList.fs @@ -20,7 +20,7 @@ module Buffer = { Filepath = Some path; Contents = contents; CursorPosition = originCell } let readLines fileBuffer start = - fileBuffer.Contents |> Seq.skip (start - 1) // Line numbers start at 1 + fileBuffer.Contents |> Seq.skip ((start - 1)/1) // Line numbers start at 1 type Buffers = private { List : Map @@ -47,13 +47,13 @@ module BufferList = MaybeFilepath = buffer.Filepath Contents = Seq.ofList buffer.Contents } - (listPlusOne, { BufferId = id; Event = BufferEvent.Added bufferProxy } :> Message ) + (listPlusOne, { BufferId = id; Message = BufferEvent.Added bufferProxy } :> Message ) let private addEmptyBuffer bufferList = addBuffer bufferList Buffer.emptyFile let private writeBufferToPath bufferList bufferId path = - let lines = Buffer.readLines bufferList.List.[bufferId] 0 + let lines = Buffer.readLines bufferList.List.[bufferId] 0 let msg = Filesystem.Command.SaveToDisk (path, lines) :> Message (bufferList, msg) @@ -85,6 +85,30 @@ module BufferList = | _ -> (bufferList, noMessage) + let private package bufferId message = + { + BufferId = bufferId + Message = message + } + + let handleGetBufferContentsRequest bufferList envelope = + let buffers = (!bufferList).List + if buffers.ContainsKey envelope.BufferId + then + let buffer = buffers.[envelope.BufferId] + { + FirstLineNumber = envelope.Message.StartingAtLine + RequestedContents = + if buffer.Contents.Length*1 < envelope.Message.StartingAtLine + then Seq.empty + else Buffer.readLines buffer envelope.Message.StartingAtLine + } + |> package envelope.BufferId + :> EnvelopeMessage + //:> EnvelopeMessage> + |> Some + else None + module Service = let subscribe (subscribeHandler : SubscribeToBus) = let bufferList = ref empty diff --git a/src/Void.Core/BufferMessages.fs b/src/Void.Core/BufferMessages.fs new file mode 100644 index 0000000..3202a4a --- /dev/null +++ b/src/Void.Core/BufferMessages.fs @@ -0,0 +1,42 @@ +namespace Void.Core + +type BufferMessage = inherit Message + +type BufferEnvelopeMessage<'TBufferMessage when 'TBufferMessage :> BufferMessage> = + { + BufferId : int + Message : 'TBufferMessage + } + interface EnvelopeMessage<'TBufferMessage> + +type FileBufferProxy = { + MaybeFilepath : string option + Contents : string seq +} + +[] +type BufferCommand = + | MoveCursor of Motion + interface CommandMessage + interface BufferMessage + +[] +type BufferEvent = + | Added of FileBufferProxy + interface EventMessage + interface BufferMessage + +type GetBufferContentsRequest = + { + StartingAtLine : int + } + interface RequestMessage + interface BufferMessage + +type GetBufferContentsResponse = + { + FirstLineNumber : int + RequestedContents : string seq + } + interface ResponseMessage + interface BufferMessage diff --git a/src/Void.Core/CoreMessages.fs b/src/Void.Core/CoreMessages.fs index 323a743..9b16576 100644 --- a/src/Void.Core/CoreMessages.fs +++ b/src/Void.Core/CoreMessages.fs @@ -41,35 +41,6 @@ type CoreCommand = | Yank interface CommandMessage -[] -type BufferCommand = - | MoveCursor of Motion - interface CommandMessage - -type BufferCommandMessage = - { - BufferId : int - Command : BufferCommand - } - interface CommandMessage - -type FileBufferProxy = { - MaybeFilepath : string option - Contents : string seq -} - -[] -type BufferEvent = - | Added of FileBufferProxy - interface CommandMessage - -type BufferEventMessage = - { - BufferId : int - Event : BufferEvent - } - interface CommandMessage - [] module ``This module is auto-opened to provide message aliases`` = let notImplemented = diff --git a/src/Void.Core/Void.Core.fsproj b/src/Void.Core/Void.Core.fsproj index fafd189..d756f56 100644 --- a/src/Void.Core/Void.Core.fsproj +++ b/src/Void.Core/Void.Core.fsproj @@ -52,6 +52,7 @@ + diff --git a/src/Void.ViewModel/ViewModel.fs b/src/Void.ViewModel/ViewModel.fs index 693f117..6bbecaa 100644 --- a/src/Void.ViewModel/ViewModel.fs +++ b/src/Void.ViewModel/ViewModel.fs @@ -20,6 +20,7 @@ module ViewModel = Buffer = defaultBuffer Area = lessRowsBelow 1 containingArea Cursor = Visible <| CursorView.Block originCell + TopLineNumber = 1 } let defaultViewModel = diff --git a/src/Void.ViewModel/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index d4461f0..62605fe 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -17,6 +17,17 @@ type ViewModelService() = | _ -> noMessage + member x.handleVMCommand = + function + | VMCommand.Scroll movement -> + match movement with + | Move.Backward xLines -> + noMessage + | Move.Forward xLines -> + noMessage + | _ -> + noMessage + member x.handleCommandBarEvent event = let commandBarOrigin = ViewModel.upperLeftCellOfCommandBar _viewModel let renderCommandBar commandBar = @@ -39,7 +50,7 @@ type ViewModelService() = renderCommandBar commandBar member x.handleBufferEvent event = - match event.Event with + match event.Message with | BufferEvent.Added buffer -> _viewModel <- ViewModel.loadBuffer buffer _viewModel let drawings = Render.currentBufferAsDrawingObjects _viewModel @@ -60,4 +71,5 @@ type ViewModelService() = subscribeHandler.subscribe x.handleEvent subscribeHandler.subscribe x.handleBufferEvent subscribeHandler.subscribe x.handleCommand + subscribeHandler.subscribe x.handleVMCommand subscribeHandler.subscribe x.handleCommandBarEvent \ No newline at end of file diff --git a/src/Void.ViewModel/ViewModelTypes.fs b/src/Void.ViewModel/ViewModelTypes.fs index 46855ae..8d61899 100644 --- a/src/Void.ViewModel/ViewModelTypes.fs +++ b/src/Void.ViewModel/ViewModelTypes.fs @@ -25,6 +25,7 @@ type WindowView = { Area : CellGrid.Block Buffer : BufferView Cursor : CursorView Visibility + TopLineNumber : int } (* "Command line" is too equivocal. I mean the ; (or : in Vim) bar at the diff --git a/src/Void.ViewModel/WindowBufferMap.fs b/src/Void.ViewModel/WindowBufferMap.fs index 093b83f..a1221a9 100644 --- a/src/Void.ViewModel/WindowBufferMap.fs +++ b/src/Void.ViewModel/WindowBufferMap.fs @@ -46,37 +46,51 @@ module WindowBufferMap = |> setCurrentBuffer bufferId |> replaceCurrentWindow windowBufferMap } - (updated, VMEvent.BufferLoadedIntoWindow :> Message) + updated, VMEvent.BufferLoadedIntoWindow :> Message let handleVMCommand windowBufferMap command = match command with | VMCommand.Edit fileOrBufferId -> match fileOrBufferId with | FileOrBufferId.Path path -> - (windowBufferMap, Filesystem.Command.OpenFile path :> Message) + windowBufferMap, Filesystem.Command.OpenFile path :> Message | FileOrBufferId.CurrentBuffer -> - (windowBufferMap, noMessage) + windowBufferMap, noMessage | FileOrBufferId.AlternateBuffer -> - (windowBufferMap, noMessage) + windowBufferMap, noMessage | FileOrBufferId.BufferNumber bufferId -> - (windowBufferMap, noMessage) + windowBufferMap, noMessage | VMCommand.Write fileOrBufferId -> match fileOrBufferId with | FileOrBufferId.Path path -> let id = currentBufferId windowBufferMap in (windowBufferMap, CoreCommand.WriteBufferToPath (id, path) :> Message) | FileOrBufferId.CurrentBuffer -> - (windowBufferMap, noMessage) + windowBufferMap, noMessage | FileOrBufferId.AlternateBuffer -> - (windowBufferMap, noMessage) + windowBufferMap, noMessage | FileOrBufferId.BufferNumber bufferId -> - (windowBufferMap, noMessage) + windowBufferMap, noMessage + | _ -> + windowBufferMap, noMessage let handleBufferEvent windowBufferMap event = - match event.Event with + match event.Message with | BufferEvent.Added _ -> loadBufferIntoCurrentWindow windowBufferMap event.BufferId + type CurrentWindowEnvelopeMessage = + { + ForBufferInCurrentWindow : BufferMessage + } + interface EnvelopeMessage + + let handleCurrentWindowMessage windowBufferMap envelope = + { + BufferId = currentBufferId !windowBufferMap + Message = envelope.ForBufferInCurrentWindow + } :> Message + module Service = open Void.Core @@ -84,3 +98,4 @@ module WindowBufferMap = let windowBufferMap = ref empty subscribeHandler.subscribe <| Service.wrap windowBufferMap handleVMCommand subscribeHandler.subscribe <| Service.wrap windowBufferMap handleBufferEvent + subscribeHandler.subscribe (handleCurrentWindowMessage windowBufferMap) From 51c9f581ea86d83a5d8e59ae0639796a2fab6b55 Mon Sep 17 00:00:00 2001 From: Kazark Date: Wed, 29 Jul 2015 23:48:55 -0400 Subject: [PATCH 04/28] BROKEN though compiling - step towards fixing request/response --- src/Void.Core/BaseMessageTypes.fs | 13 +++-- src/Void.Core/CommandLanguage.fs | 2 +- src/Void.Core/CommandMode.fs | 4 +- src/Void/Init.fs | 3 +- src/Void/Messaging.fs | 88 ++++++++++++++++--------------- 5 files changed, 56 insertions(+), 54 deletions(-) diff --git a/src/Void.Core/BaseMessageTypes.fs b/src/Void.Core/BaseMessageTypes.fs index d365f1f..b4d8fdf 100644 --- a/src/Void.Core/BaseMessageTypes.fs +++ b/src/Void.Core/BaseMessageTypes.fs @@ -26,17 +26,16 @@ type NoResponseToRequest<'TRequest when 'TRequest :> RequestMessage> = type Handle<'TMsg when 'TMsg :> Message> = 'TMsg -> Message -type HandleRequest<'TRequest when 'TRequest :> RequestMessage> = - 'TRequest -> ResponseMessage<'TRequest> +type HandleRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = + 'TRequest -> 'TResponse -type MaybeHandleRequest<'TRequest when 'TRequest :> RequestMessage> = - 'TRequest -> ResponseMessage<'TRequest> option +type MaybeHandleRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = + 'TRequest -> 'TResponse option type HandleResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = 'TResponse -> Message type SubscribeToBus = abstract member subscribe<'TMsg when 'TMsg :> Message> : Handle<'TMsg> -> unit - abstract member subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> : HandleRequest<'TRequest> -> unit - abstract member subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> : MaybeHandleRequest<'TRequest> -> unit - abstract member subscribeToResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleResponse<'TRequest, 'TResponse> -> unit + abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleRequest<'TRequest, 'TResponse> -> unit + abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : MaybeHandleRequest<'TRequest, 'TResponse> -> unit diff --git a/src/Void.Core/CommandLanguage.fs b/src/Void.Core/CommandLanguage.fs index 824feec..e3f78ff 100644 --- a/src/Void.Core/CommandLanguage.fs +++ b/src/Void.Core/CommandLanguage.fs @@ -15,7 +15,7 @@ module CommandLanguage = let handleRequest language request = { CurrentCommandLanguage = !language - } :> ResponseMessage + } let handleCommand _ (ChangeCurrentCommandLanguageTo newLanguage) = newLanguage, CurrentCommandLanguageChangedTo newLanguage :> Message diff --git a/src/Void.Core/CommandMode.fs b/src/Void.Core/CommandMode.fs index 3e84e55..29bf2c5 100644 --- a/src/Void.Core/CommandMode.fs +++ b/src/Void.Core/CommandMode.fs @@ -82,7 +82,7 @@ module CommandMode = member x.subscribe (subscribeHandler : SubscribeToBus) = subscribeHandler.subscribe <| Service.wrap _buffer handleHistoryEvent - subscribeHandler.subscribeToResponse <| Service.wrap _buffer handleInterpretFragmentResponse - subscribeHandler.subscribeToResponse <| handleGetCurrentCommandLanguageResponse _buffer + //subscribeHandler.subscribeToResponse <| Service.wrap _buffer handleInterpretFragmentResponse + //subscribeHandler.subscribeToResponse <| handleGetCurrentCommandLanguageResponse _buffer subscribeHandler.subscribe <| Service.wrap _buffer handleNoResponseToInterpretFragmentRequest subscribeHandler.subscribe <| handleNoResponseToGetCurrentCommandLanguage _buffer diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 219fb25..1768432 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -39,8 +39,7 @@ module Init = let buildVoid inputModeChanger (options : VoidOptions) = let editorService = EditorService() let viewModelService = ViewModelService() - let coreCommandChannel = Channel [ editorService.handleCommand ] - let bus = Bus [ coreCommandChannel ] + let bus = Bus [ Channel [ editorService.handleCommand ] ] let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter let modeService = ModeService(NormalModeBindings.InputHandler(), diff --git a/src/Void/Messaging.fs b/src/Void/Messaging.fs index 92faaaf..ecd8a51 100644 --- a/src/Void/Messaging.fs +++ b/src/Void/Messaging.fs @@ -38,9 +38,15 @@ type Channel<'TIn when 'TIn :> Message> then Some <| box x.addHandler else None -type RequestChannel<'TRequest when 'TRequest :> RequestMessage> +type RequestChannel = + (* F# Why you no have type classes like Haskell!?!?! + * Now I will do ugly things, with long names! *) + abstract member getBoxedRequestFunctionIfResponseTypeIs<'TMsg> : unit -> obj option + abstract member getBoxedSubscribeActionIfResponseTypeIs<'TMsg> : unit -> obj option + +type RequestChannel<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> ( - handlers : MaybeHandleRequest<'TRequest> list + handlers : MaybeHandleRequest<'TRequest, 'TResponse> list ) = let mutable _handlers = handlers @@ -54,21 +60,17 @@ type RequestChannel<'TRequest when 'TRequest :> RequestMessage> member x.addHandler handler = _handlers <- x.safetyWrap handler :: _handlers - interface Channel with - member x.publish (message : Message) = - match message with - | :? 'TRequest as msg -> - let responses = - _handlers - |> Seq.choose (fun handle -> handle msg) - |> Seq.map (fun response -> response :> Message) - if Seq.isEmpty responses - then Seq.singleton { Request = msg } - else responses - | _ -> Seq.empty + member x.request requestMsg = + Seq.tryPick (fun handle -> handle requestMsg) handlers - member x.getBoxedSubscribeActionIfTypeIs<'TMsg>() = - if typeof<'TRequest> = typeof<'TMsg> + interface RequestChannel with + member x.getBoxedRequestFunctionIfResponseTypeIs<'TMsg>() = + if typeof<'TResponse> = typeof<'TMsg> + then Some <| box x.request + else None + + member x.getBoxedSubscribeActionIfResponseTypeIs<'TMsg>() = + if typeof<'TResponse> = typeof<'TMsg> then Some <| box x.addHandler else None @@ -76,11 +78,15 @@ type Bus ( channels : Channel list ) = + let mutable _requestChannels = [] let mutable _channels = channels member private x.addChannel channel = _channels <- channel :: _channels + member private x.addRequestChannel (requestChannel : RequestChannel) = + _requestChannels <- requestChannel :: _requestChannels + member x.publishAll messages = for message in messages do x.publish message @@ -91,42 +97,40 @@ type Bus for channel in _channels do channel.publish message |> x.publishAll + member x.request<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> requestMsg = + let tryGetRequestFunction (channel : RequestChannel) = + channel.getBoxedRequestFunctionIfResponseTypeIs<'TResponse>() + match List.tryPick tryGetRequestFunction _requestChannels with + | Some request -> + requestMsg + |> unbox> request + | None -> + None + member x.subscribe<'TMsg when 'TMsg :> Message> (handle : Handle<'TMsg>) = let tryGetSubscribeAction (channel : Channel) = channel.getBoxedSubscribeActionIfTypeIs<'TMsg>() - match List.choose tryGetSubscribeAction _channels with - | [subscribe] -> + match List.tryPick tryGetSubscribeAction _channels with + | Some subscribe -> handle |> unbox -> unit> subscribe - | _ -> + | None -> x.addChannel <| Channel [ handle ] - member x.subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> (handleRequest : MaybeHandleRequest<'TRequest>) = - let tryGetSubscribeAction (channel : Channel) = - channel.getBoxedSubscribeActionIfTypeIs<'TRequest>() - match List.choose tryGetSubscribeAction _channels with - | [subscribe] -> + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = + let tryGetSubscribeAction (channel : RequestChannel) = + channel.getBoxedSubscribeActionIfResponseTypeIs<'TResponse>() + match List.tryPick tryGetSubscribeAction _requestChannels with + | Some subscribe -> handleRequest - |> unbox -> unit> subscribe - | _ -> - x.addChannel <| RequestChannel [ handleRequest ] + |> unbox -> unit> subscribe + | None -> + x.addRequestChannel <| RequestChannel<'TRequest, 'TResponse> [ handleRequest ] - member x.subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> (handleRequest : HandleRequest<'TRequest>) = + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest (handleRequest >> Some) - member x.subscribeToResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleResponse : HandleResponse<'TRequest, 'TResponse>) = - let tryGetSubscribeAction (channel : Channel) = - channel.getBoxedSubscribeActionIfTypeIs<'TResponse>() - match List.choose tryGetSubscribeAction _channels with - | [subscribe] -> - handleResponse - |> unbox -> unit> subscribe - | _ -> - x.addChannel <| RequestChannel<'TRequest> [] - x.addChannel <| Channel [ handleResponse ] - interface SubscribeToBus with member x.subscribe handle = x.subscribe handle - member x.subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> (maybeHandleRequest : MaybeHandleRequest<'TRequest>) = x.subscribeToRequest maybeHandleRequest - member x.subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> (handleRequest : HandleRequest<'TRequest>) = x.subscribeToRequest handleRequest - member x.subscribeToResponse handleResponse = x.subscribeToResponse handleResponse + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest maybeHandleRequest + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest handleRequest From 4d32367ba6be238ad6bf0b51997e0f1433562685 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 30 Jul 2015 12:44:52 -0400 Subject: [PATCH 05/28] Turn on warning as error for all projects --- src/Void.Core.Spec/Void.Core.Spec.fsproj | 4 ++++ src/Void.Core/CommandHistory.fs | 2 -- src/Void.Core/Filesystem.fs | 1 - src/Void.Core/Void.Core.fsproj | 4 ++++ src/Void.Lang.Editor/Void.Lang.Editor.fsproj | 4 ++++ .../Void.Lang.Interpreter.Spec.fsproj | 4 ++++ src/Void.Lang.Interpreter/Void.Lang.Interpreter.fsproj | 6 +++++- src/Void.Lang.Parser.Spec/Void.Lang.Parser.Spec.fsproj | 6 +++++- src/Void.Lang.Parser/Void.Lang.Parser.fsproj | 6 +++++- src/Void.Spec/Void.Spec.fsproj | 6 +++++- src/Void.UI/Void.UI.csproj | 4 +++- src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj | 6 +++++- src/Void.ViewModel/Void.ViewModel.fsproj | 6 +++++- src/Void/Void.fsproj | 4 ++++ 14 files changed, 53 insertions(+), 10 deletions(-) diff --git a/src/Void.Core.Spec/Void.Core.Spec.fsproj b/src/Void.Core.Spec/Void.Core.Spec.fsproj index 7971a82..79319ce 100644 --- a/src/Void.Core.Spec/Void.Core.Spec.fsproj +++ b/src/Void.Core.Spec/Void.Core.Spec.fsproj @@ -24,6 +24,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Core.Spec.XML + true + pdbonly @@ -33,6 +35,8 @@ TRACE 3 bin\Release\Void.Core.Spec.XML + true + 11 diff --git a/src/Void.Core/CommandHistory.fs b/src/Void.Core/CommandHistory.fs index eb413b4..7a534ca 100644 --- a/src/Void.Core/CommandHistory.fs +++ b/src/Void.Core/CommandHistory.fs @@ -56,8 +56,6 @@ module CommandHistory = move previous history | CommandHistoryCommand.MoveToNextCommand -> move next history - | _ -> - (history, noMessage) module Service = let subscribe (subscribeHandler : SubscribeToBus) = diff --git a/src/Void.Core/Filesystem.fs b/src/Void.Core/Filesystem.fs index 7bc531c..216ae5c 100644 --- a/src/Void.Core/Filesystem.fs +++ b/src/Void.Core/Filesystem.fs @@ -59,7 +59,6 @@ module Filesystem = else CoreEvent.NewFileForEditing path :> Message | Command.SaveToDisk (path, lines) -> writeLines path lines :> Message - | _ -> noMessage module Service = let subscribe (subscribeHandler : SubscribeToBus) = diff --git a/src/Void.Core/Void.Core.fsproj b/src/Void.Core/Void.Core.fsproj index d756f56..feae1cf 100644 --- a/src/Void.Core/Void.Core.fsproj +++ b/src/Void.Core/Void.Core.fsproj @@ -22,6 +22,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Core.XML + true + pdbonly @@ -31,6 +33,8 @@ TRACE 3 bin\Release\Void.Core.XML + true + diff --git a/src/Void.Lang.Editor/Void.Lang.Editor.fsproj b/src/Void.Lang.Editor/Void.Lang.Editor.fsproj index e6fbae3..50bab08 100644 --- a/src/Void.Lang.Editor/Void.Lang.Editor.fsproj +++ b/src/Void.Lang.Editor/Void.Lang.Editor.fsproj @@ -22,6 +22,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Lang.Editor.XML + true + pdbonly @@ -31,6 +33,8 @@ TRACE 3 bin\Release\Void.Lang.Editor.XML + true + diff --git a/src/Void.Lang.Interpreter.Spec/Void.Lang.Interpreter.Spec.fsproj b/src/Void.Lang.Interpreter.Spec/Void.Lang.Interpreter.Spec.fsproj index e0f2c04..1796368 100644 --- a/src/Void.Lang.Interpreter.Spec/Void.Lang.Interpreter.Spec.fsproj +++ b/src/Void.Lang.Interpreter.Spec/Void.Lang.Interpreter.Spec.fsproj @@ -24,6 +24,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Lang.Interpreter.Spec.XML + true + pdbonly @@ -33,6 +35,8 @@ TRACE 3 bin\Release\Void.Lang.Interpreter.Spec.XML + true + 11 diff --git a/src/Void.Lang.Interpreter/Void.Lang.Interpreter.fsproj b/src/Void.Lang.Interpreter/Void.Lang.Interpreter.fsproj index 384c3ae..5931bc4 100644 --- a/src/Void.Lang.Interpreter/Void.Lang.Interpreter.fsproj +++ b/src/Void.Lang.Interpreter/Void.Lang.Interpreter.fsproj @@ -22,6 +22,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Lang.Interpreter.XML + true + pdbonly @@ -31,6 +33,8 @@ TRACE 3 bin\Release\Void.Lang.Interpreter.XML + true + @@ -76,4 +80,4 @@ --> - \ No newline at end of file + diff --git a/src/Void.Lang.Parser.Spec/Void.Lang.Parser.Spec.fsproj b/src/Void.Lang.Parser.Spec/Void.Lang.Parser.Spec.fsproj index e71d1d2..1fb1288 100644 --- a/src/Void.Lang.Parser.Spec/Void.Lang.Parser.Spec.fsproj +++ b/src/Void.Lang.Parser.Spec/Void.Lang.Parser.Spec.fsproj @@ -24,6 +24,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Lang.Parser.Spec.XML + true + pdbonly @@ -33,6 +35,8 @@ TRACE 3 bin\Release\Void.Lang.Parser.Spec.XML + true + 11 @@ -91,4 +95,4 @@ --> - \ No newline at end of file + diff --git a/src/Void.Lang.Parser/Void.Lang.Parser.fsproj b/src/Void.Lang.Parser/Void.Lang.Parser.fsproj index 04223d2..19130d1 100644 --- a/src/Void.Lang.Parser/Void.Lang.Parser.fsproj +++ b/src/Void.Lang.Parser/Void.Lang.Parser.fsproj @@ -22,6 +22,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Lang.Parser.XML + true + pdbonly @@ -31,6 +33,8 @@ TRACE 3 bin\Release\Void.Lang.Parser.XML + true + @@ -68,4 +72,4 @@ --> - \ No newline at end of file + diff --git a/src/Void.Spec/Void.Spec.fsproj b/src/Void.Spec/Void.Spec.fsproj index 4b9ac10..9a3549f 100644 --- a/src/Void.Spec/Void.Spec.fsproj +++ b/src/Void.Spec/Void.Spec.fsproj @@ -24,6 +24,8 @@ DEBUG;TRACE 3 bin\Debug\Void.Spec.XML + true + pdbonly @@ -33,6 +35,8 @@ TRACE 3 bin\Release\Void.Spec.XML + true + 11 @@ -118,4 +122,4 @@ --> - \ No newline at end of file + diff --git a/src/Void.UI/Void.UI.csproj b/src/Void.UI/Void.UI.csproj index d581de3..8b39103 100644 --- a/src/Void.UI/Void.UI.csproj +++ b/src/Void.UI/Void.UI.csproj @@ -21,6 +21,7 @@ DEBUG;TRACE prompt 4 + true AnyCPU @@ -30,6 +31,7 @@ TRACE prompt 4 + true @@ -104,4 +106,4 @@ --> - \ No newline at end of file + diff --git a/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj b/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj index b608a8f..f33a4db 100644 --- a/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj +++ b/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj @@ -24,6 +24,8 @@ DEBUG;TRACE 3 bin\Debug\Void.ViewModel.Spec.XML + true + pdbonly @@ -33,6 +35,8 @@ TRACE 3 bin\Release\Void.ViewModel.Spec.XML + true + 11 @@ -99,4 +103,4 @@ --> - \ No newline at end of file + diff --git a/src/Void.ViewModel/Void.ViewModel.fsproj b/src/Void.ViewModel/Void.ViewModel.fsproj index 5a1be0b..381a3e4 100644 --- a/src/Void.ViewModel/Void.ViewModel.fsproj +++ b/src/Void.ViewModel/Void.ViewModel.fsproj @@ -22,6 +22,8 @@ DEBUG;TRACE 3 bin\Debug\Void.ViewModel.XML + true + pdbonly @@ -31,6 +33,8 @@ TRACE 3 bin\Release\Void.ViewModel.XML + true + @@ -84,4 +88,4 @@ --> - \ No newline at end of file + diff --git a/src/Void/Void.fsproj b/src/Void/Void.fsproj index 3a7714d..1b4b0f7 100644 --- a/src/Void/Void.fsproj +++ b/src/Void/Void.fsproj @@ -22,6 +22,8 @@ DEBUG;TRACE 3 bin\Debug\Void.XML + true + pdbonly @@ -31,6 +33,8 @@ TRACE 3 bin\Release\Void.XML + true + From 14632f9bd3907a17daae103013df281b51bd53d5 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 30 Jul 2015 12:53:58 -0400 Subject: [PATCH 06/28] Rename Bus -> BusImpl; SubscribeToBus -> Bus --- src/Void.Core/BaseMessageTypes.fs | 2 +- src/Void.Core/BufferList.fs | 6 +++--- src/Void.Core/CommandHistory.fs | 8 ++++---- src/Void.Core/CommandLanguage.fs | 8 ++++---- src/Void.Core/CommandMode.fs | 12 ++++++------ src/Void.Core/Filesystem.fs | 4 ++-- src/Void.Core/ModeService.fs | 12 ++++++------ src/Void.Core/Notifications.fs | 6 +++--- src/Void.UI/MainForm.cs | 4 ++-- src/Void.UI/Program.cs | 2 +- src/Void.ViewModel/CommandBar.fs | 6 +++--- src/Void.ViewModel/NotifyUserOfEvent.fs | 4 ++-- src/Void.ViewModel/ViewModelService.fs | 12 ++++++------ src/Void.ViewModel/WindowBufferMap.fs | 8 ++++---- src/Void/DefaultNormalModeBindings.fs | 4 ++-- src/Void/Init.fs | 4 ++-- src/Void/InterpreterWrapperService.fs | 4 ++-- src/Void/MessageLog.fs | 4 ++-- src/Void/Messaging.fs | 4 ++-- 19 files changed, 57 insertions(+), 57 deletions(-) diff --git a/src/Void.Core/BaseMessageTypes.fs b/src/Void.Core/BaseMessageTypes.fs index b4d8fdf..dd483f7 100644 --- a/src/Void.Core/BaseMessageTypes.fs +++ b/src/Void.Core/BaseMessageTypes.fs @@ -35,7 +35,7 @@ type MaybeHandleRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage a type HandleResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = 'TResponse -> Message -type SubscribeToBus = +type Bus = abstract member subscribe<'TMsg when 'TMsg :> Message> : Handle<'TMsg> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleRequest<'TRequest, 'TResponse> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : MaybeHandleRequest<'TRequest, 'TResponse> -> unit diff --git a/src/Void.Core/BufferList.fs b/src/Void.Core/BufferList.fs index 844f14f..77741ba 100644 --- a/src/Void.Core/BufferList.fs +++ b/src/Void.Core/BufferList.fs @@ -110,7 +110,7 @@ module BufferList = else None module Service = - let subscribe (subscribeHandler : SubscribeToBus) = + let subscribe (bus : Bus) = let bufferList = ref empty - subscribeHandler.subscribe <| Service.wrap bufferList handleCommand - subscribeHandler.subscribe <| Service.wrap bufferList handleEvent + bus.subscribe <| Service.wrap bufferList handleCommand + bus.subscribe <| Service.wrap bufferList handleEvent diff --git a/src/Void.Core/CommandHistory.fs b/src/Void.Core/CommandHistory.fs index 7a534ca..bc984c7 100644 --- a/src/Void.Core/CommandHistory.fs +++ b/src/Void.Core/CommandHistory.fs @@ -58,8 +58,8 @@ module CommandHistory = move next history module Service = - let subscribe (subscribeHandler : SubscribeToBus) = + let subscribe (bus : Bus) = let history = ref empty - subscribeHandler.subscribe <| Service.wrap history handleEvent - subscribeHandler.subscribe <| Service.wrap history handleCommand - subscribeHandler.subscribe <| Service.wrap history handleCoreEvent \ No newline at end of file + bus.subscribe <| Service.wrap history handleEvent + bus.subscribe <| Service.wrap history handleCommand + bus.subscribe <| Service.wrap history handleCoreEvent \ No newline at end of file diff --git a/src/Void.Core/CommandLanguage.fs b/src/Void.Core/CommandLanguage.fs index e3f78ff..19ae74e 100644 --- a/src/Void.Core/CommandLanguage.fs +++ b/src/Void.Core/CommandLanguage.fs @@ -24,8 +24,8 @@ module CommandLanguage = voidScript, CurrentCommandLanguageChangedTo voidScript :> Message module Service = - let subscribe (subscribeHandler : SubscribeToBus) = + let subscribe (bus : Bus) = let language = ref voidScript - subscribeHandler.subscribeToRequest (handleRequest language) - subscribeHandler.subscribe <| Service.wrap language handleCommand - subscribeHandler.subscribe <| Service.wrap language handleNoResponseToInterpretFragmentRequest \ No newline at end of file + bus.subscribeToRequest (handleRequest language) + bus.subscribe <| Service.wrap language handleCommand + bus.subscribe <| Service.wrap language handleNoResponseToInterpretFragmentRequest \ No newline at end of file diff --git a/src/Void.Core/CommandMode.fs b/src/Void.Core/CommandMode.fs index 29bf2c5..f12409e 100644 --- a/src/Void.Core/CommandMode.fs +++ b/src/Void.Core/CommandMode.fs @@ -80,9 +80,9 @@ module CommandMode = _buffer := updatedBuffer message - member x.subscribe (subscribeHandler : SubscribeToBus) = - subscribeHandler.subscribe <| Service.wrap _buffer handleHistoryEvent - //subscribeHandler.subscribeToResponse <| Service.wrap _buffer handleInterpretFragmentResponse - //subscribeHandler.subscribeToResponse <| handleGetCurrentCommandLanguageResponse _buffer - subscribeHandler.subscribe <| Service.wrap _buffer handleNoResponseToInterpretFragmentRequest - subscribeHandler.subscribe <| handleNoResponseToGetCurrentCommandLanguage _buffer + member x.subscribe (bus : Bus) = + bus.subscribe <| Service.wrap _buffer handleHistoryEvent + //bus.subscribeToResponse <| Service.wrap _buffer handleInterpretFragmentResponse + //bus.subscribeToResponse <| handleGetCurrentCommandLanguageResponse _buffer + bus.subscribe <| Service.wrap _buffer handleNoResponseToInterpretFragmentRequest + bus.subscribe <| handleNoResponseToGetCurrentCommandLanguage _buffer diff --git a/src/Void.Core/Filesystem.fs b/src/Void.Core/Filesystem.fs index 216ae5c..41faa7f 100644 --- a/src/Void.Core/Filesystem.fs +++ b/src/Void.Core/Filesystem.fs @@ -61,5 +61,5 @@ module Filesystem = writeLines path lines :> Message module Service = - let subscribe (subscribeHandler : SubscribeToBus) = - subscribeHandler.subscribe handleCommand + let subscribe (bus : Bus) = + bus.subscribe handleCommand diff --git a/src/Void.Core/ModeService.fs b/src/Void.Core/ModeService.fs index f88073d..1d78996 100644 --- a/src/Void.Core/ModeService.fs +++ b/src/Void.Core/ModeService.fs @@ -69,9 +69,9 @@ type ModeService CoreEvent.ModeChanged change :> Message | _ -> noMessage - member x.subscribe (subscribeHandler : SubscribeToBus) = - subscribeHandler.subscribe x.handleCommandModeEvent - subscribeHandler.subscribe x.handleEvent - subscribeHandler.subscribe x.handleCommand - commandModeInputHandler.subscribe subscribeHandler - subscribeHandler.subscribe normalModeInputHandler.handleCommand + member x.subscribe (bus : Bus) = + bus.subscribe x.handleCommandModeEvent + bus.subscribe x.handleEvent + bus.subscribe x.handleCommand + commandModeInputHandler.subscribe bus + bus.subscribe normalModeInputHandler.handleCommand diff --git a/src/Void.Core/Notifications.fs b/src/Void.Core/Notifications.fs index 1586048..2a9dee0 100644 --- a/src/Void.Core/Notifications.fs +++ b/src/Void.Core/Notifications.fs @@ -31,8 +31,8 @@ module Notifications = | _ -> (notifications, noMessage) module Service = - let subscribe (subscribeHandler : SubscribeToBus) = + let subscribe (bus : Bus) = let notifications = ref [] - subscribeHandler.subscribe <| Service.wrap notifications handleEvent - subscribeHandler.subscribe <| Service.wrap notifications handleCommand + bus.subscribe <| Service.wrap notifications handleEvent + bus.subscribe <| Service.wrap notifications handleCommand \ No newline at end of file diff --git a/src/Void.UI/MainForm.cs b/src/Void.UI/MainForm.cs index f3588e0..602a322 100644 --- a/src/Void.UI/MainForm.cs +++ b/src/Void.UI/MainForm.cs @@ -11,14 +11,14 @@ namespace Void.UI { public partial class MainForm : Form { - private readonly Bus _bus; + private readonly BusImpl _bus; private readonly WinFormsInputModeChanger _inputModeChanger; private Font _font = new Font(FontFamily.GenericMonospace, 9); private CellMetrics _cellMetrics; private IEnumerable _drawings; - public MainForm(Bus bus, WinFormsInputModeChanger inputModeChanger) + public MainForm(BusImpl bus, WinFormsInputModeChanger inputModeChanger) { _bus = bus; _inputModeChanger = inputModeChanger; diff --git a/src/Void.UI/Program.cs b/src/Void.UI/Program.cs index 8ed7f89..0d021b5 100644 --- a/src/Void.UI/Program.cs +++ b/src/Void.UI/Program.cs @@ -15,7 +15,7 @@ static void Main(string[] args) Application.EnableVisualStyles(); Application.SetCompatibleTextRenderingDefault(false); var inputModeChanger = new WinFormsInputModeChanger(); - Bus bus = Init.buildVoid(inputModeChanger, Options.parse(args)); + var bus = Init.buildVoid(inputModeChanger, Options.parse(args)); var view = new MainForm(bus, inputModeChanger); bus.subscribe(FSharpFuncUtil.Create(view.HandleEvent)); bus.subscribe(FSharpFuncUtil.Create(view.HandleViewModelEvent)); diff --git a/src/Void.ViewModel/CommandBar.fs b/src/Void.ViewModel/CommandBar.fs index eeff9b1..e49c496 100644 --- a/src/Void.ViewModel/CommandBar.fs +++ b/src/Void.ViewModel/CommandBar.fs @@ -92,7 +92,7 @@ module CommandBar = module Service = open Void.Core - let subscribe (subscribeHandler : SubscribeToBus) = + let subscribe (bus : Bus) = let commandBar = ref hidden - subscribeHandler.subscribe <| Service.wrap commandBar handleEvent - subscribeHandler.subscribe <| Service.wrap commandBar handleCommandModeEvent + bus.subscribe <| Service.wrap commandBar handleEvent + bus.subscribe <| Service.wrap commandBar handleCommandModeEvent diff --git a/src/Void.ViewModel/NotifyUserOfEvent.fs b/src/Void.ViewModel/NotifyUserOfEvent.fs index 829224d..8ba21b4 100644 --- a/src/Void.ViewModel/NotifyUserOfEvent.fs +++ b/src/Void.ViewModel/NotifyUserOfEvent.fs @@ -22,5 +22,5 @@ module NotifyUserOfEvent = | _ -> noMessage module Service = - let subscribe (subscribeHandler : SubscribeToBus) = - subscribeHandler.subscribe handleEvent + let subscribe (bus : Bus) = + bus.subscribe handleEvent diff --git a/src/Void.ViewModel/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index 62605fe..2ed734f 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -67,9 +67,9 @@ type ViewModelService() = VMEvent.ViewPortionRendered(areaInPoints, [drawing]) :> Message | _ -> noMessage - member x.subscribe (subscribeHandler : SubscribeToBus) = - subscribeHandler.subscribe x.handleEvent - subscribeHandler.subscribe x.handleBufferEvent - subscribeHandler.subscribe x.handleCommand - subscribeHandler.subscribe x.handleVMCommand - subscribeHandler.subscribe x.handleCommandBarEvent \ No newline at end of file + member x.subscribe (bus : Bus) = + bus.subscribe x.handleEvent + bus.subscribe x.handleBufferEvent + bus.subscribe x.handleCommand + bus.subscribe x.handleVMCommand + bus.subscribe x.handleCommandBarEvent \ No newline at end of file diff --git a/src/Void.ViewModel/WindowBufferMap.fs b/src/Void.ViewModel/WindowBufferMap.fs index a1221a9..ff06281 100644 --- a/src/Void.ViewModel/WindowBufferMap.fs +++ b/src/Void.ViewModel/WindowBufferMap.fs @@ -94,8 +94,8 @@ module WindowBufferMap = module Service = open Void.Core - let subscribe (subscribeHandler : SubscribeToBus) = + let subscribe (bus : Bus) = let windowBufferMap = ref empty - subscribeHandler.subscribe <| Service.wrap windowBufferMap handleVMCommand - subscribeHandler.subscribe <| Service.wrap windowBufferMap handleBufferEvent - subscribeHandler.subscribe (handleCurrentWindowMessage windowBufferMap) + bus.subscribe <| Service.wrap windowBufferMap handleVMCommand + bus.subscribe <| Service.wrap windowBufferMap handleBufferEvent + bus.subscribe (handleCurrentWindowMessage windowBufferMap) diff --git a/src/Void/DefaultNormalModeBindings.fs b/src/Void/DefaultNormalModeBindings.fs index 4716056..abc5832 100644 --- a/src/Void/DefaultNormalModeBindings.fs +++ b/src/Void/DefaultNormalModeBindings.fs @@ -45,7 +45,7 @@ module DefaultNormalModeBindings = let bindAllCommands bindings = Seq.map NormalModeBindings.Command.Bind bindings - let handleCommand (bus : Bus) command = + let handleCommand (bus : BusImpl) command = match command with | CoreCommand.InitializeVoid -> bindAllCommands voidBindings @@ -55,5 +55,5 @@ module DefaultNormalModeBindings = module Service = - let subscribe (bus : Bus) = + let subscribe (bus : BusImpl) = bus.subscribe (handleCommand bus) diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 1768432..bf1b2e7 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -39,7 +39,7 @@ module Init = let buildVoid inputModeChanger (options : VoidOptions) = let editorService = EditorService() let viewModelService = ViewModelService() - let bus = Bus [ Channel [ editorService.handleCommand ] ] + let bus = BusImpl [ Channel [ editorService.handleCommand ] ] let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter let modeService = ModeService(NormalModeBindings.InputHandler(), @@ -62,5 +62,5 @@ module Init = NotifyUserOfEvent.Service.subscribe bus bus - let launchVoid (bus : Bus) = + let launchVoid (bus : BusImpl) = bus.publish CoreCommand.InitializeVoid diff --git a/src/Void/InterpreterWrapperService.fs b/src/Void/InterpreterWrapperService.fs index dc2229a..cd64aab 100644 --- a/src/Void/InterpreterWrapperService.fs +++ b/src/Void/InterpreterWrapperService.fs @@ -20,5 +20,5 @@ type InterpreterWrapperService(interpreter : VoidScriptInterpreter) = |> Some | _ -> None - member x.subscribe (subscribeToBus : SubscribeToBus) = - subscribeToBus.subscribeToRequest x.handleInterpretFragmentRequest + member x.subscribe (bus : Bus) = + bus.subscribeToRequest x.handleInterpretFragmentRequest diff --git a/src/Void/MessageLog.fs b/src/Void/MessageLog.fs index 37c047c..c6e6b8e 100644 --- a/src/Void/MessageLog.fs +++ b/src/Void/MessageLog.fs @@ -8,5 +8,5 @@ module MessageLog = noMessage module Service = - let subscribe (subscribeHandler : SubscribeToBus) = - subscribeHandler.subscribe handleMessage \ No newline at end of file + let subscribe (bus : Bus) = + bus.subscribe handleMessage \ No newline at end of file diff --git a/src/Void/Messaging.fs b/src/Void/Messaging.fs index ecd8a51..371bde4 100644 --- a/src/Void/Messaging.fs +++ b/src/Void/Messaging.fs @@ -74,7 +74,7 @@ type RequestChannel<'TRequest, 'TResponse when 'TRequest :> RequestMessage and ' then Some <| box x.addHandler else None -type Bus +type BusImpl ( channels : Channel list ) = @@ -130,7 +130,7 @@ type Bus member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest (handleRequest >> Some) - interface SubscribeToBus with + interface Bus with member x.subscribe handle = x.subscribe handle member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest maybeHandleRequest member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest handleRequest From f39063e0e41a379b5f47004cff512d93d9693bd9 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 30 Jul 2015 13:31:25 -0400 Subject: [PATCH 07/28] NOT COMPILING - wire in new request/response API Still need to update the unit tests --- src/Void.Core.Spec/CommandModeSpec.fs | 16 ++++-- src/Void.Core/BaseMessageTypes.fs | 10 ++-- src/Void.Core/CommandLanguage.fs | 9 ++-- src/Void.Core/CommandMode.fs | 69 +++++++++++++------------- src/Void.Core/UserNotificationTypes.fs | 4 +- src/Void/Init.fs | 2 +- src/Void/Messaging.fs | 13 ++--- 7 files changed, 66 insertions(+), 57 deletions(-) diff --git a/src/Void.Core.Spec/CommandModeSpec.fs b/src/Void.Core.Spec/CommandModeSpec.fs index 02e6815..407fe23 100644 --- a/src/Void.Core.Spec/CommandModeSpec.fs +++ b/src/Void.Core.Spec/CommandModeSpec.fs @@ -4,6 +4,11 @@ open Void.Core open NUnit.Framework open FsUnit +type RequestSenderStub() = + interface RequestSender with + member x.makeRequest _ = + None + [] type ``Editing command mode``() = let success = InterpretScriptFragmentResponse.Completed @@ -13,10 +18,11 @@ type ``Editing command mode``() = let enter = TextOrHotKey.HotKey HotKey.Enter let escape = TextOrHotKey.HotKey HotKey.Escape let backspace = TextOrHotKey.HotKey HotKey.Backspace + let requestSenderStub = RequestSenderStub() let typeIncrement increment buffer expected = TextOrHotKey.Text increment - |> CommandMode.handle buffer + |> CommandMode.handle requestSenderStub buffer |> should equal (expected, CommandMode.Event.TextAppended increment :> Message) [] @@ -28,7 +34,7 @@ type ``Editing command mode``() = [] member x.``When enter is pressed, the current language for command mode is requested``() = - CommandMode.handle "edit" enter + CommandMode.handle requestSenderStub "edit" enter |> should equal ("edit", GetCurrentCommandLanguageRequest :> Message) [] @@ -45,17 +51,17 @@ type ``Editing command mode``() = [] member x.``When escape is pressed, command entry is cancelled``() = - CommandMode.handle "edit" escape + CommandMode.handle requestSenderStub "edit" escape |> should equal ("", CommandMode.Event.EntryCancelled :> Message) [] member x.``When backspace is pressed, the previous character is remove from the buffer``() = - CommandMode.handle "edig" backspace + CommandMode.handle requestSenderStub "edig" backspace |> should equal ("edi", CommandMode.Event.CharacterBackspaced :> Message) [] member x.``When backspace is pressed and there are no characters but the prompt, command entry is cancelled``() = - CommandMode.handle "" backspace + CommandMode.handle requestSenderStub "" backspace |> should equal ("", CommandMode.Event.EntryCancelled :> Message) [] diff --git a/src/Void.Core/BaseMessageTypes.fs b/src/Void.Core/BaseMessageTypes.fs index dd483f7..d729da0 100644 --- a/src/Void.Core/BaseMessageTypes.fs +++ b/src/Void.Core/BaseMessageTypes.fs @@ -17,12 +17,6 @@ module ``This module is auto-opened to provide a null message`` = interface Message let noMessage = NoMessage :> Message -type NoResponseToRequest<'TRequest when 'TRequest :> RequestMessage> = - { - Request : 'TRequest - } - interface Message - type Handle<'TMsg when 'TMsg :> Message> = 'TMsg -> Message @@ -35,7 +29,11 @@ type MaybeHandleRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage a type HandleResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = 'TResponse -> Message +type RequestSender = + abstract member makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : 'TRequest -> 'TResponse option + type Bus = abstract member subscribe<'TMsg when 'TMsg :> Message> : Handle<'TMsg> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleRequest<'TRequest, 'TResponse> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : MaybeHandleRequest<'TRequest, 'TResponse> -> unit + inherit RequestSender diff --git a/src/Void.Core/CommandLanguage.fs b/src/Void.Core/CommandLanguage.fs index 19ae74e..0de4cc6 100644 --- a/src/Void.Core/CommandLanguage.fs +++ b/src/Void.Core/CommandLanguage.fs @@ -20,12 +20,15 @@ module CommandLanguage = let handleCommand _ (ChangeCurrentCommandLanguageTo newLanguage) = newLanguage, CurrentCommandLanguageChangedTo newLanguage :> Message - let handleNoResponseToInterpretFragmentRequest _ (msg : NoResponseToRequest) = - voidScript, CurrentCommandLanguageChangedTo voidScript :> Message + let handleCoreEvent language event = + match event with + | CoreEvent.ErrorOccurred Error.NoInterpreter -> + voidScript, CurrentCommandLanguageChangedTo voidScript :> Message + | _ -> language, noMessage module Service = let subscribe (bus : Bus) = let language = ref voidScript bus.subscribeToRequest (handleRequest language) bus.subscribe <| Service.wrap language handleCommand - bus.subscribe <| Service.wrap language handleNoResponseToInterpretFragmentRequest \ No newline at end of file + bus.subscribe <| Service.wrap language handleCoreEvent \ No newline at end of file diff --git a/src/Void.Core/CommandMode.fs b/src/Void.Core/CommandMode.fs index f12409e..c464e60 100644 --- a/src/Void.Core/CommandMode.fs +++ b/src/Void.Core/CommandMode.fs @@ -15,23 +15,40 @@ module CommandMode = let private requestLanguageForInterpreting buffer = buffer, GetCurrentCommandLanguageRequest :> Message - let handleGetCurrentCommandLanguageResponse buffer response = + let interpretFragment buffer maybeResponse = { - Language = response.CurrentCommandLanguage - Fragment = !buffer - } :> Message + Language = + match maybeResponse with + | Some response -> response.CurrentCommandLanguage + | None -> "VoidScript" + Fragment = buffer + } - let handleNoResponseToGetCurrentCommandLanguage buffer (msg : NoResponseToRequest) = - { - Language = "VoidScript" - Fragment = !buffer - } :> Message + let handleInterpretFragmentResponse buffer maybeResponse = + match maybeResponse with + | Some response -> + match response with + | InterpretScriptFragmentResponse.Completed -> + "", Event.CommandCompleted buffer :> Message + | InterpretScriptFragmentResponse.ParseFailed error -> + "", CoreEvent.ErrorOccurred error :> Message + | InterpretScriptFragmentResponse.ParseIncomplete -> + buffer + System.Environment.NewLine, noMessage + | None -> + "", CoreEvent.ErrorOccurred <| Error.NoInterpreter :> Message + + let interpret (requestSender : RequestSender) buffer = + GetCurrentCommandLanguageRequest + |> requestSender.makeRequest + |> interpretFragment buffer + |> requestSender.makeRequest + |> handleInterpretFragmentResponse buffer - let private handleHotKey buffer hotKey = + let private handleHotKey requestSender buffer hotKey = let cancelled = ("", Event.EntryCancelled :> Message) match hotKey with | HotKey.Enter -> - requestLanguageForInterpreting buffer + interpret requestSender buffer | HotKey.Escape -> cancelled | HotKey.Backspace -> @@ -44,45 +61,29 @@ module CommandMode = buffer, CommandHistoryCommand.MoveToNextCommand :> Message | _ -> (buffer, noMessage) - let handle buffer input = + let handle requestSender buffer input = match input with | TextOrHotKey.Text text -> buffer + text, Event.TextAppended text :> Message | TextOrHotKey.HotKey hotKey -> - handleHotKey buffer hotKey + handleHotKey requestSender buffer hotKey let handleHistoryEvent buffer event = match event with | CommandHistoryEvent.MovedToCommand command -> - (command, Event.TextReplaced command :> Message) + command, Event.TextReplaced command :> Message | CommandHistoryEvent.MovedToEmptyCommand -> - ("", Event.TextReplaced "" :> Message) + "", Event.TextReplaced "" :> Message | _ -> - (buffer, noMessage) - - let handleInterpretFragmentResponse buffer response = - match response with - | InterpretScriptFragmentResponse.Completed -> - ("", Event.CommandCompleted buffer :> Message) - | InterpretScriptFragmentResponse.ParseFailed error -> - ("", CoreEvent.ErrorOccurred error :> Message) - | InterpretScriptFragmentResponse.ParseIncomplete -> - (buffer + System.Environment.NewLine, noMessage) - - let handleNoResponseToInterpretFragmentRequest _ (msg : NoResponseToRequest) = - "", CoreEvent.ErrorOccurred <| Error.UnableToInterpretLanguage msg.Request.Language :> Message + buffer, noMessage - type InputHandler() = + type InputHandler(requestSender : RequestSender) = let _buffer = ref "" member x.handleTextOrHotKey input = - let updatedBuffer, message = handle !_buffer input + let updatedBuffer, message = handle requestSender !_buffer input _buffer := updatedBuffer message member x.subscribe (bus : Bus) = bus.subscribe <| Service.wrap _buffer handleHistoryEvent - //bus.subscribeToResponse <| Service.wrap _buffer handleInterpretFragmentResponse - //bus.subscribeToResponse <| handleGetCurrentCommandLanguageResponse _buffer - bus.subscribe <| Service.wrap _buffer handleNoResponseToInterpretFragmentRequest - bus.subscribe <| handleNoResponseToGetCurrentCommandLanguage _buffer diff --git a/src/Void.Core/UserNotificationTypes.fs b/src/Void.Core/UserNotificationTypes.fs index e81f8d4..4ff5c96 100644 --- a/src/Void.Core/UserNotificationTypes.fs +++ b/src/Void.Core/UserNotificationTypes.fs @@ -3,17 +3,17 @@ [] type Error = | AccessToPathNotAuthorized of string + | NoInterpreter | NotImplemented | ScriptFragmentParseFailed of string * string - | UnableToInterpretLanguage of string module Errors = let textOf = function | Error.AccessToPathNotAuthorized path -> sprintf "Access to path not authorized: \"%s\"" path + | Error.NoInterpreter -> "No interpreter responded to the request to interpret the command" | Error.NotImplemented -> "That command is not yet implemented" | Error.ScriptFragmentParseFailed (msg, _) -> msg - | Error.UnableToInterpretLanguage language -> sprintf "No interpreter was found for %s code" language [] // In Vim this is called a message, e.g. :messages or :echomsg. diff --git a/src/Void/Init.fs b/src/Void/Init.fs index bf1b2e7..c58a5cc 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -43,7 +43,7 @@ module Init = let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter let modeService = ModeService(NormalModeBindings.InputHandler(), - CommandMode.InputHandler(), + CommandMode.InputHandler(bus), VisualModeInputHandler(), InsertModeInputHandler(), setInputMode inputModeChanger bus.publish) diff --git a/src/Void/Messaging.fs b/src/Void/Messaging.fs index 371bde4..f6bdad0 100644 --- a/src/Void/Messaging.fs +++ b/src/Void/Messaging.fs @@ -60,13 +60,13 @@ type RequestChannel<'TRequest, 'TResponse when 'TRequest :> RequestMessage and ' member x.addHandler handler = _handlers <- x.safetyWrap handler :: _handlers - member x.request requestMsg = + member x.makeRequest requestMsg = Seq.tryPick (fun handle -> handle requestMsg) handlers interface RequestChannel with member x.getBoxedRequestFunctionIfResponseTypeIs<'TMsg>() = if typeof<'TResponse> = typeof<'TMsg> - then Some <| box x.request + then Some <| box x.makeRequest else None member x.getBoxedSubscribeActionIfResponseTypeIs<'TMsg>() = @@ -97,13 +97,13 @@ type BusImpl for channel in _channels do channel.publish message |> x.publishAll - member x.request<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> requestMsg = + member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> request = let tryGetRequestFunction (channel : RequestChannel) = channel.getBoxedRequestFunctionIfResponseTypeIs<'TResponse>() match List.tryPick tryGetRequestFunction _requestChannels with - | Some request -> - requestMsg - |> unbox> request + | Some makeRequest -> + request + |> unbox> makeRequest | None -> None @@ -131,6 +131,7 @@ type BusImpl x.subscribeToRequest (handleRequest >> Some) interface Bus with + member x.makeRequest request = x.makeRequest request member x.subscribe handle = x.subscribe handle member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest maybeHandleRequest member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest handleRequest From 7d6dd5a25a9673635dc705752d3117a62fb4d3a6 Mon Sep 17 00:00:00 2001 From: Kazark Date: Mon, 3 Aug 2015 10:33:20 -0400 Subject: [PATCH 08/28] STILL RED - fix compile errors and most unit tests --- src/Void.Core.Spec/CommandModeSpec.fs | 82 ++++++++++++++++++--------- src/Void.Core/CommandMode.fs | 9 +-- src/Void.ViewModel/CommandBar.fs | 7 ++- 3 files changed, 65 insertions(+), 33 deletions(-) diff --git a/src/Void.Core.Spec/CommandModeSpec.fs b/src/Void.Core.Spec/CommandModeSpec.fs index 407fe23..6041d02 100644 --- a/src/Void.Core.Spec/CommandModeSpec.fs +++ b/src/Void.Core.Spec/CommandModeSpec.fs @@ -5,9 +5,33 @@ open NUnit.Framework open FsUnit type RequestSenderStub() = + let mutable _requests = [] + let mutable _responses = [] + + member x.registerResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (response : 'TResponse) = + _responses <- box response :: _responses + + member x.tryPickRequest<'TRequest when 'TRequest :> RequestMessage>() = + let tryUnbox request = + try + unbox<'TRequest> request |> Some + with _ -> + None + _requests |> List.tryPick tryUnbox + + member x.reset() = + _requests <- [] + _responses <- [] + interface RequestSender with - member x.makeRequest _ = - None + member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (request : 'TRequest) = + let tryUnbox response = + try + unbox<'TResponse> response |> Some + with _ -> + None + _requests <- box request :: _requests + _responses |> List.tryPick tryUnbox [] type ``Editing command mode``() = @@ -25,6 +49,10 @@ type ``Editing command mode``() = |> CommandMode.handle requestSenderStub buffer |> should equal (expected, CommandMode.Event.TextAppended increment :> Message) + [] + member x.``Set up``() = + requestSenderStub.reset() + [] member x.``Text can be incrementally typed in``() = typeIncrement "e" "" "e" @@ -33,21 +61,35 @@ type ``Editing command mode``() = typeIncrement "t" "edi" "edit" [] - member x.``When enter is pressed, the current language for command mode is requested``() = + member x.``When enter is pressed, and the current language response comes back, then the fragment interpretation request is sent for that language``() = + requestSenderStub.registerResponse { CurrentCommandLanguage = "python3" } + CommandMode.handle requestSenderStub "edit" enter |> ignore + requestSenderStub.tryPickRequest() + |> should equal (Some { Language = "python3"; Fragment = "edit"}) + + [] + member x.``When enter is pressed, and no response comes back for the current language, then the fragment interpretation request is sent with the default language``() = + CommandMode.handle requestSenderStub "edit" enter |> ignore + requestSenderStub.tryPickRequest() + |> should equal (Some { Language = "VoidScript"; Fragment = "edit"}) + + [] + member x.``When the command text is parsed successfully, the command text is reset``() = + requestSenderStub.registerResponse success CommandMode.handle requestSenderStub "edit" enter - |> should equal ("edit", GetCurrentCommandLanguageRequest :> Message) + |> should equal ("", CommandMode.Event.CommandCompleted "edit" :> Message) [] - member x.``When the current language is received, the command is interpreted for that language``() = - let command = ref "edit" - CommandMode.handleGetCurrentCommandLanguageResponse command { CurrentCommandLanguage = "python3" } - |> should equal ({ Language = "python3"; Fragment = "edit" } :> Message) + member x.``When the command text is not parsed successfully, the command text is reset``() = + requestSenderStub.registerResponse parseFailure + CommandMode.handle requestSenderStub "edit" enter + |> should equal ("", CoreEvent.ErrorOccurred error :> Message) [] - member x.``When there is no response to the request for the current language, the command is interpreted as VoidScript``() = - let command = ref "edit" - CommandMode.handleNoResponseToGetCurrentCommandLanguage command { Request = GetCurrentCommandLanguageRequest } - |> should equal ({ Language = "VoidScript"; Fragment = "edit" } :> Message) + member x.``When the command text parse is incomplete, a newline is added to the command text``() = + requestSenderStub.registerResponse parseIncomplete + CommandMode.handle requestSenderStub "edit" enter + |> should equal ("edit" + System.Environment.NewLine, CommandMode.NewlineAppended :> Message) [] member x.``When escape is pressed, command entry is cancelled``() = @@ -63,19 +105,3 @@ type ``Editing command mode``() = member x.``When backspace is pressed and there are no characters but the prompt, command entry is cancelled``() = CommandMode.handle requestSenderStub "" backspace |> should equal ("", CommandMode.Event.EntryCancelled :> Message) - - [] - member x.``When the command text is parsed successfully, the command text is reset``() = - CommandMode.handleInterpretFragmentResponse "edit" success - |> should equal ("", CommandMode.Event.CommandCompleted "edit" :> Message) - - [] - member x.``When the command text is not parsed successfully, the command text is reset``() = - CommandMode.handleInterpretFragmentResponse "edit" parseFailure - |> should equal ("", CoreEvent.ErrorOccurred error :> Message) - - [] - member x.``When the command text parse is incomplete, a newline is added to the command text``() = - CommandMode.handleInterpretFragmentResponse "edit" parseIncomplete - |> fst - |> should equal ("edit" + System.Environment.NewLine) diff --git a/src/Void.Core/CommandMode.fs b/src/Void.Core/CommandMode.fs index c464e60..dc2dd8f 100644 --- a/src/Void.Core/CommandMode.fs +++ b/src/Void.Core/CommandMode.fs @@ -8,6 +8,7 @@ module CommandMode = | EntryCancelled | CharacterBackspaced | TextAppended of string + | NewlineAppended | TextReplaced of string | CommandCompleted of string interface EventMessage @@ -15,7 +16,7 @@ module CommandMode = let private requestLanguageForInterpreting buffer = buffer, GetCurrentCommandLanguageRequest :> Message - let interpretFragment buffer maybeResponse = + let private interpretFragment buffer maybeResponse = { Language = match maybeResponse with @@ -24,7 +25,7 @@ module CommandMode = Fragment = buffer } - let handleInterpretFragmentResponse buffer maybeResponse = + let private handleInterpretFragmentResponse buffer maybeResponse = match maybeResponse with | Some response -> match response with @@ -33,11 +34,11 @@ module CommandMode = | InterpretScriptFragmentResponse.ParseFailed error -> "", CoreEvent.ErrorOccurred error :> Message | InterpretScriptFragmentResponse.ParseIncomplete -> - buffer + System.Environment.NewLine, noMessage + buffer + System.Environment.NewLine, Event.NewlineAppended :> Message | None -> "", CoreEvent.ErrorOccurred <| Error.NoInterpreter :> Message - let interpret (requestSender : RequestSender) buffer = + let private interpret (requestSender : RequestSender) buffer = GetCurrentCommandLanguageRequest |> requestSender.makeRequest |> interpretFragment buffer diff --git a/src/Void.ViewModel/CommandBar.fs b/src/Void.ViewModel/CommandBar.fs index e49c496..dbb81f3 100644 --- a/src/Void.ViewModel/CommandBar.fs +++ b/src/Void.ViewModel/CommandBar.fs @@ -44,6 +44,10 @@ module CommandBar = let bar = { commandBar with WrappedLines = [replacement] } (bar, Event.TextChanged bar :> Message) + let private appendNewline commandBar = + let bar = { commandBar with WrappedLines = "" :: commandBar.WrappedLines } + (bar, Event.TextReflowed bar :> Message) + let private appendText textToAppend commandBar = if currentLineWillOverflow textToAppend commandBar then @@ -86,8 +90,9 @@ module CommandBar = | CommandMode.Event.EntryCancelled -> hide | CommandMode.Event.CharacterBackspaced -> characterBackspaced commandBar | CommandMode.Event.TextAppended text -> appendText text commandBar - | CommandMode.Event.CommandCompleted _ -> (commandBar, noMessage) + | CommandMode.Event.CommandCompleted _ -> commandBar, noMessage | CommandMode.Event.TextReplaced text -> replaceText text commandBar + | CommandMode.Event.NewlineAppended -> appendNewline commandBar module Service = open Void.Core From 259d8b36f703a95d11648e529ec38c7d7a72ec80 Mon Sep 17 00:00:00 2001 From: Kazark Date: Mon, 3 Aug 2015 10:43:08 -0400 Subject: [PATCH 09/28] GREEN! - final fixes I'm glad to see that we have tests that catch this kind of error --- src/Void.Core/ModeService.fs | 3 ++- src/Void/InterpreterWrapperService.fs | 1 - 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Void.Core/ModeService.fs b/src/Void.Core/ModeService.fs index 1d78996..d4315ae 100644 --- a/src/Void.Core/ModeService.fs +++ b/src/Void.Core/ModeService.fs @@ -43,7 +43,8 @@ type ModeService member x.handleEvent = function - | CoreEvent.ErrorOccurred (Error.ScriptFragmentParseFailed _) -> + | CoreEvent.ErrorOccurred (Error.ScriptFragmentParseFailed _) + | CoreEvent.ErrorOccurred Error.NoInterpreter -> CoreCommand.ChangeToMode Mode.Normal :> Message // TODO or whatever mode we were in previously? | _ -> noMessage diff --git a/src/Void/InterpreterWrapperService.fs b/src/Void/InterpreterWrapperService.fs index cd64aab..434b220 100644 --- a/src/Void/InterpreterWrapperService.fs +++ b/src/Void/InterpreterWrapperService.fs @@ -16,7 +16,6 @@ type InterpreterWrapperService(interpreter : VoidScriptInterpreter) = | InterpretScriptFragmentResult.ParseFailed error -> Error.ScriptFragmentParseFailed (ParseErrors.textOf error, request.Fragment) |> InterpretScriptFragmentResponse.ParseFailed - :> ResponseMessage |> Some | _ -> None From e7835244d11ce7310106004753831a0d1bb5e8cb Mon Sep 17 00:00:00 2001 From: Kazark Date: Mon, 3 Aug 2015 11:45:37 -0400 Subject: [PATCH 10/28] First pass at packaged request/response --- src/Void.Core/BaseMessageTypes.fs | 17 +++-- src/Void.ViewModel/WindowBufferMap.fs | 8 +- src/Void/Init.fs | 3 +- ...rapperService.fs => InterpreterWrapper.fs} | 0 src/Void/Messaging.fs | 76 +++++++++++++++++-- src/Void/Void.fsproj | 4 +- 6 files changed, 88 insertions(+), 20 deletions(-) rename src/Void/{InterpreterWrapperService.fs => InterpreterWrapper.fs} (100%) diff --git a/src/Void.Core/BaseMessageTypes.fs b/src/Void.Core/BaseMessageTypes.fs index d729da0..6ddb008 100644 --- a/src/Void.Core/BaseMessageTypes.fs +++ b/src/Void.Core/BaseMessageTypes.fs @@ -12,9 +12,7 @@ type ResponseMessage<'TRequest when 'TRequest :> RequestMessage> = inherit Messa [] module ``This module is auto-opened to provide a null message`` = - type NoMessage = - | NoMessage - interface Message + type NoMessage = NoMessage interface Message let noMessage = NoMessage :> Message type Handle<'TMsg when 'TMsg :> Message> = @@ -26,14 +24,23 @@ type HandleRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'T type MaybeHandleRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = 'TRequest -> 'TResponse option -type HandleResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = - 'TResponse -> Message +type HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> = + 'TPackagedRequest -> 'TPackagedResponse + +type MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> = + 'TPackagedRequest -> 'TPackagedResponse option type RequestSender = abstract member makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : 'TRequest -> 'TResponse option +type PackagedRequestSender = + abstract member makePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> : 'TPackagedRequest -> 'TPackagedResponse option + type Bus = abstract member subscribe<'TMsg when 'TMsg :> Message> : Handle<'TMsg> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleRequest<'TRequest, 'TResponse> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : MaybeHandleRequest<'TRequest, 'TResponse> -> unit + abstract member subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> -> unit + abstract member subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> -> unit inherit RequestSender + inherit PackagedRequestSender diff --git a/src/Void.ViewModel/WindowBufferMap.fs b/src/Void.ViewModel/WindowBufferMap.fs index ff06281..232e5f8 100644 --- a/src/Void.ViewModel/WindowBufferMap.fs +++ b/src/Void.ViewModel/WindowBufferMap.fs @@ -85,11 +85,12 @@ module WindowBufferMap = } interface EnvelopeMessage - let handleCurrentWindowMessage windowBufferMap envelope = - { + let handleCurrentWindowMessage (requestSender : RequestSender) windowBufferMap envelope = + (*requestSender.makeRequest { BufferId = currentBufferId !windowBufferMap Message = envelope.ForBufferInCurrentWindow - } :> Message + }*) + () module Service = open Void.Core @@ -98,4 +99,3 @@ module WindowBufferMap = let windowBufferMap = ref empty bus.subscribe <| Service.wrap windowBufferMap handleVMCommand bus.subscribe <| Service.wrap windowBufferMap handleBufferEvent - bus.subscribe (handleCurrentWindowMessage windowBufferMap) diff --git a/src/Void/Init.fs b/src/Void/Init.fs index c58a5cc..10343ad 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -39,7 +39,8 @@ module Init = let buildVoid inputModeChanger (options : VoidOptions) = let editorService = EditorService() let viewModelService = ViewModelService() - let bus = BusImpl [ Channel [ editorService.handleCommand ] ] + let bus = BusImpl() + bus.subscribe editorService.handleCommand let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter let modeService = ModeService(NormalModeBindings.InputHandler(), diff --git a/src/Void/InterpreterWrapperService.fs b/src/Void/InterpreterWrapper.fs similarity index 100% rename from src/Void/InterpreterWrapperService.fs rename to src/Void/InterpreterWrapper.fs diff --git a/src/Void/Messaging.fs b/src/Void/Messaging.fs index f6bdad0..1e7ab43 100644 --- a/src/Void/Messaging.fs +++ b/src/Void/Messaging.fs @@ -74,19 +74,53 @@ type RequestChannel<'TRequest, 'TResponse when 'TRequest :> RequestMessage and ' then Some <| box x.addHandler else None -type BusImpl +type PackagedRequestChannel = + inherit RequestChannel + +type PackagedRequestChannel<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> ( - channels : Channel list + handlers : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> list ) = - let mutable _requestChannels = [] - let mutable _channels = channels + let mutable _handlers = handlers + + member private x.safetyWrap handle message = + try + handle message + with ex -> + printf "Error while handling %A: %A" message ex + None + + member x.addHandler handler = + _handlers <- x.safetyWrap handler :: _handlers + + member x.makeRequest packagedRequestMsg = + Seq.tryPick (fun handle -> handle packagedRequestMsg) handlers + + interface PackagedRequestChannel with + member x.getBoxedRequestFunctionIfResponseTypeIs<'TMsg>() = + if typeof<'TPackagedResponse> = typeof<'TMsg> + then Some <| box x.makeRequest + else None + + member x.getBoxedSubscribeActionIfResponseTypeIs<'TMsg>() = + if typeof<'TPackagedResponse> = typeof<'TMsg> + then Some <| box x.addHandler + else None + +type BusImpl() = + let mutable _channels : Channel list = [] + let mutable _requestChannels : RequestChannel list = [] + let mutable _packagedRequestChannels : PackagedRequestChannel list = [] member private x.addChannel channel = _channels <- channel :: _channels - member private x.addRequestChannel (requestChannel : RequestChannel) = + member private x.addRequestChannel requestChannel = _requestChannels <- requestChannel :: _requestChannels + member private x.addPackagedRequestChannel packagedRequestChannel = + _packagedRequestChannels <- packagedRequestChannel :: _packagedRequestChannels + member x.publishAll messages = for message in messages do x.publish message @@ -107,6 +141,16 @@ type BusImpl | None -> None + member x.makePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> request = + let tryGetRequestFunction (channel : PackagedRequestChannel) = + channel.getBoxedRequestFunctionIfResponseTypeIs<'TPackagedResponse>() + match List.tryPick tryGetRequestFunction _packagedRequestChannels with + | Some makeRequest -> + request + |> unbox> makeRequest + | None -> + None + member x.subscribe<'TMsg when 'TMsg :> Message> (handle : Handle<'TMsg>) = let tryGetSubscribeAction (channel : Channel) = channel.getBoxedSubscribeActionIfTypeIs<'TMsg>() @@ -117,21 +161,37 @@ type BusImpl | None -> x.addChannel <| Channel [ handle ] - member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = let tryGetSubscribeAction (channel : RequestChannel) = channel.getBoxedSubscribeActionIfResponseTypeIs<'TResponse>() match List.tryPick tryGetSubscribeAction _requestChannels with | Some subscribe -> - handleRequest + maybeHandleRequest |> unbox -> unit> subscribe | None -> - x.addRequestChannel <| RequestChannel<'TRequest, 'TResponse> [ handleRequest ] + x.addRequestChannel <| RequestChannel<'TRequest, 'TResponse> [ maybeHandleRequest ] member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest (handleRequest >> Some) + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + let tryGetSubscribeAction (channel : RequestChannel) = + channel.getBoxedSubscribeActionIfResponseTypeIs<'TPackagedResponse>() + match List.tryPick tryGetSubscribeAction _packagedRequestChannels with + | Some subscribe -> + maybeHandlePackagedRequest + |> unbox -> unit> subscribe + | None -> + x.addPackagedRequestChannel <| PackagedRequestChannel<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> [ maybeHandlePackagedRequest ] + + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + x.subscribeToPackagedRequest (handlePackagedRequest >> Some) + interface Bus with member x.makeRequest request = x.makeRequest request + member x.makePackagedRequest request = x.makePackagedRequest request member x.subscribe handle = x.subscribe handle member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest maybeHandleRequest member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest handleRequest + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = x.subscribeToPackagedRequest handlePackagedRequest + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = x.subscribeToPackagedRequest maybeHandlePackagedRequest diff --git a/src/Void/Void.fsproj b/src/Void/Void.fsproj index 1b4b0f7..cbf406e 100644 --- a/src/Void/Void.fsproj +++ b/src/Void/Void.fsproj @@ -46,7 +46,7 @@ - + @@ -102,4 +102,4 @@ --> - + \ No newline at end of file From 28f5ea23c04de4593d50715d1c887589b3d27225 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 6 Aug 2015 13:11:30 -0400 Subject: [PATCH 11/28] Add request/response for "get window contents" which the window buffer map service then maps onto a request/response for the appropriate buffer's contents --- src/Void.ViewModel/Void.ViewModel.fsproj | 3 ++- src/Void.ViewModel/WindowBufferMap.fs | 26 ++++++++++++++---------- src/Void.ViewModel/WindowMessages.fs | 20 ++++++++++++++++++ 3 files changed, 37 insertions(+), 12 deletions(-) create mode 100644 src/Void.ViewModel/WindowMessages.fs diff --git a/src/Void.ViewModel/Void.ViewModel.fsproj b/src/Void.ViewModel/Void.ViewModel.fsproj index 381a3e4..ca2138e 100644 --- a/src/Void.ViewModel/Void.ViewModel.fsproj +++ b/src/Void.ViewModel/Void.ViewModel.fsproj @@ -49,6 +49,7 @@ + @@ -88,4 +89,4 @@ --> - + \ No newline at end of file diff --git a/src/Void.ViewModel/WindowBufferMap.fs b/src/Void.ViewModel/WindowBufferMap.fs index 232e5f8..25862de 100644 --- a/src/Void.ViewModel/WindowBufferMap.fs +++ b/src/Void.ViewModel/WindowBufferMap.fs @@ -79,23 +79,27 @@ module WindowBufferMap = | BufferEvent.Added _ -> loadBufferIntoCurrentWindow windowBufferMap event.BufferId - type CurrentWindowEnvelopeMessage = + let getWindowContentsResponse getBufferContentsResponse = { - ForBufferInCurrentWindow : BufferMessage - } - interface EnvelopeMessage + FirstLineNumber = getBufferContentsResponse.Message.FirstLineNumber + RequestedContents = getBufferContentsResponse.Message.RequestedContents + } : GetWindowContentsResponse - let handleCurrentWindowMessage (requestSender : RequestSender) windowBufferMap envelope = - (*requestSender.makeRequest { + let handleGetWindowContentsRequest (requestSender : PackagedRequestSender) windowBufferMap (request : GetWindowContentsRequest) = + requestSender.makePackagedRequest { BufferId = currentBufferId !windowBufferMap - Message = envelope.ForBufferInCurrentWindow - }*) - () + Message = { StartingAtLine = request.StartingAtLine } + } + |> Option.map getWindowContentsResponse module Service = open Void.Core let subscribe (bus : Bus) = let windowBufferMap = ref empty - bus.subscribe <| Service.wrap windowBufferMap handleVMCommand - bus.subscribe <| Service.wrap windowBufferMap handleBufferEvent + Service.wrap windowBufferMap handleVMCommand + |> bus.subscribe + Service.wrap windowBufferMap handleBufferEvent + |> bus.subscribe + handleGetWindowContentsRequest bus windowBufferMap + |> bus.subscribeToRequest diff --git a/src/Void.ViewModel/WindowMessages.fs b/src/Void.ViewModel/WindowMessages.fs new file mode 100644 index 0000000..054fc33 --- /dev/null +++ b/src/Void.ViewModel/WindowMessages.fs @@ -0,0 +1,20 @@ +namespace Void.ViewModel + +open Void.Core + +type WindowMessage = inherit Message + +type GetWindowContentsRequest = + { + StartingAtLine : int + } + interface RequestMessage + interface WindowMessage + +type GetWindowContentsResponse = + { + FirstLineNumber : int + RequestedContents : string seq + } + interface ResponseMessage + interface WindowMessage From 786f68e540f452a894442804507f19214ab2486d Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 13 Aug 2015 12:51:32 -0400 Subject: [PATCH 12/28] Decouple rendering of command bar from view model service I went in to make my changes for scrolling, and once again the huge mass that is the view model hindered me. I was somewhat at a loss for what to do, so I thought I would start by finishing my decoupling of the command bar, which I have already decoupled to a large degree, thinking that might be instructive on how to proceed with scrolling in windows. In Go terms, tesuji. I've played a move elsewhere. --- src/Void.ViewModel/RenderCommandBar.fs | 36 ++++++++++++++++++++++++++ src/Void.ViewModel/ViewModelService.fs | 24 +---------------- src/Void/Init.fs | 1 + 3 files changed, 38 insertions(+), 23 deletions(-) diff --git a/src/Void.ViewModel/RenderCommandBar.fs b/src/Void.ViewModel/RenderCommandBar.fs index 9061566..a24dffa 100644 --- a/src/Void.ViewModel/RenderCommandBar.fs +++ b/src/Void.ViewModel/RenderCommandBar.fs @@ -72,4 +72,40 @@ module RenderCommandBar = (area, render commandBar area origin) + let handleCommandBarEvent commandBarOrigin event = + let renderCommandBar commandBar = + asDrawingObjects commandBar !commandBarOrigin + |> VMEvent.ViewPortionRendered :> Message + match event with + | CommandBar.Event.CharacterBackspacedFromLine cell -> + backspacedCharacterAsDrawingObject cell !commandBarOrigin + |> VMEvent.ViewPortionRendered :> Message + | CommandBar.Event.Displayed commandBar -> + renderCommandBar commandBar + | CommandBar.Event.Hidden commandBar -> + renderCommandBar commandBar + | CommandBar.Event.TextAppendedToLine textSegment -> + appendedTextAsDrawingObject textSegment !commandBarOrigin + |> VMEvent.ViewPortionRendered :> Message + | CommandBar.Event.TextChanged commandBar -> + renderCommandBar commandBar + | CommandBar.Event.TextReflowed commandBar -> + renderCommandBar commandBar + [] + type Event = + | CommandBarOriginReset of CellGrid.Cell + interface EventMessage + + let handleVMEvent commandBarOrigin event = + match event with + | VMEvent.ViewModelInitialized viewModel -> + let newOrigin = ViewModel.upperLeftCellOfCommandBar viewModel + newOrigin, Event.CommandBarOriginReset newOrigin :> Message + | _ -> commandBarOrigin, noMessage + + module Service = + let subscribe (bus : Bus) = + let commandBarOrigin = ref CellGrid.originCell + handleCommandBarEvent commandBarOrigin |> bus.subscribe + Service.wrap commandBarOrigin handleVMEvent |> bus.subscribe diff --git a/src/Void.ViewModel/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index 2ed734f..e35b957 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -28,27 +28,6 @@ type ViewModelService() = | _ -> noMessage - member x.handleCommandBarEvent event = - let commandBarOrigin = ViewModel.upperLeftCellOfCommandBar _viewModel - let renderCommandBar commandBar = - RenderCommandBar.asDrawingObjects commandBar commandBarOrigin - |> VMEvent.ViewPortionRendered :> Message - match event with - | CommandBar.Event.CharacterBackspacedFromLine cell -> - RenderCommandBar.backspacedCharacterAsDrawingObject cell commandBarOrigin - |> VMEvent.ViewPortionRendered :> Message - | CommandBar.Event.Displayed commandBar -> - renderCommandBar commandBar - | CommandBar.Event.Hidden commandBar -> - renderCommandBar commandBar - | CommandBar.Event.TextAppendedToLine textSegment -> - RenderCommandBar.appendedTextAsDrawingObject textSegment commandBarOrigin - |> VMEvent.ViewPortionRendered :> Message - | CommandBar.Event.TextChanged commandBar -> - renderCommandBar commandBar - | CommandBar.Event.TextReflowed commandBar -> - renderCommandBar commandBar - member x.handleBufferEvent event = match event.Message with | BufferEvent.Added buffer -> @@ -71,5 +50,4 @@ type ViewModelService() = bus.subscribe x.handleEvent bus.subscribe x.handleBufferEvent bus.subscribe x.handleCommand - bus.subscribe x.handleVMCommand - bus.subscribe x.handleCommandBarEvent \ No newline at end of file + bus.subscribe x.handleVMCommand \ No newline at end of file diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 10343ad..fb7cf58 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -59,6 +59,7 @@ module Init = Notifications.Service.subscribe bus Filesystem.Service.subscribe bus CommandBar.Service.subscribe bus + RenderCommandBar.Service.subscribe bus WindowBufferMap.Service.subscribe bus NotifyUserOfEvent.Service.subscribe bus bus From f436be45ca38acb4230545148958b9c3348baa74 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 20 Aug 2015 08:36:37 -0400 Subject: [PATCH 13/28] Bust the view model apart more I have to break this thing down small enough that it is possible to work with it --- .../RenderNotificationBarSpec.fs | 36 +++++++++++ src/Void.ViewModel.Spec/RenderSpec.fs | 28 --------- .../Void.ViewModel.Spec.fsproj | 3 +- src/Void.ViewModel/CommandBar.fs | 17 ++++- src/Void.ViewModel/NotificationBar.fs | 6 ++ src/Void.ViewModel/Render.fs | 23 ------- src/Void.ViewModel/RenderCommandBar.fs | 29 +++++---- src/Void.ViewModel/RenderNotificationBar.fs | 63 +++++++++++++++++++ src/Void.ViewModel/ViewModel.fs | 9 --- src/Void.ViewModel/ViewModelService.fs | 11 ---- src/Void.ViewModel/ViewModelTypes.fs | 6 -- src/Void.ViewModel/Void.ViewModel.fsproj | 3 + src/Void.ViewModel/Window.fs | 8 +++ src/Void/Init.fs | 2 + 14 files changed, 152 insertions(+), 92 deletions(-) create mode 100644 src/Void.ViewModel.Spec/RenderNotificationBarSpec.fs create mode 100644 src/Void.ViewModel/NotificationBar.fs create mode 100644 src/Void.ViewModel/RenderNotificationBar.fs create mode 100644 src/Void.ViewModel/Window.fs diff --git a/src/Void.ViewModel.Spec/RenderNotificationBarSpec.fs b/src/Void.ViewModel.Spec/RenderNotificationBarSpec.fs new file mode 100644 index 0000000..d8116c9 --- /dev/null +++ b/src/Void.ViewModel.Spec/RenderNotificationBarSpec.fs @@ -0,0 +1,36 @@ +namespace Void.ViewModel.Spec + +open Void.ViewModel +open Void.Core +open Void.Core.CellGrid +open System.Linq +open NUnit.Framework +open FsUnit + +[] +type ``Rendering user notifications``() = + let render = RenderNotificationBar.asDrawingObjects + [] + member x.``when there are none results in no drawing objects``() = + render 78 { Row = 24; Column = 0 } [] + |> should equal [] + + [] + member x.``when there is one error renders it in error colors``() = + render 78 { Row = 24; Column = 0 } [UserNotificationView.Error "Bad!"] + |> should equal [DrawingObject.Text { + Text = "Bad!" + UpperLeftCorner = { Y = 24; X = 0 } + Color = Colors.defaultColorscheme.Error + }] + + [] + member x.``when there is one notification renders it in regular colors``() = + render 80 { Row = 25; Column = 0 } [UserNotificationView.Text "Good"] + |> should equal [DrawingObject.Text { + Text = "Good" + UpperLeftCorner = { Y = 25; X = 0 } + Color = Colors.defaultColorscheme.Foreground + }] + + // TODO multiple lines diff --git a/src/Void.ViewModel.Spec/RenderSpec.fs b/src/Void.ViewModel.Spec/RenderSpec.fs index 90336e6..667bf70 100644 --- a/src/Void.ViewModel.Spec/RenderSpec.fs +++ b/src/Void.ViewModel.Spec/RenderSpec.fs @@ -18,34 +18,6 @@ type ``Rendering text lines as drawing objects for a view size``() = Color = Colors.defaultColorscheme.Foreground }] -[] -type ``Rendering user notifications``() = - let render = Render.notificationsAsDrawingObjects - [] - member x.``when there are none results in no drawing objects``() = - render 78 { Row = 24; Column = 0 } [] - |> should equal [] - - [] - member x.``when there is one error renders it in error colors``() = - render 78 { Row = 24; Column = 0 } [UserNotificationView.Error "Bad!"] - |> should equal [DrawingObject.Text { - Text = "Bad!" - UpperLeftCorner = { Y = 24; X = 0 } - Color = Colors.defaultColorscheme.Error - }] - - [] - member x.``when there is one notification renders it in regular colors``() = - render 80 { Row = 25; Column = 0 } [UserNotificationView.Text "Good"] - |> should equal [DrawingObject.Text { - Text = "Good" - UpperLeftCorner = { Y = 25; X = 0 } - Color = Colors.defaultColorscheme.Foreground - }] - - // TODO multiple lines - [] type ``Rendering buffers``() = let windowArea = { diff --git a/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj b/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj index f33a4db..ca93b23 100644 --- a/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj +++ b/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj @@ -61,6 +61,7 @@ + @@ -103,4 +104,4 @@ --> - + \ No newline at end of file diff --git a/src/Void.ViewModel/CommandBar.fs b/src/Void.ViewModel/CommandBar.fs index dbb81f3..253328e 100644 --- a/src/Void.ViewModel/CommandBar.fs +++ b/src/Void.ViewModel/CommandBar.fs @@ -19,6 +19,11 @@ module CommandBar = WrappedLines = [""] } + [] + type Command = + | Redraw of CommandBarView + interface CommandMessage + [] type Event = | CharacterBackspacedFromLine of CellGrid.Cell @@ -85,6 +90,12 @@ module CommandBar = | CoreEvent.ModeChanged { From = _; To = Mode.Command } -> show | _ -> (commandBar, noMessage) + let handleCoreCommand commandBar command = + match command with + | CoreCommand.Redraw -> + Command.Redraw !commandBar :> Message + | _ -> noMessage + let handleCommandModeEvent commandBar event = match event with | CommandMode.Event.EntryCancelled -> hide @@ -99,5 +110,7 @@ module CommandBar = let subscribe (bus : Bus) = let commandBar = ref hidden - bus.subscribe <| Service.wrap commandBar handleEvent - bus.subscribe <| Service.wrap commandBar handleCommandModeEvent + Service.wrap commandBar handleEvent |> bus.subscribe + Service.wrap commandBar handleCommandModeEvent |> bus.subscribe + handleCoreCommand commandBar |> bus.subscribe + diff --git a/src/Void.ViewModel/NotificationBar.fs b/src/Void.ViewModel/NotificationBar.fs new file mode 100644 index 0000000..ee41277 --- /dev/null +++ b/src/Void.ViewModel/NotificationBar.fs @@ -0,0 +1,6 @@ +namespace Void.ViewModel + +[] +type UserNotificationView = + | Text of string + | Error of string diff --git a/src/Void.ViewModel/Render.fs b/src/Void.ViewModel/Render.fs index 9e90053..c3a6612 100644 --- a/src/Void.ViewModel/Render.fs +++ b/src/Void.ViewModel/Render.fs @@ -1,7 +1,6 @@ namespace Void.ViewModel open Void.Core - module Render = open Void.Core.CellGrid @@ -15,27 +14,6 @@ module Render = let textLinesAsDrawingObjects = List.mapi textLineAsDrawingObject - let notificationAsDrawingObject upperLeft notification = - match notification with - | UserNotificationView.Text text -> - { - Text = text - UpperLeftCorner = GridConvert.upperLeftCornerOf upperLeft - Color = Colors.defaultColorscheme.Foreground - } - | UserNotificationView.Error text -> - { - Text = text - UpperLeftCorner = GridConvert.upperLeftCornerOf upperLeft - Color = Colors.defaultColorscheme.Error - } - |> DrawingObject.Text - - let notificationsAsDrawingObjects width upperLeft notifications = - let asDrawingObject = - notificationAsDrawingObject upperLeft - notifications |> List.map asDrawingObject - let tabBarAsDrawingObjects tabBar = [] let bufferAsDrawingObjects windowArea (buffer : BufferView) = @@ -69,7 +47,6 @@ module Render = [ tabBarAsDrawingObjects viewModel.TabBar windowsAsDrawingObjects viewModel.VisibleWindows - notificationsAsDrawingObjects viewModel.Size.Columns originCell viewModel.Notifications ] |> Seq.concat let currentBufferAsDrawingObjects viewModel = diff --git a/src/Void.ViewModel/RenderCommandBar.fs b/src/Void.ViewModel/RenderCommandBar.fs index a24dffa..fef2527 100644 --- a/src/Void.ViewModel/RenderCommandBar.fs +++ b/src/Void.ViewModel/RenderCommandBar.fs @@ -40,16 +40,16 @@ module RenderCommandBar = renderPrompt origin prompt :: renderLines origin lines |> Seq.ofList - let backspacedCharacterAsDrawingObject cell origin = + let private backspacedCharacterAsDrawingObject cell origin = let offsetCell = CellGrid.vectorAdd origin cell let area = GridConvert.boxAroundOneCell offsetCell let drawing = DrawingObject.Block { Area = area Color = Colors.defaultColorscheme.Background } - (area, Seq.singleton drawing) + area, Seq.singleton drawing - let appendedTextAsDrawingObject textSegment origin = + let private appendedTextAsDrawingObject textSegment origin = let offsetCell = CellGrid.vectorAdd origin textSegment.LeftMostCell let area = GridConvert.boxAroundOneCell offsetCell // TODO but what if it's not one cell? let drawing = DrawingObject.Text { @@ -57,7 +57,7 @@ module RenderCommandBar = UpperLeftCorner = GridConvert.upperLeftCornerOf offsetCell Color = Colors.defaultColorscheme.Foreground } - (area, Seq.singleton drawing) + area, Seq.singleton drawing let asDrawingObjects commandBar origin = let height = @@ -70,27 +70,31 @@ module RenderCommandBar = Dimensions = { Height = height; Width = commandBar.Width } } - (area, render commandBar area origin) + area, render commandBar area origin + + let private renderCommandBar commandBar commandBarOrigin = + asDrawingObjects commandBar !commandBarOrigin + |> VMEvent.ViewPortionRendered :> Message let handleCommandBarEvent commandBarOrigin event = - let renderCommandBar commandBar = - asDrawingObjects commandBar !commandBarOrigin - |> VMEvent.ViewPortionRendered :> Message match event with | CommandBar.Event.CharacterBackspacedFromLine cell -> backspacedCharacterAsDrawingObject cell !commandBarOrigin |> VMEvent.ViewPortionRendered :> Message | CommandBar.Event.Displayed commandBar -> - renderCommandBar commandBar + renderCommandBar commandBar commandBarOrigin | CommandBar.Event.Hidden commandBar -> - renderCommandBar commandBar + renderCommandBar commandBar commandBarOrigin | CommandBar.Event.TextAppendedToLine textSegment -> appendedTextAsDrawingObject textSegment !commandBarOrigin |> VMEvent.ViewPortionRendered :> Message | CommandBar.Event.TextChanged commandBar -> - renderCommandBar commandBar + renderCommandBar commandBar commandBarOrigin | CommandBar.Event.TextReflowed commandBar -> - renderCommandBar commandBar + renderCommandBar commandBar commandBarOrigin + + let handleCommandBarCommand commandBarOrigin (CommandBar.Command.Redraw commandBar) = + renderCommandBar commandBar commandBarOrigin [] type Event = @@ -108,4 +112,5 @@ module RenderCommandBar = let subscribe (bus : Bus) = let commandBarOrigin = ref CellGrid.originCell handleCommandBarEvent commandBarOrigin |> bus.subscribe + handleCommandBarCommand commandBarOrigin |> bus.subscribe Service.wrap commandBarOrigin handleVMEvent |> bus.subscribe diff --git a/src/Void.ViewModel/RenderNotificationBar.fs b/src/Void.ViewModel/RenderNotificationBar.fs new file mode 100644 index 0000000..73709b7 --- /dev/null +++ b/src/Void.ViewModel/RenderNotificationBar.fs @@ -0,0 +1,63 @@ +namespace Void.ViewModel + +module RenderNotificationBar = + open Void.Core + open Void.Core.CellGrid + + let private notificationAsDrawingObject upperLeft notification = + match notification with + | UserNotificationView.Text text -> + { + Text = text + UpperLeftCorner = GridConvert.upperLeftCornerOf upperLeft + Color = Colors.defaultColorscheme.Foreground + } + | UserNotificationView.Error text -> + { + Text = text + UpperLeftCorner = GridConvert.upperLeftCornerOf upperLeft + Color = Colors.defaultColorscheme.Error + } + |> DrawingObject.Text + + let asDrawingObjects width upperLeft notifications = + let asDrawingObject = + notificationAsDrawingObject upperLeft + notifications |> List.map asDrawingObject + + let private toScreenNotification = + function + | UserNotification.Output notificationText -> UserNotificationView.Text notificationText + | UserNotification.Error error -> UserNotificationView.Error <| Errors.textOf error + + let handleEvent notificationsOrigin event = + match event with + | CoreEvent.NotificationAdded notification -> + let area = { + UpperLeftCell = !notificationsOrigin + Dimensions = { Rows = 1; Columns = 80 } + } + let drawing = toScreenNotification notification + |> notificationAsDrawingObject !notificationsOrigin + let areaInPoints = GridConvert.boxAround area + VMEvent.ViewPortionRendered(areaInPoints, [drawing]) :> Message + | _ -> noMessage + + [] + type Event = + | NotificationBarOriginReset of CellGrid.Cell + interface EventMessage + + let handleVMEvent notificationBarOrigin event = + match event with + | VMEvent.ViewModelInitialized viewModel -> + let newOrigin = ViewModel.upperLeftCellOfCommandBar viewModel + newOrigin, Event.NotificationBarOriginReset newOrigin :> Message + | _ -> notificationBarOrigin, noMessage + + module Service = + let subscribe (bus : Bus) = + let notificationBarOrigin = ref originCell + handleEvent notificationBarOrigin |> bus.subscribe + Service.wrap notificationBarOrigin handleVMEvent |> bus.subscribe + diff --git a/src/Void.ViewModel/ViewModel.fs b/src/Void.ViewModel/ViewModel.fs index 6bbecaa..36a9de3 100644 --- a/src/Void.ViewModel/ViewModel.fs +++ b/src/Void.ViewModel/ViewModel.fs @@ -31,7 +31,6 @@ module ViewModel = FontSize = defaultFontSize TabBar = [] VisibleWindows = [defaultWindowView Sizing.defaultViewArea] - Notifications = [] } let bufferFrom (windowSize : Dimensions) lines = @@ -58,14 +57,6 @@ module ViewModel = Dimensions = view.Size } - let toScreenNotification = - function - | UserNotification.Output notificationText -> UserNotificationView.Text notificationText - | UserNotification.Error error -> UserNotificationView.Error <| Errors.textOf error - - let addNotification viewModel notification = - { viewModel with Notifications = notification :: viewModel.Notifications } - let upperLeftCellOfCommandBar viewModel = // TODO this is just hacked together for the moment { Row = CellGrid.lastRow (wholeArea viewModel); Column = 0 } diff --git a/src/Void.ViewModel/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index e35b957..c2b8b7b 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -36,18 +36,7 @@ type ViewModelService() = let area = GridConvert.boxAround (ViewModel.wholeArea _viewModel) (* TODO shouldn't redraw the whole UI *) VMEvent.ViewPortionRendered(area, drawings) :> Message - member x.handleEvent = - function // TODO clearly the code below needs to be refactored - | CoreEvent.NotificationAdded notification -> - let area = ViewModel.areaOfCommandBarOrNotifications _viewModel - let drawing = ViewModel.toScreenNotification notification - |> Render.notificationAsDrawingObject area.UpperLeftCell - let areaInPoints = GridConvert.boxAround area - VMEvent.ViewPortionRendered(areaInPoints, [drawing]) :> Message - | _ -> noMessage - member x.subscribe (bus : Bus) = - bus.subscribe x.handleEvent bus.subscribe x.handleBufferEvent bus.subscribe x.handleCommand bus.subscribe x.handleVMCommand \ No newline at end of file diff --git a/src/Void.ViewModel/ViewModelTypes.fs b/src/Void.ViewModel/ViewModelTypes.fs index 8d61899..71f0c4f 100644 --- a/src/Void.ViewModel/ViewModelTypes.fs +++ b/src/Void.ViewModel/ViewModelTypes.fs @@ -46,11 +46,6 @@ type TabNameView = | Unfocused of string | Focused of string -[] -type UserNotificationView = - | Text of string - | Error of string - type MainViewModel = { Size : CellGrid.Dimensions Title : string @@ -58,5 +53,4 @@ type MainViewModel = { FontSize : int TabBar : TabNameView list VisibleWindows : WindowView list - Notifications : UserNotificationView list } diff --git a/src/Void.ViewModel/Void.ViewModel.fsproj b/src/Void.ViewModel/Void.ViewModel.fsproj index ca2138e..e153e79 100644 --- a/src/Void.ViewModel/Void.ViewModel.fsproj +++ b/src/Void.ViewModel/Void.ViewModel.fsproj @@ -58,6 +58,9 @@ + + + diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs new file mode 100644 index 0000000..a86c6db --- /dev/null +++ b/src/Void.ViewModel/Window.fs @@ -0,0 +1,8 @@ +namespace Void.ViewModel + +module Window = + module Service = + open Void.Core + + let subscribe (bus : Bus) = + () \ No newline at end of file diff --git a/src/Void/Init.fs b/src/Void/Init.fs index fb7cf58..fb15d64 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -62,6 +62,8 @@ module Init = RenderCommandBar.Service.subscribe bus WindowBufferMap.Service.subscribe bus NotifyUserOfEvent.Service.subscribe bus + Window.Service.subscribe bus + RenderNotificationBar.Service.subscribe bus bus let launchVoid (bus : BusImpl) = From 23edd51728eaeb44d08fe8e6aaeabe4db2fbd43e Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 20 Aug 2015 13:14:23 -0400 Subject: [PATCH 14/28] GREEN BUT BROKEN - continue to bust up view model --- src/Void.Core/Grids.fs | 2 + .../{RenderSpec.fs => RenderWindowsSpec.fs} | 12 +-- .../Void.ViewModel.Spec.fsproj | 4 +- .../{ViewModelSpec.fs => WindowSpec.fs} | 12 +-- src/Void.ViewModel/CommandBar.fs | 13 +++ .../{Render.fs => RenderWindows.fs} | 37 +++++--- src/Void.ViewModel/ViewModel.fs | 32 +------ src/Void.ViewModel/ViewModelService.fs | 26 +----- src/Void.ViewModel/ViewModelTypes.fs | 34 +------ src/Void.ViewModel/Void.ViewModel.fsproj | 2 +- src/Void.ViewModel/Window.fs | 91 ++++++++++++++++++- src/Void/Init.fs | 1 + 12 files changed, 145 insertions(+), 121 deletions(-) rename src/Void.ViewModel.Spec/{RenderSpec.fs => RenderWindowsSpec.fs} (87%) rename src/Void.ViewModel.Spec/{ViewModelSpec.fs => WindowSpec.fs} (74%) rename src/Void.ViewModel/{Render.fs => RenderWindows.fs} (52%) diff --git a/src/Void.Core/Grids.fs b/src/Void.Core/Grids.fs index 7e35835..4218492 100644 --- a/src/Void.Core/Grids.fs +++ b/src/Void.Core/Grids.fs @@ -30,6 +30,8 @@ module CellGrid = Dimensions : Dimensions } let originCell = { Row = 0; Column = 0 } + let zeroDimensions = { Rows = 0; Columns = 0 } + let zeroBlock = { UpperLeftCell = originCell; Dimensions = zeroDimensions } let rightOf cell count = { Row = cell.Row; Column = cell.Column + count } diff --git a/src/Void.ViewModel.Spec/RenderSpec.fs b/src/Void.ViewModel.Spec/RenderWindowsSpec.fs similarity index 87% rename from src/Void.ViewModel.Spec/RenderSpec.fs rename to src/Void.ViewModel.Spec/RenderWindowsSpec.fs index 667bf70..4faadf1 100644 --- a/src/Void.ViewModel.Spec/RenderSpec.fs +++ b/src/Void.ViewModel.Spec/RenderWindowsSpec.fs @@ -11,7 +11,7 @@ open FsUnit type ``Rendering text lines as drawing objects for a view size``() = [] member x.``for one line, which fits on the screen in both dimensions, should place it at the origin``() = - Render.textLinesAsDrawingObjects ["Just one line"] + RenderWindows.textLinesAsDrawingObjects ["Just one line"] |> should equal [DrawingObject.Text { Text = "Just one line" UpperLeftCorner = PointGrid.originPoint @@ -25,7 +25,7 @@ type ``Rendering buffers``() = Dimensions = { Rows = 25; Columns = 80 } } - let render = Render.bufferAsDrawingObjects windowArea + let render = RenderWindows.contentsAsDrawingObjects windowArea let shouldAllBeTildes drawingObjects = drawingObjects |> Seq.mapi (fun i drawingObject -> @@ -44,14 +44,14 @@ type ``Rendering buffers``() = [] member x.``when the buffer is empty it renders as a background-colored area with muted tildes on each line except the first``() = // TODO when you open an empty buffer in Vim, why is there no tilde in the first line? - let drawingObjects = render { LinesOfText = [] } + let drawingObjects = render [] drawingObjects.Length |> should equal 25 drawingObjects.[0] |> shouldBeBackgroundBlock drawingObjects.Tail |> shouldAllBeTildes [] member x.``when the buffer has one line it renders that line and but otherwise is like an empty buffer``() = - let drawingObjects = render { LinesOfText = ["only one line"] } + let drawingObjects = render ["only one line"] drawingObjects.Length |> should equal 26 drawingObjects.[0] |> shouldBeBackgroundBlock drawingObjects.[1] |> should equal (DrawingObject.Text { @@ -63,7 +63,7 @@ type ``Rendering buffers``() = [] member x.``when the buffer has multple lines, but less than the rows that are available in the window``() = - let drawingObjects = render { LinesOfText = ["line 1"; "line 2"] } + let drawingObjects = render ["line 1"; "line 2"] drawingObjects.Length |> should equal 26 drawingObjects.[0] |> shouldBeBackgroundBlock drawingObjects.[1] |> should equal (DrawingObject.Text { @@ -81,7 +81,7 @@ type ``Rendering buffers``() = [] member x.``when the buffer has as many lines as the rows in the window, no tildes show``() = // There should never be more because of the way that the buffer view model gets constructed - let drawingObjects = render { LinesOfText = Enumerable.Repeat("line", 25) |> List.ofSeq } + let drawingObjects = render (Enumerable.Repeat("line", 25) |> List.ofSeq) drawingObjects.Length |> should equal 26 drawingObjects.[0] |> shouldBeBackgroundBlock drawingObjects |> Seq.mapi (fun i drawingObject -> diff --git a/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj b/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj index ca93b23..1c62241 100644 --- a/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj +++ b/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj @@ -58,9 +58,9 @@ - + - + diff --git a/src/Void.ViewModel.Spec/ViewModelSpec.fs b/src/Void.ViewModel.Spec/WindowSpec.fs similarity index 74% rename from src/Void.ViewModel.Spec/ViewModelSpec.fs rename to src/Void.ViewModel.Spec/WindowSpec.fs index 59aee57..a0a7de7 100644 --- a/src/Void.ViewModel.Spec/ViewModelSpec.fs +++ b/src/Void.ViewModel.Spec/WindowSpec.fs @@ -9,34 +9,34 @@ open FsUnit [] type ``Constructing a buffer view model from a sequence of text lines``() = - let asViewModelBuffer = ViewModel.bufferFrom { Rows = 25; Columns = 80 } + let asViewModelBuffer = Window.bufferFrom { Rows = 25; Columns = 80 } [] member x.``should create an empty buffer view model from an empty buffer``() = asViewModelBuffer Seq.empty - |> should equal { LinesOfText = [] } + |> should equal [] [] member x.``for one line, shorter than the window width, should create a buffer with one line``() = seq { yield "line 1" } |> asViewModelBuffer - |> should equal { LinesOfText = ["line 1"] } + |> should equal ["line 1"] [] member x.``for one line, with length equal to the window width, should create a buffer with one line``() = seq { yield String('X', 80) } |> asViewModelBuffer - |> should equal { LinesOfText = [String('X', 80)] } + |> should equal [String('X', 80)] [] member x.``for one line, longer than the window width, should truncate the visible part of the line``() = // TODO this is the behavior when Vim's wrap option is set to nowrap seq { yield String('x', 81) } |> asViewModelBuffer - |> should equal { LinesOfText = [String('x', 80)] } + |> should equal [String('x', 80)] [] member x.``for a buffer which has more lines than the window has height, should create a buffer view model to fill the window size``() = Enumerable.Repeat("line", 26) |> asViewModelBuffer - |> should equal { LinesOfText = Seq.toList <| Enumerable.Repeat("line", 25) } + |> should equal (Seq.toList <| Enumerable.Repeat("line", 25)) diff --git a/src/Void.ViewModel/CommandBar.fs b/src/Void.ViewModel/CommandBar.fs index 253328e..2c69201 100644 --- a/src/Void.ViewModel/CommandBar.fs +++ b/src/Void.ViewModel/CommandBar.fs @@ -1,5 +1,18 @@ namespace Void.ViewModel +(* "Command line" is too equivocal. I mean the ; (or : in Vim) bar at the + * bottom of the screen *) +[] +type CommandBarPrompt = + | VoidDefault + | ClassicVim + +type CommandBarView = { + Width : int + Prompt : CommandBarPrompt Visibility + WrappedLines : string list +} + module CommandBar = open Void.Core open Void.Core.CellGrid diff --git a/src/Void.ViewModel/Render.fs b/src/Void.ViewModel/RenderWindows.fs similarity index 52% rename from src/Void.ViewModel/Render.fs rename to src/Void.ViewModel/RenderWindows.fs index c3a6612..8cfb577 100644 --- a/src/Void.ViewModel/Render.fs +++ b/src/Void.ViewModel/RenderWindows.fs @@ -1,7 +1,7 @@ namespace Void.ViewModel -open Void.Core -module Render = +module RenderWindows = + open Void.Core open Void.Core.CellGrid let private textLineAsDrawingObject x line = @@ -14,15 +14,13 @@ module Render = let textLinesAsDrawingObjects = List.mapi textLineAsDrawingObject - let tabBarAsDrawingObjects tabBar = [] - - let bufferAsDrawingObjects windowArea (buffer : BufferView) = + let contentsAsDrawingObjects windowArea (buffer : string list) = let background = DrawingObject.Block { Area = GridConvert.boxAround windowArea Color = Colors.defaultColorscheme.Background } - let bufferLines = textLinesAsDrawingObjects buffer.LinesOfText + let bufferLines = textLinesAsDrawingObjects buffer let rowsNotInBuffer = let lineNotInBufferAsDrawingObject i = @@ -40,16 +38,27 @@ module Render = List.append (background :: bufferLines) rowsNotInBuffer - let windowsAsDrawingObjects (windows : WindowView list) = - bufferAsDrawingObjects windows.[0].Area windows.[0].Buffer + let private renderWindow area contents = + let drawings = contentsAsDrawingObjects area contents + VMEvent.ViewPortionRendered(GridConvert.boxAround area, drawings) :> Message - let viewModelAsDrawingObjects viewModel = + let asDrawingObjects (windows : WindowView list) = [ - tabBarAsDrawingObjects viewModel.TabBar - windowsAsDrawingObjects viewModel.VisibleWindows + contentsAsDrawingObjects windows.[0].Area windows.[0].Buffer ] |> Seq.concat - let currentBufferAsDrawingObjects viewModel = - viewModel.VisibleWindows.[0].Buffer - |> bufferAsDrawingObjects viewModel.VisibleWindows.[0].Area + let handleWindowEvent area event = + match event with + | Window.Event.ContentsUpdated contents -> + renderWindow !area contents + | Window.Event.Initialized window -> + renderWindow !area window.Buffer + + let handleWindowCommand area (Window.Command.RedrawWindow window) = + renderWindow !area window.Buffer + module Service = + let subscribe (bus : Bus) = + let area = ref zeroBlock + handleWindowEvent area |> bus.subscribe + handleWindowCommand area |> bus.subscribe \ No newline at end of file diff --git a/src/Void.ViewModel/ViewModel.fs b/src/Void.ViewModel/ViewModel.fs index 36a9de3..7e641d2 100644 --- a/src/Void.ViewModel/ViewModel.fs +++ b/src/Void.ViewModel/ViewModel.fs @@ -5,23 +5,13 @@ module Sizing = let defaultViewSize = { Rows = 26; Columns = 80 } let defaultViewArea = { UpperLeftCell = originCell; Dimensions = defaultViewSize } -module ViewModel = +module ViewModel = // TODO name suspect at this point open Void.Util open Void.Core open Void.Core.CellGrid let defaultTitle = "Void - A text editor in the spirit of Vim" let defaultFontSize = 9 - let defaultBuffer = { LinesOfText = [] } - - let defaultWindowView containingArea = - { - StatusLine = StatusLineView.Focused - Buffer = defaultBuffer - Area = lessRowsBelow 1 containingArea - Cursor = Visible <| CursorView.Block originCell - TopLineNumber = 1 - } let defaultViewModel = { @@ -29,28 +19,8 @@ module ViewModel = Title = defaultTitle BackgroundColor = Colors.defaultColorscheme.Background FontSize = defaultFontSize - TabBar = [] - VisibleWindows = [defaultWindowView Sizing.defaultViewArea] } - let bufferFrom (windowSize : Dimensions) lines = - let truncateToWindowWidth = StringUtil.noLongerThan windowSize.Columns - { - LinesOfText = lines - |> SeqUtil.notMoreThan windowSize.Rows - |> Seq.map truncateToWindowWidth - |> Seq.toList - } - - let toScreenBuffer windowSize (buffer : FileBufferProxy) = - bufferFrom windowSize buffer.Contents - - let private loadBufferIntoWindow buffer window = - { window with Buffer = toScreenBuffer window.Area.Dimensions buffer } - - let loadBuffer buffer view = - { view with VisibleWindows = [loadBufferIntoWindow buffer view.VisibleWindows.[0]] } - let wholeArea view = { UpperLeftCell = originCell diff --git a/src/Void.ViewModel/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index c2b8b7b..2e11152 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -11,32 +11,8 @@ type ViewModelService() = VMEvent.ViewModelInitialized _viewModel :> Message | CoreCommand.Display _ -> notImplemented - | CoreCommand.Redraw -> - (GridConvert.boxAround (ViewModel.wholeArea _viewModel), Render.viewModelAsDrawingObjects _viewModel) - |> VMEvent.ViewPortionRendered :> Message | _ -> noMessage - member x.handleVMCommand = - function - | VMCommand.Scroll movement -> - match movement with - | Move.Backward xLines -> - noMessage - | Move.Forward xLines -> - noMessage - | _ -> - noMessage - - member x.handleBufferEvent event = - match event.Message with - | BufferEvent.Added buffer -> - _viewModel <- ViewModel.loadBuffer buffer _viewModel - let drawings = Render.currentBufferAsDrawingObjects _viewModel - let area = GridConvert.boxAround (ViewModel.wholeArea _viewModel) (* TODO shouldn't redraw the whole UI *) - VMEvent.ViewPortionRendered(area, drawings) :> Message - member x.subscribe (bus : Bus) = - bus.subscribe x.handleBufferEvent - bus.subscribe x.handleCommand - bus.subscribe x.handleVMCommand \ No newline at end of file + bus.subscribe x.handleCommand \ No newline at end of file diff --git a/src/Void.ViewModel/ViewModelTypes.fs b/src/Void.ViewModel/ViewModelTypes.fs index 71f0c4f..7aef37c 100644 --- a/src/Void.ViewModel/ViewModelTypes.fs +++ b/src/Void.ViewModel/ViewModelTypes.fs @@ -12,37 +12,7 @@ type CursorView = | IBeam of PointGrid.Point [] -type StatusLineView = // TODO much yet to be done here - | Unfocused - | Focused - -type BufferView = { - LinesOfText: string list // TODO this is naive obviously -} - -type WindowView = { - StatusLine : StatusLineView - Area : CellGrid.Block - Buffer : BufferView - Cursor : CursorView Visibility - TopLineNumber : int -} - -(* "Command line" is too equivocal. I mean the ; (or : in Vim) bar at the - * bottom of the screen *) -[] -type CommandBarPrompt = - | VoidDefault - | ClassicVim - -type CommandBarView = { - Width : int - Prompt : CommandBarPrompt Visibility - WrappedLines : string list -} - -[] -type TabNameView = +type TabNameView = // Speculative... :( | Unfocused of string | Focused of string @@ -51,6 +21,4 @@ type MainViewModel = { Title : string BackgroundColor : RGBColor FontSize : int - TabBar : TabNameView list - VisibleWindows : WindowView list } diff --git a/src/Void.ViewModel/Void.ViewModel.fsproj b/src/Void.ViewModel/Void.ViewModel.fsproj index e153e79..a16bdd7 100644 --- a/src/Void.ViewModel/Void.ViewModel.fsproj +++ b/src/Void.ViewModel/Void.ViewModel.fsproj @@ -52,7 +52,6 @@ - @@ -61,6 +60,7 @@ + diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index a86c6db..565b82b 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -1,8 +1,93 @@ namespace Void.ViewModel +open Void.Core + +[] +type StatusLineView = // TODO much yet to be done here + | Unfocused + | Focused + +type WindowView = { + StatusLine : StatusLineView + Area : CellGrid.Block + Buffer : string list + Cursor : CursorView Visibility + TopLineNumber : int +} + module Window = - module Service = - open Void.Core + open Void.Util + open Void.Core.CellGrid + + [] + type Event = + | ContentsUpdated of string list + | Initialized of WindowView + interface EventMessage + + [] + type Command = + | RedrawWindow of WindowView + interface CommandMessage + + let private zeroWindowView = + { + StatusLine = StatusLineView.Focused + Buffer = [] + Area = zeroBlock + Cursor = Visible <| CursorView.Block originCell + TopLineNumber = 1 + } + + let private windowInArea window containingArea = + { zeroWindowView with Area = lessRowsBelow 1 containingArea } + let bufferFrom (windowSize : Dimensions) lines = + let truncateToWindowWidth = StringUtil.noLongerThan windowSize.Columns + lines + |> SeqUtil.notMoreThan windowSize.Rows + |> Seq.map truncateToWindowWidth + |> Seq.toList + + let private toScreenBuffer windowSize (buffer : FileBufferProxy) = + bufferFrom windowSize buffer.Contents + + let private loadBufferIntoWindow buffer window = + let updatedContents = toScreenBuffer window.Area.Dimensions buffer + { window with Buffer = updatedContents }, Event.ContentsUpdated updatedContents :> Message + + let handleBufferEvent window event = + match event.Message with + | BufferEvent.Added buffer -> + loadBufferIntoWindow buffer window + + let handleVMCommand = + function + | VMCommand.Scroll movement -> + match movement with + | Move.Backward xLines -> + noMessage + | Move.Forward xLines -> + noMessage + | _ -> + noMessage + + let handleCoreCommand window command = + match command with + | CoreCommand.Redraw -> + Command.RedrawWindow !window :> Message + | _ -> noMessage + + let handleVMEvent window event = + match event with + | VMEvent.ViewModelInitialized viewModel -> + let updatedWindow = windowInArea window (ViewModel.wholeArea viewModel) + updatedWindow, Event.Initialized updatedWindow :> Message + | _ -> window, noMessage + + module Service = let subscribe (bus : Bus) = - () \ No newline at end of file + let window = ref zeroWindowView + Service.wrap window handleBufferEvent |> bus.subscribe + handleCoreCommand window |> bus.subscribe + Service.wrap window handleVMEvent |> bus.subscribe diff --git a/src/Void/Init.fs b/src/Void/Init.fs index fb15d64..58c5c9c 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -63,6 +63,7 @@ module Init = WindowBufferMap.Service.subscribe bus NotifyUserOfEvent.Service.subscribe bus Window.Service.subscribe bus + RenderWindows.Service.subscribe bus RenderNotificationBar.Service.subscribe bus bus From f2d1195e904599710dc7d4970d3b51e5e153c076 Mon Sep 17 00:00:00 2001 From: Kazark Date: Fri, 21 Aug 2015 08:14:58 -0400 Subject: [PATCH 15/28] Fix: window was not drawing Window is still not redrawing properly, however --- src/Void.ViewModel.Spec/RenderWindowsSpec.fs | 7 +---- src/Void.ViewModel/RenderWindows.fs | 33 ++++++++++---------- src/Void.ViewModel/Window.fs | 14 ++++----- 3 files changed, 24 insertions(+), 30 deletions(-) diff --git a/src/Void.ViewModel.Spec/RenderWindowsSpec.fs b/src/Void.ViewModel.Spec/RenderWindowsSpec.fs index 4faadf1..f21e165 100644 --- a/src/Void.ViewModel.Spec/RenderWindowsSpec.fs +++ b/src/Void.ViewModel.Spec/RenderWindowsSpec.fs @@ -20,12 +20,7 @@ type ``Rendering text lines as drawing objects for a view size``() = [] type ``Rendering buffers``() = - let windowArea = { - UpperLeftCell = originCell - Dimensions = { Rows = 25; Columns = 80 } - } - - let render = RenderWindows.contentsAsDrawingObjects windowArea + let render = RenderWindows.contentsAsDrawingObjects { Rows = 25; Columns = 80 } let shouldAllBeTildes drawingObjects = drawingObjects |> Seq.mapi (fun i drawingObject -> diff --git a/src/Void.ViewModel/RenderWindows.fs b/src/Void.ViewModel/RenderWindows.fs index 8cfb577..1faa1b5 100644 --- a/src/Void.ViewModel/RenderWindows.fs +++ b/src/Void.ViewModel/RenderWindows.fs @@ -14,9 +14,9 @@ module RenderWindows = let textLinesAsDrawingObjects = List.mapi textLineAsDrawingObject - let contentsAsDrawingObjects windowArea (buffer : string list) = + let contentsAsDrawingObjects dimensions (buffer : string list) = let background = DrawingObject.Block { - Area = GridConvert.boxAround windowArea + Area = GridConvert.boxAround { UpperLeftCell = originCell; Dimensions = dimensions } Color = Colors.defaultColorscheme.Background } @@ -33,32 +33,31 @@ module RenderWindows = if bufferLines.Length = 0 then 1 else bufferLines.Length - [linesWithNoTilde..windowArea.Dimensions.Rows-1] + [linesWithNoTilde..dimensions.Rows-1] |> List.map lineNotInBufferAsDrawingObject List.append (background :: bufferLines) rowsNotInBuffer - let private renderWindow area contents = - let drawings = contentsAsDrawingObjects area contents - VMEvent.ViewPortionRendered(GridConvert.boxAround area, drawings) :> Message + let private renderWindow (window : WindowView) = + let drawings = contentsAsDrawingObjects window.Dimensions window.Buffer + VMEvent.ViewPortionRendered(GridConvert.boxAround { UpperLeftCell = originCell; Dimensions = window.Dimensions }, drawings) :> Message let asDrawingObjects (windows : WindowView list) = [ - contentsAsDrawingObjects windows.[0].Area windows.[0].Buffer + contentsAsDrawingObjects windows.[0].Dimensions windows.[0].Buffer ] |> Seq.concat - let handleWindowEvent area event = - match event with - | Window.Event.ContentsUpdated contents -> - renderWindow !area contents + let handleWindowEvent = + function + | Window.Event.ContentsUpdated window -> + renderWindow window | Window.Event.Initialized window -> - renderWindow !area window.Buffer + renderWindow window - let handleWindowCommand area (Window.Command.RedrawWindow window) = - renderWindow !area window.Buffer + let handleWindowCommand (Window.Command.RedrawWindow window) = + renderWindow window module Service = let subscribe (bus : Bus) = - let area = ref zeroBlock - handleWindowEvent area |> bus.subscribe - handleWindowCommand area |> bus.subscribe \ No newline at end of file + handleWindowEvent |> bus.subscribe + handleWindowCommand |> bus.subscribe \ No newline at end of file diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index 565b82b..f3b2a68 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -9,7 +9,7 @@ type StatusLineView = // TODO much yet to be done here type WindowView = { StatusLine : StatusLineView - Area : CellGrid.Block + Dimensions : CellGrid.Dimensions Buffer : string list Cursor : CursorView Visibility TopLineNumber : int @@ -21,7 +21,7 @@ module Window = [] type Event = - | ContentsUpdated of string list + | ContentsUpdated of WindowView | Initialized of WindowView interface EventMessage @@ -34,13 +34,13 @@ module Window = { StatusLine = StatusLineView.Focused Buffer = [] - Area = zeroBlock + Dimensions = zeroDimensions Cursor = Visible <| CursorView.Block originCell TopLineNumber = 1 } let private windowInArea window containingArea = - { zeroWindowView with Area = lessRowsBelow 1 containingArea } + { zeroWindowView with Dimensions = (lessRowsBelow 1 containingArea).Dimensions } let bufferFrom (windowSize : Dimensions) lines = let truncateToWindowWidth = StringUtil.noLongerThan windowSize.Columns @@ -52,9 +52,9 @@ module Window = let private toScreenBuffer windowSize (buffer : FileBufferProxy) = bufferFrom windowSize buffer.Contents - let private loadBufferIntoWindow buffer window = - let updatedContents = toScreenBuffer window.Area.Dimensions buffer - { window with Buffer = updatedContents }, Event.ContentsUpdated updatedContents :> Message + let private loadBufferIntoWindow buffer (window : WindowView) = + let updatedWindow = { window with Buffer = toScreenBuffer window.Dimensions buffer } + updatedWindow, Event.ContentsUpdated updatedWindow :> Message let handleBufferEvent window event = match event.Message with From 9fd66a2f7ca3ef2e3806109c82add954412bd7a5 Mon Sep 17 00:00:00 2001 From: Kazark Date: Fri, 21 Aug 2015 08:34:14 -0400 Subject: [PATCH 16/28] Fix: window not redrawing --- src/Void.UI/MainForm.cs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Void.UI/MainForm.cs b/src/Void.UI/MainForm.cs index 602a322..095e2df 100644 --- a/src/Void.UI/MainForm.cs +++ b/src/Void.UI/MainForm.cs @@ -13,9 +13,9 @@ public partial class MainForm : Form { private readonly BusImpl _bus; private readonly WinFormsInputModeChanger _inputModeChanger; + private readonly List _drawings = new List(); private Font _font = new Font(FontFamily.GenericMonospace, 9); private CellMetrics _cellMetrics; - private IEnumerable _drawings; public MainForm(BusImpl bus, WinFormsInputModeChanger inputModeChanger) @@ -40,7 +40,7 @@ public Message HandleViewModelEvent(VMEvent eventMsg) { if (eventMsg.IsViewPortionRendered) { - _drawings = ((VMEvent.ViewPortionRendered)eventMsg).Item2; + _drawings.AddRange(((VMEvent.ViewPortionRendered)eventMsg).Item2); if (_cellMetrics != null) { TriggerDraw(((VMEvent.ViewPortionRendered)eventMsg).Item1); @@ -103,7 +103,7 @@ public void SubscribeToPaint() { artist.Draw(drawing); } - _drawings = Enumerable.Empty(); + _drawings.Clear(); } else { From 8701ef8e9d46d1316461af66a5531900e9d278f2 Mon Sep 17 00:00:00 2001 From: Kazark Date: Fri, 21 Aug 2015 08:59:02 -0400 Subject: [PATCH 17/28] At last, initial scrolling functionality! Though without bounds checking, CTRL-E and CTRL-Y are somewhat working! Just in time to start work for the morning. --- src/Void.Core/BufferList.fs | 9 ++++----- src/Void.ViewModel/Window.fs | 20 +++++++++++++++----- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/src/Void.Core/BufferList.fs b/src/Void.Core/BufferList.fs index 77741ba..8285dc6 100644 --- a/src/Void.Core/BufferList.fs +++ b/src/Void.Core/BufferList.fs @@ -83,7 +83,7 @@ module BufferList = | CoreCommand.WriteBufferToPath (bufferId, path) -> writeBufferToPath bufferList bufferId path | _ -> - (bufferList, noMessage) + bufferList, noMessage let private package bufferId message = { @@ -104,13 +104,12 @@ module BufferList = else Buffer.readLines buffer envelope.Message.StartingAtLine } |> package envelope.BufferId - :> EnvelopeMessage - //:> EnvelopeMessage> |> Some else None module Service = let subscribe (bus : Bus) = let bufferList = ref empty - bus.subscribe <| Service.wrap bufferList handleCommand - bus.subscribe <| Service.wrap bufferList handleEvent + Service.wrap bufferList handleCommand |> bus.subscribe + Service.wrap bufferList handleEvent |> bus.subscribe + handleGetBufferContentsRequest bufferList |> bus.subscribeToPackagedRequest diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index f3b2a68..5e619ea 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -61,16 +61,25 @@ module Window = | BufferEvent.Added buffer -> loadBufferIntoWindow buffer window - let handleVMCommand = - function + let private scroll (requestSender : RequestSender) window xLines = + let request : GetWindowContentsRequest = { StartingAtLine = window.TopLineNumber + xLines } + match requestSender.makeRequest request with + | Some (response : GetWindowContentsResponse) -> + let updatedWindow = { window with TopLineNumber = response.FirstLineNumber; Buffer = Seq.toList response.RequestedContents } + updatedWindow, Event.ContentsUpdated window :> Message + | None -> window, noMessage + + let handleVMCommand requestSender window command = + match command with | VMCommand.Scroll movement -> match movement with | Move.Backward xLines -> - noMessage + // TODO bounds checking + scroll requestSender window -xLines | Move.Forward xLines -> - noMessage + scroll requestSender window xLines | _ -> - noMessage + window, noMessage let handleCoreCommand window command = match command with @@ -91,3 +100,4 @@ module Window = Service.wrap window handleBufferEvent |> bus.subscribe handleCoreCommand window |> bus.subscribe Service.wrap window handleVMEvent |> bus.subscribe + Service.wrap window (handleVMCommand bus) |> bus.subscribe From c2e8de387ade259d456a94d8af6ad6d28f4d071c Mon Sep 17 00:00:00 2001 From: Kazark Date: Fri, 21 Aug 2015 09:12:54 -0400 Subject: [PATCH 18/28] Fix the long-broken Travis build Not sure why I wasn't getting that good and appropriate error locally. --- src/Void.Core.Spec/CommandModeSpec.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Void.Core.Spec/CommandModeSpec.fs b/src/Void.Core.Spec/CommandModeSpec.fs index 6041d02..49042c1 100644 --- a/src/Void.Core.Spec/CommandModeSpec.fs +++ b/src/Void.Core.Spec/CommandModeSpec.fs @@ -89,7 +89,7 @@ type ``Editing command mode``() = member x.``When the command text parse is incomplete, a newline is added to the command text``() = requestSenderStub.registerResponse parseIncomplete CommandMode.handle requestSenderStub "edit" enter - |> should equal ("edit" + System.Environment.NewLine, CommandMode.NewlineAppended :> Message) + |> should equal ("edit" + System.Environment.NewLine, CommandMode.Event.NewlineAppended :> Message) [] member x.``When escape is pressed, command entry is cancelled``() = From 17845d6ecfacd2a338afa6d521ba0b4da087e662 Mon Sep 17 00:00:00 2001 From: Kazark Date: Sat, 22 Aug 2015 00:34:29 -0400 Subject: [PATCH 19/28] Add test which uncovered bug in Window logic; fix Also sketched out some ideas for other tests. I had observed this bug when testing manually but hadn't really understood it. The unit test showed me what it was right away. --- src/Void.Core.Spec/CommandModeSpec.fs | 31 +-------- src/Void.Core/CannedResponseRequestSender.fs | 38 +++++++++++ src/Void.Core/Void.Core.fsproj | 1 + src/Void.ViewModel.Spec/WindowSpec.fs | 68 ++++++++++++++++++++ src/Void.ViewModel/Window.fs | 5 +- 5 files changed, 112 insertions(+), 31 deletions(-) create mode 100644 src/Void.Core/CannedResponseRequestSender.fs diff --git a/src/Void.Core.Spec/CommandModeSpec.fs b/src/Void.Core.Spec/CommandModeSpec.fs index 49042c1..073d317 100644 --- a/src/Void.Core.Spec/CommandModeSpec.fs +++ b/src/Void.Core.Spec/CommandModeSpec.fs @@ -4,35 +4,6 @@ open Void.Core open NUnit.Framework open FsUnit -type RequestSenderStub() = - let mutable _requests = [] - let mutable _responses = [] - - member x.registerResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (response : 'TResponse) = - _responses <- box response :: _responses - - member x.tryPickRequest<'TRequest when 'TRequest :> RequestMessage>() = - let tryUnbox request = - try - unbox<'TRequest> request |> Some - with _ -> - None - _requests |> List.tryPick tryUnbox - - member x.reset() = - _requests <- [] - _responses <- [] - - interface RequestSender with - member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (request : 'TRequest) = - let tryUnbox response = - try - unbox<'TResponse> response |> Some - with _ -> - None - _requests <- box request :: _requests - _responses |> List.tryPick tryUnbox - [] type ``Editing command mode``() = let success = InterpretScriptFragmentResponse.Completed @@ -42,7 +13,7 @@ type ``Editing command mode``() = let enter = TextOrHotKey.HotKey HotKey.Enter let escape = TextOrHotKey.HotKey HotKey.Escape let backspace = TextOrHotKey.HotKey HotKey.Backspace - let requestSenderStub = RequestSenderStub() + let requestSenderStub = CannedResponseRequestSender() let typeIncrement increment buffer expected = TextOrHotKey.Text increment diff --git a/src/Void.Core/CannedResponseRequestSender.fs b/src/Void.Core/CannedResponseRequestSender.fs new file mode 100644 index 0000000..b6ca632 --- /dev/null +++ b/src/Void.Core/CannedResponseRequestSender.fs @@ -0,0 +1,38 @@ +namespace Void.Core + +(* This is really for tests, and probably shouldn't be here. + * However, I'm not going to extract a new assembly for this one class. + * Besides, the test DLL shouldn't depend on Void.Core. + * Void.Core has become unclear anyway: it really should be Void.Base and Void.Editor, + * or something to that effect, and the test DLL should only depend on Void.Base. + * So TODO: when there are several more things like this, create a test library. + * Until then, this code isn't really hurting anybody. *) +type CannedResponseRequestSender() = + let mutable _requests = [] + let mutable _responses = [] + + member x.registerResponse<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (response : 'TResponse) = + _responses <- box response :: _responses + + member x.tryPickRequest<'TRequest when 'TRequest :> RequestMessage>() = + let tryUnbox request = + try + unbox<'TRequest> request |> Some + with _ -> + None + _requests |> List.tryPick tryUnbox + + member x.reset() = + _requests <- [] + _responses <- [] + + interface RequestSender with + member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (request : 'TRequest) = + let tryUnbox response = + try + unbox<'TResponse> response |> Some + with _ -> + None + _requests <- box request :: _requests + _responses |> List.tryPick tryUnbox + diff --git a/src/Void.Core/Void.Core.fsproj b/src/Void.Core/Void.Core.fsproj index feae1cf..1b53f6b 100644 --- a/src/Void.Core/Void.Core.fsproj +++ b/src/Void.Core/Void.Core.fsproj @@ -48,6 +48,7 @@ + diff --git a/src/Void.ViewModel.Spec/WindowSpec.fs b/src/Void.ViewModel.Spec/WindowSpec.fs index a0a7de7..1b70832 100644 --- a/src/Void.ViewModel.Spec/WindowSpec.fs +++ b/src/Void.ViewModel.Spec/WindowSpec.fs @@ -1,6 +1,7 @@ namespace Void.ViewModel.Spec open Void.ViewModel +open Void.Core open Void.Core.CellGrid open System open System.Linq @@ -40,3 +41,70 @@ type ``Constructing a buffer view model from a sequence of text lines``() = Enumerable.Repeat("line", 26) |> asViewModelBuffer |> should equal (Seq.toList <| Enumerable.Repeat("line", 25)) + +[] +type ``Scrolling``() = + let requestSenderStub = CannedResponseRequestSender() + + let shouldEqual expected actual = + printfn "Expected: %A" expected + printfn "Actual: %A" actual + should equal expected actual + + [] + member x.``Set up``() = + requestSenderStub.reset() + + [] + member x.``up when we are already at the top of the file should do nothing``() = + [] + |> should equal [] + + [] + member x.``up one line when the top line is two should work``() = + [] + |> should equal [] + + [] + member x.``up three lines when the top line is four should go to the top of the file``() = + [] + |> should equal [] + + [] + member x.``up three lines when the top line is three should go to the top of the file``() = + [] + |> should equal [] + + [] + member x.``down when the buffer is empty should do nothing``() = + [] + |> should equal [] + + [] + member x.``down when only the last line of the buffer is showing should do nothing``() = + [] + |> should equal [] + + [] + member x.``down one line when there is another line not shown``() = + [] + |> should equal [] + + [] + member x.``down one line when there is nothing more when the top line shown is not the bottom line of the file``() = + [] + |> should equal [] + + [] + member x.``down multiple lines``() = + let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + let windowAfter = { windowBefore with TopLineNumber = 4; Buffer = ["d"; "e"; "f"] } + ({ + FirstLineNumber = 4 + RequestedContents = ["d"; "e"; "f"] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + Move.Forward 3 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index 5e619ea..30f3e04 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -42,6 +42,9 @@ module Window = let private windowInArea window containingArea = { zeroWindowView with Dimensions = (lessRowsBelow 1 containingArea).Dimensions } + let defaultWindowView = + { zeroWindowView with Dimensions = Sizing.defaultViewSize } + let bufferFrom (windowSize : Dimensions) lines = let truncateToWindowWidth = StringUtil.noLongerThan windowSize.Columns lines @@ -66,7 +69,7 @@ module Window = match requestSender.makeRequest request with | Some (response : GetWindowContentsResponse) -> let updatedWindow = { window with TopLineNumber = response.FirstLineNumber; Buffer = Seq.toList response.RequestedContents } - updatedWindow, Event.ContentsUpdated window :> Message + updatedWindow, Event.ContentsUpdated updatedWindow :> Message | None -> window, noMessage let handleVMCommand requestSender window command = From 0bf0c0efdc2f57873653936ce751494a93ccb431 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 27 Aug 2015 12:34:28 -0400 Subject: [PATCH 20/28] Test-drive some bounds checking for the scrolling --- src/Void.ViewModel.Spec/WindowSpec.fs | 100 ++++++++++++++++++++------ src/Void.ViewModel/Window.fs | 12 ++-- 2 files changed, 85 insertions(+), 27 deletions(-) diff --git a/src/Void.ViewModel.Spec/WindowSpec.fs b/src/Void.ViewModel.Spec/WindowSpec.fs index 1b70832..9a945e9 100644 --- a/src/Void.ViewModel.Spec/WindowSpec.fs +++ b/src/Void.ViewModel.Spec/WindowSpec.fs @@ -57,46 +57,100 @@ type ``Scrolling``() = [] member x.``up when we are already at the top of the file should do nothing``() = - [] - |> should equal [] + let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + ({ + FirstLineNumber = 4 + RequestedContents = ["d"; "e"; "f"] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + Move.Backward 3 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowBefore, noMessage) [] member x.``up one line when the top line is two should work``() = - [] - |> should equal [] + let windowBefore = { Window.defaultWindowView with Buffer = ["b"; "c"; "d"; "e"; "f"]; TopLineNumber = 2 } + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + ({ + FirstLineNumber = 1 + RequestedContents = ["a"; "b"; "c"; "d"; "e"; "f"] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + Move.Backward 1 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) [] member x.``up three lines when the top line is four should go to the top of the file``() = - [] - |> should equal [] + let windowBefore = { Window.defaultWindowView with Buffer = ["d"; "e"; "f"]; TopLineNumber = 4 } + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + ({ + FirstLineNumber = 1 + RequestedContents = ["a"; "b"; "c"; "d"; "e"; "f"] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse - [] - member x.``up three lines when the top line is three should go to the top of the file``() = - [] - |> should equal [] + Move.Backward 3 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) [] - member x.``down when the buffer is empty should do nothing``() = - [] - |> should equal [] + member x.``up four lines when the top line is three should go to the top of the file``() = + let windowBefore = { Window.defaultWindowView with Buffer = ["d"; "e"; "f"]; TopLineNumber = 3 } + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + ({ + FirstLineNumber = 1 + RequestedContents = ["a"; "b"; "c"; "d"; "e"; "f"] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + Move.Backward 4 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) [] - member x.``down when only the last line of the buffer is showing should do nothing``() = - [] - |> should equal [] + member x.``up when the buffer is empty should do nothing``() = + let windowBefore = Window.defaultWindowView + ({ + FirstLineNumber = 1 + RequestedContents = [] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + Move.Backward 1 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowBefore, noMessage) [] - member x.``down one line when there is another line not shown``() = - [] - |> should equal [] + member x.``down when the buffer is empty should do nothing``() = + let windowBefore = Window.defaultWindowView + ({ + FirstLineNumber = 1 + RequestedContents = [] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + Move.Forward 1 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowBefore, noMessage) [] - member x.``down one line when there is nothing more when the top line shown is not the bottom line of the file``() = - [] - |> should equal [] + member x.``down when only the last line of the buffer is showing should do nothing``() = + let windowBefore = { Window.defaultWindowView with TopLineNumber = 6; Buffer = ["f"] } + ({ + FirstLineNumber = 7 + RequestedContents = [] + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + Move.Forward 1 + |> VMCommand.Scroll + |> Window.handleVMCommand requestSenderStub windowBefore + |> shouldEqual (windowBefore, noMessage) [] - member x.``down multiple lines``() = + member x.``down multiple lines from the top``() = let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } let windowAfter = { windowBefore with TopLineNumber = 4; Buffer = ["d"; "e"; "f"] } ({ diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index 30f3e04..e277649 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -73,16 +73,20 @@ module Window = | None -> window, noMessage let handleVMCommand requestSender window command = + let noScroll = window, noMessage match command with | VMCommand.Scroll movement -> match movement with | Move.Backward xLines -> - // TODO bounds checking - scroll requestSender window -xLines + if window.TopLineNumber > 1 + then scroll requestSender window -xLines + else noScroll | Move.Forward xLines -> - scroll requestSender window xLines + if window.Buffer.Length > 1 + then scroll requestSender window xLines + else noScroll | _ -> - window, noMessage + noScroll let handleCoreCommand window command = match command with From 075a318f23d7723d846fd9c03d0fb83f3eb7d812 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 27 Aug 2015 12:45:50 -0400 Subject: [PATCH 21/28] Support CTRL-D & CTRL-U scroll down/up half screen They were low-hanging fruit now we have CTRL-E and CTRL-Y, are more useful anyway, and are good for testing. --- src/Void.ViewModel/ViewModelMessages.fs | 3 +++ src/Void.ViewModel/Window.fs | 10 ++++++++++ src/Void/DefaultNormalModeBindings.fs | 2 ++ 3 files changed, 15 insertions(+) diff --git a/src/Void.ViewModel/ViewModelMessages.fs b/src/Void.ViewModel/ViewModelMessages.fs index 6112a5a..8ff0a51 100644 --- a/src/Void.ViewModel/ViewModelMessages.fs +++ b/src/Void.ViewModel/ViewModelMessages.fs @@ -21,10 +21,13 @@ type VMEvent = | BufferLoadedIntoWindow interface EventMessage +[] type mScreenHeight + [] type VMCommand = | Edit of FileOrBufferId | Write of FileOrBufferId | Move of Motion | Scroll of Move + | ScrollHalf of Move interface CommandMessage diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index e277649..322e0ef 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -85,6 +85,16 @@ module Window = if window.Buffer.Length > 1 then scroll requestSender window xLines else noScroll + | VMCommand.ScrollHalf movement -> + match movement with + | Move.Backward screenHeights -> + if window.TopLineNumber > 1 + then scroll requestSender window -(window.Dimensions.Rows / 2 * screenHeights * 1/1) + else noScroll + | Move.Forward screenHeights -> + if window.Buffer.Length > 1 + then scroll requestSender window (window.Dimensions.Rows / 2 * screenHeights * 1/1) + else noScroll | _ -> noScroll diff --git a/src/Void/DefaultNormalModeBindings.fs b/src/Void/DefaultNormalModeBindings.fs index abc5832..60bf545 100644 --- a/src/Void/DefaultNormalModeBindings.fs +++ b/src/Void/DefaultNormalModeBindings.fs @@ -21,6 +21,8 @@ module DefaultNormalModeBindings = [KeyPress.ControlL], CoreCommand.Redraw :> CommandMessage + [KeyPress.ControlD], VMCommand.ScrollHalf (Move.Forward 1) :> CommandMessage + [KeyPress.ControlU], VMCommand.ScrollHalf (Move.Backward 1) :> CommandMessage [KeyPress.ControlE], VMCommand.Scroll (Move.Forward 1) :> CommandMessage [KeyPress.ControlY], VMCommand.Scroll (Move.Backward 1) :> CommandMessage From 596c030b1a57ac33720287de2502d08da5188f9f Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 27 Aug 2015 12:58:34 -0400 Subject: [PATCH 22/28] Refactor to remove duplication in scrolling logic Before submitting the PR, still need to: 1. Write tests for scrolling half screens 2. Refine boundary conditions for when scrolling multiple lines 3. Clean up duplication in window scrolling unit tests 4. Add any integration tests or "get buffer contents" request tests as appropriate --- src/Void.ViewModel/Window.fs | 44 ++++++++++++++++++++---------------- 1 file changed, 25 insertions(+), 19 deletions(-) diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index 322e0ef..3e26b44 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -72,31 +72,37 @@ module Window = updatedWindow, Event.ContentsUpdated updatedWindow :> Message | None -> window, noMessage + let scrollByLineMovement requestSender window movement = + let noScroll = window, noMessage + match movement with + | Move.Backward xLines -> + if window.TopLineNumber > 1 + then scroll requestSender window -xLines + else noScroll + | Move.Forward xLines -> + if window.Buffer.Length > 1 + then scroll requestSender window xLines + else noScroll + + let scrollHalfScreenHeights requestSender (window : WindowView) movement = + let toLines (screenHeights : int) = + window.Dimensions.Rows / 2 * screenHeights * 1/1 + match movement with + | Move.Backward screenHeights -> + toLines screenHeights |> Move.Backward + | Move.Forward screenHeights -> + toLines screenHeights |> Move.Forward + |> scrollByLineMovement requestSender window + let handleVMCommand requestSender window command = let noScroll = window, noMessage match command with | VMCommand.Scroll movement -> - match movement with - | Move.Backward xLines -> - if window.TopLineNumber > 1 - then scroll requestSender window -xLines - else noScroll - | Move.Forward xLines -> - if window.Buffer.Length > 1 - then scroll requestSender window xLines - else noScroll + scrollByLineMovement requestSender window movement | VMCommand.ScrollHalf movement -> - match movement with - | Move.Backward screenHeights -> - if window.TopLineNumber > 1 - then scroll requestSender window -(window.Dimensions.Rows / 2 * screenHeights * 1/1) - else noScroll - | Move.Forward screenHeights -> - if window.Buffer.Length > 1 - then scroll requestSender window (window.Dimensions.Rows / 2 * screenHeights * 1/1) - else noScroll + scrollHalfScreenHeights requestSender window movement | _ -> - noScroll + window, noMessage let handleCoreCommand window command = match command with From e617b8646850d3090f280038424c88fcf29985e1 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 3 Sep 2015 12:16:45 -0400 Subject: [PATCH 23/28] Refactor scrolling specs for readability before writing more --- src/Void.ViewModel.Spec/WindowSpec.fs | 74 ++++++++++----------------- 1 file changed, 26 insertions(+), 48 deletions(-) diff --git a/src/Void.ViewModel.Spec/WindowSpec.fs b/src/Void.ViewModel.Spec/WindowSpec.fs index 9a945e9..97235cf 100644 --- a/src/Void.ViewModel.Spec/WindowSpec.fs +++ b/src/Void.ViewModel.Spec/WindowSpec.fs @@ -51,6 +51,16 @@ type ``Scrolling``() = printfn "Actual: %A" actual should equal expected actual + let scroll window movement = + VMCommand.Scroll movement + |> Window.handleVMCommand requestSenderStub window + + let respondWith firstLineNumber contents = + ({ + FirstLineNumber = firstLineNumber + RequestedContents = contents + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + [] member x.``Set up``() = requestSenderStub.reset() @@ -58,107 +68,75 @@ type ``Scrolling``() = [] member x.``up when we are already at the top of the file should do nothing``() = let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - ({ - FirstLineNumber = 4 - RequestedContents = ["d"; "e"; "f"] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 4 ["d"; "e"; "f"] Move.Backward 3 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowBefore, noMessage) [] member x.``up one line when the top line is two should work``() = let windowBefore = { Window.defaultWindowView with Buffer = ["b"; "c"; "d"; "e"; "f"]; TopLineNumber = 2 } let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - ({ - FirstLineNumber = 1 - RequestedContents = ["a"; "b"; "c"; "d"; "e"; "f"] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] Move.Backward 1 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) [] member x.``up three lines when the top line is four should go to the top of the file``() = let windowBefore = { Window.defaultWindowView with Buffer = ["d"; "e"; "f"]; TopLineNumber = 4 } let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - ({ - FirstLineNumber = 1 - RequestedContents = ["a"; "b"; "c"; "d"; "e"; "f"] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] Move.Backward 3 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) [] member x.``up four lines when the top line is three should go to the top of the file``() = let windowBefore = { Window.defaultWindowView with Buffer = ["d"; "e"; "f"]; TopLineNumber = 3 } let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - ({ - FirstLineNumber = 1 - RequestedContents = ["a"; "b"; "c"; "d"; "e"; "f"] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] Move.Backward 4 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) [] member x.``up when the buffer is empty should do nothing``() = let windowBefore = Window.defaultWindowView - ({ - FirstLineNumber = 1 - RequestedContents = [] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 1 [] Move.Backward 1 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowBefore, noMessage) [] member x.``down when the buffer is empty should do nothing``() = let windowBefore = Window.defaultWindowView - ({ - FirstLineNumber = 1 - RequestedContents = [] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 1 [] Move.Forward 1 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowBefore, noMessage) [] member x.``down when only the last line of the buffer is showing should do nothing``() = let windowBefore = { Window.defaultWindowView with TopLineNumber = 6; Buffer = ["f"] } - ({ - FirstLineNumber = 7 - RequestedContents = [] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 7 [] Move.Forward 1 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowBefore, noMessage) [] member x.``down multiple lines from the top``() = let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } let windowAfter = { windowBefore with TopLineNumber = 4; Buffer = ["d"; "e"; "f"] } - ({ - FirstLineNumber = 4 - RequestedContents = ["d"; "e"; "f"] - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + respondWith 4 ["d"; "e"; "f"] Move.Forward 3 - |> VMCommand.Scroll - |> Window.handleVMCommand requestSenderStub windowBefore + |> scroll windowBefore |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) From 7310e7435c320459c2925fd98d367472fb82fc43 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 3 Sep 2015 12:49:22 -0400 Subject: [PATCH 24/28] My tests are vacuous. Grr. Committing before I begin to get in too deep. --- src/Void.ViewModel.Spec/WindowSpec.fs | 99 +++++++++++++++++++++++++-- src/Void.ViewModel/Window.fs | 7 ++ 2 files changed, 100 insertions(+), 6 deletions(-) diff --git a/src/Void.ViewModel.Spec/WindowSpec.fs b/src/Void.ViewModel.Spec/WindowSpec.fs index 97235cf..b679245 100644 --- a/src/Void.ViewModel.Spec/WindowSpec.fs +++ b/src/Void.ViewModel.Spec/WindowSpec.fs @@ -8,6 +8,13 @@ open System.Linq open NUnit.Framework open FsUnit +[] +module Assertions = + let shouldEqual expected actual = + printfn "Expected: %A" expected + printfn "Actual: %A" actual + should equal expected actual + [] type ``Constructing a buffer view model from a sequence of text lines``() = let asViewModelBuffer = Window.bufferFrom { Rows = 25; Columns = 80 } @@ -43,14 +50,9 @@ type ``Constructing a buffer view model from a sequence of text lines``() = |> should equal (Seq.toList <| Enumerable.Repeat("line", 25)) [] -type ``Scrolling``() = +type ``Scrolling (by line)``() = let requestSenderStub = CannedResponseRequestSender() - let shouldEqual expected actual = - printfn "Expected: %A" expected - printfn "Actual: %A" actual - should equal expected actual - let scroll window movement = VMCommand.Scroll movement |> Window.handleVMCommand requestSenderStub window @@ -140,3 +142,88 @@ type ``Scrolling``() = Move.Forward 3 |> scroll windowBefore |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) + +[] +type ``Scrolling (by half screen)``() = + let requestSenderStub = CannedResponseRequestSender() + + let scrollHalf window movement = + VMCommand.ScrollHalf movement + |> Window.handleVMCommand requestSenderStub window + + let respondWith firstLineNumber contents = + ({ + FirstLineNumber = firstLineNumber + RequestedContents = contents + } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + + [] + member x.``Set up``() = + requestSenderStub.reset() + + [] + member x.``up when we are already at the top of the file should do nothing``() = + let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + respondWith 4 ["d"; "e"; "f"] + + Move.Backward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowBefore, noMessage) + + [] + member x.``up half a screen height when the top line is two should go to the top of the file``() = + let windowBefore = { Window.defaultWindowView with Buffer = ["b"; "c"; "d"; "e"; "f"]; TopLineNumber = 2 } + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] + + Move.Backward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) + + [] + member x.``up when the buffer is empty should do nothing``() = + let windowBefore = Window.defaultWindowView + respondWith 1 [] + + Move.Backward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowBefore, noMessage) + + [] + member x.``down when the buffer is empty should do nothing``() = + let windowBefore = Window.defaultWindowView + respondWith 1 [] + + Move.Forward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowBefore, noMessage) + + [] + member x.``down when only the last line of the buffer is showing should do nothing``() = + let windowBefore = { Window.defaultWindowView with TopLineNumber = 6; Buffer = ["f"] } + respondWith 7 [] + + Move.Forward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowBefore, noMessage) + + [] + member x.``down when less than half a screen is showing should leave last line showing``() = + let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + let windowAfter = { windowBefore with TopLineNumber = 6; Buffer = ["f"] } + respondWith 6 ["f"] + + Move.Forward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) + + [] + member x.``down when exactly half a screen is showing should leave the last line showing``() = + let dimensions = { Rows = 12; Columns = 60 } + let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"]; Dimensions = dimensions } + let windowAfter = { windowBefore with TopLineNumber = 6; Buffer = ["f"] } + respondWith 6 ["f"] + + Move.Forward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index 3e26b44..34019da 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -45,6 +45,9 @@ module Window = let defaultWindowView = { zeroWindowView with Dimensions = Sizing.defaultViewSize } + let private linesInWindow window = + window.Buffer.Length*1 + let bufferFrom (windowSize : Dimensions) lines = let truncateToWindowWidth = StringUtil.noLongerThan windowSize.Columns lines @@ -80,6 +83,10 @@ module Window = then scroll requestSender window -xLines else noScroll | Move.Forward xLines -> + (*let scrollAmount = + if linesInWindow window > xLines + then xLines + else linesInWindow window - 1*) if window.Buffer.Length > 1 then scroll requestSender window xLines else noScroll From 66584d4fcf1175c47b5a5c33818395ce87b2f1cf Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 3 Sep 2015 13:06:18 -0400 Subject: [PATCH 25/28] Break down the bus implementation with composition Making the former "bus implementation" just a facade for the messaging system which implements the bus interface. --- src/Void.Core/BaseMessageTypes.fs | 1 + src/Void.UI/MainForm.cs | 4 +- src/Void/DefaultNormalModeBindings.fs | 8 +-- src/Void/Init.fs | 4 +- src/Void/Messaging.fs | 94 ++++++++++++++++----------- 5 files changed, 65 insertions(+), 46 deletions(-) diff --git a/src/Void.Core/BaseMessageTypes.fs b/src/Void.Core/BaseMessageTypes.fs index 6ddb008..7400377 100644 --- a/src/Void.Core/BaseMessageTypes.fs +++ b/src/Void.Core/BaseMessageTypes.fs @@ -37,6 +37,7 @@ type PackagedRequestSender = abstract member makePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> : 'TPackagedRequest -> 'TPackagedResponse option type Bus = + abstract member publish : Message -> unit abstract member subscribe<'TMsg when 'TMsg :> Message> : Handle<'TMsg> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : HandleRequest<'TRequest, 'TResponse> -> unit abstract member subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> : MaybeHandleRequest<'TRequest, 'TResponse> -> unit diff --git a/src/Void.UI/MainForm.cs b/src/Void.UI/MainForm.cs index 095e2df..ff05301 100644 --- a/src/Void.UI/MainForm.cs +++ b/src/Void.UI/MainForm.cs @@ -11,14 +11,14 @@ namespace Void.UI { public partial class MainForm : Form { - private readonly BusImpl _bus; + private readonly Bus _bus; private readonly WinFormsInputModeChanger _inputModeChanger; private readonly List _drawings = new List(); private Font _font = new Font(FontFamily.GenericMonospace, 9); private CellMetrics _cellMetrics; - public MainForm(BusImpl bus, WinFormsInputModeChanger inputModeChanger) + public MainForm(Bus bus, WinFormsInputModeChanger inputModeChanger) { _bus = bus; _inputModeChanger = inputModeChanger; diff --git a/src/Void/DefaultNormalModeBindings.fs b/src/Void/DefaultNormalModeBindings.fs index 60bf545..4d896f4 100644 --- a/src/Void/DefaultNormalModeBindings.fs +++ b/src/Void/DefaultNormalModeBindings.fs @@ -47,15 +47,15 @@ module DefaultNormalModeBindings = let bindAllCommands bindings = Seq.map NormalModeBindings.Command.Bind bindings - let handleCommand (bus : BusImpl) command = + let handleCommand (bus : Bus) command = match command with | CoreCommand.InitializeVoid -> - bindAllCommands voidBindings - |> bus.publishAll + for message in bindAllCommands voidBindings do + bus.publish message | _ -> () noMessage module Service = - let subscribe (bus : BusImpl) = + let subscribe (bus : Bus) = bus.subscribe (handleCommand bus) diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 58c5c9c..5539848 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -39,7 +39,7 @@ module Init = let buildVoid inputModeChanger (options : VoidOptions) = let editorService = EditorService() let viewModelService = ViewModelService() - let bus = BusImpl() + let bus = MessagingSystemFacade() :> Bus bus.subscribe editorService.handleCommand let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter @@ -67,5 +67,5 @@ module Init = RenderNotificationBar.Service.subscribe bus bus - let launchVoid (bus : BusImpl) = + let launchVoid (bus : Bus) = bus.publish CoreCommand.InitializeVoid diff --git a/src/Void/Messaging.fs b/src/Void/Messaging.fs index 1e7ab43..d8539f4 100644 --- a/src/Void/Messaging.fs +++ b/src/Void/Messaging.fs @@ -107,21 +107,13 @@ type PackagedRequestChannel<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackaged then Some <| box x.addHandler else None -type BusImpl() = +type MessageRouter() = let mutable _channels : Channel list = [] - let mutable _requestChannels : RequestChannel list = [] - let mutable _packagedRequestChannels : PackagedRequestChannel list = [] - member private x.addChannel channel = + member x.addChannel channel = _channels <- channel :: _channels - member private x.addRequestChannel requestChannel = - _requestChannels <- requestChannel :: _requestChannels - - member private x.addPackagedRequestChannel packagedRequestChannel = - _packagedRequestChannels <- packagedRequestChannel :: _packagedRequestChannels - - member x.publishAll messages = + member private x.publishAll messages = for message in messages do x.publish message @@ -131,26 +123,6 @@ type BusImpl() = for channel in _channels do channel.publish message |> x.publishAll - member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> request = - let tryGetRequestFunction (channel : RequestChannel) = - channel.getBoxedRequestFunctionIfResponseTypeIs<'TResponse>() - match List.tryPick tryGetRequestFunction _requestChannels with - | Some makeRequest -> - request - |> unbox> makeRequest - | None -> - None - - member x.makePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> request = - let tryGetRequestFunction (channel : PackagedRequestChannel) = - channel.getBoxedRequestFunctionIfResponseTypeIs<'TPackagedResponse>() - match List.tryPick tryGetRequestFunction _packagedRequestChannels with - | Some makeRequest -> - request - |> unbox> makeRequest - | None -> - None - member x.subscribe<'TMsg when 'TMsg :> Message> (handle : Handle<'TMsg>) = let tryGetSubscribeAction (channel : Channel) = channel.getBoxedSubscribeActionIfTypeIs<'TMsg>() @@ -161,6 +133,22 @@ type BusImpl() = | None -> x.addChannel <| Channel [ handle ] +type RequestRouter() = + let mutable _requestChannels : RequestChannel list = [] + + member x.addRequestChannel requestChannel = + _requestChannels <- requestChannel :: _requestChannels + + member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> request = + let tryGetRequestFunction (channel : RequestChannel) = + channel.getBoxedRequestFunctionIfResponseTypeIs<'TResponse>() + match List.tryPick tryGetRequestFunction _requestChannels with + | Some makeRequest -> + request + |> unbox> makeRequest + | None -> + None + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = let tryGetSubscribeAction (channel : RequestChannel) = channel.getBoxedSubscribeActionIfResponseTypeIs<'TResponse>() @@ -174,6 +162,22 @@ type BusImpl() = member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest (handleRequest >> Some) +type PackagedRequestRouter() = + let mutable _packagedRequestChannels : PackagedRequestChannel list = [] + + member x.addPackagedRequestChannel packagedRequestChannel = + _packagedRequestChannels <- packagedRequestChannel :: _packagedRequestChannels + + member x.makePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> request = + let tryGetRequestFunction (channel : PackagedRequestChannel) = + channel.getBoxedRequestFunctionIfResponseTypeIs<'TPackagedResponse>() + match List.tryPick tryGetRequestFunction _packagedRequestChannels with + | Some makeRequest -> + request + |> unbox> makeRequest + | None -> + None + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = let tryGetSubscribeAction (channel : RequestChannel) = channel.getBoxedSubscribeActionIfResponseTypeIs<'TPackagedResponse>() @@ -187,11 +191,25 @@ type BusImpl() = member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = x.subscribeToPackagedRequest (handlePackagedRequest >> Some) +type MessagingSystemFacade() = + let messageRouter = MessageRouter() + let requestRouter = RequestRouter() + let packagedRequestRouter = PackagedRequestRouter() + interface Bus with - member x.makeRequest request = x.makeRequest request - member x.makePackagedRequest request = x.makePackagedRequest request - member x.subscribe handle = x.subscribe handle - member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest maybeHandleRequest - member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = x.subscribeToRequest handleRequest - member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = x.subscribeToPackagedRequest handlePackagedRequest - member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = x.subscribeToPackagedRequest maybeHandlePackagedRequest + member x.publish message = + messageRouter.publish message + member x.makeRequest request = + requestRouter.makeRequest request + member x.makePackagedRequest request = + packagedRequestRouter.makePackagedRequest request + member x.subscribe handle = + messageRouter.subscribe handle + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = + requestRouter.subscribeToRequest maybeHandleRequest + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = + requestRouter.subscribeToRequest handleRequest + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + packagedRequestRouter.subscribeToPackagedRequest handlePackagedRequest + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + packagedRequestRouter.subscribeToPackagedRequest maybeHandlePackagedRequest From 854f952c6468ea058f7da2000f57c1fcec0e7903 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 3 Sep 2015 13:17:24 -0400 Subject: [PATCH 26/28] Make all messaging system types private & only expose Bus interface and move the messaging code to Void.Core so anything can use it (while at the same time providing loose coupling for the potential of future extraction of Void.Messaging). --- src/Void.Core/Messaging.fs | 216 +++++++++++++++++++++++++++++++++ src/Void.Core/Void.Core.fsproj | 1 + src/Void/Init.fs | 2 +- src/Void/Messaging.fs | 215 -------------------------------- src/Void/Void.fsproj | 1 - 5 files changed, 218 insertions(+), 217 deletions(-) create mode 100644 src/Void.Core/Messaging.fs delete mode 100644 src/Void/Messaging.fs diff --git a/src/Void.Core/Messaging.fs b/src/Void.Core/Messaging.fs new file mode 100644 index 0000000..88f762a --- /dev/null +++ b/src/Void.Core/Messaging.fs @@ -0,0 +1,216 @@ +namespace Void.Core + +module Messaging = + type private Channel = + abstract member publish : Message -> Message seq + (* F# Why you no have type classes like Haskell!?!?! + * Now I will do ugly things, with long names! *) + abstract member getBoxedSubscribeActionIfTypeIs<'TMsg> : unit -> obj option + + type private Channel<'TIn when 'TIn :> Message> + ( + handlers : Handle<'TIn> list + ) = + let mutable _handlers = handlers + + member private x.safetyWrap handle message = + try + handle message + with ex -> + printf "Error while handling %A: %A" message ex + noMessage + + member x.addHandler handler = + _handlers <- x.safetyWrap handler :: _handlers + + interface Channel with + member x.publish (message : Message) = + match message with + | :? 'TIn as msg -> + Seq.map (fun handle -> handle msg) _handlers + |> Seq.filter (fun msg -> msg <> noMessage) + | _ -> Seq.empty + + member x.getBoxedSubscribeActionIfTypeIs<'TMsg>() = + if typeof<'TIn> = typeof<'TMsg> + then Some <| box x.addHandler + else None + + type private RequestChannel = + (* F# Why you no have type classes like Haskell!?!?! + * Now I will do ugly things, with long names! *) + abstract member getBoxedRequestFunctionIfResponseTypeIs<'TMsg> : unit -> obj option + abstract member getBoxedSubscribeActionIfResponseTypeIs<'TMsg> : unit -> obj option + + type private RequestChannel<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> + ( + handlers : MaybeHandleRequest<'TRequest, 'TResponse> list + ) = + let mutable _handlers = handlers + + member private x.safetyWrap handle message = + try + handle message + with ex -> + printf "Error while handling %A: %A" message ex + None + + member x.addHandler handler = + _handlers <- x.safetyWrap handler :: _handlers + + member x.makeRequest requestMsg = + Seq.tryPick (fun handle -> handle requestMsg) handlers + + interface RequestChannel with + member x.getBoxedRequestFunctionIfResponseTypeIs<'TMsg>() = + if typeof<'TResponse> = typeof<'TMsg> + then Some <| box x.makeRequest + else None + + member x.getBoxedSubscribeActionIfResponseTypeIs<'TMsg>() = + if typeof<'TResponse> = typeof<'TMsg> + then Some <| box x.addHandler + else None + + type private PackagedRequestChannel = + inherit RequestChannel + + type private PackagedRequestChannel<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> + ( + handlers : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> list + ) = + let mutable _handlers = handlers + + member private x.safetyWrap handle message = + try + handle message + with ex -> + printf "Error while handling %A: %A" message ex + None + + member x.addHandler handler = + _handlers <- x.safetyWrap handler :: _handlers + + member x.makeRequest packagedRequestMsg = + Seq.tryPick (fun handle -> handle packagedRequestMsg) handlers + + interface PackagedRequestChannel with + member x.getBoxedRequestFunctionIfResponseTypeIs<'TMsg>() = + if typeof<'TPackagedResponse> = typeof<'TMsg> + then Some <| box x.makeRequest + else None + + member x.getBoxedSubscribeActionIfResponseTypeIs<'TMsg>() = + if typeof<'TPackagedResponse> = typeof<'TMsg> + then Some <| box x.addHandler + else None + + type private MessageRouter() = + let mutable _channels : Channel list = [] + + member x.addChannel channel = + _channels <- channel :: _channels + + member private x.publishAll messages = + for message in messages do + x.publish message + + member x.publish (message : Message) = + if message <> noMessage + then + for channel in _channels do + channel.publish message |> x.publishAll + + member x.subscribe<'TMsg when 'TMsg :> Message> (handle : Handle<'TMsg>) = + let tryGetSubscribeAction (channel : Channel) = + channel.getBoxedSubscribeActionIfTypeIs<'TMsg>() + match List.tryPick tryGetSubscribeAction _channels with + | Some subscribe -> + handle + |> unbox -> unit> subscribe + | None -> + x.addChannel <| Channel [ handle ] + + type private RequestRouter() = + let mutable _requestChannels : RequestChannel list = [] + + member x.addRequestChannel requestChannel = + _requestChannels <- requestChannel :: _requestChannels + + member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> request = + let tryGetRequestFunction (channel : RequestChannel) = + channel.getBoxedRequestFunctionIfResponseTypeIs<'TResponse>() + match List.tryPick tryGetRequestFunction _requestChannels with + | Some makeRequest -> + request + |> unbox> makeRequest + | None -> + None + + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = + let tryGetSubscribeAction (channel : RequestChannel) = + channel.getBoxedSubscribeActionIfResponseTypeIs<'TResponse>() + match List.tryPick tryGetSubscribeAction _requestChannels with + | Some subscribe -> + maybeHandleRequest + |> unbox -> unit> subscribe + | None -> + x.addRequestChannel <| RequestChannel<'TRequest, 'TResponse> [ maybeHandleRequest ] + + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = + x.subscribeToRequest (handleRequest >> Some) + + type private PackagedRequestRouter() = + let mutable _packagedRequestChannels : PackagedRequestChannel list = [] + + member x.addPackagedRequestChannel packagedRequestChannel = + _packagedRequestChannels <- packagedRequestChannel :: _packagedRequestChannels + + member x.makePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> request = + let tryGetRequestFunction (channel : PackagedRequestChannel) = + channel.getBoxedRequestFunctionIfResponseTypeIs<'TPackagedResponse>() + match List.tryPick tryGetRequestFunction _packagedRequestChannels with + | Some makeRequest -> + request + |> unbox> makeRequest + | None -> + None + + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + let tryGetSubscribeAction (channel : RequestChannel) = + channel.getBoxedSubscribeActionIfResponseTypeIs<'TPackagedResponse>() + match List.tryPick tryGetSubscribeAction _packagedRequestChannels with + | Some subscribe -> + maybeHandlePackagedRequest + |> unbox -> unit> subscribe + | None -> + x.addPackagedRequestChannel <| PackagedRequestChannel<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> [ maybeHandlePackagedRequest ] + + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + x.subscribeToPackagedRequest (handlePackagedRequest >> Some) + + type private MessagingSystemFacade() = + let messageRouter = MessageRouter() + let requestRouter = RequestRouter() + let packagedRequestRouter = PackagedRequestRouter() + + interface Bus with + member x.publish message = + messageRouter.publish message + member x.makeRequest request = + requestRouter.makeRequest request + member x.makePackagedRequest request = + packagedRequestRouter.makePackagedRequest request + member x.subscribe handle = + messageRouter.subscribe handle + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = + requestRouter.subscribeToRequest maybeHandleRequest + member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = + requestRouter.subscribeToRequest handleRequest + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + packagedRequestRouter.subscribeToPackagedRequest handlePackagedRequest + member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = + packagedRequestRouter.subscribeToPackagedRequest maybeHandlePackagedRequest + + let newBus() = + MessagingSystemFacade() :> Bus diff --git a/src/Void.Core/Void.Core.fsproj b/src/Void.Core/Void.Core.fsproj index 1b53f6b..b8f46e4 100644 --- a/src/Void.Core/Void.Core.fsproj +++ b/src/Void.Core/Void.Core.fsproj @@ -48,6 +48,7 @@ + diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 5539848..4030c66 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -39,7 +39,7 @@ module Init = let buildVoid inputModeChanger (options : VoidOptions) = let editorService = EditorService() let viewModelService = ViewModelService() - let bus = MessagingSystemFacade() :> Bus + let bus = Messaging.newBus() bus.subscribe editorService.handleCommand let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter diff --git a/src/Void/Messaging.fs b/src/Void/Messaging.fs deleted file mode 100644 index d8539f4..0000000 --- a/src/Void/Messaging.fs +++ /dev/null @@ -1,215 +0,0 @@ -namespace Void - -open Void.Core -open Void.ViewModel - -type Channel = - abstract member publish : Message -> Message seq - (* F# Why you no have type classes like Haskell!?!?! - * Now I will do ugly things, with long names! *) - abstract member getBoxedSubscribeActionIfTypeIs<'TMsg> : unit -> obj option - -type Channel<'TIn when 'TIn :> Message> - ( - handlers : Handle<'TIn> list - ) = - let mutable _handlers = handlers - - member private x.safetyWrap handle message = - try - handle message - with ex -> - printf "Error while handling %A: %A" message ex - noMessage - - member x.addHandler handler = - _handlers <- x.safetyWrap handler :: _handlers - - interface Channel with - member x.publish (message : Message) = - match message with - | :? 'TIn as msg -> - Seq.map (fun handle -> handle msg) _handlers - |> Seq.filter (fun msg -> msg <> noMessage) - | _ -> Seq.empty - - member x.getBoxedSubscribeActionIfTypeIs<'TMsg>() = - if typeof<'TIn> = typeof<'TMsg> - then Some <| box x.addHandler - else None - -type RequestChannel = - (* F# Why you no have type classes like Haskell!?!?! - * Now I will do ugly things, with long names! *) - abstract member getBoxedRequestFunctionIfResponseTypeIs<'TMsg> : unit -> obj option - abstract member getBoxedSubscribeActionIfResponseTypeIs<'TMsg> : unit -> obj option - -type RequestChannel<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> - ( - handlers : MaybeHandleRequest<'TRequest, 'TResponse> list - ) = - let mutable _handlers = handlers - - member private x.safetyWrap handle message = - try - handle message - with ex -> - printf "Error while handling %A: %A" message ex - None - - member x.addHandler handler = - _handlers <- x.safetyWrap handler :: _handlers - - member x.makeRequest requestMsg = - Seq.tryPick (fun handle -> handle requestMsg) handlers - - interface RequestChannel with - member x.getBoxedRequestFunctionIfResponseTypeIs<'TMsg>() = - if typeof<'TResponse> = typeof<'TMsg> - then Some <| box x.makeRequest - else None - - member x.getBoxedSubscribeActionIfResponseTypeIs<'TMsg>() = - if typeof<'TResponse> = typeof<'TMsg> - then Some <| box x.addHandler - else None - -type PackagedRequestChannel = - inherit RequestChannel - -type PackagedRequestChannel<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> - ( - handlers : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> list - ) = - let mutable _handlers = handlers - - member private x.safetyWrap handle message = - try - handle message - with ex -> - printf "Error while handling %A: %A" message ex - None - - member x.addHandler handler = - _handlers <- x.safetyWrap handler :: _handlers - - member x.makeRequest packagedRequestMsg = - Seq.tryPick (fun handle -> handle packagedRequestMsg) handlers - - interface PackagedRequestChannel with - member x.getBoxedRequestFunctionIfResponseTypeIs<'TMsg>() = - if typeof<'TPackagedResponse> = typeof<'TMsg> - then Some <| box x.makeRequest - else None - - member x.getBoxedSubscribeActionIfResponseTypeIs<'TMsg>() = - if typeof<'TPackagedResponse> = typeof<'TMsg> - then Some <| box x.addHandler - else None - -type MessageRouter() = - let mutable _channels : Channel list = [] - - member x.addChannel channel = - _channels <- channel :: _channels - - member private x.publishAll messages = - for message in messages do - x.publish message - - member x.publish (message : Message) = - if message <> noMessage - then - for channel in _channels do - channel.publish message |> x.publishAll - - member x.subscribe<'TMsg when 'TMsg :> Message> (handle : Handle<'TMsg>) = - let tryGetSubscribeAction (channel : Channel) = - channel.getBoxedSubscribeActionIfTypeIs<'TMsg>() - match List.tryPick tryGetSubscribeAction _channels with - | Some subscribe -> - handle - |> unbox -> unit> subscribe - | None -> - x.addChannel <| Channel [ handle ] - -type RequestRouter() = - let mutable _requestChannels : RequestChannel list = [] - - member x.addRequestChannel requestChannel = - _requestChannels <- requestChannel :: _requestChannels - - member x.makeRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> request = - let tryGetRequestFunction (channel : RequestChannel) = - channel.getBoxedRequestFunctionIfResponseTypeIs<'TResponse>() - match List.tryPick tryGetRequestFunction _requestChannels with - | Some makeRequest -> - request - |> unbox> makeRequest - | None -> - None - - member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = - let tryGetSubscribeAction (channel : RequestChannel) = - channel.getBoxedSubscribeActionIfResponseTypeIs<'TResponse>() - match List.tryPick tryGetSubscribeAction _requestChannels with - | Some subscribe -> - maybeHandleRequest - |> unbox -> unit> subscribe - | None -> - x.addRequestChannel <| RequestChannel<'TRequest, 'TResponse> [ maybeHandleRequest ] - - member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = - x.subscribeToRequest (handleRequest >> Some) - -type PackagedRequestRouter() = - let mutable _packagedRequestChannels : PackagedRequestChannel list = [] - - member x.addPackagedRequestChannel packagedRequestChannel = - _packagedRequestChannels <- packagedRequestChannel :: _packagedRequestChannels - - member x.makePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> request = - let tryGetRequestFunction (channel : PackagedRequestChannel) = - channel.getBoxedRequestFunctionIfResponseTypeIs<'TPackagedResponse>() - match List.tryPick tryGetRequestFunction _packagedRequestChannels with - | Some makeRequest -> - request - |> unbox> makeRequest - | None -> - None - - member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = - let tryGetSubscribeAction (channel : RequestChannel) = - channel.getBoxedSubscribeActionIfResponseTypeIs<'TPackagedResponse>() - match List.tryPick tryGetSubscribeAction _packagedRequestChannels with - | Some subscribe -> - maybeHandlePackagedRequest - |> unbox -> unit> subscribe - | None -> - x.addPackagedRequestChannel <| PackagedRequestChannel<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse> [ maybeHandlePackagedRequest ] - - member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = - x.subscribeToPackagedRequest (handlePackagedRequest >> Some) - -type MessagingSystemFacade() = - let messageRouter = MessageRouter() - let requestRouter = RequestRouter() - let packagedRequestRouter = PackagedRequestRouter() - - interface Bus with - member x.publish message = - messageRouter.publish message - member x.makeRequest request = - requestRouter.makeRequest request - member x.makePackagedRequest request = - packagedRequestRouter.makePackagedRequest request - member x.subscribe handle = - messageRouter.subscribe handle - member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (maybeHandleRequest : MaybeHandleRequest<'TRequest, 'TResponse>) = - requestRouter.subscribeToRequest maybeHandleRequest - member x.subscribeToRequest<'TRequest, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> (handleRequest : HandleRequest<'TRequest, 'TResponse>) = - requestRouter.subscribeToRequest handleRequest - member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (handlePackagedRequest : HandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = - packagedRequestRouter.subscribeToPackagedRequest handlePackagedRequest - member x.subscribeToPackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest> and 'TPackagedRequest :> EnvelopeMessage<'TRequest> and 'TPackagedResponse :> EnvelopeMessage<'TResponse>> (maybeHandlePackagedRequest : MaybeHandlePackagedRequest<'TRequest, 'TResponse, 'TPackagedRequest, 'TPackagedResponse>) = - packagedRequestRouter.subscribeToPackagedRequest maybeHandlePackagedRequest diff --git a/src/Void/Void.fsproj b/src/Void/Void.fsproj index cbf406e..c277d20 100644 --- a/src/Void/Void.fsproj +++ b/src/Void/Void.fsproj @@ -47,7 +47,6 @@ - From 89284af9133ef08089e173fee757ee218c3640e2 Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 10 Sep 2015 12:54:24 -0400 Subject: [PATCH 27/28] Made vacuous specs meaningful, which made them fail; got the failing specs passing by fixing the window scrolling code --- src/Void.ViewModel.Spec/WindowSpec.fs | 79 +++++++++++++-------------- src/Void.ViewModel/Window.fs | 16 ++++-- 2 files changed, 47 insertions(+), 48 deletions(-) diff --git a/src/Void.ViewModel.Spec/WindowSpec.fs b/src/Void.ViewModel.Spec/WindowSpec.fs index b679245..8f2aadb 100644 --- a/src/Void.ViewModel.Spec/WindowSpec.fs +++ b/src/Void.ViewModel.Spec/WindowSpec.fs @@ -51,26 +51,28 @@ type ``Constructing a buffer view model from a sequence of text lines``() = [] type ``Scrolling (by line)``() = - let requestSenderStub = CannedResponseRequestSender() + let buffer = ref [""] + let requestSender = + let handleRequest (request : GetWindowContentsRequest) = + { + FirstLineNumber = request.StartingAtLine + RequestedContents = Seq.skip (request.StartingAtLine/1 - 1) !buffer + } : GetWindowContentsResponse + let bus = Messaging.newBus() + bus.subscribeToRequest handleRequest + bus :> RequestSender let scroll window movement = VMCommand.Scroll movement - |> Window.handleVMCommand requestSenderStub window - - let respondWith firstLineNumber contents = - ({ - FirstLineNumber = firstLineNumber - RequestedContents = contents - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + |> Window.handleVMCommand requestSender window [] member x.``Set up``() = - requestSenderStub.reset() + buffer := ["a"; "b"; "c"; "d"; "e"; "f"] [] member x.``up when we are already at the top of the file should do nothing``() = - let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - respondWith 4 ["d"; "e"; "f"] + let windowBefore = { Window.defaultWindowView with Buffer = !buffer } Move.Backward 3 |> scroll windowBefore @@ -79,8 +81,7 @@ type ``Scrolling (by line)``() = [] member x.``up one line when the top line is two should work``() = let windowBefore = { Window.defaultWindowView with Buffer = ["b"; "c"; "d"; "e"; "f"]; TopLineNumber = 2 } - let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = !buffer } Move.Backward 1 |> scroll windowBefore @@ -89,8 +90,7 @@ type ``Scrolling (by line)``() = [] member x.``up three lines when the top line is four should go to the top of the file``() = let windowBefore = { Window.defaultWindowView with Buffer = ["d"; "e"; "f"]; TopLineNumber = 4 } - let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = !buffer } Move.Backward 3 |> scroll windowBefore @@ -99,8 +99,7 @@ type ``Scrolling (by line)``() = [] member x.``up four lines when the top line is three should go to the top of the file``() = let windowBefore = { Window.defaultWindowView with Buffer = ["d"; "e"; "f"]; TopLineNumber = 3 } - let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = !buffer } Move.Backward 4 |> scroll windowBefore @@ -108,8 +107,8 @@ type ``Scrolling (by line)``() = [] member x.``up when the buffer is empty should do nothing``() = + buffer := [] let windowBefore = Window.defaultWindowView - respondWith 1 [] Move.Backward 1 |> scroll windowBefore @@ -117,8 +116,8 @@ type ``Scrolling (by line)``() = [] member x.``down when the buffer is empty should do nothing``() = + buffer := [] let windowBefore = Window.defaultWindowView - respondWith 1 [] Move.Forward 1 |> scroll windowBefore @@ -127,7 +126,6 @@ type ``Scrolling (by line)``() = [] member x.``down when only the last line of the buffer is showing should do nothing``() = let windowBefore = { Window.defaultWindowView with TopLineNumber = 6; Buffer = ["f"] } - respondWith 7 [] Move.Forward 1 |> scroll windowBefore @@ -135,9 +133,8 @@ type ``Scrolling (by line)``() = [] member x.``down multiple lines from the top``() = - let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + let windowBefore = { Window.defaultWindowView with Buffer = !buffer } let windowAfter = { windowBefore with TopLineNumber = 4; Buffer = ["d"; "e"; "f"] } - respondWith 4 ["d"; "e"; "f"] Move.Forward 3 |> scroll windowBefore @@ -145,26 +142,28 @@ type ``Scrolling (by line)``() = [] type ``Scrolling (by half screen)``() = - let requestSenderStub = CannedResponseRequestSender() + let buffer = ref [""] + let requestSender = + let handleRequest (request : GetWindowContentsRequest) = + { + FirstLineNumber = request.StartingAtLine + RequestedContents = Seq.skip (request.StartingAtLine/1 - 1) !buffer + } : GetWindowContentsResponse + let bus = Messaging.newBus() + bus.subscribeToRequest handleRequest + bus :> RequestSender let scrollHalf window movement = VMCommand.ScrollHalf movement - |> Window.handleVMCommand requestSenderStub window - - let respondWith firstLineNumber contents = - ({ - FirstLineNumber = firstLineNumber - RequestedContents = contents - } : GetWindowContentsResponse) |> requestSenderStub.registerResponse + |> Window.handleVMCommand requestSender window [] member x.``Set up``() = - requestSenderStub.reset() + buffer := ["a"; "b"; "c"; "d"; "e"; "f"] [] member x.``up when we are already at the top of the file should do nothing``() = - let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - respondWith 4 ["d"; "e"; "f"] + let windowBefore = { Window.defaultWindowView with Buffer = !buffer } Move.Backward 1 |> scrollHalf windowBefore @@ -173,8 +172,7 @@ type ``Scrolling (by half screen)``() = [] member x.``up half a screen height when the top line is two should go to the top of the file``() = let windowBefore = { Window.defaultWindowView with Buffer = ["b"; "c"; "d"; "e"; "f"]; TopLineNumber = 2 } - let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } - respondWith 1 ["a"; "b"; "c"; "d"; "e"; "f"] + let windowAfter = { windowBefore with TopLineNumber = 1; Buffer = !buffer } Move.Backward 1 |> scrollHalf windowBefore @@ -182,8 +180,8 @@ type ``Scrolling (by half screen)``() = [] member x.``up when the buffer is empty should do nothing``() = + buffer := [] let windowBefore = Window.defaultWindowView - respondWith 1 [] Move.Backward 1 |> scrollHalf windowBefore @@ -191,8 +189,8 @@ type ``Scrolling (by half screen)``() = [] member x.``down when the buffer is empty should do nothing``() = + buffer := [] let windowBefore = Window.defaultWindowView - respondWith 1 [] Move.Forward 1 |> scrollHalf windowBefore @@ -201,7 +199,6 @@ type ``Scrolling (by half screen)``() = [] member x.``down when only the last line of the buffer is showing should do nothing``() = let windowBefore = { Window.defaultWindowView with TopLineNumber = 6; Buffer = ["f"] } - respondWith 7 [] Move.Forward 1 |> scrollHalf windowBefore @@ -209,9 +206,8 @@ type ``Scrolling (by half screen)``() = [] member x.``down when less than half a screen is showing should leave last line showing``() = - let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"] } + let windowBefore = { Window.defaultWindowView with Buffer = !buffer } let windowAfter = { windowBefore with TopLineNumber = 6; Buffer = ["f"] } - respondWith 6 ["f"] Move.Forward 1 |> scrollHalf windowBefore @@ -220,9 +216,8 @@ type ``Scrolling (by half screen)``() = [] member x.``down when exactly half a screen is showing should leave the last line showing``() = let dimensions = { Rows = 12; Columns = 60 } - let windowBefore = { Window.defaultWindowView with Buffer = ["a"; "b"; "c"; "d"; "e"; "f"]; Dimensions = dimensions } + let windowBefore = { Window.defaultWindowView with Buffer = !buffer; Dimensions = dimensions } let windowAfter = { windowBefore with TopLineNumber = 6; Buffer = ["f"] } - respondWith 6 ["f"] Move.Forward 1 |> scrollHalf windowBefore diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs index 34019da..b3a97f0 100644 --- a/src/Void.ViewModel/Window.fs +++ b/src/Void.ViewModel/Window.fs @@ -79,16 +79,20 @@ module Window = let noScroll = window, noMessage match movement with | Move.Backward xLines -> - if window.TopLineNumber > 1 - then scroll requestSender window -xLines + let scrollAmount = + if window.TopLineNumber > xLines + then xLines + else window.TopLineNumber - 1 + if scrollAmount > 0 + then scroll requestSender window -scrollAmount else noScroll | Move.Forward xLines -> - (*let scrollAmount = + let scrollAmount = if linesInWindow window > xLines then xLines - else linesInWindow window - 1*) - if window.Buffer.Length > 1 - then scroll requestSender window xLines + else linesInWindow window - 1 + if scrollAmount > 0 + then scroll requestSender window scrollAmount else noScroll let scrollHalfScreenHeights requestSender (window : WindowView) movement = From ac3fd3a76166479608f2eb9d8030a079034289de Mon Sep 17 00:00:00 2001 From: Kazark Date: Thu, 10 Sep 2015 20:17:55 -0400 Subject: [PATCH 28/28] Build the whole solution, not just .fsproj files The UI is in C#, so it wasn't building that --- build.fsx | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build.fsx b/build.fsx index 66a8347..390ce4a 100644 --- a/build.fsx +++ b/build.fsx @@ -17,7 +17,7 @@ Target "RestorePackages" (fun _ -> ) Target "Compile" (fun _ -> - !! "src/**/*.fsproj" + !! "src/Void.sln" |> MSBuildRelease buildDir "Build" |> Log "Compile-Output: " )