Merge pull request #58 from PolyglotSymposium/feature/ctrl-e-ctrl-y

Implement up/down scrolling (CTRL-E, CTRL-Y, CTRL-U, CTRL-D)

build.fsx

@@ -17,7 +17,7 @@ Target "RestorePackages" (fun _ ->
 )
 
 Target "Compile" (fun _ ->
-   !! "src/**/*.fsproj"
+   !! "src/Void.sln"
    |> MSBuildRelease buildDir "Build"
    |> Log "Compile-Output: "
 )

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)
 
+    [<SetUp>]
+    member x.``Set up``() =
+        requestSenderStub.reset()
+
     [<Test>]
     member x.``Text can be incrementally typed in``() =
         typeIncrement "e" "" "e"
@@ -27,49 +32,47 @@ type ``Editing command mode``() =
         typeIncrement "t" "edi" "edit"
 
     [<Test>]
-    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<InterpretScriptFragmentRequest>()
+        |> should equal (Some { Language = "python3"; Fragment = "edit"})
+
+    [<Test>]
+    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<InterpretScriptFragmentRequest>()
+        |> should equal (Some { Language = "VoidScript"; Fragment = "edit"})
+
+    [<Test>]
+    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)
 
     [<Test>]
-    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)
 
     [<Test>]
-    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)
 
     [<Test>]
     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)
 
     [<Test>]
     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)
 
     [<Test>]
     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)
-
-    [<Test>]
-    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)
-
-    [<Test>]
-    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)
-
-    [<Test>]
-    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)

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
 

src/Void.Core.Spec/Void.Core.Spec.fsproj

@@ -24,6 +24,8 @@
     <DefineConstants>DEBUG;TRACE</DefineConstants>
     <WarningLevel>3</WarningLevel>
     <DocumentationFile>bin\Debug\Void.Core.Spec.XML</DocumentationFile>
+    <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
+    <WarningsAsErrors />
   </PropertyGroup>
   <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
     <DebugType>pdbonly</DebugType>
@@ -33,6 +35,8 @@
     <DefineConstants>TRACE</DefineConstants>
     <WarningLevel>3</WarningLevel>
     <DocumentationFile>bin\Release\Void.Core.Spec.XML</DocumentationFile>
+    <TreatWarningsAsErrors>true</TreatWarningsAsErrors>
+    <WarningsAsErrors />
   </PropertyGroup>
   <PropertyGroup>
     <MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>

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
 
 [<AutoOpen>]
 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
+    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

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<mLine>)/1<mLine>) // Line numbers start at 1
 
 type Buffers = private {
     List : Map<int, FileBuffer>
@@ -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<mLine>
         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<mLine> < 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

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
+}
+
+[<RequireQualifiedAccess>]
+type BufferCommand =
+    | MoveCursor of Motion
+    interface CommandMessage
+    interface BufferMessage
+
+[<RequireQualifiedAccess>]
+type BufferEvent =
+    | Added of FileBufferProxy
+    interface EventMessage
+    interface BufferMessage
+
+type GetBufferContentsRequest =
+    {
+        StartingAtLine : int<mLine>
+    }
+    interface RequestMessage
+    interface BufferMessage
+
+type GetBufferContentsResponse =
+    {
+        FirstLineNumber : int<mLine>
+        RequestedContents : string seq
+    }
+    interface ResponseMessage<GetBufferContentsRequest>
+    interface BufferMessage

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
+

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
+            bus.subscribe <| Service.wrap history handleEvent
+            bus.subscribe <| Service.wrap history handleCommand
+            bus.subscribe <| Service.wrap history handleCoreEvent