feat: adds redo functionality with r (#51)

package.yaml

@@ -40,6 +40,7 @@ library:
   - Data.Taskell.Task
   - Data.Taskell.Task.Internal
   - Events.Actions.Types
+  - Events.State.History
   - Events.State.Types
   - Events.State.Types.Mode
   - IO.Config.Markdown

roadmap.md

@@ -70,7 +70,6 @@
     * [x] Markdown parsing
     * [ ] Text line breaks go a bit funny with multi-line descriptions
 - Check times work no matter what timezone
-- Redo functionality
 - Always show list title
     > Floating list titles - so you can always see what list you're in
 - Make token UX better
@@ -325,3 +324,4 @@
 - Update screenshot
 - Date should update if taskell is left open
 - Use proper error codes
+- Redo functionality

src/Events/Actions/Normal.hs

@@ -23,6 +23,7 @@ events
  =
     [ (A.Quit, quit)
     , (A.Undo, (write =<<) . undo)
+    , (A.Redo, (write =<<) . redo)
     , (A.Search, searchMode)
     , (A.Help, showHelp)
     , (A.Due, showDue)

src/Events/Actions/Types.hs

@@ -8,6 +8,7 @@ import ClassyPrelude hiding (Left, Nothing, Right)
 data ActionType
     = Quit
     | Undo
+    | Redo
     | Search
     | Due
     | Help

src/Events/State.hs

@@ -39,6 +39,7 @@ module Events.State
     , listLeft
     , listRight
     , undo
+    , redo
     , store
     , searchMode
     , clearSearch
@@ -61,7 +62,7 @@ module Events.State
 
 import ClassyPrelude hiding (delete)
 
-import Control.Lens ((&), (.~), (^.))
+import Control.Lens ((%~), (&), (.~), (?~), (^.))
 
 import Data.Char (digitToInt, ord)
 
@@ -71,19 +72,19 @@ import qualified Data.Taskell.Lists as Lists
 import           Data.Taskell.Task  (Task, isBlank, name)
 import           Types
 
-import Events.State.Types
-import Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..), Mode (..))
-import UI.Draw.Field           (Field, blankField, getText, textToField)
+import qualified Events.State.History    as History (redo, store, undo)
+import           Events.State.Types
+import           Events.State.Types.Mode (InsertMode (..), InsertType (..), ModalType (..),
+                                          Mode (..))
+import           UI.Draw.Field           (Field, blankField, getText, textToField)
 
 type InternalStateful = State -> State
 
 create :: UTCTime -> FilePath -> Lists.Lists -> State
 create t p ls =
     State
     { _mode = Normal
-    , _lists = ls
-    , _history = []
-    , _current = (ListIndex 0, TaskIndex 0)
+    , _history = fresh ls
     , _path = p
     , _io = Nothing
     , _height = 0
@@ -98,21 +99,20 @@ quit = pure . (mode .~ Shutdown)
 continue :: State -> State
 continue = io .~ Nothing
 
+store :: Stateful
+store state = pure $ state & history %~ History.store
+
+undo :: Stateful
+undo state = pure $ state & history %~ History.undo
+
+redo :: Stateful
+redo state = pure $ state & history %~ History.redo
+
 setTime :: UTCTime -> State -> State
 setTime t = time .~ t
 
 write :: Stateful
-write state = pure $ state & io .~ Just (state ^. lists)
-
-store :: Stateful
-store state = pure $ state & history .~ (state ^. current, state ^. lists) : state ^. history
-
-undo :: Stateful
-undo state =
-    pure $
-    case state ^. history of
-        []          -> state
-        ((c, l):xs) -> state & current .~ c & lists .~ l & history .~ xs
+write state = pure $ state & (io ?~ (state ^. lists))
 
 -- createList
 createList :: Stateful

src/Events/State/History.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
+
+module Events.State.History
+    ( undo
+    , redo
+    , store
+    ) where
+
+import ClassyPrelude
+
+import Control.Lens (Lens', (&), (.~), (^.))
+
+import Events.State.Types (History, future, past, present)
+
+λstack :: Lens' (History a) [a] -> History a -> [a]
+λstack fn history = history ^. present : (history ^. fn)
+
+store :: History a -> History a
+store history = history & past .~ λstack past history & future .~ empty
+
+undo :: History a -> History a
+undo history =
+    case history ^. past of
+        []          -> history
+        (moment:xs) -> history & present .~ moment & past .~ xs & future .~ λstack future history
+
+redo :: History a -> History a
+redo history =
+    case history ^. future of
+        []          -> history
+        (moment:xs) -> history & present .~ moment & future .~ xs & past .~ λstack past history

src/Events/State/Types.hs

@@ -5,19 +5,29 @@ module Events.State.Types where
 
 import ClassyPrelude
 
-import Control.Lens (makeLenses)
+import Control.Lens             (Lens', makeLenses)
+import Control.Lens.Combinators (_1, _2)
 
 import Data.Taskell.Lists (Lists)
-import Types              (Pointer)
+import Types              (Pointer, startPointer)
 import UI.Draw.Field      (Field)
 
 import qualified Events.State.Types.Mode as M (Mode)
 
+type Moment = (Pointer, Lists)
+
+data History a = History
+    { _past    :: [a]
+    , _present :: a
+    , _future  :: [a]
+    } deriving (Eq, Show)
+
+fresh :: Lists -> History Moment
+fresh ls = History empty (startPointer, ls) empty
+
 data State = State
     { _mode       :: M.Mode
-    , _lists      :: Lists
-    , _history    :: [(Pointer, Lists)]
-    , _current    :: Pointer
+    , _history    :: History Moment
     , _path       :: FilePath
     , _io         :: Maybe Lists
     , _height     :: Int
@@ -28,4 +38,12 @@ data State = State
 -- create lenses
 $(makeLenses ''State)
 
+$(makeLenses ''History)
+
 type Stateful = State -> Maybe State
+
+current :: Lens' State Pointer
+current = history . present . _1
+
+lists :: Lens' State Lists
+lists = history . present . _2

src/IO/Keyboard.hs

@@ -42,6 +42,7 @@ defaultBindings :: Bindings
 defaultBindings =
     [ (BChar 'q', A.Quit)
     , (BChar 'u', A.Undo)
+    , (BChar 'r', A.Redo)
     , (BChar '/', A.Search)
     , (BChar '!', A.Due)
     , (BChar '?', A.Help)

src/Types.hs

@@ -13,3 +13,6 @@ newtype TaskIndex = TaskIndex
     } deriving (Show, Eq, Ord)
 
 type Pointer = (ListIndex, TaskIndex)
+
+startPointer :: Pointer
+startPointer = (ListIndex 0, TaskIndex 0)

src/UI/Draw/Modal/Help.hs

@@ -38,6 +38,7 @@ descriptions =
     , ([A.MoveMenu], "Move task to specific list")
     , ([A.Delete], "Delete task")
     , ([A.Undo], "Undo")
+    , ([A.Redo], "Redo")
     , ([A.ListNew], "New list")
     , ([A.ListEdit], "Edit list title")
     , ([A.ListDelete], "Delete list")

test/Events/State/HistoryTest.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Events.State.HistoryTest
+    ( test_history
+    ) where
+
+import ClassyPrelude
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Events.State.History
+import Events.State.Types
+
+make :: [Integer] -> Integer -> [Integer] -> History Integer
+make = History
+
+testHistory :: History Integer
+testHistory = make empty 0 empty
+
+-- tests
+test_history :: TestTree
+test_history =
+    testGroup
+        "Events.State.History"
+        [ testGroup
+              "undo"
+              [ testCase "empty" (assertEqual "Nothing changes" testHistory (undo testHistory))
+              , testCase
+                    "one undo"
+                    (assertEqual "Goes back" (make empty 0 [1]) (undo $ make [0] 1 empty))
+              , testCase
+                    "two undo"
+                    (assertEqual
+                         "Goes back"
+                         (make empty 0 [1, 2])
+                         (undo . undo $ make [1, 0] 2 empty))
+              , testCase
+                    "three undo"
+                    (assertEqual
+                         "Goes back"
+                         (make empty 0 [1, 2, 3])
+                         (undo . undo . undo $ make [2, 1, 0] 3 empty))
+              ]
+        , testGroup
+              "redo"
+              [ testCase "empty" (assertEqual "Nothing changes" testHistory (redo testHistory))
+              , testCase
+                    "one redo"
+                    (assertEqual "Goes forward" (make [0] 1 empty) (redo $ make empty 0 [1]))
+              , testCase
+                    "two redo"
+                    (assertEqual
+                         "Goes forward"
+                         (make [1, 0] 2 empty)
+                         (redo . redo $ make empty 0 [1, 2]))
+              , testCase
+                    "three redo"
+                    (assertEqual
+                         "Goes forward"
+                         (make [2, 1, 0] 3 empty)
+                         (redo . redo . redo $ make empty 0 [1, 2, 3]))
+              ]
+        , testGroup
+              "mix"
+              [ testCase
+                    "empty"
+                    (assertEqual
+                         "Nothing changes"
+                         testHistory
+                         (undo . redo . undo . redo . undo $ testHistory))
+              , testCase
+                    "redo undo"
+                    (assertEqual
+                         "Nothing changes"
+                         (make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])
+                         (undo . redo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10]))
+              , testCase
+                    "undo redo"
+                    (assertEqual
+                         "Nothing changes"
+                         (make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10])
+                         (redo . undo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10]))
+              ]
+        , testGroup
+              "store"
+              [ testCase
+                    "empty"
+                    (assertEqual "Stores current value" (make [0] 0 empty) (store testHistory))
+              , testCase
+                    "undo store redo"
+                    (assertEqual
+                         "Clears redo"
+                         (make [4, 3, 2, 1, 0] 4 empty)
+                         (redo . store . undo $ make [4, 3, 2, 1, 0] 5 [6, 7, 8, 9, 10]))
+              ]
+        ]

