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: " ) diff --git a/src/Void.Core.Spec/CommandModeSpec.fs b/src/Void.Core.Spec/CommandModeSpec.fs index 02e6815..073d317 100644 --- a/src/Void.Core.Spec/CommandModeSpec.fs +++ b/src/Void.Core.Spec/CommandModeSpec.fs @@ -13,12 +13,17 @@ type ``Editing command mode``() = let enter = TextOrHotKey.HotKey HotKey.Enter let escape = TextOrHotKey.HotKey HotKey.Escape let backspace = TextOrHotKey.HotKey HotKey.Backspace + let requestSenderStub = CannedResponseRequestSender() let typeIncrement increment buffer expected = TextOrHotKey.Text increment - |> CommandMode.handle buffer + |> 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" @@ -27,49 +32,47 @@ type ``Editing command mode``() = typeIncrement "t" "edi" "edit" [] - member x.``When enter is pressed, the current language for command mode is requested``() = - CommandMode.handle "edit" enter - |> should equal ("edit", GetCurrentCommandLanguageRequest :> Message) + 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 ("", 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.Event.NewlineAppended :> Message) [] 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) - - [] - 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.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.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/BaseMessageTypes.fs b/src/Void.Core/BaseMessageTypes.fs index 6f0265d..7400377 100644 --- a/src/Void.Core/BaseMessageTypes.fs +++ b/src/Void.Core/BaseMessageTypes.fs @@ -5,36 +5,43 @@ 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 [] 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 NoResponseToRequest<'TRequest when 'TRequest :> RequestMessage> = - { - Request : 'TRequest - } - interface Message - 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, 'TResponse when 'TRequest :> RequestMessage and 'TResponse :> ResponseMessage<'TRequest>> = + 'TRequest -> 'TResponse option + +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 MaybeHandleRequest<'TRequest when 'TRequest :> RequestMessage> = - 'TRequest -> ResponseMessage<'TRequest> option +type RequestSender = + abstract member makeRequest<'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 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 SubscribeToBus = +type Bus = + abstract member publish : Message -> unit 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 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.Core/BufferList.fs b/src/Void.Core/BufferList.fs index 1de7d95..8285dc6 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 @@ -13,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 @@ -36,13 +43,17 @@ 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; 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) @@ -72,10 +83,33 @@ module BufferList = | CoreCommand.WriteBufferToPath (bufferId, path) -> writeBufferToPath bufferList bufferId path | _ -> - (bufferList, noMessage) + 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 + |> Some + 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 + Service.wrap bufferList handleCommand |> bus.subscribe + Service.wrap bufferList handleEvent |> bus.subscribe + handleGetBufferContentsRequest bufferList |> bus.subscribeToPackagedRequest 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/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/CommandHistory.fs b/src/Void.Core/CommandHistory.fs index eb413b4..bc984c7 100644 --- a/src/Void.Core/CommandHistory.fs +++ b/src/Void.Core/CommandHistory.fs @@ -56,12 +56,10 @@ module CommandHistory = move previous history | CommandHistoryCommand.MoveToNextCommand -> move next history - | _ -> - (history, noMessage) 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 824feec..0de4cc6 100644 --- a/src/Void.Core/CommandLanguage.fs +++ b/src/Void.Core/CommandLanguage.fs @@ -15,17 +15,20 @@ module CommandLanguage = let handleRequest language request = { CurrentCommandLanguage = !language - } :> ResponseMessage + } 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 (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 handleCoreEvent \ No newline at end of file diff --git a/src/Void.Core/CommandMode.fs b/src/Void.Core/CommandMode.fs index 3e84e55..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,23 +16,40 @@ module CommandMode = let private requestLanguageForInterpreting buffer = buffer, GetCurrentCommandLanguageRequest :> Message - let handleGetCurrentCommandLanguageResponse buffer response = + let private 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 private 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, Event.NewlineAppended :> Message + | None -> + "", CoreEvent.ErrorOccurred <| Error.NoInterpreter :> Message + + let private 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 +62,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 (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 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..9b16576 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 @@ -42,68 +41,6 @@ type CoreCommand = | Yank interface CommandMessage -[] -type BufferCommand = - | MoveCursor of Motion - interface CommandMessage - -type BufferCommandMessage = - { - BufferId : int - Command : BufferCommand - } - 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 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 - [] module ``This module is auto-opened to provide message aliases`` = let notImplemented = diff --git a/src/Void.Core/Filesystem.fs b/src/Void.Core/Filesystem.fs index 7bc531c..41faa7f 100644 --- a/src/Void.Core/Filesystem.fs +++ b/src/Void.Core/Filesystem.fs @@ -59,8 +59,7 @@ module Filesystem = else CoreEvent.NewFileForEditing path :> Message | Command.SaveToDisk (path, lines) -> writeLines path lines :> Message - | _ -> noMessage module Service = - let subscribe (subscribeHandler : SubscribeToBus) = - subscribeHandler.subscribe handleCommand + let subscribe (bus : Bus) = + bus.subscribe handleCommand 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..4218492 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 @@ -47,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 } @@ -90,30 +75,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/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/ModeService.fs b/src/Void.Core/ModeService.fs index 5fb4dd5..d4315ae 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, @@ -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 @@ -69,9 +70,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/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/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/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.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.Core/Void.Core.fsproj b/src/Void.Core/Void.Core.fsproj index e25f847..b8f46e4 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 + @@ -44,12 +48,18 @@ + + - + + + + - + + 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/MainForm.cs b/src/Void.UI/MainForm.cs index f3588e0..ff05301 100644 --- a/src/Void.UI/MainForm.cs +++ b/src/Void.UI/MainForm.cs @@ -13,9 +13,9 @@ public partial class MainForm : Form { 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; - private IEnumerable _drawings; public MainForm(Bus 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 { 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.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/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/RenderWindowsSpec.fs similarity index 67% rename from src/Void.ViewModel.Spec/RenderSpec.fs rename to src/Void.ViewModel.Spec/RenderWindowsSpec.fs index 90336e6..f21e165 100644 --- a/src/Void.ViewModel.Spec/RenderSpec.fs +++ b/src/Void.ViewModel.Spec/RenderWindowsSpec.fs @@ -11,49 +11,16 @@ 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 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 = { - UpperLeftCell = originCell - Dimensions = { Rows = 25; Columns = 80 } - } - - let render = Render.bufferAsDrawingObjects windowArea + let render = RenderWindows.contentsAsDrawingObjects { Rows = 25; Columns = 80 } let shouldAllBeTildes drawingObjects = drawingObjects |> Seq.mapi (fun i drawingObject -> @@ -72,14 +39,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 { @@ -91,7 +58,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 { @@ -109,7 +76,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/ViewModelSpec.fs b/src/Void.ViewModel.Spec/ViewModelSpec.fs deleted file mode 100644 index 59aee57..0000000 --- a/src/Void.ViewModel.Spec/ViewModelSpec.fs +++ /dev/null @@ -1,42 +0,0 @@ -namespace Void.ViewModel.Spec - -open Void.ViewModel -open Void.Core.CellGrid -open System -open System.Linq -open NUnit.Framework -open FsUnit - -[] -type ``Constructing a buffer view model from a sequence of text lines``() = - let asViewModelBuffer = ViewModel.bufferFrom { Rows = 25; Columns = 80 } - - [] - member x.``should create an empty buffer view model from an empty buffer``() = - asViewModelBuffer Seq.empty - |> should equal { LinesOfText = [] } - - [] - 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"] } - - [] - 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)] } - - [] - 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)] } - - [] - 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) } diff --git a/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj b/src/Void.ViewModel.Spec/Void.ViewModel.Spec.fsproj index b608a8f..1c62241 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 @@ -54,9 +58,10 @@ - + - + + diff --git a/src/Void.ViewModel.Spec/WindowSpec.fs b/src/Void.ViewModel.Spec/WindowSpec.fs new file mode 100644 index 0000000..8f2aadb --- /dev/null +++ b/src/Void.ViewModel.Spec/WindowSpec.fs @@ -0,0 +1,224 @@ +namespace Void.ViewModel.Spec + +open Void.ViewModel +open Void.Core +open Void.Core.CellGrid +open System +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 } + + [] + member x.``should create an empty buffer view model from an empty buffer``() = + asViewModelBuffer Seq.empty + |> 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 ["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 [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 [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 (Seq.toList <| Enumerable.Repeat("line", 25)) + +[] +type ``Scrolling (by line)``() = + 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 requestSender window + + [] + member x.``Set up``() = + 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 = !buffer } + + Move.Backward 3 + |> 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 = !buffer } + + Move.Backward 1 + |> 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 = !buffer } + + Move.Backward 3 + |> 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 = !buffer } + + Move.Backward 4 + |> scroll windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) + + [] + member x.``up when the buffer is empty should do nothing``() = + buffer := [] + let windowBefore = Window.defaultWindowView + + Move.Backward 1 + |> scroll windowBefore + |> shouldEqual (windowBefore, noMessage) + + [] + member x.``down when the buffer is empty should do nothing``() = + buffer := [] + let windowBefore = Window.defaultWindowView + + Move.Forward 1 + |> 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"] } + + Move.Forward 1 + |> scroll windowBefore + |> shouldEqual (windowBefore, noMessage) + + [] + member x.``down multiple lines from the top``() = + let windowBefore = { Window.defaultWindowView with Buffer = !buffer } + let windowAfter = { windowBefore with TopLineNumber = 4; Buffer = ["d"; "e"; "f"] } + + Move.Forward 3 + |> scroll windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) + +[] +type ``Scrolling (by half screen)``() = + 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 requestSender window + + [] + member x.``Set up``() = + 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 = !buffer } + + 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 = !buffer } + + Move.Backward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) + + [] + member x.``up when the buffer is empty should do nothing``() = + buffer := [] + let windowBefore = Window.defaultWindowView + + Move.Backward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowBefore, noMessage) + + [] + member x.``down when the buffer is empty should do nothing``() = + buffer := [] + let windowBefore = Window.defaultWindowView + + 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"] } + + 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 = !buffer } + let windowAfter = { windowBefore with TopLineNumber = 6; Buffer = ["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 = !buffer; Dimensions = dimensions } + let windowAfter = { windowBefore with TopLineNumber = 6; Buffer = ["f"] } + + Move.Forward 1 + |> scrollHalf windowBefore + |> shouldEqual (windowAfter, Window.Event.ContentsUpdated windowAfter :> Message) diff --git a/src/Void.ViewModel/CommandBar.fs b/src/Void.ViewModel/CommandBar.fs index eeff9b1..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 @@ -19,6 +32,11 @@ module CommandBar = WrappedLines = [""] } + [] + type Command = + | Redraw of CommandBarView + interface CommandMessage + [] type Event = | CharacterBackspacedFromLine of CellGrid.Cell @@ -44,6 +62,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 @@ -81,18 +103,27 @@ 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 | 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 - let subscribe (subscribeHandler : SubscribeToBus) = + let subscribe (bus : Bus) = let commandBar = ref hidden - subscribeHandler.subscribe <| Service.wrap commandBar handleEvent - subscribeHandler.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/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/Render.fs b/src/Void.ViewModel/Render.fs deleted file mode 100644 index 9e90053..0000000 --- a/src/Void.ViewModel/Render.fs +++ /dev/null @@ -1,78 +0,0 @@ -namespace Void.ViewModel - -open Void.Core - -module Render = - open Void.Core.CellGrid - - let private textLineAsDrawingObject x line = - DrawingObject.Text { - Text = line - UpperLeftCorner = GridConvert.upperLeftCornerOf <| below originCell x - Color = Colors.defaultColorscheme.Foreground - } - - 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) = - let background = DrawingObject.Block { - Area = GridConvert.boxAround windowArea - Color = Colors.defaultColorscheme.Background - } - - let bufferLines = textLinesAsDrawingObjects buffer.LinesOfText - - let rowsNotInBuffer = - let lineNotInBufferAsDrawingObject i = - DrawingObject.Text { - Text = "~" - UpperLeftCorner = GridConvert.upperLeftCornerOf { Row = i; Column = 0 } - Color = Colors.defaultColorscheme.DimForeground - } - let linesWithNoTilde = - if bufferLines.Length = 0 - then 1 - else bufferLines.Length - [linesWithNoTilde..windowArea.Dimensions.Rows-1] - |> List.map lineNotInBufferAsDrawingObject - - List.append (background :: bufferLines) rowsNotInBuffer - - let windowsAsDrawingObjects (windows : WindowView list) = - bufferAsDrawingObjects windows.[0].Area windows.[0].Buffer - - let viewModelAsDrawingObjects viewModel = - [ - tabBarAsDrawingObjects viewModel.TabBar - windowsAsDrawingObjects viewModel.VisibleWindows - notificationsAsDrawingObjects viewModel.Size.Columns originCell viewModel.Notifications - ] |> Seq.concat - - let currentBufferAsDrawingObjects viewModel = - viewModel.VisibleWindows.[0].Buffer - |> bufferAsDrawingObjects viewModel.VisibleWindows.[0].Area - diff --git a/src/Void.ViewModel/RenderCommandBar.fs b/src/Void.ViewModel/RenderCommandBar.fs index 9061566..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,6 +70,47 @@ 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 = + match event with + | CommandBar.Event.CharacterBackspacedFromLine cell -> + backspacedCharacterAsDrawingObject cell !commandBarOrigin + |> VMEvent.ViewPortionRendered :> Message + | CommandBar.Event.Displayed commandBar -> + renderCommandBar commandBar commandBarOrigin + | CommandBar.Event.Hidden commandBar -> + renderCommandBar commandBar commandBarOrigin + | CommandBar.Event.TextAppendedToLine textSegment -> + appendedTextAsDrawingObject textSegment !commandBarOrigin + |> VMEvent.ViewPortionRendered :> Message + | CommandBar.Event.TextChanged commandBar -> + renderCommandBar commandBar commandBarOrigin + | CommandBar.Event.TextReflowed commandBar -> + renderCommandBar commandBar commandBarOrigin + + let handleCommandBarCommand commandBarOrigin (CommandBar.Command.Redraw commandBar) = + renderCommandBar commandBar commandBarOrigin + + [] + 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 + 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/RenderWindows.fs b/src/Void.ViewModel/RenderWindows.fs new file mode 100644 index 0000000..1faa1b5 --- /dev/null +++ b/src/Void.ViewModel/RenderWindows.fs @@ -0,0 +1,63 @@ +namespace Void.ViewModel + +module RenderWindows = + open Void.Core + open Void.Core.CellGrid + + let private textLineAsDrawingObject x line = + DrawingObject.Text { + Text = line + UpperLeftCorner = GridConvert.upperLeftCornerOf <| below originCell x + Color = Colors.defaultColorscheme.Foreground + } + + let textLinesAsDrawingObjects = + List.mapi textLineAsDrawingObject + + let contentsAsDrawingObjects dimensions (buffer : string list) = + let background = DrawingObject.Block { + Area = GridConvert.boxAround { UpperLeftCell = originCell; Dimensions = dimensions } + Color = Colors.defaultColorscheme.Background + } + + let bufferLines = textLinesAsDrawingObjects buffer + + let rowsNotInBuffer = + let lineNotInBufferAsDrawingObject i = + DrawingObject.Text { + Text = "~" + UpperLeftCorner = GridConvert.upperLeftCornerOf { Row = i; Column = 0 } + Color = Colors.defaultColorscheme.DimForeground + } + let linesWithNoTilde = + if bufferLines.Length = 0 + then 1 + else bufferLines.Length + [linesWithNoTilde..dimensions.Rows-1] + |> List.map lineNotInBufferAsDrawingObject + + List.append (background :: bufferLines) rowsNotInBuffer + + 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].Dimensions windows.[0].Buffer + ] |> Seq.concat + + let handleWindowEvent = + function + | Window.Event.ContentsUpdated window -> + renderWindow window + | Window.Event.Initialized window -> + renderWindow window + + let handleWindowCommand (Window.Command.RedrawWindow window) = + renderWindow window + + module Service = + let subscribe (bus : Bus) = + handleWindowEvent |> bus.subscribe + handleWindowCommand |> bus.subscribe \ No newline at end of file diff --git a/src/Void.ViewModel/ViewModel.fs b/src/Void.ViewModel/ViewModel.fs index 24989b1..7e641d2 100644 --- a/src/Void.ViewModel/ViewModel.fs +++ b/src/Void.ViewModel/ViewModel.fs @@ -5,22 +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 - } let defaultViewModel = { @@ -28,44 +19,14 @@ module ViewModel = Title = defaultTitle BackgroundColor = Colors.defaultColorscheme.Background FontSize = defaultFontSize - TabBar = [] - VisibleWindows = [defaultWindowView Sizing.defaultViewArea] - Notifications = [] - } - - 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 = - Buffer.readLines buffer 1 - |> bufferFrom windowSize - - 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 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/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/ViewModelService.fs b/src/Void.ViewModel/ViewModelService.fs index eb20be3..2e11152 100644 --- a/src/Void.ViewModel/ViewModelService.fs +++ b/src/Void.ViewModel/ViewModelService.fs @@ -11,44 +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.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.handleEvent = - function // TODO clearly the code below needs to be refactored - | CoreEvent.BufferAdded (id, 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 - | 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.handleCommand \ No newline at end of file diff --git a/src/Void.ViewModel/ViewModelTypes.fs b/src/Void.ViewModel/ViewModelTypes.fs index 46855ae..7aef37c 100644 --- a/src/Void.ViewModel/ViewModelTypes.fs +++ b/src/Void.ViewModel/ViewModelTypes.fs @@ -12,50 +12,13 @@ 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 -} - -(* "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 -[] -type UserNotificationView = - | Text of string - | Error of string - type MainViewModel = { Size : CellGrid.Dimensions Title : string BackgroundColor : RGBColor 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 5a1be0b..a16bdd7 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 + @@ -45,14 +49,18 @@ + - + + + + diff --git a/src/Void.ViewModel/Window.fs b/src/Void.ViewModel/Window.fs new file mode 100644 index 0000000..b3a97f0 --- /dev/null +++ b/src/Void.ViewModel/Window.fs @@ -0,0 +1,137 @@ +namespace Void.ViewModel + +open Void.Core + +[] +type StatusLineView = // TODO much yet to be done here + | Unfocused + | Focused + +type WindowView = { + StatusLine : StatusLineView + Dimensions : CellGrid.Dimensions + Buffer : string list + Cursor : CursorView Visibility + TopLineNumber : int +} + +module Window = + open Void.Util + open Void.Core.CellGrid + + [] + type Event = + | ContentsUpdated of WindowView + | Initialized of WindowView + interface EventMessage + + [] + type Command = + | RedrawWindow of WindowView + interface CommandMessage + + let private zeroWindowView = + { + StatusLine = StatusLineView.Focused + Buffer = [] + Dimensions = zeroDimensions + Cursor = Visible <| CursorView.Block originCell + TopLineNumber = 1 + } + + let private windowInArea window containingArea = + { zeroWindowView with Dimensions = (lessRowsBelow 1 containingArea).Dimensions } + + 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 + |> SeqUtil.notMoreThan windowSize.Rows + |> Seq.map truncateToWindowWidth + |> Seq.toList + + let private toScreenBuffer windowSize (buffer : FileBufferProxy) = + bufferFrom windowSize buffer.Contents + + 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 + | BufferEvent.Added buffer -> + loadBufferIntoWindow buffer window + + 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 updatedWindow :> Message + | None -> window, noMessage + + let scrollByLineMovement requestSender window movement = + let noScroll = window, noMessage + match movement with + | Move.Backward 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 = + if linesInWindow window > xLines + then xLines + else linesInWindow window - 1 + if scrollAmount > 0 + then scroll requestSender window scrollAmount + 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 -> + scrollByLineMovement requestSender window movement + | VMCommand.ScrollHalf movement -> + scrollHalfScreenHeights requestSender window movement + | _ -> + window, 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) = + let window = ref zeroWindowView + Service.wrap window handleBufferEvent |> bus.subscribe + handleCoreCommand window |> bus.subscribe + Service.wrap window handleVMEvent |> bus.subscribe + Service.wrap window (handleVMCommand bus) |> bus.subscribe diff --git a/src/Void.ViewModel/WindowBufferMap.fs b/src/Void.ViewModel/WindowBufferMap.fs index 19bef48..25862de 100644 --- a/src/Void.ViewModel/WindowBufferMap.fs +++ b/src/Void.ViewModel/WindowBufferMap.fs @@ -46,43 +46,60 @@ 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) - - let handleEvent windowBufferMap event = - match event with - | CoreEvent.BufferAdded (bufferId, buffer) -> - loadBufferIntoCurrentWindow windowBufferMap bufferId + windowBufferMap, noMessage | _ -> - (windowBufferMap, noMessage) + windowBufferMap, noMessage + + let handleBufferEvent windowBufferMap event = + match event.Message with + | BufferEvent.Added _ -> + loadBufferIntoCurrentWindow windowBufferMap event.BufferId + + let getWindowContentsResponse getBufferContentsResponse = + { + FirstLineNumber = getBufferContentsResponse.Message.FirstLineNumber + RequestedContents = getBufferContentsResponse.Message.RequestedContents + } : GetWindowContentsResponse + + let handleGetWindowContentsRequest (requestSender : PackagedRequestSender) windowBufferMap (request : GetWindowContentsRequest) = + requestSender.makePackagedRequest { + BufferId = currentBufferId !windowBufferMap + Message = { StartingAtLine = request.StartingAtLine } + } + |> Option.map getWindowContentsResponse 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 handleEvent + 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 diff --git a/src/Void/DefaultNormalModeBindings.fs b/src/Void/DefaultNormalModeBindings.fs index 9964bdd..4d896f4 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 @@ -43,13 +45,13 @@ 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 | CoreCommand.InitializeVoid -> - bindAllCommands voidBindings - |> bus.publishAll + for message in bindAllCommands voidBindings do + bus.publish message | _ -> () noMessage diff --git a/src/Void/Init.fs b/src/Void/Init.fs index 61fd9a4..4030c66 100644 --- a/src/Void/Init.fs +++ b/src/Void/Init.fs @@ -38,34 +38,18 @@ 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 bus = Messaging.newBus() + bus.subscribe editorService.handleCommand let interpreter = Interpreter.init <| VoidScriptEditorModule(bus.publish).Commands let interpreterWrapperService = InterpreterWrapperService interpreter - let modeService = ModeService(NormalMode.InputHandler(), - CommandMode.InputHandler(), + let modeService = ModeService(NormalModeBindings.InputHandler(), + CommandMode.InputHandler(bus), VisualModeInputHandler(), 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 @@ -75,8 +59,12 @@ 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 + Window.Service.subscribe bus + RenderWindows.Service.subscribe bus + RenderNotificationBar.Service.subscribe bus bus let launchVoid (bus : Bus) = diff --git a/src/Void/InterpreterWrapperService.fs b/src/Void/InterpreterWrapper.fs similarity index 79% rename from src/Void/InterpreterWrapperService.fs rename to src/Void/InterpreterWrapper.fs index dc2229a..434b220 100644 --- a/src/Void/InterpreterWrapperService.fs +++ b/src/Void/InterpreterWrapper.fs @@ -16,9 +16,8 @@ type InterpreterWrapperService(interpreter : VoidScriptInterpreter) = | InterpretScriptFragmentResult.ParseFailed error -> Error.ScriptFragmentParseFailed (ParseErrors.textOf error, request.Fragment) |> InterpretScriptFragmentResponse.ParseFailed - :> ResponseMessage |> 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 deleted file mode 100644 index 92faaaf..0000000 --- a/src/Void/Messaging.fs +++ /dev/null @@ -1,132 +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<'TRequest when 'TRequest :> RequestMessage> - ( - handlers : MaybeHandleRequest<'TRequest> 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 - - 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.getBoxedSubscribeActionIfTypeIs<'TMsg>() = - if typeof<'TRequest> = typeof<'TMsg> - then Some <| box x.addHandler - else None - -type Bus - ( - channels : Channel list - ) = - let mutable _channels = channels - - member private x.addChannel channel = - _channels <- channel :: _channels - - member 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.choose tryGetSubscribeAction _channels with - | [subscribe] -> - handle - |> unbox -> unit> subscribe - | _ -> - 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] -> - handleRequest - |> unbox -> unit> subscribe - | _ -> - x.addChannel <| RequestChannel [ handleRequest ] - - member x.subscribeToRequest<'TRequest when 'TRequest :> RequestMessage> (handleRequest : HandleRequest<'TRequest>) = - 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 diff --git a/src/Void/Void.fsproj b/src/Void/Void.fsproj index 3a7714d..c277d20 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 + @@ -42,8 +46,7 @@ - - + @@ -98,4 +101,4 @@ --> - + \ No newline at end of file