test/Events/StateTest.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 
 module Events.StateTest
     ( test_state
@@ -20,7 +21,7 @@ import qualified Data.Taskell.Task       as T (new)
 import           Events.State
 import           Events.State.Types
 import           Events.State.Types.Mode
-import           Types                   (ListIndex (..), TaskIndex (..))
+import           Types                   (ListIndex (ListIndex), TaskIndex (TaskIndex))
 
 mockTime :: UTCTime
 mockTime = UTCTime (ModifiedJulianDay 20) (secondsToDiffTime 0)
@@ -29,9 +30,7 @@ testState :: State
 testState =
     State
     { _mode = Normal
-    , _lists = empty
-    , _history = []
-    , _current = (ListIndex 0, TaskIndex 0)
+    , _history = fresh empty
     , _path = "test.md"
     , _io = Nothing
     , _height = 0
@@ -43,20 +42,23 @@ moveToState :: State
 moveToState =
     State
     { _mode = Modal MoveTo
-    , _lists =
-          fromList
-              [ L.empty "List 1"
-              , L.empty "List 2"
-              , L.empty "List 3"
-              , L.empty "List 4"
-              , L.append (T.new "Test Item") (L.empty "List 5")
-              , L.empty "List 6"
-              , L.empty "List 7"
-              , L.empty "List 8"
-              , L.empty "List 9"
-              ]
-    , _history = []
-    , _current = (ListIndex 4, TaskIndex 0)
+    , _history =
+          History
+          { _past = empty
+          , _present =
+                ( (ListIndex 4, TaskIndex 0)
+                , [ L.empty "List 1"
+                  , L.empty "List 2"
+                  , L.empty "List 3"
+                  , L.empty "List 4"
+                  , L.append (T.new "Test Item") (L.empty "List 5")
+                  , L.empty "List 6"
+                  , L.empty "List 7"
+                  , L.empty "List 8"
+                  , L.empty "List 9"
+                  ])
+          , _future = empty
+          }
     , _path = "test.md"
     , _io = Nothing
     , _height = 0

test/IO/Keyboard/TypesTest.hs

@@ -21,6 +21,7 @@ notFullResult :: Bindings
 notFullResult =
     [ (BChar 'œ', A.Quit)
     , (BChar 'U', A.Undo)
+    , (BChar 'r', A.Redo)
     , (BChar '/', A.Search)
     , (BChar '!', A.Due)
     , (BChar '?', A.Help)